如何提示用户将下载保存到R中的ggplot2目录

Question

在下面的MWE代码中，单击下载按钮后，我使用ggsave(属于ggplot2(将多个绘图作为单独的文件下载。

问题是它自动将文件保存到默认目录，而不让用户知道文件保存在哪里。

我该如何配置它，以便用户可以指定将文件保存到哪个目录？

Shiny的原生downloadHandler会提示用户选择保存文件的位置，就像我希望下面的一样。但我选择了ggplot2而不是ShinydownloadHandler，因为后者不容易通过单击一个操作按钮下载多个文件。

我找到了一个类似的问题/答案来解决这个问题，但在这种情况下，该解决方案不适用于一键下载多个文件。

MWE代码：

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
library(ggplot2)
matrix1.input <- function(x){
matrixInput(x, 
value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
rows = list(extend = FALSE,  names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2.input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE,  names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}  
matrix.validate <- function(x,y){
a <- y        
a[,1][a[,1]>x] <- x 
b <- diff(a[,1,drop=FALSE]) 
b[b<=0] <- NA               
b <- c(1,b)                 
a <- cbind(a,b)
a <- na.omit(a) 
a <- a[,-c(3),drop=FALSE]         
return(a)}
vector.base <- function(x,y){
a <- rep(y,x) 
b <- seq(1:x) 
c <- data.frame(x = b, y = a) 
return(c)}
vector.multi <- function(x,y,z){                                            
a <- rep(NA, x)
a[y] <- z       
a[seq_len(min(y)-1)] <- a[min(y)] 
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}   
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y  
b <- seq(1:x)                                                     
c <- data.frame(x = b, z = a)                                     
return(c)}
vector.multiFinal <- function(x,y){
vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}
matrix.link <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}
ui <- 
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Dynamic", value=2,
actionButton('showVectorPlotBtn','Vector plots'),
actionButton('showVectorValueBtn','Vector values'),

actionButton("download", "Download"), 

uiOutput("vectorTable")),
id = "tabselected")
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods       <- reactive(input$periods)
base_input    <- reactive(input$base_input)
vector_input  <- reactive(input$vector_input)
vector1_input <- reactive(input$vector1_input)
yld           <- reactiveValues()

vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vector.base(input$periods,x)
else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}

output$Panels <- renderUI({
tagList( 
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showVectorBtn','Show'), 
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))))})

renderUI({
matrix.link("vector_input",input$base_input[1,1])
matrix.link("vector1_input",input$base_input[2,1])})

output$Vectors <- renderUI({input$resetVectorBtn
tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]),
matrix2.input("vector1_input",input$periods,input$base_input[2,1]))})

observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector_input())))
output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector1_input())))

mydata <- reactive(list(
data.frame(vectorVariable(input$base_input[1,1],vector_input())),
data.frame(vectorVariable(input$base_input[2,1],vector1_input()))
) # close list
) # close reactive
nplots <- reactive(length(mydata()))

observeEvent(input$download, {
lapply(1:nplots(), function(i){
ggsave(
paste0("vector",i,".png"), 
plot(mydata()[[i]])
) # close ggsave
}) # close lapply and embedded function
}, ignoreInit = TRUE)

output$table1 <- renderDT({vectorsAll()})

observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})

output$vectorTable <- renderUI({yld$showme})

vectorsAll <- reactive({
cbind(1:periods(),
vectorVariable(input$base_input[1,1],vector_input())[,2],
vectorVariable(input$base_input[2,1],vector1_input())[,2])})})
shinyApp(ui, server) 

Answer 1

