将过滤后的数据（用户选择）显示/绘制到 Shiny 中新创建的导航栏选项卡中

Question

我目前在 Shiny 中遇到一个问题，我无法将过滤后的数据（用户选择）显示到新创建的导航栏选项卡中。这也导致了另一个奇怪的新标签删除问题。

问题：我被 Shiny 中的选择数据、附加选项卡（在导航栏中）、outputUI 和显示/绘图逻辑序列卡住了。

场景：

1. 用户从本地计算机中选择的数据
2. 用户从下拉列表中进行第一次选择
3. 点击添加新标签
4. 用户从下拉列表中进行第二次选择
5. 点击添加新标签

使用的数据： 我不知道如何在 stackover flow 上上传数据，但是一个包含两列 A 和 B 的简单 csv 表将复制下面的结果

结果： 选项卡 A：显示“错误：无法将类型‘闭包’强制转换为‘字符’类型的向量” Tab B：删除选项卡功能现在也被破坏了

我的最终目标是提供更多背景信息：为了能够在新标签中使用此用户选择的数据显示图表、计算、表格。

在它开始出错之前我做了什么：我遵循了与这篇文章类似的逻辑，在新标签中显示用户过滤的数据（虽然不是新的导航栏）：

1. How to reuse a dataset in different objects when renderUI is used to create tabs in ShinyR

在此问题开始之前，我还从 * 获得了一些帮助。这可能有助于提供更多上下文，贡献者的所有答案都有效：

1. Append and remove tabs using sidebarPanel
2. Can't get disable button to work with observeEvent with if statement in ShinyR

一如既往，非常感谢您调查我的问题。 干杯

library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(shinyjs)
library(data.table)

ui <- fluidPage(
  useShinyjs(),
  navbarPage(title = "* help", id = "tabs",
             
             tabPanel("Home",
                      sidebarPanel(
                        fileInput("file", "Upload data",
                                  accept = c(
                                    "text/csv",
                                    "text/comma-separated-values,text/plain",
                                    ".csv")
                        ),
                        #checkboxInput("header", "Header", TRUE),
                        actionButton("append", "Add new tab"),
                        uiOutput('tabnamesui')
                      ),
                      mainPanel(
                      )
             )
  )
)

server <- function(input, output, session) {
  
  userfile <- reactive({
    input$file
  })
  
  filereact <- reactive({
      read.table(
        file = userfile()$datapath,
        sep = ',',
        header = T,
        stringsAsFactors = T
      )
    })
  
  tabsnames <- reactive({
    names(filereact())
  })
  
  output$tabnamesui <- renderUI({
    req(userfile())
    selectInput(
      'tabnamesui',
      h5('Tab names'),
      choices = as.list(tabsnames()),
      selected="",multiple = FALSE
    )
  })
  
  tabnamesinput <- reactive({
    input$tabnamesui})
  
  #Delete selected tab logic
  observeEvent(input$append,{
    appendTab(inputId = "tabs",
              tabPanel(input$tabnamesui, 
                       sidebarPanel(
                       actionButton(paste0("remove_", input$tabnamesui), "Delete")),
                       mainPanel(
                       uiOutput("tabsets") #This is where I think something is broken
                       )
              )
    )
    
  })
  
  observeEvent(lapply(grep(pattern = "^remove_", x = names(input), value = TRUE), function(x){input[[x]]}),{
    if(input$tabs != "Home"){
      removeTab(inputId = "tabs", target = input$tabs)
      updateSelectInput(session, "tabnamesui", selected = input$tabnamesui) # keep the selection when re-rendering sidebarPanel
    }
  })
  
  #New tab logic to prevent inserting same tab twice with enable/disable action button
  forcecombine = function(idtab,checker) {
    colnames(idtab) = colnames(checker)
    rbind(idtab,checker)
  }
  
  checker<-as.data.frame("checker")
  idtab<-as.data.frame("checkers")
  
  #only allow tab entry once   
  observeEvent(input$append, {
    idtab <- paste0(tabnamesinput())
    idtab<-as.data.frame(idtab)
    checkerx<-forcecombine(idtab,checker) 
    repeated<-length(grep(idtab,checkerx))
    
    if(repeated==1)  
    {
      shinyjs::disable("append")
      
    }
    else {shinyjs::enable("append")
    }
  })
  
  observeEvent(tabnamesinput(), {
    shinyjs::enable("append")
  })
  
  shinyjs::disable("append")
  
  observeEvent(input$file, {
    shinyjs::enable("append")
  })
  
  
  #Subdata section, I want to only use the data the user has selected for the new Navbar tab
  output$tabsets<-renderUI({
    req(userfile())
    tabtable<-reactive({
      lapply(tabnamesinput(), function(x)
        dataTableOutput(paste0('table',x)))
    })
  })
  
  subsetdata<-reactive({
    list_of_subdata<-lapply(tabnamesinput(), function(x) {
      as.data.table((select(filereact(),x)))
    })
    names(list_of_subdata)<-tabnamesinput()
    return(list_of_subdata)
  })
  
  observe(
    lapply(tabnamesinput(), function(x) {
      output[[paste0('table',x)]] <- 
        renderDataTable({
          subsetdata()[[x]]
        })}))
  
}

