在 R Shiny 应用程序中下载 ggplot2 和 plotly 对象答案

【问题标题】：Downloading a ggplot2 and a plotly object in an R Shiny app在 R Shiny 应用程序中下载 ggplot2 和 plotly 对象
【发布时间】：2020-08-13 03:16:45
【问题描述】：

这个问题是this post 的后续问题。

我有一个Rshiny app，它同时使用R 的plotly 和ggplot2 来生成和显示数字。

因为在shiny 中渲染plotly 数字需要plotly 的renderPlotly function 我必须定义两个render 函数，一个用于plotly，另一个用于ggplot2。

我的问题是如何定义一个downloadHandler，它将使用htmlwidgets::saveWidget 将plotly 对象保存为html，使用ggplot2::ggsave 将ggplot2 对象保存为pdf。

这是示例数据：

set.seed(1)

meta.df <- data.frame(cell = c(paste0("c_",1:1000,"_1w"), paste0("c_",1:1000,"_2w"), paste0("c_",1:1000,"_3w")),
                      cluster = c(sample(c("cl1","cl2","cl3"),1000,replace=T)),
                      age = c(rep(1,1000),rep(2,1000),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,1), nrow=20, ncol=1000, dimnames=list(paste0("g",1:20),meta.df$cell[1001:2000])),
                        matrix(rnorm(20*1000,3,1), nrow=20, ncol=1000, dimnames=list(paste0("g",1:20),meta.df$cell[2001:3000])))

这是我目前拥有的应用代码：

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,showticklabels=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),value=expression.mat[gene.idx,]),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,y=value,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")
    }
  })
  
  output$saveFigure <- downloadHandler(
    if (input$group == "age" && input$plotType == "Distribution Plot") {
      filename = function() {
        paste0(input$plotType,".pdf")
      }
    } else{
      filename = function() {
        paste0(input$plotType,".html")
      }
    },
    content = function(file) {
      if(input$plotType == "Scatter Plot"){
        htmlwidgets::saveWidget(scatter.plot(),file=file)
      } else if(input$plotType == "Distribution Plot" && input$group != "age"){
        htmlwidgets::saveWidget(distribution.plot(),file=file)
      } else{
        ggsave(distribution.plot(),filename=file)
      }
    }
  )
}


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;}"),
        tags$style(type="text/css",".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"),
      downloadButton('saveFigure', 'Save figure')
    ),
    mainPanel(
      plotly::plotlyOutput("out.plot_plotly"),
      plotOutput("out.plot_plot")
    )
  )
)

shinyApp(ui = ui, server = server)

plotly 对象确实会保存为 html，但对于input$plotType == "Distribution Plot" && input$group == "age" 选项，虽然Save figure 按钮确实会弹出保存对话框，但不会下载和保存图形。

有什么想法吗？

【问题讨论】：

我已经安全地依赖于（每一个？）情节图（通常与缩放、平移、框选...）中可用的“以 png 格式下载图”图标。否则，我看到的唯一方法是在 plotly.com/r/static-image-export 上讨论，理由是需要 orca 实用程序。（我对orca 没有运气，所以我继续前进。）没有orca，我相信downloadHandler 不适合你。
感谢@r2evans 的评论。我的情况可能略有不同，因为我试图将 plotly 图保存为 html（以从悬停文本中受益）而不是静态 pdf/png。
有趣（有趣）。有关的？ plotly.com/python/interactive-html-export（不幸的是，尽管大多数页面都有补充，但 that 页面没有 /r/ 变体）。我在 R 的 plotly 中没有看到该功能，所以他们可能还没有实现它。
假设您要在R 中将plotly 数字保存为html，则：htmlwidgets::saveWidget(object,file) 命令，我试图在downloadHandler 中使用它。跨度>
您可以调整或扩展此处给出的答案：stackoverflow.com/questions/62378430/…

标签： r shiny download handler

【解决方案1】：

我不得不改变两件事：

在ggsave 呼叫中添加device（请参阅@YBS 链接的答案，谢谢！）
将文件名的逻辑放入函数中，而不是根据情节定义不同的函数

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

set.seed(1)

meta.df <- data.frame(cell = c(paste0("c_",1:1000,"_1w"), paste0("c_",1:1000,"_2w"), paste0("c_",1:1000,"_3w")),
                      cluster = c(sample(c("cl1","cl2","cl3"),1000,replace=T)),
                      age = c(rep(1,1000),rep(2,1000),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,1), nrow=20, ncol=1000, dimnames=list(paste0("g",1:20),meta.df$cell[1001:2000])),
                        matrix(rnorm(20*1000,3,1), nrow=20, ncol=1000, dimnames=list(paste0("g",1:20),meta.df$cell[2001:3000])))

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,showticklabels=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),value=expression.mat[gene.idx,]),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,y=value,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")
    }
  })
  
  output$saveFigure <- downloadHandler(
    filename = function() {
      if (input$group == "age" && input$plotType == "Distribution Plot") {
        
          paste0(input$plotType,".pdf")
       
      } else{
        
          paste0(input$plotType,".html")
        
      }
    },
    content = function(file) {
      if(input$plotType == "Scatter Plot"){
        htmlwidgets::saveWidget(scatter.plot(),file=file)
      } else if(input$plotType == "Distribution Plot" && input$group != "age"){
        htmlwidgets::saveWidget(distribution.plot(),file=file)
      } else{
        ggsave(filename = file,
               plot = distribution.plot(),
               device = "pdf")
      }
    }
  )
}


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;}"),
        tags$style(type="text/css",".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"),
      downloadButton('saveFigure', 'Save figure')
    ),
    mainPanel(
      plotly::plotlyOutput("out.plot_plotly"),
      plotOutput("out.plot_plot")
    )
  )
)

shinyApp(ui = ui, server = server)

【讨论】：