From 939d6e01ff3b194eadb80e1a921f8ddb17213a62 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 9 Aug 2026 11:57:03 -0400 Subject: [PATCH] fix: update.PKNCAresults handles ordered-factor groups and stops warning about unchanged groups Fixes two defects in update.PKNCAresults() (issue 581): - Joins between the old and new data errored with "incompatible types" when group columns were factors whose levels differed (e.g. the ordered-factor Subject in datasets::Theoph after re-leveling), because dplyr/vctrs cannot combine ordered factors with different levels. All joins in the update machinery (changed-group detection, changed-row filtering, and dropping recalculated groups from the old results) now match group columns by value, coercing factor join keys to character only for matching; the returned data keep their original classes and factor levels. - Updating one group's data warned "No concentration data" for every unchanged group because the intervals were left unfiltered while the concentration and dose data were filtered to the changed groups. The intervals are now filtered to the changed groups symmetrically, so unchanged groups are not calculated and produce no warnings. The set of recalculated groups and the merged result are unchanged. Also return early (keeping existing results) when the new data differ only in ways that change no group's data, e.g. group-block reordering; previously this crashed in getGroups() on an empty recalculation. The v01 vignette sentence explaining the per-subject warnings is updated because the warnings no longer occur. Co-Authored-By: Claude Fable 5 --- NEWS.md | 8 ++ R/update.PKNCAresults.R | 82 ++++++++++-- tests/testthat/test-update.PKNCAresults.R | 145 +++++++++++++++++++++- vignettes/v01-introduction-and-usage.Rmd | 6 +- 4 files changed, 229 insertions(+), 12 deletions(-) diff --git a/NEWS.md b/NEWS.md index 563fa773..0e9099fc 100644 --- a/NEWS.md +++ b/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*` diff --git a/R/update.PKNCAresults.R b/R/update.PKNCAresults.R index 11eb9dc0..72e60a74 100644 --- a/R/update.PKNCAresults.R +++ b/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 + ) } } diff --git a/tests/testthat/test-update.PKNCAresults.R b/tests/testthat/test-update.PKNCAresults.R index 3db1faba..c01db62c 100644 --- a/tests/testthat/test-update.PKNCAresults.R +++ b/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) +}) diff --git a/vignettes/v01-introduction-and-usage.Rmd b/vignettes/v01-introduction-and-usage.Rmd index 5bbfbb2a..4688d027 100644 --- a/vignettes/v01-introduction-and-usage.Rmd +++ b/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