# Packages ----------------------------------------------------------------
library( shiny )
library( r2d3maps )
library( rnaturalearth )
library( dplyr )
# data --------------------------------------------------------------------
# shapes
africa <- ne_countries(continent = "Africa", returnclass = "sf")
# drinking water data
data("water_africa")
# add data to shapes
africa <- left_join(
x = africa %>% select(adm0_a3_is, name, geometry),
y = water_africa %>% filter(year == 2015),
by = c("adm0_a3_is" = "iso3")
)
# app ---------------------------------------------------------------------
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h2("Proxy example:"),
d3Output(outputId = "mymap", width = "600px", height = "500px"),
radioButtons(
inputId = "var",
label = "Indicator:",
choices = list(
"Basic" = "national_at_least_basic",
"Limited" = "national_limited_more_than_30_mins",
"Unimproved" = "national_unimproved",
"Surface water" = "national_surface_water"
),
inline = TRUE
),
radioButtons(
inputId = "palette",
label = "Change color palette",
choices = c("viridis", "magma", "plasma", "Blues", "Greens", "Reds"),
inline = TRUE
)
)
)
)
server <- function(input, output, session) {
output$mymap <- renderD3({
d3_map(shape = africa) %>%
add_continuous_breaks(var = "national_at_least_basic") %>%
# add_continuous_gradient(var = "national_at_least_basic") %>%
add_tooltip(value = "<b>{name}</b>: {round(national_at_least_basic, 1)}%") %>%
add_legend(title = "Population with at least basic access", suffix = "%") %>%
add_labs(title = "Drinking water in Africa", caption = "Data: https://washdata.org/")
})
title_legend <- list(
"national_at_least_basic" = "basic access",
"national_limited_more_than_30_mins" = "limited access",
"national_unimproved" = "unimproved water",
"national_surface_water" = "surface water"
)
observeEvent(list(input$var, input$palette), {
d3_map_proxy(shinyId = "mymap", data = africa) %>%
update_continuous_breaks(var = input$var, palette = input$palette) %>%
update_legend(title = paste("Population with", title_legend[[input$var]]), suffix = "%") %>%
update_tootltip(value = sprintf("<b>{name}</b>: {round(%s, 1)}%%", input$var))
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.