在shiny中使用导航栏时出现的heatmaply问题

Question

编辑:我已经简化了应用程序，并使其所有代码都可重现。编辑2:我刚刚发现，当我使用颜色时，我必须单击其他参数-> navBarPage。然后如预期的那样着色。

我正在开发一个闪亮的应用程序，它可以过滤我的基因，然后绘制剩余基因的热图。最近，我找到了shinyHeatmaply包。我已经下载了它们的全局、UI和服务器，当我在我自己的计算机上尝试时，它们可以正常工作。不幸的是，当我尝试使用navbarPage将我的过滤器应用程序和他们的热图组合在一起时，最后一个不能正确呈现。

我已经创建了一个极简主义的示例，将shinyheatmap添加到https://shiny.rstudio.com/gallery/shiny-theme-selector.html应用程序中的navbarPage的第二个tabPanel，但我还是得到了相同的灰色渲染。

Same mistake in a simpler application

UI: Navbar 1属于shinytheme应用程序，而Navbar 2的内容属于shinyheatmaply

tagList(
  shinythemes::themeSelector(),
  navbarPage(
    # theme = "cerulean",  # <--- To use a theme, uncomment this
    "shinythemes",
    tabPanel("Navbar 1",
             sidebarPanel(
               fileInput("file", "File input:"),
               textInput("txt", "Text input:", "general"),
               sliderInput("slider", "Slider input:", 1, 100, 30),
               tags$h5("Deafult actionButton:"),
               actionButton("action", "Search"),

               tags$h5("actionButton with CSS class:"),
               actionButton("action2", "Action button", class = "btn-primary")
             ),
             mainPanel(
               tabsetPanel(
                 tabPanel("Tab 1",
                          h4("Table"),
                          tableOutput("table"),
                          h4("Verbatim text output"),
                          verbatimTextOutput("txtout"),
                          h1("Header 1"),
                          h2("Header 2"),
                          h3("Header 3"),
                          h4("Header 4"),
                          h5("Header 5")
                 ),
                 tabPanel("Tab 2", "This panel is intentionally left blank"),
                 tabPanel("Tab 3", "This panel is intentionally left blank")
               )
             )
    ),
    tabPanel("Navbar 2", 
               fluidPage(
                 sidebarLayout(
                   sidebarPanel(width=4,
                                h4('Data Selection'),
                                fileInput(inputId="mydata", label = "Import Data",multiple = T),
                                uiOutput('data'),
                                checkboxInput('showSample','Subset Data'),
                                conditionalPanel('input.showSample',uiOutput('sample')),
                                hr(),h4('Data Preprocessing'),
                                column(width=4,selectizeInput('transpose','Transpose',choices = c('No'=FALSE,'Yes'=TRUE),selected = FALSE)),
                                column(width=4,selectizeInput("transform_fun", "Transform", c(Identity=".",Sqrt='sqrt',log='log',Scale='scale',Normalize='normalize',Percentize='percentize',"Missing values"='is.na10', Correlation='cor'),selected = '.')),
                                uiOutput('annoVars'),

                                br(),hr(),h4('Row dendrogram'),
                                column(width=6,selectizeInput("distFun_row", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
                                column(width=6,selectizeInput("hclustFun_row", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
                                column(width=12,sliderInput("r", "Number of Clusters", min = 1, max = 15, value = 2)),    
                                #column(width=4,numericInput("r", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),   

                                br(),hr(),h4('Column dendrogram'),
                                column(width=6,selectizeInput("distFun_col", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
                                column(width=6,selectizeInput("hclustFun_col", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
                                column(width=12,sliderInput("c", "Number of Clusters", min = 1, max = 15, value = 2)),
                                #column(width=4,numericInput("c", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),    

                                br(),hr(),  h4('Additional Parameters'),

                                column(3,checkboxInput('showColor','Color')),
                                column(3,checkboxInput('showMargin','Layout')),
                                column(3,checkboxInput('showDendo','Dendrogram')),
                                hr(),
                                conditionalPanel('input.showColor==1',
                                                 hr(),
                                                 h4('Color Manipulation'),
                                                 uiOutput('colUI'),
                                                 sliderInput("ncol", "Set Number of Colors", min = 1, max = 256, value = 256),
                                                 checkboxInput('colRngAuto','Auto Color Range',value = T),
                                                 conditionalPanel('!input.colRngAuto',uiOutput('colRng'))
                                ),

                                conditionalPanel('input.showDendo==1',
                                                 hr(),
                                                 h4('Dendrogram Manipulation'),
                                                 selectInput('dendrogram','Dendrogram Type',choices = c("both", "row", "column", "none"),selected = 'both'),
                                                 selectizeInput("seriation", "Seriation", c(OLO="OLO",GW="GW",Mean="mean",None="none"),selected = 'OLO'),
                                                 sliderInput('branches_lwd','Dendrogram Branch Width',value = 0.6,min=0,max=5,step = 0.1)
                                ),             

                                conditionalPanel('input.showMargin==1',
                                                 hr(),
                                                 h4('Widget Layout'),
                                                 column(4,textInput('main','Title','')),
                                                 column(4,textInput('xlab','X Title','')),
                                                 column(4,textInput('ylab','Y Title','')),
                                                 sliderInput('row_text_angle','Row Text Angle',value = 0,min=0,max=180),
                                                 sliderInput('column_text_angle','Column Text Angle',value = 45,min=0,max=180),
                                                 sliderInput("l", "Set Margin Width", min = 0, max = 200, value = 130),
                                                 sliderInput("b", "Set Margin Height", min = 0, max = 200, value = 40)
                                )
                   ),

                   mainPanel(
                     tabsetPanel(
                       tabPanel("Heatmaply",
                                tags$a(id = 'downloadData', class = paste("btn btn-default shiny-download-link",'mybutton'), href = "", target = "_blank", download = NA, icon("clone"), 'Download Heatmap as HTML'),
                                tags$head(tags$style(".mybutton{color:white;background-color:blue;} .skin-black .sidebar .mybutton{color: green;}") ),
                                plotlyOutput("heatout",height='600px')
                       ),
                       tabPanel("Data",
                                DT::dataTableOutput('tables')
                       )
                     )
                   )
                 )
               )



             ),
    tabPanel("Navbar 3", "This panel is intentionally left blank")
  )
)

服务器:关于服务器，前两个输出对应于shinytheme，其他输出属于shinyheatmaply

d=data(package='datasets')$results[,'Item']
d=d[!grepl('[\\()]',d)]
d=d[!d%in%c('UScitiesD','eurodist','sleep','warpbreaks')]
d=d[unlist(lapply(d,function(d.in) eval(parse(text=paste0('ncol(as.data.frame(datasets::',d.in,'))')))))>1]
d=d[-which(d=='mtcars')]
d=c('mtcars',d)

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


  ####This to output belongs to the shinytheme application####
  output$txtout <- renderText({
    paste(input$txt, input$slider, format(input$date), sep = ", ")
  })
  output$table <- renderTable({
    head(cars, 4)
  })
  #######################################################
  #Up to here the code belongs to shinyheatmaply
  output$txtout <- renderText({
    paste(input$txt, input$slider, format(input$date), sep = ", ")
  })
  output$table <- renderTable({
    head(cars, 4)
  })

  TEMPLIST<-new.env()
  TEMPLIST$d<-d
  #Annotation Variable UI ----
  observeEvent(data.sel(),{
    output$annoVars<-renderUI({
      data.in=data.sel()
      NM=NULL

      if(any(sapply(data.in,class)=='factor')){
        NM=names(data.in)[which(sapply(data.in,class)=='factor')]  
      } 
      column(width=4,
             selectizeInput('annoVar','Annotation',choices = names(data.in),selected=NM,multiple=T,options = list(placeholder = 'select columns',plugins = list("remove_button")))
      )
    })


    #Sampling UI ----  
    output$sample<-renderUI({
      list(
        column(4,textInput(inputId = 'setSeed',label = 'Seed',value = sample(1:10000,1))),
        column(4,numericInput(inputId = 'selRows',label = 'Number of Rows',min=1,max=pmin(500,nrow(data.sel())),value = pmin(500,nrow(data.sel())))),
        column(4,selectizeInput('selCols','Columns Subset',choices = names(data.sel()),multiple=T))
      )
    })
  })

  #Data Selection UI ----
  output$data=renderUI({
    if(!is.null(input$mydata)) TEMPLIST$d=c(input$mydata$name,TEMPLIST$d)
    selData=head(TEMPLIST$d,1)
    selectInput("data","Select Data",TEMPLIST$d,selected = selData)
  })


  #Color Pallete UI ----
  output$colUI<-renderUI({

    colSel='Vidiris'
    if(input$transform_fun=='cor') colSel='RdBu'
    if(input$transform_fun=='is.na10') colSel='grey.colors'

    selectizeInput(inputId ="pal", label ="Select Color Palette",
                   choices = c('Vidiris (Sequential)'="viridis",
                               'Magma (Sequential)'="magma",
                               'Plasma (Sequential)'="plasma",
                               'Inferno (Sequential)'="inferno",
                               'Magma (Sequential)'="magma",
                               'Magma (Sequential)'="magma",

                               'RdBu (Diverging)'="RdBu",
                               'RdYlBu (Diverging)'="RdYlBu",
                               'RdYlGn (Diverging)'="RdYlGn",
                               'BrBG (Diverging)'="BrBG",
                               'Spectral (Diverging)'="Spectral",

                               'BuGn (Sequential)'='BuGn',
                               'PuBuGn (Sequential)'='PuBuGn',
                               'YlOrRd (Sequential)'='YlOrRd',
                               'Heat (Sequential)'='heat.colors',
                               'Grey (Sequential)'='grey.colors'),
                   selected=colSel)
  })

  #Manual Color Range UI ----
  output$colRng=renderUI({
    if(!is.null(data.sel())) {
      rng=range(data.sel(),na.rm = TRUE)
    }else{
      rng=range(mtcars) # TODO: this should probably be changed
    }
    # sliderInput("colorRng", "Set Color Range", min = round(rng[1],1), max = round(rng[2],1), step = .1, value = rng)  
    n_data = nrow(data.sel())

    min_min_range = ifelse(input$transform_fun=='cor',-1,-Inf)
    min_max_range = ifelse(input$transform_fun=='cor',1,rng[1])
    min_value = ifelse(input$transform_fun=='cor',-1,rng[1])

    max_min_range = ifelse(input$transform_fun=='cor',-1,rng[2])
    max_max_range = ifelse(input$transform_fun=='cor',1,Inf)
    max_value = ifelse(input$transform_fun=='cor',1,rng[2])

    a_good_step = 0.1 # (max_range-min_range) / n_data

    list(
      numericInput("colorRng_min", "Set Color Range (min)", value = min_value, min = min_min_range, max = min_max_range, step = a_good_step),
      numericInput("colorRng_max", "Set Color Range (max)", value = max_value, min = max_min_range, max = max_max_range, step = a_good_step)
    )

  })

  #Import/Select Data ----
  data.sel=eventReactive(input$data,{
    if(input$data%in%d){
      eval(parse(text=paste0('data.in=as.data.frame(datasets::',input$data,')')))
    }else{
      data.in=importSwitch(input$mydata[input$mydata$name%in%input$data,])
    }
    data.in=as.data.frame(data.in)
    # data.in=data.in[,sapply(data.in,function(x) class(x))%in%c('numeric','integer')] # no need for this
    return(data.in)
  })  

  #Building heatmaply ----
  interactiveHeatmap<- reactive({
    data.in=data.sel()
    if(input$showSample){
      if(!is.null(input$selRows)){
        set.seed(input$setSeed)
        if((input$selRows >= 2) & (input$selRows < nrow(data.in))){
          # if input$selRows == nrow(data.in) then we should not do anything (this save refreshing when clicking the subset button)
          if(length(input$selCols)<=1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),]
          if(length(input$selCols)>1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),input$selCols]
        }
      }
    }
    # ss_num = sapply(data.in,function(x) class(x)) %in% c('numeric','integer') # in order to only transform the numeric values

    if(length(input$annoVar)>0){
      if(all(input$annoVar%in%names(data.in))) 
        data.in <- data.in%>%mutate_at(funs(factor),.vars=vars(input$annoVar))
    } 

    ss_num =  sapply(data.in, is.numeric) # in order to only transform the numeric values

    if(input$transpose) data.in=t(data.in)
    if(input$transform_fun!='.'){
      if(input$transform_fun=='is.na10'){
        updateCheckboxInput(session = session,inputId = 'showColor',value = T)
        data.in[, ss_num]=is.na10(data.in[, ss_num])
      } 
      if(input$transform_fun=='cor'){
        updateCheckboxInput(session = session,inputId = 'showColor',value = T)
        updateCheckboxInput(session = session,inputId = 'colRngAuto',value = F)
        data.in=cor(data.in[, ss_num],use = "pairwise.complete.obs")
      }
      if(input$transform_fun=='log') data.in[, ss_num]= apply(data.in[, ss_num],2,log)
      if(input$transform_fun=='sqrt') data.in[, ss_num]= apply(data.in[, ss_num],2,sqrt) 
      if(input$transform_fun=='normalize') data.in=heatmaply::normalize(data.in)
      if(input$transform_fun=='scale') data.in[, ss_num] = scale(data.in[, ss_num])
      if(input$transform_fun=='percentize') data.in=heatmaply::percentize(data.in)
    } 



    if(!is.null(input$tables_true_search_columns)) 
      data.in=data.in[activeRows(input$tables_true_search_columns,data.in),]
    if(input$colRngAuto){
      ColLimits=NULL 
    }else{
      ColLimits=c(input$colorRng_min, input$colorRng_max)
    }

    distfun_row = function(x) dist(x, method = input$distFun_row)
    distfun_col =  function(x) dist(x, method = input$distFun_col)

    hclustfun_row = function(x) hclust(x, method = input$hclustFun_row)
    hclustfun_col = function(x) hclust(x, method = input$hclustFun_col)

    p <- heatmaply(data.in,
                   main = input$main,xlab = input$xlab,ylab = input$ylab,
                   row_text_angle = input$row_text_angle,
                   column_text_angle = input$column_text_angle,
                   dendrogram = input$dendrogram,
                   branches_lwd = input$branches_lwd,
                   seriate = input$seriation,
                   colors=eval(parse(text=paste0(input$pal,'(',input$ncol,')'))),
                   distfun_row =  distfun_row,
                   hclustfun_row = hclustfun_row,
                   distfun_col = distfun_col,
                   hclustfun_col = hclustfun_col,
                   k_col = input$c, 
                   k_row = input$r,
                   limits = ColLimits) %>% 
      layout(margin = list(l = input$l, b = input$b, r='0px'))

    p$elementId <- NULL

    p
  })

  #Render Plot ----
  observeEvent(input$data,{
    output$heatout <- renderPlotly({
      if(!is.null(input$data))
        interactiveHeatmap()
    })
  })

  #Render Data Table ----
  output$tables=DT::renderDataTable(data.sel(),server = T,filter='top',
                                    extensions = c('Scroller','FixedHeader','FixedColumns','Buttons','ColReorder'),
                                    options = list(
                                      dom = 't',
                                      buttons = c('copy', 'csv', 'excel', 'pdf', 'print','colvis'),
                                      colReorder = TRUE,
                                      scrollX = TRUE,
                                      fixedColumns = TRUE,
                                      fixedHeader = TRUE,
                                      deferRender = TRUE,
                                      scrollY = 500,
                                      scroller = TRUE
                                    ))

  #Clone Heatmap ----
  observeEvent({interactiveHeatmap()},{
    h<-interactiveHeatmap()

    l<-list(main = input$main,xlab = input$xlab,ylab = input$ylab,
            row_text_angle = input$row_text_angle,
            column_text_angle = input$column_text_angle,
            dendrogram = input$dendrogram,
            branches_lwd = input$branches_lwd,
            seriate = input$seriation,
            colors=paste0(input$pal,'(',input$ncol,')'),
            distfun_row =  input$distFun_row,
            hclustfun_row = input$hclustFun_row,
            distfun_col = input$distFun_col,
            hclustfun_col = input$hclustFun_col,
            k_col = input$c, 
            k_row = input$r,
            limits = paste(c(input$colorRng_min, input$colorRng_max),collapse=',')
    )

    #l=l[!l=='']
    l=data.frame(Parameter=names(l),Value=do.call('rbind',l),row.names = NULL,stringsAsFactors = F)
    l[which(l$Value==''),2]='NULL'
    paramTbl=print(xtable::xtable(l),type = 'html',include.rownames=FALSE,print.results = F,html.table.attributes = c('border=0'))


    h$width='100%'
    h$height='800px'
    s<-tags$div(style="position: relative; bottom: 5px;",
                HTML(paramTbl),
                tags$em('This heatmap visualization was created using',
                        tags$a(href="https://github.com/yonicd/shinyHeatmaply/",target="_blank",'shinyHeatmaply'),
                        Sys.time()
                )
    )

    output$downloadData <- downloadHandler(
      filename = function() {
        paste("heatmaply-", gsub(' ','_',Sys.time()), ".html", sep="")
      },
      content = function(file) {
        libdir <- paste(tools::file_path_sans_ext(basename(file)),"_files", sep = "")

        htmltools::save_html(htmltools::browsable(htmltools::tagList(h,s)),file=file,libdir = libdir)
        if (!htmlwidgets:::pandoc_available()) {
          stop("Saving a widget with selfcontained = TRUE requires pandoc. For details see:\n", 
               "https://github.com/rstudio/rmarkdown/blob/master/PANDOC.md")
        }

        htmlwidgets:::pandoc_self_contained_html(file, file)

        unlink(libdir, recursive = TRUE)
      }
    )
  })
  #End of Code ----
})

提前感谢解决了这个问题的英雄。最好的奖励，丹尼尔。

Answer 1

问题是条件面板(使用js)和导航栏页面之间的冲突，由于某种原因，默认参数没有被读取，因此应该启用的自动着色没有被读取。