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

Question

Good day all,

I am new to Rshiny and been playing around with user reactive elements. I am trying to create a heatmap that essentially takes a data.frame as input - where the user can select the number of rows and columns to be displayed. Particularly if a user select a checkbox option, a number of columns would be selected (or deselected if checkbox is not selected).

My example code looks like this - it takes a TSV input file of 99 elements (for rows), and has 20 columns of values. I give the option to increase decrease rows as a slider, and 5 checkboxes - denoting "col_group_xx", such that each checkbox selects a group of 4 columns - adding or removing those columns from the heatmap. ie "col_group_1" would select or deselect the first 4 columns, "col_group_2" for columns 5 to 8, and so on.

My row slider works and the heatmap appropriately reduces or increases rows, but I can't seem to figure out how to connect the checkboxes to select each group of columns -

It returns this error -

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

download sample TSV input file here - https://github.com/sid5427/downloader/raw/master/example_matrix_for_heatmap.txt

github link to code for easy download - https://github.com/sid5427/downloader/raw/master/cleaned_variable_heatmap_eg.R

my code is as follows -

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)

Any help would be appreciated! Plus if there is a more efficient way of doing this via dplyr I would appreciate that as well!

Answer 1

Agree with @r2evans suggestion, you can use a reactive block. You can set up two blocks (one to select columns, and one to subset your data based on these selected columns).

In the example below I just use one reactive block to subset based on both observations and columns. In addition, it might be easier to have a simple table that relates groups to specific ranges of columns (in this case col_group ). This could be modified for your needs and may allow for some flexibility.

The reactive block will determine which column ranges to use. With the Map function you can put all the fields together in a single vector to use in subsetting data.

Also added validate in renderD3heatmap , which would make sure you have at least one group checked, and that you have at least 2 observations based on your input slider.

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)