如何在 R Shiny 和shinyjqui 中动态创建和保存用户定义的组合？

Question

这是我的拖放应用程序：

\n

library(shiny)\nlibrary(shinyjqui)\nlibrary(shinyjs)\nlibrary(dplyr)\n\n\n###### part 1 ------------------------------------------------------------------\n#creating the list of items\ndf <- structure(list(AG = c("A",  "B", "C", "D")),\n                row.names = c(NA,-4L), class = "data.frame")\n\n# cells of table\nconnections1 <- paste0("droppable_cell", ifelse(1:2 == 1, "", 1:2), "_1")\nconnections2 <- paste0("droppable_cell", ifelse(1:2 == 1, "", 1:2), "_2")\n\nconnections <- c(connections1, connections2)\n\n# Define a named list for vec_suggestion1 \nvec_suggestion1 <- list(  \n  droppable_cell_1 =   c("A", "B", "A", "B"),\n  droppable_cell_2 =  c("A", "B", "B", "A")\n)\n\n# Create the data frame\nmy_df <- data.frame(connections = connections,\n  stringsAsFactors = FALSE\n)\n\nmy_df$vec_suggestion1 <- vec_suggestion1[my_df$connections]\n\n\n###### part 2 ------------------------------------------------------------------\n\nmyComplexTableUI <-   div(id = "capture", class = "table-container",\n                          div(class = "grid-table",\n                              id = "montag",\n                              div(class = "grid-row",\n                                  div(class = "grid-cell grid-cell-text", "Montag"),\n                                  lapply(1:2, function(i) {\n                                    div(id = paste0("droppable_cell_", i), class = "grid-cell droppable-cell", "")\n                                  })\n                              )\n                          )\n                        \n                        )\n\n###### part 3 ------------------------------------------------------------------\n# my js\n\njsCode <- "\n$(function() {\n    function createSortable(day) {\n        $(\'[id^=droppable_cell\' + day + \'_]\').sortable({\n            connectWith: \'#A, #B, [id^=droppable_cell\' + day + \'_]\',\n            drop: function(event, ui) {\n                $(this).append(ui.draggable);\n            }\n        });\n    }\n\n    createSortable(\'1\'); // For day1\n    createSortable(\'2\'); // For day2\n\n  $(\'[id^=droppable_cell]\').on(\'sortupdate\', function(e, ui) {\n        var cellId = $(this).attr(\'id\');\n        var item = ui.item.text();\n        Shiny.setInputValue(\'dropEvent\', {cell: cellId, item: item}, {priority: \'event\'});\n    });\n});\n\nshinyjs.pageCol = function(params) {\n    $(\'[id^=droppable_cell]\').sortable({\n        connectWith: \'#A, #B, [id^=droppable_cell_1], [id^=droppable_cell_2]\',\n        drop: function(event, ui) {\n            $(this).append(ui.draggable);\n        }\n    });\n\n    var dataArray = Object.values(params[0]);\n    dataArray = dataArray[0].map((col, i) => dataArray.map(row => row[i]));\n\n    console.log(\'dataArray: \', dataArray);\n\n    var cacheA = $(\'#A\').html();\n    var cacheB = $(\'#B\').html();\n\n    var cacheGridCells1 = $(\'[id^=droppable_cell_1]\').html();\n\nshinyjs.setSuggestion = function (idxSuggestion) {\n  $.each(dataArray, function (index, value) {\n    var cellSelector = \'#\' + dataArray[index][0];\n    var classIndex = idxSuggestion === 1 ? 1 : 2;\n    \n    // Retrieve the items for the current cell from dataArray\n    var items = dataArray[index][idxSuggestion];\n    if (typeof items === \'string\') {\n      items = [items]; // Convert to array if there is only one item\n    }\n    \n    // Clear the cell content\n    $(cellSelector).html(\'\');\n    \n    // Append each item to the cell\n    $.each(items, function (i, item) {\n      if (item === null) {\n        return true;\n      }\n      \n      // Determine the style based on the item value\n      var itemStyle = \'\';\n      if (item === \'A\') {\n        itemStyle = \'background-color: #ffcc66;\'; // Corresponding to Bootstrap\'s warning color\n      } else if (item === \'B\') {\n        itemStyle = \'background-color: #5cb85c;\'; // Corresponding to Bootstrap\'s success color\n      }\n      \n      var cellHTML = \'<div data-value=\\"\' + item\n                   + \'\\" class=\\"btn btn-default ui-sortable-handle\\" style=\\"\' + itemStyle + \' margin: 1px;\\" jqui_sortable_idx=\\"letters__\' \n                   + (index + 1).toString()\n                   + \'\\">\'\n                   + item\n                   + \'</div>\';\n      \n      $(cellSelector).append(cellHTML);\n    });\n  });\n}\n    shinyjs.resetDnD = function (params) {\n    $(\'#A\').html(cacheA).sortable(\'refresh\');\n    $(\'#B\').html(cacheB).sortable(\'refresh\');\n    $(\'[id^=droppable_cell_1]\').html(cacheGridCells1).sortable(\'refresh\');\n    }\n};\n\n\n\n      "\nui <- fluidPage(\n  \n  useShinyjs(),\n  extendShinyjs(text = jsCode, functions = c("pageCol", "setSuggestion")),\n  \n  ###### part 4 ------------------------------------------------------------------\n  \n  # css table design\n  tags$head(\n    tags$style(\n      HTML("\n        .custom-title-panel button {\n          margin-left: 10px;\n          margin-top: 10px; \n        }\n        .grid-table {\n          width: 220px;\n          border-collapse: collapse;\n        }\n        .grid-cell {\n          width: 100%;\n          height: 210px;\n          border: 1px solid black;\n          background-color: white;\n          text-align: left;\n          margin: 0;\n          padding: 5px;\n        }\n        .grid-cell-text {\n          display: flex;\n          align-items: center;\n          justify-content: center;\n          height: 50px;\n          background-color: steelblue;\n          color: white;\n          font-size: 18px;\n        }\n        .table-container {\n          display: flex;\n          position: absolute;\n          left: 260px;\n          top: 20px;\n          margin-top: 0px;\n          overflow: hidden;\n        }\n      ")\n    )\n  ),\n  \n  ##################################################################################\n  \n  \n  # btn reset\n  tags$script(\n    HTML(\n      "$(document).ready(function() {\n          $(\'#btn_resetDnD\').click(function() {\n            $(\'.droppable-cell\').html(\'\'); // Remove content from all elements with the class \'droppable_cell\'\n          });\n        });"\n    )\n  ),\n\n  \n  # my items:      \n  tags$div(\n    style = "position: relative; height: 50px;", # Setting a height to contain the buttons\n    tags$div(style = "position: absolute; top: 30px; left: 20px;",\n             orderInput("A", "", items = df$AG[1], as_source = TRUE, connect = connections, width = "100%", item_class = "warning")\n    ),\n    tags$div(style = "position: absolute; top: 30px; left: 65px;",\n             orderInput("B", "", items = df$AG[2], as_source = TRUE, connect = connections, width = "100%", item_class = "success")\n    )\n  ),\n  \n  # my table:\n  myComplexTableUI,\n  \n  # my buttons:\n  tags$div(style = "position: absolute; top: 500px; left: 260px; display: flex; flex-direction: row;",\n           actionButton("btn_suggestion1", "Suggestion1"),\n           actionButton("btn_resetDnD", "Reset")\n           \n  )\n  )\n\n\nserver <- function(input, output, session) {\n  \n  shinyjs::js$pageCol(my_df)\n  \n  observeEvent(input$btn_suggestion1, {\n    shinyjs::disable("btn_suggestion1")\n    shinyjs::js$setSuggestion(1)\n    shinyjs::enable("btn_suggestion1")\n  })\n  \n}\n\nshinyApp(ui, server)\n

