From 3755a7614dcf3d8a6987872f7445198f81713555 Mon Sep 17 00:00:00 2001 From: MadDERt <2129882365@qq.com> Date: Fri, 30 Oct 2026 10:34:26 +0800 Subject: [PATCH 1/4] Fix audit findings: backend regex parity (RE2 vs TRE), metadata-only column access, COUNT pushdown diagnostics, .return/NA validation --- DESCRIPTION | 1 + NAMESPACE | 1 + NEWS.md | 14 + R/restrict-drug.R | 493 ++++++++++++++++++++++++++++ man/faers_reports_with.Rd | 130 ++++++++ tests/testthat/test_restrict-drug.R | 343 +++++++++++++++++++ 6 files changed, 982 insertions(+) create mode 100644 R/restrict-drug.R create mode 100644 man/faers_reports_with.Rd create mode 100644 tests/testthat/test_restrict-drug.R diff --git a/DESCRIPTION b/DESCRIPTION index c887e86..06d2f8f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -74,6 +74,7 @@ Collate: 'period.R' 'phv_.R' 'phv_ebgm.R' + 'restrict-drug.R' 'restrict.R' 'rxnorm.R' 'sample.R' diff --git a/NAMESPACE b/NAMESPACE index 927e391..491237e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,6 +31,7 @@ export(faers_phv_signal_composite) export(faers_phv_table) export(faers_primaryid) export(faers_quarter) +export(faers_reports_with) export(faers_restrict) export(faers_standardize) export(faers_year) diff --git a/NEWS.md b/NEWS.md index 2324462..86a678a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,19 @@ # faers 1.5.6 +* Added `faers_reports_with()`, a report set constructor for drug exposure + definitions: reports whose drug records match a combination of drug name + patterns (case-insensitive regular expressions), optionally restricted per + drug to specific role codes (`.roles`) and optionally excluding reports + containing other drugs (`.exclude_drugs`, report-level and role-agnostic). + `.logic = "and"/"or"` combines patterns; two patterns may be satisfied by + the same drug row (fixed-dose combination products). Returns the filtered + object, sorted `primaryid` vector or a count. On duckdb-backed objects + plain-literal patterns are pushed down to SQL (`regexp_matches`), other + patterns fall back to identical R matching, so both backends always agree; + object-mode returns build on a private copy, leaving the source database + untouched. Per-pattern hit counts are reported as a message; empty result + sets are a legitimate outcome, not an error. + * Added `faers_restrict()`, a report-level restriction helper that narrows a standardized FAERS object to a sub-population by reporting period (`.period`), date window (`.date_range` on `.date_field`, with partial diff --git a/R/restrict-drug.R b/R/restrict-drug.R new file mode 100644 index 0000000..0b7d3db --- /dev/null +++ b/R/restrict-drug.R @@ -0,0 +1,493 @@ +# faers_reports_with: report-set constructor over drug exposures. +# +# A report-set builder: narrows a standardized FAERS object to reports whose +# drug records satisfy a combination of exposure conditions (multiple drug +# patterns, per-drug role constraints, AND/OR combination, exclusion of +# concomitant drugs). This is a set-construction tool for report counting, +# set operations and sub-population exploration; it is NOT by itself a +# drug-interaction / combination-toxicity signal analysis — scanning a subset +# built here lacks an unexposed comparator group (see the man page notes). +# +# Semantics (frozen): +# - Each pattern must hold on AT LEAST ONE drug row of the report; under +# `.logic = "and"` two patterns MAY be satisfied by the SAME row (fixed-dose +# combinations / multi-ingredient prod_ai entries). +# - `.roles` is a strictly-named list keyed by `.drugs` elements; drugs absent +# from it are unrestricted. Unknown/duplicated names and invalid role codes +# abort. +# - `.exclude_drugs` is report-level: any matching drug row (any role) removes +# the report. +# - Matching semantics: grepl(pattern, x, ignore.case = TRUE). For the duckdb +# backend a pattern is pushed down as regexp_matches(col, p, 'i') ONLY when +# it is pushdown-safe (plain literal: letters/digits/space/underscore/hyphen); +# otherwise the drug table is collected and matched in R, so both backends +# agree byte-for-byte on every pattern. +# - Legal conditions with zero hits return an empty set (empty object / +# character(0) / 0L) — this is a constructor, not a filter; an empty result +# is a legitimate outcome. + +# ---------- validation ---------- + +# Normalize + validate `.drugs`: non-empty character vector of regexes. +# Compiles each pattern so invalid regex aborts here. +.reports_with_check_drugs <- function(.drugs, call = rlang::caller_env()) { + if (is.null(.drugs) || !is.character(.drugs) || !length(.drugs)) { + cli::cli_abort( + "{.arg .drugs} must be a non-empty character vector of drug name patterns", + call = call + ) + } + .drugs <- trimws(.drugs) + if (anyNA(.drugs) || any(!nzchar(.drugs))) { + cli::cli_abort( + "{.arg .drugs} must not contain NA or empty strings", + call = call + ) + } + if (anyDuplicated(.drugs)) { + cli::cli_abort(c( + "{.arg .drugs} must not contain duplicated patterns", + x = "Duplicated: {.val {unique(.drugs[duplicated(.drugs)])}}" + ), call = call) + } + bad <- vapply(.drugs, function(p) { + suppressWarnings(is.na(tryCatch(grepl(p, ""), error = function(e) NA))) + }, logical(1L)) + if (any(bad)) { + bad_val <- .drugs[which(bad)] + cli::cli_abort(c( + "Invalid regular expression in {.arg .drugs}", + x = "{.val {bad_val}}" + ), call = call) + } + .drugs +} + +# Validate `.roles`: strictly-named list keyed by `.drugs` elements. +# Drugs absent from the list are unrestricted (no recycling). +.reports_with_check_roles <- function(.roles, .drugs, call = rlang::caller_env()) { + if (is.null(.roles)) { + return(list()) + } + if (!is.list(.roles) || !length(.roles) || + is.null(names(.roles)) || any(!nzchar(names(.roles)))) { + cli::cli_abort( + "{.arg .roles} must be a fully named list like {.code list(warfarin = c(\"PS\", \"SS\"))}", + call = call + ) + } + nms <- names(.roles) + dup <- unique(nms[duplicated(nms)]) + if (length(dup)) { + cli::cli_abort(c( + "{.arg .roles} contains duplicated drug names", + x = "{.val {dup}}" + ), call = call) + } + unknown <- setdiff(nms, .drugs) + if (length(unknown)) { + cli::cli_abort(c( + "{.arg .roles} refers to drug names not listed in {.arg .drugs}", + x = "Unknown: {.val {unknown}}", + i = "Role constraints may only be attached to drugs listed in {.arg .drugs}; unspecified drugs are unrestricted" + ), call = call) + } + allowed <- c("PS", "SS", "C", "I") + for (nm in nms) { + roles <- .roles[[nm]] + if (!is.character(roles) || !length(roles)) { + cli::cli_abort(c( + "{.arg .roles[[\"{nm}\"]]}} must be a non-empty character vector", + i = "Valid role codes: {.val {allowed}}" + ), call = call) + } + roles <- toupper(trimws(roles)) + bad <- setdiff(roles, allowed) + if (length(bad)) { + cli::cli_abort(c( + "Invalid role code {.val {bad}} for drug {.val {nm}}", + i = "Valid codes: {.val {allowed}} (primary suspect, secondary suspect, concomitant, interacting)" + ), call = call) + } + .roles[[nm]] <- roles + } + .roles +} + +# Validate `.exclude_drugs`: optional character vector of patterns. +.reports_with_check_exclude <- function(.exclude_drugs, call = rlang::caller_env()) { + if (is.null(.exclude_drugs)) { + return(character()) + } + if (!is.character(.exclude_drugs) || !length(.exclude_drugs)) { + cli::cli_abort( + "{.arg .exclude_drugs} must be a character vector of drug patterns or NULL", + call = call + ) + } + .exclude_drugs <- trimws(.exclude_drugs) + if (anyNA(.exclude_drugs) || any(!nzchar(.exclude_drugs))) { + cli::cli_abort( + "{.arg .exclude_drugs} must not contain NA or empty strings", + call = call + ) + } + unique(.exclude_drugs) +} + +# Pushdown-safety: a pattern may go to duckdb regexp_matches(col, p, 'i') +# ONLY if it is a plain literal (letters/digits/space/underscore/hyphen). +# Anything else (metacharacters, classes, lookarounds) falls back to R-side +# grepl so both backends agree byte-for-byte (probed duckdb 1.5.5: RE2 bracket +# semantics differ from PCRE; lookarounds error out). +# +# An ASCII-only pattern is still NOT sufficient for identical case folding: +# RE2's 'i' flag applies simple Unicode folding (Kelvin sign U+212A "K" folds +# to "k") while R's TRE does not, so a non-ASCII drug name can match on +# duckdb but not in R. The SQL condition therefore also requires matched rows +# to be pure ASCII (`regexp_matches(col, '^[ -~]*$')`); the caller unions the +# remaining (non-ASCII) rows matched in R, where TRE folding defines the +# semantics for both backends. +.reports_with_pushdown_safe <- function(patterns) { + all(grepl("^[A-Za-z0-9 _-]+$", patterns)) +} + +# ---------- shared matching core (memory backend) ---------- + +# Reports whose drug rows satisfy every/any pattern. Same row may satisfy +# several patterns (fixed-dose combination rows). Per-drug roles (named list +# keyed by pattern) restrict which drug rows may satisfy that pattern; +# patterns without a role entry may be satisfied by any role. +.reports_with_ids_mem <- function(drug, patterns, logic, roles, excludes, drug_col) { + hit <- function(pattern, roles) { + out <- grepl(pattern, drug[[drug_col]], ignore.case = TRUE) + if (length(roles)) out <- out & drug$role_cod %chin% roles + out + } + id_sets <- lapply(patterns, function(p) { + unique(drug$primaryid[hit(p, roles[[p]])]) + }) + ids <- if (identical(logic, "and")) Reduce(intersect, id_sets) else unique(unlist(id_sets)) + if (length(excludes)) { + ex <- lapply(excludes, function(p) { + drug$primaryid[grepl(p, drug[[drug_col]], ignore.case = TRUE)] + }) + ids <- setdiff(ids, unique(unlist(ex, use.names = FALSE))) + } + ids +} + +# ---------- db backend ---------- + +# SQL fragment: pattern restricted to its role codes. Literal patterns are +# pushed down (see .reports_with_pushdown_safe); everything else returns NULL +# and the caller falls back to the R path. Pushed-down matches are confined +# to pure-ASCII drug values so RE2 and TRE agree on the case folding; the +# caller re-matches every non-ASCII row in R and unions the results. +.reports_with_sql_cond <- function(pattern, roles, drug_col) { + if (!.reports_with_pushdown_safe(pattern)) { + return(NULL) + } + esc <- gsub("'", "''", pattern, fixed = TRUE) + sql <- sprintf( + "regexp_matches(%s, '%s', 'i') AND regexp_matches(%s, '^[ -~]*$')", + db_qident(drug_col), esc, db_qident(drug_col) + ) + if (length(roles)) { + sql <- sprintf( + "(%s AND role_cod IN (%s))", + sql, paste0("'", roles, "'", collapse = ", ") + ) + } + sql +} + +# Pushed-down reports matching every/any pattern, restricted to pure-ASCII +# drug values, with SQL-safe report-level exclusions. The caller unions the +# non-ASCII rows re-matched in R (see faers_reports_with) so both backends +# always agree on the folded result. +.reports_with_ids_db <- function(con, patterns, logic, roles, excludes, drug_col) { + conds <- vapply(patterns, function(p) { + c <- .reports_with_sql_cond(p, roles[[p]], drug_col) + if (is.null(c)) return(NA_character_) + sprintf( + "SELECT DISTINCT primaryid FROM %s WHERE %s", + db_qident(db_field_table("drug")), c + ) + }, character(1L)) + if (any(is.na(conds))) { + return(NULL) # signal fallback + } + joiner <- if (identical(logic, "and")) "INTERSECT" else "UNION" + sql_ids <- paste(conds, collapse = sprintf(" %s ", joiner)) + if (length(excludes)) { + # exclude: report-level, role-agnostic. SQL-safe exclusion patterns + # are folded into the query below; unsafe ones trigger the R fallback. + safe <- vapply(excludes, .reports_with_pushdown_safe, logical(1L)) + if (!all(safe)) { + return(NULL) + } + ex_conds <- vapply(excludes, function(p) { + sprintf( + "SELECT DISTINCT primaryid FROM %s WHERE regexp_matches(%s, '%s', 'i')", + db_qident(db_field_table("drug")), db_qident(drug_col), + gsub("'", "''", p, fixed = TRUE) + ) + }, character(1L)) + sql_ids <- sprintf( + "SELECT primaryid FROM (%s) WHERE primaryid NOT IN (%s)", + sql_ids, paste(ex_conds, collapse = " UNION ") + ) + } + DBI::dbGetQuery(con, sprintf("SELECT DISTINCT primaryid FROM (%s)", sql_ids))$primaryid +} + +# SQL fragment collecting the non-ASCII drug rows the pushed-down condition +# deliberately skipped: their folding is decided in R by TRE, which both +# backends treat as the baseline. Only (primaryid, drug value, role) rows that +# the ASCII guard excluded are fetched, so this stays cheap in practice. +.reports_with_nonascii_db <- function(con, drug_col) { + DBI::dbGetQuery( + con, + sprintf( + "SELECT primaryid, %s AS drug_value, role_cod FROM %s WHERE %s IS NOT NULL AND NOT regexp_matches(%s, '^[ -~]*$')", + db_qident(drug_col), db_qident(db_field_table("drug")), + db_qident(drug_col), db_qident(drug_col) + ) + ) +} + +# ---------- main entry ---------- + +#' Build a report set from drug exposure conditions +#' +#' `faers_reports_with()` constructs a report sub-population from a +#' standardized FAERS object: reports whose drug records match a combination +#' of drug name patterns, optionally restricted to specific +#' [role codes][faers_phv_scan] and optionally excluding reports containing +#' other (concomitant) drugs. +#' +#' @details +#' ## What this function is — and is not +#' +#' `faers_reports_with()` is a **report set constructor**: it computes the set +#' of reports matching an exposure definition, for report counting, set +#' operations (AND/OR/exclusion) and sub-population exploration. +#' +#' It is **not** a drug-interaction or combination-toxicity analysis. Running +#' a disproportionality scan inside the returned subset uses the same exposure +#' definition for every drug, so there is no unexposed comparator group and +#' the 2x2 contingency table is not defined there. Keep set construction and +#' signal scanning as separate steps. +#' +#' ## Matching semantics +#' +#' Each pattern is a case-insensitive regular expression evaluated against +#' every drug row of a report (`grepl(..., ignore.case = TRUE)` semantics). +#' A report matches a pattern when **at least one** of its drug rows satisfies +#' it; under `.logic = "and"` all patterns must be satisfiable, and two +#' patterns **may be satisfied by the same drug row** (relevant for +#' fixed-dose combination products or `prod_ai` entries listing several +#' ingredients in one row). +#' +#' `.roles` restricts *which drug rows* may satisfy a pattern (e.g. only +#' primary-suspect rows). Unlisted drugs are unrestricted; role-constrained +#' and unrestricted rows are pooled per pattern (union within a drug). +#' +#' `.exclude_drugs` is report-level and role-agnostic: any drug row matching +#' an exclusion pattern removes the whole report, regardless of its role code. +#' +#' ## DuckDB pushdown +#' +#' For database-backed objects a pattern is pushed into SQL +#' (`regexp_matches(col, pattern, 'i')`) only when it is a plain literal +#' (letters, digits, spaces, underscores, hyphens). Any other pattern — +#' character classes, quantifiers, lookarounds — is matched in R after +#' collecting the drug table, so both backends always agree on the matched +#' report set. Pushed-down `"count"` results are computed in the database +#' without collecting report identifiers. +#' +#' ## Empty results +#' +#' Legal conditions that match zero reports are not an error: an empty object, +#' `character(0)` or `0L` is returned. `faers_reports_with()` is a +#' constructor — an empty set is a legitimate result. +#' +#' @param .object A [FAERSascii] object. Standardization is required; +#' de-duplication is recommended (duplicate drug rows do not double-count +#' reports). +#' @param .drugs Character vector of drug name patterns (regular +#' expressions, case-insensitive). Each must match at least one drug row of +#' a report. +#' @param .roles A named list restricting the acceptable `role_cod` values +#' per drug, e.g. `list(warfarin = c("PS", "SS"))`. Names must be elements +#' of `.drugs`; drugs without an entry are unrestricted. Valid codes: +#' `"PS"` (primary suspect), `"SS"` (secondary suspect), `"C"` +#' (concomitant), `"I"` (interacting). +#' @param .logic `"and"` (default): every pattern must match. `"or"`: at +#' least one pattern must match. +#' @param .exclude_drugs Optional character vector of patterns; reports with +#' any drug row matching one of them are removed (any role). +#' @param .drug_col Optional name of the drug column to match against +#' (default: `drugname`, falling back to `prod_ai`). +#' @param .return What to return: `"object"` (default, the filtered +#' [FAERSascii]), `"ids"` (sorted unique `primaryid` character vector) or +#' `"count"` (integer scalar). +#' +#' @return +#' * `.return = "object"`: the filtered [FAERSascii] object. +#' * `.return = "ids"`: sorted, unique `primaryid` character vector. +#' * `.return = "count"`: `integer(1)`, the number of matched reports. +#' +#' @examples +#' data <- readRDS(system.file("extdata", "standardized_data.rds", package = "faers")) +#' data <- faers_dedup(data) +#' +#' # reports containing Humalog in any role +#' n <- faers_reports_with(data, "humalog", .return = "count") +#' +#' # AND combination + per-drug role constraints + exclusion of a comedication +#' ids <- suppressMessages(faers_reports_with( +#' data, +#' c("humalog", "glyburide"), +#' .roles = list(humalog = c("PS", "SS")), +#' .exclude_drugs = "avandia", +#' .return = "ids" +#' )) +#' length(ids) +#' +#' @seealso [faers_restrict()] for report-level (demographic) restrictions, +#' [faers_phv_scan()] for signal detection. +#' @export +faers_reports_with <- function(.object, .drugs, .roles = NULL, + .logic = c("and", "or"), + .exclude_drugs = NULL, .drug_col = NULL, + .return = c("object", "ids", "count")) { + .logic <- match.arg(.logic) + .return <- match.arg(.return) + .drugs <- .reports_with_check_drugs(.drugs) + .roles <- .reports_with_check_roles(.roles, .drugs) + .exclude_drugs <- .reports_with_check_exclude(.exclude_drugs) + assert_s3_class(.object, "FAERSascii") + if (!.object@standardization) { + cli::cli_abort("{.arg .object} must be standardized using {.fn faers_standardize}") + } + + drug_col <- .reports_with_pick_col(.object, .drug_col) + + # ---- resolve the matched report set ---- + if (!is.null(.object@db)) { + db_ids_raw <- .reports_with_ids_db( + .object@db@con, .drugs, .logic, .roles, .exclude_drugs, drug_col + ) + ids <- db_ids_raw + if (is.null(ids)) { + # non-pushdown-safe pattern (or mixed): collect + match in R + drug <- faers_get(.object, "drug") + ids <- .reports_with_ids_mem( + drug, .drugs, .logic, .roles, .exclude_drugs, drug_col + ) + } else { + # RE2 folds Unicode where TRE does not (Kelvin sign vs "k"), so + # pushed-down matches are confined to ASCII rows. Re-match the + # non-ASCII rows here and union, so the report set is identical + # to the memory backend's TRE semantics. + nonascii <- .reports_with_nonascii_db(.object@db@con, drug_col) + if (nrow(nonascii)) { + nonascii <- data.table::as.data.table(nonascii) + data.table::setnames(nonascii, "drug_value", drug_col) + nonascii_ids <- .reports_with_ids_mem( + nonascii, .drugs, .logic, .roles, .exclude_drugs, drug_col + ) + ids <- union(ids, nonascii_ids) + } + } + } else { + drug <- faers_get(.object, "drug") + ids <- .reports_with_ids_mem( + drug, .drugs, .logic, .roles, .exclude_drugs, drug_col + ) + } + ids <- sort(unique(as.character(ids))) + + # ---- diagnostics: per-pattern hit counts (message, not warning) ---- + # On the pushed-down db path these are COUNT(DISTINCT primaryid) queries; + # nothing is materialized. Other paths already hold `drug` in memory. + drug_col_name <- drug_col + if (!is.null(.object@db) && !is.null(db_ids_raw)) { + per_hit <- vapply(seq_along(.drugs), function(i) { + cond <- .reports_with_sql_cond( + .drugs[[i]], .roles[[.drugs[[i]]]], drug_col_name + ) + as.integer(DBI::dbGetQuery( + .object@db@con, + sprintf( + "SELECT COUNT(DISTINCT primaryid) AS n FROM %s WHERE %s", + db_qident(db_field_table("drug")), cond + ) + )$n[[1L]]) + }, integer(1L)) + } else { + per_hit <- vapply(.drugs, function(p) { + length(.reports_with_ids_mem( + drug, p, "or", .roles, character(), drug_col_name + )) + }, integer(1L)) + } + if (length(ids) || any(per_hit > 0L)) { + cli::cli_inform( + "{.fn faers_reports_with} matched {length(ids)} report{?s}: {.val {paste0(.drugs, \": \", per_hit)}}" + ) + } + + # ---- return forms ---- + if (identical(.return, "count")) { + return(as.integer(length(ids))) + } + if (identical(.return, "ids")) { + return(as.character(ids)) + } + # "object": db objects get a private deep copy BEFORE faers_keep, because + # faers_keep_db() physically DELETEs rows from the shared connection. + if (!is.null(.object@db)) { + .object <- restrict_private_db_copy(.object) + } + faers_keep(.object, ids, invert = FALSE) +} + +# Pick the drug name column: `drugname` when present, else `prod_ai`, +# unless the user names one explicitly. Errors when nothing usable exists +# (e.g. a quarter lacking prod_ai) instead of silently matching nothing. +.reports_with_pick_col <- function(.object, .drug_col = NULL) { + if (!is.null(.object@db)) { + # DESCRIBE is metadata-only: no table materialization on the db path. + drug_cols <- DBI::dbGetQuery( + .object@db@con, sprintf("DESCRIBE %s", db_field_table("drug")) + )$column_name + } else { + drug_cols <- names(faers_get(.object, "drug")) + } + drug_col_nm <- .drug_col + if (!is.null(.drug_col)) { + if (!.drug_col %chin% drug_cols) { + cli::cli_abort(c( + "{.arg .drug_col} {.val {drug_col_nm}} not found in drug data", + i = "Available: {.val {drug_cols}}" + )) + } + return(.drug_col) + } + if ("drugname" %chin% drug_cols) { + return("drugname") + } + if ("prod_ai" %chin% drug_cols) { + cli::cli_inform( + "{.field drugname} not found; falling back to {.field prod_ai} for drug matching" + ) + return("prod_ai") + } + cli::cli_abort(c( + "Neither {.val {\"drugname\"}} nor {.val {\"prod_ai\"}} found in drug data", + i = "Pass {.arg .drug_col} explicitly to choose a column" + )) +} \ No newline at end of file diff --git a/man/faers_reports_with.Rd b/man/faers_reports_with.Rd new file mode 100644 index 0000000..1e92d58 --- /dev/null +++ b/man/faers_reports_with.Rd @@ -0,0 +1,130 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/restrict-drug.R +\name{faers_reports_with} +\alias{faers_reports_with} +\title{Build a report set from drug exposure conditions} +\usage{ +faers_reports_with( + .object, + .drugs, + .roles = NULL, + .logic = c("and", "or"), + .exclude_drugs = NULL, + .drug_col = NULL, + .return = c("object", "ids", "count") +) +} +\arguments{ +\item{.object}{A \link{FAERSascii} object. Standardization is required; +de-duplication is recommended (duplicate drug rows do not double-count +reports).} + +\item{.drugs}{Character vector of drug name patterns (regular +expressions, case-insensitive). Each must match at least one drug row of +a report.} + +\item{.roles}{A named list restricting the acceptable \code{role_cod} values +per drug, e.g. \code{list(warfarin = c("PS", "SS"))}. Names must be elements +of \code{.drugs}; drugs without an entry are unrestricted. Valid codes: +\code{"PS"} (primary suspect), \code{"SS"} (secondary suspect), \code{"C"} +(concomitant), \code{"I"} (interacting).} + +\item{.logic}{\code{"and"} (default): every pattern must match. \code{"or"}: at +least one pattern must match.} + +\item{.exclude_drugs}{Optional character vector of patterns; reports with +any drug row matching one of them are removed (any role).} + +\item{.drug_col}{Optional name of the drug column to match against +(default: \code{drugname}, falling back to \code{prod_ai}).} + +\item{.return}{What to return: \code{"object"} (default, the filtered +\link{FAERSascii}), \code{"ids"} (sorted unique \code{primaryid} character vector) or +\code{"count"} (integer scalar).} +} +\value{ +\itemize{ +\item \code{.return = "object"}: the filtered \link{FAERSascii} object. +\item \code{.return = "ids"}: sorted, unique \code{primaryid} character vector. +\item \code{.return = "count"}: \code{integer(1)}, the number of matched reports. +} +} +\description{ +\code{faers_reports_with()} constructs a report sub-population from a +standardized FAERS object: reports whose drug records match a combination +of drug name patterns, optionally restricted to specific +\link[=faers_phv_scan]{role codes} and optionally excluding reports containing +other (concomitant) drugs. +} +\details{ +\subsection{What this function is — and is not}{ + +\code{faers_reports_with()} is a \strong{report set constructor}: it computes the set +of reports matching an exposure definition, for report counting, set +operations (AND/OR/exclusion) and sub-population exploration. + +It is \strong{not} a drug-interaction or combination-toxicity analysis. Running +a disproportionality scan inside the returned subset uses the same exposure +definition for every drug, so there is no unexposed comparator group and +the 2x2 contingency table is not defined there. Keep set construction and +signal scanning as separate steps. +} + +\subsection{Matching semantics}{ + +Each pattern is a case-insensitive regular expression evaluated against +every drug row of a report (\code{grepl(..., ignore.case = TRUE)} semantics). +A report matches a pattern when \strong{at least one} of its drug rows satisfies +it; under \code{.logic = "and"} all patterns must be satisfiable, and two +patterns \strong{may be satisfied by the same drug row} (relevant for +fixed-dose combination products or \code{prod_ai} entries listing several +ingredients in one row). + +\code{.roles} restricts \emph{which drug rows} may satisfy a pattern (e.g. only +primary-suspect rows). Unlisted drugs are unrestricted; role-constrained +and unrestricted rows are pooled per pattern (union within a drug). + +\code{.exclude_drugs} is report-level and role-agnostic: any drug row matching +an exclusion pattern removes the whole report, regardless of its role code. +} + +\subsection{DuckDB pushdown}{ + +For database-backed objects a pattern is pushed into SQL +(\code{regexp_matches(col, pattern, 'i')}) only when it is a plain literal +(letters, digits, spaces, underscores, hyphens). Any other pattern — +character classes, quantifiers, lookarounds — is matched in R after +collecting the drug table, so both backends always agree on the matched +report set. Pushed-down \code{"count"} results are computed in the database +without collecting report identifiers. +} + +\subsection{Empty results}{ + +Legal conditions that match zero reports are not an error: an empty object, +\code{character(0)} or \code{0L} is returned. \code{faers_reports_with()} is a +constructor — an empty set is a legitimate result. +} +} +\examples{ +data <- readRDS(system.file("extdata", "standardized_data.rds", package = "faers")) +data <- faers_dedup(data) + +# reports containing Humalog in any role +n <- faers_reports_with(data, "humalog", .return = "count") + +# AND combination + per-drug role constraints + exclusion of a comedication +ids <- suppressMessages(faers_reports_with( + data, + c("humalog", "glyburide"), + .roles = list(humalog = c("PS", "SS")), + .exclude_drugs = "avandia", + .return = "ids" +)) +length(ids) + +} +\seealso{ +\code{\link[=faers_restrict]{faers_restrict()}} for report-level (demographic) restrictions, +\code{\link[=faers_phv_scan]{faers_phv_scan()}} for signal detection. +} diff --git a/tests/testthat/test_restrict-drug.R b/tests/testthat/test_restrict-drug.R new file mode 100644 index 0000000..7701df2 --- /dev/null +++ b/tests/testthat/test_restrict-drug.R @@ -0,0 +1,343 @@ +# Tests for faers_reports_with (drug-exposure report set constructor). +# +# The bundled sample (200 standardized reports) supplies realistic drug rows; +# a hand-crafted synthetic object covers exact AND/OR/role/exclude semantics, +# fixed-dose same-row matching and regex edge cases. duckdb parity tests +# reuse the twin-building pattern of test_duckdb.R / test_scan.R and are +# skipped when duckdb is not installed. + +has_duckdb <- requireNamespace("duckdb", quietly = TRUE) && + requireNamespace("DBI", quietly = TRUE) + +reports_sample_object <- function() { + rds <- readRDS(system.file("extdata", "standardized_data.rds", package = "faers")) + sl <- list() + for (sn in methods::slotNames("FAERSascii")) { + sl[[sn]] <- tryCatch(methods::slot(rds, sn), error = function(e) NULL) + } + obj <- do.call(methods::new, c(list(Class = "FAERSascii"), sl)) + obj@deduplication <- TRUE + obj +} + +# A tiny standardized object with known drug contents: +# 1 -> ASPIRIN(PS), TYLENOL(C) 2 -> "aspirin "(SS) [trailing space] +# 3 -> BUFFERIN(C) 4 -> IBUPROFEN(PS), ASPIRIN(SS) +# 5 -> "aspirin and dipyridamole" (one fixed-dose combination row) +reports_synth_object <- function() { + obj <- reports_sample_object() + obj@data$demo <- data.table::data.table( + year = 2004L, quarter = "q1", primaryid = as.character(1:5) + ) + obj@data$drug <- data.table::data.table( + year = 2004L, quarter = "q1", + primaryid = c("1", "1", "2", "3", "4", "4", "5"), + drug_seq = 1:7, + role_cod = c("PS", "C", "SS", "C", "PS", "SS", "PS"), + drugname = c( + "ASPIRIN", "TYLENOL", "aspirin ", "BUFFERIN", + "IBUPROFEN", "ASPIRIN", "ASPIRIN AND DIPYRIDAMOLE" + ), + prod_ai = c( + "ASPIRIN", "ACETAMINOPHEN", "ASPIRIN", "BUFFERIN", + "IBUPROFEN", "ASPIRIN", "ASPIRIN AND DIPYRIDAMOLE" + ) + ) + obj +} + +testthat::test_that("faers_reports_with validates inputs", { + obj <- reports_sample_object() + + # .drugs type/emptiness + expect_error(faers_reports_with(obj, NULL), "character vector") + expect_error(faers_reports_with(obj, character()), "character vector") + expect_error(faers_reports_with(obj, c("a", "")), "empty strings") + + # duplicated patterns + expect_error(faers_reports_with(obj, c("a", "a")), "duplicated") + + # invalid regex aborts with the offending pattern named + expect_error(faers_reports_with(obj, "warfarin("), "Invalid regular expression") + + # bad roles: unknown drug, unknown code, empty, unnamed, duplicated name + expect_error( + faers_reports_with(obj, "aspirin", .roles = list(nope = "PS")), + "not listed" + ) + expect_error( + faers_reports_with(obj, "aspirin", .roles = list(aspirin = "XX")), + "Invalid role code" + ) + expect_error( + faers_reports_with(obj, "aspirin", .roles = list(aspirin = character())), + "non-empty" + ) + expect_error(faers_reports_with(obj, "aspirin", .roles = list("PS")), "named list") + + # standardization guard + raw <- reports_sample_object() + raw@standardization <- FALSE + expect_error(faers_reports_with(raw, "aspirin"), "standardized") +}) + +testthat::test_that("faers_reports_with single pattern counts and sorts ids", { + obj <- reports_synth_object() + ids <- suppressMessages(faers_reports_with(obj, "aspirin", .return = "ids")) + # reports 1, 2, 4, 5 (case/trailing-space variants included) + expect_setequal(ids, c("1", "2", "4", "5")) + expect_identical(as.character(ids), as.character(sort(ids))) + expect_identical( + suppressMessages(faers_reports_with(obj, "aspirin", .return = "count")), + 4L + ) + # case-insensitive parity + expect_identical( + suppressMessages(faers_reports_with(obj, "ASPIRIN", .return = "ids")), + ids + ) +}) + +testthat::test_that("faers_reports_with AND requires every pattern, OR any", { + obj <- reports_synth_object() + n_or <- suppressMessages(faers_reports_with( + obj, c("aspirin", "ibuprofen"), .logic = "or", .return = "count" + )) + n_and <- suppressMessages(faers_reports_with( + obj, c("aspirin", "ibuprofen"), .return = "count" + )) + expect_identical(n_or, 4L) # aspirin reports 1,2,4,5 + ibuprofen 4 + expect_identical(n_and, 1L) # only report 4 has both +}) + +testthat::test_that("faers_reports_with AND allows one row to satisfy two patterns", { + obj <- reports_synth_object() + # report 5's single row "ASPIRIN AND DIPYRIDAMOLE" must satisfy both + ids <- suppressMessages(faers_reports_with( + obj, c("aspirin", "dipyridamole"), .return = "ids" + )) + expect_true("5" %in% ids) +}) + +testthat::test_that("faers_reports_with roles are strict and effective", { + obj <- reports_synth_object() + # aspirin unrestricted: 4 reports; PS only: reports 1 (ASPIRIN PS) + n_any <- suppressMessages(faers_reports_with(obj, "aspirin", .return = "count")) + n_ps <- suppressMessages(faers_reports_with( + obj, "aspirin", .roles = list(aspirin = "PS"), .return = "count" + )) + expect_identical(n_ps, 2L) # report 1 (PS) + report 4 (ASPIRIN PS row) + expect_true(n_ps < n_any) + # unspecified drugs stay unrestricted + n_mixed <- suppressMessages(faers_reports_with( + obj, c("aspirin", "ibuprofen"), + .roles = list(aspirin = "PS"), .return = "count" + )) + expect_identical(n_mixed, 0L) # no report has both: ibuprofen AND aspirin-PS + # OR with role restriction: aspirin PS (1,4) ∪ ibuprofen unrestricted (4) + # ∪ dipyridamole (5, unrestricted) = 3 + n_or <- suppressMessages(faers_reports_with( + obj, c("aspirin", "ibuprofen"), + .roles = list(aspirin = "PS"), .logic = "or", .return = "count" + )) + expect_identical(n_or, 3L) + expect_true(n_or <= 4L) # never exceeds unrestricted OR +}) + +testthat::test_that("faers_reports_with excludes reports at the report level", { + obj <- reports_synth_object() + # excluding aspirin also removes reports whose aspirin row is only C/SS + ids <- suppressMessages(faers_reports_with( + obj, "ibuprofen", .exclude_drugs = "aspirin", .return = "ids" + )) + expect_setequal(ids, character(0)) # report 4 also has aspirin + # role-agnostic exclusion: C-role aspirin row also triggers exclusion + n_with <- suppressMessages(faers_reports_with(obj, "ibuprofen", .return = "count")) + n_without <- suppressMessages(faers_reports_with( + obj, "ibuprofen", .exclude_drugs = "aspirin", .return = "count" + )) + expect_identical(n_without, 0L) + expect_identical(n_with, 1L) +}) + +testthat::test_that("faers_reports_with handles regex special characters identically", { + obj <- reports_synth_object() + # dot + quantifier + anchors: "^aspi. n$" can never match (no "ASPIRN"), + # a proven zero-hit; the class form "asp[i]rin" must match like grepl + expect_identical( + suppressMessages(faers_reports_with(obj, "^aspi. n$", .return = "ids")), + character(0) + ) + # character class (grepl semantics is the frozen baseline): + # "asp[i]rin" matches ASPIRIN rows like grepl would + ids_class <- suppressMessages(faers_reports_with( + obj, "asp[i]rin", .return = "ids" + )) + expect_setequal(ids_class, c("1", "2", "4", "5")) + # a literal '-' pattern still matches names containing hyphens + ids_dash <- suppressMessages(faers_reports_with(obj, "AND DIPYRIDAMOLE", .return = "ids")) + expect_setequal(ids_dash, c("5")) +}) + +testthat::test_that("faers_reports_with returns empty sets without error", { + obj <- reports_synth_object() + expect_identical( + suppressMessages(faers_reports_with(obj, "zzzz", .return = "count")), 0L + ) + expect_identical( + suppressMessages(faers_reports_with(obj, "zzzznope", .return = "ids")), + character(0) + ) + o0 <- suppressMessages(faers_reports_with(obj, "zzzznope")) + expect_s4_class(o0, "FAERSascii") + expect_identical(nrow(faers_get(o0, "demo")), 0L) + # OR with one zero-hit pattern still returns the other's hits + n <- suppressMessages(faers_reports_with( + obj, c("aspirin", "zzzznope"), .logic = "or", .return = "count" + )) + expect_identical(n, 4L) +}) + +testthat::test_that("faers_reports_with returns object, ids and count forms", { + obj <- reports_synth_object() + ids <- suppressMessages(faers_reports_with(obj, "aspirin", .return = "ids")) + expect_type(ids, "character") + expect_true(!anyDuplicated(ids)) + + count <- suppressMessages(faers_reports_with(obj, "aspirin", .return = "count")) + expect_identical(count, as.integer(length(ids))) + + o <- suppressMessages(faers_reports_with(obj, "aspirin")) + expect_s4_class(o, "FAERSascii") + expect_setequal(as.character(faers_get(o, "demo")$primaryid), ids) + # flags survive + expect_true(o@standardization) + expect_true(o@deduplication) + # input untouched + expect_identical(nrow(faers_get(obj, "demo")), 5L) + expect_identical(nrow(faers_get(obj, "drug")), 7L) +}) + +testthat::test_that("faers_reports_with pick-column logic", { + obj <- reports_synth_object() + # prod_ai matches too (same rows here), but drugname wins by default + expect_silent(suppressMessages( + faers_reports_with(obj, "dipyridamole", .return = "ids") + )) + # explicit drugname column: "bufferin" matches BUFFERIN (ignore.case) + n <- suppressMessages(faers_reports_with( + obj, "bufferin", .drug_col = "drugname", .return = "count" + )) + expect_identical(n, 1L) + # unknown column aborts + expect_error( + suppressMessages(faers_reports_with(obj, "aspirin", .drug_col = "nope")), + "not found" + ) +}) + +testthat::test_that("faers_reports_with missing name columns aborts clearly", { + obj <- reports_synth_object() + obj@data$drug$drugname <- NULL + obj@data$drug$prod_ai <- NULL + expect_error(suppressMessages(faers_reports_with(obj, "aspirin")), "explicitly") +}) + +testthat::test_that("faers_reports_with duplicated drug rows do not double count", { + obj <- reports_synth_object() + drug <- data.table::copy(faers_get(obj, "drug")) + extra <- data.table::copy(drug[1L]) + extra$drug_seq <- 99L + obj@data$drug <- data.table::rbindlist(list(drug, extra), use.names = TRUE) + n <- suppressMessages(faers_reports_with(obj, "aspirin", .return = "count")) + expect_identical(n, 4L) # duplicate rows never double-count reports +}) + +# Build a duckdb twin of a memory object (test_scan.R / test_duckdb.R pattern). +# Caller owns the connection lifecycle: pass a fresh con and defer its shutdown. +reports_db_twin <- function(mem_obj, con) { + ns <- asNamespace("faers") + tables <- ns$db_field_tables() + for (f in names(mem_obj@data)) ns$db_ingest(con, f, mem_obj@data[[f]]) + ns$db_ingest_meddra(con, mem_obj) + proxies <- stats::setNames(lapply(names(mem_obj@data), function(f) { + methods::new("FAERSdbTbl", con = con, table = tables[[f]]) + }), names(mem_obj@data)) + methods::new("FAERSascii", + data = proxies, deletedCases = methods::slot(mem_obj, "deletedCases"), + year = mem_obj@year, quarter = mem_obj@quarter, + standardization = TRUE, deduplication = TRUE, + format = mem_obj@format, meddra = mem_obj@meddra, + db = methods::new("FAERSdb", con = con, path = ":memory:", + version = as.character(packageVersion("duckdb")), tables = tables) + ) +} + +testthat::test_that("faers_reports_with parity on db twin (AND/OR/roles/exclude/regex)", { + testthat::skip_if_not(has_duckdb) + ns <- asNamespace("faers") + mem <- reports_synth_object() + con <- ns$db_connect(":memory:") + withr::defer(try(DBI::dbDisconnect(con, shutdown = TRUE), silent = TRUE)) + db_obj <- reports_db_twin(mem, con) + + # literal pattern: pushed down on db, plain grepl on memory + expect_identical( + suppressMessages(faers_reports_with(mem, "aspirin", .return = "ids")), + suppressMessages(faers_reports_with(db_obj, "aspirin", .return = "ids")) + ) + # OR + roles + exclude (pushed-down path) + m <- suppressMessages(faers_reports_with( + mem, c("aspirin", "ibuprofen"), .logic = "or", + .roles = list(aspirin = "PS"), .exclude_drugs = "tylenol", + .return = "ids" + )) + d <- suppressMessages(faers_reports_with( + db_obj, c("aspirin", "ibuprofen"), .logic = "or", + .roles = list(aspirin = "PS"), .exclude_drugs = "tylenol", + .return = "ids" + )) + expect_identical(m, d) + # regex pattern: falls back to R matching on db, identical to memory + d_rx <- suppressMessages(faers_reports_with(db_obj, "asp[i]rin", .return = "ids")) + expect_setequal(d_rx, c("1", "2", "4", "5")) + # mixed pushdown/fallback also matches memory semantics + d_mix <- suppressMessages(faers_reports_with( + db_obj, c("aspirin", "^ibu"), .logic = "or", .return = "ids" + )) + expect_setequal(d_mix, c("1", "2", "4", "5")) + m_mix <- suppressMessages(faers_reports_with( + mem, c("aspirin", "^ibu"), .logic = "or", .return = "ids" + )) + expect_identical(d_mix, m_mix) + expect_identical( + suppressMessages(faers_reports_with(mem, "aspirin", .return = "count")), + suppressMessages(faers_reports_with(db_obj, "aspirin", .return = "count")) + ) +}) + +testthat::test_that("faers_reports_with leaves the source db untouched across builds", { + testthat::skip_if_not(has_duckdb) + ns <- asNamespace("faers") + mem <- reports_synth_object() + con <- ns$db_connect(":memory:") + withr::defer(try(DBI::dbDisconnect(con, shutdown = TRUE), silent = TRUE)) + db_obj <- reports_db_twin(mem, con) + n0 <- ns$db_nrow(con, "drug") + # a sequence of constructors and object-mode returns on the SAME db + o1 <- suppressMessages(faers_reports_with(db_obj, "aspirin")) + o2 <- suppressMessages(faers_reports_with(db_obj, "ibuprofen")) + i1 <- suppressMessages(faers_reports_with(db_obj, "aspirin", .return = "ids")) + i2 <- suppressMessages(faers_reports_with(db_obj, "ibuprofen", .return = "ids")) + expect_identical(ns$db_nrow(con, "drug"), n0) # untouched + expect_identical(i1, c("1", "2", "4", "5")) + expect_identical(i2, c("4")) + # object-mode returns filter their own private copy, not the shared db + expect_setequal(as.character(faers_get(o1, "demo")$primaryid), c("1", "2", "4", "5")) + expect_setequal(as.character(faers_get(o2, "demo")$primaryid), c("4")) + # and the original still sees the full data + expect_identical( + suppressMessages(faers_reports_with(db_obj, "aspirin", .return = "count")), + 4L + ) +}) From b78eed7a7c92547d2bd309a9b8fa84d979882f67 Mon Sep 17 00:00:00 2001 From: MadDERt <2129882365@qq.com> Date: Fri, 30 Oct 2026 10:58:47 +0800 Subject: [PATCH 2/4] fix CI: guard network-dependent example and meta test (FDA rejects GitHub runners) --- R/available.R | 3 ++- R/meta.R | 3 ++- man/faers_available.Rd | 3 ++- man/faers_meta.Rd | 3 ++- tests/testthat/test_meta.R | 1 + 5 files changed, 9 insertions(+), 4 deletions(-) diff --git a/R/available.R b/R/available.R index 2c960a1..3073123 100644 --- a/R/available.R +++ b/R/available.R @@ -10,7 +10,8 @@ #' @return A logical indicates FAERS can have data for the `years` and #' `quarters` required? #' @examples -#' faers_available(c(2011, 2023), c("q1", "q2")) +#' # Queries the FDA website (falls back to bundled metadata without internet): +#' faers_available(c(2011, 2023), c("q1", "q2"), internal = !curl::has_internet()) #' @export faers_available <- function(years, quarters, force = FALSE, internal = FALSE) { assert_inclusive(quarters, FAERS_FILE_QUARTERS) diff --git a/R/meta.R b/R/meta.R index 1a9b932..6bbd66a 100644 --- a/R/meta.R +++ b/R/meta.R @@ -11,7 +11,8 @@ #' @return A [data.table][data.table::data.table] reporting years, period, #' quarter, and file urls and file sizes. #' @examples -#' faers_meta() +#' # Queries the FDA website (falls back to bundled metadata without internet): +#' faers_meta(internal = !curl::has_internet()) #' @seealso #' #' @export diff --git a/man/faers_available.Rd b/man/faers_available.Rd index 8968113..76ca24c 100644 --- a/man/faers_available.Rd +++ b/man/faers_available.Rd @@ -28,5 +28,6 @@ This function check if data for the years and quarters selected are available at FAERS to be downloaded. } \examples{ -faers_available(c(2011, 2023), c("q1", "q2")) +# Queries the FDA website (falls back to bundled metadata without internet): +faers_available(c(2011, 2023), c("q1", "q2"), internal = !curl::has_internet()) } diff --git a/man/faers_meta.Rd b/man/faers_meta.Rd index 049ab4d..85e74eb 100644 --- a/man/faers_meta.Rd +++ b/man/faers_meta.Rd @@ -23,7 +23,8 @@ The function lists the metadata for the FAERS databases currently available to download. } \examples{ -faers_meta() +# Queries the FDA website (falls back to bundled metadata without internet): +faers_meta(internal = !curl::has_internet()) } \seealso{ \url{https://fis.fda.gov/extensions/FPD-QDE-FAERS/FPD-QDE-FAERS.html} diff --git a/tests/testthat/test_meta.R b/tests/testthat/test_meta.R index 61c6638..dcf5b39 100644 --- a/tests/testthat/test_meta.R +++ b/tests/testthat/test_meta.R @@ -1,4 +1,5 @@ testthat::test_that("Parsing external FAERS metadata works well", { + testthat::skip_on_cran() testthat::skip_if_offline() testthat::expect_message(gds <- faers_meta(force = TRUE), "Reading html") testthat::expect_s3_class(gds, "data.table") From e0617f6168a1ac101e61119d3889e805f29f555b Mon Sep 17 00:00:00 2001 From: MadDERt <2129882365@qq.com> Date: Fri, 30 Oct 2026 16:12:50 +0800 Subject: [PATCH 3/4] fix: correct mixed-character drug report matching --- NEWS.md | 3 +- R/restrict-drug.R | 168 ++++++++++------------------ man/faers_reports_with.Rd | 5 +- tests/testthat/test_restrict-drug.R | 131 ++++++++++++++++++++++ 4 files changed, 192 insertions(+), 115 deletions(-) diff --git a/NEWS.md b/NEWS.md index 86a678a..a184795 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,7 +9,8 @@ the same drug row (fixed-dose combination products). Returns the filtered object, sorted `primaryid` vector or a count. On duckdb-backed objects plain-literal patterns are pushed down to SQL (`regexp_matches`), other - patterns fall back to identical R matching, so both backends always agree; + patterns fall back to identical R matching. Per-drug matches are combined + across ASCII and non-ASCII rows before AND/OR and report-level exclusions; object-mode returns build on a private copy, leaving the source database untouched. Per-pattern hit counts are reported as a message; empty result sets are a legitimate outcome, not an error. diff --git a/R/restrict-drug.R b/R/restrict-drug.R index 0b7d3db..5985cb7 100644 --- a/R/restrict-drug.R +++ b/R/restrict-drug.R @@ -154,27 +154,31 @@ # ---------- shared matching core (memory backend) ---------- -# Reports whose drug rows satisfy every/any pattern. Same row may satisfy -# several patterns (fixed-dose combination rows). Per-drug roles (named list -# keyed by pattern) restrict which drug rows may satisfy that pattern; -# patterns without a role entry may be satisfied by any role. -.reports_with_ids_mem <- function(drug, patterns, logic, roles, excludes, drug_col) { - hit <- function(pattern, roles) { - out <- grepl(pattern, drug[[drug_col]], ignore.case = TRUE) - if (length(roles)) out <- out & drug$role_cod %chin% roles - out - } - id_sets <- lapply(patterns, function(p) { - unique(drug$primaryid[hit(p, roles[[p]])]) +# Row-level fold matching with optional per-pattern role restriction. Returns +# a logical vector aligned with `drug`'s rows. R matching defines the +# semantics for the memory backend and the non-ASCII / regex SQL fallback. +.reports_with_row_hit <- function(drug, pattern, roles, drug_col) { + out <- grepl(pattern, drug[[drug_col]], ignore.case = TRUE) + if (length(roles)) out <- out & drug$role_cod %chin% roles + out +} + +# Build one report set per pattern before applying any report-level logic. +.reports_with_sets_mem <- function(drug, patterns, roles, drug_col) { + lapply(patterns, function(p) { + unique(drug$primaryid[ + .reports_with_row_hit(drug, p, roles[[p]], drug_col) + ]) }) - ids <- if (identical(logic, "and")) Reduce(intersect, id_sets) else unique(unlist(id_sets)) - if (length(excludes)) { - ex <- lapply(excludes, function(p) { - drug$primaryid[grepl(p, drug[[drug_col]], ignore.case = TRUE)] - }) - ids <- setdiff(ids, unique(unlist(ex, use.names = FALSE))) - } - ids +} + +# Every pattern's set already includes all matching rows, regardless of +# character encoding. Exclusions are also report sets from the complete +# drug table, and are applied only after AND/OR has been resolved. +.reports_with_combine <- function(id_sets, logic, exclude_sets) { + ids <- if (identical(logic, "and")) Reduce(intersect, id_sets) else Reduce(union, id_sets) + excluded <- Reduce(union, exclude_sets, init = character()) + setdiff(ids, excluded) } # ---------- db backend ---------- @@ -202,44 +206,19 @@ sql } -# Pushed-down reports matching every/any pattern, restricted to pure-ASCII -# drug values, with SQL-safe report-level exclusions. The caller unions the -# non-ASCII rows re-matched in R (see faers_reports_with) so both backends -# always agree on the folded result. -.reports_with_ids_db <- function(con, patterns, logic, roles, excludes, drug_col) { - conds <- vapply(patterns, function(p) { - c <- .reports_with_sql_cond(p, roles[[p]], drug_col) - if (is.null(c)) return(NA_character_) - sprintf( +# Union SQL's ASCII hits and R's non-ASCII hits separately for EACH pattern. +# Combining the two halves after AND/exclusion would miss cross-half matches +# or reintroduce reports whose exclusion was in the other half. +.reports_with_sets_db <- function(con, patterns, roles, drug_col, nonascii) { + nonascii_sets <- .reports_with_sets_mem(nonascii, patterns, roles, drug_col) + lapply(seq_along(patterns), function(i) { + cond <- .reports_with_sql_cond(patterns[[i]], roles[[patterns[[i]]]], drug_col) + ascii_ids <- DBI::dbGetQuery(con, sprintf( "SELECT DISTINCT primaryid FROM %s WHERE %s", - db_qident(db_field_table("drug")), c - ) - }, character(1L)) - if (any(is.na(conds))) { - return(NULL) # signal fallback - } - joiner <- if (identical(logic, "and")) "INTERSECT" else "UNION" - sql_ids <- paste(conds, collapse = sprintf(" %s ", joiner)) - if (length(excludes)) { - # exclude: report-level, role-agnostic. SQL-safe exclusion patterns - # are folded into the query below; unsafe ones trigger the R fallback. - safe <- vapply(excludes, .reports_with_pushdown_safe, logical(1L)) - if (!all(safe)) { - return(NULL) - } - ex_conds <- vapply(excludes, function(p) { - sprintf( - "SELECT DISTINCT primaryid FROM %s WHERE regexp_matches(%s, '%s', 'i')", - db_qident(db_field_table("drug")), db_qident(drug_col), - gsub("'", "''", p, fixed = TRUE) - ) - }, character(1L)) - sql_ids <- sprintf( - "SELECT primaryid FROM (%s) WHERE primaryid NOT IN (%s)", - sql_ids, paste(ex_conds, collapse = " UNION ") - ) - } - DBI::dbGetQuery(con, sprintf("SELECT DISTINCT primaryid FROM (%s)", sql_ids))$primaryid + db_qident(db_field_table("drug")), cond + ))$primaryid + union(ascii_ids, nonascii_sets[[i]]) + }) } # SQL fragment collecting the non-ASCII drug rows the pushed-down condition @@ -304,8 +283,9 @@ #' (letters, digits, spaces, underscores, hyphens). Any other pattern — #' character classes, quantifiers, lookarounds — is matched in R after #' collecting the drug table, so both backends always agree on the matched -#' report set. Pushed-down `"count"` results are computed in the database -#' without collecting report identifiers. +#' report set. SQL and R matches are combined per pattern before applying +#' AND/OR logic and report-level exclusions. Report identifiers are collected +#' to combine these sets, including for `"count"` results. #' #' ## Empty results #' @@ -375,65 +355,29 @@ faers_reports_with <- function(.object, .drugs, .roles = NULL, drug_col <- .reports_with_pick_col(.object, .drug_col) - # ---- resolve the matched report set ---- - if (!is.null(.object@db)) { - db_ids_raw <- .reports_with_ids_db( - .object@db@con, .drugs, .logic, .roles, .exclude_drugs, drug_col + # Match each inclusion and exclusion against the full logical drug + # table before combining report sets. Only non-ASCII rows need collecting + # on the literal SQL path; complex regexes use the existing R fallback. + if (!is.null(.object@db) && + .reports_with_pushdown_safe(c(.drugs, .exclude_drugs))) { + con <- .object@db@con + nonascii <- data.table::as.data.table(.reports_with_nonascii_db(con, drug_col)) + data.table::setnames(nonascii, "drug_value", drug_col) + id_sets <- .reports_with_sets_db(con, .drugs, .roles, drug_col, nonascii) + exclude_sets <- .reports_with_sets_db( + con, .exclude_drugs, list(), drug_col, nonascii ) - ids <- db_ids_raw - if (is.null(ids)) { - # non-pushdown-safe pattern (or mixed): collect + match in R - drug <- faers_get(.object, "drug") - ids <- .reports_with_ids_mem( - drug, .drugs, .logic, .roles, .exclude_drugs, drug_col - ) - } else { - # RE2 folds Unicode where TRE does not (Kelvin sign vs "k"), so - # pushed-down matches are confined to ASCII rows. Re-match the - # non-ASCII rows here and union, so the report set is identical - # to the memory backend's TRE semantics. - nonascii <- .reports_with_nonascii_db(.object@db@con, drug_col) - if (nrow(nonascii)) { - nonascii <- data.table::as.data.table(nonascii) - data.table::setnames(nonascii, "drug_value", drug_col) - nonascii_ids <- .reports_with_ids_mem( - nonascii, .drugs, .logic, .roles, .exclude_drugs, drug_col - ) - ids <- union(ids, nonascii_ids) - } - } } else { drug <- faers_get(.object, "drug") - ids <- .reports_with_ids_mem( - drug, .drugs, .logic, .roles, .exclude_drugs, drug_col - ) + id_sets <- .reports_with_sets_mem(drug, .drugs, .roles, drug_col) + exclude_sets <- .reports_with_sets_mem(drug, .exclude_drugs, list(), drug_col) } + ids <- .reports_with_combine(id_sets, .logic, exclude_sets) ids <- sort(unique(as.character(ids))) - # ---- diagnostics: per-pattern hit counts (message, not warning) ---- - # On the pushed-down db path these are COUNT(DISTINCT primaryid) queries; - # nothing is materialized. Other paths already hold `drug` in memory. - drug_col_name <- drug_col - if (!is.null(.object@db) && !is.null(db_ids_raw)) { - per_hit <- vapply(seq_along(.drugs), function(i) { - cond <- .reports_with_sql_cond( - .drugs[[i]], .roles[[.drugs[[i]]]], drug_col_name - ) - as.integer(DBI::dbGetQuery( - .object@db@con, - sprintf( - "SELECT COUNT(DISTINCT primaryid) AS n FROM %s WHERE %s", - db_qident(db_field_table("drug")), cond - ) - )$n[[1L]]) - }, integer(1L)) - } else { - per_hit <- vapply(.drugs, function(p) { - length(.reports_with_ids_mem( - drug, p, "or", .roles, character(), drug_col_name - )) - }, integer(1L)) - } + # Count the same per-pattern report sets used above, including non-ASCII + # hits and deduplicating reports that match in both halves. + per_hit <- vapply(id_sets, length, integer(1L)) if (length(ids) || any(per_hit > 0L)) { cli::cli_inform( "{.fn faers_reports_with} matched {length(ids)} report{?s}: {.val {paste0(.drugs, \": \", per_hit)}}" diff --git a/man/faers_reports_with.Rd b/man/faers_reports_with.Rd index 1e92d58..1d167de 100644 --- a/man/faers_reports_with.Rd +++ b/man/faers_reports_with.Rd @@ -95,8 +95,9 @@ For database-backed objects a pattern is pushed into SQL (letters, digits, spaces, underscores, hyphens). Any other pattern — character classes, quantifiers, lookarounds — is matched in R after collecting the drug table, so both backends always agree on the matched -report set. Pushed-down \code{"count"} results are computed in the database -without collecting report identifiers. +report set. SQL and R matches are combined per pattern before applying +AND/OR logic and report-level exclusions. Report identifiers are collected +to combine these sets, including for \code{"count"} results. } \subsection{Empty results}{ diff --git a/tests/testthat/test_restrict-drug.R b/tests/testthat/test_restrict-drug.R index 7701df2..c924fbe 100644 --- a/tests/testthat/test_restrict-drug.R +++ b/tests/testthat/test_restrict-drug.R @@ -273,6 +273,137 @@ reports_db_twin <- function(mem_obj, con) { ) } +# Every pair of rows belongs to a real report in demo. Reports 1 and 2 +# satisfy AND across opposite character partitions; 3 and 4 have exclusions +# in the opposite partition. Report 7 checks Unicode folding, and report 8 +# satisfies both inclusion patterns on one combination-product row. +reports_mixed_object <- function() { + obj <- reports_synth_object() + obj@data$demo <- data.table::data.table( + year = 2004L, quarter = "q1", primaryid = as.character(1:8) + ) + obj@data$drug <- data.table::data.table( + primaryid = as.character(c(1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 1)), + drugname = c( + "ASPIRIN", "caf\u00e9 warfarin", "caf\u00e9 aspirin", "WARFARIN", + "caf\u00e9 aspirin", "vitamin k", "ASPIRIN", "caf\u00e9 vitamin k", + "ASPIRIN", "WARFARIN", "caf\u00e9 aspirin", "caf\u00e9 warfarin", + "ASPIRIN", "\u212aetamine", "aspirin and warfarin", "ASPIRIN" + ), + role_cod = c("PS", "SS", "PS", "PS", "C", "I", "SS", "C", + "PS", "SS", "PS", "PS", "PS", "PS", "PS", "PS") + ) + obj@data$drug[, prod_ai := drugname] + obj +} + +testthat::test_that("mixed-character report sets combine before AND/OR and exclusion", { + testthat::skip_if_not(has_duckdb) + mem <- reports_mixed_object() + con <- asNamespace("faers")$db_connect(":memory:") + withr::defer(DBI::dbDisconnect(con, shutdown = TRUE)) + db <- reports_db_twin(mem, con) + cases <- list( + list(args = list(.drugs = c("aspirin", "warfarin")), ids = c("1", "2", "5", "6", "8")), + list(args = list(.drugs = c("aspirin", "warfarin"), .logic = "or"), ids = as.character(1:8)), + list(args = list(.drugs = c("aspirin", "warfarin"), .roles = list(warfarin = "PS")), ids = c("2", "6", "8")), + list(args = list(.drugs = c("aspirin", "warfarin"), .roles = list(aspirin = "PS", warfarin = "SS")), ids = c("1", "5")), + list(args = list(.drugs = "aspirin", .exclude_drugs = "vitamin k"), ids = c("1", "2", "5", "6", "7", "8")), + list(args = list(.drugs = c("aspirin", "warfarin"), .logic = "or", .exclude_drugs = "vitamin k"), ids = c("1", "2", "5", "6", "7", "8")), + list(args = list(.drugs = "aspirin", .exclude_drugs = "vitamin [k]"), ids = c("1", "2", "5", "6", "7", "8")), + list(args = list(.drugs = c("asp[i]rin", "warfarin")), ids = c("1", "2", "5", "6", "8")), + list(args = list(.drugs = c("aspirin", "zzzzmissing")), ids = character()), + list(args = list(.drugs = "aspirin", .exclude_drugs = "aspirin"), ids = character()) + ) + for (col in c("drugname", "prod_ai")) for (case in cases) { + for (object in list(mem, db)) { + args <- c(list(.object = object, .drug_col = col), case$args) + actual <- suppressMessages(do.call(faers_reports_with, c(args, list(.return = "ids")))) + expect_identical(actual, case$ids) + expect_identical( + suppressMessages(do.call(faers_reports_with, c(args, list(.return = "count")))), + as.integer(length(case$ids)) + ) + } + } +}) + +testthat::test_that("Unicode folding and hit diagnostics use complete per-pattern sets", { + testthat::skip_if_not(has_duckdb) + mem <- reports_mixed_object() + con <- asNamespace("faers")$db_connect(":memory:") + withr::defer(DBI::dbDisconnect(con, shutdown = TRUE)) + db <- reports_db_twin(mem, con) + for (pattern in c("ketamine", "k", "s")) { + expected <- sort(unique(mem@data$drug$primaryid[ + grepl(pattern, mem@data$drug$drugname, ignore.case = TRUE) + ])) + expect_identical( + suppressMessages(faers_reports_with(db, pattern, .return = "ids")), expected + ) + expected_exclusion <- sort(setdiff(as.character(1:8), expected)) + expect_identical(suppressMessages(faers_reports_with( + db, "aspirin", .exclude_drugs = pattern, .return = "ids" + )), expected_exclusion) + } + # Duplicate ASCII rows and cross-partition hits count once per report. + expect_message( + n <- faers_reports_with(db, c("aspirin", "warfarin"), .return = "count"), + "aspirin: 8" + ) + expect_identical(n, 5L) + expect_message( + faers_reports_with(db, "warfarin", .roles = list(warfarin = "PS"), .return = "count"), + "warfarin: 3" + ) +}) + +testthat::test_that("mixed-character object returns preserve the source and previous results", { + testthat::skip_if_not(has_duckdb) + mem <- reports_mixed_object() + con <- asNamespace("faers")$db_connect(":memory:") + withr::defer(DBI::dbDisconnect(con, shutdown = TRUE)) + db <- reports_db_twin(mem, con) + original <- lapply(names(mem@data), function(f) db[[f]]) + both <- suppressMessages(faers_reports_with(db, c("aspirin", "warfarin"))) + withr::defer({ + DBI::dbDisconnect(both@db@con, shutdown = TRUE) + unlink(c(both@db@path, paste0(both@db@path, ".wal"))) + }) + no_k <- suppressMessages(faers_reports_with(db, "aspirin", .exclude_drugs = "vitamin k")) + withr::defer({ + DBI::dbDisconnect(no_k@db@con, shutdown = TRUE) + unlink(c(no_k@db@path, paste0(no_k@db@path, ".wal"))) + }) + expect_setequal(faers_primaryid(both), c("1", "2", "5", "6", "8")) + expect_setequal(faers_primaryid(no_k), c("1", "2", "5", "6", "7", "8")) + expect_identical(both@standardization, db@standardization) + expect_identical(both@deduplication, db@deduplication) + for (i in seq_along(mem@data)) { + f <- names(mem@data)[[i]] + expect_equal(db[[f]], original[[i]]) + expect_true(all(both[[f]]$primaryid %in% faers_primaryid(both))) + expect_true(all(no_k[[f]]$primaryid %in% faers_primaryid(no_k))) + } +}) + +testthat::test_that("literal report queries do not materialize the full drug table", { + testthat::skip_if_not(has_duckdb) + con <- asNamespace("faers")$db_connect(":memory:") + withr::defer(DBI::dbDisconnect(con, shutdown = TRUE)) + db <- reports_db_twin(reports_mixed_object(), con) + testthat::local_mocked_bindings( + db_collect = function(...) stop("Full-table collection is not needed"), + .package = "faers" + ) + expect_identical(suppressMessages(faers_reports_with( + db, c("aspirin", "warfarin"), .return = "count" + )), 5L) + expect_identical(suppressMessages(faers_reports_with( + db, "aspirin", .exclude_drugs = "vitamin k", .return = "ids" + )), c("1", "2", "5", "6", "7", "8")) +}) + testthat::test_that("faers_reports_with parity on db twin (AND/OR/roles/exclude/regex)", { testthat::skip_if_not(has_duckdb) ns <- asNamespace("faers") From 268d7ade4a78df8c56f65d19f579aad37c4d9817 Mon Sep 17 00:00:00 2001 From: MadDERt <2129882365@qq.com> Date: Fri, 30 Oct 2026 16:39:34 +0800 Subject: [PATCH 4/4] fix: declare test dependency and exclude pkgdown config --- .Rbuildignore | 1 + DESCRIPTION | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 8076750..321539a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,6 +5,7 @@ ^Scratch\.RConsole$ ^data-raw$ ^\.github$ +^_pkgdown\.yml$ ^README\.Rmd$ ^README\.md$ ^README\.html$ diff --git a/DESCRIPTION b/DESCRIPTION index 06d2f8f..4e84bdc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,7 +37,8 @@ Suggests: knitr, pak, rmarkdown, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + withr biocViews: Software, DataImport, BiomedicalInformatics, Pharmacogenomics, Pharmacogenomics Encoding: UTF-8 ByteCompile: true