Non-reactive legend in Shiny

Question

How can I create a static legend in this Shiny App?

The legend must contain all 4 anomaly factor levels, regardless if they are present in the reactive plot. The factor levels are NORMAL, TENTATIVE, LOW, and HIGH

The input data-frame is automatically created in the script below. The color and shape of the legend points and plot points should match.

I also must keep the hover information presently coded into the aes_string()

# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)


# Create input dataframe
DF <- data.frame(
  recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
  Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
  CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
  startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
  companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
  wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
  Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
  finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
  Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
  Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
)  %>%
  mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))



# Info columns
VARS_info <- c('recordID', 'startDate', 'Category', 'CategoryTRUEFALSE', 'Duration', 'Anomaly')

# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')







# UI
ui <- navbarPage(title = "Anomaly Browser",
                 
                 
                 tabPanel("Browse data",
                          sidebarLayout(
                            sidebarPanel(
                              
                              
                              selectInput(inputId = "companyName",
                                          label = "Rail haul provider: ",
                                          choices = sort(unique(Shiny$companyName)),
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "wayPoint",
                                          label = "Load point: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "capacity",
                                          label = "Capacity: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              
                              selectInput(inputId = "finalDestination",
                                          label = "Terminal: ",
                                          choices = NULL,
                                          multiple = FALSE),
                              
                              br(),
                              br(),
                              
                              
                              
                              switchInput(inputId = "category",
                                          onLabel = "X",
                                          offLabel = "Z",
                                          onStatus = "GreenStatus",
                                          offStatus = "RedStatus",
                                          inline = TRUE,
                                          value = TRUE,
                                          size = 'large'
                              ),
                              
                              
                              
                              br(),
                              br(),
                              downloadLink("downloadData", "Download plot data"),
                              br(),
                              width = 2, 
                              
                              # switchInput color while on
                              tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
                                       .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
                                        background: green;
                                        color: white;
                                        }'))),
                              
                              # switchInput color while off
                              tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
                                       .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
                                        background: darkred;
                                        color: white;
                                        }'))),
                              
                            ),
                            
                            mainPanel(
                              
                              plotlyOutput(outputId = "scatterplot", width = "120%", height = "800px"),
                              DT::dataTableOutput(outputId = "Table1", width = "125%")
                              
                            ))))









# Server
server <- function(input, output, session) {
  
  
  observeEvent(input$companyName,{
    updateSelectInput(session,'wayPoint',
                      choices=sort(unique(Shiny$wayPoint[Shiny$companyName %in% input$companyName])))
  })
  
  
  observeEvent(input$wayPoint,{
    updateSelectInput(session,'capacity',
                      choices=sort(unique(Shiny$Capacity[Shiny$wayPoint %in% input$wayPoint &
                                                           Shiny$companyName %in% input$companyName])))
    
    
  })
  
  observeEvent(input$capacity,{
    updateSelectInput(session,'finalDestination',
                      choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
                                                               Shiny$wayPoint %in% input$wayPoint &
                                                               Shiny$companyName %in% input$companyName])))
  })
  
  observeEvent(input$wayPoint,{
    updateSelectInput(session,'finalDestination',
                      choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
                                                               Shiny$wayPoint %in% input$wayPoint &
                                                               Shiny$companyName %in% input$companyName])))
  })
  
  
  
  
  
  observeEvent(input$finalDestination,{
    updateSelectInput(session,'category',
                      choices=sort(unique(Shiny$Category[Shiny$finalDestination %in% input$finalDestination &
                                                           Shiny$Capacity == input$capacity &
                                                           Shiny$wayPoint %in% input$wayPoint &
                                                           Shiny$companyName %in% input$companyName])))
  })
  
  
  
  # Selected
  selected1 <- reactive({
    req(input$companyName, input$wayPoint, input$capacity, input$finalDestination)
    Shiny %>%
      select(all_of(VARS_info), all_of(VARS_selector)) %>%
      filter(companyName %in% input$companyName &
               wayPoint %in% input$wayPoint &
               Capacity == input$capacity &
               finalDestination %in% input$finalDestination &
               CategoryTRUEFALSE %in% input$category) %>%
      select(-CategoryTRUEFALSE)
  })
  
  
  
  
  
  
  # Create scatterplot object the plotOutput function is expecting
  output$scatterplot <- renderPlotly({
    
    p <- ggplot(data = selected1(), aes_string("startDate", "Duration",
                                               A = "startDate", B = "Duration", C = "recordID", D = 'Anomaly'))
    p  <- p + ggtitle(paste0(input$companyName, " - ", input$wayPoint, " - ", input$finalDestination, " - ", input$capacity, " (", unique(selected1()$Category), ")")) +
      xlab('Cycle Start Date') + ylab("Duration  (mins)") + theme(text = element_text(size = 13))
    
    p  <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
      
      geom_smooth(method = "gam", formula = y ~ s(x, bs = "cs", k = 1), colour = "black", lwd = 0.7, se = FALSE)
    
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='NORMAL'),],
                         pch=21, fill= NA, size=1.0, colour="darkgreen", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='TENTATIVE'),],
                         pch=21, fill= NA, size=1.0, colour="royalblue3", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='LOW'),],
                         pch=21, fill= NA, size=1.0, colour="orange", stroke=1.5)
    p  <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='HIGH'),],
                         pch=21, fill= NA, size=1.0, colour="red", stroke=1.5)
    
    
    ggplotly(p, tooltip = c("A", "B", "C", "D"))
    
  })
  
  
  
  
  # Data table Tab-1
  output$Table1 <- DT::renderDataTable({
    DT::datatable(data = selected1(),
                  options = list(pageLength = 20),
                  rownames = FALSE)
  })
  
  
  
  
  
  # Save CSV
  output$downloadData <- downloadHandler(
    filename = function() {paste0(input$companyName,'_',input$wayPoint,'_',input$finalDestination,'_',unique(selected1()$Category),'_','cap=',input$capacity,'.csv')},
    content = function(file) {
      write.csv(selected1(), file, row.names = FALSE)
      
    })
  
  
}


