Seriation via Correspondence Analysis Shinylive App

app.R

library(shiny)
library(bslib)
library(readxl)
library(FactoMineR)
library(factoextra)
library(DT)
library(dplyr)
library(data.table)

ui <- page_sidebar(
  title = "Seriation via Correspondence Analysis",
  sidebar = sidebar(
    fileInput("file", "Upload CSV/Excel file",
              accept = c(".csv", ".xls", ".xlsx")),
    actionButton("load_example", "Load Example Data", class = "btn-secondary"),
    checkboxInput("transpose", "Flip rows/columns", FALSE),
    checkboxInput("flip_x", "Flip x-axis", FALSE),
    checkboxInput("show_labels", "Show point labels", TRUE),
    
    # About button
    hr(),
    actionButton("show_about", "About", class = "btn-primary")
  ),
  
  navset_card_tab(
    nav_panel(
      title = "CA Plots",
      layout_columns(
        col_widths = c(6, 6),
        card(
          card_header(
            "CA Factor Map - Columns",
            actionButton("open_cols", icon("up-right-from-square"), 
                        class = "btn-link btn-sm float-end",
                        title = "Open in new window")
          ),
          plotOutput("ca_plot_vars", height = "400px",
                    click = clickOpts(id = "plot_vars_click"))
        ),
        card(
          card_header(
            "CA Factor Map - Rows",
            actionButton("open_rows", icon("up-right-from-square"), 
                        class = "btn-link btn-sm float-end",
                        title = "Open in new window")
          ),
          plotOutput("ca_plot_obs", height = "400px",
                    click = clickOpts(id = "plot_obs_click"))
        )
      ),
      card(
        class = "mt-3",
        card_header(
          "CA Biplot",
          actionButton("open_biplot", icon("up-right-from-square"), 
                      class = "btn-link btn-sm float-end",
                      title = "Open in new window")
        ),
        plotOutput("ca_biplot", height = "600px",
                  click = clickOpts(id = "biplot_click"))
      )
    ),
    
    nav_panel(
      title = "Sorted Matrix",
      card(
        card_header("Sorted Matrix"),
        DT::dataTableOutput("sorted_table", height = "800px")
      )
    )
  )
)

