fix: update.PKNCAresults handles ordered-factor groups and stops warning about unchanged groups

NEWS.md

@@ -6,6 +6,14 @@ the dosing including dose amount and route.
 
 # Development version
 
+* Bug fix: `update()` on a `PKNCAresults` object now works when group columns
+  are factors whose levels differ between the old and new data (for example,
+  ordered factors like `datasets::Theoph$Subject` after re-leveling); group
+  columns are matched by value while keeping their classes and levels in the
+  results.  `update()` also no longer warns "No concentration data" for every
+  unchanged group, because the intervals are now filtered to the changed groups
+  along with the concentration and dose data (#581).
+
 * Bug fix: `pk.nca()` no longer errors on unsorted concentration-time data.
   Group-level concentration data are now sorted by time before calculation, so
   parameters that use the full group (e.g. `aucint.all` and the other `aucint*`

R/update.PKNCAresults.R

@@ -33,23 +33,73 @@ update.PKNCAresults <- function(object, data, ...) {
   }
   # detect changed groups
   groups_changed <- find_changed_group(old = as_PKNCAdata(object), new = data)
+  if ((nrow(groups_changed$conc) + nrow(groups_changed$dose)) == 0) {
+    # The data differ (e.g. group order), but no group's data changed, so the
+    # results are unchanged.
+    message("No changes detected within any group; keeping existing results")
+    ret <- object
+    ret$data <- data
+    return(addProvenance(ret, replace = TRUE))
+  }
   conc_changed <- filter_changed(as.data.frame(as_PKNCAconc(data)), changed = groups_changed)
   dose_changed <- filter_changed(as.data.frame(as_PKNCAdose(data)), changed = groups_changed)
-  # insert the changed data into the old data as new data!
+  intervals_changed <- filter_changed(data$intervals, changed = groups_changed)
+  # insert the changed data into the old data as new data!  The intervals are
+  # filtered to the changed groups, too, so that unchanged groups are not
+  # calculated and do not warn about their (intentionally) missing
+  # concentration data.
   data_new <- data
   data_new$conc$data <- conc_changed
   data_new$dose$data <- dose_changed
+  data_new$intervals <- intervals_changed
   result_new <- pk.nca(data_new)
   result_new_df <- as.data.frame(result_new)
   result_old_df <- as.data.frame(object)
   drop_old_groups <- unique(getGroups(result_new))
-  result_old_df_keep <- dplyr::anti_join(result_old_df, drop_old_groups, by = names(drop_old_groups))
+  result_old_df_keep <-
+    anti_join_by_value(result_old_df, drop_old_groups, by = names(drop_old_groups))
   ret <- object
   ret$data <- data
   ret$result <- rbind(result_old_df_keep, result_new_df)
   addProvenance(ret, replace = TRUE)
 }
 
+#' Convert factor join-key columns to character so that joins match by value
+#'
+#' Factor group columns can differ in their levels between the old and new data
+#' (e.g. ordered factors after re-leveling or dropping levels), and dplyr joins
+#' error on factors with mismatched levels rather than matching by value.  The
+#' coerced data are only used for matching; the data returned to the user keep
+#' their original classes and factor levels.
+#'
+#' @param data A data.frame
+#' @param cols Column names to coerce when they are factors
+#' @returns `data` with any factor columns in `cols` converted to character
+#' @noRd
+coerce_factor_join_keys <- function(data, cols) {
+  for (nm in cols) {
+    if (is.factor(data[[nm]])) {
+      data[[nm]] <- as.character(data[[nm]])
+    }
+  }
+  data
+}
+
+#' `dplyr::anti_join()` matching factor key columns by value, not by levels
+#'
+#' @param x,y Data.frames to anti-join
+#' @param by Column names to join by
+#' @returns The rows of `x` (unmodified, in their original order) that have no
+#'   match in `y`
+#' @noRd
+anti_join_by_value <- function(x, y, by) {
+  rowid_col <- paste0(max(names(x)), "X")
+  tracking <- coerce_factor_join_keys(x, cols = by)
+  tracking[[rowid_col]] <- seq_len(nrow(x))
+  kept <- dplyr::anti_join(tracking, coerce_factor_join_keys(y, cols = by), by = by)
+  x[kept[[rowid_col]], , drop = FALSE]
+}
+
 # remove the original data.frames from the source data to enable comparison for
 # updates
 strip_source_data <- function(data) {
@@ -76,10 +126,20 @@ find_changed_group <- function(old, new) {
       dose = find_changed_group(old = as_PKNCAdose(old), new = as_PKNCAdose(new))
     )
   } else {
-    # Find subjects that changed (for PKNCAconc or PKNCAdose)
+    # Find subjects that changed (for PKNCAconc or PKNCAdose).  Group columns
+    # are matched by value (factors as character) so that factor level
+    # differences between the old and new data do not prevent joining.
     group_col <- unlist(old$columns$groups, use.names = FALSE)
-    d_nest_old <- tidyr::nest(old$data, data_old = !tidyr::all_of(group_col))
-    d_nest_new <- tidyr::nest(new$data, data_new = !tidyr::all_of(group_col))
+    d_nest_old <-
+      tidyr::nest(
+        coerce_factor_join_keys(old$data, cols = group_col),
+        data_old = !tidyr::all_of(group_col)
+      )
+    d_nest_new <-
+      tidyr::nest(
+        coerce_factor_join_keys(new$data, cols = group_col),
+        data_new = !tidyr::all_of(group_col)
+      )
     d_nest_combo <- dplyr::full_join(d_nest_old, d_nest_new, by = group_col)
     mask_changed_id <-
       vapply(
@@ -105,13 +165,21 @@ filter_changed <- function(data, changed) {
 }
 
 filter_changed_inner_join <- function(data, changed) {
+  by_cols <- intersect(names(data), names(changed))
   if (nrow(changed) == 0) {
     # Return a zero-row data.frame if nothing changed
     data[0,]
-  } else if (length(intersect(names(data), names(changed))) == 0) {
+  } else if (length(by_cols) == 0) {
     # Return all the data if there is not an intersection in column names
     data
   } else {
-    dplyr::inner_join(data, changed, by = intersect(names(data), names(changed)))
+    # Match by value (factors as character) so that factor level differences do
+    # not prevent joining.  The result is only used for row selection, so the
+    # coercion does not affect the data returned by filter_changed().
+    dplyr::inner_join(
+      coerce_factor_join_keys(data, cols = by_cols),
+      coerce_factor_join_keys(changed, cols = by_cols),
+      by = by_cols
+    )
   }
 }

tests/testthat/test-update.PKNCAresults.R

@@ -65,9 +65,152 @@ test_that("update() keeps concentration data", {
   d_conc_setzero$conc[d_conc$Time == 0] <- 0
   o_conc_update <- PKNCAconc(d_conc_setzero, conc~Time|Subject)
   o_data_update <- PKNCAdata(o_conc_update, o_dose)
-  o_nca_update <- suppressWarnings(update(o_nca, o_data_update))
+  # No warnings: unchanged subjects are not recalculated and must not warn
+  # about missing concentration data (issue 581)
+  expect_no_warning(o_nca_update <- update(o_nca, o_data_update))
   expect_equal(
     o_nca_update$data$conc,
     o_conc_update
   )
 })
+
+# Sort results for row-order-insensitive comparison
+sort_update_results <- function(d) {
+  d <- as.data.frame(d)
+  d$Subject <- as.character(d$Subject)
+  d <- d[order(d$Subject, d$start, d$end, d$PPTESTCD), , drop = FALSE]
+  rownames(d) <- NULL
+  d
+}
+
+test_that("update() with ordered-factor groups recalculates only changed subjects without warnings (issue 581)", {
+  # datasets::Theoph$Subject is an ordered factor
+  d_conc <- as.data.frame(datasets::Theoph)
+  d_dose <- d_conc[d_conc$Time == 0, ]
+  o_conc <- PKNCAconc(d_conc, conc~Time|Subject)
+  o_dose <- PKNCAdose(d_dose, Dose~Time|Subject)
+  o_data <- PKNCAdata(o_conc, o_dose)
+  o_nca <- pk.nca(o_data)
+
+  # Modify a single concentration value for one subject
+  d_conc_new <- as.data.frame(datasets::Theoph)
+  idx_change <- which(d_conc_new$Subject == "1")[3]
+  d_conc_new$conc[idx_change] <- d_conc_new$conc[idx_change] * 2
+  o_conc_new <- PKNCAconc(d_conc_new, conc~Time|Subject)
+  o_data_new <- PKNCAdata(o_conc_new, o_dose)
+
+  # Error-free and warning-free (previously either an ordered-factor join
+  # error or one "No concentration data" warning per unchanged subject)
+  expect_no_warning(o_nca_update <- update(o_nca, data = o_data_new))
+
+  # The updated result equals a full recalculation on the modified data
+  o_nca_full <- pk.nca(o_data_new)
+  expect_identical(
+    sort_update_results(as.data.frame(o_nca_update)),
+    sort_update_results(as.data.frame(o_nca_full))
+  )
+  # And the modification really changed the results (the comparison above is
+  # not vacuously comparing to the original results)
+  expect_false(
+    identical(
+      sort_update_results(as.data.frame(o_nca)),
+      sort_update_results(as.data.frame(o_nca_full))
+    )
+  )
+
+  # The ordered factor keeps its class and levels in the returned results
+  df_update <- as.data.frame(o_nca_update)
+  expect_true(is.ordered(df_update$Subject))
+  expect_identical(levels(df_update$Subject), levels(d_conc$Subject))
+
+  # Unchanged subjects are byte-identical to the original results
+  df_orig <- as.data.frame(o_nca)
+  unchanged_update <- as.data.frame(df_update[df_update$Subject != "1", , drop = FALSE])
+  unchanged_orig <- as.data.frame(df_orig[df_orig$Subject != "1", , drop = FALSE])
+  rownames(unchanged_update) <- NULL
+  rownames(unchanged_orig) <- NULL
+  expect_identical(unchanged_update, unchanged_orig)
+})
+
+test_that("update() with character groups recalculates only changed subjects without warnings (issue 581)", {
+  d_conc <- as.data.frame(datasets::Theoph)
+  d_conc$Subject <- as.character(d_conc$Subject)
+  d_dose <- d_conc[d_conc$Time == 0, ]
+  o_conc <- PKNCAconc(d_conc, conc~Time|Subject)
+  o_dose <- PKNCAdose(d_dose, Dose~Time|Subject)
+  o_data <- PKNCAdata(o_conc, o_dose)
+  o_nca <- pk.nca(o_data)
+
+  d_conc_new <- d_conc
+  idx_change <- which(d_conc_new$Subject == "1")[3]
+  d_conc_new$conc[idx_change] <- d_conc_new$conc[idx_change] * 2
+  o_conc_new <- PKNCAconc(d_conc_new, conc~Time|Subject)
+  o_data_new <- PKNCAdata(o_conc_new, o_dose)
+
+  expect_no_warning(o_nca_update <- update(o_nca, data = o_data_new))
+  o_nca_full <- pk.nca(o_data_new)
+  expect_identical(
+    sort_update_results(as.data.frame(o_nca_update)),
+    sort_update_results(as.data.frame(o_nca_full))
+  )
+})
+
+test_that("update() joins ordered-factor groups by value when levels differ (issue 581)", {
+  d_conc <- as.data.frame(datasets::Theoph)
+  d_dose <- d_conc[d_conc$Time == 0, ]
+  o_conc <- PKNCAconc(d_conc, conc~Time|Subject)
+  o_dose <- PKNCAdose(d_dose, Dose~Time|Subject)
+  manual_int <- data.frame(start = 0, end = 24, auclast = TRUE)
+  o_data <- PKNCAdata(o_conc, o_dose, intervals = manual_int)
+  o_nca <- pk.nca(o_data)
+
+  # The new data have the same subjects, but the ordered factor is re-leveled
+  # (numerically sorted instead of the original Theoph level order)
+  relevel_sorted <- function(d) {
+    d$Subject <- factor(as.character(d$Subject), levels = as.character(1:12), ordered = TRUE)
+    d
+  }
+  d_conc_new <- relevel_sorted(d_conc)
+  idx_change <- which(d_conc_new$Subject == "1")[3]
+  d_conc_new$conc[idx_change] <- d_conc_new$conc[idx_change] * 2
+  d_dose_new <- relevel_sorted(d_dose)
+  o_data_new <-
+    PKNCAdata(
+      PKNCAconc(d_conc_new, conc~Time|Subject),
+      PKNCAdose(d_dose_new, Dose~Time|Subject),
+      intervals = manual_int
+    )
+
+  # Previously errored with "Can't join `x$Subject` with `y$Subject` due to
+  # incompatible types" because the ordered-factor levels differ
+  expect_no_warning(o_nca_update <- update(o_nca, data = o_data_new))
+  o_nca_full <- pk.nca(o_data_new)
+  expect_identical(
+    sort_update_results(as.data.frame(o_nca_update)),
+    sort_update_results(as.data.frame(o_nca_full))
+  )
+  # The results keep an ordered factor with a full set of levels
+  df_update <- as.data.frame(o_nca_update)
+  expect_true(is.ordered(df_update$Subject))
+  expect_setequal(levels(df_update$Subject), levels(d_conc$Subject))
+})
+
+test_that("update() without changes in any group keeps the results as-is (issue 581)", {
+  d_conc <- as.data.frame(datasets::Theoph)
+  d_dose <- d_conc[d_conc$Time == 0, ]
+  o_conc <- PKNCAconc(d_conc, conc~Time|Subject)
+  o_dose <- PKNCAdose(d_dose, Dose~Time|Subject)
+  manual_int <- data.frame(start = 0, end = 24, auclast = TRUE)
+  o_data <- PKNCAdata(o_conc, o_dose, intervals = manual_int)
+  o_nca <- pk.nca(o_data)
+
+  # Reorder the subject blocks without changing any subject's data
+  d_conc_new <- d_conc[order(as.integer(d_conc$Subject)), ]
+  o_data_new <- PKNCAdata(PKNCAconc(d_conc_new, conc~Time|Subject), o_dose, intervals = manual_int)
+  expect_message(
+    o_nca_update <- update(o_nca, data = o_data_new),
+    regexp = "No changes detected within any group"
+  )
+  expect_identical(o_nca_update$result, o_nca$result)
+  expect_identical(o_nca_update$data$conc$data, o_data_new$conc$data)
+})

vignettes/v01-introduction-and-usage.Rmd

@@ -453,10 +453,8 @@ o_nca_update <- update(o_nca, o_data_update)
 summary(o_nca_update)
 ```
 
-The per-subject "No concentration data" warnings above occur because `update()`
-filters the concentration data to only the changed subjects while keeping all
-dose rows, so the unchanged subjects have doses but no concentrations during
-the partial recalculation.
+Only the participants whose concentration data changed are recalculated;
+results for all other participants are carried over unchanged.
 
 Now, assume that instead of calculating `auclast` from time 0 to 24, we want to
 calculate `aucint.inf.obs`. We can change the intervals to create a new