## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 7,
  fig.height = 5,
  fig.align = "center"
)

## -----------------------------------------------------------------------------
library(dampack)
run_sick_sicker_model <- function(l_params, verbose = FALSE) {
  with(as.list(l_params), {
    # l_params must include:
    # -- disease progression parameters (annual): r_HD, p_S1S2, hr_S1D, hr_S2D, 
    # -- initial cohort distribution: v_s_init
    # -- vector of annual state utilities: v_state_utility = c(u_H, u_S1, u_S2, u_D)
    # -- vector of annual state costs: v_state_cost = c(c_H, c_S1, c_S2, c_D)
    # -- time horizon (in annual cycles): n_cyles
    # -- annual discount rate: r_disc
    
    ####### SET INTERNAL PARAMETERS #########################################
    
    # state names
    v_names_states <- c("H", "S1", "S2", "D")
    n_states <- length(v_names_states)
    
    # vector of discount weights
    v_dw  <- 1 / ((1 + r_disc) ^ (0:n_cycles))
    
    # state rewards
    v_state_cost <- c("H" = c_H, "S1" = c_S1, "S2" = c_S2, "D" = c_D)
    v_state_utility <- c("H" = u_H, "S1" = u_S1, "S2" = u_S2, "D" = u_D)
    
    # transition probability values
    r_S1D <- hr_S1D * r_HD 	 # rate of death in sick state
    r_S2D <- hr_S2D * r_HD   # rate of death in sicker state
    p_S1D <- 1 - exp(-r_S1D) # probability of dying when sick
    p_S2D <- 1 - exp(-r_S2D) # probability of dying when sicker
    p_HD  <- 1 - exp(-r_HD)   # probability of dying when healthy
    
    ## Initialize transition probability matrix 
    # all transitions to a non-death state are assumed to be conditional on survival 
    m_P <- matrix(0, 
                  nrow = n_states, ncol = n_states, 
                  dimnames = list(v_names_states, v_names_states)) # define row and column names
    ## Fill in matrix
    # From H
    m_P["H", "H"]   <- (1 - p_HD) * (1 - p_HS1)    
    m_P["H", "S1"]  <- (1 - p_HD) * p_HS1 
    m_P["H", "D"]   <- p_HD
    # From S1
    m_P["S1", "H"]  <- (1 - p_S1D) * p_S1H
    m_P["S1", "S1"] <- (1 - p_S1D) * (1 - (p_S1H + p_S1S2))
    m_P["S1", "S2"] <- (1 - p_S1D) * p_S1S2
    m_P["S1", "D"]  <- p_S1D
    # From S2
    m_P["S2", "S2"] <- 1 - p_S2D
    m_P["S2", "D"]  <- p_S2D
    # From D
    m_P["D", "D"]   <- 1
    
    # check that all transition matrix entries are between 0 and 1 
    if(!all(m_P <= 1 & m_P >= 0)){
      stop("This is not a valid transition matrix (entries are not between 0 and 1")
    } else
      # check transition matrix rows add up to 1
      if (!all.equal(as.numeric(rowSums(m_P)),rep(1,n_states))){
        stop("This is not a valid transition matrix (rows do not sum to 1)")
      }
    
    ####### INITIALIZATION #########################################
    # create the cohort trace
    m_Trace <- matrix(NA, nrow = n_cycles + 1 , 
                  ncol = n_states,
                  dimnames = list(0:n_cycles, v_names_states)) # create Markov trace
    
    # create vectors of costs and QALYs
    v_C <- v_Q <- numeric(length = n_cycles + 1)
    
    ############# PROCESS ###########################################
    
    m_Trace[1, ] <- v_s_init # initialize Markov trace
    v_C[1] <- 0 # no upfront costs
    v_Q[1] <- 0 # no upfront QALYs
    
    for (t in 1:n_cycles){ # throughout the number of cycles
      m_Trace[t + 1, ] <- m_Trace[t, ] %*% m_P # calculate trace for cycle (t + 1) based on cycle t
      
      v_C[t + 1] <- m_Trace[t + 1, ] %*% v_state_cost
      
      v_Q[t + 1] <- m_Trace[t + 1, ] %*% v_state_utility
      
    }
    
    #############  PRIMARY ECONOMIC OUTPUTS  #########################
    
    # Total discounted costs
    n_tot_cost <- t(v_C) %*% v_dw
    
    # Total discounted QALYs
    n_tot_qaly <- t(v_Q) %*% v_dw
    
    #############  OTHER OUTPUTS   ###################################
    
    # Total discounted life-years (sometimes used instead of QALYs)
    n_tot_ly <- t(m_Trace %*% c(1, 1, 1, 0)) %*% v_dw
    
    ####### RETURN OUTPUT  ###########################################
    out <- list(m_Trace = m_Trace,
                m_P = m_P,
                l_params,
                n_tot_cost = n_tot_cost,
                n_tot_qaly = n_tot_qaly,
                n_tot_ly = n_tot_ly)
    
    return(out)
  }
  )
}

