CODEWITHSUNDEEP
shinyselectize.js
Jeff
Jeff

Reputation: 724

Dynamically reorder options in selectizeInput so that most recently choise is at the top

I have an Rshiny app where users can select from a list of items to view. The list is usually very long (>10,000). Most users would want to look back and forth between a select sample of these options, so I would like to rearrange the order dynamically so that whenever an option is chosen, it is placed at the top of the list for them.

Googling "dynamically order selectInput Rshiny" only shows results for changing the options themselves and not simply reordering them.

Here is toy code that emulates my issue as best as possible:

  library(shiny)
  library(shinyjs) # runjs
  library(jsonlite) # For bolding the features
  
  # ui ----
  ui <- 
  shinyUI(
    fluidPage(
      tags$head(tags$style(HTML(".diff {font-weight: bold;} .notdiff {font-weight: normal;}"))), # make .diff do something
      sidebarLayout(
        sidebarPanel(
          useShinyjs(),
          fluidRow(column(9, fileInput('diff', 'Choose File',
                                        accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))),
                  actionButton("load_button", "Load", width = "100%")),
          selectizeInput('feature',
                   "Feature",
                   choices = NA),
          textOutput(outputId = "debug")
        ), # Sidebarpanel
        mainPanel()
      ) # sidebarlayout
    ) # FluidPage
  ) # ShinyUI
  
  # highlight function ----
  dropdown_highlight =
    "{
    item: function(item, escape) {
      var diffText = %s;
      var embolden = diffText[item.label];
      return '<div class=\"' + embolden + '\">' + item.label + '</div>';
    },
      option: function(item, escape) {
        var diffText = %s;
        var embolden = diffText[item.label];
        return '<div class=\"' + embolden + '\">' + item.label + '</div>';
    }
  }"
  
  # Server ----
  server <- shinyServer(function(input, output, session) {
    data <- reactiveValues()
    observeEvent(input$load_button, {
      data$diff = read.table(input$diff$datapath, sep = '\t', header = T)
      output$debug = renderText(data$diff$words)
    })
    
    observeEvent(data$diff, {
      freezeReactiveValue(input, "feature")
      ord = order(data$diff$order)
      # This section handles bolding features in the dropdown
      features = data$diff$words[ord]
      diffText = ifelse(features=="hello", "diff", "notdiff")
      names(diffText) = features
      diffText = toJSON(as.list(diffText))

      updateSelectizeInput(session, "feature", choices = features, selected = features[1],
                           options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
    })
    
    observeEvent(input$feature, {
      #freezeReactiveValue(input, "feature")
      # What do I put here? My initial thought was something along the lines of:
      # features = input$features$CHOICES # This variable doesn't exist as far as I know...
      # features = c(input$feature, features[-which(features==input$feature)])
      #updateSelectizeInput(session, "feature", choices = features)
      
    })
  })
  
  shinyApp(ui, server)

Toy dataset, picasso.tsv:

words   order
hello   1
salud   3
its 2
me  0
your    5
duke    4

To simplify my question, I want the most recently chosen options to be at the top of the list in my dropdown.

EDIT:

I tried tackling this again myself. Here is where I've gotten:

orderedFeatures <- reactiveValues()
observeEvent(data$diff, {
  freezeReactiveValue(input, "feature")
  ord = order(data$diff$order)
  # This section handles bolding features in the dropdown
  orderedFeatures$feat = data$diff$words[ord]
  diffText = ifelse(orderedFeatures$feat=="hello", "diff", "notdiff")
  names(diffText) = orderedFeatures$feat
  diffText = toJSON(as.list(diffText))

  updateSelectizeInput(session, "feature", choices = orderedFeatures$feat, selected = orderedFeatures$feat[1],
                       options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
})

orderedFeatures$feat <- reactive({
  cat("decrease")
  input$feature
  return(rev(orderedFeatures$feat))
})

observeEvent(orderedFeatures$feat, ignoreInit = T, handlerExpr = {
  cat(orderedFeatures$feat)
  req(input$feature)
  freezeReactiveValue(input, "feature")
  diffText = ifelse(orderedFeatures$feat=="hello", "diff", "notdiff")
  names(diffText) = orderedFeatures$feat
  diffText = toJSON(as.list(diffText))
  updateSelectizeInput(session, "feature", choices = orderedFeatures$feat,
                       options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
})

My approach was to make a global variable to store the order of the features called orderedFeatures. When a file is uploaded, it is updated. The reactive call is supposed to happen whenever the "input$feature" changes, but when looking at the reactlog, it just can't seem to invalidate the reactive to recompute. As a simple example, I just want the order of features to change so I'm using rev. The last observeEvent is supposed to trigger when orderedFeatures$feat changes, but not on startup so that it doesn't crash.

This stretch of code fails to reorder the dropdown menu, but doesn't break anything. My next step would be to use a dynamic approach--just make a new dropdown each time with uiOutput.

EDIT2:

I have made it do a thing! The below code performs a rearrangement of the items in the dropdown menu, but it is an infinite loop and I would like the code to run just once each time input$feature is adjusted. I assume there is a circular dependence that I am somehow not preventing here. Please help. Thank you.

orderedFeatures <- reactiveValues()
observeEvent(data$diff, {
  freezeReactiveValue(input, "feature")
  ord = order(data$diff$order)
  # This section handles bolding features in the dropdown
  orderedFeatures$feat = data$diff$words[ord]
  diffText = ifelse(orderedFeatures$feat=="hello", "diff", "notdiff")
  names(diffText) = orderedFeatures$feat
  diffText = toJSON(as.list(diffText))

  updateSelectizeInput(session, "feature", choices = orderedFeatures$feat, selected = orderedFeatures$feat[1],
                       options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
})
observeEvent(input$feature, ignoreInit = T, ignoreNULL = T, handlerExpr = {
  freezeReactiveValue(input, "feature")
  cat(orderedFeatures$feat, sep = ' ')
  orderedFeatures$feat <- isolate(rev(orderedFeatures$feat))
  diffText = ifelse(orderedFeatures$feat=="a", "diff", "notdiff")
  names(diffText) = orderedFeatures$feat
  diffText = toJSON(as.list(diffText))
  updateSelectizeInput(session, "feature", choices = orderedFeatures$feat, selected = isolate(input$feature),
                       options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
  cat(orderedFeatures$feat, sep = ' ')
})

Final Edit (probably):

Thanks to Nir Graham for his beautiful code. Thanks to his example, I have relearned some useful concepts for shiny. For completion, here is my final toy example that I will adapt back to my app:

  library(shiny)
  library(shinyjs) # runjs
  library(jsonlite) # For bolding the features
  
  # ui ----
  ui <- 
  shinyUI(
    fluidPage(
      tags$head(tags$style(HTML(".diff {font-weight: bold;} .notdiff {font-weight: normal;}"))), # make .diff do something
      sidebarLayout(
        sidebarPanel(
          useShinyjs(),
          fluidRow(column(9, fileInput('diff', 'Choose File',
                                        accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))),
                  actionButton("load_button", "Load", width = "100%")),
          selectizeInput('feature',
                   "Feature",
                   choices = NA),
          textOutput(outputId = "debug")
        ), # Sidebarpanel
        mainPanel()
      ) # sidebarlayout
    ) # FluidPage
  ) # ShinyUI
  
  # highlight function ----
  dropdown_highlight =
    "{
    item: function(item, escape) {
      var diffText = %s;
      var embolden = diffText[item.label];
      return '<div class=\"' + embolden + '\">' + item.label + '</div>';
    },
      option: function(item, escape) {
        var diffText = %s;
        var embolden = diffText[item.label];
        return '<div class=\"' + embolden + '\">' + item.label + '</div>';
    }
  }"
  
  # Server ----
  server <- shinyServer(function(input, output, session) {

    data <- reactiveValues()
    observeEvent(input$load_button, {
      data$diff = read.table(input$diff$datapath, sep = '\t', header = T)
    })

    orderedFeatures <- reactiveVal(NULL)
    observeEvent(data$diff, {
      ord = order(data$diff$order)
      orderedFeatures(data$diff$words[ord])
    })

    observeEvent(orderedFeatures(), {
      freezeReactiveValue(input, "feature")
      diffText = ifelse(orderedFeatures()=="hello", "diff", "notdiff")
      names(diffText) = orderedFeatures()
      diffText = toJSON(as.list(diffText))
      updateSelectizeInput(session, "feature", choices = orderedFeatures(),
                           options = list(render = I(sprintf(dropdown_highlight, diffText, diffText))))
    })

    observeEvent(input$feature, {
      req(input$feature %in% orderedFeatures())
      originalOrderedFeatures <- orderedFeatures()
      newOrderedFeatures <- c(input$feature, setdiff(originalOrderedFeatures, input$feature))
      orderedFeatures(newOrderedFeatures)
    })
  })
  shinyApp(ui, server)

Actual Final Edit: Needed to add a minor bug fix to the final, correct code.

Upvotes: 0

Views: 209

Answers (1)

Nir Graham
Nir Graham

Reputation: 5167

library(shiny)

ui <- fluidPage(
  actionButton("load", "load a dataset"),
  selectInput("mysel", "Choose", choices = NULL)
)

server <- function(input, output, session) {
  orderedFeatures <- reactiveVal(NULL)

  mydata <- eventReactive(input$load, {
    mtcars
  })

  observeEvent(
    mydata(),
    orderedFeatures(unique(rownames(mtcars)))
  )

  observeEvent(orderedFeatures(), {
    updateSelectInput(
      inputId = "mysel",
      choices = orderedFeatures()
    )
  })
  observeEvent(input$mysel, {
    original_orderedFeatures <- orderedFeatures()
    new <- c(input$mysel, setdiff(original_orderedFeatures, input$mysel))
    orderedFeatures(new)
  })
}

shinyApp(ui, server)

Upvotes: 2

Related Questions