server <- function(input, output) {
  
  # Example dataset
  example_data <- structure(list(
    motif = c("beaker", "blackrim", "bottle", "flatpot", "handle", "pointed", "spirals"),
    `3` = c(0, 1, 1, 0, 1, 0, 0),
    `6` = c(0, 0, 0, 1, 0, 1, 0),
    `7` = c(0, 0, 0, 0, 0, 1, 0),
    `5` = c(0, 0, 0, 1, 1, 1, 1),
    `2` = c(1, 1, 1, 0, 0, 0, 0),
    `1` = c(1, 1, 0, 0, 0, 0, 0),
    `4` = c(0, 0, 0, 0, 1, 0, 1)
  ), class = "data.frame", row.names = c(NA, 7L))

  # Current data source
  data_source <- reactiveVal(NULL)

  # Observer for example data button
  observeEvent(input$load_example, {
    if (!is.null(input$file)) {
      showModal(modalDialog(
        title = "Confirm Data Replacement",
        "This will replace your currently uploaded data with the example dataset. Do you want to proceed?",
        footer = tagList(
          modalButton("Cancel"),
          actionButton("confirm_example", "OK", class = "btn-primary")
        )
      ))
    } else {
      data_source(example_data)
    }
  })

  # Observer for confirmation
  observeEvent(input$confirm_example, {
    data_source(example_data)
    removeModal()
  })
  
  # About modal
  observeEvent(input$show_about, {
    showModal(modalDialog(
      title = "About",
      div(
        div(
          "Created by Staffan Betn\u00E9r ",
          tags$a(href = "mailto:[email protected]", 
                 icon("envelope"),
                 title = "[email protected]",
                 style = "margin-left: 5px;")
        ),
        tags$br(),
        "Feature requests are welcome via email.",
        tags$br(),
        "Source code available ",
        tags$a(href = "https://gist.github.com/StaffanBetner/597eadb6d0c6976cd8399f18fe460ee8",
               "here",
               target = "_blank"),
        tags$br(),
        "Created at the suggestion of Martin Rundkvist."
      ),
      easyClose = TRUE,
      footer = modalButton("Close")
    ))
  })
  
  # Read the raw file data and process for CA
  data <- reactive({
    if (!is.null(input$file)) {
      ext <- tools::file_ext(input$file$name)
      
      if (ext == "csv") {
        df <- as.data.frame(fread(input$file$datapath))
      } else {
        df <- as.data.frame(read_excel(input$file$datapath))
      }
      
      # If first column is character, use as row names
      if (is.character(df[[1]])) {
        rnames <- df[[1]]
        df <- as.data.frame(df[-1])
        rownames(df) <- rnames
      }
    } else if (!is.null(data_source())) {
      df <- data_source()
      if (is.character(df[[1]])) {
        rnames <- df[[1]]
        df <- as.data.frame(df[-1])
        rownames(df) <- rnames
      }
    } else {
      return(NULL)
    }
    
    # Transpose if requested
    if (input$transpose) {
      df <- as.data.frame(t(as.matrix(df)))
    }
    df <- as.table(as.matrix(df))
    
    return(df)
  })
  
  # Perform CA
  ca_result <- reactive({
    req(data())
    CA(data(), graph = FALSE)
  })
  
  # Function to reverse x-axis if needed
  reverse_x_if_needed <- function(p) {
    if(input$flip_x) {
      p + scale_x_continuous(trans = "reverse") + coord_fixed()
    } else {
      p + coord_fixed()
    }
  }
  
  # Function to create column plot
  make_col_plot <- function() {
    p <- fviz_ca_col(ca_result(),
                     repel = TRUE,
                     geom = if(input$show_labels) c("point", "text") else "point",
                     title = if(input$transpose) "Row Points" else "Column Points")
    reverse_x_if_needed(p)
  }
  
  # Function to create row plot
  make_row_plot <- function() {
    p <- fviz_ca_row(ca_result(),
                     repel = TRUE,
                     geom = if(input$show_labels) c("point", "text") else "point",
                     title = if(input$transpose) "Column Points" else "Row Points")
    reverse_x_if_needed(p)
  }
  
  # Function to create biplot
  make_biplot <- function() {
    p <- fviz_ca_biplot(ca_result(),
                        repel = TRUE,
                        geom = if(input$show_labels) c("point", "text") else "point",
                        title = "CA Biplot")
    reverse_x_if_needed(p)
  }
  
  # Function to show modal
  show_modal_plot <- function(title, plot_output_id, height = "80vh") {
    showModal(modalDialog(
      title = title,
      size = "l",
      easyClose = TRUE,
      footer = modalButton("Close"),
      tags$div(
        style = "width: 100%; max-width: 1200px; margin: 0 auto;",
        plotOutput(plot_output_id, 
                  height = height,
                  width = "100%")
      ),
      style = "padding: 20px;"
    ))
  }
  
  # CA plot for variables
  output$ca_plot_vars <- renderPlot({
    req(ca_result())
    make_col_plot()
  })
  
  # CA plot for observations
  output$ca_plot_obs <- renderPlot({
    req(ca_result())
    make_row_plot()
  })
  
  # CA biplot
  output$ca_biplot <- renderPlot({
    req(ca_result())
    make_biplot()
  })
  
  # Modal observers for plots
  observeEvent(input$open_cols, {
    show_modal_plot("CA Factor Map - Columns", "modal_cols_plot")
  })
  
  observeEvent(input$plot_vars_click, {
    show_modal_plot("CA Factor Map - Columns", "modal_cols_plot")
  })
  
  output$modal_cols_plot <- renderPlot({
    req(ca_result())
    make_col_plot()
  })
  
  observeEvent(input$open_rows, {
    show_modal_plot("CA Factor Map - Rows", "modal_rows_plot")
  })
  
  observeEvent(input$plot_obs_click, {
    show_modal_plot("CA Factor Map - Rows", "modal_rows_plot")
  })
  
  output$modal_rows_plot <- renderPlot({
    req(ca_result())
    make_row_plot()
  })
  
  observeEvent(input$open_biplot, {
    show_modal_plot("CA Biplot", "modal_biplot_plot", "90vh")
  })
  
  observeEvent(input$biplot_click, {
    show_modal_plot("CA Biplot", "modal_biplot_plot", "90vh")
  })
  
  output$modal_biplot_plot <- renderPlot({
    req(ca_result())
    make_biplot()
  })
  
  # Get sorted data
  sorted_data <- reactive({
    req(ca_result())
    
    # Get coordinates
    row_coords <- ca_result()$row$coord[,1]
    col_coords <- ca_result()$col$coord[,1]
    
    # Sort data by first dimension coordinates
    if(input$flip_x) {
      sorted <- data()[order(-row_coords), order(-col_coords)]
    } else {
      sorted <- data()[order(row_coords), order(col_coords)]
    }
    
    # Add row names as first column
    sorted <- cbind(Row_Names = rownames(sorted), sorted)
    
    return(sorted)
  })
  
  # Sorted incidence matrix
  output$sorted_table <- DT::renderDataTable({
    req(sorted_data())
    DT::datatable(sorted_data(), 
                  extensions = 'Buttons',
                  options = list(
                    scrollX = TRUE,
                    dom = 'Bfrtip',
                    buttons = c('copy', 'csv', 'excel'),
                    pageLength = -1,  # Show all rows
                    scrollY = "700px"
                  ),
                  caption = "Matrix sorted by first CA dimension",
                  rownames = FALSE)
  })
}

shinyApp(ui, server)

Available here:
https://shinylive.io/r/app/#gist=597eadb6d0c6976cd8399f18fe460ee8