Extend tests

tests/test-icd_compact_to_full.R

@@ -12,6 +12,13 @@ stopifnot(identical(
   c("E912.0","250.0","I21.4")
 ))
 
+# ICD-9 procedure codes gain a decimal after the second character; scalars for
+# icdv/dx are recycled across the input vector.
+stopifnot(identical(
+  icd_compact_to_full(c("0309","1712"), icdv = 9, dx = 0),
+  c("03.09","17.12")
+))
+
 ################################################################################
 #                                 End of File                                  #
 ################################################################################

tests/test-is_icd.R

@@ -30,6 +30,25 @@ stopifnot(
   code_length_one_icd10pr = length(icd10pr) == 36L && !any(icd10pr)
 )
 
+################################################################################
+# check for early return if the input combination of icdv, dx, src excludes all
+# possible codes
+x <- c("7993", ".7993", "7.993", "79.93", "799.3", "7993.")
+y <- rep_len(FALSE, length(x))
+
+stopifnot(
+  "failed to stop on bad icdv" = inherits(tryCatchError(is_icd(x, icdv = 8)), "error"),
+  "failed to stop on bad src"  = inherits(tryCatchError(is_icd(x, src = "a")), "error"),
+  "failed to stop on bad dx"   = inherits(tryCatchError(is_icd(x, dx = 2)), "error"),
+  "warning for WHO and ICD 9"   = inherits(tryCatchWarning(is_icd(x, icdv = 9, src = "who")), "warning"),
+  "all FALSE for WHO and ICD 9" = identical(suppressWarnings(is_icd(x, icdv = 9, src = "who")), y),
+  "warning for CDC and ICD 9"   = inherits(tryCatchWarning(is_icd(x, icdv = 9, src = "cdc")), "warning"),
+  "all FALSE for CDC and ICD 9" = identical(suppressWarnings(is_icd(x, icdv = 9, src = "cdc")), y),
+  "warning for WHO, ICD-10, pr" = inherits(tryCatchWarning(is_icd(x, icdv = 10, src = "who", dx = 0)), "warning"),
+  "all FLASE for WHO, ICD-10, pr" = identical(suppressWarnings(is_icd(x, icdv = 10, src = "who", dx = 0)), y)
+)
+
+
 ################################################################################
 # For ICD-9 test that the presense of a dot is considered when testing.
 # Example 7993 is the simplified version of the proper ICD-9 DX code 799.3 and
@@ -38,11 +57,16 @@ stopifnot(
 # FALSE if the dot is in the wrong place
 
 x <- c("7993", ".7993", "7.993", "79.93", "799.3", "7993.")
+f <- factor(x)
 stopifnot(
   identical(is_icd(x, icdv =  9, dx = 1L), c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE)),
   identical(is_icd(x, icdv =  9, dx = 0L), c(TRUE, FALSE, FALSE, TRUE, FALSE, FALSE)),
   !any(is_icd(x, icdv = 10, dx = 1L)),
-  !any(is_icd(x, icdv = 10, dx = 0L))
+  !any(is_icd(x, icdv = 10, dx = 0L)),
+  identical(is_icd(x, icdv =  9, dx = 1L), is_icd(f, icdv =  9, dx = 1L)),
+  identical(is_icd(x, icdv =  9, dx = 0L), is_icd(f, icdv =  9, dx = 0L)),
+  identical(is_icd(x, icdv = 10, dx = 1L), is_icd(f, icdv = 10, dx = 1L)),
+  identical(is_icd(x, icdv = 10, dx = 0L), is_icd(f, icdv = 10, dx = 0L))
 )
 
 # expect a warning that 7993 is ambiguous
@@ -62,11 +86,16 @@ x <- c("C441121",
        "C4411.21",
        "C44112.1",
        "C441121.")
+f <- factor(x)
 stopifnot(
   identical(is_icd(x, icdv = 10, dx = 1L), c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE)),
   !any(is_icd(x, icdv = 9, dx = 1L)),
   !any(is_icd(x, icdv = 9, dx = 0L)),
