R/collocationAnalysis.R

#' @include logging.R
setGeneric("collocationAnalysis", function(kco, ...) standardGeneric("collocationAnalysis"))

#' Collocation analysis
#'
#' @family collocation analysis functions
#' @aliases collocationAnalysis
#'
#' @description
#'
#' Performs a collocation analysis for the given node (or query)
#' in the given virtual corpus.
#'
#' @details
#' The collocation analysis is currently implemented on the client side, as some of the
#' functionality is not yet provided by the KorAP backend. Mainly for this reason
#' it is very slow (several minutes, up to hours), but on the other hand very flexible.
#' You can, for example, perform the analysis in arbitrary virtual corpora, use complex node queries,
#' and look for expression-internal collocates using the focus function (see examples and demo).
#'
#' To increase speed at the cost of accuracy and possible false negatives,
#' you can decrease searchHitsSampleLimit and/or topCollocatesLimit and/or set exactFrequencies to FALSE.
#'
#' Note that some outdated non-DeReKo back-ends might not yet support returning tokenized matches (warning issued).
#' In this case, the client library will fall back to client-side tokenization which might be slightly less accurate.
#' This might lead to false negatives and to frequencies that differ from corresponding ones acquired via the web
#' user interface.
#'
#'
#' @param lemmatizeNodeQuery     if TRUE, node query will be lemmatized, i.e. `x -> [tt/l=x]`
#' @param minOccur               minimum absolute number of observed co-occurrences to consider a collocate candidate
#' @param topCollocatesLimit     limit analysis to the n most frequent collocates in the search hits sample
#' @param searchHitsSampleLimit  limit the size of the search hits sample
#' @param stopwords              vector of stopwords not to be considered as collocates
#' @param withinSpan             KorAP span specification (see <https://korap.ids-mannheim.de/doc/ql/poliqarp-plus?embedded=true#spans>) for collocations to be searched within. Defaults to `base/s=s`.
#' @param exactFrequencies       if FALSE, extrapolate observed co-occurrence frequencies from frequencies in search hits sample, otherwise retrieve exact co-occurrence frequencies
#' @param seed                   seed for random page collecting order
#' @param expand                 if TRUE, `node` and `vc` parameters are expanded to all of their combinations
#' @param maxRecurse             apply collocation analysis recursively `maxRecurse` times
#' @param addExamples            If TRUE, examples for instances of collocations will be added in a column `example`. This makes a difference in particular if `node` is given as a lemma query.
#' @param thresholdScore         association score function (see \code{\link{association-score-functions}}) to use for computing the threshold that is applied for recursive collocation analysis calls
#' @param threshold              minimum value of `thresholdScore` function call to apply collocation analysis recursively
#' @param localStopwords         vector of stopwords that will not be considered as collocates in the current function call, but that will not be passed to recursive calls
#' @param collocateFilterRegex   allow only collocates matching the regular expression
#' @param queryMissingScores     if TRUE, attempt to retrieve corpus-based association scores for vc/collocate combinations that would otherwise be imputed, by re-querying the KorAP backend without applying the collocate frequency threshold
#' @param missingScoreQuantile   lower quantile (evaluated per association measure) that anchors the adaptive floor used for imputing missing scores between virtual corpora; a robust spread is subtracted from this anchor so the imputed values stay below the weakest observed scores
#' @param vcLabel optional label override for the current virtual corpus (used internally when named VC collections are expanded)
#' @param ...                    more arguments will be passed to [collocationScoreQuery()]
#' @inheritParams collocationScoreQuery,KorAPConnection-method
#' @return
#' A tibble where each row represents a candidate collocate for the requested node.
#' Columns include (depending on the selected association measures):
#' 
#' \itemize{
#'   \item \code{node}, \code{collocate}, \code{vc}, \code{label}: identifiers for the query node, collocate, virtual corpus, and optional label.
#'   \item Frequency and contingency information such as \code{frequency}, \code{O}, \code{O1}, \code{O2}, \code{E}, \code{leftContextSize}, \code{rightContextSize}, and \code{w}.
#'   \item Association measures (e.g. \code{logDice}, \code{ll}, \code{mi}, ...), one column per requested scorer.
#'   \item Per-labelled association scores produced by multi-VC comparisons using the pattern \code{<measure>_<label>}.
#'   \item Ranks per label/measure with the pattern \code{rank_<label>_<measure>} (1 is best) and the corresponding percentile ranks \code{percentile_rank_<label>_<measure>}.
#'   \item Pairwise contrasts for two-label comparisons, e.g. \code{delta_<measure>}, \code{delta_rank_<measure>}, and \code{delta_percentile_rank_<measure>}.
#'   \item Summary columns describing the strongest labels per measure (\code{winner_*}, \code{runner_up_*}, \code{loser_*}, and \code{max_delta_*}).
#'   \item Optional helper columns such as \code{query}, \code{example}, or \code{url} when example retrieval is requested.
#' }
#' @importFrom dplyr arrange desc slice_head bind_rows group_by mutate ungroup left_join select row_number all_of first
#' @importFrom purrr pmap
#' @importFrom tidyr expand_grid pivot_wider
#' @importFrom rlang sym
#'
#' @examples
#' \dontrun{
#'
#' # Find top collocates of "Packung" inside and outside the sports domain.
#' KorAPConnection(verbose = TRUE) |>
#'   collocationAnalysis("Packung",
#'     vc = c("textClass=sport", "textClass!=sport"),
#'     leftContextSize = 1, rightContextSize = 1, topCollocatesLimit = 20
#'   ) |>
#'   dplyr::filter(logDice >= 5)
#' }
#'
#' \dontrun{
#'
#' # Identify the most prominent light verb construction with "in ... setzen".
#' # Note that, currently, the use of focus function disallows exactFrequencies.
#' KorAPConnection(verbose = TRUE) |>
#'   collocationAnalysis("focus(in [tt/p=NN] {[tt/l=setzen]})",
#'     leftContextSize = 1, rightContextSize = 0, exactFrequencies = FALSE, topCollocatesLimit = 20
#'   )
#' }
#'
#' @export
setMethod(
  "collocationAnalysis", "KorAPConnection",
  function(kco,
           node,
           vc = "",
           lemmatizeNodeQuery = FALSE,
           minOccur = 5,
           leftContextSize = 5,
           rightContextSize = 5,
           topCollocatesLimit = 200,
           searchHitsSampleLimit = 20000,
           ignoreCollocateCase = FALSE,
           withinSpan = ifelse(exactFrequencies, "base/s=s", ""),
           exactFrequencies = TRUE,
           stopwords = append(RKorAPClient::synsemanticStopwords(), node),
           seed = 7,
           expand = length(vc) != length(node),
           maxRecurse = 0,
           addExamples = FALSE,
           thresholdScore = "logDice",
           threshold = 2.0,
           localStopwords = c(),
           collocateFilterRegex = "^[:alnum:]+-?[:alnum:]*$",
           queryMissingScores = FALSE,
           missingScoreQuantile = 0.05,
           vcLabel = NA_character_,
           ...) {
    word <- frequency <- O <- NULL

    if (!exactFrequencies && (!is.na(withinSpan) && !is.null(withinSpan) && nzchar(withinSpan))) {
      stop(sprintf("Not empty withinSpan (='%s') requires exactFrequencies=TRUE", withinSpan), call. = FALSE)
    }

    warnIfNotAuthorized(kco)

    if (lemmatizeNodeQuery) {
      node <- lemmatizeWordQuery(node)
    }

    vcNames <- names(vc)
    if (is.null(vcNames)) {
      vcNames <- rep(NA_character_, length(vc))
    }

    label_lookup <- NULL
    if (!is.null(names(vc)) && length(vc) > 0) {
      raw_names <- names(vc)
      if (any(!is.na(raw_names) & raw_names != "")) {
        label_lookup <- stats::setNames(raw_names, vc)
      }
    }

    result <- if (length(node) > 1 || length(vc) > 1) {
      grid <- if (expand) {
        tmp_grid <- tidyr::expand_grid(node = node, idx = seq_along(vc))
        tmp_grid$vc <- vc[tmp_grid$idx]
        tmp_grid$vcLabel <- vcNames[tmp_grid$idx]
        tmp_grid[, c("node", "vc", "vcLabel"), drop = FALSE]
      } else {
        tibble(node = node, vc = vc, vcLabel = vcNames)
      }

      multi_result <- purrr::pmap(grid, function(node, vc, vcLabel, ...) {
        collocationAnalysis(kco,
          node = node,
          vc = vc,
          minOccur = minOccur,
          leftContextSize = leftContextSize,
          rightContextSize = rightContextSize,
          topCollocatesLimit = topCollocatesLimit,
          searchHitsSampleLimit = searchHitsSampleLimit,
          ignoreCollocateCase = ignoreCollocateCase,
          withinSpan = withinSpan,
          exactFrequencies = exactFrequencies,
          stopwords = stopwords,
          addExamples = TRUE,
          localStopwords = localStopwords,
          seed = seed,
          expand = expand,
          missingScoreQuantile = missingScoreQuantile,
          queryMissingScores = queryMissingScores,
          collocateFilterRegex = collocateFilterRegex,
          vcLabel = vcLabel,
          ...
        )
      }) |>
        bind_rows()

      if (!"vc" %in% names(multi_result) || nrow(multi_result) == 0) {
        multi_result
      } else {
        if (queryMissingScores) {
          multi_result <- backfill_missing_scores(
            multi_result,
            grid = grid,
            kco = kco,
            ignoreCollocateCase = ignoreCollocateCase,
            ...
          )
        }

        if (!"label" %in% names(multi_result)) {
          multi_result$label <- NA_character_
        }

        if (!is.null(label_lookup)) {
          override <- unname(label_lookup[multi_result$vc])
          missing_idx <- is.na(multi_result$label) | multi_result$label == ""
          if (any(missing_idx)) {
            multi_result$label[missing_idx] <- override[missing_idx]
          }
        }

        missing_idx <- is.na(multi_result$label) | multi_result$label == ""
        if (any(missing_idx)) {
          multi_result$label[missing_idx] <- queryStringToLabel(multi_result$vc[missing_idx])
        }

        multi_result |>
          add_multi_vc_comparisons(
            missingScoreQuantile = missingScoreQuantile
          )
      }
    } else {
      if ((is.na(vcLabel) || vcLabel == "") && length(vcNames) >= 1) {
        vcLabel <- vcNames[1]
      }

      set.seed(seed)
      candidates <- collocatesQuery(
        kco,
        node,
        vc = vc,
        minOccur = minOccur,
        leftContextSize = leftContextSize,
        rightContextSize = rightContextSize,
        searchHitsSampleLimit = searchHitsSampleLimit,
        ignoreCollocateCase = ignoreCollocateCase,
        stopwords = append(stopwords, localStopwords),
        collocateFilterRegex = collocateFilterRegex,
        ...
      )

      if (nrow(candidates) > 0) {
        candidates <- candidates |>
          filter(frequency >= minOccur) |>
          slice_head(n = topCollocatesLimit)
        collocationScoreQuery(
          kco,
          node = node,
          collocate = candidates$word,
          vc = vc,
          leftContextSize = leftContextSize,
          rightContextSize = rightContextSize,
          observed = if (exactFrequencies) NA else candidates$frequency,
          ignoreCollocateCase = ignoreCollocateCase,
          withinSpan = withinSpan,
          ...
        ) |>
          filter(O >= minOccur) |>
          dplyr::arrange(dplyr::desc(logDice))
      } else {
        tibble()
      }
    }

    if (!is.na(vcLabel) && vcLabel != "" && "label" %in% names(result)) {
      result$label <- rep(vcLabel, nrow(result))
    }

    threshold_col <- thresholdScore
    if (maxRecurse > 0 && nrow(result) > 0 && threshold_col %in% names(result)) {
      threshold_values <- result[[threshold_col]]
      eligible_idx <- which(!is.na(threshold_values) & threshold_values >= threshold)
      if (length(eligible_idx) > 0) {
        recurseWith <- result[eligible_idx, , drop = FALSE]
        result <- collocationAnalysis(
          kco,
          node = paste0("(", buildCollocationQuery(
            removeWithinSpan(recurseWith$node, withinSpan),
            recurseWith$collocate,
            leftContextSize = leftContextSize,
            rightContextSize = rightContextSize,
            withinSpan = ""
          ), ")"),
          vc = vc,
          minOccur = minOccur,
          leftContextSize = leftContextSize,
          rightContextSize = rightContextSize,
          withinSpan = withinSpan,
          maxRecurse = maxRecurse - 1,
          stopwords = stopwords,
          localStopwords = recurseWith$collocate,
          exactFrequencies = exactFrequencies,
          searchHitsSampleLimit = searchHitsSampleLimit,
          topCollocatesLimit = topCollocatesLimit,
          addExamples = FALSE,
          missingScoreQuantile = missingScoreQuantile,
          collocateFilterRegex = collocateFilterRegex,
          queryMissingScores = queryMissingScores,
          vcLabel = vcLabel
        ) |>
          bind_rows(result) |>
          filter(logDice >= 2) |>
          filter(O >= minOccur) |>
          dplyr::arrange(dplyr::desc(logDice))
      }
    }

    if (addExamples && nrow(result) > 0) {
      result$query <- buildCollocationQuery(
        result$node,
        result$collocate,
        leftContextSize = leftContextSize,
        rightContextSize = rightContextSize,
        withinSpan = withinSpan
      )
      result$example <- findExample(
        kco,
        query = result$query,
        vc = result$vc
      )
    }

    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
  }
)

