Shiny: Как принять «реактивный ввод», сгенерированный из renderUI, как ввод в функцию? - PullRequest
Новая
       12

Shiny: Как принять «реактивный ввод», сгенерированный из renderUI, как ввод в функцию?

0 голосов
/ 29 марта 2019

Введение

Я делаю блестящее приложение (панель инструментов) для какой-то работы. У меня есть фрейм данных имен (сгенерированный из внешнего файла Excel, который может быть расширен, таким образом, требуется реактивность), который должен генерировать collapsePanel (из bsCollapse) для каждого имени в вышеупомянутом списке. Это уже реализовано и работает с использованием renderUI на сервере; тем не менее, теперь я действительно хочу изменить входные данные, включенные в collapsePanel: у меня есть несколько входов на панели, но самый важный, который я покажу в этом примере, это группа флажков. Моя проблема возникает, когда я хочу использовать входные данные группы флажков в функции (например, для сохранения новой информации).

Минимальный рабочий пример 

if (!require("pacman")) install.packages("pacman")

pacman::p_load(tidyverse, shiny, shinythemes, sweetalertR, shinyWidgets, 
shinycssloaders, shinyBS, shinyjs, shinydashboard, rlist, readxl)

list_of_names <- tibble("Name" = c("Name1", "Name2", "Name3"), 
    "0 pt" = c("Criteria 0 name1", "Criteria 0 name2", "Criteria 0 name3"), 
    "1 pt" = c("Criteria 1 name1", "Criteria 1 name2", "Criteria 1 name3"), 
    "2 pt" = c("Criteria 2 name1", "Criteria 2 name2", "Criteria 2 name3"))

t <- c()
for (i in list_of_names$Name) {
    t <- c(t, paste0("input$", i, "_id"))
}

mycollapse <- lapply(1:nrow(list_of_names), function(i) {
    bsCollapsePanel(paste0(list_of_names$Name[i]),
    awesomeCheckboxGroup(inputId = paste0(list_of_names$Name[i], "_id"),label = NULL,
    choices = as.character(list_of_names[i,2:4]),
    status = "success", width = "75%"))
})
mycollapse[["id"]] <- "collapseID"
mycollapse[["multiple"]] <- FALSE
mycollapse[["open"]] <- "Name1"

#### UI ----------

ui <- dashboardPage(
  dashboardHeader(title = "Minimal Example"),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Dashboard", tabName = "Dashboard", icon = icon("dashboard"), 
               selected = TRUE))),   
  dashboardBody(
      fluidPage(
          column(6, shinyjs::useShinyjs(), withSpinner(uiOutput("Data"))))))

server <- function(input, output, session) {
    output$Data <- renderUI({
        tagList(
            do.call(bsCollapse, args = mycollapse) %>% return(),
            actionButton("Save", "Save"))
    })

    observeEvent(input$Save, {
        confirmSweetAlert(session, inputId = "Save_SWAL", title = 
        "Save?", text = "Are you sure?",
        type = "warning", danger_mode = TRUE, btn_labels = c("Cancel", "Yes, save please"))
    })

    observeEvent(input$Save_SWAL, {
        if (isTRUE(input$Save_SWAL)) {
            # SOMETHING HERE
        }
    })
}

shinyApp(ui, server)

Задача

Моя проблема сейчас в том, что я хочу использовать input$Name1_id, input$Name2_id и input$Name3_id в функции, где в коде написано «ЧТО-ТО ЗДЕСЬ», например, для преобразования выбранных баллов в максимальные и минимальные значения. когда я нажимаю на кнопку действия.

Итак, в основном я хочу следующее, но реактивно: 

observeEvent(input$Save_SWAL, {
    if (isTRUE(input$Save_SWAL)) {
        list(
            "Result1" = list("min" = min(input$Name1_id), "max" = max(input$Name1_id)), 
            "Result2" = list("min" = min(input$Name2_id), "max" = max(input$Name2_id)),
            "Result3" = list("min" = min(input$Name3_id), "max" = max(input$Name3_id))
        ) %>% print()
    }
})

Как я могу сделать это, используя цикл for и применить?

Я пытался использовать eval() и do.call() в строке символов, например: "input$Name1_id"; однако ни один из этих вариантов, похоже, не помогает. 

observeEvent(input$Save_SWAL, {
    if (isTRUE(input$Save_SWAL)) {
        sapply(do.call(t), min) %>% print()
    }
})

1 Ответ

0 голосов
/ 30 марта 2019

