在R Shiny应用程序中渲染ggplot2和一个可绘制对象

问题描述

我有一个R shiny应用程序，它同时使用R的{​​{1}}和plotly来生成和显示图形。

由于要在ggplot2中绘制plotly图形需要shiny的{​​{1}}函数，因此plotly图形被转换为renderPlotly对象。 ggplot2部分，将它们弄乱了。

这是一个例子。 首先，生成一些数据：

plotly

这是应用程序代码：

renderPlotly

如果用户选择set.seed(1) meta.df <- data.frame(cell = c(paste0("c_",1:1000,"_1w"),paste0("c_","_2w"),"_3w")),cluster = c(sample(c("cl1","cl2","cl3"),1000,replace=T)),age = c(rep(1,1000),rep(2,rep(3,1000)),x = rnorm(3000),y = rnorm(3000)) expression.mat <- cbind(matrix(rnorm(20*1000,1,1),nrow=20,ncol=1000,dimnames=list(paste0("g",1:20),meta.df$cell[1:1000])),matrix(rnorm(20*1000,2,meta.df$cell[1001:2000])),3,meta.df$cell[2001:3000]))) library(shiny) library(dplyr) library(ggplot2) library(ggpmisc) server <- function(input,output,session) { output$gene <- renderUI({ selectInput("gene","Select Gene to Display",choices = rownames(expression.mat)) }) output$group <- renderUI({ if(input$plotType == "Distribution Plot"){ selectInput("group","Select Group",choices = c("cluster","age")) } }) scatter.plot <- reactive({ scatter.plot <- NULL if(!is.null(input$gene)){ gene.idx <- which(rownames(expression.mat) == input$gene) plot.df <- suppressWarnings(meta.df %>% dplyr::left_join(data.frame(cell=colnames(expression.mat),value=expression.mat[gene.idx,]),by=c("cell"="cell"))) scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$value,x=plot.df$x,y=plot.df$y,showlegend=F,colors=colorRamp(c("lightgray","darkred"))) %>% plotly::layout(title=input$gene,xaxis=list(zeroline=F,showticklabels=F,showgrid=F),yaxis=list(zeroline=F,showgrid=F)) %>% plotly::colorbar(limits=c(min(plot.df$value,na.rm=T),max(plot.df$value,na.rm=T)),len=0.4,title="Scaled Expression")) } return(scatter.plot) }) distribution.plot <- reactive({ distribution.plot <- NULL if(!is.null(input$gene) & !is.null(input$group)){ gene.idx <- which(rownames(expression.mat) == input$gene) plot.df <- suppressWarnings(meta.df %>% dplyr::left_join(data.frame(cell=colnames(expression.mat),by=c("cell"="cell"))) if(input$group == "cluster"){ distribution.plot <- suppressWarnings(plotly::plot_ly(x=plot.df$cluster,y=plot.df$value,split=plot.df$cluster,type='violin',box=list(visible=T),points=T,color=plot.df$cluster,showlegend=F) %>% plotly::layout(title=input$gene,xaxis=list(title=input$group,zeroline=F),yaxis=list(title="Scaled Expression",zeroline=F))) } else{ plot.df <- plot.df %>% dplyr::mutate(time=age) %>% dplyr::arrange(time) plot.df$age <- factor(plot.df$age,levels=unique(plot.df$age)) distribution.plot <- suppressWarnings(ggplot(plot.df,aes(x=time,y=value)) + geom_violin(aes(fill=age,color=age),alpha=0.3) + geom_boxplot(width=0.1,aes(color=age),fill=NA) + geom_smooth(mapping=aes(x=time,y=value,group=cluster),color="black",method='lm',size=1,se=T) + stat_poly_eq(mapping=aes(x=time,group=cluster,label=stat(p.value.label)),formula=y~x,parse=T,npcx="center",npcy="bottom") + scale_x_discrete(name=NULL,labels=levels(plot.df$cluster),breaks=unique(plot.df$time)) + facet_wrap(~cluster) + theme_minimal() + ylab(paste0("#",input$gene," Scaled Expressioh"))+theme(legend.title=element_blank())) } } return(distribution.plot) }) output$out.plot <- plotly::renderPlotly({ if(input$plotType == "Scatter Plot"){ scatter.plot() } else if(input$plotType == "Distribution Plot"){ distribution.plot() } }) } ui <- fluidPage( titlePanel("Explorer"),sidebarLayout( sidebarPanel( tags$head( tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome,Safari,Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),tags$style(type="text/css","#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),selectInput("plotType","Plot Type",choices = c("Scatter Plot","Distribution Plot")),uiOutput("gene"),uiOutput("group"),),mainPanel( plotly::plotlyOutput("out.plot") ) ) ) shinyApp(ui = ui,server = server) 和“年龄” Distribution Plot，则将用Plot Type和Group生成图形。作为ggplot2对象时，这些数字如下所示：

P0734R0 Concepts

但是，随着ggpmisc对象（我想象ggplot2部分使用plotly的{​​{1}}函数从plotly::renderPlotly对象转换），它变成：

如您所见，底部的P值丢失了，图例为“行为异常”。

首选解决方案是，如果对象是ggplot2对象，请使用plotly函数；如果对象是ggplotly，请使用plotly::renderPlotly，但是我不建议使用不知道如何实现（我认为要解决和更正plotly对象转换为render对象时所做的修改）。

有什么主意吗？

解决方法

我认为最简单的解决方案是定义2个输出，一个位于plotly图前，另一个用于ggplot图，并使用shinyjs根据输入：

set.seed(1)

meta.df <- data.frame(cell = c(paste0("c_",1:1000,"_1w"),paste0("c_","_2w"),"_3w")),cluster = c(sample(c("cl1","cl2","cl3"),1000,replace=T)),age = c(rep(1,1000),rep(2,rep(3,1000)),x = rnorm(3000),y = rnorm(3000))

expression.mat <- cbind(matrix(rnorm(20*1000,1,1),nrow=20,ncol=1000,dimnames=list(paste0("g",1:20),meta.df$cell[1:1000])),matrix(rnorm(20*1000,2,meta.df$cell[1001:2000])),3,meta.df$cell[2001:3000])))

library(shiny)
library(dplyr)
library(ggplot2)
library(ggpmisc)
library(shinyjs)

server <- function(input,output,session)
{
  output$gene <- renderUI({
    selectInput("gene","Select Gene to Display",choices = rownames(expression.mat))
  })
  
  output$group <- renderUI({
    if(input$plotType == "Distribution Plot"){
      selectInput("group","Select Group",choices = c("cluster","age"))
    }
  })
  
  scatter.plot <- reactive({
    scatter.plot <- NULL
    if(!is.null(input$gene)){
      gene.idx <- which(rownames(expression.mat) == input$gene)
      plot.df <- suppressWarnings(meta.df %>% dplyr::left_join(data.frame(cell=colnames(expression.mat),value=expression.mat[gene.idx,]),by=c("cell"="cell")))
      scatter.plot <- suppressWarnings(plotly::plot_ly(marker=list(size=3),type='scatter',mode="markers",color=plot.df$value,x=plot.df$x,y=plot.df$y,showlegend=F,colors=colorRamp(c("lightgray","darkred"))) %>%
                                         plotly::layout(title=input$gene,xaxis=list(zeroline=F,showticklabels=F,showgrid=F),yaxis=list(zeroline=F,showgrid=F)) %>%
                                         plotly::colorbar(limits=c(min(plot.df$value,na.rm=T),max(plot.df$value,na.rm=T)),len=0.4,title="Scaled Expression"))
    }
    return(scatter.plot)
  })
  
  distribution.plot <- reactive({
    distribution.plot <- NULL
    if(!is.null(input$gene) & !is.null(input$group)){
      gene.idx <- which(rownames(expression.mat) == input$gene)
      plot.df <- suppressWarnings(meta.df %>% dplyr::left_join(data.frame(cell=colnames(expression.mat),by=c("cell"="cell")))
      if(input$group == "cluster"){
        distribution.plot <- suppressWarnings(plotly::plot_ly(x=plot.df$cluster,y=plot.df$value,split=plot.df$cluster,type='violin',box=list(visible=T),points=T,color=plot.df$cluster,showlegend=F) %>%
                                                plotly::layout(title=input$gene,xaxis=list(title=input$group,zeroline=F),yaxis=list(title="Scaled Expression",zeroline=F)))
      } else{
        plot.df <- plot.df %>% dplyr::mutate(time=age) %>% dplyr::arrange(time)
        plot.df$age <- factor(plot.df$age,levels=unique(plot.df$age))
        distribution.plot <- suppressWarnings(ggplot(plot.df,aes(x=time,y=value)) +
                                                geom_violin(aes(fill=age,color=age),alpha=0.3) +
                                                geom_boxplot(width=0.1,aes(color=age),fill=NA) +
                                                geom_smooth(mapping=aes(x=time,y=value,group=cluster),color="black",method='lm',size=1,se=T) +
                                                stat_poly_eq(mapping=aes(x=time,group=cluster,label=stat(p.value.label)),formula=y~x,parse=T,npcx="center",npcy="bottom") +
                                                scale_x_discrete(name=NULL,labels=levels(plot.df$cluster),breaks=unique(plot.df$time)) +
                                                facet_wrap(~cluster) + theme_minimal() + ylab(paste0("#",input$gene," Scaled Expressioh"))+theme(legend.title=element_blank()))
      }
    }
    return(distribution.plot)
  })
  
  output$out.plot_plotly <- plotly::renderPlotly({
    if(input$plotType == "Scatter Plot"){
      scatter.plot()
    } else {
      req(input$group)
      if (input$plotType == "Distribution Plot" && input$group != "age"){
        distribution.plot()
      }
    }
  })
  
  output$out.plot_plot <- renderPlot({
    req(input$group)
    if (input$plotType == "Distribution Plot" && input$group == "age") {
      distribution.plot()
    }
  })
  
  observeEvent(c(input$group,input$plotType),{
    req(input$group)
    if (input$group == "age" && input$plotType == "Distribution Plot") {
      hide("out.plot_plotly")
      show("out.plot_plot")
    } else {
      hide("out.plot_plot")
      show("out.plot_plotly")
    }
  })
}


ui <- fluidPage(
  titlePanel("Explorer"),useShinyjs(),sidebarLayout(
    sidebarPanel(
      tags$head(
        tags$style(HTML(".multicol {-webkit-column-count: 3; /* Chrome,Safari,Opera */-moz-column-count: 3; /* Firefox */column-count: 3;}")),tags$style(type="text/css","#loadmessage {position: fixed;top: 0px;left: 0px;width: 100%;padding: 5px 0px 5px 0px;text-align: center;font-weight: bold;font-size: 100%;color: #000000;background-color: #CCFF66;z-index: 105;}"),".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }")),conditionalPanel(condition="$('html').hasClass('shiny-busy')",tags$div("In Progress...",id="loadmessage")),selectInput("plotType","Plot Type",choices = c("Scatter Plot","Distribution Plot")),uiOutput("gene"),uiOutput("group"),),mainPanel(
      plotly::plotlyOutput("out.plot_plotly"),plotOutput("out.plot_plot")
    )
  )
)

shinyApp(ui = ui,server = server)