# #' @export
removeWithinSpan <- function(query, withinSpan) {
  if (withinSpan == "") {
    return(query)
  }
  needle <- sprintf("^\\(contains\\(<%s>, ?(.*)\\){2}$", withinSpan)
  res <- gsub(needle, "\\1", query)
  needle <- sprintf("^contains\\(<%s>, ?(.*)\\)$", withinSpan)
  res <- gsub(needle, "\\1", res)
  return(res)
}

backfill_missing_scores <- function(result,
                                    grid,
                                    kco,
                                    ignoreCollocateCase,
                                    ...) {
  if (!"vc" %in% names(result) || !"node" %in% names(result) || !"collocate" %in% names(result)) {
    return(result)
  }

  if (nrow(result) == 0) {
    return(result)
  }

  distinct_pairs <- dplyr::distinct(result, node, collocate)
  if (nrow(distinct_pairs) == 0) {
    return(result)
  }

  collocates_by_node <- split(as.character(distinct_pairs$collocate), distinct_pairs$node)
  if (length(collocates_by_node) == 0) {
    return(result)
  }

  required_combinations <- unique(as.data.frame(grid[, c("node", "vc", "vcLabel")], drop = FALSE))
  for (i in seq_len(nrow(required_combinations))) {
    node_value <- required_combinations$node[i]
    vc_value <- required_combinations$vc[i]

    collocate_pool <- collocates_by_node[[node_value]]
    if (is.null(collocate_pool) || length(collocate_pool) == 0) {
      next
    }

    existing_idx <- result$node == node_value & result$vc == vc_value
    existing_collocates <- unique(as.character(result$collocate[existing_idx]))
    missing_collocates <- setdiff(unique(collocate_pool), existing_collocates)
    missing_collocates <- missing_collocates[!is.na(missing_collocates) & nzchar(missing_collocates)]

    if (length(missing_collocates) == 0) {
      next
    }

    context_rows <- result[result$node == node_value & result$vc == vc_value, , drop = FALSE]
    if (nrow(context_rows) == 0) {
      context_rows <- result[result$node == node_value, , drop = FALSE]
    }

    left_size <- context_rows$leftContextSize[!is.na(context_rows$leftContextSize)][1]
    if (is.na(left_size) || length(left_size) == 0) {
      left_size <- result$leftContextSize[!is.na(result$leftContextSize)][1]
    }
    if (is.na(left_size) || length(left_size) == 0) {
      left_size <- 5
    }

    right_size <- context_rows$rightContextSize[!is.na(context_rows$rightContextSize)][1]
    if (is.na(right_size) || length(right_size) == 0) {
      right_size <- result$rightContextSize[!is.na(result$rightContextSize)][1]
    }
    if (is.na(right_size) || length(right_size) == 0) {
      right_size <- 5
    }

    within_span_value <- ""
    if ("query" %in% names(context_rows)) {
      query_candidate <- context_rows$query[!is.na(context_rows$query) & nzchar(context_rows$query)][1]
      if (!is.na(query_candidate) && nzchar(query_candidate)) {
        match_one <- regexec("^\\(*contains\\(<([^>]+)>,", query_candidate)
        matches <- regmatches(query_candidate, match_one)
        if (length(matches) >= 1 && length(matches[[1]]) >= 2) {
          within_span_value <- matches[[1]][2]
        }
      }
    }

    new_rows <- collocationScoreQuery(
      kco,
      node = node_value,
      collocate = missing_collocates,
      vc = vc_value,
      leftContextSize = left_size,
      rightContextSize = right_size,
      ignoreCollocateCase = ignoreCollocateCase,
      withinSpan = within_span_value,
      ...
    )

    if (nrow(new_rows) == 0) {
      next
    }

    if (!is.null(required_combinations$vcLabel[i]) && !is.na(required_combinations$vcLabel[i]) && required_combinations$vcLabel[i] != "" && "label" %in% names(new_rows)) {
      new_rows$label <- required_combinations$vcLabel[i]
    }

    result <- dplyr::bind_rows(result, new_rows)
  }

  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

  if (!"label" %in% names(result) || dplyr::n_distinct(result$label) < 2) {
    return(result)
  }

  numeric_cols <- names(result)[vapply(result, is.numeric, logical(1))]
  non_score_cols <- c("N", "O", "O1", "O2", "E", "w", "leftContextSize", "rightContextSize", "frequency")
  score_cols <- setdiff(numeric_cols, non_score_cols)

  if (length(score_cols) == 0) {
    return(result)
  }

  compute_score_floor <- function(values) {
    # Estimate a conservative floor so missing scores can be imputed without favoring any label
    finite_values <- values[is.finite(values)]
    if (length(finite_values) == 0) {
      return(0)
    }

    prob <- min(max(missingScoreQuantile, 0), 0.5)
    # Use a lower quantile as the anchor to stay near the weakest attested scores
    q_val <- suppressWarnings(stats::quantile(finite_values,
      probs = prob,
      names = FALSE,
      type = 7
    ))

    if (!is.finite(q_val)) {
      q_val <- suppressWarnings(min(finite_values, na.rm = TRUE))
    }

    min_val <- suppressWarnings(min(finite_values, na.rm = TRUE))
    if (!is.finite(min_val)) {
      min_val <- 0
    }

    spread_candidates <- c(
      suppressWarnings(stats::IQR(finite_values, na.rm = TRUE, type = 7)),
      stats::sd(finite_values, na.rm = TRUE),
      abs(q_val) * 0.1,
      abs(min_val - q_val)
    )
    spread_candidates <- spread_candidates[is.finite(spread_candidates)]

    spread <- 0
    if (length(spread_candidates) > 0) {
      spread <- max(spread_candidates)
    }
    if (!is.finite(spread) || spread == 0) {
      spread <- max(abs(q_val), abs(min_val), 1e-06)
    }

    # Step away from the anchor by a robust spread estimate to avoid ties with real scores
    candidate <- q_val - spread
    if (!is.finite(candidate)) {
      candidate <- min_val
    }

    floor_value <- suppressWarnings(min(c(candidate, min_val), na.rm = TRUE))
    if (!is.finite(floor_value)) {
      floor_value <- min_val
    }
    if (!is.finite(floor_value)) {
      floor_value <- 0
    }

    floor_value
  }

  score_replacements <- stats::setNames(
    vapply(score_cols, function(col) {
      compute_score_floor(result[[col]])
    }, numeric(1)),
    score_cols
  )

  comparison <- result |>
    dplyr::select(node, collocate, label, dplyr::all_of(score_cols)) |>
    tidyr::pivot_wider(
      names_from = label,
      values_from = dplyr::all_of(score_cols),
      names_glue = "{.value}_{make.names(label)}",
      values_fn = dplyr::first
    )

  raw_labels <- unique(result$label)
  labels <- make.names(raw_labels)
  label_map <- stats::setNames(raw_labels, labels)

  rank_data <- result |>
    dplyr::distinct(node, collocate)

  for (i in seq_along(raw_labels)) {
    raw_lab <- raw_labels[i]
    safe_lab <- labels[i]
    label_df <- result[result$label == raw_lab, c("node", "collocate", score_cols), drop = FALSE]
    if (nrow(label_df) == 0) {
      next
    }
    label_df <- dplyr::distinct(label_df)
    rank_tbl <- label_df[, c("node", "collocate"), drop = FALSE]
    for (col in score_cols) {
      rank_col_name <- paste0("rank_", safe_lab, "_", col)
      percentile_col_name <- paste0("percentile_rank_", safe_lab, "_", col)
      values <- label_df[[col]]
      ranks <- rep(NA_real_, length(values))
      percentiles <- rep(NA_real_, length(values))
      valid_idx <- which(!is.na(values))
      if (length(valid_idx) > 0) {
        ranks[valid_idx] <- rank(-values[valid_idx], ties.method = "first")
        total <- length(valid_idx)
        percentiles[valid_idx] <- 1 - (ranks[valid_idx] - 1) / total
      }
      rank_tbl[[rank_col_name]] <- ranks
      rank_tbl[[percentile_col_name]] <- percentiles
    }
    rank_data <- dplyr::left_join(rank_data, rank_tbl, by = c("node", "collocate"))
  }

  comparison <- dplyr::left_join(comparison, rank_data, by = c("node", "collocate"))

  rank_replacements <- numeric(0)
  rank_column_names <- grep("^rank_", names(comparison), value = TRUE)
  if (length(rank_column_names) > 0) {
    rank_replacements <- stats::setNames(
      vapply(rank_column_names, function(col) {
        col_values <- comparison[[col]]
        valid_values <- col_values[!is.na(col_values)]
        if (length(valid_values) == 0) {
          nrow(comparison) + 1
        } else {
          suppressWarnings(max(valid_values, na.rm = TRUE)) + 1
        }
      }, numeric(1)),
      rank_column_names
    )
  }

  percentile_replacements <- numeric(0)
  percentile_column_names <- grep("^percentile_rank_", names(comparison), value = TRUE)
  if (length(percentile_column_names) > 0) {
    percentile_replacements <- stats::setNames(
      rep(0, length(percentile_column_names)),
      percentile_column_names
    )
  }

  collapse_label_values <- function(indices, safe_labels_vec) {
    if (length(indices) == 0) {
      return(NA_character_)
    }
    labs <- label_map[safe_labels_vec[indices]]
    fallback <- safe_labels_vec[indices]
    labs[is.na(labs) | labs == ""] <- fallback[is.na(labs) | labs == ""]
    labs <- labs[!is.na(labs) & labs != ""]
    if (length(labs) == 0) {
      return(NA_character_)
    }
    paste(unique(labs), collapse = ", ")
  }

  if (length(labels) == 2) {
    fill_scores <- function(x, y, measure_col) {
      replacement <- score_replacements[[measure_col]]
      fallback_min <- suppressWarnings(min(c(x, y), na.rm = TRUE))
      if (!is.finite(fallback_min)) {
        fallback_min <- 0
      }
      if (!is.null(replacement) && is.finite(replacement)) {
        replacement <- min(replacement, fallback_min)
      } else {
        replacement <- fallback_min
      }
      if (!is.finite(replacement)) {
        replacement <- 0
      }
      if (any(is.na(x))) {
        x[is.na(x)] <- replacement
      }
      if (any(is.na(y))) {
        y[is.na(y)] <- replacement
      }
      list(x = x, y = y)
    }

    fill_percentiles <- function(x, y, left_pct_col, right_pct_col) {
      replacement_left <- percentile_replacements[[left_pct_col]]
      if (is.null(replacement_left) || !is.finite(replacement_left)) {
        replacement_left <- 0
      }
      replacement_right <- percentile_replacements[[right_pct_col]]
      if (is.null(replacement_right) || !is.finite(replacement_right)) {
        replacement_right <- 0
      }
      if (any(is.na(x))) {
        x[is.na(x)] <- replacement_left
      }
      if (any(is.na(y))) {
        y[is.na(y)] <- replacement_right
      }
      list(x = x, y = y)
    }

    fill_ranks <- function(x, y, left_rank_col, right_rank_col) {
      fallback <- nrow(comparison) + 1
      replacement_left <- rank_replacements[[left_rank_col]]
      if (is.null(replacement_left) || !is.finite(replacement_left)) {
        replacement_left <- fallback
      }
      replacement_right <- rank_replacements[[right_rank_col]]
      if (is.null(replacement_right) || !is.finite(replacement_right)) {
        replacement_right <- fallback
      }
      if (any(is.na(x))) {
        x[is.na(x)] <- replacement_left
      }
      if (any(is.na(y))) {
        y[is.na(y)] <- replacement_right
      }
      list(x = x, y = y)
    }

    left_label <- labels[1]
    right_label <- labels[2]

    for (col in score_cols) {
      left_col <- paste0(col, "_", left_label)
      right_col <- paste0(col, "_", right_label)
      if (!all(c(left_col, right_col) %in% names(comparison))) {
        next
      }
  filled <- fill_scores(comparison[[left_col]], comparison[[right_col]], col)
      comparison[[left_col]] <- filled$x
      comparison[[right_col]] <- filled$y
      comparison[[paste0("delta_", col)]] <- filled$x - filled$y
      rank_left <- paste0("rank_", left_label, "_", col)
      rank_right <- paste0("rank_", right_label, "_", col)
      if (all(c(rank_left, rank_right) %in% names(comparison))) {
        filled_rank <- fill_ranks(
          comparison[[rank_left]],
          comparison[[rank_right]],
          rank_left,
          rank_right
        )
        comparison[[paste0("delta_rank_", col)]] <- filled_rank$x - filled_rank$y
      }
      pct_left <- paste0("percentile_rank_", left_label, "_", col)
      pct_right <- paste0("percentile_rank_", right_label, "_", col)
      if (all(c(pct_left, pct_right) %in% names(comparison))) {
        filled_pct <- fill_percentiles(
          comparison[[pct_left]],
          comparison[[pct_right]],
          pct_left,
          pct_right
        )
        comparison[[paste0("delta_percentile_rank_", col)]] <- filled_pct$x - filled_pct$y
      }
    }
  }

  for (col in score_cols) {
    value_cols <- paste0(col, "_", labels)
    existing <- value_cols %in% names(comparison)
    if (!any(existing)) {
      next
    }
    value_cols <- value_cols[existing]
    safe_labels <- labels[existing]

    score_values <- comparison[, value_cols, drop = FALSE]

    winner_label_col <- paste0("winner_", col)
    winner_value_col <- paste0("winner_", col, "_value")
    runner_label_col <- paste0("runner_up_", col)
    runner_value_col <- paste0("runner_up_", col, "_value")
    loser_label_col <- paste0("loser_", col)
    loser_value_col <- paste0("loser_", col, "_value")
    max_delta_col <- paste0("max_delta_", col)

    if (nrow(score_values) == 0) {
      comparison[[winner_label_col]] <- character(0)
      comparison[[winner_value_col]] <- numeric(0)
      comparison[[runner_label_col]] <- character(0)
      comparison[[runner_value_col]] <- numeric(0)
      comparison[[loser_label_col]] <- character(0)
      comparison[[loser_value_col]] <- numeric(0)
      comparison[[max_delta_col]] <- numeric(0)
      next
    }

    score_matrix <- as.matrix(score_values)
    storage.mode(score_matrix) <- "numeric"

    n_rows <- nrow(score_matrix)
    winner_labels <- rep(NA_character_, n_rows)
    winner_values <- rep(NA_real_, n_rows)
    runner_labels <- rep(NA_character_, n_rows)
    runner_values <- rep(NA_real_, n_rows)
    loser_labels <- rep(NA_character_, n_rows)
    loser_values <- rep(NA_real_, n_rows)
    max_deltas <- rep(NA_real_, n_rows)

    if (n_rows > 0) {
      for (i in seq_len(n_rows)) {
        numeric_row <- as.numeric(score_matrix[i, ])
        if (all(is.na(numeric_row))) {
          next
        }

        replacement <- score_replacements[[col]]
        fallback_min <- suppressWarnings(min(numeric_row, na.rm = TRUE))
        if (!is.finite(fallback_min)) {
          fallback_min <- 0
        }
        if (!is.null(replacement) && is.finite(replacement)) {
          replacement <- min(replacement, fallback_min)
        } else {
          replacement <- fallback_min
        }
        if (!is.finite(replacement)) {
          replacement <- 0
        }
        if (any(is.na(numeric_row))) {
          numeric_row[is.na(numeric_row)] <- replacement
        }
        score_matrix[i, ] <- numeric_row

        max_val <- suppressWarnings(max(numeric_row, na.rm = TRUE))
        max_idx <- which(numeric_row == max_val)
        winner_labels[i] <- collapse_label_values(max_idx, safe_labels)
        winner_values[i] <- max_val

        unique_vals <- sort(unique(numeric_row), decreasing = TRUE)
        if (length(unique_vals) >= 2) {
          runner_val <- unique_vals[2]
          runner_idx <- which(numeric_row == runner_val)
          runner_labels[i] <- collapse_label_values(runner_idx, safe_labels)
          runner_values[i] <- runner_val
        }

        min_val <- suppressWarnings(min(numeric_row, na.rm = TRUE))
        min_idx <- which(numeric_row == min_val)
        loser_labels[i] <- collapse_label_values(min_idx, safe_labels)
        loser_values[i] <- min_val

        if (is.finite(max_val) && is.finite(min_val)) {
          max_deltas[i] <- max_val - min_val
        }
      }
    }

    comparison[, value_cols] <- score_matrix
    comparison[[winner_label_col]] <- winner_labels
    comparison[[winner_value_col]] <- winner_values
    comparison[[runner_label_col]] <- runner_labels
    comparison[[runner_value_col]] <- runner_values
    comparison[[loser_label_col]] <- loser_labels
    comparison[[loser_value_col]] <- loser_values
    comparison[[max_delta_col]] <- max_deltas
  }

  for (col in score_cols) {
    rank_cols <- paste0("rank_", labels, "_", col)
    existing <- rank_cols %in% names(comparison)
    if (!any(existing)) {
      next
    }
    rank_cols <- rank_cols[existing]
    safe_labels <- labels[existing]
    rank_values <- comparison[, rank_cols, drop = FALSE]

    winner_rank_label_col <- paste0("winner_rank_", col)
    winner_rank_value_col <- paste0("winner_rank_", col, "_value")
    runner_rank_label_col <- paste0("runner_up_rank_", col)
    runner_rank_value_col <- paste0("runner_up_rank_", col, "_value")
    loser_rank_label_col <- paste0("loser_rank_", col)
    loser_rank_value_col <- paste0("loser_rank_", col, "_value")
    max_delta_rank_col <- paste0("max_delta_rank_", col)

    if (nrow(rank_values) == 0) {
      comparison[[winner_rank_label_col]] <- character(0)
      comparison[[winner_rank_value_col]] <- numeric(0)
      comparison[[runner_rank_label_col]] <- character(0)
      comparison[[runner_rank_value_col]] <- numeric(0)
      comparison[[loser_rank_label_col]] <- character(0)
      comparison[[loser_rank_value_col]] <- numeric(0)
      comparison[[max_delta_rank_col]] <- numeric(0)
      next
    }

  rank_matrix <- as.matrix(rank_values)
  storage.mode(rank_matrix) <- "numeric"

    n_rows <- nrow(rank_matrix)
    winner_labels <- rep(NA_character_, n_rows)
    winner_values <- rep(NA_real_, n_rows)
    runner_labels <- rep(NA_character_, n_rows)
    runner_values <- rep(NA_real_, n_rows)
    loser_labels <- rep(NA_character_, n_rows)
    loser_values <- rep(NA_real_, n_rows)
    max_deltas <- rep(NA_real_, n_rows)

    for (i in seq_len(n_rows)) {
      numeric_row <- as.numeric(rank_matrix[i, ])
      if (all(is.na(numeric_row))) {
        next
      }

      if (length(rank_cols) > 0) {
        replacement_vec <- rank_replacements[rank_cols]
        replacement_vec[is.na(replacement_vec)] <- nrow(comparison) + 1
        missing_idx <- which(is.na(numeric_row))
        if (length(missing_idx) > 0) {
          numeric_row[missing_idx] <- replacement_vec[missing_idx]
        }
      }

      valid_idx <- seq_along(numeric_row)
      valid_values <- numeric_row[valid_idx]
      min_val <- suppressWarnings(min(valid_values, na.rm = TRUE))
      min_positions <- valid_idx[which(valid_values == min_val)]
      winner_labels[i] <- collapse_label_values(min_positions, safe_labels)
      winner_values[i] <- min_val

      ordered_vals <- sort(unique(valid_values), decreasing = FALSE)
      if (length(ordered_vals) >= 2) {
        runner_val <- ordered_vals[2]
        runner_positions <- valid_idx[which(valid_values == runner_val)]
        runner_labels[i] <- collapse_label_values(runner_positions, safe_labels)
        runner_values[i] <- runner_val
      }

      max_val <- suppressWarnings(max(valid_values, na.rm = TRUE))
      max_positions <- valid_idx[which(valid_values == max_val)]
      loser_labels[i] <- collapse_label_values(max_positions, safe_labels)
      loser_values[i] <- max_val

      if (is.finite(max_val) && is.finite(min_val)) {
        max_deltas[i] <- max_val - min_val
      }
    }

    comparison[[winner_rank_label_col]] <- winner_labels
    comparison[[winner_rank_value_col]] <- winner_values
    comparison[[runner_rank_label_col]] <- runner_labels
    comparison[[runner_rank_value_col]] <- runner_values
    comparison[[loser_rank_label_col]] <- loser_labels
    comparison[[loser_rank_value_col]] <- loser_values
    comparison[[max_delta_rank_col]] <- max_deltas
  }

  for (col in score_cols) {
    pct_cols <- paste0("percentile_rank_", labels, "_", col)
    existing <- pct_cols %in% names(comparison)
    if (!any(existing)) {
      next
    }
    pct_cols <- pct_cols[existing]
    safe_labels <- labels[existing]
    pct_values <- comparison[, pct_cols, drop = FALSE]

    winner_pct_label_col <- paste0("winner_percentile_rank_", col)
    winner_pct_value_col <- paste0("winner_percentile_rank_", col, "_value")
    runner_pct_label_col <- paste0("runner_up_percentile_rank_", col)
    runner_pct_value_col <- paste0("runner_up_percentile_rank_", col, "_value")
    loser_pct_label_col <- paste0("loser_percentile_rank_", col)
    loser_pct_value_col <- paste0("loser_percentile_rank_", col, "_value")
    max_delta_pct_col <- paste0("max_delta_percentile_rank_", col)

    if (nrow(pct_values) == 0) {
      comparison[[winner_pct_label_col]] <- character(0)
      comparison[[winner_pct_value_col]] <- numeric(0)
      comparison[[runner_pct_label_col]] <- character(0)
      comparison[[runner_pct_value_col]] <- numeric(0)
      comparison[[loser_pct_label_col]] <- character(0)
      comparison[[loser_pct_value_col]] <- numeric(0)
      comparison[[max_delta_pct_col]] <- numeric(0)
      next
    }

    pct_matrix <- as.matrix(pct_values)
    storage.mode(pct_matrix) <- "numeric"

    n_rows <- nrow(pct_matrix)
    winner_labels <- rep(NA_character_, n_rows)
    winner_values <- rep(NA_real_, n_rows)
    runner_labels <- rep(NA_character_, n_rows)
    runner_values <- rep(NA_real_, n_rows)
    loser_labels <- rep(NA_character_, n_rows)
    loser_values <- rep(NA_real_, n_rows)
    max_deltas <- rep(NA_real_, n_rows)

    if (n_rows > 0) {
      for (i in seq_len(n_rows)) {
        numeric_row <- as.numeric(pct_matrix[i, ])
        if (all(is.na(numeric_row))) {
          next
        }

        if (any(is.na(numeric_row))) {
          numeric_row[is.na(numeric_row)] <- 0
        }
        pct_matrix[i, ] <- numeric_row

        max_val <- suppressWarnings(max(numeric_row, na.rm = TRUE))
        max_idx <- which(numeric_row == max_val)
        winner_labels[i] <- collapse_label_values(max_idx, safe_labels)
        winner_values[i] <- max_val

        unique_vals <- sort(unique(numeric_row), decreasing = TRUE)
        if (length(unique_vals) >= 2) {
          runner_val <- unique_vals[2]
          runner_idx <- which(numeric_row == runner_val)
          runner_labels[i] <- collapse_label_values(runner_idx, safe_labels)
          runner_values[i] <- runner_val
        }

        min_val <- suppressWarnings(min(numeric_row, na.rm = TRUE))
        min_idx <- which(numeric_row == min_val)
        loser_labels[i] <- collapse_label_values(min_idx, safe_labels)
        loser_values[i] <- min_val

        if (is.finite(max_val) && is.finite(min_val)) {
          max_deltas[i] <- max_val - min_val
        }
      }
    }

    comparison[, pct_cols] <- pct_matrix
    comparison[[winner_pct_label_col]] <- winner_labels
    comparison[[winner_pct_value_col]] <- winner_values
    comparison[[runner_pct_label_col]] <- runner_labels
    comparison[[runner_pct_value_col]] <- runner_values
    comparison[[loser_pct_label_col]] <- loser_labels
    comparison[[loser_pct_value_col]] <- loser_values
    comparison[[max_delta_pct_col]] <- max_deltas
  }

  dplyr::left_join(result, comparison, by = c("node", "collocate"))
}

