R/states_eval.R

In pierucci/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 <- compat_lazy_dots(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("markov_cycle", names(x))]
    #dplyr::mutate(parameters, !!!x_tidy)[c("markov_cycle", 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 <- pryr::standardise_call(x)
        #x$x <- substitute((.x * rep(x = 1, times = dplyr::n())), list(.x = x$x))
        x[[1]] <- substitute(discount2)
        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) {
          x$expr <- f(x$expr, env = x$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(x, quote(heemod::discount)) &&
        (utils::packageVersion("dplyr") <= "0.5" ||
         utils::packageVersion("lazyeval") <= "0.2")) {
      warning("Install the development version of 'lazyeval' and 'dplyr' ",
              'to avoid the error \'could not find function "n"\'.')
    }
    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
  }
}