更新R Shiny

时间:2016-08-15 13:45:21

标签: r shiny

我正在开发一个应用程序,允许用户动态地向UI添加新的selectInput框,我希望所有这些selectInput框都将数据集的列名作为他们的选择' ;。数据集也应该由用户选择,这就是为什么我使selectInput选项对数据集选择中的更改起反应的原因。

听起来很简单但我似乎无法让它正常工作。当我第一次打开应用程序时,第一个selectInput为空;这没关系,因为我希望用户能够上传他们自己的数据集,因此默认数据集无论如何都是NULL(这里使用预先加载的数据集进行再现,因此它略有不同)。

enter image description here

我选择了一个(不同的)数据集,' iris'从下拉列表中选择框,以及' iris'的列名称。数据集会自动加载到selectInput框中(表1)。这根据需要完美地工作。

enter image description here

接下来,我通过单击表1中的Plus符号添加一个新的selectInput框,旁边会出现一个新的selectInput框(表2)。

enter image description here

问题在于:我希望新创建的子selectInput框自动使用数据集的列名,但我无法弄清楚如何执行此操作。填充新selectInput框的唯一方法是再次更改数据集选项,这是不可取的。

以下是此示例中使用的代码:

library(shiny)
library(datasets)

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

  newNode <- function(id, parentId) {
    node <- list(
      parent = parentId, 
      children = list()
    )
    # Create the UI for this node
    createSliceBox(id, parentId) 
    return(node)
  }

  createSliceBox <- function(id, parentId) {
    # Div names
    containerDivID <- paste0('container',id,'_div')
    nodeDivID <- paste0('node',id,'_div')
    childrenDivID <- paste0('children',id,'_div')

    if (parentId == 0) { # Root node case
      parentDivID <- 'allSliceBoxes'
    } else {
      parentDivID <- paste0('children',parentId,'_div')
    }

    # Input names
    selectID <- paste0("sliceBoxSelect", id)
    buttonID <- paste0("sliceBoxButton", id)

    # Insert the UI element for the node under the parent's children_div
    insertUI(
      selector = paste0('#',parentDivID), 
      where = 'afterBegin',
      ui = tagList(
        tags$div(id=containerDivID, style='float:left',
          tags$div(id=nodeDivID, style='float:left; margin: 5px; min-width:250px',
            actionButton(buttonID, "", 
              icon("plus-circle fa-1x"), style="float:right; border:none; color:#00bc8c; background-color:rgba(0,0,0,0)"),
            wellPanel(class="well well-sm",
              selectInput(selectID, paste0("Table ", id, ", child of ", parentId, "."), c(''), multiple=FALSE)
            )
          ),
          tags$div(id=childrenDivID, style='float:left') # Container for children, starts empty
        ),
        tags$br('')
      )
    )
    # Observer for selectors
    observe(
      updateSelectInput(session, selectID, choices=names(d.Preview()) ) # Doesn't work as expected?
    )
  }

  ### CODE STARTS HERE
  tags$head(tags$script(src="https://use.fontawesome.com/15c2608d79.js")) # Import FontAwesome for icons

  # File upload

  d.Preview <- reactive({
    switch(input$dataset,
           "mtcars" = mtcars,
           "iris" = iris,
           "esoph" = esoph)
  })

  # We'll store our nodes as a 1D list, so parent and child ID's are recorded as their indices in the list
  sliceBox.data <- reactiveValues(display=list(), selected=list())
  rootNode <- newNode(1, 0) # Page loads with NULL first node, before input is chosen
  sliceBox.tree <- reactiveValues(tree=list(rootNode))
  # Special case for loading data into first node, needs reactive parentData - not the case for children nodes
  observeEvent(input$dataset, {
    slice <- reactive({
      sliceData(d.Preview(), input$sliceBoxSelect1)
    })
    # Creating data for the first node
    sliceBox.data$display[[1]] <- reactive(slice())
    sliceBox.data$selected[[1]] = reactive({
      selectedRows <- input[[paste0("sliceBoxTable", 1, "_rows_selected")]]
      filterData(d.Preview(), sliceBox.data$display[[1]](), selectedRows, input[[paste0("sliceBoxSelect",1)]]) 
    })

  })

  # Keep a total count of all the button presses (also used loosely as the number of tables created)
  v <- reactiveValues(counter = 1L) 
  # Every time v$counter is increased, create new handler for the new button at id=v$counter
  observeEvent(v$counter, {
    parentId <- v$counter
    buttonID <- paste0("sliceBoxButton", parentId)

    # Button handlers to create new sliceBoxes
    observeEvent(input[[buttonID]], {
      v$counter <- v$counter + 1L
      childId <- v$counter 
      # Note that because the ObserveEvents are run separately on different triggers, (childId != parentId+1)

      # Create new child
      sliceBox.tree$tree[[childId]] <- newNode(childId, parentId)

      # Append new childId to parent's list of children
      numChildren <- length(sliceBox.tree$tree[[parentId]]$children)
      sliceBox.tree$tree[[parentId]]$children[numChildren+1] <- childId 
    })
  })

}

ui <- fluidPage(theme = "bootstrap.css", 
  # Main display body
  fluidRow(style="padding:5px",
    selectInput("dataset", "Choose a dataset:", choices = c("mtcars", "iris", "esoph"), selected=NULL),
    tags$div(uiOutput("allSliceBoxes"), style="padding:20px")
  ) 
)

shinyApp(ui = ui, server = server)

希望有人可以提供帮助,有很多关于selectInput在线的问题,但我还没有找到解决这个特殊问题的解决方案。

0 个答案:

没有答案