R/ctstm.R

Defines functions create_IndivCtstmTrans.params_surv_list create_IndivCtstmTrans.params_surv create_IndivCtstmTrans.flexsurvreg create_IndivCtstmTrans.flexsurvreg_list create_IndivCtstmTrans_flexsurvreg create_IndivCtstmTrans indiv_ctstm_sim_stateprobs indiv_ctstm_sim_disease

Documented in create_IndivCtstmTrans create_IndivCtstmTrans.flexsurvreg create_IndivCtstmTrans.flexsurvreg_list create_IndivCtstmTrans.params_surv create_IndivCtstmTrans.params_surv_list

# CtstmTrans base class --------------------------------------------------------
#' An `R6` base class for continuous time state transition models
#'
#' @description 
#' Contains methods that can be used to summarize both individual- and cohort-level
#' continuous time state transition models. That is, this class is relevant for
#' both Markov and semi-Markov multi-state models and does not depend on the 
#' methodology used for prediction of state probabilities. 
#' @format An [`R6::R6Class`] object.
#' @seealso [`create_IndivCtstmTrans()`], [`IndivCtstmTrans`]
#' @keywords internal
#' @export
CtstmTrans <- R6::R6Class(
  "CtstmTrans",
  
  private = list(
    check_base = function(){
      if(!inherits(self$input_data, "input_mats")){
        stop("'input_data' must be an object of class 'input_mats'",
            call. = FALSE)
      }
      if(!inherits(self$params, c("params_surv", 
                                  "params_surv_list"))){
        stop("Class of 'params' is not supported. See documentation.",
             call. = FALSE)
      }
      if (!is.matrix(self$trans_mat)){
        stop("'trans_mat' must be a matrix",
             call. = FALSE)
      }
      if(nrow(self$trans_mat) != ncol(self$trans_mat)){
        stop("'trans_mat' must be a square matrix",
             call. = FALSE)
      }
      if(inherits(self$params, "params_surv_list")){
        if(max(self$trans_mat, na.rm = TRUE) != length(self$params)){
          stop(paste0("The number of models in 'params' must equal the maximum integer in ",
                      "in 'trans_mat'."),
               call. = FALSE)
        }
      }
    },
    
      summary = function(t, type = c("hazard", "cumhazard")){
        self$check()
        type <- match.arg(type)
        res <- data.table(C_ctstm_summary(self, t, type))
        res[, transition_id := transition_id + 1]
        res[, sample := sample + 1]
        if (type == "hazard") setnames(res, "value", "hazard")
        if (type == "cumhazard") setnames(res, "value", "cumhazard")
        return(res[])
      }
    ), # end private
  
  public = list(
    #' @description
    #' Predict the hazard functions for each health state transition.
    #' @param t  A numeric vector of times.
    #' @return A `data.table` with columns `transition_id`,
    #'  `sample`, `strategy_id`, `grp_id`, `t`, and `hazard`.
    hazard = function(t){
      private$summary(t, "hazard")
    },

    #' @description
    #' Predict the cumulative hazard functions for each health state transition.
    #' @param t  A numeric vector of times.    
    #' @return A `data.table` with columns `transition_id`,
    #'  `sample`, `strategy_id`, `grp_id`, `t`, and `cumhazard`.
    cumhazard = function(t){
       private$summary(t, "cumhazard")
    }
  )
)

# IndivCtstmTrans class --------------------------------------------------------
indiv_ctstm_sim_disease <- function(trans_model, max_t = 100, max_age = 100,
                                    progress = NULL){
  sample <- from <- to <- NULL # to avoid no visible bindings CRAN warning
  if (any(trans_model$start_age > max_age)){
    stop("Starting ages in the simulation must be less than maximum age.",
         call. = FALSE)
  }
  if (is.null(progress)){
    progress <- 0
  }
  
  # Simulate
  disprog <- C_ctstm_sim_disease(trans_model, trans_model$start_state - 1, 
                                 trans_model$start_age,
                                 rep(0, trans_model$input_data$n_patients), # Start time is always 0
                                 trans_model$death_state - 1, 
                                 trans_model$clock,
                                 trans_model$reset_states - 1,
                                 ## must match `enum TransitionTypes` in indiv-ctstm.h
                                 match(trans_model$transition_types, c("reset","time","age")) - 1L,
                                 max_t, max_age, progress)
  disprog <- data.table(disprog)
  disprog[, sample := sample + 1]
  disprog[, from := from + 1]
  disprog[, to := to + 1]
  setattr(disprog, "class", 
          c("disprog", "data.table", "data.frame"))
  setattr(disprog, "size",
          c(get_size(trans_model), n_states = nrow(trans_model$trans_mat)))
  setattr(disprog, "absorbing", absorbing(trans_model$trans_mat))
  return(disprog[, ])
}

