R Shiny：为什么 ggplot geom_rect 因反应刻面而失败？

Question

我正在尝试使用 Shiny 创建交互式绘图，用户可以在其中选择分面变量。我还想在点/线数据下方绘制温度数据。这一切都很好，直到我尝试合并一个反应分面函数并添加一个 geom_rect 调用，当我收到错误时：

Warning: Error in : Assigned data `layout$PANEL[match(keys$x, keys$y)]` must be compatible with existing data.
x Existing data has 1094 rows.
x Assigned data has 32 rows.
i Only vectors of size 1 are recycled.

我假设我的分面功能做错了，但我在第 2 周无法解决这个问题，所以是时候寻求帮助了！

这是应用的简化模型。我可以添加两个方面，或者我可以添加温度衬底，但是尝试这两种方法都会导致上述错误。

library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)

{ # Setup ----
    # Create a dummy data frame
    sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
    region <- rep(c("North", "South", "East", "West"), times = 8)
    elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
    date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
    affected <- runif(32, min = 0, max = 1)
    sitedata <- data.frame(date, sitename, region, elevation, affected)

    # Load and process external temperature data
    noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)

    noaacrw <- noaacrw %>%
        mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
        mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
        mutate(SST_AVG = `SST@90th_HS`) %>%
        select(DateStart, DateEnd, SST_AVG) %>%
        filter(DateStart > as.Date("2015-01-01")) %>%
        filter(DateEnd < as.Date("2018-01-01"))

}

# UI ----

ui <- fluidPage(
    fluidRow(
        box(
            title = "Choose your data", width = 3, solidHeader = TRUE,
            selectInput("facet_select", "Select faceting variable:",
                        choices = list("None" = "none",
                                       "Region" = "region",
                                       "Elevation" = "elevation"),
                        selected = c("None")),
            selectInput("facet2_select", "Select second faceting variable",
                        choices = list("None" = "none",
                                       "Region" = "region",
                                       "Elevation" = "elevation")),
            checkboxInput("show_temp", "Show temperature data", FALSE)
        ),

        box(
            title = "See your data output", width = 9, solidHeader = TRUE,
            plotOutput("siteplot", height = 500)
        )
    )
)

和服务器端：

server <- function(input, output) {


    facet1 <- reactive({
        if(input$facet_select == "region"){return(region)}  
        if(input$facet_select == "elevation"){return(elevation)}
    })

    facet2 <- reactive({
        if(input$facet_select == "region"){return(region)}
        if(input$facet_select == "elevation"){return(elevation)}
    })

    faceter <- reactive({
        if(input$facet_select == "none"){return(NULL)}
        else if(input$facet_select != "none" & input$facet2_select == "none")
             {return(list(facet_grid(facet1() ~ .)))}
        else if(input$facet_select != "none" & input$facet2_select != "none")
             {return(list(facet_grid(facet1() ~ facet2())))}
    })

    temperature <- reactive({
        if(input$show_temp == FALSE){return(NULL)}
        else if(input$show_temp == TRUE){return(list(
            geom_rect(data = noaacrw, 
                      aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
                      position = "identity", show.legend = TRUE, alpha = 0.5),
            scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
    })



output$siteplot <- renderPlot({

    ggplot()+
        temperature()+
        geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
        geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
        #facet_grid(elevation ~ region) <-- this works!
        faceter()  # <- but this does not!
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

这是我的看法（我使用了syms(...)）。它至少在 R4.0 下工作：

library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)
library(ggplot2)
library(dplyr)

{ # Setup ----
    # Create a dummy data frame
    sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
    region <- rep(c("North", "South", "East", "West"), times = 8)
    elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
    date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
    affected <- runif(32, min = 0, max = 1)
    sitedata <- data.frame(date, sitename, region, elevation, affected)

    # Load and process external temperature data
    noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)

    noaacrw <- noaacrw %>%
        mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
        mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
        mutate(SST_AVG = `SST@90th_HS`) %>%
        select(DateStart, DateEnd, SST_AVG) %>%
        filter(DateStart > as.Date("2015-01-01")) %>%
        filter(DateEnd < as.Date("2018-01-01"))

}

# UI ----

ui <- fluidPage(
    fluidRow(
        box(
            title = "Choose your data", width = 3, solidHeader = TRUE,
            selectInput("facet_select", "Select faceting variable:",
                        choices = list("None" = NULL,
                                       "Region" = "region",
                                       "Elevation" = "elevation"),
                        selected = c("None"), 
                        multiple = TRUE),
            checkboxInput("show_temp", "Show temperature data", FALSE)
        ),

        box(
            title = "See your data output", width = 9, solidHeader = TRUE,
            plotOutput("siteplot", height = 500)
        )
    )
)



server <- function(input, output) {
    temperature <- reactive({
        if(!input$show_temp){return(NULL)}
        else if(input$show_temp){return(list(
            geom_rect(data = noaacrw, 
                      aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
                      position = "identity", show.legend = TRUE, alpha = 0.5),
            scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
    })

   makePlot <- function(...){
       p <- ggplot()+
           temperature()+
           geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
           geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)
       if(length(eval(substitute(alist(...)))) > 0){
           p <- p + facet_grid(syms(...))
           }
       return(p)
   }

    output$siteplot <- renderPlot({
        makePlot(input$facet_select)
    })
}

# Run the application 
shinyApp(ui = ui, server = server)