-  !any(is_icd(x, icdv = 10, dx = 0L))
+  !any(is_icd(x, icdv = 10, dx = 0L)),
+  identical(is_icd(x, icdv =  9, dx = 1L), is_icd(f, icdv =  9, dx = 1L)),
+  identical(is_icd(x, icdv =  9, dx = 0L), is_icd(f, icdv =  9, dx = 0L)),
+  identical(is_icd(x, icdv = 10, dx = 1L), is_icd(f, icdv = 10, dx = 1L)),
+  identical(is_icd(x, icdv = 10, dx = 0L), is_icd(f, icdv = 10, dx = 0L))
   )
 
 # another example
@@ -79,12 +108,17 @@ x <- c("Y389X2S",
        "Y389X.2S",
        "Y389X2.S",
        "Y389X2S.")
+f <- factor(x)
 stopifnot(
   identical(is_icd(x), c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE)),
   identical(is_icd(x, icdv = 10, dx = 1L), c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE)),
   !any(is_icd(x, icdv = 9, dx = 1L)),
   !any(is_icd(x, icdv = 9, dx = 0L)),
-  !any(is_icd(x, icdv = 10, dx = 0L))
+  !any(is_icd(x, icdv = 10, dx = 0L)),
+  identical(is_icd(x, icdv =  9, dx = 1L), is_icd(f, icdv =  9, dx = 1L)),
+  identical(is_icd(x, icdv =  9, dx = 0L), is_icd(f, icdv =  9, dx = 0L)),
+  identical(is_icd(x, icdv = 10, dx = 1L), is_icd(f, icdv = 10, dx = 1L)),
+  identical(is_icd(x, icdv = 10, dx = 0L), is_icd(f, icdv = 10, dx = 0L))
   )
 
 # ICD 10 pr codes have no dots
@@ -97,12 +131,17 @@ x <- c("0016074",
        "00160.74",
        "001607.4",
        "0016074.")
+f <- factor(x)
 stopifnot(
   identical(is_icd(x), c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE)),
   identical(is_icd(x, icdv = 10, dx = 0L), c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE)),
   !any(is_icd(x, icdv = 9, dx = 1L)),
   !any(is_icd(x, icdv = 9, dx = 0L)),
-  !any(is_icd(x, icdv = 10, dx = 1L))
+  !any(is_icd(x, icdv = 10, dx = 1L)),
+  identical(is_icd(x, icdv =  9, dx = 1L), is_icd(f, icdv =  9, dx = 1L)),
+  identical(is_icd(x, icdv =  9, dx = 0L), is_icd(f, icdv =  9, dx = 0L)),
+  identical(is_icd(x, icdv = 10, dx = 1L), is_icd(f, icdv = 10, dx = 1L)),
+  identical(is_icd(x, icdv = 10, dx = 0L), is_icd(f, icdv = 10, dx = 0L))
   )
 
 ################################################################################

tests/test-summary-charlson.R