indiv_ctstm_sim_stateprobs <- function(disprog = NULL, trans_model = NULL, t, ...){
  
  # Simulate disease progression if 'disprog' is missing
  if (is.null(disprog)){
    trans_model$check()
    dots <- list(...)
    fun <- trans_model$sim_disease
    disprog <- do.call("fun", dots)
    
  } else{
    disprog <- copy(disprog)
  }
  
  # Compute state probabilities
  ## Indexing for C++
  disprog[, strategy_index := .GRP, by = "strategy_id"]
  strategy_index <- disprog$strategy_index - 1
  disprog[, strategy_index := NULL]
  
  disprog[, grp_index := .GRP, by = "grp_id"]
  grp_index <- disprog$grp_index - 1
  disprog[, grp_index := NULL]

  ## Dimensions of simulation
  n_grps <- length(unique(disprog$grp_id))
  n_states <- nrow(trans_model$trans_mat)
  n_strategies <- trans_model$input_data$n_strategies
  n_patients <- trans_model$input_data$n_patients
  if (inherits(trans_model$params, "params_surv_list")){
    n_samples <- trans_model$params[[1]]$n_samples
  } else{
    n_samples <- trans_model$params$n_samples
  }
  unique_strategy_id <- unique(trans_model$input_data$strategy_id)
  unique_grp_id <- unique(trans_model$input_data$grp_id)
  
  ## Computation
  stprobs <- C_ctstm_indiv_stateprobs(disprog, 
                                      t, 
                                      n_samples,
                                      n_strategies, 
                                      unique_strategy_id,
                                      strategy_index,
                                      n_grps,
                                      unique_grp_id,
                                      grp_index,
                                      n_states,
                                      n_patients)
  stprobs <- data.table(stprobs)
      
  ## C++ to R indexing
  stprobs[, "sample" := get("sample") + 1]
  stprobs[, "state_id" := get("state_id") + 1]
  
  # Return
  setattr(stprobs, "class", 
          c("stateprobs", "data.table", "data.frame"))
  return(stprobs[])      
}

#' Transitions for an individual-level continuous time state transition model
#'
#' @description
#' Simulate health state transitions in an individual-level continuous time state
#'  transition model using parameters from a multi-state model.
#' @format An [R6::R6Class] object.
#' @example man-roxygen/example-IndivCtstmTrans.R
#' @seealso `IndivCtstmTrans` objects are conveniently created from either 
#' fitted models or parameter objects with [create_IndivCtstmTrans()]. 
#' A complete economic model can be implemented with the [`IndivCtstm`] class. 
#' @name IndivCtstmTrans
NULL

