CA: Inject focus into to result webUIRequestUrls
if appropriate to improve the immediate visibility of the actual
collocations.
Change-Id: I728e61701bf4fc620b40077da54a11506e6e941c
diff --git a/R/collocationAnalysis.R b/R/collocationAnalysis.R
index 8435c6c..ab8d2f8f 100644
--- a/R/collocationAnalysis.R
+++ b/R/collocationAnalysis.R
@@ -313,6 +313,44 @@
)
}
+ if (!is.null(withinSpan) && !is.na(withinSpan) && nzchar(withinSpan) &&
+ nrow(result) > 0 &&
+ "webUIRequestUrl" %in% names(result) &&
+ "query" %in% names(result)) {
+ candidate_rows <- which(!is.na(result$node) &
+ !grepl("focus\\(", result$node, perl = TRUE) &
+ !is.na(result$query) & nzchar(result$query))
+
+ if (length(candidate_rows) > 0) {
+ focused_queries <- vapply(
+ result$query[candidate_rows],
+ inject_focus_into_query,
+ character(1)
+ )
+
+ changed <- focused_queries != result$query[candidate_rows]
+ if (any(changed)) {
+ indices <- candidate_rows[changed]
+ vc_values <- as.character(result$vc)
+ vc_values[is.na(vc_values)] <- ""
+
+ result$webUIRequestUrl[indices] <- mapply(
+ function(new_query, vc_value) {
+ buildWebUIRequestUrlFromString(
+ kco@KorAPUrl,
+ new_query,
+ vc = vc_value,
+ ql = "poliqarp"
+ )
+ },
+ focused_queries[changed],
+ vc_values[indices],
+ USE.NAMES = FALSE
+ )
+ }
+ }
+ }
+
result
}
)
@@ -430,6 +468,47 @@
result
}
+inject_focus_into_query <- function(query) {
+ if (is.null(query) || is.na(query)) {
+ return(query)
+ }
+
+ trimmed <- trimws(query)
+ if (!nzchar(trimmed)) {
+ return(query)
+ }
+
+ if (!grepl("^contains\\(<[^>]+>", trimmed, perl = TRUE)) {
+ return(query)
+ }
+
+ if (grepl("focus\\(", trimmed, perl = TRUE)) {
+ return(query)
+ }
+
+ pattern <- "^contains\\(<([^>]+)>\\s*,\\s*\\((.*)\\)\\)\\s*$"
+ matches <- regexec(pattern, trimmed, perl = TRUE)
+ components <- regmatches(trimmed, matches)
+ if (length(components) == 0 || length(components[[1]]) < 3) {
+ return(query)
+ }
+
+ span <- components[[1]][2]
+ inner <- components[[1]][3]
+ parts <- strsplit(inner, "\\|", perl = TRUE)[[1]]
+ parts <- trimws(parts)
+ parts <- parts[nzchar(parts)]
+
+ if (length(parts) == 0) {
+ return(query)
+ }
+
+ focused <- paste0("focus({", parts, "})")
+ combined <- paste(focused, collapse = " | ")
+
+ sprintf("contains(<%s>, (%s))", span, combined)
+}
+
add_multi_vc_comparisons <- function(result, missingScoreQuantile = 0.05) {
label <- node <- collocate <- NULL
diff --git a/tests/testthat/test-collocations.R b/tests/testthat/test-collocations.R
index 7ab1b22..14508f6 100644
--- a/tests/testthat/test-collocations.R
+++ b/tests/testthat/test-collocations.R
@@ -408,6 +408,24 @@
expect_true(is.data.frame(result))
})
+test_that("inject_focus_into_query adds focus wrappers when span queries lack them", {
+ unfocused <- "contains(<base/s=s>, (Anspruch [tt/l=nehmen] | [tt/l=nehmen] Anspruch))"
+ focused <- RKorAPClient:::inject_focus_into_query(unfocused)
+
+ expect_equal(
+ focused,
+ "contains(<base/s=s>, (focus({Anspruch [tt/l=nehmen]}) | focus({[tt/l=nehmen] Anspruch})))"
+ )
+})
+
+test_that("inject_focus_into_query leaves existing focus segments unchanged", {
+ already_focused <- "contains(<base/s=s>, (focus({Anspruch [tt/l=nehmen]})))"
+ expect_identical(
+ RKorAPClient:::inject_focus_into_query(already_focused),
+ already_focused
+ )
+})
+
# Removed hanging findExample tests as they cause infinite wait
# These tests make API calls that don't complete properly