# Create a Shiny app object
shinyApp(ui = ui, server = server)

ismirsehregal · Accepted Answer · 2022-04-08T10:52:55.573

We can force ggplot to display all legend items by providing a dummy data.frame containing all levels available in the dataset.

Furthermore, I'm using scale_colour_manual to reduce the code:

# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)

# Create input dataframe
DF <- data.frame(
  recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
  Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
  CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
  startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
  companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
  wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
  Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
  finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
  Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
  Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
) %>% mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))

DF <- with(DF, DF[order(Anomaly),])

dummyDF <- DF[!duplicated(DF$Anomaly),]
dummyDF$startDate <- as.Date(NA)

colours = c("NORMAL" = "darkgreen", "TENTATIVE" = "royalblue3", "LOW" = "orange", "HIGH" = "red")

# Info columns
VARS_info <- c('recordID',
               'startDate',
               'Category',
               'CategoryTRUEFALSE',
               'Duration',
               'Anomaly')

# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')

# UI
ui <- navbarPage(title = "Anomaly Browser",
                 tabPanel("Browse data",
                          sidebarLayout(
                            sidebarPanel(
                              selectInput(
                                inputId = "companyName",
                                label = "Rail haul provider: ",
                                choices = sort(unique(DF$companyName)),
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "wayPoint",
                                label = "Load point: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "capacity",
                                label = "Capacity: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              selectInput(
                                inputId = "finalDestination",
                                label = "Terminal: ",
                                choices = NULL,
                                multiple = FALSE
                              ),
                              br(),
                              br(),
                              switchInput(
                                inputId = "category",
                                onLabel = "X",
                                offLabel = "Z",
                                onStatus = "GreenStatus",
                                offStatus = "RedStatus",
                                inline = TRUE,
                                value = TRUE,
                                size = 'large'
                              ),
                              br(),
                              br(),
                              downloadLink("downloadData", "Download plot data"),
                              br(),
                              width = 2,
                              # switchInput color while on
                              tags$head(tags$style(
                                HTML(
                                  '.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
                                   .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
                                     background: green; 
                                     color: white;
                                  }'
                                )
                              )),
                              # switchInput color while off
                              tags$head(tags$style(
                                HTML(
                                  '.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
                                   .bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
                                     background: darkred;
                                     color: white;
                                  }'
                                )
                              )),
                            ),
                            mainPanel(
                              plotlyOutput(
                                outputId = "scatterplot",
                                width = "120%",
                                height = "800px"
                              ),
                              DT::dataTableOutput(outputId = "Table1", width = "125%")
                            )
                          )))