#' @rdname IndivCtstmTrans
#' @export
IndivCtstmTrans <- R6::R6Class(
  "IndivCtstmTrans",
  
  inherit = CtstmTrans,
  
  private = list(
    
    check_history = function(field){
      field_name <- deparse(substitute(field))
      if (length(field) !=1 & length(field) != self$input_data$n_patients){
        stop(paste0("The length of '", field_name, "' must either be 1 or the number ",
                          "of simulated patients."),
                 call. = FALSE)        
      }
      if (length(field) == 1){
        field <- rep(field, self$input_data$n_patients)
      }
      return(field)
    }
  ), # end private

  public = list(
    #' @field params An object of class [`params_surv`] or [`params_surv_list`].
    params = NULL,
    
    #' @field input_data Input data used to simulate health state transitions 
    #' by sample from the probabilistic sensitivity analysis (PSA), treatment strategy and patient.
    #' Must be an object of class [`input_mats`]. If `params` contains parameters from
    #' a list of models (i.e., of class [`params_surv_list`]), then `input_data` 
    #' must contain a unique row for each treatment strategy
    #' and patient; if `params` contains parameters from a joint model 
    #' (i.e., of class [`params_surv`]), then `input_data` must contain a unique
    #' row for each treatment strategy, patient, and transition.
    input_data = NULL,
    
    #' @field trans_mat A transition matrix describing the states and transitions 
    #' in a multi-state model in the format from the [`mstate`][mstate::mstate] package. 
    #' See the documentation for the argument `"trans"` in [`mstate::msprep`].
    trans_mat = NULL, 
    
    #' @field start_state A scalar or vector denoting the starting health state. 
    #' Default is the first health state. If a vector, must be equal to the number of simulated patients.
    start_state = NULL,
    
    #' @field start_age A scalar or vector denoting the starting age of each patient 
    #' in the simulation. Default is 38. If a vector, must be equal to the number of simulated patients.
    start_age = NULL,
    
    #' @field death_state The death state in `trans_mat`. Used with `max_age` 
    #' in `sim_disease` as patients transition to this state upon reaching maximum age.
    #'  By default, it is set to the final absorbing state (i.e., a row in `trans_mat` with all NAs).
    death_state = NULL,
    
    #' @field clock "reset" for a clock-reset model, "forward" for a clock-forward model, 
    #' "mix" for a mixture of clock-reset and clock-forward models by state, and
    #' "mixt" for a mixture of clock-reset and clock-forward models by transition. A clock-reset model 
    #' is a semi-Markov model in which transition rates depend on time since entering a state. 
    #' A clock-forward model is a Markov model in which transition rates depend on time 
    #' since entering the initial state. If `"mix"` is used, then 
    #' `reset_states` must be specified. If `"mixt"` is used, then `transition_types` must
    #' be specified.
    clock = NULL,
    
    #' @field reset_states A vector denoting the states in which time resets. 
    #' Hazard functions are always a function of elapsed time since either the 
    #' start of the model or from when time was previously reset. Only used if 
    #' `clock = "mix"`.
    reset_states = NULL,
    
    #' @field transition_types A vector denoting the type of transition.
    #' The vector is of the same length as the number of transitions
    #' and takes values `"reset"`, `"time"` or `"age"` for hazards that are functions of
    #' reset time, time since study entry or age, respectively. Only used if
    #' `clock = "mixt"`.
    transition_types = NULL,
    
    #' @description
    #' Create a new `IndivCtstmTrans` object.
    #' @param params The `params` field.
    #' @param input_data The `input_data` field.
    #' @param trans_mat The `trans_mat` field.
    #' @param start_state The `start_state` field.
    #' @param start_age The `start_age` field.
    #' @param death_state The `death_state` field.
    #' @param clock The `clock` field.
    #' @param reset_states The `reset_states` field.
    #' @param transition_types The `transition_types` field.
    #' @return A new `IndivCtstmTrans` object.    
    initialize = function(params, input_data, trans_mat, 
                          start_state = 1,
                          start_age = 38,
                          death_state = NULL,
                          clock = c("reset", "forward", "mix", "mixt"),
                          reset_states = NULL,
                          transition_types = NULL) {
      self$params <- params
      self$input_data <- input_data
      self$trans_mat <- trans_mat
      self$clock <- match.arg(clock)
      if (is.null(reset_states)){
        self$reset_states <- vector(mode = "double")
      } else{
        self$reset_states <- reset_states
      }
      if (is.null(transition_types)){
        self$transition_types <- vector(mode = "double")
      } else{
        all_transition_types = c("reset", "time", "age")
        self$transition_types <-
            all_transition_types[pmatch(transition_types, all_transition_types, NA, TRUE)]
        stopifnot(all(self$transition_types %in% all_transition_types),
                  is.null(trans_mat) || length(self$transition_types) == max(trans_mat, na.rm=TRUE))
      }
      
      # history
      self$start_state <- private$check_history(start_state)
      self$start_age <- private$check_history(start_age)
      
      # death state
      if (!is.null(death_state)){
        if (death_state > nrow(trans_mat)){
          stop("'death_state' cannot be larger than the number of rows in 'trans_mat'",
               call. = FALSE)
        } else{
          self$death_state <- death_state
        }
      } else{
        absorbing_states <- absorbing(trans_mat) 
        self$death_state <- absorbing_states[length(absorbing_states)]
      }
    },
    
    #' @description
    #' Simulate disease progression (i.e., individual trajectories through a 
    #' multi-state model using an individual patient simulation).
    #' @param max_t A scalar or vector denoting the length of time to simulate the model.
    #'  If a vector, must be equal to the number of simulated patients.
    #' @param max_age A scalar or vector denoting the maximum age to simulate 
    #' each patient until. If a vector, must be equal to the number of simulated patients.
    #' @param progress An integer, specifying the PSA iteration (i.e., sample) that 
    #' should be printed every progress PSA iterations. For example, if progress = 2,
    #' then every second PSA iteration is printed. Default is NULL, in which case
    #'  no output is printed.
    #' @return An object of class [`disprog`].  
    sim_disease = function(max_t = 100, max_age = 100, progress = NULL){
      self$check()
      disprog <- indiv_ctstm_sim_disease(self,
                                         max_t = max_t,
                                         max_age = max_age,
                                         progress = progress)
      return(disprog)
    },

    #' @description
    #' Simulate health state probabilities from a [disprog] object.
    #' @param t A numeric vector of times.
    #' @param disprog A [disprog] object. If
    #' `NULL`, then this will be simulated prior to computing state probabilities
    #' using `IndivCtstm$sim_disease()`.
    #' @param ... Additional arguments to pass to `IndivCtstm$sim_disease()` if
    #' `disprog = NULL`.
    #' @return An object of class [`stateprobs`].  
    sim_stateprobs = function(t, disprog = NULL, ...){
      self$check()
      if (is.null(disprog)){
        args <- c(trans_model = self, list(...))
        disprog <- do.call("indiv_ctstm_sim_disease", args)
      }
      return(indiv_ctstm_sim_stateprobs(disprog, self, t))
    },
    
    #' @description
    #' Input validation for class. Checks that fields are the correct type. 
    check = function(){
      private$check_base()
    }
    
    
  ) # end public
)

