#########################################
# Perceptual map using factor analysis
#########################################
pm_nr_dim <- c("2 dimensions" = 2, "3 dimensions" = 3)
## list of function arguments
pm_args <- as.list(formals(prmap))
## list of function inputs selected by user
pm_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
pm_args$data_filter <- if (input$show_filter) input$data_filter else ""
pm_args$dataset <- input$dataset
for (i in r_drop(names(pm_args))) {
pm_args[[i]] <- input[[paste0("pm_", i)]]
}
pm_args
})
pm_plot_args <- as.list(if (exists("plot.prmap")) {
formals(plot.prmap)
} else {
formals(radiant.multivariate:::plot.prmap)
})
## list of function inputs selected by user
pm_plot_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
for (i in names(pm_plot_args)) {
pm_plot_args[[i]] <- input[[paste0("pm_", i)]]
}
pm_plot_args
})
output$ui_pm_brand <- renderUI({
isLabel <- "character" == .get_class() | "factor" == .get_class()
vars <- varnames()[isLabel]
selectInput(
inputId = "pm_brand", label = "Brand:", choices = vars,
selected = state_single("pm_brand", vars), multiple = FALSE
)
})
output$ui_pm_attr <- renderUI({
vars <- varnames()
## can't get valid factor scores with PCA and {factor} variables
# toSelect <- .get_class() %in% c("numeric", "integer", "date", "factor")
toSelect <- .get_class() %in% c("numeric", "integer", "date")
vars <- vars[toSelect]
selectInput(
inputId = "pm_attr", label = "Attributes:", choices = vars,
selected = state_multiple("pm_attr", vars), multiple = TRUE,
size = min(10, length(vars)), selectize = FALSE
)
})
output$ui_pm_pref <- renderUI({
if (not_available(input$pm_attr)) {
return()
}
vars <- varnames()
toSelect <- .get_class() %in% c("numeric", "integer", "date", "factor")
vars <- vars[toSelect]
if (length(vars) > 0) vars <- vars[-which(vars %in% c(input$pm_brand, input$pm_attr))]
selectInput(
inputId = "pm_pref", label = "Preferences:", choices = vars,
selected = state_multiple("pm_pref", vars), multiple = TRUE,
size = max(1, min(5, length(vars))), selectize = FALSE
)
})
output$ui_pm_plots <- renderUI({
plot_list <- c("Brands" = "brand", "Attributes" = "attr")
if (!is.empty(input$pm_pref)) plot_list <- c(plot_list, c("Preferences" = "pref"))
checkboxGroupInput(
"pm_plots", NULL, plot_list,
selected = state_group("pm_plots"),
inline = TRUE
)
})
output$ui_pm_store_name <- renderUI({
req(input$dataset)
textInput("pm_store_name", "Store factor scores:", "", placeholder = "Provide single variable name")
})
## add a spinning refresh icon if the factors need to be updated
run_refresh(pm_args, "pm", init = "attr", tabs = "tabs_prmap", label = "Estimate model", relabel = "Re-estimate model")
output$ui_prmap <- renderUI({
req(input$dataset)
tagList(
conditionalPanel(
condition = "input.tabs_prmap == 'Summary'",
wellPanel(
actionButton("pm_run", "Estimate model", width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success")
)
),
wellPanel(
conditionalPanel(
condition = "input.tabs_prmap == 'Summary'",
uiOutput("ui_pm_brand"),
uiOutput("ui_pm_attr"),
uiOutput("ui_pm_pref"),
radioButtons(
inputId = "pm_nr_dim", label = NULL, pm_nr_dim,
selected = state_init("pm_nr_dim", 2),
inline = TRUE
),
# checkboxInput("pm_hcor", "Adjust for {factor} variables", value = state_init("pm_hcor", FALSE)),
numericInput(
"pm_cutoff",
label = "Loadings cutoff:", min = 0,
max = 1, state_init("pm_cutoff", 0), step = .05
),
conditionalPanel(
condition = "input.pm_attr != null",
tags$table(
tags$td(uiOutput("ui_pm_store_name")),
tags$td(actionButton("pm_store", "Store", icon = icon("plus", verify_fa = FALSE)), class = "top")
)
)
),
conditionalPanel(
condition = "input.tabs_prmap == 'Plot'",
uiOutput("ui_pm_plots"),
tags$table(
tags$td(numericInput("pm_scaling", "Attribute scale:", state_init("pm_scaling", 2), .5, 4, .1, width = "117px")),
tags$td(numericInput("pm_fontsz", "Font size:", state_init("pm_fontsz", 5), 1, 20, 1, width = "117px")),
width = "100%"
)
)
),
help_and_report(
modal_title = "Attribute based brand maps",
fun_name = "prmap",
help_file = inclMD(file.path(getOption("radiant.path.multivariate"), "app/tools/help/prmap.md"))
)
)
})
pm_plot <- eventReactive(input$pm_run, {
req(input$pm_nr_dim)
nrDim <- as.numeric(input$pm_nr_dim)
nrPlots <- (nrDim * (nrDim - 1)) / 2
list(plot_width = 650, plot_height = 650 * nrPlots)
})
pm_plot_width <- function() {
pm_plot() %>%
{
if (is.list(.)) .$plot_width else 650
}
}
pm_plot_height <- function() {
pm_plot() %>%
{
if (is.list(.)) .$plot_height else 650
}
}
output$prmap <- renderUI({
register_print_output("summary_prmap", ".summary_prmap")
register_plot_output(
"plot_prmap", ".plot_prmap",
width_fun = "pm_plot_width",
height_fun = "pm_plot_height"
)
pm_output_panels <- tabsetPanel(
id = "tabs_prmap",
tabPanel(
"Summary",
download_link("dl_pm_loadings"), br(),
verbatimTextOutput("summary_prmap")
),
tabPanel(
"Plot",
download_link("dlp_prmap"),
plotOutput("plot_prmap", height = "100%")
)
)
stat_tab_panel(
menu = "Multivariate > Maps",
tool = "Attributes",
tool_ui = "ui_prmap",
output_panels = pm_output_panels
)
})
.prmap_available <- reactive({
if (not_pressed(input$pm_run)) {
"** Press the Estimate button to generate perceptual maps **"
} else if (not_available(input$pm_brand) || not_available(input$pm_attr)) {
"This analysis requires a brand variable of type factor or character and multiple attribute variables\nof type numeric or integer. If these variables are not available please select another dataset.\n\n" %>%
suggest_data("retailers")
} else if (length(input$pm_attr) < 2) {
"Please select two or more attribute variables"
} else {
# brand <- .get_data()[[input$pm_brand]]
# if (length(unique(brand)) < length(brand)) {
# "Number of observations and unique IDs for the brand variable do not match.\nPlease choose another brand variable or another dataset.\n\n" %>%
# suggest_data("retailers")
# } else {
"available"
# }
}
})
.prmap <- eventReactive(input$pm_run, {
withProgress(message = "Generating perceptual map", value = 1, {
pmi <- pm_inputs()
pmi$envir <- r_data
do.call(prmap, pmi)
})
})
.summary_prmap <- reactive({
if (.prmap_available() != "available") {
return(.prmap_available())
}
validate(
need(
input$pm_cutoff >= 0 && input$pm_cutoff <= 1,
"Provide a correlation cutoff value in the range from 0 to 1"
)
)
summary(.prmap(), cutoff = input$pm_cutoff)
})
.plot_prmap <- eventReactive(
{
c(input$pm_run, pm_plot_inputs())
},
{
if (.prmap_available() != "available") {
return(.prmap_available())
}
req("pm_plots" %in% names(input))
robj <- .prmap()
if (is.character(robj)) {
return(robj)
}
withProgress(message = "Generating brand maps", value = 1, {
do.call(plot, c(list(x = robj), pm_plot_inputs(), shiny = TRUE))
})
}
)
prmap_report <- function() {
outputs <- c("summary", "plot")
inp_out <- list(list(cutoff = input$pm_cutoff, dec = 2), "")
inp_out[[2]] <- clean_args(pm_plot_inputs(), pm_plot_args[-1])
inp <- clean_args(pm_inputs(), pm_args)
if (!is.empty(inp$nr_dim)) inp$nr_dim <- as_integer(inp$nr_dim)
if (!is.empty(input$pm_store_name)) {
fixed <- fix_names(input$pm_store_name)
updateTextInput(session, "pm_store_name", value = fixed)
xcmd <- glue('{input$dataset} <- store({input$dataset}, result, name = "{fixed}")')
} else {
xcmd <- ""
}
update_report(
inp_main = inp,
fun_name = "prmap",
inp_out = inp_out,
fig.width = pm_plot_width(),
fig.height = pm_plot_height(),
xcmd = xcmd
)
}
## store factor scores
observeEvent(input$pm_store, {
req(input$pm_store_name, input$pm_run)
fixed <- fix_names(input$pm_store_name)
updateTextInput(session, "pm_store_name", value = fixed)
robj <- .prmap()
if (!is.character(robj)) {
withProgress(
message = "Storing factor scores", value = 1,
r_data[[input$dataset]] <- store(r_data[[input$dataset]], robj, name = fixed)
)
}
})
dl_pm_loadings <- function(path) {
if (pressed(input$pm_run)) {
.prmap() %>%
{
if (is.list(.)) .$fres$loadings else return()
} %>%
clean_loadings(input$pm_cutoff, fsort = FALSE) %>%
write.csv(file = path)
} else {
cat("No output available. Press the Estimate button to generate the factor analysis results", file = path)
}
}
download_handler(
id = "dl_pm_loadings",
fun = dl_pm_loadings,
fn = function() paste0(input$dataset, "_prmap_loadings"),
type = "csv",
caption = "Save factor loadings"
)
download_handler(
id = "dlp_prmap",
fun = download_handler_plot,
fn = function() paste0(input$dataset, "_prmap"),
type = "png",
caption = "Save preceptual map plot",
plot = .plot_prmap,
width = pm_plot_width,
height = pm_plot_height
)
observeEvent(input$prmap_report, {
r_info[["latest_screenshot"]] <- NULL
prmap_report()
})
observeEvent(input$prmap_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_prmap_screenshot")
})
observeEvent(input$modal_prmap_screenshot, {
prmap_report()
removeModal() ## remove shiny modal after save
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.