How to make updateOrderInput from shinyjqui to pass a list of item_classes

Issue

In the source code of the updateOrderInput() function from the shinyjqui package, it appears there's no support for passing a vector of item_classes.

This is a follow-up question to this.

The Code:

library(shiny)
library(shinyjqui)
library(dplyr)

df <-structure(list(AG = c("A",  "B", "C", "D")), row.names = c(NA, -4L), class = "data.frame")

# cells of table
tableOrderInputIds <- paste0("Montag", "_droppable_cell_", 1:2)

# Define a named list for vec_suggestion1
# should vec_suggestions be global? Shared across shiny sessions?
if (file.exists("vec_suggestions.RData")) {
  load(file = "vec_suggestions.RData")
} else {
  vec_suggestions <- list(
    vec_suggestion1 = list(
      Montag_droppable_cell_1 = c("A", "B", "A", "B"),
      Montag_droppable_cell_2 = c("A", "B", "B", "A")
    ),
    vec_suggestion2 = list(
      Montag_droppable_cell_1 = c("B", "B", "B", "B"),
      Montag_droppable_cell_2 = c("A", "A", "A", "A")
    )
  )
}

###### part 2 ------------------------------------------------------------------

myComplexTableUI <- div(id = "capture",
                        class = "table-container",
                        div(
                          class = "grid-table",
                          id = "montag",
                          div(
                            class = "grid-row",
                            div(class = "grid-cell grid-cell-text", "Montag"),
                            lapply(tableOrderInputIds, function(x) {
                              div(
                                orderInput(
                                  inputId = x,
                                  label = NULL,
                                  items = NULL,
                                  connect = tableOrderInputIds,
                                  width = "100%",
                                  style = "min-height: 200px;"
                                ),
                                class = "grid-cell"
                              )
                            })
                          )
                        ))

ui <- fluidPage(
  # css table design
  tags$head(tags$style(
    HTML(
      "
        .custom-title-panel button {
          margin-left: 10px;
          margin-top: 10px;
        }
        .grid-table {
          width: 220px;
          border-collapse: collapse;
        }
        .grid-cell {
          width: 100%;
          height: 210px;
          border: 1px solid black;
          background-color: white;
          text-align: left;
          margin: 0;
          padding: 5px;
        }
        .grid-cell-text {
          display: flex;
          align-items: center;
          justify-content: center;
          height: 50px;
          background-color: steelblue;
          color: white;
          font-size: 18px;
        }
        .table-container {
          display: flex;
          position: absolute;
          left: 260px;
          top: 20px;
          margin-top: 0px;
          overflow: hidden;
        }
      "
    )
  )),
  # my items:
  tags$div(
    style = "position: relative; height: 50px;",
    # Setting a height to contain the buttons
    tags$div(
      style = "position: absolute; top: 30px; left: 20px;",
      orderInput(
        "A",
        "",
        items = df$AG[1],
        as_source = TRUE,
        connect = tableOrderInputIds,
        width = "100%", 
        item_class = "success"
      )
    ),
    tags$div(
      style = "position: absolute; top: 30px; left: 65px;",
      orderInput(
        "B",
        "",
        items = df$AG[2],
        as_source = TRUE,
        connect = tableOrderInputIds,
        width = "100%",
        item_class = "warning"
      )
    )
  ),
  # my table:
  myComplexTableUI,
  # my buttons:
  column(
    12,
    selectizeInput(
      "select_suggestion",
      "Select / Add suggestion",
      choices = names(vec_suggestions),
      multiple = FALSE,
      options = list('create' = TRUE,
                     'persist' = FALSE)
    ),
    actionButton("load_suggestion", "Load suggestion"),
    actionButton("btn_resetDnD", "Reset"),
    actionButton("save_suggestion", "Save suggestion"),
    style = "position: absolute; top: 500px; left: 20px;"
  )
)