# Server
server <- function(input, output, session) {
  observeEvent(input$companyName, {
    updateSelectInput(session, 'wayPoint',
                      choices = sort(unique(DF$wayPoint[DF$companyName %in% input$companyName])))
  })
  observeEvent(input$wayPoint, {
    updateSelectInput(session, 'capacity',
                      choices = sort(unique(DF$Capacity[DF$wayPoint %in% input$wayPoint &
                                                          DF$companyName %in% input$companyName])))
  })
  observeEvent(input$capacity, {
    updateSelectInput(session, 'finalDestination',
                      choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
                                                                  DF$wayPoint %in% input$wayPoint &
                                                                  DF$companyName %in% input$companyName])))
  })
  observeEvent(input$wayPoint, {
    updateSelectInput(session, 'finalDestination',
                      choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
                                                                  DF$wayPoint %in% input$wayPoint &
                                                                  DF$companyName %in% input$companyName])))
  })
  observeEvent(input$finalDestination, {
    updateSelectInput(session, 'category',
                      choices = sort(unique(DF$Category[DF$finalDestination %in% input$finalDestination &
                                                          DF$Capacity == input$capacity &
                                                          DF$wayPoint %in% input$wayPoint &
                                                          DF$companyName %in% input$companyName])))
  })
  
  # Selected
  selected1 <- reactive({
    req(input$companyName,
        input$wayPoint,
        input$capacity,
        input$finalDestination)
    DF %>%
      select(all_of(VARS_info), all_of(VARS_selector)) %>%
      filter(
        companyName %in% input$companyName &
          wayPoint %in% input$wayPoint &
          Capacity == input$capacity &
          finalDestination %in% input$finalDestination &
          CategoryTRUEFALSE %in% input$category
      ) %>%
      select(-CategoryTRUEFALSE)
  })
  
  # Create scatterplot object the plotOutput function is expecting
  output$scatterplot <- renderPlotly({
    p <- ggplot(
      data = dummyDF,
      aes(x = startDate, y = Duration, color = Anomaly, A = startDate, B = Duration, C = recordID, D = Anomaly)
    ) + geom_point(
      pch = 21,
      fill = NA,
      size = 1.0,
      stroke = 1.5
    ) + geom_point(
      data = selected1(),
      pch = 21,
      fill = NA,
      size = 1.0,
      stroke = 1.5
    ) + scale_colour_manual(values = colours)
    
    p  <- p + ggtitle(
      paste0(
        input$companyName,
        " - ",
        input$wayPoint,
        " - ",
        input$finalDestination,
        " - ",
        input$capacity,
        " (",
        unique(selected1()$Category),
        ")"
      )
    ) +
      xlab('Cycle Start Date') + ylab("Duration  (mins)") + theme(text = element_text(size = 13))
    
    p  <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
      geom_smooth(
        method = "gam",
        formula = y ~ s(x, bs = "cs", k = 1),
        colour = "black",
        lwd = 0.7,
        se = FALSE
      )
    
    ggplotly(p, tooltip = c("A", "B", "C", "D")) %>% layout(legend = list(
      itemclick = FALSE,
      itemdoubleclick = FALSE,
      groupclick = FALSE,
      itemsizing = "constant",
      itemwidth = 100
      # x = [...],
      # xanchor = [...],
      # y = [...],
      # yanchor = [...]
    ))
  })
  
  # Data table Tab-1
  output$Table1 <- DT::renderDataTable({
    DT::datatable(
      data = selected1(),
      options = list(pageLength = 20),
      rownames = FALSE
    )
  })
  
  # Save CSV
  output$downloadData <- downloadHandler(
    filename = function() {
      paste0(
        input$companyName,
        '_',
        input$wayPoint,
        '_',
        input$finalDestination,
        '_',
        unique(selected1()$Category),
        '_',
        'cap=',
        input$capacity,
        '.csv'
      )
    },
    content = function(file) {
      write.csv(selected1(), file, row.names = FALSE)
    }
  )
}

# Create a Shiny app object
shinyApp(ui = ui, server = server)

I also provided a layout call on ggplotly to avoid legend clicks, to have a fully static legend. Not sure if this is needed, though.

Regarding the legend position please run schema() and navigate: object ► layout ► layoutAttributes ► legend ► x for more information on the parameters, e.g.:

Sets the x position (in normalized coordinates) of the legend. Defaults to 1.02 for vertical legends and defaults to 0 for horizontal legends.

Here a related post concerning the legend item size can be found.

Nice solution, unfortunately the hover feature has stopped working. — Brad, Apr 08 '22 at 08:51
Works great, thanks a lot! Two tiny things. The factor is an ordered factor, but the legend is unordered. Also, is it possible to scale the legend size and adjust the vertical position of the legend? — Brad, Apr 08 '22 at 09:56
Please see another edit to resize and to reorder the legend items (they are ordered according to first appearance in the dataset). I also left some instructions regarding the legend position. I think this is something you should adapt to your own needs. — ismirsehregal, Apr 08 '22 at 11:08

Non-reactive legend in Shiny

1 Answers1

Linked