在dataTableOutput中显示不正确的列名，当selectinput(multiple=T) -发亮时

Question

我希望显示一个显示重复计数的表以及用户定义的列。我在这个闪亮的应用程序中有了selectinput选项，用户可以选择多个列来检查重复的组合。

但当用户选择第一列时，将显示不正确的列名。选择两列时，列名是正确的。

请帮我找到解决这个问题的办法。当用户选择第一列时，应显示正确的列。

密码，

library(shiny)
library(shinydashboard)

ui <- dashboardPage(skin = "black",
                    dashboardHeader(title = "test"),
                    dashboardSidebar(
                      sidebarMenu(
                        menuItem("Complete", tabName = "comp"))),
                  dashboardBody(useShinyjs(),
                    tabItems(
                    tabItem(tabName = "comp",
                      fluidRow(
                      box(selectInput("dup_var", "Variable", multiple = TRUE, c("1"="1","2"="2")), 
                          width = 3, status = "primary")),
                      fluidRow(
                      box(title = "Duplicate Records", width = 12, solidHeader = TRUE, status = "primary", 
                      collapsible = TRUE, DT::dataTableOutput("dup_data")))))))

server <- function(input, output, session) {
  observe({
    cname <- c("Select All", names(mtcars))
    col_options <- list()
    col_options[ cname] <- cname

    updateSelectInput(session, "dup_var",
                      label = "",
                      choices = c("Choose Attributes"="",col_options))   
  })

  output$dup_data <- DT::renderDT({ 
    if (input$dup_var == "Select All"){
      col_names = colnames(mtcars)
      df = count(mtcars, col_names)
      df = df[df$freq > 1,]
      Dup <- df$freq
      df1 <- cbind.data.frame(Dup, df[,!names(df) %in% "freq"])
      df1 <- df1[order(-df1$Dup),]
      names(df1)[names(df1) == 'Dup'] <- 'Duplicate Count'

      dp <- DT::datatable(df1, rownames = FALSE)
      return(dp)
    } else {
      col_names = colnames(mtcars[,c(input$dup_var)])
      df = count(mtcars[,c(input$dup_var)], col_names)
      df = df[df$freq > 1,]
      Dup <- df$freq
      df1 <- cbind.data.frame(Dup, df[,!names(df) %in% "freq"])
      df1 <- df1[order(-df1$Dup),]
      names(df1)[names(df1) == 'Dup'] <- 'Duplicate Count'

      dp <- DT::datatable(df1, rownames = FALSE)
      return(dp)
    }
  }) 
          }
shinyApp(ui, server)

​

​

提前谢谢。

Answer 1

看起来你错过了几个drop = FALSE。添加这一项后，您可以以与多列情况相同的方式处理某一列的特殊情况：

else {
  col_names = colnames(mtcars[, c(input$dup_var), drop = FALSE])
  df = count(mtcars[, c(input$dup_var), drop = FALSE], col_names)
  df = df[df$freq > 1, ]
  Dup <- df$freq
  df1 <- cbind.data.frame(Dup, df[, !(names(df) %in% "freq"), drop = FALSE])
  df1 <- df1[order(-df1$Dup), ]
  names(df1)[names(df1) == 'Dup'] <- 'Duplicate Count'

请注意，我不确定您的函数count，但是上面的内容对我来说似乎是可信的。

Answer 2

您不需要在输出中放一个if- here语句，因为逐列设置数据帧会给出您在这里需要的值。我不能完全复制你的代码，也许这给了你一个想法。

library(shiny)

choices <- c("Select All", names(mtcars))

ui <- fluidPage(
  selectInput("dup_var", "Variable", choices, multiple = TRUE),
  DT::dataTableOutput("dup_data")
)

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

  observe({
    if ("Select All" %in% input$dup_var) {
      allchoices <- setdiff(choices, "Select All")
      updateSelectInput(session, "dup_var", selected = allchoices)
    }
  })

  output$dup_data <- DT::renderDataTable({
    data <- mtcars[input$dup_var]
    do.call(rbind, lapply(names(data), function(name) {
      x <- data[, name, drop = TRUE]
      aggregate(list(count = x), by = list(name = x), length)
    })) -> df

    df <- df[df$count > 1, ]
    data.frame(duplicate_count = df$count, x = df[,!names(df) %in% "count"],
               stringsAsFactors = FALSE)
  }, rownames = FALSE)
}

shinyApp(ui, server)