adjust filter by context to exclude key words

DESCRIPTION

@@ -35,7 +35,7 @@ Suggests:
     BiocStyle,
     knitr,
     rmarkdown,
-    testthat (>= 3.0.0),
+    testthat (>= 3.1.7),
     mockery,
     MSstatsConvert,
     shiny

R/filterSubnetworkByContext.R

@@ -8,8 +8,9 @@
 #'
 #' \describe{
 #'   \item{\code{"tag_count"} (default)}{
-#'     Counts how many tags from \code{query} appear as substrings in the
-#'     abstract (case-insensitive). The score for each abstract is an integer
+#'     Counts how many tags from \code{query} appear as whole words or phrases
+#'     in the abstract (case-insensitive), so \code{"colon"} does not match
+#'     "colony" or "colonize". The score for each abstract is an integer
 #'     in \code{[0, length(query)]}. Set \code{cutoff} to the minimum number of
 #'     tags that must appear - e.g. \code{cutoff = 2} keeps abstracts that
 #'     mention at least 2 of your tags. \code{query} must be a character
@@ -30,6 +31,9 @@
 #' @param query  For \code{method = "tag_count"}: a character vector of tags,
 #'               e.g. \code{c("CHEK1", "DNA damage", "DNA damage repair")}.
 #'               For \code{method = "cosine"}: a single character string.
+#'               May be \code{NULL} (default) when \code{exclude_keywords} is
+#'               supplied; abstracts are then not scored (\code{score} is
+#'               \code{NA}) and only the keyword exclusion is applied.
 #' @param cutoff Numeric threshold applied to the chosen scoring method.
 #'               \itemize{
 #'                 \item \code{"tag_count"}: integer >= 0; abstracts must
@@ -39,14 +43,41 @@
 #'                   must score >= this value. Default \code{0.10}.
 #'               }
 #' @param method One of \code{"tag_count"} (default) or \code{"cosine"}.
+#' @param exclude_keywords Optional character vector of keywords. Abstracts
+#'   containing any of them as a whole word or phrase (case-insensitive) are
+#'   removed, regardless of their score. For example, \code{"colon"} matches
+#'   "colon" and "colon-specific" but not "colonize" or "colons"; list
+#'   variants such as plurals explicitly. To exclude by keyword only, omit
+#'   \code{query}. Default \code{NULL} excludes nothing.
 #'
-#' @return A named list with three elements:
+#' @return A named list with four elements:
 #'   \item{nodes}{Filtered nodes dataframe (only nodes present in kept edges)}
 #'   \item{edges}{Filtered edges dataframe}
 #'   \item{evidence}{Dataframe with columns: source, target, interaction, site,
 #'     evidenceLink, stmt_hash, text, pmid, score. The \code{score} column
 #'     contains tag counts (integer) or cosine similarities (numeric) depending
 #'     on the method used.}
+#'   \item{abstracts}{Named character vector mapping each PMID in
+#'     \code{evidence} to its abstract text.}
+#'   The \code{evidence} and \code{abstracts} elements can be passed to the
+#'   same-named arguments of \code{\link{decomposeSubnetworkByTopic}} or
+#'   \code{\link{decomposeSubnetworkIntoHierarchicalTopics}}, together with the
+#'   returned list as \code{subnetwork}, so INDRA and PubMed are not queried
+#'   again.
+#'
+#' @examples
+#' \dontrun{
+#' filtered <- filterSubnetworkByContext(
+#'     subnetwork$nodes, subnetwork$edges,
+#'     query = c("DNA damage", "DNA repair"),
+#'     exclude_keywords = c("review")
+#' )
+#' hierarchy <- decomposeSubnetworkIntoHierarchicalTopics(
+#'     filtered,
+#'     evidence  = filtered$evidence,
+#'     abstracts = filtered$abstracts
+#' )
+#' }
 #'
 #' @importFrom text2vec itoken word_tokenizer create_vocabulary prune_vocabulary vocab_vectorizer create_dtm TfIdf fit_transform
 #' @importFrom stopwords stopwords
