|
|
@@ -0,0 +1,367 @@
|
|
|
+library(tidyverse)
|
|
|
+library(here)
|
|
|
+
|
|
|
+# optim(par = c(0, 1),
|
|
|
+# fn = function(params, beta_shape1, beta_shape2) {
|
|
|
+# a <- beta_shape1
|
|
|
+# b <- beta_shape2
|
|
|
+# beta_mean <- a / (a + b)
|
|
|
+# beta_var <- a * b / ((a + b) ^ 2 * (a + b + 1))
|
|
|
+# moments <- logitnorm::momentsLogitnorm(params[1], params[2])
|
|
|
+# (moments[1] - beta_mean) ^ 2 + (moments[2] - beta_var) ^ 2
|
|
|
+# },
|
|
|
+# beta_shape1 = 69.7,
|
|
|
+# beta_shape2 = 162.633333,
|
|
|
+# method = "BFGS")
|
|
|
+
|
|
|
+theta_mean <- c(-5.490935,
|
|
|
+ -0.0367022,
|
|
|
+ 0.768536,
|
|
|
+ -1.344474,
|
|
|
+ 0.3740968,
|
|
|
+ -4.0944849,
|
|
|
+ -4.0944849,
|
|
|
+ -3.2869827,
|
|
|
+ log(5294^2 / sqrt(1487 ^ 2 + 5294 ^ 2)),
|
|
|
+ 1.753857,
|
|
|
+ 1.1100567,
|
|
|
+ -0.8513930)
|
|
|
+theta_var <- matrix(0, 12, 12)
|
|
|
+theta_var[1:5,1:5] <- c(+4.32191e-2, -7.83e-4, -7.247e-3, -6.42e-4, -5.691e-3,
|
|
|
+ -7.83e-4, +2.71566e-5, +3.3e-5, -1.1e-4, +2.8e-8,
|
|
|
+ -7.247e-3, +3.3e-5, +1.18954e-2, +1.84e-4, +5.1e-6,
|
|
|
+ -6.42e-4, -1.11e-4, +1.84e-4, +1.46369e-1, +2.59e-4,
|
|
|
+ -5.691e-3, +2.8e-8, +5.1e-6, +2.59e-4, +2.25151e-3)
|
|
|
+theta_var[6,6] <- 0.6527744^2
|
|
|
+theta_var[7,7] <- 0.6527744^2
|
|
|
+theta_var[8,8] <- 0.4889407^2
|
|
|
+theta_var[9,9] <- log(1487^2/5294^2 + 1)
|
|
|
+theta_var[10,10] <- 0.235360^2
|
|
|
+theta_var[11,11] <- 0.2147719^2
|
|
|
+theta_var[12,12] <- 0.1433964^2
|
|
|
+
|
|
|
+# ggplot(tibble(x = c(0, 0.2)), aes(x)) +
|
|
|
+# stat_function(aes(colour = "Beta(4, 96)"), fun = dbeta, args = list(shape1 = 4, shape2 = 96)) +
|
|
|
+# stat_function(aes(colour = "LogitN(-3.29, 0.49)"), fun = logitnorm::dlogitnorm, args = list(mu = -3.2869827, sigma = 0.4889407)) +
|
|
|
+# labs(x = "Re-revision risk", y = "Probability density function", colour = NULL) +
|
|
|
+# theme_bw()
|
|
|
+# ggsave(filename = "logitnormal-approx.png", width = 20.28, height = 10.62, units = "cm", scale = 0.8)
|
|
|
+#
|
|
|
+#
|
|
|
+# ggplot(tibble(x = c(0, 20000)), aes(x)) +
|
|
|
+# stat_function(aes(colour = "Gamma(12.67, 417.67)"), fun = dgamma, args = list(shape = 12.67, scale = 417.67)) +
|
|
|
+# stat_function(aes(colour = "LogN(8.54, 0.28)"), fun = dlnorm, args = list(meanlog = 8.53636, sdlog = 0.2755688)) +
|
|
|
+# labs(x = "Cost of revision THR", y = "Probability density function", colour = NULL) +
|
|
|
+# theme_bw()
|
|
|
+# ggsave(filename = "lognormal-approx.png", width = 20.28, height = 10.62, units = "cm", scale = 0.8)
|
|
|
+
|
|
|
+state_labels <- c("Standard_SuccessP", "Standard_Revision", "Standard_SuccessR", "Standard_Death",
|
|
|
+ "NP1_SuccessP", "NP1_Revision", "NP1_SuccessR", "NP1_Death")
|
|
|
+cycle_labels <- 1:60
|
|
|
+output_labels <- c("Standard_Costs", "Standard_QALYs", "NP1_Costs", "NP1_QALYs", "Incremental_Costs", "Incremental_QALYs")
|
|
|
+param_labels <- c("beta_0", "beta_age", "beta_male", "beta_NP1", "ln_gamma", "logit_phi", "logit_psi", "logit_rho", "ln_C", "logit_U_SuccessP", "logit_U_SuccessR", "logit_U_Revision")
|
|
|
+
|
|
|
+names(theta_mean) <- param_labels
|
|
|
+dimnames(theta_var) <- list(theta_i = param_labels, theta_j = param_labels)
|
|
|
+
|
|
|
+age <- 60
|
|
|
+male <- 0
|
|
|
+
|
|
|
+mortality <- function(age, male) {
|
|
|
+ if (male) {
|
|
|
+ if (age < 45) 0.00151
|
|
|
+ else if (age < 55) 0.00393
|
|
|
+ else if (age < 65) 0.0109
|
|
|
+ else if (age < 75) 0.0316
|
|
|
+ else if (age < 85) 0.0801
|
|
|
+ else 0.1879
|
|
|
+ } else {
|
|
|
+
|
|
|
+ if (age < 45) 0.00099
|
|
|
+ else if (age < 55) 0.0026
|
|
|
+ else if (age < 65) 0.0067
|
|
|
+ else if (age < 75) 0.0193
|
|
|
+ else if (age < 85) 0.0535
|
|
|
+ else 0.1548
|
|
|
+ }
|
|
|
+}
|
|
|
+
|
|
|
+logit <- function(p) log(p) - log(1 - p)
|
|
|
+expit <- function(x) 1 / (1 + exp(-x))
|
|
|
+
|
|
|
+x <- array(0, dim = c(8, 60), dimnames = list(state = state_labels, cycle = cycle_labels))
|
|
|
+P <- array(0, dim = c(8, 8, 60), dimnames = list(state_from = state_labels, state_to = state_labels, cycle = cycle_labels))
|
|
|
+V <- array(0, dim = c(8, 6, 60), dimnames = list(state = state_labels, output = output_labels, cycle = cycle_labels))
|
|
|
+gt <- array(NA_real_, dim = c(6, 60), dimnames = list(output = output_labels, cycle = cycle_labels))
|
|
|
+dx <- array(0, dim = c(8, 60, 12), dimnames = list(state = state_labels, cycle = cycle_labels, theta_i = param_labels))
|
|
|
+d2x <- array(0, dim = c(8, 60, 12, 12), dimnames = list(state = state_labels, cycle = cycle_labels, theta_i = param_labels, theta_j = param_labels))
|
|
|
+dP <- array(0, dim = c(8, 8, 60, 12), dimnames = list(state_from = state_labels, state_to = state_labels, cycle = cycle_labels, theta_i = param_labels))
|
|
|
+d2P <- array(0, dim = c(8, 8, 60, 12, 12), dimnames = list(state_from = state_labels, state_to = state_labels, cycle = cycle_labels, theta_i = param_labels, theta_j = param_labels))
|
|
|
+dV <- array(0, dim = c(8, 6, 60, 12), dimnames = list(state = state_labels, output = output_labels, cycle = cycle_labels, theta_i = param_labels))
|
|
|
+d2V <- array(0, dim = c(8, 6, 60, 12, 12), dimnames = list(state = state_labels, output = output_labels, cycle = cycle_labels, theta_i = param_labels, theta_j = param_labels))
|
|
|
+dgt <- array(NA_real_, dim = c(6, 60, 12), dimnames = list(output = output_labels, cycle = cycle_labels, theta_i = param_labels))
|
|
|
+d2gt <- array(NA_real_, dim = c(6, 60, 12, 12), dimnames = list(output = output_labels, cycle = cycle_labels, theta_i = param_labels, theta_j = param_labels))
|
|
|
+
|
|
|
+# INITIAL STATE DISTRIBUTION
|
|
|
+x[4, 1] <- expit(theta_mean[6])
|
|
|
+x[1, 1] <- 1 - x[4, 1]
|
|
|
+x[8, 1] <- expit(theta_mean[6])
|
|
|
+x[5, 1] <- 1 - x[8, 1]
|
|
|
+
|
|
|
+# TRANSITION MATRIX
|
|
|
+P[4, 4, ] <- 1
|
|
|
+P[8, 8, ] <- 1
|
|
|
+for (t in 1:60) {
|
|
|
+ rt_Standard <- 1 - exp(exp(theta_mean[1] + theta_mean[2] * age + theta_mean[3] * male) * ((t - 1)^exp(theta_mean[5]) - t^exp(theta_mean[5])))
|
|
|
+ rt_NP1 <- 1 - exp(exp(theta_mean[1] + theta_mean[2] * age + theta_mean[3] * male + theta_mean[4]) * ((t - 1)^exp(theta_mean[5]) - t^exp(theta_mean[5])))
|
|
|
+ P[1, 2, t] <- rt_Standard
|
|
|
+ P[5, 6, t] <- rt_NP1
|
|
|
+ P[1, 4, t] <- mortality(age + t, male)
|
|
|
+ P[2, 4, t] <- mortality(age + t, male) + expit(theta_mean[7])
|
|
|
+ P[3, 4, t] <- mortality(age + t, male)
|
|
|
+ P[5, 8, t] <- mortality(age + t, male)
|
|
|
+ P[6, 8, t] <- mortality(age + t, male) + expit(theta_mean[7])
|
|
|
+ P[7, 8, t] <- mortality(age + t, male)
|
|
|
+ P[3, 2, t] <- expit(theta_mean[8])
|
|
|
+ P[7, 6, t] <- expit(theta_mean[8])
|
|
|
+ P[1, 1, t] <- 1 - P[1, 2, t] - P[1, 4, t]
|
|
|
+ P[2, 3, t] <- 1 - P[2, 4, t]
|
|
|
+ P[3, 3, t] <- 1 - P[3, 2, t] - P[3, 4, t]
|
|
|
+ P[5, 5, t] <- 1 - P[5, 6, t] - P[5, 8, t]
|
|
|
+ P[6, 7, t] <- 1 - P[6, 8, t]
|
|
|
+ P[7, 7, t] <- 1 - P[7, 6, t] - P[7, 8, t]
|
|
|
+}
|
|
|
+
|
|
|
+# VALUE MATRIX
|
|
|
+V_base <- matrix(0, 8, 6)
|
|
|
+V_base[2, 1] <- exp(theta_mean[9])
|
|
|
+V_base[2, 5] <- -exp(theta_mean[9])
|
|
|
+V_base[6, c(3, 5)] <- exp(theta_mean[9])
|
|
|
+
|
|
|
+V_base[1, 2] <- expit(theta_mean[10])
|
|
|
+V_base[1, 6] <- -expit(theta_mean[10])
|
|
|
+V_base[5, 4] <- expit(theta_mean[10])
|
|
|
+V_base[5, 6] <- expit(theta_mean[10])
|
|
|
+
|
|
|
+V_base[3, 2] <- expit(theta_mean[11])
|
|
|
+V_base[3, 6] <- -expit(theta_mean[11])
|
|
|
+V_base[7, 4] <- expit(theta_mean[11])
|
|
|
+V_base[7, 6] <- expit(theta_mean[11])
|
|
|
+
|
|
|
+V_base[2, 2] <- expit(theta_mean[12])
|
|
|
+V_base[2, 6] <- -expit(theta_mean[12])
|
|
|
+V_base[6, 4] <- expit(theta_mean[12])
|
|
|
+V_base[6, 6] <- expit(theta_mean[12])
|
|
|
+
|
|
|
+for (t in 1:60) {
|
|
|
+ V[, , t] <- V_base %*% diag(rep(c(1.06^(-t), 1.015^(-t)), 3), 6, 6)
|
|
|
+}
|
|
|
+
|
|
|
+# STANDARD MARKOV COHORT SIMULATION
|
|
|
+g0 <- c(394, 0, 579, 0, 579 - 394, 0)
|
|
|
+gt[, 1] <- t(V[, , 1]) %*% x[, 1]
|
|
|
+for (t in 2:60) {
|
|
|
+ x[, t] <- t(P[, , t-1]) %*% x[, t-1]
|
|
|
+ gt[, t] <- t(V[, , t]) %*% x[, t]
|
|
|
+}
|
|
|
+g <- g0 + rowSums(gt)
|
|
|
+
|
|
|
+# DELTA METHOD
|
|
|
+# - Transition matrix (use symbolic differentiation, but exclude mortality as constant)
|
|
|
+P11 <- expression(exp(exp(theta1 + theta2 * age + theta3 * male) * ((t - 1)^exp(theta5) - t^exp(theta5))))
|
|
|
+P12 <- expression(1 - exp(exp(theta1 + theta2 * age + theta3 * male) * ((t - 1)^exp(theta5) - t^exp(theta5))))
|
|
|
+P23 <- expression(1 - 1/(1+exp(-theta7)))
|
|
|
+P24 <- expression(1/(1+exp(-theta7)))
|
|
|
+P32 <- expression(1/(1+exp(-theta8)))
|
|
|
+P33 <- expression(1 - 1/(1+exp(-theta8)))
|
|
|
+P55 <- expression(exp(exp(theta1 + theta2 * age + theta3 * male + theta4) * ((t - 1)^exp(theta5) - t^exp(theta5))))
|
|
|
+P56 <- expression(1 - exp(exp(theta1 + theta2 * age + theta3 * male + theta4) * ((t - 1)^exp(theta5) - t^exp(theta5))))
|
|
|
+P67 <- expression(1 - 1/(1+exp(-theta7)))
|
|
|
+P68 <- expression(1/(1+exp(-theta7)))
|
|
|
+P76 <- expression(1/(1+exp(-theta8)))
|
|
|
+P77 <- expression(1 - 1/(1+exp(-theta8)))
|
|
|
+
|
|
|
+dP11 <- deriv3(P11, paste0("theta", 1:12))
|
|
|
+dP12 <- deriv3(P12, paste0("theta", 1:12))
|
|
|
+dP23 <- deriv3(P23, paste0("theta", 1:12))
|
|
|
+dP24 <- deriv3(P24, paste0("theta", 1:12))
|
|
|
+dP32 <- deriv3(P32, paste0("theta", 1:12))
|
|
|
+dP33 <- deriv3(P33, paste0("theta", 1:12))
|
|
|
+dP55 <- deriv3(P55, paste0("theta", 1:12))
|
|
|
+dP56 <- deriv3(P56, paste0("theta", 1:12))
|
|
|
+dP67 <- deriv3(P67, paste0("theta", 1:12))
|
|
|
+dP68 <- deriv3(P68, paste0("theta", 1:12))
|
|
|
+dP76 <- deriv3(P76, paste0("theta", 1:12))
|
|
|
+dP77 <- deriv3(P77, paste0("theta", 1:12))
|
|
|
+
|
|
|
+param_list <- set_names(as.list(theta_mean), paste0("theta", 1:12))
|
|
|
+grad <- purrr::attr_getter("gradient")
|
|
|
+hessian <- purrr::attr_getter("hessian")
|
|
|
+
|
|
|
+from_ <- rep(c(1, 2, 3, 5, 6, 7), each = 2)
|
|
|
+to_ <- c(1:4, 2, 3, 5:8, 6, 7)
|
|
|
+
|
|
|
+for (t in 1:60) {
|
|
|
+ param_list$t <- pmax(t, 1 + 1e-10)
|
|
|
+
|
|
|
+ walk2(from_, to_, function(f_, t_) {
|
|
|
+ tmp <- eval(get(paste0("dP", f_, t_)), param_list)
|
|
|
+ dP[f_, t_, t, ] <<- unname(grad(tmp))[1, ]
|
|
|
+ d2P[f_, t_, t, , ] <<- unname(hessian(tmp))[1, , ]
|
|
|
+ })
|
|
|
+}
|
|
|
+
|
|
|
+# - Value matrix
|
|
|
+# - Utilities
|
|
|
+dV[1, 2, , 10] <- -exp(-theta_mean[10]) * (1 + exp(-theta_mean[10])) ^ (-2) * 1.015 ^ (-(1:60)) # V[1, 2, t] = U_SuccessP 1.015^(-t)
|
|
|
+dV[1, 6, , 10] <- -dV[1, 2, , 10]
|
|
|
+dV[2, 2, , 12] <- -exp(-theta_mean[12]) * (1 + exp(-theta_mean[12])) ^ (-2) * 1.015 ^ (-(1:60))
|
|
|
+dV[2, 6, , 12] <- -dV[2, 2, , 12]
|
|
|
+dV[3, 2, , 11] <- -exp(-theta_mean[11]) * (1 + exp(-theta_mean[11])) ^ (-2) * 1.015 ^ (-(1:60))
|
|
|
+dV[3, 6, , 11] <- -dV[3, 2, , 11]
|
|
|
+dV[5, 4, , 10] <- -exp(-theta_mean[10]) * (1 + exp(-theta_mean[10])) ^ (-2) * 1.015 ^ (-(1:60))
|
|
|
+dV[5, 6, , 10] <- dV[5, 4, , 10]
|
|
|
+dV[6, 4, , 12] <- -exp(-theta_mean[12]) * (1 + exp(-theta_mean[12])) ^ (-2) * 1.015 ^ (-(1:60))
|
|
|
+dV[6, 6, , 12] <- dV[6, 4, , 12]
|
|
|
+dV[7, 4, , 11] <- -exp(-theta_mean[11]) * (1 + exp(-theta_mean[11])) ^ (-2) * 1.015 ^ (-(1:60))
|
|
|
+dV[7, 6, , 11] <- dV[7, 4, , 11]
|
|
|
+
|
|
|
+d2V[1, 2, , 10, 10] <- exp(-theta_mean[10]) * (1 - exp(-theta_mean[10])) * (1 + exp(-theta_mean[10])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[1, 6, , 10, 10] <- -d2V[1, 2, , 10, 10]
|
|
|
+d2V[2, 2, , 12, 12] <- exp(-theta_mean[12]) * (1 - exp(-theta_mean[12])) * (1 + exp(-theta_mean[12])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[2, 6, , 12, 12] <- -d2V[2, 2, , 12, 12]
|
|
|
+d2V[3, 2, , 11, 11] <- exp(-theta_mean[11]) * (1 - exp(-theta_mean[11])) * (1 + exp(-theta_mean[11])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[3, 6, , 11, 11] <- -d2V[3, 2, , 11, 11]
|
|
|
+d2V[5, 4, , 10, 10] <- exp(-theta_mean[10]) * (1 - exp(-theta_mean[10])) * (1 + exp(-theta_mean[10])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[5, 6, , 10, 10] <- d2V[5, 4, , 10, 10]
|
|
|
+d2V[6, 4, , 12, 12] <- exp(-theta_mean[12]) * (1 - exp(-theta_mean[12])) * (1 + exp(-theta_mean[12])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[6, 6, , 12, 12] <- d2V[6, 4, , 12, 12]
|
|
|
+d2V[7, 4, , 11, 11] <- exp(-theta_mean[11]) * (1 - exp(-theta_mean[11])) * (1 + exp(-theta_mean[11])) ^ (-3) * 1.015 ^ (-(1:60))
|
|
|
+d2V[7, 6, , 11, 11] <- d2V[7, 4, , 11, 11]
|
|
|
+
|
|
|
+# - Costs
|
|
|
+dV[2, 1, , 9] <- V[2, 1, ] # V[2, 1, t] = exp(theta[9]) 1.06^(-t)
|
|
|
+dV[2, 5, , 9] <- V[2, 5, ]
|
|
|
+dV[6, 3, , 9] <- V[6, 3, ]
|
|
|
+dV[6, 5, , 9] <- V[6, 5, ]
|
|
|
+d2V[2, 1, , 9, 9] <- V[2, 1, ]
|
|
|
+d2V[2, 5, , 9, 9] <- V[2, 5, ]
|
|
|
+d2V[6, 3, , 9, 9] <- V[6, 3, ]
|
|
|
+d2V[6, 5, , 9, 9] <- V[6, 5, ]
|
|
|
+
|
|
|
+# - Initial state distribution
|
|
|
+dx[c(1, 4, 5, 8), 1, 6] <- c(-1, 1, -1, 1) * exp(-theta_mean[6]) * (1 + exp(-theta_mean[6])) ^ (-2)
|
|
|
+d2x[c(1, 4, 5, 8), 1, 6, 6] <- c(1, -1, 1, -1) * exp(-theta_mean[6]) * (1 - exp(-theta_mean[6])) * (1 + exp(-theta_mean[6])) ^ (-3)
|
|
|
+for (i in 1:12) {
|
|
|
+ dgt[, 1, i] <- t(dV[, , 1, i]) %*% x[, 1] + t(V[, , 1]) %*% dx[, 1, i]
|
|
|
+ for (j in 1:12) {
|
|
|
+ d2gt[, 1, i, j] <- t(d2V[, , 1, i, j]) %*% x[, 1] +
|
|
|
+ t(dV[, , 1, i]) %*% dx[, 1, j] +
|
|
|
+ t(dV[, , 1, j]) %*% dx[, 1, i] +
|
|
|
+ t(V[, , 1]) %*% d2x[, 1, i, j]
|
|
|
+ }
|
|
|
+}
|
|
|
+
|
|
|
+# - Recurrence relation
|
|
|
+for (t in 2:60) {
|
|
|
+ for (i in 1:12) {
|
|
|
+ dx[, t, i] <- t(dP[, , t-1, i]) %*% x[, t-1] + t(P[, , t-1]) %*% dx[, t-1, i]
|
|
|
+ dgt[, t, i] <- t(dV[, , t, i]) %*% x[, t] + t(V[, , t]) %*% dx[, t-1, i]
|
|
|
+ for (j in 1:12) {
|
|
|
+ d2x[, t, i, j] <- t(d2P[, , t-1, i, j]) %*% x[, t-1] +
|
|
|
+ t(dP[, , t-1, i]) %*% dx[, t-1, j] +
|
|
|
+ t(dP[, , t-1, j]) %*% dx[, t-1, i] +
|
|
|
+ t(P[, , t-1]) %*% d2x[, t-1, i, j]
|
|
|
+
|
|
|
+ d2gt[, t, i, j] <- t(d2V[, , t, i, j]) %*% x[, t] +
|
|
|
+ t(dV[, , t, i]) %*% dx[, t, j] +
|
|
|
+ t(dV[, , t, j]) %*% dx[, t, i] +
|
|
|
+ t(V[, , t]) %*% d2x[, t, i, j]
|
|
|
+ }
|
|
|
+ }
|
|
|
+}
|
|
|
+
|
|
|
+# RESULTS!
|
|
|
+dg <- apply(dgt, c(1, 3), sum)
|
|
|
+d2g <- apply(d2gt, c(1, 3, 4), sum)
|
|
|
+
|
|
|
+g_expected <- sapply(1:6, function(v) g[v] + 0.5 * sum(d2g[v, , ] * theta_var))
|
|
|
+g_variance <- dg %*% theta_var %*% t(dg)
|
|
|
+g_sd <- sqrt(diag(g_variance))
|
|
|
+
|
|
|
+# COMPARE WITH PSA
|
|
|
+g_psa <- readRDS("THR-MCPSA.rds")
|
|
|
+
|
|
|
+library(patchwork)
|
|
|
+
|
|
|
+p_standard_costs <- ggplot(g_psa, aes(x = Standard_Costs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[1], sd = g_sd[1]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Lifetime costs", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ ggtitle("Costs for standard prosthesis") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+p_standard_QALYs <- ggplot(g_psa, aes(x = Standard_QALYs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[2], sd = g_sd[2]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Quality adjusted life years (QALYs)") +
|
|
|
+ ggtitle("QALYs for standard prosthesis") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+p_NP1_costs <- ggplot(g_psa, aes(x = NP1_Costs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[3], sd = g_sd[3]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Lifetime costs", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ ggtitle("Costs for NP1 prosthesis") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+p_NP1_QALYs <- ggplot(g_psa, aes(x = NP1_QALYs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[4], sd = g_sd[4]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Quality adjusted life years (QALYs)") +
|
|
|
+ ggtitle("QALYs for NP1 prosthesis") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+p_inc_costs <- ggplot(g_psa, aes(x = Incremental_Costs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[5], sd = g_sd[5]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Lifetime costs", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ ggtitle("Incremental costs") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+p_inc_QALYs <- ggplot(g_psa, aes(x = Incremental_QALYs)) +
|
|
|
+ geom_density() +
|
|
|
+ stat_function(fun = dnorm, args = list(mean = g_expected[6], sd = g_sd[6]), linetype = "dashed", colour = "blue") +
|
|
|
+ scale_x_continuous("Quality adjusted life years (QALYs)") +
|
|
|
+ ggtitle("Incremental QALYs") +
|
|
|
+ theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), axis.title.y = element_blank())
|
|
|
+
|
|
|
+(p_standard_costs + p_NP1_costs + p_inc_costs) / (p_standard_QALYs + p_NP1_QALYs + p_inc_QALYs)
|
|
|
+ggsave("Delta-PSA comparison.png", width = 20.28, height = 10.62, units = "cm")
|
|
|
+
|
|
|
+wtp <- seq(0, 10000, by = 100)
|
|
|
+
|
|
|
+ceac_psa <- sapply(wtp, function(lambda) mean(lambda * g_psa$Incremental_QALYs >= g_psa$Incremental_Costs))
|
|
|
+
|
|
|
+m <- - g_expected[5] + wtp * g_expected[6]
|
|
|
+s <- sqrt(wtp ^ 2 * g_variance[6,6] - 2 * wtp * g_variance[5,6] + g_variance[5,5])
|
|
|
+
|
|
|
+ggplot(tibble(x = wtp, ceac.delta = pnorm(m/s), ceac.psa = ceac_psa), aes(x)) +
|
|
|
+ geom_line(aes(y = ceac.delta, linetype = "Delta-PSA", colour = "Delta-PSA")) +
|
|
|
+ geom_line(aes(y = ceac.psa, linetype = "MC-PSA", colour = "MC-PSA")) +
|
|
|
+ scale_x_continuous("Willingness-to-pay for additional QALY", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ scale_y_continuous("Probability NP1 is cost-effective", labels = scales::percent_format()) +
|
|
|
+ scale_colour_discrete("Method") +
|
|
|
+ scale_linetype_discrete("Method")
|
|
|
+ggsave("Delta-PSA CEAC.png", width = 20.28, height = 10.62, units = "cm", scale = 0.8)
|
|
|
+
|
|
|
+evpi_psa <- sapply(wtp, function(lambda) {
|
|
|
+ inmb <- lambda * g_psa$Incremental_QALYs - g_psa$Incremental_Costs
|
|
|
+ evpi <- mean(abs(inmb)) - abs(mean(inmb))
|
|
|
+ evpi
|
|
|
+})
|
|
|
+evpi_delta <- (s * sqrt(2/pi) * exp(-m^2 / (2 * s^2)) - m * (1 - 2 * pnorm(m/s))) - abs(m)
|
|
|
+
|
|
|
+ggplot(tibble(x = wtp, evpi.delta = evpi_delta, evpi.psa = evpi_psa), aes(x)) +
|
|
|
+ geom_line(aes(y = evpi.delta, linetype = "Delta-PSA", colour = "Delta-PSA")) +
|
|
|
+ geom_line(aes(y = evpi.psa, linetype = "MC-PSA", colour = "MC-PSA")) +
|
|
|
+ scale_x_continuous("Willingness-to-pay for additional QALY", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ scale_y_continuous("Expected value of perfect information", labels = scales::dollar_format(prefix = "£")) +
|
|
|
+ scale_colour_discrete("Method") +
|
|
|
+ scale_linetype_discrete("Method")
|
|
|
+ggsave("Delta-PSA EVPI.png", width = 20.28, height = 10.62, units = "cm", scale = 0.8)
|