# create_IndivCtstmTrans methods -----------------------------------------------
#' Create `IndivCtstmTrans` object
#' 
#' A generic function for creating an object of class [`IndivCtstmTrans`].
#' @param object An object of the appropriate class containing either a fitted 
#' multi-state model or parameters of a multi-state model. 
#' @param input_data An object of class `expanded_hesim_data` returned by 
#' [`expand.hesim_data`].
#' @param trans_mat The transition matrix describing the states and transitions in a 
#' multi-state model in the format from the [`mstate`][mstate::mstate] package. See [`IndivCtstmTrans`].
#' @param clock "reset" for a clock-reset model, "forward" for a clock-forward model,
#' "mix" for a mixture by state, and "mixt" for a mixture by transition
#' of clock-reset and clock-forward models. See the field `clock` in [`IndivCtstmTrans`].
#' @param reset_states A vector denoting the states in which time resets. See the field 
#' `reset_states` in [`IndivCtstmTrans`].
#' @param transition_types A vector denoting the type for each transition. See the field
#' `transition_types` in [`IndivCtstmTrans`].
#' @inheritParams create_CohortDtstmTrans
#' @param ... Further arguments passed to `IndivCtstmTrans$new()` in [`IndivCtstmTrans`].
#' @return Returns an [`R6Class`] object of class [`IndivCtstmTrans`].
#' @template details-create_disease_model
#' @seealso See [`IndivCtstmTrans`] and [`IndivCtstm`] for examples.
#' @name create_IndivCtstmTrans
#' @rdname create_IndivCtstmTrans
#' @export
create_IndivCtstmTrans <- function(object, ...){
  UseMethod("create_IndivCtstmTrans", object)
}