shinyApp(ui, server)

Answer 1

您不能在多个选项卡中输出相同的ID。一旦你解决了这个问题，它就可以工作了。您仍然需要定义希望在每个选项卡中显示的内容。我只是显示一个过滤表和一个示例图。此外，标签删除需要进行微调。工作代码如下所示。

ui <- fluidPage(
  useShinyjs(),
  navbarPage(title = "* help", id = "tabs",

             tabPanel("Home",
                      sidebarPanel(
                        fileInput("file", "Upload data",
                                  accept = c(
                                    "text/csv",
                                    "text/comma-separated-values,text/plain",
                                    ".csv")
                        ),
                        #checkboxInput("header", "Header", TRUE),
                        actionButton("append", "Add new tab"),
                        uiOutput('tabnamesui')
                      ),
                      mainPanel( 

                      )
             )
  )
)

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

  userfile <- reactive({
    input$file
  })

  filereact <- reactive({
    read.table(
      file = userfile()$datapath,
      sep = ',',
      header = T,
      stringsAsFactors = T
    )
  })

  tabsnames <- reactive({
    names(filereact())
  })

  output$tabnamesui <- renderUI({
    req(userfile())
    selectInput(
      'tabnamesui',
      h5('Tab names'),
      choices = as.list(tabsnames()),
      selected="",multiple = FALSE
    )
  })

  tabnamesinput <- reactive({
    input$tabnamesui})

  #Append selected tab logic
  observeEvent(input$append,{
    appendTab(inputId = "tabs",
              tabPanel(input$tabnamesui,
                       sidebarPanel(
                         actionButton(paste0("remove_", input$tabnamesui), "Delete")),
                       mainPanel(
                         #uiOutput("tabsets") #This is where I think something is broken
                         DTOutput(paste0("table",input$tabnamesui)),
                         plotOutput(paste0("plot",input$tabnamesui))
                       )
              )
    )

  })
  
  # Delete selected tab logic
  observeEvent(lapply(grep(pattern = "^remove_", x = names(input), value = TRUE), function(x){input[[x]]}),{
    if(input$tabs != "Home"){
      if (input[[paste0("remove_",input$tabs)]]) { ## remove tab only if delete button has been clicked
        removeTab(inputId = "tabs", target = input$tabs)
        updateSelectInput(session, "tabnamesui", selected = input$tabnamesui) # keep the selection when re-rendering sidebarPanel
      }
    }
  })

  #New tab logic to prevent inserting same tab twice with enable/disable action button
  forcecombine = function(idtab,checker) {
    colnames(idtab) = colnames(checker)
    rbind(idtab,checker)
  }

  checker<-as.data.frame("checker")
  idtab<-as.data.frame("checkers")

  #only allow tab entry once
  observeEvent(input$append, {
    idtab <- paste0(tabnamesinput())
    idtab<-as.data.frame(idtab)
    checkerx<-forcecombine(idtab,checker)
    repeated<-length(grep(idtab,checkerx))

    if(repeated==1)
    {
      shinyjs::disable("append")

    }
    else {shinyjs::enable("append")
    }
  })

  observeEvent(input$tabnamesui, {
    shinyjs::enable("append")
    output[[paste0("plot",input$tabnamesui)]] <- renderPlot(plot(cars))
    lapply(tabnamesinput(), function(x) {
      df <- as.data.table(filereact()[[as.name(tabnamesinput())]])
      output[[paste0('table',x)]] <- renderDT({
          df
          #subsetdata()[[x]]
        })})
  })

  shinyjs::disable("append")

  observeEvent(input$file, {
    shinyjs::enable("append")
  })

}

shinyApp(ui, server)

Answer 2

试试这个：

library(plotly)
library(shiny)
library(DT)


ui <- fluidPage(

    mainPanel(
         plotlyOutput("SepalPlot"),
         DT::dataTableOutput("Sepal"),
         plotlyOutput("PetalPlot"),
         DT::dataTableOutput("Petal")
    )
)


server <- function(input, output) {

   output$SepalPlot<- renderPlotly({
     plot_ly(iris, x = ~Sepal.Length, y = ~Sepal.Width, type = 'scatter', mode = 'markers')
   })

   sep<-data.frame(c(iris$Sepal.Length, iris$Sepal.Width))
   output$Sepal<-renderDataTable({datatable(sep)})

   output$PetalPlot<- renderPlotly({
     plot_ly(iris, x = ~Petal.Length, y = ~Petal.Width, type = 'scatter', mode = 'markers')
   })

   pet<-data.frame(c(iris$Petal.Length, iris$Petal.Width))
   output$Petal<-renderDataTable({pet})
}


shinyApp(ui = ui, server = server)