From f01f254fe7c66f4af15a3231802716524edf5581 Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Fri, 3 Apr 2026 13:53:52 -0700 Subject: [PATCH 1/8] allow data weight strategies to be used in fit --- R/calculate_fit_weights.R | 107 ++++++++++++++++++++++++++++++++++++++ R/run_eval.R | 9 ++++ R/run_eval_core.R | 42 +++++++++------ 3 files changed, 143 insertions(+), 15 deletions(-) create mode 100644 R/calculate_fit_weights.R diff --git a/R/calculate_fit_weights.R b/R/calculate_fit_weights.R new file mode 100644 index 0000000..e3ec359 --- /dev/null +++ b/R/calculate_fit_weights.R @@ -0,0 +1,107 @@ +#' Calculate time-based sample weights for MAP Bayesian fitting +#' +#' Downweights older observations relative to more recent ones during the +#' iterative MAP Bayesian fitting step. Can be passed as the `weights` +#' argument to [run_eval()]. +#' +#' Available schemes: +#' - `"weight_all"`: all samples weighted equally (weight = 1). +#' - `"weight_last_only"`: only the most recent sample is used (weight = 1), +#' all others are excluded (weight = 0). +#' - `"weight_last_two_only"`: only the two most recent samples are used. +#' - `"weight_gradient_linear"`: weights increase linearly from a minimum +#' (`w1`) for samples older than `t1` days to a maximum (`w2`) for samples +#' more recent than `t2` days. Accepts optional list element `gradient` with +#' named elements `t1`, `w1`, `t2`, `w2`. Default: +#' `list(t1 = 7, w1 = 0, t2 = 2, w2 = 1)`. +#' - `"weight_gradient_exponential"`: weights decay exponentially with the age +#' of the sample. Accepts optional list elements `t12_decay` (half-life of +#' decay in hours, default 48) and `t_start` (delay in hours before decay +#' starts, default 0). +#' +#' For schemes with additional parameters, pass `weights` as a named list with +#' a `scheme` element plus any scheme-specific elements, e.g.: +#' ```r +#' list(scheme = "weight_gradient_exponential", t12_decay = 72) +#' list(scheme = "weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) +#' ``` +#' +#' @param weights weighting scheme: a string with the scheme name, or a named +#' list with a `scheme` element plus optional scheme-specific parameters. +#' @param t numeric vector of observation times (in hours) +#' +#' @returns numeric vector of weights the same length as `t`, or `NULL` if +#' `weights` is `NULL`. +#' @export +calculate_fit_weights <- function(weights = NULL, t = NULL) { + if (is.null(weights) || is.null(t)) return(NULL) + + scheme <- if (is.list(weights)) weights$scheme else weights + + valid_schemes <- c( + "weight_gradient_linear", + "weight_gradient_exponential", + "weight_last_only", + "weight_last_two_only", + "weight_all" + ) + + if (!scheme %in% valid_schemes) { + warning("Weighting scheme not recognized, ignoring weights.") + return(NULL) + } + + weight_vec <- NULL + + if (scheme == "weight_gradient_linear") { + gradient <- list(t1 = 7, w1 = 0, t2 = 2, w2 = 1) + if (is.list(weights) && !is.null(weights$gradient)) { + gradient[names(weights$gradient)] <- weights$gradient + } + t_start <- max(c(0, max(t) - gradient$t1 * 24)) + t_end <- max(c(0, max(t) - gradient$t2 * 24)) + if (t_end <= t_start) { + weight_vec <- ifelse(t >= t_end, gradient$w2, gradient$w1) + } else { + weight_vec <- ifelse( + t <= t_start, gradient$w1, + ifelse( + t >= t_end, gradient$w2, + gradient$w1 + (gradient$w2 - gradient$w1) * (t - t_start) / (t_end - t_start) + ) + ) + } + } + + if (scheme == "weight_gradient_exponential") { + t12_decay <- if (is.list(weights) && !is.null(weights$t12_decay)) weights$t12_decay else 48 + k_decay <- log(2) / t12_decay + t_diff <- max(t) - t + if (is.list(weights) && !is.null(weights$t_start)) { + t_diff <- t_diff - weights$t_start + t_diff <- ifelse(t_diff < 0, 0, t_diff) + } + weight_vec <- exp(-k_decay * t_diff) + } + + if (scheme == "weight_last_only") { + weight_vec <- rep(0, length(t)) + weight_vec[length(t)] <- 1 + } + + if (scheme == "weight_last_two_only") { + weight_vec <- rep(0, length(t)) + weight_vec[length(t)] <- 1 + if (length(t) > 1) weight_vec[length(t) - 1] <- 1 + } + + if (scheme == "weight_all") { + weight_vec <- rep(1, length(t)) + } + + if (!is.null(weight_vec)) { + weight_vec[t < 0] <- 0 + } + + weight_vec +} diff --git a/R/run_eval.R b/R/run_eval.R index c04c3cf..0b60083 100644 --- a/R/run_eval.R +++ b/R/run_eval.R @@ -14,6 +14,14 @@ #' this can be used to group peaks and troughs together, or to group #' observations on the same day together. Grouping will be done prior to #' running the analysis, so cannot be changed afterwards. +#' @param weights optional sample downweighting scheme based on how long ago +#' observations were taken. Either a string naming the scheme (e.g. +#' `”weight_gradient_exponential”`), or a named list with a `scheme` element +#' plus any scheme-specific parameters (e.g. +#' `list(scheme = “weight_gradient_exponential”, t12_decay = 72)`). See +#' [calculate_fit_weights()] for all available schemes and their parameters. +#' Default is `NULL` (no downweighting; all included samples are weighted +#' equally). #' @param censor_covariates with the `proseval` tool in PsN, there is “data #' leakage” (of future covariates data): since the NONMEM dataset in each step #' contains the covariates for the future, this is technically data leakage, @@ -126,6 +134,7 @@ run_eval <- function( .x = data_parsed, .f = run_eval_core, mod_obj = mod_obj, + weights = weights, censor_covariates = censor_covariates, weight_prior = weight_prior, incremental = incremental, diff --git a/R/run_eval_core.R b/R/run_eval_core.R index 7f105a1..649d675 100644 --- a/R/run_eval_core.R +++ b/R/run_eval_core.R @@ -28,13 +28,14 @@ run_eval_core <- function( for(i in seq_along(iterations)) { ## Select which samples should be used in fit, for regular iterative - ## forecasting and incremental. - ## TODO: handle weighting down of earlier samples - weights <- handle_sample_weighting( + ## forecasting and incremental. Applies time-based downweighting if a + ## weighting scheme is provided via the `weights` argument. + sample_weights <- handle_sample_weighting( obs_data, iterations, incremental, - i + i, + weights = weights ) ## Should covariate data be leaked? PsN::proseval does this, @@ -67,7 +68,7 @@ run_eval_core <- function( covariates = cov_data, regimen = data$regimen, weight_prior = weight_prior, - weights = weights, + weights = sample_weights, iov_bins = mod_obj$bins, verbose = FALSE ), @@ -88,7 +89,7 @@ run_eval_core <- function( wres = fit$wres, cwres = fit$cwres, ofv = fit$fit$value, - ss_w = ss(fit$dv, fit$ipred, weights), + ss_w = ss(fit$dv, fit$ipred, sample_weights), `_iteration` = iterations[i], `_grouper` = obs_data$`_grouper` ) @@ -122,7 +123,7 @@ run_eval_core <- function( wres = fit$wres, cwres = fit$cwres, ofv = fit$fit$value, - ss_w = ss(fit$dv, fit$ipred, weights), + ss_w = ss(fit$dv, fit$ipred, sample_weights), `_iteration` = iterations[i], `_grouper` = obs_data$`_grouper` ) @@ -239,9 +240,9 @@ handle_covariate_censoring <- function( #' Handle weighting of samples #' -#' This function is used to select the samples used in the fit (1 or 0), -#' but also to select their weight, if a sample weighting strategy is -#' selected. +#' Binary selection of which samples are used in the fit (0 = excluded, +#' 1 = included), combined with optional continuous downweighting of older +#' samples via a time-based scheme (see [calculate_fit_weights()]). #' #' @inheritParams run_eval_core #' @param obs_data tibble or data.frame with observed data for individual @@ -254,13 +255,24 @@ handle_sample_weighting <- function( obs_data, iterations, incremental, - i + i, + weights = NULL ) { - weights <- rep(0, nrow(obs_data)) + binary_weights <- rep(0, nrow(obs_data)) if(incremental) { # just fit current sample or group - weights[obs_data[["_grouper"]] %in% iterations[i]] <- 1 + binary_weights[obs_data[["_grouper"]] %in% iterations[i]] <- 1 } else { # fit all samples up until current sample - weights[obs_data[["_grouper"]] %in% iterations[1:i]] <- 1 + binary_weights[obs_data[["_grouper"]] %in% iterations[1:i]] <- 1 } - weights + if (!is.null(weights)) { + active_idx <- which(binary_weights == 1) + scheme_weights <- calculate_fit_weights( + weights = weights, + t = obs_data$t[active_idx] + ) + if (!is.null(scheme_weights)) { + binary_weights[active_idx] <- scheme_weights + } + } + binary_weights } From 8d8f5c44c1fcf289eb70fe0d46e6d7856074c76e Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Fri, 3 Apr 2026 14:17:43 -0700 Subject: [PATCH 2/8] weight-based MAP using different strategies --- NAMESPACE | 1 + R/calculate_fit_weights.R | 13 +- man/calculate_fit_weights.Rd | 48 +++ man/handle_sample_weighting.Rd | 17 +- man/run_eval.Rd | 12 +- man/run_eval_core.Rd | 12 +- .../_snaps/run_vpc/nm-busulfan-vpc.new.svg | 306 ++++++++++++++++++ .../_snaps/run_vpc/nm-vanco-vpc.new.svg | 134 ++++++++ tests/testthat/test-calculate_fit_weights.R | 119 +++++++ tests/testthat/test-handle_sample_weighting.R | 50 +++ 10 files changed, 697 insertions(+), 15 deletions(-) create mode 100644 man/calculate_fit_weights.Rd create mode 100644 tests/testthat/_snaps/run_vpc/nm-busulfan-vpc.new.svg create mode 100644 tests/testthat/_snaps/run_vpc/nm-vanco-vpc.new.svg create mode 100644 tests/testthat/test-calculate_fit_weights.R diff --git a/NAMESPACE b/NAMESPACE index 683b32d..48d6f9a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ S3method(print,mipdeval_results_stats_summ) export(accuracy) export(add_grouping_column) export(calculate_bayesian_impact) +export(calculate_fit_weights) export(calculate_shrinkage) export(calculate_stats) export(compare_psn_execute_results) diff --git a/R/calculate_fit_weights.R b/R/calculate_fit_weights.R index e3ec359..195491f 100644 --- a/R/calculate_fit_weights.R +++ b/R/calculate_fit_weights.R @@ -58,6 +58,12 @@ calculate_fit_weights <- function(weights = NULL, t = NULL) { if (is.list(weights) && !is.null(weights$gradient)) { gradient[names(weights$gradient)] <- weights$gradient } + if (gradient$t2 > gradient$t1) { + warning( + "weight_gradient_linear: t2 (", gradient$t2, ") > t1 (", gradient$t1, + "). t1 should be the older threshold and t2 the more recent one." + ) + } t_start <- max(c(0, max(t) - gradient$t1 * 24)) t_end <- max(c(0, max(t) - gradient$t2 * 24)) if (t_end <= t_start) { @@ -86,13 +92,14 @@ calculate_fit_weights <- function(weights = NULL, t = NULL) { if (scheme == "weight_last_only") { weight_vec <- rep(0, length(t)) - weight_vec[length(t)] <- 1 + weight_vec[which.max(t)] <- 1 } if (scheme == "weight_last_two_only") { weight_vec <- rep(0, length(t)) - weight_vec[length(t)] <- 1 - if (length(t) > 1) weight_vec[length(t) - 1] <- 1 + ranked <- order(t, decreasing = TRUE) + weight_vec[ranked[1]] <- 1 + if (length(t) > 1) weight_vec[ranked[2]] <- 1 } if (scheme == "weight_all") { diff --git a/man/calculate_fit_weights.Rd b/man/calculate_fit_weights.Rd new file mode 100644 index 0000000..0eb5d1e --- /dev/null +++ b/man/calculate_fit_weights.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/calculate_fit_weights.R +\name{calculate_fit_weights} +\alias{calculate_fit_weights} +\title{Calculate time-based sample weights for MAP Bayesian fitting} +\usage{ +calculate_fit_weights(weights = NULL, t = NULL) +} +\arguments{ +\item{weights}{weighting scheme: a string with the scheme name, or a named +list with a \code{scheme} element plus optional scheme-specific parameters.} + +\item{t}{numeric vector of observation times (in hours)} +} +\value{ +numeric vector of weights the same length as \code{t}, or \code{NULL} if +\code{weights} is \code{NULL}. +} +\description{ +Downweights older observations relative to more recent ones during the +iterative MAP Bayesian fitting step. Can be passed as the \code{weights} +argument to \code{\link[=run_eval]{run_eval()}}. +} +\details{ +Available schemes: +\itemize{ +\item \code{"weight_all"}: all samples weighted equally (weight = 1). +\item \code{"weight_last_only"}: only the most recent sample is used (weight = 1), +all others are excluded (weight = 0). +\item \code{"weight_last_two_only"}: only the two most recent samples are used. +\item \code{"weight_gradient_linear"}: weights increase linearly from a minimum +(\code{w1}) for samples older than \code{t1} days to a maximum (\code{w2}) for samples +more recent than \code{t2} days. Accepts optional list element \code{gradient} with +named elements \code{t1}, \code{w1}, \code{t2}, \code{w2}. Default: +\code{list(t1 = 7, w1 = 0, t2 = 2, w2 = 1)}. +\item \code{"weight_gradient_exponential"}: weights decay exponentially with the age +of the sample. Accepts optional list elements \code{t12_decay} (half-life of +decay in hours, default 48) and \code{t_start} (delay in hours before decay +starts, default 0). +} + +For schemes with additional parameters, pass \code{weights} as a named list with +a \code{scheme} element plus any scheme-specific elements, e.g.: + +\if{html}{\out{
}}\preformatted{list(scheme = "weight_gradient_exponential", t12_decay = 72) +list(scheme = "weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) +}\if{html}{\out{
}} +} diff --git a/man/handle_sample_weighting.Rd b/man/handle_sample_weighting.Rd index 40e009d..f2655b8 100644 --- a/man/handle_sample_weighting.Rd +++ b/man/handle_sample_weighting.Rd @@ -4,7 +4,7 @@ \alias{handle_sample_weighting} \title{Handle weighting of samples} \usage{ -handle_sample_weighting(obs_data, iterations, incremental, i) +handle_sample_weighting(obs_data, iterations, incremental, i, weights = NULL) } \arguments{ \item{obs_data}{tibble or data.frame with observed data for individual} @@ -20,12 +20,21 @@ approach has been called "model predictive control (MPC)" "regular" MAP in some scenarios. Default is \code{FALSE}.} \item{i}{index} + +\item{weights}{optional sample downweighting scheme based on how long ago +observations were taken. Either a string naming the scheme (e.g. +\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +plus any scheme-specific parameters (e.g. +\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. +Default is \code{NULL} (no downweighting; all included samples are weighted +equally).} } \value{ vector of weights (numeric) } \description{ -This function is used to select the samples used in the fit (1 or 0), -but also to select their weight, if a sample weighting strategy is -selected. +Binary selection of which samples are used in the fit (0 = excluded, +1 = included), combined with optional continuous downweighting of older +samples via a time-based scheme (see \code{\link[=calculate_fit_weights]{calculate_fit_weights()}}). } diff --git a/man/run_eval.Rd b/man/run_eval.Rd index 9c0c94c..f08206e 100644 --- a/man/run_eval.Rd +++ b/man/run_eval.Rd @@ -59,10 +59,14 @@ this can be used to group peaks and troughs together, or to group observations on the same day together. Grouping will be done prior to running the analysis, so cannot be changed afterwards.} -\item{weights}{vector of weights for error. Length of vector should be same -as length of observation vector. If NULL (default), all weights are equal. -Used in both MAP and NP methods. Note that `weights` argument will also -affect residuals (residuals will be scaled too).} +\item{weights}{optional sample downweighting scheme based on how long ago +observations were taken. Either a string naming the scheme (e.g. +\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +plus any scheme-specific parameters (e.g. +\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. +Default is \code{NULL} (no downweighting; all included samples are weighted +equally).} \item{weight_prior}{weighting of priors in relationship to observed data, default = 1} diff --git a/man/run_eval_core.Rd b/man/run_eval_core.Rd index a9c6020..fa083c5 100644 --- a/man/run_eval_core.Rd +++ b/man/run_eval_core.Rd @@ -22,10 +22,14 @@ run_eval_core( \item{data}{NONMEM-style data.frame, or path to CSV file with NONMEM data} -\item{weights}{vector of weights for error. Length of vector should be same -as length of observation vector. If NULL (default), all weights are equal. -Used in both MAP and NP methods. Note that `weights` argument will also -affect residuals (residuals will be scaled too).} +\item{weights}{optional sample downweighting scheme based on how long ago +observations were taken. Either a string naming the scheme (e.g. +\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +plus any scheme-specific parameters (e.g. +\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. +Default is \code{NULL} (no downweighting; all included samples are weighted +equally).} \item{weight_prior}{weighting of priors in relationship to observed data, default = 1} diff --git a/tests/testthat/_snaps/run_vpc/nm-busulfan-vpc.new.svg b/tests/testthat/_snaps/run_vpc/nm-busulfan-vpc.new.svg new file mode 100644 index 0000000..a93e121 --- /dev/null +++ b/tests/testthat/_snaps/run_vpc/nm-busulfan-vpc.new.svg @@ -0,0 +1,306 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +1000 +2000 +3000 +4000 +5000 + + + + + + + + + + + +0 +25 +50 +75 +100 +TIME +DV +nm_busulfan VPC + + diff --git a/tests/testthat/_snaps/run_vpc/nm-vanco-vpc.new.svg b/tests/testthat/_snaps/run_vpc/nm-vanco-vpc.new.svg new file mode 100644 index 0000000..b308e8d --- /dev/null +++ b/tests/testthat/_snaps/run_vpc/nm-vanco-vpc.new.svg @@ -0,0 +1,134 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +10 +20 +30 +40 +50 + + + + + + + + + + +20 +40 +60 +80 +TIME +DV +nm_vanco VPC + + diff --git a/tests/testthat/test-calculate_fit_weights.R b/tests/testthat/test-calculate_fit_weights.R new file mode 100644 index 0000000..d37a244 --- /dev/null +++ b/tests/testthat/test-calculate_fit_weights.R @@ -0,0 +1,119 @@ +test_that("weight_all returns all ones", { + result <- calculate_fit_weights("weight_all", t = c(0, 12, 24, 48)) + expect_equal(result, c(1, 1, 1, 1)) +}) + +test_that("weight_last_only returns 1 for most recent observation", { + result <- calculate_fit_weights("weight_last_only", t = c(0, 12, 24, 48)) + expect_equal(result, c(0, 0, 0, 1)) +}) + +test_that("weight_last_only handles unsorted times", { + result <- calculate_fit_weights("weight_last_only", t = c(24, 0, 48, 12)) + expect_equal(result, c(0, 0, 1, 0)) +}) + +test_that("weight_last_two_only returns 1 for two most recent observations", { + result <- calculate_fit_weights("weight_last_two_only", t = c(0, 12, 24, 48)) + expect_equal(result, c(0, 0, 1, 1)) +}) + +test_that("weight_last_two_only handles unsorted times", { + result <- calculate_fit_weights("weight_last_two_only", t = c(24, 0, 48, 12)) + expect_equal(result, c(1, 0, 1, 0)) +}) + +test_that("weight_last_two_only works with single observation", { + result <- calculate_fit_weights("weight_last_two_only", t = c(10)) + expect_equal(result, c(1)) +}) + +test_that("weight_gradient_exponential produces correct decay", { + t <- c(0, 24, 48) + result <- calculate_fit_weights("weight_gradient_exponential", t = t) + # default t12_decay = 48, most recent sample (t=48) gets weight 1 + expect_equal(result[3], 1) + # t=24 is 24h before max, weight = exp(-log(2)/48 * 24) = exp(-log(2)/2) + expect_equal(result[2], exp(-log(2) / 2), tolerance = 1e-10) + # t=0 is 48h before max, weight = exp(-log(2)/48 * 48) = 0.5 + expect_equal(result[1], 0.5, tolerance = 1e-10) +}) + +test_that("weight_gradient_exponential accepts custom t12_decay", { + t <- c(0, 24) + result <- calculate_fit_weights( + list(scheme = "weight_gradient_exponential", t12_decay = 24), + t = t + ) + expect_equal(result[2], 1) + expect_equal(result[1], 0.5, tolerance = 1e-10) +}) + +test_that("weight_gradient_exponential respects t_start delay", { + t <- c(0, 20, 24) + result <- calculate_fit_weights( + list(scheme = "weight_gradient_exponential", t12_decay = 48, t_start = 4), + t = t + ) + # t=24 is 0h ago, no decay -> weight 1 + expect_equal(result[3], 1) + # t=20 is 4h ago, within t_start window, t_diff clamped to 0 -> weight 1 + expect_equal(result[2], 1) + # t=0 is 24h ago, minus t_start=4 -> effective t_diff=20 + expect_equal(result[1], exp(-log(2) / 48 * 20), tolerance = 1e-10) +}) + +test_that("weight_gradient_linear uses default gradient", { + t <- c(0, 100, 200) + result <- calculate_fit_weights("weight_gradient_linear", t = t) + expect_length(result, 3) + # most recent sample should get highest weight + expect_true(result[3] >= result[2]) + expect_true(result[2] >= result[1]) +}) + +test_that("weight_gradient_linear accepts custom gradient via list", { + result <- calculate_fit_weights( + list(scheme = "weight_gradient_linear", gradient = list(t1 = 3, w1 = 0.2, t2 = 1, w2 = 0.9)), + t = c(0, 24, 48, 72) + ) + expect_length(result, 4) + expect_equal(result[4], 0.9) +}) + +test_that("weight_gradient_linear warns when t2 > t1", { + expect_warning( + calculate_fit_weights( + list(scheme = "weight_gradient_linear", gradient = list(t1 = 1, t2 = 5)), + t = c(0, 24, 48) + ), + "t2.*>.*t1" + ) +}) + +test_that("invalid scheme returns NULL with warning", { + expect_warning( + result <- calculate_fit_weights("nonexistent_scheme", t = c(0, 12)), + "not recognized" + ) + expect_null(result) +}) + +test_that("NULL weights returns NULL", { + expect_null(calculate_fit_weights(NULL, t = c(0, 12))) +}) + +test_that("NULL t returns NULL", { + expect_null(calculate_fit_weights("weight_all", t = NULL)) +}) + +test_that("negative times get weight 0", { + result <- calculate_fit_weights("weight_all", t = c(-10, 0, 12, 24)) + expect_equal(result[1], 0) + expect_equal(result[2:4], c(1, 1, 1)) +}) + +test_that("scheme passed as list with scheme element works", { + result <- calculate_fit_weights(list(scheme = "weight_all"), t = c(0, 12)) + expect_equal(result, c(1, 1)) +}) diff --git a/tests/testthat/test-handle_sample_weighting.R b/tests/testthat/test-handle_sample_weighting.R index 27921f5..2d53531 100644 --- a/tests/testthat/test-handle_sample_weighting.R +++ b/tests/testthat/test-handle_sample_weighting.R @@ -95,6 +95,56 @@ test_that("handle_sample_weighting handles edge case with single observation", { expect_equal(weights_inc, c(1)) }) +test_that("handle_sample_weighting applies weight scheme to active samples", { + obs_data <- data.frame( + t = c(0, 12, 24, 48), + `_grouper` = c(1, 2, 3, 4), + check.names = FALSE + ) + iterations <- c(1, 2, 3, 4) + + # At iteration 3, samples 1-3 are active. weight_last_only should + + # give weight 1 only to the most recent active sample (t=24). + result <- handle_sample_weighting( + obs_data, iterations, incremental = FALSE, i = 3, + weights = "weight_last_only" + ) + expect_equal(result, c(0, 0, 1, 0)) +}) + +test_that("handle_sample_weighting applies exponential weights to active samples", { + obs_data <- data.frame( + t = c(0, 24, 48), + `_grouper` = c(1, 2, 3), + check.names = FALSE + ) + iterations <- c(1, 2, 3) + + result <- handle_sample_weighting( + obs_data, iterations, incremental = FALSE, i = 3, + weights = list(scheme = "weight_gradient_exponential", t12_decay = 48) + ) + expect_equal(result[3], 1) + expect_equal(result[1], 0.5, tolerance = 1e-10) + expect_true(result[2] > result[1] && result[2] < result[3]) +}) + +test_that("handle_sample_weighting without weights gives binary result", { + obs_data <- data.frame( + t = c(0, 12, 24), + `_grouper` = c(1, 2, 3), + check.names = FALSE + ) + iterations <- c(1, 2, 3) + + result <- handle_sample_weighting( + obs_data, iterations, incremental = FALSE, i = 2, + weights = NULL + ) + expect_equal(result, c(1, 1, 0)) +}) + test_that("handle_sample_weighting maintains correct vector length", { # Test with various data sizes for(n_obs in c(1, 5, 10, 100)) { From 62e1dcb499f9d1e643106b952b797c7f65b5443a Mon Sep 17 00:00:00 2001 From: roninsightrx Date: Fri, 3 Apr 2026 15:18:00 -0700 Subject: [PATCH 3/8] Update R/run_eval.R Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- R/run_eval.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/run_eval.R b/R/run_eval.R index 0b60083..0f779f4 100644 --- a/R/run_eval.R +++ b/R/run_eval.R @@ -16,9 +16,9 @@ #' running the analysis, so cannot be changed afterwards. #' @param weights optional sample downweighting scheme based on how long ago #' observations were taken. Either a string naming the scheme (e.g. -#' `”weight_gradient_exponential”`), or a named list with a `scheme` element +#' `"weight_gradient_exponential"`), or a named list with a `scheme` element #' plus any scheme-specific parameters (e.g. -#' `list(scheme = “weight_gradient_exponential”, t12_decay = 72)`). See +#' `list(scheme = "weight_gradient_exponential", t12_decay = 72)`). See #' [calculate_fit_weights()] for all available schemes and their parameters. #' Default is `NULL` (no downweighting; all included samples are weighted #' equally). From 9a2ead866fc22c16375d72386026c763c937df9d Mon Sep 17 00:00:00 2001 From: roninsightrx Date: Fri, 3 Apr 2026 15:18:17 -0700 Subject: [PATCH 4/8] Update man/run_eval.Rd Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- man/run_eval.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/run_eval.Rd b/man/run_eval.Rd index f08206e..2208d17 100644 --- a/man/run_eval.Rd +++ b/man/run_eval.Rd @@ -61,9 +61,9 @@ running the analysis, so cannot be changed afterwards.} \item{weights}{optional sample downweighting scheme based on how long ago observations were taken. Either a string naming the scheme (e.g. -\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +\verb{"weight_gradient_exponential"}), or a named list with a \code{scheme} element plus any scheme-specific parameters (e.g. -\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\verb{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See \code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. Default is \code{NULL} (no downweighting; all included samples are weighted equally).} From 691cf055e054a21d713f478d07be2dd8f78f2fa5 Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Fri, 3 Apr 2026 15:19:06 -0700 Subject: [PATCH 5/8] fix docs --- man/handle_sample_weighting.Rd | 4 ++-- man/run_eval.Rd | 4 ++-- man/run_eval_core.Rd | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/man/handle_sample_weighting.Rd b/man/handle_sample_weighting.Rd index f2655b8..c73341b 100644 --- a/man/handle_sample_weighting.Rd +++ b/man/handle_sample_weighting.Rd @@ -23,9 +23,9 @@ approach has been called "model predictive control (MPC)" \item{weights}{optional sample downweighting scheme based on how long ago observations were taken. Either a string naming the scheme (e.g. -\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element plus any scheme-specific parameters (e.g. -\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\code{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See \code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. Default is \code{NULL} (no downweighting; all included samples are weighted equally).} diff --git a/man/run_eval.Rd b/man/run_eval.Rd index 2208d17..6c46505 100644 --- a/man/run_eval.Rd +++ b/man/run_eval.Rd @@ -61,9 +61,9 @@ running the analysis, so cannot be changed afterwards.} \item{weights}{optional sample downweighting scheme based on how long ago observations were taken. Either a string naming the scheme (e.g. -\verb{"weight_gradient_exponential"}), or a named list with a \code{scheme} element +\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element plus any scheme-specific parameters (e.g. -\verb{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See +\code{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See \code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. Default is \code{NULL} (no downweighting; all included samples are weighted equally).} diff --git a/man/run_eval_core.Rd b/man/run_eval_core.Rd index fa083c5..4382724 100644 --- a/man/run_eval_core.Rd +++ b/man/run_eval_core.Rd @@ -24,9 +24,9 @@ run_eval_core( \item{weights}{optional sample downweighting scheme based on how long ago observations were taken. Either a string naming the scheme (e.g. -\verb{”weight_gradient_exponential”}), or a named list with a \code{scheme} element +\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element plus any scheme-specific parameters (e.g. -\verb{list(scheme = “weight_gradient_exponential”, t12_decay = 72)}). See +\code{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See \code{\link[=calculate_fit_weights]{calculate_fit_weights()}} for all available schemes and their parameters. Default is \code{NULL} (no downweighting; all included samples are weighted equally).} From cca7bd02d1ca6b694fc5b89c79ef8e3c4c581710 Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Thu, 16 Jul 2026 14:45:31 +0200 Subject: [PATCH 6/8] split out weight methods --- NAMESPACE | 1 + R/calculate_fit_weights.R | 207 +++++++++++++++++++++++------------ man/calculate_fit_weights.Rd | 34 ++---- 3 files changed, 145 insertions(+), 97 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a50d66c..b12e9c8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ export(calculate_stats) export(compare_psn_execute_results) export(compare_psn_proseval_results) export(fit_options) +export(fit_weights) export(group_by_dose) export(group_by_time) export(install_default_literature_model) diff --git a/R/calculate_fit_weights.R b/R/calculate_fit_weights.R index 195491f..23e1f67 100644 --- a/R/calculate_fit_weights.R +++ b/R/calculate_fit_weights.R @@ -1,8 +1,9 @@ -#' Calculate time-based sample weights for MAP Bayesian fitting +#' Construct a fit-weighting scheme specification #' -#' Downweights older observations relative to more recent ones during the -#' iterative MAP Bayesian fitting step. Can be passed as the `weights` -#' argument to [run_eval()]. +#' Self-documenting helper that builds a `fit_weights` object describing how +#' older observations should be downweighted relative to more recent ones +#' during the iterative MAP Bayesian fitting step. The result can be passed as +#' the `weights` argument to [run_eval()]. #' #' Available schemes: #' - `"weight_all"`: all samples weighted equally (weight = 1). @@ -11,32 +12,100 @@ #' - `"weight_last_two_only"`: only the two most recent samples are used. #' - `"weight_gradient_linear"`: weights increase linearly from a minimum #' (`w1`) for samples older than `t1` days to a maximum (`w2`) for samples -#' more recent than `t2` days. Accepts optional list element `gradient` with -#' named elements `t1`, `w1`, `t2`, `w2`. Default: +#' more recent than `t2` days. Accepts scheme parameter `gradient`, a list +#' with named elements `t1`, `w1`, `t2`, `w2`. Default: #' `list(t1 = 7, w1 = 0, t2 = 2, w2 = 1)`. #' - `"weight_gradient_exponential"`: weights decay exponentially with the age -#' of the sample. Accepts optional list elements `t12_decay` (half-life of -#' decay in hours, default 48) and `t_start` (delay in hours before decay -#' starts, default 0). +#' of the sample. Accepts scheme parameters `t12_decay` (half-life of decay +#' in hours, default 48) and `t_start` (delay in hours before decay starts, +#' default 0). #' -#' For schemes with additional parameters, pass `weights` as a named list with -#' a `scheme` element plus any scheme-specific elements, e.g.: -#' ```r -#' list(scheme = "weight_gradient_exponential", t12_decay = 72) -#' list(scheme = "weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) -#' ``` +#' @param scheme name of the weighting scheme (see Details). +#' @param ... scheme-specific parameters, e.g. `t12_decay = 72` for +#' `"weight_gradient_exponential"`, or +#' `gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)` for +#' `"weight_gradient_linear"`. +#' +#' @returns an object of class `fit_weights`. +#' @examples +#' fit_weights("weight_all") +#' fit_weights("weight_gradient_exponential", t12_decay = 72) +#' fit_weights("weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) +#' @export +fit_weights <- function( + scheme = c( + "weight_all", + "weight_last_only", + "weight_last_two_only", + "weight_gradient_linear", + "weight_gradient_exponential" + ), + ... +) { + scheme <- match.arg(scheme) + structure( + list(scheme = scheme, params = list(...)), + class = "fit_weights" + ) +} + +#' Calculate time-based sample weights for MAP Bayesian fitting #' -#' @param weights weighting scheme: a string with the scheme name, or a named -#' list with a `scheme` element plus optional scheme-specific parameters. +#' Downweights older observations relative to more recent ones during the +#' iterative MAP Bayesian fitting step. Can be passed as the `weights` +#' argument to [run_eval()]. +#' +#' `weights` may be a [fit_weights()] object, a string naming a scheme, or a +#' named list with a `scheme` element plus optional scheme-specific parameters +#' (e.g. `list(scheme = "weight_gradient_exponential", t12_decay = 72)`). See +#' [fit_weights()] for the available schemes and their parameters. +#' +#' @param weights weighting scheme: a [fit_weights()] object, a string with the +#' scheme name, or a named list with a `scheme` element plus optional +#' scheme-specific parameters. #' @param t numeric vector of observation times (in hours) #' #' @returns numeric vector of weights the same length as `t`, or `NULL` if -#' `weights` is `NULL`. +#' `weights` is `NULL` or the scheme is not recognized. #' @export calculate_fit_weights <- function(weights = NULL, t = NULL) { if (is.null(weights) || is.null(t)) return(NULL) - scheme <- if (is.list(weights)) weights$scheme else weights + weights <- as_fit_weights(weights) + if (is.null(weights)) return(NULL) + + weight_vec <- switch( + weights$scheme, + weight_gradient_linear = .wt_gradient_linear(t, weights$params), + weight_gradient_exponential = .wt_gradient_exponential(t, weights$params), + weight_last_only = .wt_last_only(t), + weight_last_two_only = .wt_last_two_only(t), + weight_all = .wt_all(t) + ) + + if (!is.null(weight_vec)) { + weight_vec[t < 0] <- 0 + } + + weight_vec +} + +# Normalize the various accepted `weights` inputs into a `fit_weights` object. +# Returns NULL (with a warning) when the scheme cannot be recognized, so that +# callers can cleanly ignore invalid input rather than error. +as_fit_weights <- function(weights) { + if (inherits(weights, "fit_weights")) return(weights) + + if (is.character(weights)) { + scheme <- weights + params <- list() + } else if (is.list(weights)) { + scheme <- weights$scheme + params <- weights[setdiff(names(weights), "scheme")] + } else { + warning("Weighting scheme not recognized, ignoring weights.") + return(NULL) + } valid_schemes <- c( "weight_gradient_linear", @@ -46,69 +115,65 @@ calculate_fit_weights <- function(weights = NULL, t = NULL) { "weight_all" ) - if (!scheme %in% valid_schemes) { + if (length(scheme) != 1 || is.na(scheme) || !scheme %in% valid_schemes) { warning("Weighting scheme not recognized, ignoring weights.") return(NULL) } - weight_vec <- NULL - - if (scheme == "weight_gradient_linear") { - gradient <- list(t1 = 7, w1 = 0, t2 = 2, w2 = 1) - if (is.list(weights) && !is.null(weights$gradient)) { - gradient[names(weights$gradient)] <- weights$gradient - } - if (gradient$t2 > gradient$t1) { - warning( - "weight_gradient_linear: t2 (", gradient$t2, ") > t1 (", gradient$t1, - "). t1 should be the older threshold and t2 the more recent one." - ) - } - t_start <- max(c(0, max(t) - gradient$t1 * 24)) - t_end <- max(c(0, max(t) - gradient$t2 * 24)) - if (t_end <= t_start) { - weight_vec <- ifelse(t >= t_end, gradient$w2, gradient$w1) - } else { - weight_vec <- ifelse( - t <= t_start, gradient$w1, - ifelse( - t >= t_end, gradient$w2, - gradient$w1 + (gradient$w2 - gradient$w1) * (t - t_start) / (t_end - t_start) - ) - ) - } - } + structure(list(scheme = scheme, params = params), class = "fit_weights") +} - if (scheme == "weight_gradient_exponential") { - t12_decay <- if (is.list(weights) && !is.null(weights$t12_decay)) weights$t12_decay else 48 - k_decay <- log(2) / t12_decay - t_diff <- max(t) - t - if (is.list(weights) && !is.null(weights$t_start)) { - t_diff <- t_diff - weights$t_start - t_diff <- ifelse(t_diff < 0, 0, t_diff) - } - weight_vec <- exp(-k_decay * t_diff) +.wt_gradient_linear <- function(t, params = list()) { + gradient <- list(t1 = 7, w1 = 0, t2 = 2, w2 = 1) + if (!is.null(params$gradient)) { + gradient[names(params$gradient)] <- params$gradient } - - if (scheme == "weight_last_only") { - weight_vec <- rep(0, length(t)) - weight_vec[which.max(t)] <- 1 + if (gradient$t2 > gradient$t1) { + warning( + "weight_gradient_linear: t2 (", gradient$t2, ") > t1 (", gradient$t1, + "). t1 should be the older threshold and t2 the more recent one." + ) } - - if (scheme == "weight_last_two_only") { - weight_vec <- rep(0, length(t)) - ranked <- order(t, decreasing = TRUE) - weight_vec[ranked[1]] <- 1 - if (length(t) > 1) weight_vec[ranked[2]] <- 1 + t_start <- max(c(0, max(t) - gradient$t1 * 24)) + t_end <- max(c(0, max(t) - gradient$t2 * 24)) + if (t_end <= t_start) { + ifelse(t >= t_end, gradient$w2, gradient$w1) + } else { + ifelse( + t <= t_start, gradient$w1, + ifelse( + t >= t_end, gradient$w2, + gradient$w1 + (gradient$w2 - gradient$w1) * (t - t_start) / (t_end - t_start) + ) + ) } +} - if (scheme == "weight_all") { - weight_vec <- rep(1, length(t)) +.wt_gradient_exponential <- function(t, params = list()) { + t12_decay <- if (!is.null(params$t12_decay)) params$t12_decay else 48 + k_decay <- log(2) / t12_decay + t_diff <- max(t) - t + if (!is.null(params$t_start)) { + t_diff <- t_diff - params$t_start + t_diff <- ifelse(t_diff < 0, 0, t_diff) } + exp(-k_decay * t_diff) +} - if (!is.null(weight_vec)) { - weight_vec[t < 0] <- 0 - } +.wt_last_only <- function(t) { + weight_vec <- rep(0, length(t)) + weight_vec[which.max(t)] <- 1 + weight_vec +} +.wt_last_two_only <- function(t) { + weight_vec <- rep(0, length(t)) + ranked <- order(t, decreasing = TRUE) + weight_vec[ranked[1]] <- 1 + if (length(t) > 1) weight_vec[ranked[2]] <- 1 weight_vec } + +.wt_all <- function(t) { + rep(1, length(t)) +} diff --git a/man/calculate_fit_weights.Rd b/man/calculate_fit_weights.Rd index 0eb5d1e..99c94b4 100644 --- a/man/calculate_fit_weights.Rd +++ b/man/calculate_fit_weights.Rd @@ -7,14 +7,15 @@ calculate_fit_weights(weights = NULL, t = NULL) } \arguments{ -\item{weights}{weighting scheme: a string with the scheme name, or a named -list with a \code{scheme} element plus optional scheme-specific parameters.} +\item{weights}{weighting scheme: a \code{\link[=fit_weights]{fit_weights()}} object, a string with the +scheme name, or a named list with a \code{scheme} element plus optional +scheme-specific parameters.} \item{t}{numeric vector of observation times (in hours)} } \value{ numeric vector of weights the same length as \code{t}, or \code{NULL} if -\code{weights} is \code{NULL}. +\code{weights} is \code{NULL} or the scheme is not recognized. } \description{ Downweights older observations relative to more recent ones during the @@ -22,27 +23,8 @@ iterative MAP Bayesian fitting step. Can be passed as the \code{weights} argument to \code{\link[=run_eval]{run_eval()}}. } \details{ -Available schemes: -\itemize{ -\item \code{"weight_all"}: all samples weighted equally (weight = 1). -\item \code{"weight_last_only"}: only the most recent sample is used (weight = 1), -all others are excluded (weight = 0). -\item \code{"weight_last_two_only"}: only the two most recent samples are used. -\item \code{"weight_gradient_linear"}: weights increase linearly from a minimum -(\code{w1}) for samples older than \code{t1} days to a maximum (\code{w2}) for samples -more recent than \code{t2} days. Accepts optional list element \code{gradient} with -named elements \code{t1}, \code{w1}, \code{t2}, \code{w2}. Default: -\code{list(t1 = 7, w1 = 0, t2 = 2, w2 = 1)}. -\item \code{"weight_gradient_exponential"}: weights decay exponentially with the age -of the sample. Accepts optional list elements \code{t12_decay} (half-life of -decay in hours, default 48) and \code{t_start} (delay in hours before decay -starts, default 0). -} - -For schemes with additional parameters, pass \code{weights} as a named list with -a \code{scheme} element plus any scheme-specific elements, e.g.: - -\if{html}{\out{
}}\preformatted{list(scheme = "weight_gradient_exponential", t12_decay = 72) -list(scheme = "weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) -}\if{html}{\out{
}} +\code{weights} may be a \code{\link[=fit_weights]{fit_weights()}} object, a string naming a scheme, or a +named list with a \code{scheme} element plus optional scheme-specific parameters +(e.g. \code{list(scheme = "weight_gradient_exponential", t12_decay = 72)}). See +\code{\link[=fit_weights]{fit_weights()}} for the available schemes and their parameters. } From 397ed1fac14d20ab8c62feba07de7ef7b27e6bf0 Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Thu, 16 Jul 2026 14:46:21 +0200 Subject: [PATCH 7/8] add new tests --- tests/testthat/test-calculate_fit_weights.R | 79 +++++++++++++++++++++ 1 file changed, 79 insertions(+) diff --git a/tests/testthat/test-calculate_fit_weights.R b/tests/testthat/test-calculate_fit_weights.R index d37a244..49eb1d0 100644 --- a/tests/testthat/test-calculate_fit_weights.R +++ b/tests/testthat/test-calculate_fit_weights.R @@ -117,3 +117,82 @@ test_that("scheme passed as list with scheme element works", { result <- calculate_fit_weights(list(scheme = "weight_all"), t = c(0, 12)) expect_equal(result, c(1, 1)) }) + +# ---- fit_weights() constructor ---- + +test_that("fit_weights returns a fit_weights object with scheme and params", { + fw <- fit_weights("weight_gradient_exponential", t12_decay = 72) + expect_s3_class(fw, "fit_weights") + expect_equal(fw$scheme, "weight_gradient_exponential") + expect_equal(fw$params, list(t12_decay = 72)) +}) + +test_that("fit_weights defaults to weight_all and supports partial matching", { + expect_equal(fit_weights()$scheme, "weight_all") + expect_equal(fit_weights("weight_last_two")$scheme, "weight_last_two_only") +}) + +test_that("fit_weights errors on unknown scheme", { + expect_error(fit_weights("nonexistent_scheme")) +}) + +# ---- calculate_fit_weights() with fit_weights objects ---- + +test_that("fit_weights object produces same result as string form", { + t <- c(0, 12, 24, 48) + expect_equal( + calculate_fit_weights(fit_weights("weight_last_only"), t = t), + calculate_fit_weights("weight_last_only", t = t) + ) +}) + +test_that("fit_weights object passes scheme params through", { + t <- c(0, 24) + from_obj <- calculate_fit_weights(fit_weights("weight_gradient_exponential", t12_decay = 24), t = t) + from_list <- calculate_fit_weights(list(scheme = "weight_gradient_exponential", t12_decay = 24), t = t) + expect_equal(from_obj, from_list) + expect_equal(from_obj[2], 1) + expect_equal(from_obj[1], 0.5, tolerance = 1e-10) +}) + +test_that("fit_weights object passes linear gradient param through", { + result <- calculate_fit_weights( + fit_weights("weight_gradient_linear", gradient = list(t1 = 3, w1 = 0.2, t2 = 1, w2 = 0.9)), + t = c(0, 24, 48, 72) + ) + expect_equal(result[4], 0.9) +}) + +# ---- input validation guards ---- + +test_that("NA scheme returns NULL with warning", { + expect_warning( + result <- calculate_fit_weights(NA_character_, t = c(0, 12)), + "not recognized" + ) + expect_null(result) +}) + +test_that("non-scalar scheme returns NULL with warning", { + expect_warning( + result <- calculate_fit_weights(c("weight_all", "weight_last_only"), t = c(0, 12)), + "not recognized" + ) + expect_null(result) +}) + +test_that("numeric weights input returns NULL with warning", { + expect_warning( + result <- calculate_fit_weights(c(1, 0, 1), t = c(0, 12, 24)), + "not recognized" + ) + expect_null(result) +}) + +test_that("list without scheme element returns NULL with warning", { + expect_warning( + result <- calculate_fit_weights(list(t12_decay = 48), t = c(0, 12)), + "not recognized" + ) + expect_null(result) +}) From 96cb07ab4ba020235170242600209054460baae0 Mon Sep 17 00:00:00 2001 From: Ron Keizer Date: Thu, 16 Jul 2026 14:46:30 +0200 Subject: [PATCH 8/8] add man page --- man/fit_weights.Rd | 52 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 man/fit_weights.Rd diff --git a/man/fit_weights.Rd b/man/fit_weights.Rd new file mode 100644 index 0000000..2241b1e --- /dev/null +++ b/man/fit_weights.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/calculate_fit_weights.R +\name{fit_weights} +\alias{fit_weights} +\title{Construct a fit-weighting scheme specification} +\usage{ +fit_weights( + scheme = c("weight_all", "weight_last_only", "weight_last_two_only", + "weight_gradient_linear", "weight_gradient_exponential"), + ... +) +} +\arguments{ +\item{scheme}{name of the weighting scheme (see Details).} + +\item{...}{scheme-specific parameters, e.g. \code{t12_decay = 72} for +\code{"weight_gradient_exponential"}, or +\code{gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)} for +\code{"weight_gradient_linear"}.} +} +\value{ +an object of class \code{fit_weights}. +} +\description{ +Self-documenting helper that builds a \code{fit_weights} object describing how +older observations should be downweighted relative to more recent ones +during the iterative MAP Bayesian fitting step. The result can be passed as +the \code{weights} argument to \code{\link[=run_eval]{run_eval()}}. +} +\details{ +Available schemes: +\itemize{ +\item \code{"weight_all"}: all samples weighted equally (weight = 1). +\item \code{"weight_last_only"}: only the most recent sample is used (weight = 1), +all others are excluded (weight = 0). +\item \code{"weight_last_two_only"}: only the two most recent samples are used. +\item \code{"weight_gradient_linear"}: weights increase linearly from a minimum +(\code{w1}) for samples older than \code{t1} days to a maximum (\code{w2}) for samples +more recent than \code{t2} days. Accepts scheme parameter \code{gradient}, a list +with named elements \code{t1}, \code{w1}, \code{t2}, \code{w2}. Default: +\code{list(t1 = 7, w1 = 0, t2 = 2, w2 = 1)}. +\item \code{"weight_gradient_exponential"}: weights decay exponentially with the age +of the sample. Accepts scheme parameters \code{t12_decay} (half-life of decay +in hours, default 48) and \code{t_start} (delay in hours before decay starts, +default 0). +} +} +\examples{ +fit_weights("weight_all") +fit_weights("weight_gradient_exponential", t12_decay = 72) +fit_weights("weight_gradient_linear", gradient = list(t1 = 5, w1 = 0.1, t2 = 1, w2 = 1)) +}