R/efficiency_frontier.R

Defines functions stop_frontier get_frontier.run_model get_frontier.default get_frontier

Documented in get_frontier

#' Return Efficiency Frontier
#' 
#' @param x An `eval_strategy_list` object.
#'   
#' @return A vector of model names on the efficiency
#'   frontier.
#'   
#' @keywords internal
get_frontier <- function(x) {
  UseMethod("get_frontier")
}

get_frontier.default <- function(x) {
  # recursive function
  # if  all strat have same effect
  #     or root strat is more effective
  #   return less costly
  # else
  #   find root strat
  #   center on root strat
  #   remove less effective strat
  #   compute icer from root strat
  #
  #   return strats with NaN ICER
  #
  #   next strat on frontier: lowest icer & effect
  #   remove strat less effective than next strat
  #   recursively apply function on result
  
  if (stop_frontier(x)) {
    sort(
      (x %>% 
         dplyr::filter(.data$.cost == min(.data$.cost)))$.strategy_names)
  } else {
    bm <- get_root_strategy(x)
    ebm <- x$.effect[x$.strategy_names == bm]
    cbm <- x$.cost[x$.strategy_names == bm]
    
    x$.effect <- x$.effect - ebm
    x$.cost <- x$.cost - cbm
    
    x <- x %>% 
      dplyr::filter(.data$.effect >= 0) %>% # not needed in theory
      dplyr::mutate(
        .icer = .data$.cost / .data$.effect
      ) %>% 
      dplyr::arrange(.data$.icer, .data$.effect)
    
    enext <- dplyr::slice(x, 1)$.effect # relies on NaN last sorting
    
    x_res <- x %>% dplyr::filter(.data$.effect >= enext)
    # 0/0 = NaN = NA
    # x/0 = Inf != NA
    # is.na(.icer) excludes same effect more cost
    c(sort((dplyr::filter(x, is.na(.data$.icer)))$.strategy_names),
      get_frontier(x_res))
  }
}

get_frontier.run_model <- function(x) {
  x$frontier
}

stop_frontier <- function(x) {
  length(unique(x$.effect)) == 1 ||
    get_root_strategy(x) %in% 
    (dplyr::filter(x, .data$.effect == max(.data$.effect)))$.strategy_names
}

Try the heemod package in your browser

Any scripts or data that you put into this service are public.

heemod documentation built on July 26, 2023, 5:45 p.m.