Merge branch 'redesign_meddra'

Yunuuuu · Oct 26, 2023 · dcc050b · dcc050b
2 parents 7037eec + a9b4a9b
commit dcc050b
Show file tree

Hide file tree

Showing 9 changed files with 111 additions and 82 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -43,6 +43,7 @@ exportMethods(faers_quarter)
 exportMethods(faers_standardize)
 exportMethods(faers_year)
 exportMethods(show)
+importClassesFrom(data.table,data.table)
 importFrom(data.table,":=")
 importFrom(data.table,.BY)
 importFrom(data.table,.EACHI)

diff --git a/R/class-FAERS.R b/R/class-FAERS.R
@@ -5,8 +5,10 @@
 #' @slot quarter A string specifies the quarter information.
 #' @slot data For `FAERSxml`, a [data.table][data.table::data.table]. For
 #' `FAERSascii`, a list of [data.table][data.table::data.table].
-#' @slot format: A string of "ascii" or "xml" indicates the file format used.
-#' @slot deletedCases: A list of integers, as of 2019 Quarter one there are new
+#' @slot meddra A [data.table][data.table::data.table] or `NULL` representing
+#' the meddra data used for standardization.
+#' @slot format A string of "ascii" or "xml" indicates the file format used.
+#' @slot deletedCases A list of integers, as of 2019 Quarter one there are new
 #' files that lists deleted cases.
 #' @details
 #'  - `faers_data`: Extract the `data` slot.
@@ -17,18 +19,24 @@
 #'  - `faers_deleted_cases`: Extract the `deletedCases` slot.
 #' @aliases FAERS
 #' @name FAERS-class
