R/strategy_define.R

Defines functions get_state_names.uneval_model get_state_value_names.uneval_model set_states.default set_states get_states.default get_states set_transition.default set_transition get_transition.default get_transition define_strategy_ define_strategy

Documented in define_strategy define_strategy_ get_transition

#' Define a Markov Model
#' 
#' Combine information on parameters, transition matrix and 
#' states defined through [define_parameters()], 
#' [define_transition()] and [define_state()] respectively.
#' 
#' This function checks whether the objects are compatible 
#' in the same model (same state names...).
#' 
#' State values and transition probabilities referencing 
#' `state_time` are automatically expanded to implicit 
#' tunnel states.
#' 
#' @param transition An object generated by 
#'   [define_transition()].
#' @param ... Objects generated by [define_state()]. Each object should be named 
#' with the state names of the transition matrix.
#' @param states List of states, only used by 
#'   `define_strategy_` to avoid using `...`.
#' @param starting_values Optional starting values defined
#'   with [define_starting_values()].
#'   
#' @return An object of class `uneval_model` (a list 
#'   containing the unevaluated parameters, matrix and 
#'   states).
#'   
#' @export
#' 
#' @example inst/examples/example_define_strategy.R
define_strategy <- function(...,
                            transition = define_transition(),
                            starting_values = define_starting_values()) {

  states <- define_state_list_(list(...))
  define_strategy_(
    transition = transition,
    states = states,
    starting_values = starting_values
  )
}

#' @rdname define_strategy
#' @export
define_strategy_ <- function(transition, states, starting_values) {
  starting_values <- check_starting_values(
    x = starting_values,
    ref = get_state_value_names(states)
  )
  
  if (! get_state_number(states) == get_state_number(transition)) {
    stop(sprintf(
      "Number of state in model input (%i) differ from number of state in transition object (%i).",
      get_state_number(states),
      length(get_state_names(transition))
    ))
  }
  
  if (! identical(
    as.vector(sort(get_state_names(states))),
    as.vector(sort(get_state_names(transition)))
  )) {
    stop("State names differ from transition object.")
  }
  
  structure(
    list(
      transition = transition,
      states = states,
      starting_values = starting_values
    ), class = "uneval_model")
}

#' Get Markov Model Transition Matrix
#' 
#' Works on both unevaluated and evaluated models.
#' 
#' @param x An `uneval_model` or `eval_model` 
#'   object.
#'   
#' @return An `uneval_matrix` or `uneval_matrix` 
#'   object.
#'   
#' @keywords internal
get_transition <- function(x){
  UseMethod("get_transition")
}

get_transition.default <- function(x){
  x$transition
}

set_transition <- function(x, m) {
  UseMethod("set_transition")
}

set_transition.default <- function(x, m) {
  x$transition <- m
  x
}

get_states <- function(x){
  UseMethod("get_states")
}

get_states.default <- function(x) {
  x$states
}

set_states <- function(x, s) {
  UseMethod("set_states")
}

set_states.default <- function(x, s) {
  x$states <- s
  x
}

get_state_value_names.uneval_model <- function(x) {
  get_state_value_names(get_states(x))
}

get_state_names.uneval_model <- function(x, ...) {
  get_state_names(get_states(x))
}
pierucci/heemod documentation built on July 17, 2022, 9:27 p.m.