PPANMETH in pk.nca output

NEWS.md

@@ -27,6 +27,7 @@ the dosing including dose amount and route.
 * `PKNCA.set.summary(reset = TRUE)` warns that it may break the use of
   `summary()` (#477)
 
+* `pk.nca` output now includes a `PPANMETH` column describing the analysis methods used for each parameter regarding imputations, AUC and half.life calculations (#457)
 * New post-processing functions to normalize PKNCA result parameters based on any column in PKNCAconc data.frame (`normalize_by_col()`) or by using a custom normalization table (`normalize()`)
 * New excretion rate parameters: `ermax` (Maximum excretion rate), `ertmax` (Midpoint time
   of maximum excretion rate) and `ertlst` (Time of last excretion rate measurement) (#433)

R/auc.R

@@ -184,6 +184,15 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf),
         fun_linear = fun_linear, fun_log = fun_log, fun_inf = fun_inf
       )
   }
+  # Add method details as an attribute
+  attr(ret, "method") <- character()
+  auc_method <- if (is.null(method)) {
+    PKNCA.options()$auc.method
+  } else {
+    method
+  }
+  attr(ret, "method") <- c(attr(ret, "method"), paste0("AUC: ", auc_method))
+
   ret
 }
 

R/aucint.R

@@ -184,6 +184,15 @@ pk.calc.aucint <- function(conc, time,
       fun_log = aucintegrate_log,
       fun_inf = aucintegrate_inf
     )
+  # Add method details as an attribute
+  attr(ret, "method") <- character()
+  auc_method <- if (is.null(method)) {
+    PKNCA.options()$auc.method
+  } else {
+    method
+  }
+  attr(ret, "method") <- c(attr(ret, "method"), paste0("AUC: ", auc_method))
+
   ret
 }
 

R/class-PKNCAresults.R

@@ -89,7 +89,7 @@ as.data.frame.PKNCAresults <- function(x, ..., out_format = c('long', 'wide'), f
     # Since we moved the results into PPTESTCD and PPORRES regardless of what
     # they really are in the source data, remove the extra units and unit
     # conversion columns to allow spread to work.
-    ret <- ret[, setdiff(names(ret), c("PPSTRES", "PPSTRESU", "PPORRESU"))]
+    ret <- ret[, setdiff(names(ret), c("PPSTRES", "PPSTRESU", "PPORRESU", "PPANMETH"))]
     ret <- tidyr::spread(ret, key="PPTESTCD", value="PPORRES")
   }
   ret

R/half.life.R

@@ -134,6 +134,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast,
       data <- data[as.numeric(data$time) > max(end.dose, na.rm = TRUE), ]
     }
   }
+
   # Prepare the return values
   ret <- data.frame(
     # Terminal elimination slope
@@ -156,6 +157,11 @@ pk.calc.half.life <- function(conc, time, tmax, tlast,
     half.life=NA,
     # T1/2 span ratio
     span.ratio=NA)
+
+
+  # Build method attribute
+  attr(ret, "method") <- character()
+
   ret_replacements <-
     c("lambda.z", "r.squared", "adj.r.squared", "lambda.z.corrxy", "lambda.z.time.first",
       "lambda.z.time.last", "lambda.z.n.points", "clast.pred", "half.life", "span.ratio")
@@ -181,6 +187,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast,
     dfK <- data[as.numeric(data$time) > as.numeric(ret$tmax), ]
   }
   if (manually.selected.points) {
+    attr(ret, "method") <- c(attr(ret, "method"), "Lambda Z: Manual selection")
     if (nrow(data) > 0) {
       fit <- fit_half_life(data=data, tlast=ret$tlast, conc_units=conc_units)
       ret[,ret_replacements] <- fit[,ret_replacements]
@@ -271,6 +278,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast,
     ret$tmax <- NULL
   if (!missing(tlast))
     ret$tlast <- NULL
+
   ret
 }
 

R/pk.calc.all.R

@@ -370,6 +370,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
   if (nrow(interval) != 1) {
     stop("Please report a bug.  Interval must be a one-row data.frame")
   }
+
   if (!all(is.na(impute_method))) {
     impute_funs <- PKNCA_impute_fun_list(impute_method)
     stopifnot(length(impute_funs) == 1)
@@ -385,6 +386,11 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
     }
     conc <- impute_data$conc
     time <- impute_data$time
+    tmp_imp_method <- c(
+      paste0("Imputation: ", paste(na.omit(impute_method), collapse = ", "))
+    )
+  } else {
+    tmp_imp_method <- character()
   }
   # Prepare the return value using SDTM names
   ret <- data.frame(PPTESTCD=NA, PPORRES=NA)[-1,]
@@ -492,6 +498,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
           }
         }
       }