## -----------------------------------------------------------------------------
simulate_strategies <- function(l_params, wtp = 100000){
    # l_params must include:
    # -- *** Model parameters ***
    # -- disease progression parameters (annual): r_HD, p_S1S2, hr_S1D, hr_S2D, 
    # -- initial cohort distribution: v_s_init
    # -- vector of annual state utilities: v_state_utility = c(u_H, u_S1, u_S2, u_D)
    # -- vector of annual state costs: v_state_cost = c(c_H, c_S1, c_S2, c_D)
    # -- time horizon (in annual cycles): n_cyles
    # -- annual discount rate: r_disc
    # -- *** Strategy specific parameters ***
    # -- treartment costs (applied to Sick and Sicker states): c_trtA, c_trtB
    # -- utility with Treatment_A (for Sick state only): u_trtA
    # -- hazard ratio of progression with Treatment_B: hr_S1S1_trtB
  
  with(as.list(l_params), {
    
    ####### SET INTERNAL PARAMETERS #########################################
    # Strategy names
    v_names_strat <- c("No_Treatment", "Treatment_A", "Treatment_B")
    # Number of strategies
    n_strat <- length(v_names_strat)
    
    ## Treatment_A
    # utility impacts
    u_S1_trtA <- u_trtA
    # include treatment costs
    c_S1_trtA <- c_S1 + c_trtA
    c_S2_trtA <- c_S2 + c_trtA
    
    ## Treatment_B
    # progression impacts
    r_S1S2_trtB <- -log(1 - p_S1S2) * hr_S1S2_trtB 
    p_S1S2_trtB <- 1 - exp(-r_S1S2_trtB)
    # include treatment costs
    c_S1_trtB <- c_S1 + c_trtB
    c_S2_trtB <- c_S2 + c_trtB

    
    
    ####### INITIALIZATION #########################################
    # Create cost-effectiveness results data frame
    df_ce <- data.frame(Strategy = v_names_strat,
                        Cost = numeric(n_strat),
                        QALY = numeric(n_strat),
                        LY = numeric(n_strat),
                        stringsAsFactors = FALSE)
    
    
    ######### PROCESS ##############################################
    for (i in 1:n_strat){
      l_params_markov <- list(n_cycles = n_cycles, r_disc = r_disc, v_s_init = v_s_init,
                              c_H =  c_H, c_S1 = c_S2, c_S2 = c_S1, c_D = c_D,
                              u_H =  u_H, u_S1 = u_S2, u_S2 = u_S1, u_D = u_D,
                              r_HD = r_HD, hr_S1D = hr_S1D, hr_S2D = hr_S2D,
                              p_HS1 = p_HS1, p_S1H = p_S1H, p_S1S2 = p_S1S2)
      
      if (v_names_strat[i] == "Treatment_A"){
        l_params_markov$u_S1 <- u_S1_trtA
        l_params_markov$c_S1 <- c_S1_trtA
        l_params_markov$c_S2 <- c_S2_trtA
        
      } else if(v_names_strat[i] == "Treatment_B"){
        l_params_markov$p_S1S2 <- p_S1S2_trtB
        l_params_markov$c_S1   <- c_S1_trtB
        l_params_markov$c_S2   <- c_S2_trtB
      }

      l_result <- run_sick_sicker_model(l_params_markov)
      
      df_ce[i, c("Cost", "QALY", "LY")] <- c(l_result$n_tot_cost,
                                           l_result$n_tot_qaly,
                                           l_result$n_tot_ly)
      df_ce[i, "NMB"] <- l_result$n_tot_qaly * wtp - l_result$n_tot_cost
    }
    
    return(df_ce)
  })
}

