bug-man/HF_Shiny_Maxdiff_Calculation_Automation

1library(shiny)2library(openxlsx)3library(dplyr)4library(readr)5library(haven)6library(readxl)7 8# Increase maximum file size to 30MB9options(shiny.maxRequestSize = 30*1024^2)10 11# Define UI12ui <- fluidPage(13  titlePanel("MaxDiff Analysis App"),14  15  sidebarLayout(16    sidebarPanel(17      fileInput("main_survey", "Upload Main Survey (SAV/ZIP)", accept = c(".sav", ".zip")),18      fileInput("secondary_survey", "Upload Secondary Survey (SAV/ZIP)", accept = c(".sav", ".zip")),19      fileInput("maxdiff_results", "Upload MaxDiff Results (CSV/ZIP)", accept = c(".csv", ".zip")),20      selectInput("filter_option", "Filter by:", choices = c("None", "P4W", "Personality")),21      conditionalPanel(22        condition = "input.filter_option == 'P4W'",23        uiOutput("p4w_checkbox_group")24      ),25      conditionalPanel(26        condition = "input.filter_option == 'Personality'",27        checkboxGroupInput("personality_colors", "Select personality colors:",28                           choices = c("Orange" = "1,3", "Purple" = "2,4", "Green" = "5,6", "Blue" = "7,8"),29                           selected = c("1,3", "2,4", "5,6", "7,8"))30      ),31      uiOutput("design_route_checkbox"),32      actionButton("run_analysis", "Run Analysis"),33      downloadButton("download_results", "Download Results")34    ),35    36    mainPanel(37      textOutput("status"),38      tableOutput("results_preview")39    )40  )41)42 43# Define server logic44server <- function(input, output, session) {45  46  # Function to read uploaded file47  read_uploaded_file <- function(file) {48    if (is.null(file)) return(NULL)49    50    ext <- tools::file_ext(file$name)51    52    if (ext == "zip") {53      temp <- tempfile()54      unzip(file$datapath, exdir = temp)55      file_path <- list.files(temp, full.names = TRUE)[1]56    } else {57      file_path <- file$datapath58    }59    60    if (ext == "sav" || (ext == "zip" && grepl("\\.sav$", file_path))) {61      data <- haven::read_sav(file_path)62    } else if (ext == "csv" || (ext == "zip" && grepl("\\.csv$", file_path))) {63      data <- readr::read_csv(file_path)64    }65    66    return(data)67  }68  69  # Reactive values to store uploaded data70  uploaded_data <- reactiveValues(71    main_survey = NULL,72    secondary_survey = NULL,73    maxdiff_results = NULL74  )75  76  # Observers for file uploads77  observe({78    req(input$main_survey)79    uploaded_data$main_survey <- read_uploaded_file(input$main_survey)80  })81  82  observe({83    req(input$secondary_survey)84    uploaded_data$secondary_survey <- read_uploaded_file(input$secondary_survey)85  })86  87  observe({88    req(input$maxdiff_results)89    uploaded_data$maxdiff_results <- read_uploaded_file(input$maxdiff_results)90  })91  92  # Generate P4W checkboxes93  output$p4w_checkbox_group <- renderUI({94    req(uploaded_data$main_survey)95    p4w_cols <- grep("^P4W", names(uploaded_data$main_survey), value = TRUE)96    p4w_cols <- p4w_cols[!grepl("P4W_Beer_Drinker", p4w_cols)]97    checkboxGroupInput("p4w_columns", "Select P4W variables to filter:", choices = p4w_cols)98  })99  100  # Generate Design Route checkbox101  output$design_route_checkbox <- renderUI({102    req(uploaded_data$main_survey)103    if ("Design_Route" %in% names(uploaded_data$main_survey)) {104      checkboxInput("design_route", "Filter Design Route = 1", value = TRUE)105    }106  })107  108  # Run analysis when button is clicked109  observeEvent(input$run_analysis, {110    req(uploaded_data$main_survey, uploaded_data$secondary_survey, uploaded_data$maxdiff_results)111    112    # Filter main survey data113    survey_data <- uploaded_data$main_survey %>% 114      filter(gc == "5")115    116    if (input$design_route && "Design_Route" %in% names(survey_data)) {117      survey_data <- survey_data %>% filter(Design_Route == "1")118    }119    120    # Merge data121    merged_data <- maxdiff_merger(uploaded_data$maxdiff_results, uploaded_data$secondary_survey, survey_data)122    123    # Apply filtering based on user selection124    if (input$filter_option == "P4W" && !is.null(input$p4w_columns)) {125      merged_data <- merged_data %>% 126        filter(across(all_of(input$p4w_columns), ~ .x == "1"))127      128      filter_description <- paste("P4W filtered by", paste(gsub("P4W_", "", input$p4w_columns), collapse = " and "))129    } else if (input$filter_option == "Personality") {130      personality_types <- c("1. Diligent Discoverer", "2. Moderate Sipper", "3. Sensible Culturalist",131                             "4. Loyal Traditionalist", "5. Cheerful Indulger", "6. Proud Partier",132                             "7. Trendsetting Socializer", "8. Fun Explorer")133      selected_types <- unlist(strsplit(input$personality_colors, ","))134      merged_data <- merged_data %>% 135        filter(Typing_Tool %in% personality_types[as.integer(selected_types)])136      137      color_map <- c("1,3" = "Orange", "2,4" = "Purple", "5,6" = "Green", "7,8" = "Blue")138      selected_colors <- color_map[input$personality_colors]139      filter_description <- paste("Personality filtered by", paste(selected_colors, collapse = " and "))140    } else {141      filter_description <- "Unfiltered"142    }143    144    # Calculate results145    results <- maxdiff_calc(merged_data)146    147    # Store results for download148    output$download_results <- downloadHandler(149      filename = function() {150        testing_variable <- tail(names(merged_data), n = 1)151        paste(testing_variable, "Interaction Score", filter_description, ".xlsx", sep = " ")152      },153      content = function(file) {154        write.xlsx(results, file = file, rowNames = TRUE)155      }156    )157    158    # Display results preview with row names159    output$results_preview <- renderTable({160      results_df <- results$`With Testing Variable calc`161      results_df <- cbind(row.names(results_df), results_df)162      colnames(results_df)[1] <- "Metric"163      results_df164    }, rownames = FALSE)165    166    output$status <- renderText("Analysis complete. You can now download the results.")167  })168  169  # Define maxdiff_merger function170  maxdiff_merger <- function(maxdiff_results, secondary_survey, survey_data) {171    data_frame_y <- select(secondary_survey, ResponseId, OriginalRID)172    173    col_index <- grep("^P4W", colnames(survey_data))174    col_names <- colnames(survey_data)[col_index]175    col_names <- col_names[!grepl("P4W_Beer_Drinker", col_names)]176    177    if (length(col_index) > 0) {178      typing_data <- select(survey_data, Typing_Tool, OriginalRID, col_names)179    } else {180      typing_data <- select(survey_data, Typing_Tool, OriginalRID)181    }182    183    data_frame_y <- merge(typing_data, data_frame_y, by = 'OriginalRID')184    data_frame_x <- merge(data_frame_y, maxdiff_results, by = 'ResponseId')185    186    return(data_frame_x)187  }188  189  # Define maxdiff_calc function190  maxdiff_calc <- function(filtered_output) {191    max_diff_data <- filtered_output192    testing_variable <- tail(names(max_diff_data), n = 1)193    194    col_index <- grep("^P4W", colnames(max_diff_data))195    col_names <- colnames(max_diff_data)[col_index]196    197    if (length(col_index) > 0) {198      max_diff_data_base <- select(max_diff_data, -all_of(testing_variable), -ResponseId, -Typing_Tool, -OriginalRID, -col_names)199    } else {200      max_diff_data_base <- select(max_diff_data, -all_of(testing_variable), -ResponseId, -Typing_Tool, -OriginalRID)201    }202    203    df2 <- max_diff_data_base * 0204    max_col <- apply(max_diff_data_base, 1, which.max)205    df2[cbind(1:nrow(max_diff_data_base), max_col)] <- 1206    207    x <- nrow(df2)208    total_count <- rep(x, ncol(df2))209    col_sum <- colSums(df2)210    base_percent <- col_sum/x211    212    results_df_base <- rbind(col_sum, total_count, base_percent)213    214    if (length(col_index) > 0) {215      max_diff_data_with_testing <- select(max_diff_data, -ResponseId, -Typing_Tool, -OriginalRID, -col_names)216    } else {217      max_diff_data_with_testing <- select(max_diff_data, -ResponseId, -Typing_Tool, -OriginalRID)218    }219    220    df3 <- max_diff_data_with_testing * 0221    max_col <- apply(max_diff_data_with_testing, 1, which.max)222    df3[cbind(1:nrow(max_diff_data_with_testing), max_col)] <- 1223    224    x <- nrow(df3)225    total_count <- rep(x, ncol(df3))226    col_sum <- colSums(df3)227    testing_percent <- col_sum/x228    base_percent_big <- c(base_percent, NA)229    testing_percent_small <- head(testing_percent, -1)230    change_percent <- (base_percent - testing_percent_small)231    average_change <- mean(change_percent)232    change_percent_big <- c(change_percent, average_change)233    interaction_score <- (change_percent / average_change)*100234    interaction_score <- c(interaction_score, NA)235    236    results_df_testing <- rbind(col_sum, total_count, testing_percent, base_percent_big, change_percent_big, interaction_score)237    results_df_testing <- as.data.frame(results_df_testing)238    239    dataset_names <- list('Individual Preference Share' = max_diff_data, 'Basemodel' = max_diff_data_base, 'BaseModel Results' = results_df_base, "With Testing Variable" = max_diff_data_with_testing, "With Testing Variable calc" = results_df_testing)240    241    return(dataset_names)242  }243}244 245# Run the Shiny app246shinyApp(ui = ui, server = server)247