Как перезапустить цикл lapply в renderUI - PullRequest
Новая
       8

Как перезапустить цикл lapply в renderUI

2 голосов
/ 30 сентября 2019

Я пытаюсь создать блестящий код, который может фильтровать таблицу не определенное количество раз. Когда пользователь загружает другую (новую) таблицу, к сожалению, код ломается, так как мне нужно как-то перезапустить цикл lapply, выбрасывая ранее сохраненные имена столбцов.

Я хотел бы создать непредопределенную фильтрациюВарианты столика в Shiny. Пользователь может выбрать столбец и отфильтровать таблицу, выбрав различные категориальные переменные в этом столбце. Можно добавить дополнительные поля выбора, нажав кнопку «Добавить».

пользовательский интерфейс: 

library(shiny)
library(shinydashboard)
library(dplyr)

ui <- shinyUI(
  pageWithSidebar(
  headerPanel("testing of dynamic number of selection"),
  sidebarPanel(
    uiOutput("buttons")),
  mainPanel(
    uiOutput("drops")
    ,tableOutput("table")
  )
))

Сервер:

Таблица (test.csv)автоматически сохраняется в реактивных значениях, и появляется первое поле поиска с 3 кнопками (Добавить =, чтобы добавить новое поле поиска, читая в именах столбцов, и множественный выбор, в котором хранятся уникальные переменные из этих столбцов. Функция фильтрации активируется при вычислениикнопка) 

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

###### read in test file
values<-reactiveValues(number = 1,
                    upload = NULL,
                    input = NULL)

values$upload<-read.csv("test.csv")

#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
  div(
    actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
    actionButton(inputId = "new", label = "new table")
  )
})

#pressing the add button
observeEvent(input$add, {
  cat("i adding a new record\n")
  values$number  <- values$number + 1L })

daStuff <- function(i){  
  inputName<-paste0("drop", i)
  inputName2<-paste0("select", i)
  inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
  inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
  fluidRow(
    column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),   
    column(6,selectInput(inputName2, inputName2,                     
    na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
                         multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}

output$drops<- renderUI({
  lapply(seq_len(values$number), daStuff)})

При нажатии кнопки «Рассчитать» загруженная таблица подвергается фильтрации в зависимости от выбранных уникальных значений и отображается в выходной таблице $ 

observeEvent(input$calc, {
   values$input<-NULL
    for (i in 1:values$number){
      if(!is.null(input[[paste0("select",i)]])){
        if(is.null(values$input)){
          values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
        else{
          values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
      } }
   if (is.null(values$input)){values$input<-values$upload}

   output$table <- renderTable({values$input}) 
   })

Моя проблемаКогда я загружаю новую таблицу (test2.csv), я не знаю, как стереть ранее сохраненные выборки (сбросить * и выбрать * значения) и выдает сообщение об ошибке. 

 observeEvent(input$new,{
   values$upload<-read.csv("test2.csv")
})
}

shinyApp(ui=ui, server = server)

Полагаю, я должен как-то остановить цикл lapply и перезапустить его, чтобы ранее сохраненные значения были заменены в зависимости от нового выбора, но я немного застрял в том, как мне этого добиться.

1 Ответ

0 голосов
/ 02 октября 2019

На тот случай, если вы все еще ищете решения, я хотел бы поделиться чем-то похожим и потенциально адаптированным к вашим потребностям.

При этом используется observeEvent для всех выбранных входов. Если он обнаружит какие-либо изменения, он обновит все входные данные, включая возможности для select на основе drop.

Кроме того, когда читается новый файл, selectInput для drop и select сбрасываются до первого значения.

Редактировать : я забылсохранить selected = input[[paste0("drop",i)]] на месте для раскрывающегося списка (см. исправленный код). Кажется, теперь значения сохраняются при добавлении новых фильтров - дайте мне знать, если вы это имели в виду. 

library(shiny)
library(shinydashboard)
library(dplyr)

myDataFrame <- read.csv("test.csv")

ui <- shinyUI(
  pageWithSidebar(
    headerPanel("Testing of dynamic number of selection"),
    sidebarPanel(
      fileInput("file1", "Choose file to upload", accept = ".csv"),
      uiOutput("buttons")
    ),
    mainPanel(
      uiOutput("inputs"),
      tableOutput("table")
    )
  )
)

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

  myInputs <- reactiveValues(rendered = c(1))

  myData <- reactive({
    inFile <- input$file1
    if (is.null(inFile)) {
      d <- myDataFrame
    } else {
      d <- read.csv(inFile$datapath)
    }
    d
  })

  observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
    for (i in myInputs$rendered) {
      updateSelectInput(session, 
                       paste0('select', i), 
                       choices = myData()[input[[paste0('drop', i)]]],
                       selected = input[[paste0("select",i)]])
    }
  })

  output$buttons <- renderUI({
    div(
      actionButton(inputId = "add", label = "Add"), 
      actionButton(inputId = "calc", label = "Calculate")
    )
  })

  observeEvent(input$add, {
    myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
  })

  observeEvent(input$calc, {
    showData <- NULL
    for (i in 1:length(myInputs$rendered)) {
      if(!is.null(input[[paste0("select",i)]])) {
        if(is.null(showData)) {
          showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
        }
        else {
          showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
        }
      }
    }
    if (is.null(showData)) { showData <- myData() }
    output$table <- renderTable({showData}) 
  })

  observe({
    output$inputs <- renderUI({
      rows <- lapply(myInputs$rendered, function(i){
        fluidRow(
          column(6,  selectInput(paste0('drop',i), 
                               label = "", 
                               choices = colnames(myData()), 
                               selected = input[[paste0("drop",i)]])),
          column(6,  selectInput(paste0('select',i),
                               label = "",
                               choices = myData()[1],
                               multiple = TRUE,
                               selectize = TRUE))
        )
      })
      do.call(shiny::tagList, rows)
    })
  })
}

shinyApp(ui, server)
...