Parse KWIC snippets of any shape in collocation analysis
Affects only servers that do not deliver tokenized matches, where the
analysis falls back to parsing KWIC markup. Against a current KorAP
matches2FreqTable() is used instead.
The reported crash comes from findExample(), not from the regular
expression: after a failed request collectedMatches has no snippet
column, so the example was character(0) and assigning it aborted.
The expression was wrong as well, in three ways: it required the match
to be followed directly by the closing span, which a <span
class="cutted"> breaks, it required a non-empty left context, and it did
not expect a <span class="more"> in the right context. Counts stayed
correct - a guard skipped those snippets - but about 15 in every 100
hits of the query from the report were dropped silently. The two context
spans are now read one by one and stripped of whatever markup they
contain.
Also fixes both frequency table functions for their own default of an
empty stopword list, which used to leave the table without the column
the stopwords are joined on.
Resolves #14
Change-Id: I1cec847480ddb44fbf688042661019b9c5702a24
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
diff --git a/R/collocationAnalysis.R b/R/collocationAnalysis.R
index c54b46d..d3ea450 100644
--- a/R/collocationAnalysis.R
+++ b/R/collocationAnalysis.R
@@ -1458,7 +1458,9 @@
summarise(frequency = sum(frequency), .groups = "drop") |>
arrange(desc(frequency))
} else {
- stopwordsTable <- dplyr::tibble(word = stopwords)
+ # as.character keeps the column when stopwords is empty: tibble(word = c())
+ # would drop it altogether and the anti_join below would not find it
+ stopwordsTable <- dplyr::tibble(word = as.character(stopwords))
left <- tail(unlist(matches$tokens$left[index]), leftContextSize)
@@ -1481,6 +1483,25 @@
}
}
+#' Text content of a KWIC snippet span
+#'
+#' Returns the text inside the span captured by `pattern`, with any nested
+#' markup removed, or `NA` if the snippet does not contain that span at all.
+#' The capture is greedy on purpose: the context spans contain further spans,
+#' such as `<span class="more">`, whose closing tag a lazy match would stop at.
+#'
+#' @param snippet KWIC snippet
+#' @param pattern regular expression whose first group captures the span content
+#' @return text content of the span, or `NA`
+#' @noRd
+htmlSpanContent <- function(snippet, pattern) {
+ content <- str_match(snippet, pattern)[1, 2]
+ if (is.na(content)) {
+ return(NA_character_)
+ }
+ stringr::str_trim(stringr::str_replace_all(content, "<[^>]*>", " "))
+}
+
#' @importFrom magrittr debug_pipe
#' @importFrom stringr str_match str_split str_detect
#' @importFrom dplyr as_tibble tibble rename filter anti_join tibble bind_rows case_when
@@ -1519,26 +1540,31 @@
summarise(frequency = sum(frequency), .groups = "drop") |>
arrange(desc(frequency))
} else {
- stopwordsTable <- dplyr::tibble(word = stopwords)
- match <-
- str_match(
- snippet,
- '<span class="context-left">(<span class="more"></span>)?(.*[^ ]) *</span><span class="match"><mark>.*</mark></span><span class="context-right"> *([^<]*)'
- )
+ # as.character keeps the column when stopwords is empty: tibble(word = c())
+ # would drop it altogether and the anti_join below would not find it
+ stopwordsTable <- dplyr::tibble(word = as.character(stopwords))
+
+ # The two context spans are taken one by one, up to the element that follows
+ # them, and stripped of whatever markup they contain. Matching the snippet
+ # as a whole used to require one particular shape and silently dropped every
+ # snippet of any other, which cost about 15% of the hits of a
+ # contains(<base/s=s>, ...) query: those are cut at the sentence boundary and
+ # carry a <span class="cutted"> inside the match, and a match filling the
+ # whole sentence leaves an empty context span (see issue #14).
+ leftContext <- htmlSpanContent(snippet, '<span class="context-left">(.*)</span><span class="match">')
+ rightContext <- htmlSpanContent(snippet, '<span class="context-right">(.*)</span>')
left <- if (leftContextSize > 0) {
- tail(unlist(str_split(match[1, 3], tokenizeRegex)), leftContextSize)
+ tail(unlist(str_split(leftContext, tokenizeRegex)), leftContextSize)
} else {
""
}
- # cat(paste("left:", left, "\n", collapse=" "))
right <- if (rightContextSize > 0) {
- head(unlist(str_split(match[1, 4], tokenizeRegex)), rightContextSize)
+ head(unlist(str_split(rightContext, tokenizeRegex)), rightContextSize)
} else {
""
}
- # cat(paste("right:", right, "\n", collapse=" "))
if (is.na(left[1]) || is.na(right[1]) || length(left) + length(right) == 0) {
oldTable
@@ -1639,8 +1665,13 @@
q <- corpusQuery(kco, paste0("(", query[i], ")"), vc = vc[i], metadataOnly = FALSE)
if (q@totalResults > 0) {
q <- fetchNext(q, maxFetch = 50, randomizePageOrder = F)
+ # A failed request leaves collectedMatches without a snippet column at
+ # all, so that the example is character(0) rather than NA and assigning
+ # it fails with "replacement has length zero" (see issue #14).
example <- as.character((q@collectedMatches)$snippet[1])
- out[i] <- if (matchOnly) {
+ out[i] <- if (length(example) != 1 || is.na(example)) {
+ ""
+ } else if (matchOnly) {
gsub(".*<mark>(.+)</mark>.*", "\\1", example)
} else {
stringr::str_replace(example, "<[^>]*>", "")