I’ve created a shiny app with raster layers plotted over a leaflet map. The user selects which raster to show with two drop down menus: one to select the type of data (mean or SD) the other to select a particular threshold (e.g., mean with 50-deg threshold, mean with 100-deg threshold). I’m having problems with the alignment of labels in the legend. The labels are right justified (see image), but I would like all the labels to be left justified.
Legend with incorrect formatting:
This answer that was just posted to a previous question works perfectly if I dont't have reactive rasters. However, when I try the same thing in code used to display reactive rasters nothing happens. Will this work if I'm using leafletProxy()with clearControls()? Here is all the code used the run the app (with fake data):
library(lubridate)
library(raster)
library(shiny)
library(leaflet)
library(leafem)
# Create example csv
params <- data.frame(summary = c("Mean", "Mean", "SD" , "SD"),
threshold = c(1, 2, 1, 2))
# Create raster brick (example)
raster_list <- list()
for (i in 1:4) {
raster_list[[i]] <- raster(xmn=-90, xmx=-75, ymn=40, ymx=47,
crs = "+proj=longlat +datum=NAD83 +no_defs ",
resolution = 0.0416667)
}
raster_list[[1]] <- setValues(raster_list[[1]],
sample(30:50, ncell(raster_list[[1]]), replace = TRUE))
raster_list[[2]] <- setValues(raster_list[[1]],
sample(50:80, ncell(raster_list[[2]]), replace = TRUE))
raster_list[[3]] <- setValues(raster_list[[3]],
sample(1:20, ncell(raster_list[[3]]), replace = TRUE))
raster_list[[4]] <- setValues(raster_list[[4]],
sample(1:20, ncell(raster_list[[4]]), replace = TRUE))
all_rast <- stack(raster_list)
names(all_rast) <- paste0(tolower(params$summary), "_", params$threshold)
all_rast <- brick(all_rast)
all_rast <- projectRaster(all_rast, raster::projectExtent(all_rast, crs = "epsg:3857"))
# Modify function used to format legend labels so we can add dates
myLabelFormat <- function(..., dates = FALSE){
if (dates) {
function(type = "numeric", cuts) {
dd <- parse_date_time(paste("2019", cuts), orders = "%Y %j")
dd <- format(dd, "%d %B")
paste0(cuts, " (", dd, ")")
}
} else {
labelFormat(...)
}
}
# ui --------------------------------------------------------------------------#
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "threshold",
label = "Threshold",
choices = unique(params$threshold)),
selectInput(inputId = "summary",
label = "Summary",
choices = unique(params$summary))
), # end sidebarPanel
mainPanel(
leafletOutput("map", height = "80vh")
) # end mainPanel
) # end sidebarLayout
) # end fluidPage
# server ----------------------------------------------------------------------#
server <- shinyServer(function(input, output) {
reacRaster <- reactive({all_rast[[paste0(tolower(input$summary),
"_", input$threshold)]]})
legend_title <- reactive({ifelse(input$summary == "SD",
"SD (days)", "Day of year")})
legend_labels <- reactive({ifelse(input$summary == "SD",
myLabelFormat(dates = FALSE),
myLabelFormat(dates = TRUE))})
output$map <- renderLeaflet({
leaflet() %>%
fitBounds(lng1 = -88, lat1 = 35, lng2 = -65, lat2 = 47) %>%
addTiles()
})
observe({
pal <- colorNumeric(palette = "viridis",
domain = values(reacRaster()),
na.color = "transparent",
reverse = TRUE)
leafletProxy("map") %>%
clearImages() %>%
clearControls() %>%
addRasterImage(reacRaster(),
colors = pal,
group = "Value",
layerId = "Value",
opacity = 0.8,
project = FALSE) %>%
addLegend("bottomright",
pal = pal,
values = values(reacRaster()),
labFormat = legend_labels(),
title = legend_title(),
opacity = 0.8) %>%
addImageQuery(reacRaster(),
digits = 2,
type = "click",
position = "bottomleft",
prefix = "",
layerId = "Value",
project = TRUE)
}) # end observe
}) # end server
# run app ---------------------------------------------------------------------#
shinyApp(ui = ui, server = server)
I’ve created a shiny app with raster layers plotted over a leaflet map. The user selects which raster to show with two drop down menus: one to select the type of data (mean or SD) the other to select a particular threshold (e.g., mean with 50-deg threshold, mean with 100-deg threshold). I’m having problems with the alignment of labels in the legend. The labels are right justified (see image), but I would like all the labels to be left justified.
Legend with incorrect formatting:
This answer that was just posted to a previous question works perfectly if I dont't have reactive rasters. However, when I try the same thing in code used to display reactive rasters nothing happens. Will this work if I'm using leafletProxy()with clearControls()? Here is all the code used the run the app (with fake data):
library(lubridate)
library(raster)
library(shiny)
library(leaflet)
library(leafem)
# Create example csv
params <- data.frame(summary = c("Mean", "Mean", "SD" , "SD"),
threshold = c(1, 2, 1, 2))
# Create raster brick (example)
raster_list <- list()
for (i in 1:4) {
raster_list[[i]] <- raster(xmn=-90, xmx=-75, ymn=40, ymx=47,
crs = "+proj=longlat +datum=NAD83 +no_defs ",
resolution = 0.0416667)
}
raster_list[[1]] <- setValues(raster_list[[1]],
sample(30:50, ncell(raster_list[[1]]), replace = TRUE))
raster_list[[2]] <- setValues(raster_list[[1]],
sample(50:80, ncell(raster_list[[2]]), replace = TRUE))
raster_list[[3]] <- setValues(raster_list[[3]],
sample(1:20, ncell(raster_list[[3]]), replace = TRUE))
raster_list[[4]] <- setValues(raster_list[[4]],
sample(1:20, ncell(raster_list[[4]]), replace = TRUE))
all_rast <- stack(raster_list)
names(all_rast) <- paste0(tolower(params$summary), "_", params$threshold)
all_rast <- brick(all_rast)
all_rast <- projectRaster(all_rast, raster::projectExtent(all_rast, crs = "epsg:3857"))
# Modify function used to format legend labels so we can add dates
myLabelFormat <- function(..., dates = FALSE){
if (dates) {
function(type = "numeric", cuts) {
dd <- parse_date_time(paste("2019", cuts), orders = "%Y %j")
dd <- format(dd, "%d %B")
paste0(cuts, " (", dd, ")")
}
} else {
labelFormat(...)
}
}
# ui --------------------------------------------------------------------------#
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "threshold",
label = "Threshold",
choices = unique(params$threshold)),
selectInput(inputId = "summary",
label = "Summary",
choices = unique(params$summary))
), # end sidebarPanel
mainPanel(
leafletOutput("map", height = "80vh")
) # end mainPanel
) # end sidebarLayout
) # end fluidPage
# server ----------------------------------------------------------------------#
server <- shinyServer(function(input, output) {
reacRaster <- reactive({all_rast[[paste0(tolower(input$summary),
"_", input$threshold)]]})
legend_title <- reactive({ifelse(input$summary == "SD",
"SD (days)", "Day of year")})
legend_labels <- reactive({ifelse(input$summary == "SD",
myLabelFormat(dates = FALSE),
myLabelFormat(dates = TRUE))})
output$map <- renderLeaflet({
leaflet() %>%
fitBounds(lng1 = -88, lat1 = 35, lng2 = -65, lat2 = 47) %>%
addTiles()
})
observe({
pal <- colorNumeric(palette = "viridis",
domain = values(reacRaster()),
na.color = "transparent",
reverse = TRUE)
leafletProxy("map") %>%
clearImages() %>%
clearControls() %>%
addRasterImage(reacRaster(),
colors = pal,
group = "Value",
layerId = "Value",
opacity = 0.8,
project = FALSE) %>%
addLegend("bottomright",
pal = pal,
values = values(reacRaster()),
labFormat = legend_labels(),
title = legend_title(),
opacity = 0.8) %>%
addImageQuery(reacRaster(),
digits = 2,
type = "click",
position = "bottomleft",
prefix = "",
layerId = "Value",
project = TRUE)
}) # end observe
}) # end server
# run app ---------------------------------------------------------------------#
shinyApp(ui = ui, server = server)
- I voted for duplicate and posted the answer on the original question – Tim G Commented Mar 14 at 9:25
- 1 @TimG Yes, please vote for duplicate in this case. – Jan Commented Mar 14 at 9:28
- @Jan Okay! - I can't though, since my answer is not accepted / upvoted – Tim G Commented Mar 14 at 9:30
- 1 This question is similar to: How to change legend text formatting in Leaflet in R?. If you believe it’s different, please edit the question, make it clear how it’s different and/or how the answers on that question are not helpful for your problem. – dthorbur Commented Mar 14 at 10:55
- 1 @TimG Thanks again for trying to help. I just edited my post, creating fake data in the R script and including all the code necessary to run the shiny app. – erz Commented Mar 14 at 19:32
1 Answer
Reset to default 0You can follow up map with htmlwidgets::onRender() -> query the document for all text elements below info.legend 1 and then change their text-anchor attribute 2 each time the mutationObserver observes any change on the map object (= a layer is changed) 3. This is a slight variation of my previous answer but the principle stays the same, just this method is more robust to map-changes!
library(lubridate)
library(raster)
library(shiny)
library(leaflet)
library(leafem)
# Create example csv
params <- data.frame(summary = c("Mean", "Mean", "SD" , "SD"),
threshold = c(1, 2, 1, 2))
# Create raster brick (example)
raster_list <- list()
for (i in 1:4) {
raster_list[[i]] <- raster(xmn=-90, xmx=-75, ymn=40, ymx=47,
crs = "+proj=longlat +datum=NAD83 +no_defs ",
resolution = 0.0416667)
}
raster_list[[1]] <- setValues(raster_list[[1]],
sample(30:50, ncell(raster_list[[1]]), replace = TRUE))
raster_list[[2]] <- setValues(raster_list[[1]],
sample(50:80, ncell(raster_list[[2]]), replace = TRUE))
raster_list[[3]] <- setValues(raster_list[[3]],
sample(1:20, ncell(raster_list[[3]]), replace = TRUE))
raster_list[[4]] <- setValues(raster_list[[4]],
sample(1:20, ncell(raster_list[[4]]), replace = TRUE))
all_rast <- stack(raster_list)
names(all_rast) <- paste0(tolower(params$summary), "_", params$threshold)
all_rast <- brick(all_rast)
all_rast <- projectRaster(all_rast, raster::projectExtent(all_rast, crs = "epsg:3857"))
# Modify function used to format legend labels so we can add dates
myLabelFormat <- function(..., dates = FALSE){
if (dates) {
function(type = "numeric", cuts) {
dd <- parse_date_time(paste("2019", cuts), orders = "%Y %j")
dd <- format(dd, "%d %B")
paste0(cuts, " (", dd, ")")
}
} else {
labelFormat(...)
}
}
# ui --------------------------------------------------------------------------#
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "threshold",
label = "Threshold",
choices = unique(params$threshold)),
selectInput(inputId = "summary",
label = "Summary",
choices = unique(params$summary))
), # end sidebarPanel
mainPanel(
leafletOutput("map", height = "80vh")
) # end mainPanel
) # end sidebarLayout
) # end fluidPage
# server ----------------------------------------------------------------------#
server <- shinyServer(function(input, output) {
reacRaster <- reactive({all_rast[[paste0(tolower(input$summary),
"_", input$threshold)]]})
legend_title <- reactive({ifelse(input$summary == "SD",
"SD (days)", "Day of year")})
legend_labels <- reactive({ifelse(input$summary == "SD",
myLabelFormat(dates = FALSE),
myLabelFormat(dates = TRUE))})
output$map <- renderLeaflet({
leaflet() %>%
fitBounds(lng1 = -88, lat1 = 35, lng2 = -65, lat2 = 47) %>%
addTiles() %>%
htmlwidgets::onRender("
function(el, x) {
const observer = new MutationObserver(function(mutations) {
mutations.forEach(function(mutation) {
if (mutation.addedNodes.length > 0) {
var labels = el.querySelectorAll('.info.legend text'); // 1 Find all legend text elements as before
if (labels.length > 0) {
//console.log('Applying text alignment to', labels.length, 'legend labels');
labels.forEach(function(label) {
label.setAttribute('text-anchor', 'start'); // 2
label.setAttribute('dx', '5');
});
}
}
});
});
// 3 observing the entire map container el for changes
observer.observe(el, { childList: true, subtree: true });
}
")
})
observe({
pal <- colorNumeric(palette = "viridis",
domain = values(reacRaster()),
na.color = "transparent",
reverse = TRUE)
leafletProxy("map") %>%
clearImages() %>%
clearControls() %>%
addRasterImage(reacRaster(),
colors = pal,
group = "Value",
layerId = "Value",
opacity = 0.8,
project = FALSE) %>%
addLegend("bottomright",
pal = pal,
values = values(reacRaster()),
labFormat = legend_labels(),
title = legend_title(),
opacity = 0.8) %>%
addImageQuery(reacRaster(),
digits = 2,
type = "click",
position = "bottomleft",
prefix = "",
layerId = "Value",
project = TRUE)
}) # end observe
}) # end server
# run app ---------------------------------------------------------------------#
shinyApp(ui = ui, server = server)