app.R

# 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('
        <button id="share-button" 
                style="
                  display: inline-flex;
                  align-items: center;
                  justify-content: center;
                  gap: 8px; 
                  padding: 5px 10px;
                  font-size: 16px;
                  font-weight: normal;
                  color: #000;
                  background-color: #fff;
                  border: 1px solid #ddd;
                  border-radius: 6px;
                  cursor: pointer;
                  box-shadow: 0 1.5px 0 #000;
                ">
          <svg width="18" height="18" viewBox="0 0 24 24" fill="none" stroke="currentColor" 
               stroke-width="2" stroke-linecap="round" stroke-linejoin="round">
            <circle cx="18" cy="5" r="3"></circle>
            <circle cx="6" cy="12" r="3"></circle>
            <circle cx="18" cy="19" r="3"></circle>
            <line x1="8.59" y1="13.51" x2="15.42" y2="17.49"></line>
            <line x1="15.41" y1="6.51" x2="8.59" y2="10.49"></line>
          </svg>
          <strong>Share</strong>
        </button>
      '),
    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)