#' @importFrom magrittr debug_pipe
#' @importFrom stringr str_detect
#' @importFrom dplyr as_tibble tibble rename filter anti_join tibble bind_rows case_when
#'
matches2FreqTable <- function(matches,
                              index = 0,
                              minOccur = 5,
                              leftContextSize = 5,
                              rightContextSize = 5,
                              ignoreCollocateCase = FALSE,
                              stopwords = c(),
                              collocateFilterRegex = "^[:alnum:]+-?[:alnum:]*$",
                              oldTable = data.frame(word = rep(NA, 1), frequency = rep(NA, 1)),
                              verbose = TRUE) {
  word <- NULL # https://stackoverflow.com/questions/8096313/no-visible-binding-for-global-variable-note-in-r-cmd-check
  frequency <- NULL

  if (nrow(matches) < 1) {
    dplyr::tibble(word = c(), frequency = c())
  } else if (index == 0) {
    if (!"tokens" %in% colnames(matches) || !is.list(matches$tokens)) {
      log_info(verbose, "Outdated KorAP server: Falling back to client side tokenization.\n")
      return(snippet2FreqTable(matches$snippet, minOccur, leftContextSize, rightContextSize,
        ignoreCollocateCase = ignoreCollocateCase,
        stopwords = stopwords, oldTable = oldTable, verbose = verbose
      ))
    }
    log_info(verbose, paste("Joining", nrow(matches), "kwics\n"))
    for (i in seq_len(nrow(matches))) {
      oldTable <- matches2FreqTable(
        matches,
        i,
        leftContextSize = leftContextSize,
        rightContextSize = rightContextSize,
        collocateFilterRegex = collocateFilterRegex,
        oldTable = oldTable,
        stopwords = stopwords
      )
    }
    log_info(verbose, paste("Aggregating", length(oldTable$word), "tokens\n"))
    oldTable |>
      group_by(word) |>
      mutate(word = dplyr::case_when(ignoreCollocateCase ~ tolower(word), TRUE ~ word)) |>
      summarise(frequency = sum(frequency), .groups = "drop") |>
      arrange(desc(frequency))
  } else {
    stopwordsTable <- dplyr::tibble(word = stopwords)

    left <- tail(unlist(matches$tokens$left[index]), leftContextSize)

    #    cat(paste("left:", left, "\n", collapse=" "))

    right <- head(unlist(matches$tokens$right[index]), rightContextSize)

    #    cat(paste("right:", right, "\n", collapse=" "))

    if (length(left) + length(right) == 0) {
      oldTable
    } else {
      table(c(left, right)) |>
        dplyr::as_tibble(.name_repair = "minimal") |>
        dplyr::rename(word = 1, frequency = 2) |>
        dplyr::filter(str_detect(word, collocateFilterRegex)) |>
        dplyr::anti_join(stopwordsTable, by = "word") |>
        dplyr::bind_rows(oldTable)
    }
  }
}

