Item ranking app for multiple raters using rank-ordered logit models

app.R

library(shiny)
library(shinythemes)
library(rhandsontable)
library(shinyalert)
library(PlackettLuce)

selopts <- list(
  plugins = list("remove_button"),
  create = TRUE,
  persist = TRUE
)

ui <- fluidPage(
  theme = shinytheme("simplex"),
  titlePanel("Item ranking app"),
  verticalLayout(
    selectizeInput("items", choices = c(), label = "Item names",  multiple = TRUE, options = selopts),
    selectizeInput("raters", choices = c(), label = "Rater names", multiple = TRUE, options = selopts),
    p(strong("Ranking table")),
    p("Enter item ranking for each rater below. 0 means unranked."),
    rHandsontableOutput(outputId = "tab"),
    br(),
    actionButton("compute", label = "Compute rankings"),
    br(),
    p(strong("Ranking of items:")),
    tableOutput("rank"),
    br(),
    p(strong("Relative worth plot:")),
    plotOutput("plot", width = "600px")
  )
)

server <- function(input, output) {
  df <- reactive({
    N <- length(input$raters)
    P <- length(input$items)
    mat <- matrix(0L, nrow = N, ncol = P)
    colnames(mat) <- input$items
    rownames(mat) <- input$raters
    if (!is.null(input$tab)) {
      vals <- hot_to_r(input$tab) |> as.matrix()
      if (length(vals) > 0L) {
        Nv <- min(N, nrow(vals))
        Pv <- min(P, ncol(vals))
        mat[1:Nv, 1:Pv] <- vals[1:Nv, 1:Pv]
      }
    }
    as.data.frame(mat)
  })
  
  
  output$tab <- renderRHandsontable(
    {
      P <- length(input$items)
      if (P == 0L) return(NULL)
      df() |> 
        rhandsontable(useTypes = TRUE) |> 
        hot_validate_numeric(cols = 1:P, min = 0, max = P, allowInvalid = FALSE) |> 
        hot_table(licenseKey = "non-commercial-and-evaluation")
    }
  )
  
  observeEvent(input$compute, {
    tab <- hot_to_r(input$tab)
    fit <- tryCatch(PlackettLuce(as.rankings(tab)), error = \(e) {
      shinyalert(
        title = "Model fitting failed", 
        text = "Please check your input data.", 
        type = "error", 
        showConfirmButton = FALSE, 
        timer = 1200
      )
      return()
    })
    if (is.null(fit)) return()
    pars <- itempar(fit)
    sortpars <- sort(pars, decreasing = TRUE)
    output$rank <- renderTable(data.frame(item = names(sortpars), score = sortpars), striped = TRUE)
    output$plot <- renderPlot(
      expr = tryCatch(plot(qvcalc(pars)), error = \(e) plot(pars)),
      bg = "transparent"
    )
  })

}

shinyApp(ui = ui, server = server)

install_and_run.R

install.packages(c("shiny", "shinythemes", "rhandsontable", "shinyalert", "PlackettLuce"))
shiny::runGist("https://gist.github.com/vankesteren/166c4d194817dd471a3f59ae7104a38d")