server <- function(input, output, session) {
  # user_suggestion <- reactiveValues(droppable_cell_1 = NULL, droppable_cell_2 = NULL)
  user_suggestion <- do.call(shiny::reactiveValues, setNames(vector(mode = "list", length = length(tableOrderInputIds)), tableOrderInputIds))
  
  observeEvent(input$load_suggestion, {
    lapply(tableOrderInputIds, function(x) {
      updateOrderInput(
        session, 
        inputId = x, 
        items = vec_suggestions[[input$select_suggestion]][[x]],
        item_class = "warning" 
      )
    })
  }, ignoreNULL = FALSE)
  
  
  observeEvent(input$save_suggestion, {
    # should vec_suggestions be global? Shared across shiny sessions?
    vec_suggestions <<- modifyList(vec_suggestions, setNames(list(reactiveValuesToList(user_suggestion)), input$select_suggestion))
    save(vec_suggestions, file = "vec_suggestions.RData")
    showNotification("Saved suggestions to disk.")
  })
  
  observeEvent(input$btn_resetDnD, {
    lapply(tableOrderInputIds, function(x) {
      updateOrderInput(session, inputId = x, items = list())
    })
  })
  
  observe({
    lapply(tableOrderInputIds, function(x) {
      user_suggestion[[x]] <- input[[x]]
    })
  })
}

shinyApp(ui, server)

The question:

Is it possible to pass a list of classes in this part of the code:

  observeEvent(input$load_suggestion, {
    lapply(tableOrderInputIds, function(x) {
      updateOrderInput(
        session, 
        inputId = x, 
        items = vec_suggestions[[input$select_suggestion]][[x]],
        item_class = "warning" 
      )
    })
  }, ignoreNULL = FALSE)

Something like:

item_class = c("success", "warning")

The primary goal is to display the appropriate colors after clicking "Load suggestion":

Clicking the "Load" button results in:

The issue is that A isn't color-coded correctly. It should be green!

Solution

Edit: the dev version of {shinyjqui} by now supports passing a list of item classes to updateOrderInput().

---

Below please find a workaround using a custom JS function to restyle the buttons. It is not ideal though, as the timing isn't perfect. Maybe you should switch from orderInput to jqui_sortable as suggested here.

library(shiny)
library(shinyjqui)
library(dplyr)

df <- structure(list(AG = c("A",  "B", "C", "D")), row.names = c(NA, -4L), class = "data.frame")

# cells of table
tableOrderInputIds <- paste0("Montag", "_droppable_cell_", 1:2)

# Define a named list for vec_suggestion1
# should vec_suggestions be global? Shared across shiny sessions?
if (file.exists("vec_suggestions.RData")) {
  load(file = "vec_suggestions.RData")
} else {
  vec_suggestions <- list(
    vec_suggestion1 = list(
      Montag_droppable_cell_1 = c("A", "B", "A", "B"),
      Montag_droppable_cell_2 = c("A", "B", "B", "A")
    ),
    vec_suggestion2 = list(
      Montag_droppable_cell_1 = c("B", "B", "B", "B"),
      Montag_droppable_cell_2 = c("A", "A", "A", "A")
    )
  )
}

###### part 2 ------------------------------------------------------------------

myComplexTableUI <- div(id = "capture",
                        class = "table-container",
                        div(
                          class = "grid-table",
                          id = "montag",
                          div(
                            class = "grid-row",
                            div(class = "grid-cell grid-cell-text", "Montag"),
                            lapply(tableOrderInputIds, function(x) {
                              div(
                                orderInput(
                                  inputId = x,
                                  label = NULL,
                                  items = NULL,
                                  connect = tableOrderInputIds,
                                  width = "100%",
                                  style = "min-height: 200px;"
                                ),
                                class = "grid-cell"
                              )
                            })
                          )
                        ))

