diff --git a/NAMESPACE b/NAMESPACE
index 07ac060..b12e9c8 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -14,11 +14,13 @@ export(bootstrap_metrics)
export(bootstrap_options)
export(calculate_bayesian_impact)
export(calculate_bootstrap_summ)
+export(calculate_fit_weights)
export(calculate_shrinkage)
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
new file mode 100644
index 0000000..23e1f67
--- /dev/null
+++ b/R/calculate_fit_weights.R
@@ -0,0 +1,179 @@
+#' Construct a fit-weighting scheme specification
+#'
+#' 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).
+#' - `"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 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 scheme parameters `t12_decay` (half-life of decay
+#' in hours, default 48) and `t_start` (delay in hours before decay starts,
+#' default 0).
+#'
+#' @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
+#'
+#' 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` or the scheme is not recognized.
+#' @export
+calculate_fit_weights <- function(weights = NULL, t = NULL) {
+ if (is.null(weights) || is.null(t)) return(NULL)
+
+ 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",
+ "weight_gradient_exponential",
+ "weight_last_only",
+ "weight_last_two_only",
+ "weight_all"
+ )
+
+ if (length(scheme) != 1 || is.na(scheme) || !scheme %in% valid_schemes) {
+ warning("Weighting scheme not recognized, ignoring weights.")
+ return(NULL)
+ }
+
+ structure(list(scheme = scheme, params = params), class = "fit_weights")
+}
+
+.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 (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) {
+ 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)
+ )
+ )
+ }
+}
+
+.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)
+}
+
+.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/R/run_eval.R b/R/run_eval.R
index 9ef7529..bd8946c 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,
@@ -185,6 +193,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 cedda8e..2dcbb13 100644
--- a/R/run_eval_core.R
+++ b/R/run_eval_core.R
@@ -30,13 +30,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,
@@ -69,7 +70,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
),
@@ -102,6 +103,7 @@ run_eval_core <- function(
par_dummy[, eta_names] <- NA_real_
fit_pars <- dplyr::mutate(as.data.frame(par_dummy), id = obs_data$id[1])
} else {
+ ## Data frame with predictive data
## Data frame with predictive data
pred_data <- tibble::tibble(
id = obs_data$id,
@@ -115,7 +117,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`
)
@@ -248,9 +250,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
@@ -263,13 +265,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
+ }
+ 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
+ }
}
- weights
+ binary_weights
}
diff --git a/man/calculate_fit_weights.Rd b/man/calculate_fit_weights.Rd
new file mode 100644
index 0000000..99c94b4
--- /dev/null
+++ b/man/calculate_fit_weights.Rd
@@ -0,0 +1,30 @@
+% 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 \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} or the scheme is not recognized.
+}
+\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{
+\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.
+}
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))
+}
diff --git a/man/handle_sample_weighting.Rd b/man/handle_sample_weighting.Rd
index eddfc54..bfd6d80 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,13 +20,22 @@ 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.
+\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element
+plus any scheme-specific parameters (e.g.
+\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).}
}
\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()}}).
}
\keyword{internal}
diff --git a/man/run_eval.Rd b/man/run_eval.Rd
index 8518afc..03bd96e 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.
+\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element
+plus any scheme-specific parameters (e.g.
+\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).}
\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 377ff2c..c66d856 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.
+\code{"weight_gradient_exponential"}), or a named list with a \code{scheme} element
+plus any scheme-specific parameters (e.g.
+\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).}
\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 @@
+
+
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 @@
+
+
diff --git a/tests/testthat/test-calculate_fit_weights.R b/tests/testthat/test-calculate_fit_weights.R
new file mode 100644
index 0000000..49eb1d0
--- /dev/null
+++ b/tests/testthat/test-calculate_fit_weights.R
@@ -0,0 +1,198 @@
+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))
+})
+
+# ---- 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)
+})
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)) {