R/states_eval.R

In heemod: Markov Models for Health Economic Evaluations

#' Evaluate Markov Model States
#' 
#' @param x An `uneval_state_list` object generated by 
#'   [define_state_list()].
#' @param parameters An `eval_parameters` object 
#'   generated by [eval_parameters()].
#'   
#' @return An `eval_states` object, a list with one 
#'   data.frame per state containing a column per state 
#'   value and a line per cycle.
#'   
#' @keywords internal
eval_state_list <- function(x, parameters) {
  f <- function(x, extracted) {
    x <- discount_hack(x[[extracted]])
    # update calls to dispatch_strategy()
    x <- dispatch_strategy_hack(x)
    
    x_tidy <- x
    # bottleneck!
    lapply(seq_along(x_tidy), function(i){
      #parameters[names(x)[i]] <<- eval(rlang::quo_squash(x_tidy[[i]]), parameters)
      parameters[names(x)[i]] <<- rlang::eval_tidy(x_tidy[[i]], data = parameters)
    })
    parameters[c("model_time", names(x))]
    #dplyr::mutate(parameters, !!!x_tidy)[c("model_time", names(x))]
    
  }
  
  res <- list(
    .dots = lapply(x, f, ".dots"),
    starting_values = lapply(x, f, "starting_values")
  )
  structure(res,
            class = c("eval_state_list", class(res)))
}

get_state_value_names.eval_state_list <- function(x){
  names(x$.dots[[1]])[-1]
}

#' Hack to Work Around a Discounting Issue
#' 
#' This function is a hack to avoid a problem with 
#' discounting when the argument is a constant.
#' 
#' The hack consists in replacing calls to
#' `discount(x)` by `discount(x * rep(1, dplyr::n()))` to
#' ensure `x` is recycled to the correct length.
#' 
#' @param .dots A state object.
#'   
#' @return A modified state object.
#'   
#' @keywords internal
discount_hack <- function(.dots) {
  f <- function (x, env) {
    if (is.atomic(x) || is.name(x)) {
      x
    } else if (is.call(x)) {
      if (discount_check(x[[1]], env)) {
        x <- call_match(x, rlang::eval_bare(rlang::node_car(x)))
        x$time <- substitute(model_time)
      }
      as.call(lapply(x, f, env = env))
    } else if (is.pairlist(x)) {
      as.pairlist(lapply(x, f, env = env))
    } else {
      stop(sprintf(
        "Don't know how to handle type %s.",
        typeof(x)))
    }
  }

  
  do.call(
    structure,
    c(list(
      .Data = lapply(
        .dots,
        function(x) {
          set_expr(x, f(get_expr(x), env = get_env(x)))
        }
      )),
      attributes(.dots)
    )
  )
}

# Ensure only heemod version of discount gets used
discount_check <- function(x, env) {
  if (identical(x, quote(discount)) ||
      identical(x, quote(heemod::discount))) {
    if (identical(environment(eval(x, envir = env)),
                  asNamespace("heemod"))) {
      TRUE
    } else {
      warning("A version of 'discount()' that is not defined by heemod was found.")
      FALSE
    }
  } else {
    FALSE
  }
}