脑海中浮现出一些想法，第一个想法是使用textInput指定保存绘图的文件夹路径(~表示主目录(。或者，我们可以将selectInput用于预先指定的目录，供用户选择。最后，出现某种弹出窗口或消息，通知用户绘图保存正确，以防无法访问R的终端。

在ui内部。

textInput('path', 'Enter Path for ggsave',value = '~')

在服务器内部。

observeEvent(input$download, {
lapply(1:nplots(), function(i){
ggsave(
paste0("vector",i,".png"), 
plot(mydata()[[i]]),path = input$path
) # close ggsave
}) # close lapply and embedded function
}, ignoreInit = TRUE)

Answer 2

最后，我很难调整多文件下载功能，以便用户可以轻松地指定将文件保存在哪里。因此，我选择了使用本机函数downHandler的模式对话框，允许用户选择下载哪个文件以及将该文件下载到哪里。downloadHandler在默认下载目录和提示用户将文件保存到哪里方面做得很好。以下是该解决方案的MWE(这偏离了我最初的问题，但在我看来，最终是一种更好的方法(：

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1.input <- function(x){
matrixInput(x, 
value = matrix(c(0.2), 2, 1, dimnames = list(c("A","B"),NULL)),
rows = list(extend = FALSE,  names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2.input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE,  names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}  
matrix.validate <- function(x,y){
a <- y        
a[,1][a[,1]>x] <- x 
b <- diff(a[,1,drop=FALSE]) 
b[b<=0] <- NA               
b <- c(1,b)                 
a <- cbind(a,b)
a <- na.omit(a) 
a <- a[,-c(3),drop=FALSE]         
return(a)}
vector.base <- function(x,y){
a <- rep(y,x) 
b <- seq(1:x) 
c <- data.frame(x = b, y = a) 
return(c)}
vector.multi <- function(x,y,z){                                            
a <- rep(NA, x)
a[y] <- z       
a[seq_len(min(y)-1)] <- a[min(y)] 
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}   
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y  
b <- seq(1:x)                                                     
c <- data.frame(x = b, z = a)                                     
return(c)}
vector.multiFinal <- function(x,y){
vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}
matrix.link <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}
ui <- 
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Dynamic", value=2,
actionButton('showVectorPlotBtn','Vector plots'),
actionButton('showVectorValueBtn','Vector values'),

actionButton("showDownload", "Download"),

uiOutput("vectorTable")),
id = "tabselected")
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods       <- reactive(input$periods)
base_input    <- reactive(input$base_input)
vector1_input <- reactive(input$vector1_input)
vector2_input <- reactive(input$vector2_input)
yld           <- reactiveValues()

vectorVariable <- function(x,y){
if(input$showVectorBtn == 0) vector.base(input$periods,x)
else vector.multiFinal(input$periods,matrix.validate(input$periods,y))}

output$Panels <- renderUI({
tagList( 
conditionalPanel(
condition="input.tabselected==2",
sliderInput('periods','',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showVectorBtn','Show'), 
actionButton('hideVectorBtn','Hide'),
actionButton('resetVectorBtn','Reset'),
hidden(uiOutput("Vectors"))))})

renderUI({
matrix.link("vector1_input",input$base_input[1,1])
matrix.link("vector2_input",input$base_input[2,1])})

output$Vectors <- renderUI({input$resetVectorBtn
tagList(matrix2.input("vector1_input",input$periods,input$base_input[1,1]),
matrix2.input("vector2_input",input$periods,input$base_input[2,1]))})

observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

output$graph1 <- renderPlot(plot(vectorVariable(input$base_input[1,1],vector1_input())))
output$graph2 <- renderPlot(plot(vectorVariable(input$base_input[2,1],vector2_input())))

output$download <- downloadHandler(
filename = function() {
if (input$downloadItem == "Vector2 plot") {paste("Vector2Plot","png",sep=".")}
else if (input$downloadItem == "Vector values") {paste("vectorValues","csv",sep=".")}
else {paste("Vector1Plot","png",sep=".")}
},
content = function(file){

if(input$downloadItem == "Vector2 plot"){
png(file)
plot(vectorVariable(input$base_input[2,1],vector2_input()))
dev.off()
} # close if statement

else if(input$downloadItem == "Vector values"){write.csv(vectorsAll(),file,row.names=FALSE)}

else {
png(file)
plot(vectorVariable(input$base_input[1,1],vector1_input()))
dev.off()
} # close else
} # close content function
) # close download handler

observeEvent(input$showDownload,
{showModal(modalDialog(
selectInput("downloadItem","Select item to download:",
c("Vector1 plot","Vector2 plot","Vector values","Card asset amortization values")),
downloadButton("download", "Download")

) # close modalDialog
) # close showModal
} # close showModal function
) # close observeEvent

output$table1 <- renderDT({vectorsAll()})

observeEvent(input$showVectorPlotBtn,{yld$showme <- tagList(plotOutput("graph1"), plotOutput("graph2"))},ignoreNULL = FALSE)
observeEvent(input$showVectorValueBtn,{yld$showme <- DTOutput("table1")})

output$vectorTable <- renderUI({yld$showme})

vectorsAll <- reactive({
cbind(1:periods(),
vectorVariable(input$base_input[1,1],vector1_input())[,2],
vectorVariable(input$base_input[2,1],vector2_input())[,2])})})
shinyApp(ui, server)