+
       # Apply manual inclusion and exclusion
       if (n %in% "half.life") {
         uses_include_hl <- !is.null(include_half.life) && !all(is.na(include_half.life))
@@ -507,6 +514,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
           call_args$time <- call_args$time[!exclude_tf]
         }
       }
+
       # Do the calculation
       tmp_result <- do.call(all_intervals[[n]]$FUN, call_args)
       # The handling of the exclude column is documented in the
@@ -524,6 +532,10 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
         } else {
           NA_character_
         }
+      # The handling of the method column (PPANMETH)
+      tmp_method <- c(tmp_imp_method, attr(tmp_result, "method"))
+      attr(tmp_result, "method") <- NULL
+
       # If the function returns a data frame, save all the returned values,
       # otherwise, save the value returned.
       if (is.data.frame(tmp_result)) {
@@ -557,6 +569,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc,
         data.frame(
           PPTESTCD=tmp_testcd,
           PPORRES=tmp_result,
+          PPANMETH=paste(tmp_method, collapse=". "),
           exclude=exclude_reason,
           stringsAsFactors=FALSE
         )

R/sparse.R

@@ -316,13 +316,24 @@ pk.calc.sparse_auc <- function(conc, time, subject,
       auc.type=auc.type,
       method="linear"
     )
+
   var_auc <- var_sparse_auc(sparse_pk_mean)
-  data.frame(
+  ret <- data.frame(
     sparse_auc=auc,
     # as.numeric() drops the "df" attribute
     sparse_auc_se=sqrt(as.numeric(var_auc)),
     sparse_auc_df=attr(var_auc, "df")
   )
+
+  # Add method details as an attribute
+  for (col in names(ret)) {
+    attr(ret[[col]], "method") <- character()
+    auc_method <- "linear"
+    attr(ret[[col]], "method") <- c(attr(ret[[col]], "method"), paste0("AUC: ", auc_method))
+    attr(ret[[col]], "method") <- c(attr(ret[[col]], "method"), paste0("Sparse: ", "arithmetic mean, <=50% BLQ"))
+  }
+
+  ret
 }
 
 #' @describeIn pk.calc.sparse_auc Compute the AUClast for sparse PK

tests/testthat/test-auc.R

@@ -71,7 +71,7 @@ test_that("pk.calc.auc: Linear AUC when the conc at the end of the interval is a
                              lambda.z=NA,
                              auc.type=t,
                              method="linear"))
-    expect_equal(v1, tests[[t]], info=t)
+    expect_equal(v1, tests[[t]], info=t, ignore_attr = TRUE)
   }
 })
 
@@ -95,7 +95,7 @@ test_that("pk.calc.auc: Linear AUC when the conc at the end of the interval is B
                              lambda.z=NA,
                              auc.type=t,
                              method="linear"))
-    expect_equal(v1, tests[[t]], info=t)
+    expect_equal(v1, tests[[t]], info=t, ignore_attr = TRUE)
   }
 })
 
@@ -118,7 +118,7 @@ test_that("pk.calc.auc: Linear AUC when the conc at the end of the interval is B
                              lambda.z=1,
                              auc.type=t,
                              method="linear"))
-    expect_equal(v1, tests[[t]], info=t)
+    expect_equal(v1, tests[[t]], info=t, ignore_attr = TRUE)
   }
 })
 
@@ -140,7 +140,7 @@ test_that("pk.calc.auc: Linear AUC when when there are multiple BLQ values at th
                              lambda.z=1,
                              auc.type=t,
                              method="linear"))
-    expect_equal(v1, tests[[t]], info=t)
+    expect_equal(v1, tests[[t]], info=t, ignore_attr = TRUE)
   }
 })
 
@@ -171,7 +171,7 @@ test_that("pk.calc.auc: Confirm that center BLQ points are dropped, kept, or imp
                                auc.type=n,
                                conc.blq="keep",
                                method=t))
-      expect_equal(v1, tests[[t]][[n]], info=paste(t, n))
+      expect_equal(v1, tests[[t]][[n]], info=paste(t, n), ignore_attr = TRUE)
     }
   }
 })
@@ -203,7 +203,7 @@ test_that("pk.calc.auc: Confirm BLQ in the middle or end are calculated correctl
                                auc.type=n,
                                conc.blq="keep",
                                method=t))
-      expect_equal(v1, tests[[t]][[n]], info=paste(t, n))
+      expect_equal(v1, tests[[t]][[n]], info=paste(t, n), ignore_attr = TRUE)
     }
   }
 
@@ -238,9 +238,12 @@ test_that("pk.calc.auc: Confirm BLQ in the middle or end are calculated correctl
                                  middle="drop",
                                  last="keep"),
                                method=t))
