select 基于复选框选择并显示热图的 Rshiny 中 data.frame 的多列

Question

大家好，

我是 Rshiny 的新手，一直在玩用户反应元素。 我正在尝试创建一个基本上以 data.frame 作为输入的热图 - 用户可以在其中 select 要显示的行数和列数。 特别是如果用户 select 有一个复选框选项，则会选择一些列（如果未选中复选框，则取消选择）。

我的示例代码如下所示 - 它采用 99 个元素（用于行）的 TSV 输入文件，并具有 20 列值。 我提供了增加减少行的选项，如 slider 和 5 个复选框 - 表示“col_group_xx”，这样每个复选框选择一组 4 列 - 从热图中添加或删除这些列。 即“col_group_1”将 select 或取消选择前 4 列，“col_group_2”用于第 5 到 8 列，依此类推。

我的行 slider 有效，热图适当地减少或增加行，但我似乎无法弄清楚如何将复选框连接到 select 每组列 -

它返回此错误 -

Warning: Error in [.data.frame: undefined columns selected
  [No stack trace available]

在此处下载示例 TSV 输入文件 - https://github.com/sid5427/downloader/raw/master/example_matrix_for_heatmap.txt

github 代码链接以便于下载 - https://github.com/sid5427/downloader/raw/master/cleaned_variable_heatmap_eg.ZE1E1D3D40573127E36EE0480CAF1

我的代码如下 -

library(d3heatmap)
library(RColorBrewer)
library(shiny)
library(shinythemes)
library(reprex)
library(dplyr)


data<-read.csv("example_matrix_for_heatmap.txt", header=TRUE, row.names = 1, sep="\t")
rownames(data)
nrow(data)
dim(data)

new_data_matrix <- data.frame(rownames(data))

colnames <- c("col_group_1","col_group_2","col_group_3","col_group_4","col_group_5")

####ui####
ui<-fluidPage(
  titlePanel("example_heatmap"), 
  theme=shinytheme("cerulean"),

  sidebarPanel(
    sliderInput("obs",
                "Number of observations:",
                min = 1,
                max = nrow(data),
                value = nrow(data)),
    tableOutput("values"),

    #group of checkboxes
    checkboxGroupInput("checkGroup", 
                       label = h3("columns to select"),
                       choices = colnames,
                       selected = colnames)
  ),

  mainPanel(
    d3heatmapOutput("heatmap", 
                    height="1200px", width="80%")
  ),


  fluidRow(column(3, verbatimTextOutput("value")))
)

####server####
server <- function(input, output) 
{
  output$value <- renderPrint({ input$checkGroup })

  observeEvent(input$checkGroup,{
    if("col_group_1" %in% input$checkGroup){
      print("col_group_1") ##debuging
      new_data_matrix <- cbind(new_data_matrix,data[,1:4])
    }
    if("col_group_2" %in% input$checkGroup ){
      print("col_group_2") ##debuging
      new_data_matrix <- cbind(new_data_matrix,data[,5:8])
    }
    if("col_group_3" %in% input$checkGroup ){
      print("col_group_3") ##debuging
      new_data_matrix <- cbind(new_data_matrix,data[,9:12])
    }
    if("col_group_4" %in% input$checkGroup ){
      print("col_group_4") ##debuging
      new_data_matrix <- cbind(new_data_matrix,data[,13:16])
    }
    if("col_group_5" %in% input$checkGroup ){
      print("col_group_5") ##debuging
      new_data_matrix <- cbind(new_data_matrix,data[,17:20])
    }
    dim(new_data_matrix) ##debuging
  })

  output$heatmap <- renderD3heatmap({
    d3heatmap(new_data_matrix[1:input$obs,2:ncol(new_data_matrix)],
              col=brewer.pal(9,"Reds"),
              scale="none")}
  )
}

shinyApp(ui, server)

任何帮助，将不胜感激！ 另外，如果有更有效的方法通过 dplyr 执行此操作，我也将不胜感激！

Answer 1

同意@r2evans 的建议，您可以使用reactive块。 您可以设置两个块（一个用于 select 列，一个用于根据这些选定的列对数据进行子集化）。

在下面的示例中，我只使用一个reactive块来根据观察和列进行子集化。 此外，拥有一个将组与特定范围的列（在本例中col_group ）相关联的简单表可能更容易。 这可以根据您的需要进行修改，并且可能具有一定的灵活性。

reactive块将确定要使用的列范围。 使用Map function，您可以将所有字段放在一个向量中以用于子集数据。

还在renderD3heatmap中添加了validate ，这将确保您至少检查了一组，并且根据您的输入 slider，您至少有 2 个观察值。

library(d3heatmap)
library(RColorBrewer)
library(shiny)
library(shinythemes)
library(reprex)
library(dplyr)

data<-read.csv("example_matrix_for_heatmap.txt", header=TRUE, row.names = 1, sep="\t")

col_group <- data.frame(
  group = c("col_group_1","col_group_2","col_group_3","col_group_4","col_group_5"),
  min_col = c(1, 5, 9, 13, 17),
  max_col = c(4, 8, 12, 16, 20)
)

####ui####
ui<-fluidPage(
  titlePanel("example_heatmap"), 
  theme=shinytheme("cerulean"),

  sidebarPanel(
    sliderInput("obs",
                "Number of observations:",
                min = 1,
                max = nrow(data),
                value = nrow(data)),
    tableOutput("values"),

    #group of checkboxes
    checkboxGroupInput("checkGroup", 
                       label = h3("columns to select"),
                       choices = col_group[, "group"],
                       selected = col_group[, "group"])
  ),

  mainPanel(
    d3heatmapOutput("heatmap", 
                    height="1200px", width="80%")
  ),


  fluidRow(column(3, verbatimTextOutput("value")))
)

####server####
server <- function(input, output) 
{
  new_data_matrix <- reactive({
    col_ranges <- col_group %>% 
      filter(group %in% input$checkGroup)

    all_cols <- unlist(Map(`:`, col_ranges$min_col, col_ranges$max_col))

    data[1:input$obs, all_cols]
  })

  output$heatmap <- renderD3heatmap({
    validate(
      need(input$checkGroup, 'Check at least one group!'),
      need(input$obs >= 2, 'Need at least 2 groups to cluster!')
    )
    d3heatmap(new_data_matrix(),
              col=brewer.pal(9,"Reds"),
              scale="none")
  })
}

shinyApp(ui, server)