@@ -55,13 +86,32 @@
 #' @export
 filterSubnetworkByContext <- function(nodes,
                                       edges,
-                                      query,
+                                      query = NULL,
                                       cutoff = NULL,
-                                      method = c("tag_count", "cosine")) {
-
+                                      method = c("tag_count", "cosine"),
+                                      exclude_keywords = NULL) {
+
     method <- match.arg(method)
 
-    if (method == "tag_count") {
+    if (is.character(query)) query <- trimws(query)
+    if (is.character(exclude_keywords)) exclude_keywords <- trimws(exclude_keywords)
+
+    if (!is.null(exclude_keywords) &&
+        (!is.character(exclude_keywords) || length(exclude_keywords) < 1 ||
+         any(is.na(exclude_keywords)) || any(!nzchar(exclude_keywords)))) {
+        stop("`exclude_keywords` must be NULL or a character vector of non-empty keywords.")
+    }
+    no_abstracts <- stats::setNames(character(0), character(0))
+
+    if (is.null(query)) {
+        if (is.null(exclude_keywords)) {
+            stop("Supply `query`, `exclude_keywords`, or both.")
+        }
+        if (!is.null(cutoff)) {
+            stop("`cutoff` has no effect without `query`; remove it or supply `query`.")
+        }
+        cat("No query: scoring skipped, filtering by `exclude_keywords` only\n")
+    } else if (method == "tag_count") {
         if (!is.character(query) || length(query) < 1 || 
             any(is.na(query)) || any(!nzchar(query))) {
             stop("`query` must be a character vector of tags when method = 'tag_count'.")
@@ -95,7 +145,8 @@ filterSubnetworkByContext <- function(nodes,
     if (nrow(evidence) == 0) {
         evidence$score <- if (method == "tag_count") integer(0) else numeric(0)
         warning("No evidence text found - returning unfiltered inputs.")
-        return(list(nodes = nodes, edges = edges, evidence = evidence))
+        return(list(nodes = nodes, edges = edges, evidence = evidence,
+                    abstracts = no_abstracts))
     }
     pmids <- unique(evidence$pmid[!is.na(evidence$pmid) & nchar(evidence$pmid) > 0])
 
@@ -106,7 +157,8 @@ filterSubnetworkByContext <- function(nodes,
             rep(NA_real_, nrow(evidence))
         }
         warning("No PMIDs found in evidence - returning unfiltered inputs.")
-        return(list(nodes = nodes, edges = edges, evidence = evidence))
+        return(list(nodes = nodes, edges = edges, evidence = evidence,
+                    abstracts = no_abstracts))
     }
 
     abstract_list <- .fetch_clean_abstracts_xml(pmids)
@@ -116,26 +168,48 @@ filterSubnetworkByContext <- function(nodes,
         stringsAsFactors = FALSE
     )
 
-    if (method == "tag_count") {
-        abstracts_df$score <- .score_by_tag_count(abstracts_df$abstract, query)
+    if (is.null(query)) {
+        abstracts_df$score <- if (method == "tag_count") NA_integer_ else NA_real_
+        passing <- rep(TRUE, nrow(abstracts_df))
     } else {
-        abstracts_df$score <- .score_by_cosine(query, abstracts_df$abstract)
+        if (method == "tag_count") {
+            abstracts_df$score <- .score_by_tag_count(abstracts_df$abstract, query)
+        } else {
+            abstracts_df$score <- .score_by_cosine(query, abstracts_df$abstract)
+        }
+        passing <- abstracts_df$score >= cutoff
     }
-
-    passing_pmids <- abstracts_df$pmid[abstracts_df$score >= cutoff]
-
-    cat(sprintf(
-        "\n%d / %d abstracts passed cutoff (score >= %s)\n",
-        length(passing_pmids), nrow(abstracts_df), cutoff
-    ))
-
+    if (!is.null(exclude_keywords)) {
+        excluded <- .contains_any_keyword(abstracts_df$abstract,
+                                          exclude_keywords)
+        cat(sprintf(
+            "\n%d / %d abstracts excluded by keyword(s): %s\n",
+            sum(excluded), nrow(abstracts_df),
+            paste(exclude_keywords, collapse = ", ")
+        ))
+        passing <- passing & !excluded
+    }
+    passing_pmids <- abstracts_df$pmid[passing]
+
+    if (is.null(query)) {
+        cat(sprintf("\n%d / %d abstracts kept\n",
+                    length(passing_pmids), nrow(abstracts_df)))
+    } else {
+        cat(sprintf(
+            "\n%d / %d abstracts passed cutoff (score >= %s)\n",
+            length(passing_pmids), nrow(abstracts_df), cutoff
+        ))
+    }
+
     evidence_scored <- merge(
         evidence,
         abstracts_df[, c("pmid", "score")],
         by    = "pmid",
         all.x = TRUE
     )
-    evidence_scored$score[is.na(evidence_scored$score)] <- 0
+    if (!is.null(query)) {
+        evidence_scored$score[is.na(evidence_scored$score)] <- 0
+    }
 
     evidence_filtered <- evidence_scored[
         evidence_scored$pmid %in% passing_pmids,
@@ -144,13 +218,13 @@ filterSubnetworkByContext <- function(nodes,
     ]
 
     surviving_hashes <- unique(evidence_filtered$stmt_hash)
-    edges_filtered   <- edges[edges$stmt_hash %in% surviving_hashes, ]
+    edges_filtered   <- edges[edges$stmt_hash %in% surviving_hashes, , drop = FALSE]
 
     surviving_nodes  <- union(edges_filtered$source, edges_filtered$target)
     if (!"id" %in% names(nodes)) {
         stop("`nodes` must contain an `id` column.")
     }
-    nodes_filtered   <- nodes[nodes$id %in% surviving_nodes, ]
+    nodes_filtered   <- nodes[nodes$id %in% surviving_nodes, , drop = FALSE]
 
     cat(sprintf(
         "Retained: %d edges (of %d), %d nodes (of %d), %d evidence rows (of %d)\n",
@@ -159,30 +233,68 @@ filterSubnetworkByContext <- function(nodes,
         nrow(evidence_filtered), nrow(evidence_scored)
     ))
 
+    kept_pmids <- unique(evidence_filtered$pmid)
+    abstracts_kept <- stats::setNames(
+        abstracts_df$abstract[match(kept_pmids, abstracts_df$pmid)],
+        kept_pmids
+    )
+
     return(list(
-        nodes    = nodes_filtered,
-        edges    = edges_filtered,
-        evidence = evidence_filtered
+        nodes     = nodes_filtered,
+        edges     = edges_filtered,
+        evidence  = evidence_filtered,
+        abstracts = abstracts_kept
     ))
 }
 
 
+#' Flag abstracts that contain any of a set of keywords
+#'
+#' @param abstracts Character vector of abstract texts.
+#' @param keywords  Character vector of keywords to search for.
+#' @return Logical vector, same length as \code{abstracts}; \code{TRUE} when
+#'   the abstract contains at least one keyword as a whole word or phrase
+#'   (case-insensitive), so \code{"colon"} does not match \code{"colonize"}.
+#' @keywords internal
+#' @noRd
+.contains_any_keyword <- function(abstracts, keywords) {
+    hits <- lapply(keywords, function(keyword) .has_term(abstracts, keyword))
+    Reduce(`|`, hits, logical(length(abstracts)))
+}
+
+
+#' Test abstracts for a whole-word, case-insensitive term
+#'
+#' The term must not be flanked by letters or digits, so \code{"colon"}
+#' matches "colon" and "colon-specific" but not "colonize" or "colony".
+#' Regex metacharacters in \code{term} are matched literally.
+#'
+#' @param abstracts Character vector of abstract texts.
+#' @param term      Single word or phrase.
+#' @return Logical vector, same length as \code{abstracts}.
+#' @keywords internal
+#' @noRd
+.has_term <- function(abstracts, term) {
+    escaped <- gsub("([][{}()+*^$|\\\\?.])", "\\\\\\1", tolower(term))
+    pattern <- paste0("(?<![[:alnum:]])", escaped, "(?![[:alnum:]])")
+    grepl(pattern, tolower(abstracts), perl = TRUE)
+}
+
+
 #' Score abstracts by tag count
 #'
-#' For each abstract, counts how many tags appear as case-insensitive substrings.
+#' For each abstract, counts how many tags appear as case-insensitive whole
+#' words or phrases.
 #'
 #' @param abstracts Character vector of abstract texts.
 #' @param tags      Character vector of tags to search for.
 #' @return Integer vector of tag hit counts, same length as \code{abstracts}.
 #' @keywords internal
 #' @noRd
 .score_by_tag_count <- function(abstracts, tags) {
-    abstracts_lower <- tolower(abstracts)
-    tags_lower      <- tolower(tags)
-
-    sapply(abstracts_lower, function(abstract) {
-        sum(sapply(tags_lower, function(tag) grepl(tag, abstract, fixed = TRUE)))
-    }, USE.NAMES = FALSE)
+    hits <- vapply(tags, function(tag) .has_term(abstracts, tag),
+                   logical(length(abstracts)))
+    as.integer(rowSums(matrix(hits, nrow = length(abstracts))))
 }