create_IndivCtstmTrans_flexsurvreg <- function(object, input_data, trans_mat, clock = c("reset", "forward"),
                                               n = 1000, uncertainty = c("normal", "none"),
                                               is_uncertainty_missing, ...) {
  # For backwards compatibility until deprecated point_estimate argument is no longer supported
  dots <- list(...)  
  uncertainty <- deprecate_point_estimate(dots$point_estimate, uncertainty,
                                          is_uncertainty_missing)
  dots <- dots[names(dots) != "point_estimate"]
  
  # Code to always keep
  uncertainty <- match.arg(uncertainty)
  input_mats <- create_input_mats(object, input_data)
  params <- create_params(object, n = n, uncertainty = uncertainty)
  do.call(
    IndivCtstmTrans$new, 
     c(list(input_data = input_mats, params = params, trans_mat = trans_mat,
            clock = match.arg(clock)), 
        dots)
  )
  
}


#' @export
#' @rdname create_IndivCtstmTrans
create_IndivCtstmTrans.flexsurvreg_list <- function(object, input_data, trans_mat, clock = c("reset", "forward"),
                                                    n = 1000, uncertainty = c("normal", "none"), ...){
  create_IndivCtstmTrans_flexsurvreg(
    object = object, 
    input_data = input_data, 
    trans_mat = trans_mat,
    clock = clock,
    n = n, 
    uncertainty = uncertainty,
    is_uncertainty_missing = missing(uncertainty), 
    ...
  )
}

#' @export
#' @rdname create_IndivCtstmTrans
create_IndivCtstmTrans.flexsurvreg <- function(object, input_data, trans_mat, clock = c("reset", "forward"),
                                               n = 1000, uncertainty = c("normal", "none"), ...){
  create_IndivCtstmTrans_flexsurvreg(
    object = object, 
    input_data = input_data, 
    trans_mat = trans_mat,
    clock = clock,
    n = n, uncertainty = uncertainty,
    is_uncertainty_missing = missing(uncertainty),
    ...)
}

#' @export
#' @rdname create_IndivCtstmTrans
create_IndivCtstmTrans.params_surv <- function(object, input_data, trans_mat, 
                                               clock = c("reset", "forward", "mix", "mixt"),
                                               reset_states = NULL, transition_types = NULL,
                                               ...){
  input_mats <- create_input_mats(object, input_data)
  return(IndivCtstmTrans$new(input_data = input_mats, params = object, trans_mat = trans_mat,
                             clock = match.arg(clock), reset_states = reset_states,
                             transition_types = transition_types, ...))
}

#' @export
#' @rdname create_IndivCtstmTrans
create_IndivCtstmTrans.params_surv_list <- function(object, input_data, trans_mat, 
                                                    clock = c("reset", "forward", "mix", "mixt"),
                                                    reset_states = NULL,
                                                    transition_types = NULL, ...){
  input_mats <- create_input_mats(object, input_data)
  return(IndivCtstmTrans$new(input_data = input_mats, params = object, trans_mat = trans_mat,
                             clock = match.arg(clock), reset_states = reset_states,
                             transition_types = transition_types, ...))
}

# IndivCtstm class -------------------------------------------------------------
#' Individual-level continuous time state transition model
#'
#' @description
#' Simulate outcomes from an individual-level continuous time state transition 
#' model (CTSTM). The class supports "clock-reset"
#' (i.e., semi-Markov), "clock-forward" (i.e., Markov), and mixtures of 
#' clock-reset and clock-forward multi-state models as described in 
#' [`IndivCtstmTrans`]. 
#' @format An [R6::R6Class] object.
#' @seealso  The [`IndivCtstmTrans`] documentation
#' describes the class for the transition model and the [`StateVals`] documentation
#' describes the class for the cost and utility models. An [`IndivCtstmTrans`] 
#' object is typically created using [create_IndivCtstmTrans()]. 
#' 
#' There are currently two relevant vignettes. `vignette("mstate")` shows how to
#' parameterize `IndivCtstmTrans` objects in cases where patient-level data is 
#' available by fitting a multi-state models. `vignette("markov-inhomogeneous-indiv")`
#' shows how the time inhomogeneous Markov cohort model in 
#' `vignette("markov-inhomogeneous-cohort")` can be developed as an individual
#' patient simulation; in doing so, it shows how `IndivCtstm` models can be
#' used even without access to patient-level data.
#' @references [Incerti and Jansen (2021)](https://arxiv.org/abs/2102.09437).
#' See Section 2.2 for a mathematical description of an individual-level CTSTM and Section 4.1 for 
#' an example in oncology.
#' @example man-roxygen/example-IndivCtstm.R
#' @name IndivCtstm
NULL

