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