convert_model <- function(model) {
converted_strats <- convert_strategies(model$strategieshow)
list(
decision = 'how', # Not used, but here to pass tests
settings = convert_settings(model$settings, model$settingsOverrides),
groups = convert_groups(model$groups),
strategies = converted_strats,
states = convert_states(model$states),
transitions = convert_transitions(get_transitions(model), converted_strats, model$modelheader, model$settings),
hvalues = convert_hvalues(model$values, converted_strats),
evalues = convert_evalues(model$values, converted_strats),
hsumms = convert_hsumms(model$summaries),
esumms = convert_esumms(model$summaries),
variables = convert_variables(model$formulas),
tables = convert_tables(model$tables),
scripts = convert_scripts(model$scripts),
surv_dists = convert_surv_dists(model$surv_dists),
type = NULL,
vbp = model$vbp,
twsa_settings = model$twsa_settings,
twsa_parameters = model$twsa_parameters,
twsa = model$twsa,
psa = convert_psa(model$psa, model$psa_correlations),
dsa_settings = model$dsa_settings,
scenario_settings = model$scenario_settings,
scenario = convert_scenarios(model$scenarios),
cores = get_n_cores(model$cores),
script_to_run = model$script_to_run,
threshold_analyses = model$threshold_analyses,
create_progress_reporter_factory = model$create_progress_reporter_factory,
.manifest = model$.manifest,
name = safe_filename(model$modelheader$filename)
)
}
#' @export
run_code_preview_compat <- function(...) {
data <- list(...)
do.call(
run_markdown,
list(
text = data$scripts[[data$script_to_run]],
data = data$tables,
create_progress_reporter = data$create_progress_reporter,
.manifest = data$.manifest,
name = data$name
)
)
}
get_n_cores <- function(cores) {
if (is.null(cores)) return(parallel::detectCores())
cores
}
convert_settings <- function(settings, overrides) {
# Apply overrides to settings
merged_settings <- list_modify(settings, !!!overrides)
# Return settings object
settings_list <- list(
disc_cost = get_cost_dr(merged_settings),
disc_eff = get_outcomes_dr(merged_settings),
n_cycles = get_n_cycles(merged_settings),
method = get_hc_method(merged_settings),
disc_method = get_disc_method(merged_settings),
CycleLength = get_cycle_length(merged_settings),
CycleLengthUnits = get_cycle_length_units(merged_settings),
ModelTimeframe = get_timeframe(merged_settings),
ModelTimeframeUnits = get_timeframe_units(merged_settings),
days_per_year = get_days_per_year(merged_settings)
)
discard(settings_list, is.null)
}
convert_groups <- function(groups) {
if (is.null(groups) || class(groups) == "list") {
return(groups)
}
groups %>%
filter(on_off == "On") %>%
mutate(name = paste0('"', name, '"')) %>%
select(-label, -id, -on_off)
}
convert_states <- function(states) {
transmute(states,name = name, desc = label, prob = initial_probability, limit = limit)
}
convert_strategies <- function(strategies) {
strategies %>%
filter(on_off == "On") %>%
transmute(name = name, desc = label)
}
convert_transitions <- function(transitions, strategies, header, settings) {
switch(
header$modelType,
"Markov" = convert_markov_transitions(transitions, strategies),
"PS" = convert_psm_transitions(transitions, strategies, settings),
"PSCustom" = convert_custom_transitions(transitions, strategies)
)
}
get_transitions <- function(model) {
switch(
model$modelheader$modelType,
"Markov" = model$transitions,
"PS" = model$psm_transitions,
"PSCustom" = model$transitions
)
}
convert_markov_transitions <- function(transitions, strategies) {
transitions %>%
filter(strategy %in% c("All", strategies$name)) %>%
transmute(strategy, from, to, value = formula)
}
convert_psm_transitions <- function(transitions, strategies, settings) {
dpy <- 365
if (!is.null(settings$days_per_year)) {
dpy <- settings$days_per_year
}
filtered_transitions <- filter(transitions, strategy %in% c("All", strategies$name))
cycle_length <- get_cycle_length(settings)
cycle_length_units <- get_cycle_length_units(settings)
cycle_length_days <- time_in_days(cycle_length_units, dpy) * cycle_length
surv_cycle_unit_days <- map_dbl(filtered_transitions$unit, function(x) time_in_days(x, dpy))
surv_cycle_length_days <- cycle_length_days / surv_cycle_unit_days
transmute(
filtered_transitions,
strategy = strategy,
endpoint = endpoint,
cycle_length = surv_cycle_length_days,
value = formula
)
}
convert_custom_transitions <- function(transitions, strategies) {
transitions %>%
filter(strategy %in% c("All", strategies$name)) %>%
transmute(strategy, state, value = formula)
}
convert_hvalues <- function(values, strategies) {
values %>%
filter(category == "Health", strategy %in% c("All", strategies$name)) %>%
transmute(
name,
label = description,
strategy,
state = map2_chr(state, type, function(x, y) if(y == "Transition") paste0(x$from, "\u2192", x$to) else x),
value = formula
)
}
convert_evalues <- function(values, strategies) {
values %>%
filter(category == "Economic", strategy %in% c("All", strategies$name)) %>%
transmute(
name,
label = description,
strategy,
state = map2_chr(state, type, function(x, y) if(y == "Transition") paste0(x$from, "\u2192", x$to) else x),
value = formula
)
}
convert_hsumms <- function(summaries) {
summaries %>%
filter(category == "Health") %>%
rowwise() %>%
group_split() %>%
map(function(summary) {
data.frame(
name = summary$name,
description = summary$description,
value = summary$values[[1]],
wtp = as.numeric(summary$wtp),
stringsAsFactors = F
)
}) %>%
bind_rows()
}
convert_esumms <- function(summaries) {
summaries %>%
filter(category == "Economic") %>%
rowwise() %>%
group_split() %>%
map(function(summary) {
data.frame(
name = summary$name,
description = summary$description,
value = summary$values[[1]],
wtp = as.numeric(NA),
stringsAsFactors = F
)
}) %>%
bind_rows()
}
convert_variables <- function(variables) {
if (is.null(variables) || class(variables) == "list") {
return(variables)
}
variables %>%
mutate(
overrideActive = if(exists('overrideActive')) overrideActive else 'Off',
overrideValue = if(exists('overrideValue')) overrideValue else NA,
psaActive = if(exists('psaActive')) psaActive else 'Off',
low = if(exists('low')) low else '',
high = if(exists('high')) high else '',
psa = if(exists('psa')) psa else ''
) %>%
transmute(
name = name,
desc = description,
value = as.character(ifelse(!is.na(overrideActive) & overrideActive == "On", overrideValue, formula)),
low = as.character(ifelse(!is.na(active) & active == "On", low, "")),
high = as.character(ifelse(!is.na(active) & active == "On", high, "")),
psa = as.character(ifelse(!is.na(psa_active) & psa_active == "On", distribution, ""))
)
}
convert_surv_dists <- function(surv_dists) {
if (is.null(surv_dists) || class(surv_dists) == "list") {
return(surv_dists)
}
transmute(
surv_dists,
name = name,
value = as.character(formula)
)
}
convert_scripts <- function(scripts) {
if (is.null(scripts) || class(scripts) == "list") {
return(structure(list(), names=character(0)))
}
scripts %>%
rowwise() %>%
group_split() %>%
map(function(script) script$text) %>%
set_names(scripts$name)
}
convert_tables <- function(tables) {
if (is.null(tables) || class(tables) == "list") {
return(structure(list(), names=character(0)))
}
suppressWarnings(table_lists <- cpp_convert_tables(tables$data, tables$name))
map(table_lists, function(x) set_names(as.data.frame(x, stringsAsFactors = F), names(x)))
}
convert_psa <- function(psa, correlations) {
var_names <- correlations$variables
correlations <- correlations$data
if (is.null(correlations) || class(correlations) == "list") {
psa$correlation <- list()
} else {
n_var <- length(var_names)
n_correls <- (n_var^2 - n_var)/2
correls <- data.frame(
var1 = character(n_correls),
var2 = character(n_correls),
value = numeric(n_correls),
stringsAsFactors = F
)
row_index <- 1
col_index <- 1
for (i in seq_len(n_correls)) {
correls$var1[i] <- var_names[row_index + 1]
correls$var2[i] <- var_names[col_index]
correls$value[i] <- as.numeric(correlations[row_index + 1, col_index])
col_index <- col_index + 1
if (col_index > row_index) {
row_index <- row_index + 1
col_index <- 1
}
}
psa$correlation <- correls
}
psa$parallel <- T
#psa$n <- 50L
psa
}
convert_scenarios <- function(scenarios) {
if (is.null(scenarios) || class(scenarios) == "list") {
return(list())
}
scenarios %>%
filter(active) %>%
rowwise() %>%
group_split() %>%
map(function(x) {
transmute(
x$params[[1]],
scenario_name = x$name,
description = x$description,
param_name = x$params[[1]]$name,
formula = x$params[[1]]$scen_value
)
}) %>%
bind_rows()
}
# Settings Getter Functions
get_cost_dr <- function(settings) {
as.numeric(settings$DiscountRateCosts) / 100
}
get_outcomes_dr <- function(settings) {
as.numeric(settings$DiscountRateOutcomes) / 100
}
get_n_cycles <- function(settings) {
as.integer(settings$CycleCount)
}
get_hc_method <- function(settings) {
if (is.null(settings$method)) {
return("life-table")
}
switch(
settings$method,
"start" = "beginning",
"end" = "end",
"life-table" = "life-table"
)
}
get_disc_method <- function(settings) {
if (is.null(settings$discMethod)) {
return("start")
}
settings$discMethod
}
get_cycle_length <- function(settings) {
settings$CycleLength
}
get_cycle_length_units <- function(settings) {
settings$CycleLengthUnits
}
get_timeframe <- function(settings) {
settings$ModelTimeframe
}
get_timeframe_units <- function(settings) {
settings$ModelTimeframeUnits
}
get_days_per_year <- function(settings) {
settings$days_per_year
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.