+NULL
+
+#' @importClassesFrom data.table data.table
+methods::setClassUnion("DTOrNull", c("NULL", "data.table"))
+
 methods::setClass(
     "FAERS",
     slots = list(
         year = "integer",
         quarter = "character",
         data = "ANY",
+        meddra = "DTOrNull",
         deduplication = "logical",
         standardization = "logical",
         format = "character"
     ),
     prototype = list(
-        data = NULL,
+        data = NULL, meddra = NULL,
         deduplication = FALSE,
         standardization = FALSE
     )
@@ -117,9 +125,9 @@ methods::setValidity("FAERSascii", function(object) {
 #' @rdname FAERS-class
 methods::setClass(
     "FAERSxml",
-    slots = list(data = "data.table", header = "list"),
+    slots = list(data = "DTOrNull", header = "list"),
     prototype = list(
-        data = data.table::data.table(),
+        data = NULL,
         header = list(), format = "xml"
     ),
     contains = "FAERS"
@@ -187,23 +195,6 @@ methods::setMethod("faers_header", "FAERSxml", function(object) {
     object@header
 })
 
-#######################################################
-#' @param x A [FAERS] object.
-#' @param i Indices specifying elements to extract.
-#' @export
-#' @aliases [[,FAERS-method
-#' @rdname FAERS-class
-methods::setMethod("[[", "FAERS", function(x, i) {
-    x@data[[use_indices(i, names(x@data))]]
-})
-
-#' @export
-#' @aliases [,FAERS-method
-#' @rdname FAERS-class
-methods::setMethod("[", "FAERS", function(x, i) {
-    x@data[use_indices(i, names(x@data))]
-})
-
 #######################################################
 #' @param object A [FAERS] object.
 #' @param ... Other arguments passed to specific methods.
@@ -314,33 +305,3 @@ build_periods <- function(
     }
     cli::cli_abort("both {.arg {arg_years}} and {.arg {arg_quarters}} should be set", call = call)
 }
-
-use_indices <- function(i, names, arg = rlang::caller_arg(i), call = rlang::caller_env()) {
-    if (anyNA(i)) {
-        cli::cli_abort(
-            sprintf("%s cannot contain `NA`", style_arg(arg)),
-            call = call
-        )
-    }
-    if (is.character(i)) {
-        outbounded_values <- setdiff(i, names)
-        if (length(outbounded_values)) {
-            cli::cli_abort(sprintf(
-                "%s contains outbounded values: {outbounded_values}",
-                style_arg(arg)
-            ), call = call)
-        }
-    } else if (is.numeric(i)) {
-        if (any(i < 1L) || any(i > length(names))) {
-            cli::cli_abort(sprintf(
-                "%s contains out-of-bounds indices", style_arg(arg)
-            ), call = call)
-        }
-    } else {
-        cli::cli_abort(sprintf(
-            "%s must be an atomic numeric or character",
-            style_arg(arg)
-        ), call = call)
-    }
-    i
-}
diff --git a/R/dedup.R b/R/dedup.R
@@ -22,7 +22,7 @@ methods::setMethod("faers_dedup", "FAERSascii", function(object, remove_deleted_
     }
     deduplicated_data <- do.call(
         dedup_faers_ascii,
-        faers_data(object)[c("demo", "drug", "indi", "ther", "reac")]
+        object[c("demo", "drug", "indi", "ther", "reac")]
     )
     if (isTRUE(remove_deleted_cases)) {
         deleted_cases <- faers_deleted_cases(object)

diff --git a/R/meddra.R b/R/meddra.R
@@ -104,19 +104,12 @@ meddra_standardize_pt <- function(terms, meddra_data, use = c("llt", "pt")) {
         idx[operated_idx] <- mapped_idx
         if (!anyNA(idx)) break
     }
-    out <- meddra_data[idx]
-    # nolint start
-    out[, meddra_hierarchy := pt_from]
-    out[, meddra_code := as.character(out_code)]
-    out[, meddra_pt := meddra_map_code_into_names(meddra_code, meddra_data)]
-    # nolint end
-
-    # remove the low meddra hierarchy fields
-    deleted_columns <- meddra_hierarchy_infos(
-        use[-length(use)],
-        add_soc_abbrev = FALSE
+    data.table::data.table(
+        meddra_idx = idx,
+        meddra_hierarchy = pt_from,
+        meddra_code = as.character(out_code),
+        meddra_pt = meddra_map_code_into_names(meddra_code, meddra_data)
     )
-    out[, .SD, .SDcols = !deleted_columns]
 }
 
 meddra_hierarchy_infos <- function(use, add_soc_abbrev = TRUE) {

diff --git a/R/merge.R b/R/merge.R
@@ -35,9 +35,9 @@ methods::setMethod("faers_merge", "FAERSascii", function(object, use = NULL, all
     # for LAERS, caseid only exist in `demo` data.
     # So we just keep the caseid of `demo`
     if (length(use) == 1L) {
-        return(object@data[[use]])
+        return(object[[use]])
     }
-    lst <- object@data[use]
+    lst <- object[use]
     # check if we need copy indi
     # to prevent modify in place (change the input object)
     indi_reference <- TRUE

diff --git a/R/methods-utils.R b/R/methods-utils.R
@@ -33,7 +33,40 @@ methods::setGeneric("faers_get", function(object, ...) {
 #' @rdname FAERS-methods
 methods::setMethod("faers_get", "FAERSascii", function(object, field) {
     field <- match.arg(field, faers_ascii_file_fields)
-    object@data[[field]]
+    out <- object@data[[field]]
+    if (object@standardization && any(field == c("indi", "reac"))) {
+        out <- cbind(out[, !"meddra_idx"], object@meddra[out$meddra_idx])
+    }
+    out
+})
+
+#######################################################
+#' @param x A [FAERSascii] object.
+#' @param i Indices specifying elements to extract. See `field`. It will be okay
+#' to use integer indices.
+#' @export
+#' @aliases [[,FAERSascii-method
+#' @rdname FAERS-methods
+methods::setMethod("[[", "FAERSascii", function(x, i) {
+    full_nms <- names(x@data)
+    nms <- full_nms[[use_indices(i, full_nms)]]
+    faers_get(x, nms)
+})
+
+#' @export
+#' @aliases [,FAERSascii-method
+#' @rdname FAERS-methods
+methods::setMethod("[", "FAERSascii", function(x, i) {
+    data <- x@data
+    out <- data[use_indices(i, names(data))]
+    if (x@standardization) {
+        ii <- intersect(names(out), c("indi", "reac"))
+        for (i in ii) {
+            meddra_idx <- out[[i]]$meddra_idx
+            out[[i]] <- cbind(out[[i]][, !"meddra_idx"], x@meddra[meddra_idx])
+        }
+    }
+    out
 })
 
 ##############################################################
@@ -197,6 +230,8 @@ methods::setMethod(
     }
 )
 
+utils::globalVariables(c("a", "b", "d", "n.1"))
+
 #' @rdname FAERS-methods
 methods::setMethod(
     "faers_phv_table",
@@ -228,4 +263,33 @@ methods::setMethod("faers_phv_signal", "FAERSascii", function(object, pt = "soc_
     )
 })
 
-utils::globalVariables(c("a", "b", "d", "n.1"))
+#########################################################
+use_indices <- function(i, names, arg = rlang::caller_arg(i), call = rlang::caller_env()) {
+    if (anyNA(i)) {
+        cli::cli_abort(
+            sprintf("%s cannot contain `NA`", style_arg(arg)),
+            call = call
+        )
+    }
+    if (is.character(i)) {
+        outbounded_values <- setdiff(i, names)
+        if (length(outbounded_values)) {
+            cli::cli_abort(sprintf(
+                "%s contains outbounded values: {outbounded_values}",
+                style_arg(arg)
+            ), call = call)
+        }
+    } else if (is.numeric(i)) {
+        if (any(i < 1L) || any(i > length(names))) {
+            cli::cli_abort(sprintf(
+                "%s contains out-of-bounds indices", style_arg(arg)
+            ), call = call)
+        }
+    } else {
+        cli::cli_abort(sprintf(
+            "%s must be an atomic numeric or character",
+            style_arg(arg)
+        ), call = call)
+    }
+    i
+}
diff --git a/R/standardize.R b/R/standardize.R
@@ -26,6 +26,11 @@ methods::setMethod("faers_standardize", "FAERSascii", function(object, meddra_pa
     # add SMQ data will increase the usage of memory
     # don't use it anymore.
     meddra_data <- meddra_hierarchy_data(meddra_path)
+    meddra_data <- meddra_data[, .SD, .SDcols = c(
+        meddra_hierarchy_infos(meddra_hierarchy_fields),
+        "primary_soc_fg", "meddra_hierarchy",
+        "meddra_code", "meddra_pt"
+    )]
     # https://stackoverflow.com/questions/70181149/is-a-saved-and-loaded-data-table-with-qs-a-correct-data-table
     # fix error: when load a saved FAERS object
     cli::cli_alert("standardize {.field Preferred Term} in indi")
@@ -46,6 +51,7 @@ methods::setMethod("faers_standardize", "FAERSascii", function(object, meddra_pa
         meddra_standardize_pt(object@data$reac$cleaned_pt, meddra_data)
     )
     object@data$reac[, cleaned_pt := NULL]
+    object@meddra <- meddra_data
     object@standardization <- TRUE
     object
 })

diff --git a/man/FAERS-class.Rd b/man/FAERS-class.Rd
diff --git a/man/FAERS-methods.Rd b/man/FAERS-methods.Rd