Merge branch 'main' into test-stratify-data

.Rbuildignore

@@ -21,3 +21,5 @@ allpopsamples_hlye.csv$
 ^serocalculator.*\.tgz$
 ^inst/extdata
 ^CRAN-SUBMISSION$
+^README\.qmd$
+^codecov\.yml$

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: serocalculator
 Type: Package
 Title: Estimating Infection Rates from Serological Data
-Version: 1.1.0.9000
+Version: 1.2.0
 Authors@R: c(
   person(given = "Peter", family = "Teunis", email = "[email protected]", role = c("aut", "cph"), comment = "Author of the method and original code."),
   person(given = "Kristina", family = "Lai", email = "[email protected]", role = c("aut", "cre")), 
@@ -42,11 +42,12 @@ Suggests:
     readr,
     bookdown,
     ggbeeswarm,
-    DT
+    DT,
+    spelling
 LazyData: true
 Encoding: UTF-8
 URL: https://github.com/UCD-SERG/serocalculator, https://ucd-serg.github.io/serocalculator/
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 NeedsCompilation: no
 LinkingTo: 
     Rcpp

NAMESPACE

@@ -6,9 +6,19 @@ S3method(autoplot,pop_data)
 S3method(autoplot,seroincidence)
 S3method(autoplot,seroincidence.by)
 S3method(autoplot,summary.seroincidence.by)
+S3method(get_age,pop_data)
+S3method(get_age_var,pop_data)
+S3method(get_id,pop_data)
+S3method(get_id_var,pop_data)
+S3method(get_value,pop_data)
+S3method(get_value_var,pop_data)
 S3method(print,seroincidence)
 S3method(print,seroincidence.by)
+S3method(print,summary.pop_data)
 S3method(print,summary.seroincidence.by)
+S3method(set_age,pop_data)
+S3method(set_id,pop_data)
+S3method(set_value,pop_data)
 S3method(strata,seroincidence.by)
 S3method(summary,pop_data)
 S3method(summary,seroincidence)

NEWS.md

@@ -1,4 +1,9 @@
-# serocalculator (development version)
+# serocalculator 1.2.0
+* Added `test-summary.pop_data` test
+
+* Modified `test-est.incidence` test
+
+* Added stratification to `summary.pop_data`
 
 * Added `verbose` option for `check_pop_data()`, changing default behavior
 to avoid printing an OK message.

R/load_pop_data.R

@@ -50,6 +50,7 @@ get_age <- function(object, ...) {
   UseMethod("get_age", object)
 }
 
+#' @export
 get_age.pop_data <- function(object, ...) {
   # get age data
   age_data <- object %>% pull(attr(object, "age_var"))
@@ -61,6 +62,7 @@ get_age_var <- function(object, ...) {
   UseMethod("get_age_var", object)
 }
 
+#' @export
 get_age_var.pop_data <- function(object, ...) {
   # get value attribute
   age_var <- attributes(object)$age_var
@@ -72,6 +74,7 @@ get_value <- function(object, ...) {
   UseMethod("get_value", object)
 }
 
+#' @export
 get_value.pop_data <- function(object, ...) {
   # get age data
   value_data <- object %>% pull(attr(object, "value_var"))
@@ -83,6 +86,7 @@ get_value_var <- function(object, ...) {
   UseMethod("get_value_var", object)
 }
 
+#' @export
 get_value_var.pop_data <- function(object, ...) {
   # get value attribute
   value_var <- attributes(object)$value_var
@@ -94,6 +98,7 @@ get_id <- function(object, ...) {
   UseMethod("get_id", object)
 }
 
+#' @export
 get_id.pop_data <- function(object, ...) {
   # get age data
   id_data <- object %>% pull(attr(object, "id_var"))
@@ -105,17 +110,20 @@ get_id_var <- function(object, ...) {
   UseMethod("get_id_var", object)
 }
 
+#' @export
 get_id_var.pop_data <- function(object, ...) {
   # get value attribute
   id_var <- attributes(object)$id_var
 
   return(id_var)
 }
 
+
 set_age <- function(object, ...) {
   UseMethod("set_age", object)
 }
 
+#' @export
 set_age.pop_data <- function(object, age = "Age", standardize = TRUE, ...) {
   # check if age column exists
   if (age %in% colnames(object)) {
@@ -163,6 +171,7 @@ set_value <- function(object, ...) {
   UseMethod("set_value", object)
 }
 
+#' @export
 set_value.pop_data <- function(object, value = "result", standardize = TRUE, ...) {
   # check if value column exists
   if (value %in% colnames(object)) {
@@ -209,6 +218,7 @@ set_id <- function(object, ...) {
   UseMethod("set_id", object)
 }
 
+#' @export
 set_id.pop_data <- function(object, id = "index_id", standardize = TRUE, ...) {
   # check if id column exists
   if (id %in% colnames(object)) {

data-raw/nlm_exit_codes.R → R/nlm_exit_codes.R

@@ -6,4 +6,3 @@ nlm_exit_codes <- c(
   "5" = "5: maximum step size `stepmax` exceeded five consecutive times. Either the function is unbounded below, becomes asymptotic to a finite value from above in some direction or `stepmax` is too small."
 )
 
-usethis::use_data(nlm_exit_codes, overwrite = TRUE, internal = TRUE)

R/summary.pop_data.R

@@ -1,55 +1,96 @@
 #'
-#' @title Summarize a cross-sectional antibody survey data set
+#' @title Summarize cross-sectional antibody survey data
 #' @description
-#' This function is a `summary()` method for `pop_data` objects
+#' [summary()] method for `pop_data` objects
 #'
-#' @param object a `pop_data` object
+#' @param object a `pop_data` object (from [as_pop_data()])
+#' @param strata a [character()] specifying grouping column(s)
 #' @param ...  unused
 #'
-#' @returns a list containing two summary tables: one of `age` and one of `value`, stratified by `antigen_iso`
+#' @returns a `summary.pop_data` object, which is a list containing two summary tables:
+#'
+#' * `age_summary` summarizing `age`
+#' * `ab_summary` summarizing `value`, stratified by `antigen_iso`
+#'
 #' @export
 #' @examples
 #' library(dplyr)
 #'
 #' xs_data <- load_pop_data("https://osf.io/download//n6cp3/")
+#' summary(xs_data, strata = "Country")
 #'
-#' summary(xs_data)
-#'
-summary.pop_data <- function(object, ...) {
+summary.pop_data <- function(object, strata = NULL, ...) {
+  # get relevant columns from object
+  age_column <- object %>% get_age_var()
+  value_column <- object %>% get_value_var()
+  id_column <- object %>% get_id_var()
+
+  # create a list of the columns
+  cols <- c(age_column, id_column, strata)
+
   ages <-
     object %>%
-    distinct(.data$id, .data$age)
-
-  cat("\nn =", nrow(ages), "\n")
+    distinct(across(all_of(cols)))
 
-  cat("\nDistribution of age: \n\n")
   age_summary <-
     ages %>%
-    pull("age") %>%
-    summary() %>%
-    print()
-
-  cat("\nDistributions of antigen-isotype measurements:\n\n")
+    summarise(
+      .by = all_of(strata),
+      n = n(),
+      min = min(.data[[age_column]]),
+      first_quartile = quantile(.data[[age_column]], 0.25),
+      median = median(.data[[age_column]]),
+      mean = mean(.data[[age_column]]),
+      third_quartile = quantile(.data[[age_column]], 0.75),
+      max = max(.data[[age_column]])
+    )
 
   ab_summary <-
     object %>%
     dplyr::summarize(
-      .by = .data$antigen_iso,
-      Min = object %>% get_value() %>% min(na.rm = TRUE),
-      `1st Qu.` = object %>% get_value() %>% quantile(.25, na.rm = TRUE),
-      Median = object %>% get_value() %>% median(),
-      `3rd Qu.` = object %>% get_value() %>% quantile(.75, na.rm = TRUE),
-      Max = object %>% get_value() %>% max(na.rm = TRUE),
-      `# NAs` = object %>% get_value() %>% is.na() %>% sum()
-    ) %>%
-    as.data.frame() %>%
-    print()
-
-  to_return <- list(
-    n = nrow(ages),
-    age_summary = age_summary,
-    ab_summary = ab_summary
-  )
-
-  return(invisible(to_return))
+      .by = all_of(c("antigen_iso", strata)),
+      across(
+        .cols = all_of(value_column),
+        .fns = list(
+          Min = ~ min(.x, na.rm = TRUE),
+          `1st Qu.` = ~ quantile(.x, p = .25, na.rm = TRUE),
+          Median = ~ median(.x, na.rm = TRUE),
+          `3rd Qu.` = ~ quantile(.x, p = .75, na.rm = TRUE),
+          Max = ~ max(.x, na.rm = TRUE),
+          `# NAs` = ~ is.na(.x) %>% sum()
+        ),
+        .names = "{.fn}"
+      ))
+
+  to_return <- list(n = nrow(ages),
+                    age_summary = age_summary,
+                    ab_summary = ab_summary)
+
+  class(to_return) = "summary.pop_data"
+
+  return(to_return)
+}
+
+
+#' Print method for [summary.pop_data] objects
+#' @param x an object of class `"summary.pop_data"`; usually, the result of a call to [summary.pop_data()]
+#' @rdname summary.pop_data
+#' @export
+print.summary.pop_data = function(x, ...)
+{
+  n_obs = x$age_summary %>% pull("n") %>% sum()
+
+  cat("\nn =", n_obs, "\n")
+
+  cat("\nDistribution of age: \n\n")
+
+  x$age_summary %>% print()
+
+  cat("\nDistributions of antigen-isotype measurements:\n\n")
+
+  x$ab_summary %>% print()
+
+  cat("\n")
+
+  invisible(x)
 }

data-raw/typhoid_results.R

@@ -0,0 +1,40 @@
+# Filter population data for Pakistan
+xs_data <- load_pop_data(
+  file_path = "https://osf.io/download//n6cp3/",
+  age = "Age",
+  value = "result",
+  id = "index_id",
+  standardize = TRUE
+) %>%
+  filter(Country == "Pakistan")
+
+# get noise data
+noise <- load_noise_params("https://osf.io/download//hqy4v/") %>%
+  filter(Country == "Pakistan")
+
+# get curve data
+curve <- load_curve_params("https://osf.io/download/rtw5k/")
+
+# Initial estimates for lambda
+start <- .05
+
+# Estimate incidence
+fit <- est.incidence(
+  pop_data = xs_data,
+  curve_param = curve,
+  noise_param = noise,
+  antigen_isos = c("HlyE_IgG", "HlyE_IgA")
+)
+
+typhoid_results <- fit %>%
+  summary.seroincidence(
+    coverage = .95,
+    start = start
+  ) %>%
+  mutate(
+    ageCat = NULL,
+    antigen.iso = paste(collapse = "+", "HlyE_IgG")
+  ) %>%
+  structure(noise.parameters = noise)
+
+saveRDS(object = typhoid_results,file = "tests/testthat/fixtures/typhoid_results.rds")