#' @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
#'
snippet2FreqTable <- function(snippet,
                              minOccur = 5,
                              leftContextSize = 5,
                              rightContextSize = 5,
                              ignoreCollocateCase = FALSE,
                              stopwords = c(),
                              tokenizeRegex = "([! )(\uc2\uab,.:?\u201e\u201c\'\"]+|&quot;)",
                              collocateFilterRegex = "^[:alnum:]+-?[:alnum:]*$",
                              oldTable = data.frame(word = rep(NA, 1), frequency = rep(NA, 1)),
                              verbose = TRUE) {
  word <- NULL # https://stackoverflow.com/questions/8096313/no-visible-binding-for-global-variable-note-in-r-cmd-check
  frequency <- NULL

  if (length(snippet) < 1) {
    dplyr::tibble(word = c(), frequency = c())
  } else if (length(snippet) > 1) {
    log_info(verbose, paste("Joining", length(snippet), "kwics\n"))
    for (s in snippet) {
      oldTable <- snippet2FreqTable(
        s,
        leftContextSize = leftContextSize,
        rightContextSize = rightContextSize,
        collocateFilterRegex = collocateFilterRegex,
        oldTable = oldTable,
        stopwords = stopwords
      )
    }
    log_info(verbose, paste("Aggregating", length(oldTable$word), "tokens\n"))
    oldTable |>
      group_by(word) |>
      mutate(word = dplyr::case_when(ignoreCollocateCase ~ tolower(word), TRUE ~ word)) |>
      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"> *([^<]*)'
      )

    left <- if (leftContextSize > 0) {
      tail(unlist(str_split(match[1, 3], tokenizeRegex)), leftContextSize)
    } else {
      ""
    }
    #    cat(paste("left:", left, "\n", collapse=" "))

    right <- if (rightContextSize > 0) {
      head(unlist(str_split(match[1, 4], tokenizeRegex)), rightContextSize)
    } else {
      ""
    }
    #    cat(paste("right:", right, "\n", collapse=" "))

    if (is.na(left[1]) || is.na(right[1]) || length(left) + length(right) == 0) {
      oldTable
    } else {
      table(c(left, right)) |>
        dplyr::as_tibble(.name_repair = "minimal") |>
        dplyr::rename(word = 1, frequency = 2) |>
        dplyr::filter(str_detect(word, collocateFilterRegex)) |>
        dplyr::anti_join(stopwordsTable, by = "word") |>
        dplyr::bind_rows(oldTable)
    }
  }
}