@@ -0,0 +1,123 @@
+source('utilities.R')
+################################################################################
+# Tests for summarizing Charlson comorbidities
+library(medicalcoder)
+
+################################################################################
+# Prepare input with an age variable to exercise age scoring logic
+mdcr$age <- as.integer(substr(as.character(mdcr$patid), 1, 2))
+
+charlson <- comorbidities(
+  data       = mdcr,
+  id.vars    = "patid",
+  icdv.var   = "icdv",
+  icd.codes  = "code",
+  dx.var     = "dx",
+  method     = "charlson_quan2011",
+  flag.method = "current",
+  poa        = 1,
+  age.var    = "age"
+)
+
+summary_current <- summary(charlson)
+
+stopifnot(
+  is.list(summary_current),
+  identical(names(summary_current), c("conditions", "age_summary", "index_summary")),
+  is.data.frame(summary_current$conditions),
+  identical(
+    names(summary_current$conditions),
+    c("condition_description", "condition", "count", "percent")
+  ),
+  is.character(summary_current$conditions$condition_description),
+  is.character(summary_current$conditions$condition),
+  is.numeric(summary_current$conditions$count),
+  is.numeric(summary_current$conditions$percent),
+  all(summary_current$conditions$count >= 0),
+  all(summary_current$conditions$percent >= 0),
+  all(summary_current$conditions$percent <= 100)
+)
+
+################################################################################
+# Conditions summary matches direct aggregations
+aidshiv_count <- summary_current$conditions[
+  !is.na(summary_current$conditions$condition) &
+  summary_current$conditions$condition == "aidshiv",
+  "count"
+]
+copd_count <- summary_current$conditions[
+  !is.na(summary_current$conditions$condition) &
+  summary_current$conditions$condition == "copd",
+  "count"
+]
+
+stopifnot(
+  aidshiv_count == sum(charlson$aidshiv),
+  copd_count   == sum(charlson$copd)
+)
+
+num_ge_1 <- summary_current$conditions[
+  is.na(summary_current$conditions$condition) &
+  summary_current$conditions$condition_description == ">= 1",
+  "count"
+]
+num_ge_2 <- summary_current$conditions[
+  is.na(summary_current$conditions$condition) &
+  summary_current$conditions$condition_description == ">= 2",
+  "count"
+]
+
+stopifnot(
+  num_ge_1 == sum(charlson$num_cmrb >= 1),
+  num_ge_2 == sum(charlson$num_cmrb >= 2)
+)
+
+################################################################################
+# Age and index summaries align with expected calculations
+expected_age_summary <-
+  merge(
+    x = stats::setNames(as.data.frame(table(charlson$age_score, useNA = "always")), c("age_score", "count")),
+    y = stats::setNames(as.data.frame(100 * prop.table(table(charlson$age_score, useNA = "always"))), c("age_score", "percent")),
+    by = "age_score"
+  )
+
+stopifnot(identical(summary_current$age_summary, expected_age_summary))
+
+expected_index_summary <-
+  data.frame(
+    min    = min(charlson$cci),
+    q1     = stats::quantile(charlson$cci, prob = 0.25),
+    median = stats::median(charlson$cci),
+    q3     = stats::quantile(charlson$cci, prob = 0.75),
+    max    = max(charlson$cci),
+    row.names = NULL
+  )
+
+stopifnot(identical(summary_current$index_summary, expected_index_summary))
+
+################################################################################
+# A non-current flag.method generates a warning but still returns the summary
+charlson_cumulative <- charlson
+attr(charlson_cumulative, "flag.method") <- "cumulative"
+
+warn_obj <- tryCatchWarning(summary(charlson_cumulative))
+
+stopifnot(
+  inherits(warn_obj, "warning"),
+  identical(
+    conditionMessage(warn_obj),
+    "Logic for charlson summary table has been implemented for flag.method = 'current'.  Using this function for flag.method = 'cumulative' may not provide a meaningful summary."
+  )
+)
+
+summary_cumulative <- suppressWarnings(summary(charlson_cumulative))
+
+stopifnot(
+  identical(summary_cumulative$conditions, summary_current$conditions),
+  identical(summary_cumulative$age_summary, summary_current$age_summary),
+  identical(summary_cumulative$index_summary, summary_current$index_summary)
+)
+
+################################################################################
+#                                 End of File                                  #
+################################################################################

tests/test-summary-elixhauser.R

