# setwd("~/Dropbox/OptimizingSI/Analysis/ono") # install.packages( "~/Documents/strategize-software/strategize", repos = NULL, type = "source",force = F) # Script: app_ono.R options(error = NULL) library(shiny) library(ggplot2) library(strategize) library(dplyr) # Custom plotting function for optimal strategy distributions plot_factor <- function(pi_star_list, pi_star_se_list, factor_name, zStar = 1.96, n_strategies = 1L) { probs <- lapply(pi_star_list, function(x) x[[factor_name]]) ses <- lapply(pi_star_se_list, function(x) x[[factor_name]]) levels <- names(probs[[1]]) # Create data frame for plotting df <- do.call(rbind, lapply(1:n_strategies, function(i) { data.frame( Strategy = if (n_strategies == 1) "Optimal" else c("Democrat", "Republican")[i], Level = levels, Probability = probs[[i]] #SE = ses[[i]] ) })) # Manual dodging: Create numeric x-positions with offsets df$Level_num <- as.numeric(as.factor(df$Level)) # Convert Level to numeric (1, 2, ...) if (n_strategies == 1) { df$x_dodged <- df$Level_num # No dodging for single strategy } else { # Apply ±offset for Democrat/Republican df$x_dodged <- df$Level_num + ifelse(df$Strategy == "Democrat", -0.05, 0.05) } # Plot with ggplot2 p <- ggplot(df, aes(x = x_dodged, y = Probability, color = Strategy)) + # Segment from y=0 to y=Probability geom_segment( aes(x = x_dodged, xend = x_dodged, y = 0, yend = Probability), size = 0.3 ) + # Point at the probability geom_point( size = 2.5 ) + # Text label above the point geom_text( aes(x = x_dodged, label = sprintf("%.2f", Probability)), vjust = -0.7, size = 3 ) + # Set x-axis with original Level labels scale_x_continuous( breaks = unique(df$Level_num), labels = unique(df$Level), limits = c(min(df$x_dodged)-0.20, max(df$x_dodged)+0.20) ) + # Labels labs( title = "Optimal Distribution for:", subtitle = sprintf("*%s*", gsub(factor_name, pattern = "\\.", replace = " ")), x = "Level", y = "Probability" ) + # Apply Tufte's minimalistic theme theme_minimal(base_size = 18, base_line_size = 0) + theme( legend.position = "none", legend.title = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), axis.line = element_line(color = "black", size = 0.5), axis.text.x = element_text(angle = 45, hjust = 1, margin = margin(r = 10)) # Add right margin ) + # Manual color scale for different strategies scale_color_manual(values = c("Democrat" = "#89cff0", "Republican" = "red", "Optimal" = "black")) return(p) } # UI Definition ui <- fluidPage( titlePanel("Exploring strategize with the candidate choice conjoint data"), tags$p( style = "text-align: left; margin-top: -10px;", tags$a( href = "https://strategizelab.org/", target = "_blank", title = "strategizelab.org", style = "color: #337ab7; text-decoration: none;", "strategizelab.org ", icon("external-link", style = "font-size: 12px;") ) ), # ---- Minimal "Share" button HTML + JS inlined ---- tags$div( style = "text-align: left; margin: 0.5em 0 0.5em 0em;", HTML(' '), tags$script( HTML(" (function() { const shareBtn = document.getElementById('share-button'); // Reusable helper function to show a small “Copied!” message function showCopyNotification() { const notification = document.createElement('div'); notification.innerText = 'Copied to clipboard'; notification.style.position = 'fixed'; notification.style.bottom = '20px'; notification.style.right = '20px'; notification.style.backgroundColor = 'rgba(0, 0, 0, 0.8)'; notification.style.color = '#fff'; notification.style.padding = '8px 12px'; notification.style.borderRadius = '4px'; notification.style.zIndex = '9999'; document.body.appendChild(notification); setTimeout(() => { notification.remove(); }, 2000); } shareBtn.addEventListener('click', function() { const currentURL = window.location.href; const pageTitle = document.title || 'Check this out!'; // If browser supports Web Share API if (navigator.share) { navigator.share({ title: pageTitle, text: '', url: currentURL }) .catch((error) => { console.log('Sharing failed', error); }); } else { // Fallback: Copy URL if (navigator.clipboard && navigator.clipboard.writeText) { navigator.clipboard.writeText(currentURL).then(() => { showCopyNotification(); }, (err) => { console.error('Could not copy text: ', err); }); } else { // Double fallback for older browsers const textArea = document.createElement('textarea'); textArea.value = currentURL; document.body.appendChild(textArea); textArea.select(); try { document.execCommand('copy'); showCopyNotification(); } catch (err) { alert('Please copy this link:\\n' + currentURL); } document.body.removeChild(textArea); } } }); })(); ") ) ), # ---- End: Minimal Share button snippet ---- sidebarLayout( sidebarPanel( h4("Analysis Options"), radioButtons("case_type", "Case Type:", choices = c("Average", "Adversarial"), selected = "Average"), conditionalPanel( condition = "input.case_type == 'Average'", selectInput("respondent_group", "Respondent Group:", choices = c("All", "Democrat", "Independent", "Republican"), selected = "All") ), numericInput("lambda_input", "Lambda (regularization):", value = 0.01, min = 1e-6, max = 10, step = 0.01), actionButton("compute", "Compute Results", class = "btn-primary"), hr(), h4("Visualization"), selectInput("factor", "Select Factor to Display:", choices = NULL), br(), selectInput("previousResults", "View Previous Results:", choices = NULL), hr(), h5("Instructions:"), p("1. Select a case type and, for Average case, a respondent group."), p("2. Specify the single lambda to be used by strategize."), p("3. Click 'Compute Results' to generate optimal strategies."), p("4. Choose a factor to view its distribution."), p("5. Use 'View Previous Results' to toggle among past computations.") ), mainPanel( tabsetPanel( tabPanel("Optimal Strategy Plot", plotOutput("strategy_plot", height = "600px")), tabPanel("Q Value", verbatimTextOutput("q_value"), p("Q represents the estimated outcome under the optimal strategy, with 95% confidence interval.")), tabPanel("About", h3("About this page"), p("This page app explores the ", a("strategize R package", href = "https://github.com/cjerzak/strategize-software/", target = "_blank"), " using Ono forced conjoint experimental data. It computes optimal strategies for Average (optimizing for a respondent group) and Adversarial (optimizing for both parties in competition) cases on the fly."), p(strong("Average Case:"), "Optimizes candidate characteristics for a selected respondent group."), p(strong("Adversarial Case:"), "Finds equilibrium strategies for Democrats and Republicans."), p(strong("More information:"), a("strategizelab.org", href = "https://strategizelab.org", target = "_blank")) ) ), br(), wellPanel( h4("Currently Selected Computation:"), verbatimTextOutput("selection_summary") ) ) ) ) # Server Definition server <- function(input, output, session) { # Load data load("Processed_OnoData.RData") Primary2016 <- read.csv("PrimaryCandidates2016 - Sheet1.csv") # Prepare a storage structure for caching multiple results cachedResults <- reactiveValues(data = list()) # Dynamic update of factor choices observe({ if (input$case_type == "Average") { factors <- colnames(FACTOR_MAT_FULL)[!colnames(FACTOR_MAT_FULL) %in% c("Office")] } else { factors <- colnames(FACTOR_MAT_FULL)[!colnames(FACTOR_MAT_FULL) %in% c("Office", "Party.affiliation", "Party.competition")] } updateSelectInput(session, "factor", choices = factors, selected = factors[1]) }) # Observe "Compute Results" button to generate a new result and cache it observeEvent(input$compute, { withProgress(message = "Computing optimal strategies...", value = 0, { incProgress(0.2, detail = "Preparing data...") # Common hyperparameters params <- list( nSGD = 1000L, batch_size = 50L, penalty_type = "KL", nFolds = 3L, use_optax = TRUE, compute_se = FALSE, # Set to FALSE for quicker results conf_level = 0.95, conda_env = "strategize", conda_env_required = TRUE ) # Grab the single user-chosen lambda my_lambda <- input$lambda_input # We'll define a label to track the result uniquely # Include the case type, group (if Average), and lambda in the label if (input$case_type == "Average") { label <- paste("Case=Average, Group=", input$respondent_group, ", Lambda=", my_lambda, sep="") } else { label <- paste("Case=Adversarial, Lambda=", my_lambda, sep="") } strategize_start <- Sys.time() # Timing strategize start if (input$case_type == "Average") { # Subset data for Average case if (input$respondent_group == "All") { indices <- which(my_data$Office == "President") } else { indices <- which( my_data_FULL$R_Partisanship == input$respondent_group & my_data$Office == "President" ) } FACTOR_MAT <- FACTOR_MAT_FULL[indices, !colnames(FACTOR_MAT_FULL) %in% c("Office","Party.affiliation","Party.competition")] Yobs <- Yobs_FULL[indices] X <- X_FULL[indices, ] log_pr_w <- log_pr_w_FULL[indices] pair_id <- pair_id_FULL[indices] assignmentProbList <- assignmentProbList_FULL[names(FACTOR_MAT)] incProgress(0.4, detail = "Running strategize...") # Compute with strategize Qoptimized <- strategize( Y = Yobs, W = FACTOR_MAT, X = X, pair_id = pair_id, p_list = assignmentProbList[colnames(FACTOR_MAT)], lambda = my_lambda, diff = TRUE, adversarial = FALSE, use_regularization = TRUE, K = 1L, nSGD = params$nSGD, penalty_type = params$penalty_type, folds = params$nFolds, use_optax = params$use_optax, compute_se = params$compute_se, conf_level = params$conf_level, conda_env = params$conda_env, conda_env_required = params$conda_env_required ) Qoptimized$n_strategies <- 1L } if (input$case_type == "Adversarial"){ # Adversarial case DROP_FACTORS <- c("Office", "Party.affiliation", "Party.competition") FACTOR_MAT <- FACTOR_MAT_FULL[, !colnames(FACTOR_MAT_FULL) %in% DROP_FACTORS] Yobs <- Yobs_FULL X <- X_FULL log_pr_w <- log_pr_w_FULL assignmentProbList <- assignmentProbList_FULL[!names(assignmentProbList_FULL) %in% DROP_FACTORS] incProgress(0.3, detail = "Preparing slate data...") FactorOptions <- apply(FACTOR_MAT, 2, table) prior_alpha <- 10 Primary_D <- Primary2016[Primary2016$Party == "Democratic", colnames(FACTOR_MAT)] Primary_R <- Primary2016[Primary2016$Party == "Republican", colnames(FACTOR_MAT)] Primary_D_slate <- lapply(colnames(Primary_D), function(col) { posterior_alpha <- FactorOptions[[col]]; posterior_alpha[] <- prior_alpha Empirical_ <- table(Primary_D[[col]]) Empirical_ <- Empirical_[names(Empirical_) != "Unclear"] posterior_alpha[names(Empirical_)] <- posterior_alpha[names(Empirical_)] + Empirical_ prop.table(posterior_alpha) }) names(Primary_D_slate) <- colnames(Primary_D) Primary_R_slate <- lapply(colnames(Primary_R), function(col) { posterior_alpha <- FactorOptions[[col]]; posterior_alpha[] <- prior_alpha Empirical_ <- table(Primary_R[[col]]) Empirical_ <- Empirical_[names(Empirical_) != "Unclear"] posterior_alpha[names(Empirical_)] <- posterior_alpha[names(Empirical_)] + Empirical_ prop.table(posterior_alpha) }) names(Primary_R_slate) <- colnames(Primary_R) slate_list <- list("Democratic" = Primary_D_slate, "Republican" = Primary_R_slate) indices <- which( my_data$R_Partisanship %in% c("Republican","Democrat") & my_data$Office == "President" ) FACTOR_MAT <- FACTOR_MAT_FULL[indices, !colnames(FACTOR_MAT_FULL) %in% c("Office","Party.competition","Party.affiliation")] Yobs <- Yobs_FULL[indices] my_data_red <- my_data_FULL[indices,] pair_id <- pair_id_FULL[indices] cluster_var <- cluster_var_FULL[indices] my_data_red$Party.affiliation_clean <- ifelse( my_data_red$Party.affiliation == "Republican Party", yes = "Republican", no = ifelse(my_data_red$Party.affiliation == "Democratic Party","Democrat","Independent") ) assignmentProbList <- assignmentProbList_FULL[colnames(FACTOR_MAT)] slate_list$Democratic <- slate_list$Democratic[names(assignmentProbList)] slate_list$Republican <- slate_list$Republican[names(assignmentProbList)] incProgress(0.4, detail = "Running strategize...") Qoptimized <- strategize( Y = Yobs, W = FACTOR_MAT, X = NULL, p_list = assignmentProbList, slate_list = slate_list, varcov_cluster_variable = cluster_var, competing_group_variable_respondent = my_data_red$R_Partisanship, competing_group_variable_candidate = my_data_red$Party.affiliation_clean, competing_group_competition_variable_candidate = my_data_red$Party.competition, pair_id = pair_id, respondent_id = my_data_red$respondentIndex, respondent_task_id = my_data_red$task, profile_order = my_data_red$profile, lambda = my_lambda, diff = TRUE, use_regularization = TRUE, force_gaussian = FALSE, adversarial = TRUE, K = 1L, nMonte_adversarial = 20L, nSGD = params$nSGD, penalty_type = params$penalty_type, learning_rate_max = 0.001, use_optax = params$use_optax, compute_se = params$compute_se, conf_level = params$conf_level, conda_env = params$conda_env, conda_env_required = params$conda_env_required ) # check correlation between strategies to diagnose optimization issues # plot(unlist(Qoptimized$pi_star_point$Democrat), unlist(Qoptimized$pi_star_point$Republican)) Qoptimized$n_strategies <- 2L } Qoptimized$runtime_seconds <- as.numeric(difftime(Sys.time(), strategize_start, units = "secs")) Qoptimized <- Qoptimized[c("pi_star_point", "pi_star_se", "Q_point", "Q_se", "n_strategies", "runtime_seconds")] incProgress(0.8, detail = "Finalizing results...") # Store in the reactiveValues cache cachedResults$data[[label]] <- Qoptimized # Update the choice list for previous results updateSelectInput(session, "previousResults", choices = names(cachedResults$data), selected = label) }) }) # Reactive to pick the result the user wants to display selectedResult <- reactive({ validate( need(input$previousResults != "", "No result computed or selected yet.") ) cachedResults$data[[input$previousResults]] }) # Render strategy plot output$strategy_plot <- renderPlot({ req(selectedResult()) factor_name <- input$factor pi_star_list <- selectedResult()$pi_star_point pi_star_se_list <- selectedResult()$pi_star_se n_strategies <- selectedResult()$n_strategies plot_factor(pi_star_list = pi_star_list, pi_star_se_list = pi_star_se_list, factor_name = factor_name, n_strategies = n_strategies) }) # Render Q value output$q_value <- renderText({ req(selectedResult()) q_point <- selectedResult()$Q_point q_se <- selectedResult()$Q_se show_se <- length(q_se) > 0 if(show_se){ show_se <- q_se > 0 } if(!show_se){ render_text <- paste("Estimated Q Value:", sprintf("%.3f", q_point)) } if(show_se){ render_text <- paste("Estimated Q Value:", sprintf("%.3f ± %.3f", q_point, 1.96 * q_se)) } sprintf("%s (Runtime: %.3f s)", render_text, selectedResult()$runtime_seconds) }) # Show which set of parameters (label) is currently selected output$selection_summary <- renderText({ input$previousResults }) } # Run the app shinyApp(ui, server)