################################################################
# Conjoint
################################################################
# 交互阶数
ca_show_interactions <- c("", 2, 3)
names(ca_show_interactions) <- c(i18n$t("None"), i18n$t("2-way"), i18n$t("3-way"))
# 预测输入类型
ca_predict <- c("none", "data", "cmd", "datacmd")
names(ca_predict) <- c(i18n$t("None"), i18n$t("Data"), i18n$t("Command"), i18n$t("Data & Command"))
# 绘图选项
ca_plots <- list("none", "pw", "iw")
names(ca_plots) <- c(i18n$t("None"), i18n$t("Part-worths"), i18n$t("Importance-weights"))
# list of function arguments
ca_args <- as.list(formals(conjoint))
# list of function inputs selected by user
ca_inputs <- reactive({
# loop needed because reactive values don't allow single bracket indexing
ca_args$data_filter <- if (input$show_filter) input$data_filter else ""
ca_args$dataset <- input$dataset
for (i in r_drop(names(ca_args))) {
ca_args[[i]] <- input[[paste0("ca_", i)]]
}
ca_args
})
ca_sum_args <- as.list(if (exists("summary.conjoint")) {
formals(summary.conjoint)
} else {
formals(radiant.multivariate:::summary.conjoint)
})
## list of function inputs selected by user
ca_sum_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
for (i in names(ca_sum_args)) {
ca_sum_args[[i]] <- input[[paste0("ca_", i)]]
}
ca_sum_args
})
ca_plot_args <- as.list(if (exists("plot.conjoint")) {
formals(plot.conjoint)
} else {
formals(radiant.multivariate:::plot.conjoint)
})
## list of function inputs selected by user
ca_plot_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
for (i in names(ca_plot_args)) {
ca_plot_args[[i]] <- input[[paste0("ca_", i)]]
}
ca_plot_args
})
ca_pred_args <- as.list(if (exists("predict.conjoint")) {
formals(predict.conjoint)
} else {
formals(radiant.multivariate:::predict.conjoint)
})
## list of function inputs selected by user
ca_pred_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
for (i in names(ca_pred_args)) {
ca_pred_args[[i]] <- input[[paste0("ca_", i)]]
}
ca_pred_args$pred_cmd <- ca_pred_args$pred_data <- ""
if (input$ca_predict == "cmd") {
ca_pred_args$pred_cmd <- gsub("\\s{2,}", " ", input$ca_pred_cmd) %>%
gsub(";\\s+", ";", .) %>%
gsub("\"", "\'", .)
} else if (input$ca_predict == "data") {
ca_pred_args$pred_data <- input$ca_pred_data
} else if (input$ca_predict == "datacmd") {
ca_pred_args$pred_cmd <- gsub("\\s{2,}", " ", input$ca_pred_cmd) %>%
gsub(";\\s+", ";", .) %>%
gsub("\"", "\'", .)
ca_pred_args$pred_data <- input$ca_pred_data
}
ca_pred_args
})
ca_pred_plot_args <- as.list(if (exists("plot.model.predict")) {
formals(plot.model.predict)
} else {
formals(radiant.model:::plot.model.predict)
})
## list of function inputs selected by user
ca_pred_plot_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
for (i in names(ca_pred_plot_args)) {
ca_pred_plot_args[[i]] <- input[[paste0("ca_", i)]]
}
ca_pred_plot_args
})
output$ui_ca_rvar <- renderUI({
isNum <- "numeric" == .get_class() | "integer" == .get_class()
vars <- varnames()[isNum]
selectInput(
inputId = "ca_rvar", label = i18n$t("Profile evaluations:"), choices = vars,
selected = state_single("ca_rvar", vars), multiple = FALSE
)
})
output$ui_ca_evar <- renderUI({
hasLevs <- .get_class() %in% c("factor", "logical", "character")
vars <- varnames()[hasLevs]
selectInput(
inputId = "ca_evar", label = i18n$t("Attributes:"), choices = vars,
selected = state_multiple("ca_evar", vars), multiple = TRUE,
size = min(10, length(vars)), selectize = FALSE
)
})
output$ui_ca_show_interactions <- renderUI({
choices <- ca_show_interactions[1:max(min(3, length(input$ca_evar)), 1)]
radioButtons(
inputId = "ca_show_interactions", label = i18n$t("Interactions:"),
choices = choices, selected = state_init("ca_show_interactions"),
inline = TRUE
)
})
output$ui_ca_int <- renderUI({
if (isolate("ca_show_interactions" %in% names(input)) &&
is.empty(input$ca_show_interactions)) {
choices <- character(0)
} else if (is.empty(input$ca_show_interactions)) {
return()
} else {
vars <- input$ca_evar
if (not_available(vars) || length(vars) < 2) {
return()
}
## list of interaction terms to show
choices <- iterms(vars, input$ca_show_interactions)
}
selectInput(
"ca_int",
label = NULL, choices = choices,
selected = state_init("ca_int"),
multiple = TRUE, size = min(4, length(choices)), selectize = FALSE
)
})
output$ui_ca_by <- renderUI({
vars <- c("None" = "none", varnames())
selectInput(
inputId = "ca_by", label = i18n$t("By:"), choices = vars,
selected = state_single("ca_by", vars, "none"), multiple = FALSE
)
})
output$ui_ca_show <- renderUI({
levs <- c()
if (available(input$ca_by)) {
levs <- .get_data()[[input$ca_by]] %>%
as_factor() %>%
levels()
}
selectInput(
inputId = "ca_show", label = i18n$t("Show:"), choices = levs,
selected = state_single("ca_show", levs, levs[1]), multiple = FALSE
)
})
## reset ca_show if needed
observeEvent(input$ca_by == "none" && !is.empty(input$ca_show), {
updateSelectInput(session = session, inputId = "ca_show", selected = NULL)
})
## reset prediction and plot settings when the dataset changes
observeEvent(input$dataset, {
updateSelectInput(session = session, inputId = "ca_predict", selected = "none")
updateSelectInput(session = session, inputId = "ca_plots", selected = "none")
})
## add a spinning refresh icon if the tabel needs to be (re)calculated
run_refresh(ca_args, "ca", init = "evar", tabs = "tabs_conjoint", label = i18n$t("Estimate model"), relabel = i18n$t("Re-estimate model"))
output$ui_ca_store <- renderUI({
req(input$ca_by != "none")
tagList(
HTML(paste0("")),
tags$table(
tags$td(textInput("ca_store_pw_name", NULL, "", placeholder = i18n$t("Provide data name"))),
tags$td(actionButton("ca_store_pw", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top_mini")
),
tags$br(),
HTML(paste0("")),
tags$table(
tags$td(textInput("ca_store_iw_name", NULL, "", placeholder = i18n$t("Provide data name"))),
tags$td(actionButton("ca_store_iw", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top_mini")
)
)
})
output$ui_ca_store_pred <- renderUI({
req(input$ca_predict != "none")
req(input$ca_by)
lab <- paste0("")
name <- "pred_ca"
if (input$ca_by != "none") {
lab <- sub(":", paste0(" ", i18n$t("in new dataset:"), ":"), lab)
name <- ""
}
tags$table(
if (!input$ca_pred_plot) tags$br(),
HTML(lab),
tags$td(textInput("ca_store_pred_name", NULL, name, placeholder = i18n$t("Provide data name"))),
tags$td(actionButton("ca_store_pred", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top_mini")
)
})
output$ui_ca_predict_plot <- renderUI({
req(input$ca_by)
if (input$ca_by != "none") {
predict_plot_controls("ca", vars_color = input$ca_by, init_color = input$ca_by)
} else {
predict_plot_controls("ca")
}
})
output$ui_ca_pred_data <- renderUI({
selectizeInput(
inputId = "ca_pred_data", label = i18n$t("Prediction data:"),
choices = c("None" = "", r_info[["datasetlist"]]),
selected = state_single("ca_pred_data", c("None" = "", r_info[["datasetlist"]])),
multiple = FALSE
)
})
output$ui_conjoint <- renderUI({
req(input$dataset)
tagList(
conditionalPanel(
condition = "input.tabs_conjoint == 'Summary'",
wellPanel(
actionButton("ca_run", i18n$t("Estimate model"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success")
)
),
wellPanel(
conditionalPanel(
condition = "input.tabs_conjoint == 'Summary'",
uiOutput("ui_ca_rvar"),
uiOutput("ui_ca_evar"),
# uiOutput("ui_ca_show_interactions"),
# conditionalPanel(condition = "input.ca_show_interactions != ''",
# uiOutput("ui_ca_int")
# ),
uiOutput("ui_ca_by"),
conditionalPanel(
condition = "input.tabs_conjoint != 'Predict' & input.ca_by != 'none'",
uiOutput("ui_ca_show")
),
conditionalPanel(
condition = "input.tabs_conjoint == 'Summary'",
uiOutput("ui_ca_store")
),
conditionalPanel(
condition = "input.ca_evar != null",
checkboxInput(
"ca_reverse",
label = i18n$t("Reverse evaluation scores"),
value = state_init("ca_reverse", FALSE)
),
conditionalPanel(
condition = "input.tabs_conjoint == 'Summary'",
checkboxInput(
inputId = "ca_additional", label = i18n$t("Additional regression output"),
value = state_init("ca_additional", FALSE)
),
checkboxInput(
inputId = "ca_mc_diag", label = i18n$t("VIF"),
value = state_init("ca_mc_diag", FALSE)
)
)
)
),
conditionalPanel(
condition = "input.tabs_conjoint == 'Predict'",
selectInput(
"ca_predict",
label = i18n$t("Prediction input type:"), ca_predict,
selected = state_single("ca_predict", ca_predict, "none")
),
conditionalPanel(
"input.ca_predict == 'data' | input.ca_predict == 'datacmd'",
uiOutput("ui_ca_pred_data")
),
conditionalPanel(
"input.ca_predict == 'cmd' | input.ca_predict == 'datacmd'",
returnTextAreaInput(
"ca_pred_cmd", i18n$t("Prediction command:"),
value = state_init("ca_pred_cmd", "")
)
),
conditionalPanel(
condition = "input.ca_predict != 'none'",
checkboxInput("ca_pred_plot", i18n$t("Plot predictions"), state_init("ca_pred_plot", FALSE)),
conditionalPanel(
"input.ca_pred_plot == true",
uiOutput("ui_ca_predict_plot")
)
),
## only show if a dataset is used for prediction or storing predictions 'by'
conditionalPanel(
"input.ca_predict == 'data' | input.ca_predict == 'datacmd' | input.ca_by != 'none'",
uiOutput("ui_ca_store_pred")
)
),
conditionalPanel(
condition = "input.tabs_conjoint == 'Plot'",
selectInput(
"ca_plots", i18n$t("Conjoint plots:"),
choices = ca_plots,
selected = state_single("ca_plots", ca_plots, "none")
),
conditionalPanel(
condition = "input.ca_plots == 'pw'",
checkboxInput(
inputId = "ca_scale_plot", label = i18n$t("Scale PW plots"),
value = state_init("ca_scale_plot", FALSE)
)
)
)
),
help_and_report(
modal_title = i18n$t("Conjoint"),
fun_name = "conjoint",
help_file = inclMD(file.path(getOption("radiant.path.multivariate"), "app/tools/help/conjoint.md"))
)
)
})
ca_available <- reactive({
if (not_pressed(input$ca_run)) {
i18n$t("** Press the Estimate button to run the conjoint analysis **")
} else if (not_available(input$ca_rvar)) {
i18n$t("This analysis requires a response variable of type integer\nor numeric and one or more explanatory variables.\nIf these variables are not available please select another dataset.") %>%
suggest_data("carpet")
} else if (not_available(input$ca_evar)) {
i18n$t("Please select one or more explanatory variables of type factor.\nIf none are available please choose another dataset") %>%
suggest_data("carpet")
} else {
"available"
}
})
ca_plot <- reactive({
req(pressed(input$ca_run))
if (ca_available() != "available") {
return()
}
req(input$ca_plots)
nrVars <- length(input$ca_evar)
plot_height <- plot_width <- 500
if (input$ca_plots == "pw") {
plot_height <- 325 * (1 + floor((nrVars - 1) / 2))
plot_width <- 325 * min(nrVars, 2)
}
list(plot_width = plot_width, plot_height = plot_height)
})
ca_plot_width <- function() {
ca_plot() %>%
{
if (is.list(.)) .$plot_width else 650
}
}
ca_plot_height <- function() {
ca_plot() %>%
{
if (is.list(.)) .$plot_height else 400
}
}
ca_pred_plot_height <- function() {
if (input$ca_pred_plot) 500 else 0
}
output$conjoint <- renderUI({
register_print_output("summary_conjoint", ".summary_conjoint")
register_print_output("predict_conjoint", ".predict_print_conjoint")
register_plot_output(
"predict_plot_conjoint", ".predict_plot_conjoint",
height_fun = "ca_pred_plot_height"
)
register_plot_output(
"plot_conjoint", ".plot_conjoint",
height_fun = "ca_plot_height",
width_fun = "ca_plot_width"
)
## three separate tabs
ca_output_panels <- tabsetPanel(
id = "tabs_conjoint",
tabPanel(
i18n$t("Summary"), value = "Summary",
download_link("dl_ca_PWs"), br(),
verbatimTextOutput("summary_conjoint")
),
tabPanel(
i18n$t("Predict"), value = "Predict",
conditionalPanel(
"input.ca_pred_plot == true",
download_link("dlp_ca_pred"),
plotOutput("predict_plot_conjoint", width = "100%", height = "100%")
),
download_link("dl_ca_pred"), br(),
verbatimTextOutput("predict_conjoint")
),
tabPanel(
i18n$t("Plot"), value = "Plot",
download_link("dlp_conjoint"),
plotOutput("plot_conjoint", width = "100%", height = "100%")
)
)
stat_tab_panel(
menu = i18n$t("Multivariate > Conjoint"),
tool = i18n$t("Conjoint"),
tool_ui = "ui_conjoint",
output_panels = ca_output_panels
)
})
.conjoint <- eventReactive(input$ca_run, {
req(available(input$ca_rvar), available(input$ca_evar))
withProgress(message = i18n$t("Estimating model"), value = 1, {
cai <- ca_inputs()
cai$envir <- r_data
do.call(conjoint, cai)
})
})
.summary_conjoint <- reactive({
if (not_pressed(input$ca_run)) {
return(i18n$t("** Press the Estimate button to estimate the model **"))
}
if (ca_available() != "available") {
return(ca_available())
}
cai <- ca_sum_inputs()
cai$object <- .conjoint()
do.call(summary, cai)
})
.predict_conjoint <- reactive({
if (not_pressed(input$ca_run)) {
return(i18n$t("** Press the Estimate button to estimate the model **"))
}
if (ca_available() != "available") {
return(ca_available())
}
if (is.empty(input$ca_predict, "none")) {
return(i18n$t("** Select prediction input **"))
}
if ((input$ca_predict == "data" || input$ca_predict == "datacmd") && is.empty(input$ca_pred_data)) {
return(i18n$t("** Select data for prediction **"))
}
if (input$ca_predict == "cmd" && is.empty(input$ca_pred_cmd)) {
return(i18n$t("** Enter prediction commands **"))
}
withProgress(message = i18n$t("Generating predictions"), value = 1, {
cai <- ca_pred_inputs()
cai$object <- .conjoint()
cai$envir <- r_data
do.call(predict, cai)
})
})
.predict_print_conjoint <- reactive({
.predict_conjoint() %>%
{
if (is.character(.)) cat(., "\n") else print(.)
}
})
.predict_plot_conjoint <- reactive({
if (not_pressed(input$ca_run)) {
return(invisible())
}
if (ca_available() != "available") {
return(ca_available())
}
req(input$ca_pred_plot, available(input$ca_xvar))
if (is.empty(input$ca_predict, "none")) {
return(invisible())
}
if ((input$ca_predict == "data" || input$ca_predict == "datacmd") && is.empty(input$ca_pred_data)) {
return(invisible())
}
if (input$ca_predict == "cmd" && is.empty(input$ca_pred_cmd)) {
return(invisible())
}
withProgress(message = "Generating prediction plot", value = 1, {
do.call(plot, c(list(x = .predict_conjoint()), ca_pred_plot_inputs()))
})
})
.plot_conjoint <- reactive({
if (not_pressed(input$ca_run)) {
return(i18n$t("** Press the Estimate button to estimate the model **"))
} else if (is.empty(input$ca_plots, "none")) {
return(i18n$t("Please select a conjoint plot from the drop-down menu"))
}
input$ca_scale_plot
input$ca_plots
isolate({
if (ca_available() != "available") {
return(ca_available())
}
withProgress(message = i18n$t("Generating plots"), value = 1, {
do.call(plot, c(list(x = .conjoint()), ca_plot_inputs(), shiny = TRUE))
})
})
})
conjoint_report <- function() {
outputs <- c("summary")
inp_out <- list("", "")
inp_out[[1]] <- clean_args(ca_sum_inputs(), ca_sum_args[-1])
figs <- FALSE
if (!is.empty(input$ca_plots, "none")) {
inp_out[[2]] <- clean_args(ca_plot_inputs(), ca_plot_args[-1])
inp_out[[2]]$custom <- FALSE
outputs <- c(outputs, "plot")
figs <- TRUE
}
xcmd <- ""
if (input$ca_by != "none") {
if (!is.empty(input$ca_store_pw_name)) {
fixed <- fix_names(input$ca_store_pw_name)
updateTextInput(session, "ca_store_pw_name", value = fixed)
xcmd <- glue('{xcmd}{fixed} <- result$PW\nregister("{fixed}")\n\n')
}
if (!is.empty(input$ca_store_iw_name)) {
fixed <- fix_names(input$ca_store_iw_name)
updateTextInput(session, "ca_store_iw_name", value = fixed)
xcmd <- glue('{xcmd}{fixed} <- result$IW\nregister("{fixed}")\n\n')
}
}
if (!is.empty(input$ca_predict, "none") &&
(!is.empty(input$ca_pred_data) || !is.empty(input$ca_pred_cmd))) {
pred_args <- clean_args(ca_pred_inputs(), ca_pred_args[-1])
if (!is.empty(pred_args$pred_cmd)) {
pred_args$pred_cmd <- strsplit(pred_args$pred_cmd, ";\\s*")[[1]]
} else {
pred_args$pred_cmd <- NULL
}
if (!is.empty(pred_args$pred_data)) {
pred_args$pred_data <- as.symbol(pred_args$pred_data)
} else {
pred_args$pred_data <- NULL
}
inp_out[[2 + figs]] <- pred_args
fixed <- "pred"
if (!is.empty(input$ca_by, "none") && !is.empty(input$ca_store_pred_name)) {
fixed <- fix_names(input$ca_store_pred_name)
updateTextInput(session, "ca_store_pred_name", value = fixed)
outputs <- c(outputs, paste0(fixed, " <- predict"))
xcmd <- paste0(xcmd, fixed %>% paste0("register(\"", ., "\")\nprint(", ., ", n = 10)"))
} else {
outputs <- c(outputs, "pred <- predict")
xcmd <- paste0(xcmd, "print(pred, n = 10)")
if (input$ca_predict %in% c("data", "datacmd")) {
if (is.empty(input$ca_by, "none")) {
fixed <- unlist(strsplit(input$ca_store_pred_name, "(\\s*,\\s*|\\s*;\\s*)")) %>%
fix_names() %>%
deparse(., control = getOption("dctrl"), width.cutoff = 500L)
xcmd <- paste0(
xcmd, "\n", input$ca_pred_data, " <- store(",
input$ca_pred_data, ", pred, name = ", fixed, ")"
)
}
}
}
if (input$ca_pred_plot && !is.empty(input$ca_xvar)) {
inp_out[[3 + figs]] <- clean_args(ca_pred_plot_inputs(), ca_pred_plot_args[-1])
inp_out[[3 + figs]]$result <- pred_args$pred_name
outputs <- c(outputs, "plot")
figs <- TRUE
}
}
update_report(
inp_main = clean_args(ca_inputs(), ca_args),
fun_name = "conjoint",
inp_out = inp_out,
outputs = outputs,
figs = figs,
fig.width = ca_plot_width(),
fig.height = ca_plot_height(),
xcmd = xcmd
)
}
observeEvent(input$ca_store_pw, {
name <- input$ca_store_pw_name
req(pressed(input$ca_run), name)
fixed <- fix_names(input$ca_store_pw_name)
updateTextInput(session, "ca_store_pw_name", value = fixed)
robj <- .conjoint()
if (!is.list(robj)) {
return()
}
withProgress(
message = i18n$t("Storing PWs"), value = 1,
r_data[[fixed]] <- robj$PW
)
register(fixed)
})
observeEvent(input$ca_store_iw, {
name <- input$ca_store_iw_name
req(pressed(input$ca_run), name)
fixed <- fix_names(input$ca_store_iw_name)
updateTextInput(session, "ca_store_iw_name", value = fixed)
robj <- .conjoint()
if (!is.list(robj)) {
return()
}
withProgress(
message = i18n$t("Storing IWs"), value = 1,
r_data[[fixed]] <- robj$IW
)
register(fixed)
})
observeEvent(input$ca_store_pred, {
req(!is.empty(input$ca_pred_data), pressed(input$ca_run))
pred <- .predict_conjoint()
if (is.null(pred)) {
return()
}
fixed <- fix_names(input$ca_store_pred_name)
updateTextInput(session, "ca_store_pred_name", value = fixed)
if ("conjoint.predict.by" %in% class(pred)) {
withProgress(
message = i18n$t("Storing predictions in new dataset"), value = 1,
r_data[[fixed]] <- pred,
)
register(fixed)
} else {
withProgress(
message = i18n$t("Storing predictions"), value = 1,
r_data[[input$ca_pred_data]] <- radiant.model:::store.model.predict(
r_data[[input$ca_pred_data]], pred,
name = fixed
)
)
}
})
dl_ca_PWs <- function(path) {
if (pressed(input$ca_run)) {
if (is.empty(input$ca_show)) {
tab <- .conjoint()$model_list[["full"]]$tab
} else {
tab <- .conjoint()$model_list[[input$ca_show]]$tab
}
write.csv(tab$PW, file = path, row.names = FALSE)
} else {
cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path)
}
}
download_handler(
id = "dl_ca_PWs",
fun = dl_ca_PWs,
fn = function() paste0(input$dataset, "_PWs"),
type = "csv",
caption = i18n$t("Save part worths")
)
dl_ca_pred <- function(path) {
if (pressed(input$ca_run)) {
write.csv(.predict_conjoint(), file = path, row.names = FALSE)
} else {
cat(i18n$t("No output available. Press the Estimate button to generate results"), file = path)
}
}
download_handler(
id = "dl_ca_pred",
fun = dl_ca_pred,
fn = function() paste0(input$dataset, "_conjoint_pred"),
type = "csv",
caption = i18n$t("Save predictions")
)
download_handler(
id = "dlp_ca_pred",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_conjoint_pred"),
type = "png",
caption = i18n$t("Save conjoint prediction plot"),
plot = .predict_plot_conjoint,
width = plot_width,
height = ca_pred_plot_height
)
download_handler(
id = "dlp_conjoint",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_conjoint"),
type = "png",
caption = i18n$t("Save conjoint plot"),
plot = .plot_conjoint,
width = ca_plot_width,
height = ca_plot_height
)
observeEvent(input$conjoint_report, {
r_info[["latest_screenshot"]] <- NULL
conjoint_report()
})
observeEvent(input$conjoint_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_conjoint_screenshot")
})
observeEvent(input$modal_conjoint_screenshot, {
conjoint_report()
removeModal() ## remove shiny modal after save
})