如何在 Shiny 仪表板的多个选项卡中为图形创建通用图例？

Question

我希望 5 个图表具有 相同 图例。 2 个图表位于 Shiny 应用的第一个选项卡上，3 个图表位于第二个选项卡上。

我已尝试添加图例，但图例在 both 上占用了太太多空间选项卡。

有人可以告诉我一个更好的方法吗？

这是一个代表：

# Reprex.
library(shiny)
library(shinydashboard)
library(xts)
library(quantmod)
# Data Engineering.
# Some fake data.

series1 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series2 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series3 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series4 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series5 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)

# A function to make a plot from a given series.

myplot <- function(x,n) {
    chartSeries(x,theme=chartTheme("white"),name=n);
    addLines(h=c(mean(x),mean(x)+sd(x),h=mean(x)-sd(x)),col=c("red","blue","blue"))  
    }

# Setup for Shiny

ui <- dashboardPage(
    dashboardHeader(title = "Mydashboard"),
    dashboardSidebar(
        sidebarMenu(
            menuItem("Tab 1", tabName = "mytab1"),
            menuItem("Tab 2", tabName = "mytab2")
        )
    ),
    dashboardBody(
        tabItems(
            tabItem(tabName="mytab1",
                    box(plotOutput("graph1")),
                    box(plotOutput("graph2"))
                    ),
            tabItem(tabName="mytab2",
                    box(plotOutput("graph3")),
                    box(plotOutput("graph4")),
                    box(plotOutput("graph5")))
        ),
        fluidRow(
            box(plotOutput("mylegend"),width=12,height=NULL)
        )
    )
)


server <- function(input,output){
    output$graph1 <- renderPlot({
        myplot(series1,"Series 1")
    })
    output$graph2 <- renderPlot({
        myplot(series2,"Series 2")
    })   
    output$graph3 <- renderPlot({
        myplot(series3,"Series 3")
    })
    output$graph4 <- renderPlot({
        myplot(series4,"Series 4")
    })
    output$graph5 <- renderPlot({
        myplot(series5,"Series 5")
    })

# I make an empty (NULL) plot since I am interested only in the legend.    

    output$mylegend <- renderPlot({
        plot(NULL ,xaxt='n',yaxt='n',bty='n',ylab='',xlab='', xlim=c(0,.1), ylim=c(0,.1))
        legend("bottom", legend=c("Mean","+/- One Standard Deviation"),lty=c(1,1),col=c("red","blue"))
        
    })
}

shinyApp(ui,server)

我知道我可以做 cowplot 并创建一个包含多个图和图例的大图，但它不再是一个闪亮的 dashboard。

我希望创建一个带有一个图例的仪表板，这两个标签恰好是相同的。

请在此处查看应用程序第一个选项卡顶部和底部的屏幕截图：

Answer 1

这是一种将图例移动到侧边栏的方法。这看起来也不错。

我在此处发布了一个完整示例，以便于复制和粘贴。

# Reprex.
library(shiny)
library(shinydashboard)
library(xts)
library(quantmod)
# Data Engineering.
# Some fake data.

series1 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series2 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series3 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series4 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series5 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)

# A function to make a plot from a given series.

myplot <- function(x,n) {
    chartSeries(x,theme=chartTheme("white"),name=n);
    addLines(h=c(mean(x),mean(x)+sd(x),h=mean(x)-sd(x)),col=c("red","blue","blue"))  
    }

ui <- dashboardPage(
    dashboardHeader(title = "Mydashboard"),
    dashboardSidebar(
        sidebarMenu(
            menuItem("Tab 1", tabName = "mytab1"),
            menuItem("Tab 2", tabName = "mytab2"),
            plotOutput("mylegend")
        )
    ),
    dashboardBody(
        tabItems(
            tabItem(tabName="mytab1",
                    fluidRow(box(plotOutput("graph1")),
                    box(plotOutput("graph2")))
                    ),
            tabItem(tabName="mytab2",
                    fluidRow(box(plotOutput("graph3")),
                             box(plotOutput("graph4"))),
                    fluidRow(box(plotOutput("graph5")))
                    )
        )        
    )
)
server <- function(input,output)({
    output$graph1 <- renderPlot({
        myplot(series1,"Series 1")
    })
    output$graph2 <- renderPlot({
        myplot(series2,"Series 2")
    })   
    output$graph3 <- renderPlot({
        myplot(series3,"Series 3")
    })
    output$graph4 <- renderPlot({
        myplot(series4,"Series 4")
    })
    output$graph5 <- renderPlot({
        myplot(series5,"Series 5")
    })
    
    output$mylegend <- renderPlot({
        par(mai=rep(0.01,4))
        plot(NULL ,xaxt='n',yaxt='n',bty='n',ylab='',xlab='', xlim=c(0,.1), ylim=c(0,.1))
        legend("center", legend=c("Mean","+/- One Standard Deviation"),lty=c(1,1),col=c("red","blue"))
        
    },height=50)
})

shinyApp(ui,server)

下面是上面app对应的截图：

这里是另一种可以展示的方式：

我可以将图例移动到页脚。我希望我可以删除两个选项卡上图例下方的空格。

我还想知道如何为页脚设置 CSS 主题，以便仅在页脚的 CENTER 后面有白色背景。

library(shiny)
library(shinydashboard)
library(xts)
library(quantmod)
# Data Engineering.
# Some fake data.

series1 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series2 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series3 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series4 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)
series5 <- xts(cumsum(rnorm(365)),order.by = Sys.Date()-1:365)

# A function to make a plot from a given series.

myplot <- function(x,n) {
    chartSeries(x,theme=chartTheme("white"),name=n);
    addLines(h=c(mean(x),mean(x)+sd(x),h=mean(x)-sd(x)),col=c("red","blue","blue"))  
    }

# Setup for Shiny

ui <- dashboardPage(
    dashboardHeader(title = "Mydashboard"),
    dashboardSidebar(
        sidebarMenu(
            menuItem("Tab 1", tabName = "mytab1"),
            menuItem("Tab 2", tabName = "mytab2")
        )
    ),
    dashboardBody(
        tabItems(
            tabItem(tabName="mytab1",
                    fluidRow(box(plotOutput("graph1")),
                    box(plotOutput("graph2")))
                    ),
            tabItem(tabName="mytab2",
                    fluidRow(box(plotOutput("graph3")),
                             box(plotOutput("graph4"))),
                    fluidRow(box(plotOutput("graph5")))
                    )
        ),
        div(class="footer",
            plotOutput("mylegend")
            )
        )        
    )


server <- function(input,output)({
    output$graph1 <- renderPlot({
        myplot(series1,"Series 1")
    })
    output$graph2 <- renderPlot({
        myplot(series2,"Series 2")
    })   
    output$graph3 <- renderPlot({
        myplot(series3,"Series 3")
    })
    output$graph4 <- renderPlot({
        myplot(series4,"Series 4")
    })
    output$graph5 <- renderPlot({
        myplot(series5,"Series 5")
    })
    
    output$mylegend <- renderPlot({
        par(mai=rep(0.01,4))
        plot(NULL ,xaxt='n',yaxt='n',bty='n',ylab='',xlab='', xlim=c(0,.1), ylim=c(0,.1))
        legend("center", legend=c("Mean","+/- One Standard Deviation"),lty=c(1,1),col=c("red","blue"))
        
    },height=50)
})

shinyApp(ui,server)

这是我的查询的 2 个屏幕截图：

我希望仅在页脚中心（图例所在的位置）后面有白色背景：

我希望删除页脚下方的空白区域：