Merge pull request #101 from UCD-SERG/residuals_fits

Adding fitted and residual values

Author: d-morrison

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: serodynamics
 Title: What the Package Does (One Line, Title Case)
-Version: 0.0.0.9037
+Version: 0.0.0.9038
 Authors@R: c(
     person("Peter", "Teunis", , "p.teunis@emory.edu", role = c("aut", "cph"),
            comment = "Author of the method and original code."),

NEWS.md

@@ -1,8 +1,11 @@
 # serodynamics (development version)
 
-* Added support for faceting by multiple IDs in `plot_predicted_curve()`:
-    - New `facet_by_id` argument allows faceted plots by participant ID.
-* Added `plot_predicted_curve()`  (#68)
+* Initial CRAN submission.
+
+## New features
+
+* Including fitted and residual values as data frame in run_mod output. (#101)
+* Added  `plot_predicted_curve()` with support for faceting by multiple IDs (#68)
 * Replacing old data object with new run_mod output (#102)
 * Adding class assignment to run_mod output (#76)
 * Making prep_priors modifiable (#78)

R/Run_Mod.R

@@ -48,14 +48,16 @@
 #'   - `nParameters`: The amount of parameters estimated in the model.
 #'   - `nIterations`: Number of iteration specified.
 #'   - `nBurnin`: Number of burn ins.
-#'   - `nThin`: Thinning number (niter/nmc)
+#'   - `nThin`: Thinning number (niter/nmc).
 #'   - `priors`: A [list] that summarizes the input priors, including:
 #'     - `mu_hyp_param`
 #'     - `prec_hyp_param`
 #'     - `omega_param`
 #'     - `wishdf`
 #'     - `prec_logy_hyp_param`
-#'     - An optional `"jags.post"` attribute, included when argument
+#'   - `fitted_residuals`: A [data.frame] containing fitted and residual values
+#'   for all observations.
+#'   - An optional `"jags.post"` attribute, included when argument
 #'   `with_post` = TRUE.
 #' @inheritDotParams prep_priors
 #' @export
@@ -192,11 +194,18 @@ run_mod <- function(data,
   jags_out <- jags_out |>
     structure("priors" = attributes(priorspec)$used_priors)
 
+  # Calculating fitted and residuals
+  # Renaming columns using attributes from as_case_data
+  fit_res <- calc_fit_mod(modeled_dat = jags_out,
+                          original_data = dl_sub)
+  jags_out <- jags_out |>
+    structure(fitted_residuals = fit_res)
+
   # Conditionally adding jags.post
   if (with_post) {
     jags_out <- jags_out |>
       structure(jags.post = jags_post_final)
-  } 
+  }
   jags_out <- jags_out |>
     structure(class = union("sr_model", class(jags_out)))
   jags_out

R/calc_fit_mod.R

@@ -0,0 +1,47 @@
+#' @title Calculates fitted and residual values for modeled outputs
+#' @description
+#'  `calc_fit_mod()` takes antibody kinetic parameter estimates and calculates
+#'  fitted and residual values. Fitted values correspond to the estimated assay
+#'  value (ex. ELISA units etc.) at time since infection (TSI). Residual values
+#'  are calculated as the difference between fitted and observed values.
+#' @param modeled_dat A [data.frame] of modeled antibody kinetic parameter
+#' values.
+#' @param original_data A [data.frame] of the original input dataset.
+#' @returns A [data.frame] attached as an [attributes] with the following
+#' values:
+#'   - Subject = ID number specifying an individual
+#'   - Iso_type = The modeled antigen_isotype
+#'   - t = Time since infection 
+#'   - fitted = The fitted value calculated using model output parameters for a
+#'   given `t`
+#'   - residual = The residual value calculated as the difference between
+#'   observed and fitted values for a given `t`
+#' @keywords internal
+calc_fit_mod <- function(modeled_dat, 
+                         original_data) {
+  original_data <- original_data |> 
+    use_att_names() |>
+    select(.data$Subject, .data$Iso_type, .data$t, .data$result)
+  
+  # Preparing modeled data
+  modeled_dat <- modeled_dat |>
+    dplyr::summarize(.by = c(.data$Parameter, .data$Iso_type, 
+                             .data$Stratification, 
+                             .data$Subject),
+                     med_value = stats::median(.data$value)) |>
+    tidyr::pivot_wider(names_from = .data$Parameter, 
+                       values_from = .data$med_value)
+
+  # Matching input data with modeled data
+  matched_dat <- merge(modeled_dat, original_data, 
+                       by = c("Subject", "Iso_type"),
+                       all.y = TRUE)
+
+  # Calculating fitted and residual
+  fitted_dat <- matched_dat |>
+    mutate(fitted = ab(.data$t, .data$y0, .data$y1, .data$t1,
+                       .data$alpha, .data$shape),
+           residual = .data$result - .data$fitted) |>
+    select(.data$Subject, .data$Iso_type, .data$t, .data$fitted, .data$residual)
+  fitted_dat
+}

R/use_att_names.R

@@ -0,0 +1,20 @@
+#' @title Assigns column names to conform with [calc_fit_mod()] using attributes
+#' @description
+#'  `use_att_names` takes prepared longitudinal data for antibody kinetic
+#'  modeling and names columns using attribute values to allow merging
+#'  with a modeled [run_mod()] output [dplyr::tbl_df]. The column names include
+#'  `Subject`, `Iso_type`, `t`, and `result`. 
+#' @param data A [data.frame] raw longitudinal data that has been
+#' prepared for antibody kinetic modeling using [as_case_data()].
+#' @returns The input [data.frame] with columns named after attributes.
+#' @keywords internal
+use_att_names <- function(data) {
+  data <- data |> 
+    dplyr::rename(
+      Subject = data |> serocalculator::ids_varname(),
+      Iso_type = data |> serocalculator::get_biomarker_names_var(),
+      t = data |> get_timeindays_var(),
+      result = data |> serocalculator::get_values_var()
+    ) 
+  return(data)
+}

inst/WORDLIST

@@ -1,28 +1,43 @@
+Biomarker
 CMD
 CodeFactor
 Codecov
+HlyE
+Hyperpriors
+IgA
+IgG
+Iso
 JAGs
 Lifecycle
 Postprocess
 Rhat
+TSI
 Traceplots
 behaviour
 biomarker
 biomarkers
+bmatrix
+cdot
 dobson
 dotplots
 geoms
 ggproto
 hyp
 hyperprior
 hyperpriors
+ij
 iso
 isotype
 isotypes
+mathcal
 mcmc
+mergine
 nmc
+npl
+overfit
 params
 prec
+pred
 rhat
 sd
 seroconversion
@@ -32,13 +47,7 @@ seroresponses
 strat
 stratifications
 tbl
+tibble
 unstratified
+vectorized
 wishdf
-dayssincefeveronset
-ggplot
-tibble
-HlyE
-IgA
-IgG
-newpage
-npl