RShiny: почему ggplot geom_rect терпит неудачу с реактивной огранкой? - PullRequest
Новая
       31

RShiny: почему ggplot geom_rect терпит неудачу с реактивной огранкой?

0 голосов
/ 02 мая 2020

Я пытаюсь создать интерактивные графики с 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.

Я предполагаю, что я сделал что-то не так с моей функцией огранки, но я на второй неделе не могу решить эту проблему, поэтому пришло время обратиться за помощью!

Вот упрощенный макет приложения. Я могу добавить две грани, ИЛИ я могу добавить подложку температуры, но попытка обоих результатов приведет к ошибке выше. 

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)

1 Ответ

0 голосов
/ 02 мая 2020

Вот мой дубль (я использовал 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)
...