ui <- fluidPage(
  tags$script(HTML(
    sprintf("
    $(document).on('shiny:inputchanged', function(event) {
      // if (event.name === 'load_suggestion') { // not working - triggered before new elements are rendered
      if (%s) {
            var list = document.getElementById('capture').getElementsByClassName('btn ui-sortable-handle');
            for (let item of list) {
                var value = item.getAttribute('data-value');
                if (value === 'A') {
                  item.classList.remove('btn-default');
                  item.classList.add('btn-success');
                }
                if (value === 'B') {
                  item.classList.remove('btn-default');
                  item.classList.add('btn-warning');
                }
            }
      }
    });
    ", paste0("[", toString((sQuote(tableOrderInputIds, q = FALSE))), "].includes(event.name)"))
  ),
  # css table design
  tags$head(tags$style(
    HTML(
      "
        .custom-title-panel button {
          margin-left: 10px;
          margin-top: 10px;
        }
        .grid-table {
          width: 220px;
          border-collapse: collapse;
        }
        .grid-cell {
          width: 100%;
          height: 210px;
          border: 1px solid black;
          background-color: white;
          text-align: left;
          margin: 0;
          padding: 5px;
        }
        .grid-cell-text {
          display: flex;
          align-items: center;
          justify-content: center;
          height: 50px;
          background-color: steelblue;
          color: white;
          font-size: 18px;
        }
        .table-container {
          display: flex;
          position: absolute;
          left: 260px;
          top: 20px;
          margin-top: 0px;
          overflow: hidden;
        }
        [data-value='A'] {
        /* Attribute has this exact value */
        }
      "
    )
  ))),

  # my items:
  tags$div(
    style = "position: relative; height: 50px;",
    # Setting a height to contain the buttons
    tags$div(
      style = "position: absolute; top: 30px; left: 20px;",
      orderInput(
        "A",
        "",
        items = df$AG[1],
        as_source = TRUE,
        connect = tableOrderInputIds,
        width = "100%", 
        item_class = "success"
      )
    ),
    tags$div(
      style = "position: absolute; top: 30px; left: 65px;",
      orderInput(
        "B",
        "",
        items = df$AG[2],
        as_source = TRUE,
        connect = tableOrderInputIds,
        width = "100%",
        item_class = "warning"
      )
    )
  ),
  # my table:
  myComplexTableUI,
  # my buttons:
  column(
    12,
    selectizeInput(
      "select_suggestion",
      "Select / Add suggestion",
      choices = names(vec_suggestions),
      multiple = FALSE,
      options = list('create' = TRUE,
                     'persist' = FALSE)
    ),
    actionButton("load_suggestion", "Load suggestion"),
    actionButton("btn_resetDnD", "Reset"),
    actionButton("save_suggestion", "Save suggestion"),
    style = "position: absolute; top: 500px; left: 20px;"
  )
)

server <- function(input, output, session) {
  # user_suggestion <- reactiveValues(droppable_cell_1 = NULL, droppable_cell_2 = NULL)
  user_suggestion <- do.call(shiny::reactiveValues, setNames(vector(mode = "list", length = length(tableOrderInputIds)), tableOrderInputIds))
  
  observeEvent(input$load_suggestion, {
    lapply(tableOrderInputIds, function(x) {
      updateOrderInput(
        session, 
        inputId = x, 
        items = vec_suggestions[[input$select_suggestion]][[x]],
        item_class = "default" 
      )
    })
  }, ignoreNULL = FALSE)
  
  
  observeEvent(input$save_suggestion, {
    # should vec_suggestions be global? Shared across shiny sessions?
    vec_suggestions <<- modifyList(vec_suggestions, setNames(list(reactiveValuesToList(user_suggestion)), input$select_suggestion))
    save(vec_suggestions, file = "vec_suggestions.RData")
    showNotification("Saved suggestions to disk.")
  })
  
  observeEvent(input$btn_resetDnD, {
    lapply(tableOrderInputIds, function(x) {
      updateOrderInput(session, inputId = x, items = list())
    })
  })
  
  observe({
    lapply(tableOrderInputIds, function(x) {
      user_suggestion[[x]] <- input[[x]]
    })
  })
}

shinyApp(ui, server)

Answered By - ismirsehregal