\n

该应用程序基本上执行以下操作： \n

\n

我想动态创建“vec_suggestion1”输入，该输入当前是硬编码的。我希望系统在将用户\xe2\x80\x99s 拖动到“droppable_cell1\”时识别并保存用户输入。

\n

vec_suggestion1 <- list(  \n  droppable_cell_1 =   c("A", "B", "A", "B"),\n  droppable_cell_2 =  c("A", "B", "B", "A")\n)\n

\n

我的目标是为用户提供拖放他们理想的 A 和 B 组合的能力。此信息应动态保存到“vec_suggestion2”。随后，A 和 B 的任何其他组合也应保存，但保存到“vec_suggestion3”、“vec_suggestion4”等。随着每个新向量的创建，应添加相应的新按钮，例如“btn_suggestion2”、“btn_suggestion3”等。

\n

Answer 1

以下方法删除了自定义 JS 并orderInput为每个单元格使用 JS，这简化了对列表的跟踪。现在，我放弃了item_class让事情变得简单的论点（我们可以处理div 列表，而jqui_sortable()不是保存样式）。然而，保存自定义组合的过程应该很清楚：

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%"
      )
    ),
    tags$div(
      style = "position: absolute; top: 30px; left: 65px;",
      orderInput(
        "B",
        "",
        items = df$AG[2],
        as_source = TRUE,
        connect = tableOrderInputIds,
        width = "100%"
      )
    )
  ),
  # 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]])
    })
  }, 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)