Use different weight strategies (like in Nova)

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)

R/calculate_fit_weights.R

@@ -0,0 +1,114 @@
+#' 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
+    }
+    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)
+        )
+      )
+    }
+  }
+
+  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[which.max(t)] <- 1
+  }
+
+  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
+  }
+
+  if (scheme == "weight_all") {
+    weight_vec <- rep(1, length(t))
+  }
+
+  if (!is.null(weight_vec)) {
+    weight_vec[t < 0] <- 0
+  }
+
+  weight_vec
+}

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,

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
 }