@ Мортен, я не очень опытен с sapply, но я хотел попробовать. Мне не удалось через 2 часа извлечь что-либо полезное из sa p слоистых структур, но я предоставил вам 2 альтернативных решения. Некоторое объяснение в коде ниже в комментариях

проблема, с которой я столкнулся с sapply, заключается в том, что я получаю либо list(), либо имена inputs, напечатанные вместо их values. Обычно я использовал бы eval(parse(text = 'name of input here')) для обработки входных имен, представленных в виде строки, а не в виде кода, но для этого случая использования его внутри функции apply, кажется, ускользает от меня, почему она не работает.

В любом случае, ниже есть подход с lapply над именами ввода или путем сбора результатов в reactiveVariable, то есть список, который содержит все T/F values всех ваших checkboxes на группу. 

list_of_names <- tibble("Name" = c("Name1", "Name2", "Name3"), 
                        "0 pt" = c("Criteria 0 name1", "Criteria 0 name2", "Criteria 0 name3"), 
                        "1 pt" = c("Criteria 1 name1", "Criteria 1 name2", "Criteria 1 name3"), 
                        "2 pt" = c("Criteria 2 name1", "Criteria 2 name2", "Criteria 2 name3"))

vectorx <- c('input$Name1_id', 'input$Name2_id', 'input$Name3_id')

listx <- sapply(sapply(1:3, function(i) { paste0("input$Name", i, "_id")}),function(x) NULL)

mycollapse <- lapply(1:nrow(list_of_names), function(i) {
  bsCollapsePanel(paste0(list_of_names$Name[i]),
                  awesomeCheckboxGroup(inputId = paste0(list_of_names$Name[i], "_id"),label = NULL,
                                       choices = as.character(list_of_names[i,2:4]),
                                       status = "success", width = "75%"))
})
mycollapse[["id"]] <- "collapseID"
mycollapse[["multiple"]] <- FALSE
mycollapse[["open"]] <- "Name1"

#### UI ----------

ui <- dashboardPage(
  dashboardHeader(title = "Minimal Example"),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Dashboard", tabName = "Dashboard", icon = icon("dashboard"), 
               selected = TRUE))),   
  dashboardBody(
    fluidPage(
      column(6, shinyjs::useShinyjs(), withSpinner(uiOutput("Data"))))))

server <- function(input, output, session) {

  #approach 1 make a reactive list to store the inputs
  values <- reactiveValues(mylist = list())
  output$Data <- renderUI({
    tagList(
      do.call(bsCollapse, args = mycollapse) %>% return(),
      actionButton("Save", "Save"))
  })

  #approach 1 observe changes in the inputs (including deselect of all, which would not work if you use observeEvent as it does not fire if all boxes are FALSE)
 observe({ lapply(1:3, function(i) {
    values$mylist[[paste0('Name', i, '_id', sep = '')]] <- input[[paste0('Name', i, '_id', sep = '')]]
})
  })
   ####################



  observeEvent(input$Save, {
    confirmSweetAlert(session, inputId = "Save_SWAL", title = 
                        "Save?", text = "Are you sure?",
                      type = "warning", danger_mode = TRUE, btn_labels = c("Cancel", "Yes, save please"))
  })


  observeEvent(input$Save_SWAL, {
    if (isTRUE(input$Save_SWAL)) {


      #approach 1 simply print the minimums in the reactive list
      print("#approach 1")
      print(sapply(values$mylist, min) )

      ##### I tried for over 1.5 hour, but I could not get an sapply block working on strings called "input$Name1_id" etc 
      ## normally I would use eval(parse(text = 'input$Name1_id')) to read what the input is, but for some reason it will not work with a list of names
      ## This makes a named yet empty list for instance:  
      ## listx <- sapply(sapply(1:3, function(i) { paste0("input$Name", i, "_id")}),function(x) NULL)
      ## with the idea that I could then try to sapply over the names with eval(parse()) construct, but it doesn't return the minimums

      # keeps printing empty 'list()'
      # print(sapply(eval(parse(text = names(listx))), min))


      ##this keeps printing the names of vectorx
      # print(sapply(vectorx, min))


      #approach 2 run an lapply over all the inputs without the need to store them
      print("#approach 2")
      lapply(1:3, function(i) {
        if(!!length(input[[paste0('Name', i, '_id', sep = '')]])) {  ## !!length means it is NOT an empty list, so then we want the min
          min(input[[paste0('Name', i, '_id', sep = '')]]) %>% print()
        }
      })

    }
  })
}

shinyApp(ui, server)
...