#' @param dr Discount rate.
#' @param type `"predict"` for mean values or `"random"` for random samples 
#' as in `$sim()` in [`StateVals`].
#' @param by_patient If `TRUE`, then QALYs and/or costs are computed at the patient level.
#'  If `FALSE`, then they are averaged across patients by health state.
#' @export
IndivCtstm <- R6::R6Class("IndivCtstm",
  private = list(  
    .stateprobs_ = NULL,
    .qalys_ = NULL,
    .costs_ = NULL,
    disprog_idx = NULL,
    
    sim_ev = function(stateval_list, dr, stateval_type = c("costs", "qalys"),
                      sim_type, by_patient = FALSE, max_t = Inf,
                      lys = FALSE){
     
      stateval_type <- match.arg(stateval_type)
      if(is.null(self$disprog_)){
        stop("You must first simulate disease progression using '$sim_disease'.",
            call. = FALSE)
      }
      check_dr(dr)
      check_StateVals(stateval_list, self$disprog_, object_name = "disprog")
      
      # Indexing patient and strategy ID's
      if (is.null(private$disprog_idx)){
        self$disprog_[, strategy_idx := .GRP, by = "strategy_id"]
        self$disprog_[, patient_idx := .GRP, by = "patient_id"]
        private$disprog_idx <- self$disprog_[, c("strategy_idx", "patient_idx"), with = FALSE]
        self$disprog_[, strategy_idx := NULL]
        self$disprog_[, patient_idx := NULL]
        private$disprog_idx[, strategy_idx := strategy_idx - 1]
        private$disprog_idx[, patient_idx := patient_idx - 1]
      }
      
      #  Categories
      n_cats <- length(stateval_list)
      if (stateval_type == "costs"){
        if (is.null(names(stateval_list))){
          categories <- paste0("Category ", seq(1, n_cats))
        } else{
          categories <- names(stateval_list)
        } # end if/else names for cost models
      } else{
        categories <- "qalys"
      } # end if/else costs vs. qalys
      
      
      # Maximum time
      if (!(length(max_t) %in% c(1, n_cats))){
        stop("'max_t' must either equal the number of cost categories or be of length 1.",
             call. = FALSE)
      }
      if (length(max_t) == 1){
        max_t <- rep(max_t, n_cats)
      }
      
      # Computation
      n_dr <- length(dr)
      ev_list <- vector(mode = "list", length = n_cats * n_dr)
      counter <- 1
      for (i in 1:n_cats){
        for (j in 1:n_dr){
          
          if (stateval_list[[i]]$method == "wlos"){
            C_ev <- C_indiv_ctstm_wlos(self$disprog_, # Note: C++ re-indexing done at C level for disprog_
                                       private$disprog_idx$strategy_idx,
                                       private$disprog_idx$patient_idx,
                                       stateval_list[[i]], dr[j],
                                       sim_type, max_t[i])
          } else if (stateval_list[[i]]$method == "starting"){
            C_ev <- C_indiv_ctstm_starting(self$disprog_, 
                                           private$disprog_idx$strategy_idx,
                                           private$disprog_idx$patient_idx,
                                           stateval_list[[i]], dr[j],
                                           sim_type)
          } else{
            stop("The 'StateVals' 'method' must either be 'wlos' or 'starting'.")
          }
          self$disprog_[, ev := C_ev]
          if (lys){
            C_los <- C_indiv_ctstm_los(self$disprog_, # Note: C++ re-indexing done at C level for disprog_
                                       private$disprog_idx$strategy_idx,
                                       private$disprog_idx$patient_idx,
                                       dr[j])
            self$disprog_[, lys := C_los]
            sdcols <- c("ev", "lys")
          } else{
            sdcols <- "ev"
          }
          if (by_patient == TRUE){
            by_cols <- c("sample", "strategy_id", "patient_id", "grp_id", "from")
            ev_list[[counter]] <- self$disprog_[, lapply(.SD, sum), 
                                                        .SDcols = sdcols,
                                                        by = by_cols]
            setkeyv(ev_list[[counter]], by_cols)
            # Pad missing health states within sample/strategy pairs with  NA's
            ev_list[[counter]] <- ev_list[[counter]][CJ(sample, strategy_id, patient_id, grp_id, from,
                                                              unique = TRUE)]
          } else{
            by_cols <- c("sample", "strategy_id", "grp_id", "from")
            n_patients <- self$trans_model$input_data$n_patients
            ev_list[[counter]] <- self$disprog_[, lapply(.SD, sum), 
                                                        .SDcols = sdcols,
                                                        by = by_cols]
            ev_list[[counter]][, ev := ev/n_patients]
            if(lys) ev_list[[counter]][, lys := lys/n_patients]
            # Pad missing health states within sample/strategy pairs with NA's
            setkeyv(ev_list[[counter]], by_cols)
            ev_list[[counter]] <- ev_list[[counter]][CJ(sample, strategy_id, grp_id, from,
                                                            unique = TRUE)]
          }
          ev_list[[counter]][, "dr" := dr[j]]
          ev_list[[counter]][, "category" := categories[i]]
          self$disprog_[, "ev" := NULL]
          ev_list[[counter]][, ev := ifelse(is.na(ev), 0, ev)] # Replace padded NA's with 0's
          if (lys){
            self$disprog_[, "lys" := NULL]
            ev_list[[counter]][, lys := ifelse(is.na(lys), 0, lys)] # Replace padded NA's with 0's
          }
          counter <- counter + 1
        }
      }
      ev_dt <- rbindlist(ev_list)
      setcolorder(ev_dt, c(by_cols, "dr", "category", sdcols))
      setnames(ev_dt, "from", "state_id")
      if (stateval_type == "costs"){
        setnames(ev_dt, "ev", "costs")
      } else{
        setnames(ev_dt, "ev", "qalys")
        ev_dt[, category := NULL]
      }
      return(ev_dt[,])
     } # end sim_ev

  ), # end private  
                                                  
  public = list(
    #' @field trans_model The model for health state transitions. Must be an object 
    #' of class [`IndivCtstmTrans`]. 
    trans_model = NULL,
    
    #' @field utility_model The model for health state utility. Must be an object of
    #' class [`StateVals`].    
    utility_model = NULL,
    
    #' @field cost_models The models used to predict costs by health state. 
    #' Must be a list of objects of class [`StateVals`], where each element of the 
    #' list represents a different cost category.    
    cost_models = NULL,
    
    #' @field disprog_ An object of class [`disprog`].
    disprog_ = NULL,
    
    #' @field stateprobs_ An object of class [`stateprobs`] simulated using `$sim_stateprobs()`.    
    stateprobs_ = NULL,
    
    #' @field qalys_ An object of class [`qalys`] simulated using `$sim_qalys()`.
    qalys_ = NULL,
    
    #' @field costs_ An object of class [`costs`] simulated using `$sim_costs()`.
    costs_ = NULL,
    
    #' @description
    #' Create a new `IndivCtstm` object.
    #' @param trans_model The `trans_model` field.
    #' @param utility_model The `utility_model` field.
    #' @param cost_models The `cost_models` field.
    #' @return A new `IndivCtstm` object.      
    initialize = function(trans_model = NULL, utility_model = NULL, cost_models = NULL) {
      self$trans_model <- trans_model
      self$utility_model = utility_model
      self$cost_models = cost_models
    },
    
    #' @description
    #' Simulate disease progression (i.e., individual trajectories through a multi-state
    #' model) using `IndivCtstmTrans$sim_disease()`.
    #' @param max_t  A scalar or vector denoting the length of time to simulate the model. 
    #' If a vector, must be equal to the number of simulated patients. 
    #' @param max_age A scalar or vector denoting the maximum age to simulate each patient until.
    #'  If a vector, must be equal to the number of simulated patients.
    #' @param progress An integer, specifying the PSA iteration (i.e., sample) that should be 
    #' printed every `progress` PSA iterations. For example, if `progress = 2`, 
    #' then every second PSA iteration is printed. Default is `NULL`, 
    #' in which case no output is printed.
    #' @return An instance of self with simulated output stored in `disprog_`.
    sim_disease = function(max_t = 100, max_age = 100, progress = NULL){
      if(!inherits(self$trans_model, "IndivCtstmTrans")){
        stop("'trans_model' must be an object of class 'IndivCtstmTrans'",
          call. = FALSE)
      }
      self$qalys_ <- NULL
      self$costs_ <- NULL
      self$stateprobs_ <- NULL
      private$disprog_idx <- NULL
      self$disprog_ <- self$trans_model$sim_disease(max_t = max_t,
                                                    max_age = max_age,
                                                    progress = progress)
      self$stateprobs_ <- NULL
      invisible(self)
    },
    
    #' @description
    #' Simulate health state probabilities as a function of time using the 
    #' simulation output stored in `disprog`.
    #' @param t A numeric vector of times.
    #' @return An instance of `self` with simulated output of class [`stateprobs`] 
    #' stored in `stateprobs_`.    
    sim_stateprobs = function(t){
      if(is.null(self$disprog_)){
        stop("You must first simulate disease progression using '$sim_disease'.",
            call. = FALSE)
      }
      self$stateprobs_ <- indiv_ctstm_sim_stateprobs(self$disprog_,
                                                     self$trans_model,
                                                     t = t)
      invisible(self)
    },
    
    #' @description
    #' Simulate quality-adjusted life-years (QALYs) as a function of `disprog_` and
    #' `utility_model`. 
    #' @param lys If `TRUE`, then life-years are simulated in addition to QALYs.
    #' @return An instance of `self` with simulated output of
    #' class [qalys] stored in `qalys_`.    
    sim_qalys = function(dr = .03, type = c("predict", "random"),
                         lys = TRUE,
                         by_patient = FALSE){
      if(!inherits(self$utility_model, "StateVals")){
        stop("'utility_model' must be an object of class 'StateVals'",
          call. = FALSE)
      }
      type <- match.arg(type)
      self$qalys_ <- private$sim_ev(list(self$utility_model), dr, "qalys", type, by_patient,
                                    lys = lys)
      invisible(self)
    },
    
    #' @description
    #' Simulate costs as a function of `disprog_` and `cost_models`. 
    #' @param max_t  Maximum time duration to compute costs once a patient has
    #'   entered a (new) health state. By default, equal to `Inf`, 
    #'   so that costs are computed over the entire duration that a patient is in
    #'   a given health state. If time varies by each cost category, then time 
    #'   can also be passed as a numeric vector of length equal to the number of 
    #'   cost categories (e.g., `c(1, 2, Inf, 3)` for a model with four cost categories).
    #' @return An instance of `self` with simulated output of class [costs]
    #' stored in `costs_`.    
    sim_costs = function(dr = .03, type = c("predict", "random"), by_patient = FALSE, max_t = Inf){
      if(!is.list(self$cost_models)){
        stop("'cost_models' must be a list of objects of class 'StateVals'",
          call. = FALSE)
      } else{
        for (i in 1:length(self$cost_models)){
          if (!inherits(self$cost_models[[i]], "StateVals")){
            stop("'cost_models' must be a list of objects of class 'StateVals'",
                call. = FALSE)
          }
        }
      }
      type <- match.arg(type)
      self$costs_ <- private$sim_ev(self$cost_models, dr, "costs", type, by_patient, max_t)
      invisible(self)
    },
    
    #' @description
    #' Summarize costs and QALYs so that cost-effectiveness analysis can be performed. 
    #' See [summarize_ce()].    
    #' @param by_grp If `TRUE`, then costs and QALYs are computed by subgroup. If
    #' `FALSE`, then costs and QALYs are aggregated across all patients (and subgroups).
    summarize = function(by_grp = FALSE) {
      check_summarize(self)
      summarize_ce(self$costs_, self$qalys_, by_grp)
    }
    
  ) # end public
) # end class
dincerti/cea documentation built on Feb. 16, 2024, 1:15 p.m.