#' Preliminary synsemantic stopwords function
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Preliminary synsemantic stopwords function to be used in collocation analysis.
#'
#' @details
#' Currently only suitable for German. See stopwords package for other languages.
#'
#' @param ... future arguments for language detection
#'
#' @family collocation analysis functions
#' @return Vector of synsemantic stopwords.
#' @export
synsemanticStopwords <- function(...) {
  base <- c(
    "der",
    "die",
    "und",
    "in",
    "den",
    "von",
    "mit",
    "das",
    "zu",
    "im",
    "ist",
    "auf",
    "sich",
    "des",
    "dem",
    "nicht",
    "ein",
    "eine",
    "es",
    "auch",
    "an",
    "als",
    "am",
    "aus",
    "bei",
    "er",
    "dass",
    "sie",
    "nach",
    "um",
    "zum",
    "noch",
    "war",
    "einen",
    "einer",
    "wie",
    "einem",
    "vor",
    "bis",
    "\u00fcber",
    "so",
    "aber",
    "diese",
    "oder"
  )

  lower <- unique(tolower(base))
  capitalized <- paste0(toupper(substr(lower, 1, 1)), substring(lower, 2))

  unique(c(lower, capitalized))
}


# #' @export
findExample <-
  function(kco,
           query,
           vc = "",
           matchOnly = TRUE) {
    out <- character(length = length(query))

    if (length(vc) < length(query)) {
      vc <- rep(vc, length(query))
    }

    for (i in seq_along(query)) {
      q <- corpusQuery(kco, paste0("(", query[i], ")"), vc = vc[i], metadataOnly = FALSE)
      if (q@totalResults > 0) {
        q <- fetchNext(q, maxFetch = 50, randomizePageOrder = F)
        example <- as.character((q@collectedMatches)$snippet[1])
        out[i] <- if (matchOnly) {
          gsub(".*<mark>(.+)</mark>.*", "\\1", example)
        } else {
          stringr::str_replace(example, "<[^>]*>", "")
        }
      } else {
        out[i] <- ""
      }
    }
    out
  }

collocatesQuery <-
  function(kco,
           query,
           vc = "",
           minOccur = 5,
           leftContextSize = 5,
           rightContextSize = 5,
           searchHitsSampleLimit = 20000,
           ignoreCollocateCase = FALSE,
           stopwords = c(),
           collocateFilterRegex = "^[:alnum:]+-?[:alnum:]*$",
           ...) {
    frequency <- NULL
    q <- corpusQuery(kco, query, vc, metadataOnly = F, ...)
    if (q@totalResults == 0) {
      tibble(word = c(), frequency = c())
    } else {
      q <- fetchNext(q, maxFetch = searchHitsSampleLimit, randomizePageOrder = TRUE)
      matches2FreqTable(q@collectedMatches,
        0,
        minOccur = minOccur,
        leftContextSize = leftContextSize,
        rightContextSize = rightContextSize,
        ignoreCollocateCase = ignoreCollocateCase,
        stopwords = stopwords,
        collocateFilterRegex = collocateFilterRegex,
        ...,
        verbose = kco@verbose
      ) |>
        mutate(frequency = frequency * q@totalResults / min(q@totalResults, searchHitsSampleLimit)) |>
        filter(frequency >= minOccur)
    }
  }