@@ -0,0 +1,126 @@
+source('utilities.R')
+################################################################################
+# Tests for summarizing Elixhauser comorbidities
+library(medicalcoder)
+
+################################################################################
+# Build Elixhauser comorbidities and summary
+elixhauser <- comorbidities(
+  data        = mdcr,
+  id.vars     = "patid",
+  icdv.var    = "icdv",
+  icd.codes   = "code",
+  dx.var      = "dx",
+  method      = "elixhauser_ahrq2025",
+  flag.method = "current",
+  poa         = 1,
+  primarydx   = 0
+)
+
+summary_current <- summary(elixhauser)
+
+stopifnot(
+  is.list(summary_current),
+  identical(names(summary_current), c("conditions", "index_summary")),
+  is.data.frame(summary_current$conditions),
+  identical(
+    names(summary_current$conditions),
+    c("condition", "count", "percent")
+  ),
+  is.character(summary_current$conditions$condition),
+  is.numeric(summary_current$conditions$count),
+  is.numeric(summary_current$conditions$percent),
+  all(summary_current$conditions$count >= 0),
+  all(summary_current$conditions$percent >= 0),
+  all(summary_current$conditions$percent <= 100)
+)
+
+################################################################################
+# Conditions summary matches direct aggregations
+hf_count <- summary_current$conditions[
+  summary_current$conditions$condition == "HF",
+  "count"
+]
+diab_cx_count <- summary_current$conditions[
+  summary_current$conditions$condition == "DIAB_CX",
+  "count"
+]
+
+stopifnot(
+  hf_count == sum(elixhauser$HF),
+  diab_cx_count == sum(elixhauser$DIAB_CX)
+)
+
+num_ge_1 <- summary_current$conditions[
+  summary_current$conditions$condition == ">= 1",
+  "count"
+]
+num_ge_2 <- summary_current$conditions[
+  summary_current$conditions$condition == ">= 2",
+  "count"
+]
+
+stopifnot(
+  num_ge_1 == sum(elixhauser$num_cmrb >= 1),
+  num_ge_2 == sum(elixhauser$num_cmrb >= 2)
+)
+
+################################################################################
+# Index summary aligns with expected calculations
+stopifnot(
+  is.data.frame(summary_current$index_summary),
+  identical(
+    names(summary_current$index_summary),
+    c("index", "min", "q1", "median", "q3", "max")
+  ),
+  is.character(summary_current$index_summary$index),
+  is.numeric(summary_current$index_summary$min),
+  is.numeric(summary_current$index_summary$q1),
+  is.numeric(summary_current$index_summary$median),
+  is.numeric(summary_current$index_summary$q3),
+  is.numeric(summary_current$index_summary$max)
+)
+
+expected_index_summary <-
+  data.frame(
+    index  = c("readmission", "mortality"),
+    min    = c(min(elixhauser$readmission_index),
+               min(elixhauser$mortality_index)),
+    q1     = c(stats::quantile(elixhauser$readmission_index, prob = 0.25),
+               stats::quantile(elixhauser$mortality_index, prob = 0.25)),
+    median = c(stats::median(elixhauser$readmission_index),
+               stats::median(elixhauser$mortality_index)),
+    q3     = c(stats::quantile(elixhauser$readmission_index, prob = 0.75),
+               stats::quantile(elixhauser$mortality_index, prob = 0.75)),
+    max    = c(max(elixhauser$readmission_index),
+               max(elixhauser$mortality_index)),
+    row.names = NULL
+  )
+
+stopifnot(identical(summary_current$index_summary, expected_index_summary))
+
+################################################################################
+# A non-current flag.method generates a warning but still returns the summary
+elixhauser_cumulative <- elixhauser
+attr(elixhauser_cumulative, "flag.method") <- "cumulative"
+
+warn_obj <- tryCatchWarning(summary(elixhauser_cumulative))
+
+stopifnot(
+  inherits(warn_obj, "warning"),
+  identical(
+    conditionMessage(warn_obj),
+    "Logic for Elixhauser summary has been implemented for flag.method = 'current'.  Using this function for flag.method = 'cumulative' may not provide a meaningful summary."
+  )
+)
+
+summary_cumulative <- suppressWarnings(summary(elixhauser_cumulative))
+
+stopifnot(
+  identical(summary_cumulative$conditions, summary_current$conditions),
+  identical(summary_cumulative$index_summary, summary_current$index_summary)
+)
+
+################################################################################
+#                                 End of File                                  #
+################################################################################