-      expect_equal(v1,
-                   tests[[t]][[n]],
-                   info=paste(t, n))
+      expect_equal(
+        v1,
+        tests[[t]][[n]],
+        info=paste(t, n),
+        ignore_attr = TRUE
+      )
     }
   }
 })
@@ -274,9 +277,12 @@ test_that("pk.calc.auc: When AUCinf is requested with NA for lambda.z, the resul
                                  middle="drop",
                                  last="keep"),
                                method=t))
-      expect_equal(v1,
-                   tests[[t]][[n]],
-                   info=paste(t, n))
+      expect_equal(
+        v1,
+        tests[[t]][[n]],
+        info=paste(t, n),
+        ignore_attr = TRUE
+      )
     }
   }
 })
@@ -314,9 +320,12 @@ test_that("pk.calc.auc: Test NA at the end", {
                                  middle="drop",
                                  last="keep"),
                                method=t))
-      expect_equal(v1,
-                   tests[[t]][[n]],
-                   info=paste(t, n))
+      expect_equal(
+        v1,
+        tests[[t]][[n]],
+        info=paste(t, n),
+        ignore_attr = TRUE
+      )
     }
 })
 
@@ -349,9 +358,12 @@ test_that("pk.calc.auc: interpolation of times within the time interval", {
                                  middle="drop",
                                  last="keep"),
                                method=t))
-      expect_equal(v1,
-                   tests[[t]][[n]],
-                   info=paste(t, n))
+      expect_equal(
+        v1,
+        tests[[t]][[n]],
+        info=paste(t, n),
+        ignore_attr = TRUE
+      )
     }
   }
 })
@@ -397,7 +409,8 @@ test_that("pk.calc.auc: warning with beginning of interval before the beginning
       expect_equal(
         v1,
         tests[[t]][[n]],
-        info=paste(t, n)
+        info=paste(t, n),
+        ignore_attr = TRUE
       )
     }
   }
@@ -449,7 +462,8 @@ test_that("pk.calc.auc: warning with beginning of interval before the beginning
       )
       expect_equal(v1,
                    tests[[t]][[n]],
-                   info=paste(t, n))
+                   info=paste(t, n),
+                   ignore_attr = TRUE)
     }
 
   # Confirm error with concentration and time not of equal lengths
@@ -563,14 +577,18 @@ test_that("pk.calc.aumc", {
       time=0:3,
       interval=c(0, 3),
       method="linear"),
-    3.75)
+    3.75,
+    ignore_attr = TRUE
+  )
   expect_equal(
     pk.calc.aumc(
       conc=c(0, 1, 1, 0.5),
       time=0:3,
       interval=c(0, 3),
       method="lin up/log down"),
-    2-0.5/log(0.5)+0.5/(log(0.5)^2))
+    2-0.5/log(0.5)+0.5/(log(0.5)^2),
+    ignore_attr = TRUE
+  )
   expect_equal(
     pk.calc.aumc(
       conc=c(0, 1, 1, 0.5),
@@ -579,7 +597,9 @@ test_that("pk.calc.aumc", {
       auc.type="AUCinf",
       lambda.z=1,
       method="lin up/log down"),
-    2 - 0.5/log(0.5) + 0.5/(log(0.5)^2) + 1.5 + 0.5)
+    2 - 0.5/log(0.5) + 0.5/(log(0.5)^2) + 1.5 + 0.5,
+    ignore_attr = TRUE
+  )
 })
 
 
@@ -728,3 +748,34 @@ test_that("AUC with a single concentration measured should return NA (fix #176)"
     )
   )
 })
+
+test_that("pk.calc.auc and wrappers: method attribute is set and propagated", {
+
+  auc_params <- c(
+    "auc", "auc.last", "auc.inf.obs", "auc.inf.pred", "auc.all",
+    "aumc.last", "aumc.inf.obs", "aumc.inf.pred", "aumc.all"
+  )
+  auc_methods <- c("linear", "lin up/log down", "lin-log")
+  auc_args <- list(
+    conc=c(0,1,1),
+    time=0:2,
+    interval=c(0,2),
+    lambda.z=1,
+    clast.pred = 1,
+    clast.obs = 1
+  )
+
+  for (param in auc_params) {
+    auc_fun <- get(paste0("pk.calc.", param))
+    args_fun <- auc_args[intersect(names(auc_args), names(formals(auc_fun)))]
+    for (method in auc_methods) {
+      args_fun$method <- method
+      v <- do.call(auc_fun, args_fun)
+      expect_equal(
+        attr(v, "method"),
+        paste0("AUC: ", method),
+        info=paste("pk.calc.param sets method attribute for", param, "with method", method)
+      )
+    }
+  }
+})