Question

我创建了以下闪亮模块，但它不起作用，因为它给出了错误：警告：数据表中的错误：'data'必须是2维的（例如数据框或矩阵）堆栈跟踪（最里面的第一个）

outputTableInput <- function(input, output, session, the_data){

  ns <- session$ns

  df = reactive({
    return(as.data.frame(the_data()))
  })


  DT::renderDataTable({
    df
    },rownames = FALSE,
    options = list(
      dom = 'tip',
      language = list(info = ''),
      scrollY = '300px', 
      paging = FALSE ,
      initComplete = JS(
        "function(settings, json) {",
        "$(this.api().table().header()).css({
        'height': '80%',
        'font-size': '75%' ,
        'background-color': '#FF0000', 
        'color': '#fff'});",
        "$(this.api().table().body()).css({
        'font-size': '60%'})}")
      ))
}

相应的应用是：

    shinyApp(
      ui = fluidPage(
        fluidRow(
          column(2, dynamicSelectInput("MovementSocietyColumn", "Select Entity", multiple = FALSE)),
          column(2, dynamicSelectInput("MovementAccountColumn", "Select Account", multiple = FALSE)),
          column(2, dynamicSelectInput("MovementImporteColumn", "Select Import", multiple = FALSE)),
          column(2, dynamicSelectInput("MovementCountryColumn", "Select Country", multiple = FALSE))
        ),
        fluidRow(
          column(2, checkboxInput("one", "Show Example", FALSE)),
          column(2, checkboxInput("two", "Show Example", FALSE)),
          column(2, checkboxInput("three", "Show Example", FALSE)),
          column(2, checkboxInput("four", "Show Example", FALSE))
        ),
        fluidRow(
          column(2,
                 conditionalPanel(condition="input.one==true", dataTableOutput("table1"))),
                                  #wellPanel(id = "tPanel",
                                  #          style = "overflow-y:scroll; max-height: 150px",
                                  #          dataTableOutput("table1")))),
          column(2,conditionalPanel(condition="input.two==true", 
                 dataTableOutput("table2"))),
          column(2,conditionalPanel(condition="input.three==true", 
                 dataTableOutput("table3"))),
          column(2,conditionalPanel(condition="input.four==true", 
                 dataTableOutput("table4")))
        )
      ),
      server = function(input, output, session){

        the_data <- reactive({
          data1
        })

        a_filter <- shiny::callModule(dynamicSelect, "MovementSocietyColumn", the_data, default_select = 1)
        b_filter <- shiny::callModule(dynamicSelect, "MovementAccountColumn", the_data, default_select = 1)
        c_filter <- shiny::callModule(dynamicSelect, "MovementImporteColumn", the_data, default_select = 1)
        d_filter <- shiny::callModule(dynamicSelect, "MovementCountryColumn", the_data, default_select = 1)

        output$table1<-shiny::callModule(outputTableInput,"table1",a_filter()))
})

我知道这个问题与反应点有关，但我无法弄清楚这一点。非常感谢您提前寻求帮助。这里data1是一个全局数据帧（我们也可以使用mycars）。

我使用的功能如下：

safeSubset <- function(df, subset){

  testthat::expect_is(df, "data.frame")

  if(!is.null(subset)){
    testthat::expect_is(subset, "character")
    out<- df[[subset]]
  } else {
    message("Subset is NULL, returning original")
    out <- df
  }

  new_data<-as.data.frame(unique(out[!is.na((out))])[1:min(50,length(unique(out)))])
  names(new_data)<-c(subset)
  new_data
}


#' Dynamical Update of a selectInput
#'
#' Shiny Module: useage details at \link{dynamicSelect}
#'
#' @param id shiny id
#'
#' @return dynamicSelectInput
#' @export
dynamicSelectInput <- function(id, label, multiple = FALSE){

  ns <- shiny::NS(id)

  shiny::selectInput(ns("dynamic_select"), label,
                     choices = NULL, multiple = multiple, width = "100%")

}

#' Dynamical Update of a selectInput
#'
#' Shiny Module
#'
#' Use via \code{callModule(dynamicSelect, "name_select", the_data, "cyl")}
#'
#' @param input shiny input
#' @param output shiny output
#' @param session shiny session
#' @param the_data data.frame containing column of choices
#' @param column The column to select from
#' @param default_select The choices to select on load
#'
#' @seealso \link{dynamicSelectInput}
#'
#' @return the_data filtered to the choice
#' @export
dynamicSelect <- function(input, output, session, the_data, default_select = NULL){

  ns <- session$ns

  ## update input$dynamic_select
  observe({
    shiny::validate(
      shiny::need(the_data(),"Fetching data")
    )
    dt <- the_data()

    testthat::expect_is(dt, "data.frame")

    choice <- unique(names(dt))

    updateSelectInput(session, "dynamic_select",
                      choices = choice,
                      selected = default_select)

  })

  new_data <- reactive({
    shiny::validate(
      shiny::need(input$dynamic_select,"Select data"),
      shiny::need(the_data(), "Waiting for data")
    )

    sd <- the_data()
    selected <- input$dynamic_select

    ## will return sd even if column is NULL
    safeSubset(sd, selected)

  })

  return(new_data)

}

RenderdataTable作为闪亮模块

0 个答案: