Search code examples
htmlcssrshinyshinyjqui

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


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":

enter image description here

Clicking the "Load" button results in:

enter image description here

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)