## -----------------------------------------------------------------------------
my_params <- c(#Transition probabilities
               "p_HS1", 
               "p_S1H", 
               "p_S1S2", 
               #Hazard ratios
               "hr_S1", 
               "hr_S2",
               "hr_S1S2_trtB",
               #Costs
               "c_H", 
               "c_S1", 
               "c_S2",
               "c_trtA",
               "c_trtB",
               #Utilities
               "u_H",
               "u_S1",
               "u_S2", 
               "u_TrtA")

my_dists <- c(#Transition probabilities
              "beta", 
              "beta", 
              "beta",
              #Hazard ratios
              "log-normal",
              "log-normal", 
              "log-normal",
              #Costs
              "gamma", 
              "gamma", 
              "gamma",
              "gamma", 
              "gamma", 
              #Utilities
              "truncated-normal", 
              "truncated-normal", 
              "truncated-normal", 
              "truncated-normal")

my_parameterization_types <- c(#Transition Probabilities
                               "a, b", 
                               "a, b", 
                               "a, b",
                               #Hazard ratios
                               "mean, sd", 
                               "mean, sd", 
                               "mean, sd",
                               #Costs
                               "shape, scale", 
                               "shape, scale", 
                               "shape, scale",
                               "shape, scale",
                               "shape, scale",
                               #Utilities
                               "mean, sd, ll, ul", 
                               "mean, sd, ll, ul", 
                               "mean, sd, ll, ul",
                               "mean, sd, ll, ul")

my_dists_params <- list(#Transition Probabilities
                        c(7.5, 42.5), 
                        c(12, 12), 
                        c(15, 133),
                        #Hazard ratios
                        c(3, 0.5), 
                        c(10, 0.5),
                        c(0.6, .01),
                        #Costs
                        c(44.5, 45), 
                        c(178, 22.5),
                        c(900, 16.67), 
                        c(576, 21),
                        c(676, 19),
                        #Utilities
                        c(1, 0.01, NA, 1),
                        c(0.75, 0.02, NA, 1), 
                        c(0.5, 0.03, NA, 1),
                        c(0.95, 0.02, NA, 1))
                       
my_psa_params <- gen_psa_samp(params = my_params,
                              dists = my_dists,
                              parameterization_types = my_parameterization_types,
                              dists_params = my_dists_params,
                              n = 100)

## -----------------------------------------------------------------------------
my_params_basecase <- list(p_HS1 = 0.15,
                           p_S1H = 0.5,
                           p_S1S2 = 0.105,
                           r_HD = 0.002, 
                           hr_S1D = 3, 
                           hr_S2D = 10,
                           hr_S1S2_trtB = 0.6,
                           c_H = 2000,
                           c_S1 = 4000,
                           c_S2 = 15000, 
                           c_D = 0,
                           c_trtA = 12000,
                           c_trtB = 13000,
                           u_H = 1,
                           u_S1 = 0.75,
                           u_S2 = 0.5,
                           u_D = 0,
                           u_trtA = 0.95,
                           n_cycles = 75,
                           v_s_init = c(1, 0, 0, 0),
                           r_disc = 0.03)

psa_output <- run_psa(psa_samp = my_psa_params,
                      params_basecase = my_params_basecase,
                      FUN = simulate_strategies,
                      outcomes = c("Cost", "QALY", "LY", "NMB"),
                      strategies = c("No_Treatment", "Treatment_A", "Treatment_B"),
                      progress = FALSE)

## -----------------------------------------------------------------------------
cea_psa <- make_psa_obj(cost = psa_output$Cost$other_outcome, 
                        effect = psa_output$QALY$other_outcome, 
                        parameters = psa_output$Cost$parameters,
                        strategies = psa_output$Cost$strategies,
                        currency = "$")

