Expected Value of Perfect Information: What Could Better Evidence Be Worth?
On this page
อ่านฉบับภาษาไทย (Thai version)
Abstract
A hospital network's drug committee must choose drug A or drug B for about 2,000 adults with heart failure a year. A 40 million THB trial could settle which is better. Its model values each drug per patient as health in money minus cost. On average B is worth 120 thousand THB per patient and A 115 thousand THB, so B wins today. But the evidence allows four equally likely versions of the truth (we call them worlds), and in two of them A would be better. Knowing the truth first, the committee would pick the better drug in each world, worth 135 on average. The expected value of perfect information (EVPI) is that average gain from knowing first: 135 minus 120 thousand THB, or 15 thousand THB per patient. Over five years of patients, in today's money, settling the question could be worth at most 141.51 million THB. The trial is not ruled out, though a real trial is worth less than this ceiling.
A drug committee deciding now or after a trial
A provincial hospital network starts about 2,000 adults with heart failure on long-term treatment each year. Its drug committee must choose one first-line drug for all of them: A, the drug it uses now, or B, a newer and dearer one. A small trial suggests that B prevents more hospital admissions, but its confidence interval is wide. A research group offers a larger trial, costing 40 million THB, that would settle the question.
To weigh the drugs, the committee's model counts health in one unit for both length and quality of life. A QALY, a quality-adjusted life year, is a year of life weighted by its quality, from 1 for full health to 0 for death. Over 10 years, a state valued at 0.70 counts as 7.0 QALYs, so full health over those years would add 3.0. The full lesson is in the foundation article on quality-adjusted life years.
The model then turns health into money and takes away the cost. Net monetary benefit (NMB) is health valued at the threshold minus cost, where the threshold is the most the payer will pay for one QALY. A positive incremental NMB (INMB) means the extra cost is worth paying: at 160,000 THB per QALY, 1.00 extra QALY for 150,000 THB more gives an INMB of 10,000 THB. The full lesson is in the foundation article on net benefit and the threshold.
For each drug, the committee's model gives an NMB per patient, counted in thousand THB. Averaged over everything the evidence still allows, which the next sections make precise, B is worth 120 and A 115 thousand THB, so B looks a little better. All numbers here are invented for teaching; they are not evidence about any heart failure drug.
The tempting answer: unsure evidence means wait
Many people would answer at once: the interval is wide, so wait for the trial. This is the misconception the article corrects. Uncertainty is worth reducing only when it could change the choice, and then only by what a wrong choice would cost. Fenwick and colleagues describe this way of pricing research by the decision it serves.
So the committee needs three answers: how often B would be the wrong choice, how much each wrong choice would cost, and how many patients the choice would reach. The rest of the article answers them with the committee's numbers.
Four possible worlds
Nobody knows yet how well B prevents admissions, how often patients are admitted, or what an admission costs. The committee's model therefore works with four equally likely versions of the truth, which we call possible worlds. Each world fixes all the unknowns at once and values both drugs in it.
Probabilistic sensitivity analysis (PSA) is how a full model makes many more worlds. It reruns the model many times with every uncertain input drawn from its distribution, so the result is a share of runs rather than one number. When the extra net benefit averages 10,000 THB with a standard deviation of 40,000 THB, about 599 of 1,000 runs favour the treatment; the full lesson is in Probabilistic Sensitivity Analysis: From Parameter Distributions to CEAC.
Four worlds are enough to see every step. Read the figure below one row at a time, from left to right, not down a column. In the first world B is worth 120 and A is worth 100 thousand THB, so B is better. In the second, A is worth 140 and B 110 thousand THB, so A is better.
In the third world B is worth 150 and A 90 thousand THB, so B is better. In the fourth, A is worth 130 and B 100 thousand THB, so A is better. So B is better in the first and third worlds and A in the second and fourth. A row is one version of the truth for every patient, not a group of patients the committee could treat differently.
Check the series' examples in R
# Trace the series' shared examples that this article recaps before the committee's own numbers.
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")10 years at 0.70 = 7.0 | full health adds 3.0
Series example: 160000 x 1.00 - 150000 = 10,000 THB
Average extra gain 10,000 THB, spread 40,000 THB | runs favouring it: 599 of 1,000Requires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
Choose now, or choose after knowing
Choosing now, the committee cannot tell which world is true. It must give one drug to every patient, so it judges each drug by its average over the four worlds and picks the larger average.
Now imagine the committee could learn the true world before choosing. Then it would give the better drug in that world. For now it does not know which world is true, and each is equally likely, so the value of choosing after knowing is the average of the best values. The card below works out both orders.
Average then choose, or choose then average
-
Choose now: average, then choose
\[ \max(115,\ 120) = 120 \]
Drug A averages (100 + 140 + 90 + 130) / 4 = 115 thousand THB per patient. Drug B averages (120 + 110 + 150 + 100) / 4 = 120 thousand THB, so the committee picks B.
-
Know first: choose, then average
\[ \frac{120 + 140 + 150 + 130}{4} = 135 \]
In each world take the better drug: 120 for B, 140 for A, 150 for B and 130 for A. These best values average 135 thousand THB per patient.
-
The gain from knowing first
\[ 135 - 120 = 15 \]
Take the value of choosing now from the value of knowing first.
Result: Knowing the true world before choosing would be worth 15 thousand THB per patient on average.
The gap has a name
The gain of 135 minus 120 = 15 thousand THB per patient has a name. The expected value of perfect information (EVPI) is the average gain from knowing the true inputs before choosing. It is the most that removing all the uncertainty could be worth. Expected means averaged over the possible worlds, and perfect means every unknown is revealed.
In words, EVPI is the average, over the worlds, of the better drug's value in each world (135), minus the value of the drug with the better average (120). It can never fall below zero, because a committee that knows the true world can always give the same drug it would have chosen without knowing.
Check the two orders in R
# Four equally likely worlds. Each row holds both drugs' value in the same world.
# Values are thousand THB per patient, illustrative.
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")Average value, A and B: 115 120 | choose now: drug B
Better drug in each world: B A B A
Best value in each world: 120 140 150 130 | their average: 135
Knowing first: 135 - choosing now: 120 = 15Requires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
Read the gain as a loss avoided
There is a second way to reach 15. Choosing B for everyone loses nothing in the first and third worlds, where B is better. It loses 140 - 110 = 30 in the second world and 130 - 100 = 30 in the fourth. Averaged over the four worlds, (0 + 30 + 0 + 30) / 4 = 15, the same number.
So EVPI is the average loss from the choice made now, the loss that perfect knowledge would remove. It depends on two things at once: how often the choice is wrong and how much each wrong choice loses.
Now test the tempting answer: choosing B is wrong in two of the four worlds, a 50% chance. Suppose every A value were 10 lower, so A averaged 105 thousand THB. Choosing B would still be wrong in the same two worlds but would lose less: 130 - 110 = 20 in the second world (A drops to 140 - 10 = 130) and 120 - 100 = 20 in the fourth (A drops to 130 - 10 = 120). The average loss would fall to (0 + 20 + 0 + 20) / 4 = 10.
The chance of a wrong choice is still 50%, yet knowing first is now worth a third less. And if B were better in every world, knowing first would change nothing and EVPI would be 0, however wide the interval looked. Briggs, Claxton and Sculpher set out this decision view of uncertainty in their textbook.
Check the loss reading in R
# What choosing B loses in each world, then a check with every A value lower by 10.
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")Loss from choosing B in each world: 0 30 0 30 | average: 15
Worlds where B loses: 2 of 4 | share (%): 50
A lower by 10: average 105 | losses 0 20 0 20 | average: 10Requires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
Keep each world's values together
The calculation works only if A and B in a row come from the same world. Suppose someone sorted each column from low to high on its own: A becomes 90, 100, 130, 140 and B becomes 100, 110, 120, 150 thousand THB. The rows would then pair 90 with 100, 100 with 110, 130 with 120 and 140 with 150: pairs that never occur together in any world.
The best values of the sorted rows, 100, 110, 130 and 150 thousand THB, average 122.5. The gap over choosing now would shrink to 2.5, a wrong answer. In a full model, keep both drugs' results from the same run side by side; Briggs and colleagues explain why inputs shared by the options must stay linked.
Check what sorting does in R
# The same arithmetic after sorting each column on its own, which breaks the worlds apart.
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")Sorted A: 90 100 130 140 | sorted B: 100 110 120 150 | best in each row: 100 110 130 150
Their average: 122.5 | gap over choosing now: 2.5Requires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
From one patient to the whole network
The 15 thousand THB (15,000 THB) is per patient, but the trial would inform the choice for every patient who starts treatment while the choice stands. The network starts 2,000 patients a year, and the committee expects to keep its choice for 5 years. That is 2,000 × 5 = 10,000 patients, so perfect knowledge is worth at most 10,000 × 15,000 THB = 150 million THB.
Money that arrives in later years counts for less today. Discounting is converting a future cost or health gain into its value today, shrinking it by the discount rate for each year away. At 3% a cost of 1,834 THB due 3 years from now is worth 1,678 THB today; the full lesson is in the foundation article on costs over time.
Here each year's patients bring 2,000 × 15,000 THB = 30 million THB. The first year's patients start today, so that year counts in full and the network's third year is only two years away. The card below counts each year in today's money at the same 3% a year.
Five years of patients in today's money
-
The dividers
\[ 1.03 \times 1.03 = 1.0609 \]
The first year counts in full because it starts today. The second year is divided by 1.03 once (1.0300) and the third twice (1.03 × 1.03 = 1.0609). Each later year is divided by 1.03 once more: 1.0609 × 1.03 = 1.0927 and 1.0927 × 1.03 = 1.1255.
-
Each year in today's money
\[ \frac{30}{1.0609} = 28.28 \]
Divide 30 million THB by each divider: 30.00, 29.13, 28.28, 27.45 and 26.65 million THB. For the third year, 30 / 1.0609 = 28.28.
-
Add the years
\[ 30.00 + 29.13 + 28.28 + 27.45 + 26.65 = 141.51 \]
The five years add up to 141.51 million THB, below the 150 million counted without adjusting for time.
Result: In today's money, removing all the uncertainty is worth at most 141.51 million THB to the network.
The ceiling for research
This total is called the population EVPI: EVPI per patient multiplied by every patient the choice reaches, in today's money. It is a ceiling, the most any study on this question could be worth to the network.
The trial costs 40 million THB, well below the ceiling of 141.51 million THB, so it is not ruled out. A study costing more than the ceiling would be ruled out whatever it found, because even perfect knowledge would not repay it.
Count the patients in R
# From one patient to the network: the patients the choice reaches, and the most knowing is worth.
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")Patients reached: 2,000 x 5 = 10,000
Each year: 2,000 x 15,000 THB = 30 million THB
Ceiling: 10,000 x 15,000 THB = 150 million THBRequires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
Count the years in today's money in R
# Count later years in today's money at the series' rate, then hold the trial's cost against it.
yearly_factor <- 1.03
per_patient <- 15000
per_year <- 2000
years_used <- 5
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")Series: 1,834 THB due in 3 years at (%): 3 -> 1678 THB
Dividers, year by year: 1.0000 1.0300 1.0609 1.0927 1.1255
Each year in today's money (million THB): 30.00 29.13 28.28 27.45 26.65
Ceiling today (million THB): 141.51
Trial (million THB): 40 | below the ceiling: TRUERequires R ≥ 4.5.2 · tibble 3.3.1 · dplyr 1.2.1 · dampack 1.0.2.1000 · works in R 4.6.1 · Download expected-value-of-perfect-information.R
Full tidy script
# Two drugs, four possible worlds: what knowing the truth first is worth to a hospital network
# ยาสองตัว ความจริงที่เป็นไปได้สี่แบบ: การรู้ความจริงก่อนเลือกมีค่าเท่าใดต่อเครือข่ายโรงพยาบาล
# Requires: R >= 4.5.2
# Tested: works in R 4.6.1
# tibble 3.3.1 (stable)
# dplyr 1.2.1 (stable)
# dampack 1.0.2.1000 (stable)
# install.packages(c("tibble", "dplyr", "dampack"))
# update.packages(oldPkgs = c("tibble", "dplyr", "dampack"))
# remotes::install_version("tibble", "3.3.1")
# remotes::install_version("dplyr", "1.2.1")
# remotes::install_version("dampack", "1.0.2.1000")
library(tibble) # Write the four worlds as an explicit input table.
library(dplyr) # Add each world's best value and loss to the table.
library(dampack) # Cross-check the gain from knowing first with an independent routine.
stopifnot(getRversion() >= "4.5.2")
#%%@note 1. The series' shared examples
# A health weight over ten years, the threshold, and the share of reruns that favour a treatment.
# ค่าน้ำหนักสุขภาพตลอดสิบปี เกณฑ์ และสัดส่วนของการรันซ้ำที่เอียงไปทางการรักษา
big <- function(value) prettyNum(round(value, 2), big.mark = ",", digits = 10, scientific = FALSE)
years_lived <- 10
state_weight <- 0.70
lambda <- 160000
mean_gain <- 10000
sd_gain <- 40000
runs <- 1000
stopifnot(round(runs * stats::pnorm(mean_gain / sd_gain)) == 599)
#%%@note 2. Four worlds, both drugs valued in the same world
# Each row is one equally likely version of the truth. Values are thousand THB per patient.
# แต่ละแถวคือความจริงแบบหนึ่งที่มีโอกาสเท่ากัน ค่าเป็นพันบาทต่อผู้ป่วย และเป็นตัวเลขสมมติ
nmb_a <- c(100, 140, 90, 130)
nmb_b <- c(120, 110, 150, 100)
worlds <- tibble::tibble(world = seq_along(nmb_a), drug_a = nmb_a, drug_b = nmb_b) |>
dplyr::mutate(best = pmax(drug_a, drug_b), loss_with_b = best - drug_b)
averages <- c(A = mean(nmb_a), B = mean(nmb_b))
choose_now <- max(averages)
row_best <- pmax(nmb_a, nmb_b)
know_first <- mean(row_best)
stopifnot(know_first - choose_now == mean(worlds$loss_with_b))
#%%@note 3. What choosing B loses, then two checks
# Every A value lower by 10 keeps the same losing worlds. Sorting each column breaks the worlds.
# ลด A ลง 10 ทุกแถวยังแพ้ในโลกเดิม ส่วนการเรียงแต่ละคอลัมน์แยกกันทำให้โลกแตกออกจากกัน
shift_a <- 10
loss_b <- pmax(nmb_a, nmb_b) - nmb_b
lower_a <- nmb_a - shift_a
loss_lower <- pmax(lower_a, nmb_b) - nmb_b
sorted_best <- pmax(sort(nmb_a), sort(nmb_b))
stopifnot(sum(loss_lower > 0) == sum(loss_b > 0), mean(sorted_best) < know_first)
#%%@note 4. Cross-check with an independent routine
# dampack values each strategy as effect x wtp - cost, so effect = value, cost = 0 and wtp = 1.
# dampack คิดค่าเป็น effect x wtp - cost จึงให้ effect เป็นค่า ให้ cost เป็น 0 และ wtp เป็น 1
zero_cost <- data.frame(A = 0 * nmb_a, B = 0 * nmb_b)
psa_obj <- dampack::make_psa_obj(cost = zero_cost, effectiveness = data.frame(A = nmb_a, B = nmb_b),
parameters = data.frame(world = seq_along(nmb_a)), strategies = c("A", "B"))
checked <- dampack::calc_evpi(psa_obj, wtp = 1)
stopifnot(abs(checked[[2]] - (know_first - choose_now)) < 1e-9)
#%%@note 5. From one patient to the network, in today's money
# Patients reached over the years the choice stands, then each year divided by 1.03 once more.
# จำนวนผู้ป่วยตลอดช่วงที่การเลือกนี้ใช้อยู่ แล้วหารค่าของแต่ละปีด้วย 1.03 เพิ่มอีกหนึ่งครั้ง
per_patient <- 15000
per_year <- 2000
years_used <- 5
reached <- per_year * years_used
yearly_factor <- 1.03
trial_cost <- 40
dividers <- yearly_factor^(seq_len(years_used) - 1)
today <- per_year * per_patient / 1e6 / dividers
stopifnot(per_patient == 1000 * (know_first - choose_now), trial_cost < sum(today))
#%%@note 6. Numbers the article quotes
# Print the short boxes' lines in their reading order.
# พิมพ์ผลลัพธ์ตรงกับกล่องโค้ดสั้นตามลำดับในบทความ
cat("10 years at 0.70 =", formatC(years_lived * state_weight, format = "f", digits = 1),
"| full health adds", formatC(years_lived * 0.30, format = "f", digits = 1), "\n")
cat("Series example: 160000 x 1.00 - 150000 =", big(lambda * 1.00 - 150000), "THB\n")
cat("Average extra gain", big(mean_gain), "THB, spread", big(sd_gain), "THB | runs favouring it:",
round(runs * stats::pnorm(mean_gain / sd_gain)), "of", big(runs), "\n")
cat("Average value, A and B:", averages, "| choose now: drug", names(which.max(averages)), "\n")
cat("Better drug in each world:", ifelse(nmb_a > nmb_b, "A", "B"), "\n")
cat("Best value in each world:", row_best, "| their average:", know_first, "\n")
cat("Knowing first:", know_first, "- choosing now:", choose_now, "=", know_first - choose_now, "\n")
cat("Loss from choosing B in each world:", loss_b, "| average:", mean(loss_b), "\n")
cat("Worlds where B loses:", sum(loss_b > 0), "of", length(loss_b),
"| share (%):", 100 * mean(loss_b > 0), "\n")
cat("A lower by 10: average", mean(lower_a), "| losses", loss_lower, "| average:",
mean(loss_lower), "\n")
cat("Sorted A:", sort(nmb_a), "| sorted B:", sort(nmb_b), "| best in each row:", sorted_best, "\n")
cat("Their average:", mean(sorted_best), "| gap over choosing now:",
mean(sorted_best) - max(mean(nmb_a), mean(nmb_b)), "\n")
cat("Patients reached:", big(per_year), "x", years_used, "=", big(reached), "\n")
cat("Each year:", big(per_year), "x", big(per_patient), "THB =", big(per_year * per_patient / 1e6),
"million THB\n")
cat("Ceiling:", big(reached), "x", big(per_patient), "THB =", big(reached * per_patient / 1e6),
"million THB\n")
cat("Series: 1,834 THB due in 3 years at (%):", 3, "->", round(1834 / yearly_factor^3), "THB\n")
cat("Dividers, year by year:", formatC(dividers, format = "f", digits = 4), "\n")
cat("Each year in today's money (million THB):", formatC(today, format = "f", digits = 2), "\n")
cat("Ceiling today (million THB):", formatC(sum(today), format = "f", digits = 2), "\n")
cat("Trial (million THB):", trial_cost, "| below the ceiling:", trial_cost < sum(today), "\n")
A real trial is worth less than the ceiling
EVPI assumes the study would reveal the true world exactly. A real trial of finite size narrows the uncertainty but leaves some, so the committee could still choose wrongly after it. The expected value of sample information (EVSI) is the average gain from acting on a real study's possible results. For the same question it is never larger than EVPI.
So the trial is worth funding only if its EVSI, counted over the same patients, is larger than its 40 million THB cost. Results also arrive late, and patients who start treatment while the trial runs gain nothing from it. If the network cannot switch drugs once it has chosen, a result that arrives late cannot be acted on at all.
The same calculation can be run for one input at a time, for example only B's effect on admissions. This is called a partial EVPI, and it shows which part of the uncertainty is worth studying. Jalal and colleagues describe how analyses like these are run in R.
What the number leaves out
EVPI covers only the uncertainty the model includes. If the model leaves out a way the drugs could differ, that uncertainty is not counted. EVPI also says nothing about whether the network can afford B; that budget question has its own article in this series.
Terms as we use them
- Possible world
- One version of the truth that fixes every unknown input at once and values every option in it.
- Expected value of perfect information (EVPI)
- The average gain from knowing the true inputs before choosing; here 135 - 120 = 15 thousand THB per patient.
- Loss from the current choice
- What the choice made now gives up in a world where another option is better; its average equals EVPI.
- Population EVPI
- EVPI per patient multiplied by every patient the choice reaches, in today's money; the ceiling for research.
- Expected value of sample information (EVSI)
- The average gain from acting on a real study's possible results; never above EVPI.
- Partial EVPI
- The same calculation for one input at a time; it points to the part of the uncertainty worth studying.
Connect to the foundation articles
The foundation article on how a model turns evidence into a decision shows where a full model's worlds come from. The one on communicating health economic evidence shows how to put a number like the ceiling before a committee.
Try it in the app
Open our model app to change the inputs and watch the result update. It needs a login and a Pro or Max plan.
The app starts from its own example values, so its numbers will not match this article.
References
- Fenwick Elisabeth, Steuten Lotte, Knies Saskia, Ghabri Salah, Basu Anirban, Murray James F., Koffijberg Hendrik (Erik), Strong Mark, Sanders Schmidler Gillian D., Rothery Claire. Value of Information Analysis for Research Decisions-An Introduction: Report 1 of the ISPOR Value of Information Analysis Emerging Good Practices Task Force. Value in Health. 2020;23(2):139-150. doi:10.1016/j.jval.2020.01.001. https://api.crossref.org/works/10.1016/j.jval.2020.01.001
- Briggs Andrew H., Weinstein Milton C., Fenwick Elisabeth A.L., Karnon Jonathan, Sculpher Mark J., Paltiel A. David. Model Parameter Estimation and Uncertainty: A Report of the ISPOR-SMDM Modeling Good Research Practices Task Force-6. Value in Health. 2012;15(6):835-842. doi:10.1016/j.jval.2012.04.014. https://api.crossref.org/works/10.1016/j.jval.2012.04.014
- Andrew Briggs, Karl Claxton, Mark Sculpher. Decision Modelling for Health Economic Evaluation (Handbooks for Health Economic Evaluation). Oxford University Press; 2006. ISBN 9780198526629. https://openlibrary.org/isbn/9780198526629.json
- Jalal Hawre, Pechlivanoglou Petros, Krijkamp Eline, Alarid-Escudero Fernando, Enns Eva, Hunink M. G. Myriam. An Overview of R in Health Decision Sciences. Medical Decision Making. 2017;37(7):735-746. doi:10.1177/0272989x16686559. https://api.crossref.org/works/10.1177/0272989x16686559
The series, in learning order
- Health Economic Modelling Series Guide: From Evidence to a Decision
- Choosing a Decision-Analytic Model: Let the Clinical Pathway Decide
- Auditable Model Inputs: Build a Parameter Table You Can Trace
- Finding Model Inputs in the Literature: Match the Estimate to the Question
- Rates, Probabilities and Transition Probabilities: Keep Time in the Calculation
- Building a Decision Tree Step by Step: Follow Outcomes, Costs and Health
- Building a Markov Cohort Model Step by Step: Follow the Cohort Through Time
- Budget Impact Analysis in Practice: Count People Before Counting Money
- ICER and Net Monetary Benefit Across Strategies: Find the Relevant Frontier
- Probabilistic Sensitivity Analysis: From Parameter Distributions to CEAC
- Model Validation and Verification: Test the Question, Equations and Code
- Expected Value of Perfect Information: What Could Better Evidence Be Worth? (this article)
Key takeaways
- Uncertain evidence is worth buying only when it could change the choice: choosing B is wrong in two of the four worlds, and only what those wrong choices lose gives research its value.
- Average then choose gives 120 and choose then average gives 135 thousand THB per patient. The gap, 15 thousand THB per patient, is the EVPI.
- EVPI is also the average loss from the choice made now: 30 in two of the four worlds averages 15. If the chance of a wrong choice stays at 50% but each loss is only 20, EVPI falls to 10.
- Keep both options' values from the same world side by side; sorting the columns apart gives 2.5, a wrong answer.
- Count every patient the choice reaches, in today's money: 141.51 million THB is the ceiling, so the 40 million THB trial is not ruled out, but a real trial is worth less.
Related in the wiki: Decision Trees, Markov Cohorts and Probabilistic Sensitivity Analysis: How a Model Turns Evidence into a Decision · Communicating Health Economic Evidence: From Model Outputs to Policy Briefs