Non-reactive legend in Shiny - r

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)

Answer 1

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.