################################################################################
#
# Ground work: ----
#api_key <- get_hs_API_key(env_var_name = "Healthsites_API_key")
api_key <- "key" # seems that HS API works without a valid/proper key
countries <- sort(spData::world$name_long)
light <- bslib::bs_theme(primary = "#AF3269")
dark <- bslib::bs_theme(bg = "#131313", fg = "white", primary = "#AF3269")
# Server: ----
server <- function(input, output, session) {
observeEvent(
eventExpr = input$exit_landing,
handlerExpr = {
shinyjs::runjs("
function removeFadeOut( el) {
el.style.transition = 'opacity 1s ease';
el.style.opacity = 0;
setTimeout(function() {
el.parentNode.removeChild(el);
}, 1000);
}
const landingPage = document.getElementById('landing-page');
removeFadeOut(landingPage);"
)
})
# Grab the country name and save it to id:
.id_ <- reactive({
input$add_country
})
# Grab tab (country name), remove any spaces and save it:
.tab_name <- reactive({
stringr::str_remove_all(
string = input$countries,
pattern = " "
)
})
# Reactive list:
exist_rv <- reactiveValues()
# R6 container to contain added countries (much like plant Earth):
Earth <- bolsteR::World_R6$new()
# Add a country:
observeEvent(
eventExpr = input$add,
handlerExpr = {
insertTab(
inputId = "countries",
tab = tabPanel(
title = .id_() ,
tagList(
tabsetPanel(
id = paste0(
stringr::str_remove_all(
string = .id_(),
pattern = " "
),
"pill_card"),
tabPanel(
title = "Setup",
icon = icon("cog"),
fluidRow(
column(
class = "px-5 py-3",
width = 12,
DT::dataTableOutput(
width = "100%",
outputId = paste0(
stringr::str_remove_all(
string = .id_(),
pattern = " "
),
"_data_status")
)
)
)
)
)
)
),
target = "World"
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
# Create an object of class Waiter to provide feedback to the user:
waiter <- waiter::Waiter$new(
html = div(
style = "
display: flex;
flex-direction: column;
align-items: center;
justify-content:center;
color: white;
opacity: 1 !important;
",
h4("Retrieving data from API..."),
h4("Please wait."),
br(),br(),
waiter::spin_wandering_cubes()
),
hide_on_render = FALSE
)
# UI conditional elements:----
## All:----
### Control all APIs:----
observeEvent(
eventExpr = input[[paste0(.tab_name(), "All")]],
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Require user toggles "Query All":
if(isTRUE(input[[paste0(.tab_name(), "All")]]) &
if(!is.null(exist_rv[[paste0(.tab_name(), "All")]]))
!isTRUE(exist_rv[[paste0(.tab_name(), "All")]])
else FALSE) {
# Record existence of reactive objects:
exist_rv[[paste0(.tab_name(), "All")]] <- TRUE
# Activate all available APIs:
# GHO:
if(!isTRUE(input[[paste0(.tab_name(), "GHO")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "GHO"),
value = TRUE
)
}
# DHS:
if(!isTRUE(input[[paste0(.tab_name(), "DHS")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "DHS"),
value = TRUE
)
}
# WB:
if(!isTRUE(input[[paste0(.tab_name(), "WB")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "WB"),
value = TRUE
)
}
# HS:
if(!isTRUE(input[[paste0(.tab_name(), "HS")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "HS"),
value = TRUE
)
}
} else if(!isTRUE(input[[paste0(.tab_name(), "All")]])) {
# Deactivate all APIs:
# GHO:
if(isTRUE(input[[paste0(.tab_name(), "GHO")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "GHO"),
value = FALSE
)
}
# DHS:
if(isTRUE(input[[paste0(.tab_name(), "DHS")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "DHS"),
value = FALSE
)
}
# WB:
if(isTRUE(input[[paste0(.tab_name(), "WB")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "WB"),
value = FALSE
)
}
# HS:
if(isTRUE(input[[paste0(.tab_name(), "HS")]])) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "HS"),
value = FALSE
)
}
# Allow tab re-insertion after removal:
exist_rv[[paste0(.tab_name(), "All")]] <- FALSE
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
### Control the "Query All" button from the other APIs' buttons:----
observe({
# toggle "All" TRUE if all APIs are on:
if(isTRUE(input[[paste0(.tab_name(), "GHO")]]) &
isTRUE(input[[paste0(.tab_name(), "DHS")]]) &
isTRUE(input[[paste0(.tab_name(), "WB")]]) &
isTRUE(input[[paste0(.tab_name(), "HS")]])) {
if(!isTRUE(
isolate(
input[[paste0(.tab_name(), "All")]]
)
)) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "All"),
value = TRUE
)
}
}
# toggle "All" FALSE if all APIs are off:
if(!isTRUE(input[[paste0(.tab_name(), "GHO")]]) &
!isTRUE(input[[paste0(.tab_name(), "DHS")]]) &
!isTRUE(input[[paste0(.tab_name(), "WB")]]) &
!isTRUE(input[[paste0(.tab_name(), "HS")]])) {
if(isTRUE(
isolate(
input[[paste0(.tab_name(), "All")]]
)
)) {
shinyWidgets::updatePrettySwitch(
inputId = paste0(.tab_name(), "All"),
value = FALSE
)
}
}
})
## DHS:----
observeEvent(
eventExpr = isTRUE(input[[paste0(.tab_name(), "DHS")]]),
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Require user selects DHS to query the API:
if(isTRUE(input[[paste0(.tab_name(), "DHS")]]) &
if(!is.null(exist_rv[[paste0(.tab_name(), "DHS")]]))
!isTRUE(exist_rv[[paste0(.tab_name(), "DHS")]])
else FALSE) {
# Record existence of object:
exist_rv[[paste0(.tab_name(), "DHS")]] <- TRUE
# Insert tab:
insertTab(
inputId = paste0(.tab_name(), "pill_card"),
tabPanel(
title = "Demographic and Health Surveys (DHS)",
tabsetPanel(
id = paste0(.tab_name(), "DHS_tabset"),
tabPanel(
title = "DHS Surveys",
div(
class = "card",
div(
style = "display: flex;",
class = "px-5 py-4",
selectInput(
inputId = paste0(.tab_name(),
"_DHS_S_dropList"),
label = "DHS survey year",
choices = NULL,
selectize = TRUE
),
div(
class = "ml-3",
style = "margin-top: 2rem !important;",
actionButton(
inputId = paste0(.tab_name(),
"get_DHS_servey"),
label = "Fetch",
class = "btn-primary"
)
)
),
fluidRow(
column(
class = "px-5 py-3",
width = 12,
DT::dataTableOutput(
width = "100%",
outputId = paste0(.tab_name(),
"_DHS_S_Data")
)
)
)
)
),
tabPanel(
title = 'DHS Indicators',
div(
class = "card",
div(
style = "display: flex;",
class = "px-5 py-4",
selectizeInput(
inputId = paste0(.tab_name(),
"_DHS_I_dropList"),
label = "DHS survey indicators",
choices = NULL,
width = "50%",
multiple = TRUE
),
div(
class = "ml-3",
style = "margin-top: 2rem !important;",
actionButton(
inputId = paste0(.tab_name(),
"get_DHS_indc"),
label = "Fetch",
class = "btn-primary"
)
)
),
fluidRow(
column(
class = "px-5 py-3",
width = 12,
DT::dataTableOutput(
width = "100%",
outputId = paste0(.tab_name(), "_DHS_I_Data")
)
)
)
)
)
)
),
target = "Setup"
)
# Initiate DHS API query:
Earth$country_data[[input$countries]]$
initiate_DHS_API()
} else if(!isTRUE(input[[paste0(.tab_name(), "DHS")]])) {
# Remove tab:
removeTab(
inputId = paste0(.tab_name(), "pill_card"),
target = "Demographic and Health Surveys (DHS)")
# Allow tab re-insertion after removal:
exist_rv[[paste0(.tab_name(), "DHS")]] <- FALSE
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## GHO:----
observeEvent(
eventExpr = isTRUE(input[[paste0(.tab_name(), "GHO")]]),
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Require user selects GHO to query the API:
if(isTRUE(input[[paste0(.tab_name(), "GHO")]]) &
if(!is.null(exist_rv[[paste0(.tab_name(), "GHO")]]))
!isTRUE(exist_rv[[paste0(.tab_name(), "GHO")]])
else FALSE) {
# Record existence of object:
exist_rv[[paste0(.tab_name(), "GHO")]] <- TRUE
# Insert tab:
insertTab(
inputId = paste0(.tab_name(), "pill_card"),
tabPanel(
title = "Global Health Observatory (GHO)",
tabsetPanel(
id = paste0(.tab_name(), "GHO_tabset"),
tabPanel(
title = "GHO Indicators",
div(
class = "card",
div(
style = "display: flex;",
class = "px-5 py-4",
selectizeInput(
inputId = paste0(.tab_name(), "_GHO_I_dropList"),
label = "GHO indicators",
choices = NULL,
width = "50%",
multiple = FALSE
),
div(
class = "ml-3",
style = "margin-top: 2rem !important;",
actionButton(
inputId = paste0(.tab_name(), "get_GHO_indc"),
label = "Fetch",
class = "btn-primary"
)
)
),
fluidRow(
column(
class = "px-5 py-3",
width = 12,
DT::dataTableOutput(
width = "100%",
outputId = paste0(.tab_name(), "_GHO_I_Data")
)
)
)
)
)
)
),
target = "Setup"
)
# Initiate GHO API query:
Earth$country_data[[input$countries]]$
initiate_GHO_API()
} else if(!isTRUE(input[[paste0(.tab_name(), "GHO")]])) {
removeTab(
inputId = paste0(.tab_name(), "pill_card"),
target = "Global Health Observatory (GHO)")
# Allow tab re-insertion after removal:
exist_rv[[paste0(.tab_name(), "GHO")]] <- FALSE
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## WB:----
observeEvent(
eventExpr = isTRUE(input[[paste0(.tab_name(), "WB")]]),
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Require user selects WB to query the API:
if(isTRUE(input[[paste0(.tab_name(), "WB")]]) &
if(!is.null(exist_rv[[paste0(.tab_name(), "WB")]]))
!isTRUE(exist_rv[[paste0(.tab_name(), "WB")]])
else FALSE) {
# Record existence of object:
exist_rv[[paste0(.tab_name(), "WB")]] <- TRUE
# Insert tab:
insertTab(
inputId = paste0(.tab_name(), "pill_card"),
tabPanel(
title = "World bank (WB)",
tabsetPanel(
id = paste0(.tab_name(), "WB_tabset"),
tabPanel(
title = 'WB Indicators',
div(
class = "card",
div(
style = "display: flex;",
class = "px-5 py-4",
selectizeInput(
inputId = paste0(.tab_name(), "_WB_I_dropList"),
label = "WB indicators",
choices = NULL,
multiple = FALSE
),
div(
class = "ml-3",
style = "margin-top: 2rem !important;",
actionButton(
inputId = paste0(.tab_name(), "get_WB_indc"),
label = "Fetch",
class = "btn-primary"
)
)
),
fluidRow(
column(
class = "px-5 py-3",
width = 12,
DT::dataTableOutput(
width = "100%",
outputId = paste0(.tab_name(), "_WB_I_Data")
)
)
)
)
)
)
),
target = "Setup"
)
# Initiate WB API query:
Earth$country_data[[input$countries]]$
initiate_WB_API()
} else if(!isTRUE(input[[paste0(.tab_name(), "WB")]])) {
# Remove tab:
removeTab(
inputId = paste0(.tab_name(), "pill_card"),
target = "World bank (WB)")
# Allow tab re-insertion after removal:
exist_rv[[paste0(.tab_name(), "WB")]] <- FALSE
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## HS:----
observeEvent(
eventExpr = isTRUE(input[[paste0(.tab_name(), "HS")]]),
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Require user selects HS to query the API:
if(isTRUE(input[[paste0(.tab_name(), "HS")]]) &
if(!is.null(exist_rv[[paste0(.tab_name(), "HS")]]))
!isTRUE(exist_rv[[paste0(.tab_name(), "HS")]])
else FALSE) {
# Record existence of object:
exist_rv[[paste0(.tab_name(), "HS")]] <- TRUE
# Insert tab:
insertTab(
inputId = paste0(.tab_name(), "pill_card"),
tabPanel(
title = "Health sities (HS)",
tabsetPanel(
id = paste0(.tab_name(), "HS_tabset"),
tabPanel(
title = "Map",
div(
class = "card px-3 py-3",
leaflet::leafletOutput(
height = "70vh",
outputId = paste0(.tab_name(), "_map"))
)
),
tabPanel(
title = "Stats",
div(
class = "card px-3 py-3",
DT::dataTableOutput(
outputId = paste0(.tab_name(), "_stats")
)
)
),
tabPanel(
title = "Data",
div(
class = "card px-3 py-3",
DT::dataTableOutput(
outputId = paste0(.tab_name(), "_data")
)
)
)
)
),
target = "Setup"
)
# Initiate HS API query:
Earth$country_data[[input$countries]]$
initiate_HS_API()
# Render country facilities map:
output[[paste0(.tab_name(), "_map")]] <-
leaflet::renderLeaflet({
# If statement prevents an error when switching to World tab:
if(.tab_name() != "World")
Earth$country_data[[isolate(input$countries)]]$
get_facilities_map()
})
# Render country facilities data:
output[[paste0(.tab_name(), "_data")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = T, pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
get_facilities_data()
)
}
)
# Render country facilities stats:
output[[paste0(.tab_name(), "_stats")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = T, pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
get_facilities_stats()
)
}
)
# Update World (Earth) health sites data:
Earth$
update_world_data(country_name = input$countries)
# Render world facilities map:
output$world_map <- leaflet::renderLeaflet({
Earth$get_world_map()
})
# Render world facilities data:
output$world_stats <- DT::renderDataTable(
Earth$get_world_stats()
)
} else if(!isTRUE(input[[paste0(.tab_name(), "HS")]])) {
# Remove tab:
removeTab(
inputId = paste0(.tab_name(), "pill_card"),
target = "Health sities (HS)")
# Allow tab re-insertion after removal:
exist_rv[[paste0(.tab_name(), "HS")]] <- FALSE
}
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
# Select a country:----
observeEvent(
eventExpr = input$add,
handlerExpr = {
# Let the user know shiny is processing their query:
waiter$show()
on.exit(waiter$hide())
# Instantiate a country R6 class for the chosen country in the
# world's (Earth) object:
Earth$
# add new data to the Earth object (stats and plot will update):
add_country(
country_name = .id_(),
country_object = bolsteR::Country_R6$
new(
country_name = .id_(),
hs_API_key = API_key(),
shiny_ = TRUE)
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
# Render country API data status table:----
## Reactive objects to prevent recursive updates:
update_API <- reactive({
if(is.null(exist_rv[[paste0(.tab_name(), "update_API")]]))
exist_rv[[paste0(.tab_name(), "update_API")]] <- TRUE
return(exist_rv[[paste0(.tab_name(), "update_API")]])
})
## Draw API data status table:
observe({
if(update_API()) {
if(input$countries != "World") {
### Draw table:
output[[paste0(isolate(.tab_name()), "_data_status")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
# retrieve data availability:
dt_API <- Earth$country_data[[isolate(input$countries)]]$
data_status %>%
dplyr::as_tibble(rownames = "API") %>%
dplyr::mutate(value = toupper(value)) %>%
dplyr::rename("Data availability" = value) %>%
dplyr::bind_rows(
c(API = "All",
`Data availability` = if(
isTRUE(
all(
Earth$
country_data[[isolate(input$countries)]]$
data_status))) "TRUE" else "FALSE"))
# create buttons vector:
btn_vector <- vector(mode = "character", length = 0)
for (i in 1:nrow(dt_API)) {
btn_vector[i] <- as.character(
if(dt_API %>%
dplyr::slice(i) %>%
dplyr::pull(`Data availability`) == 'TRUE') {
shinyWidgets::prettySwitch(
inputId = paste0(isolate(.tab_name()),
dt_API$API[i]),
label = paste0("Query ", dt_API$API[i]),
status = "success",
inline = FALSE,
bigger = TRUE
)
} else { # Disable controls where data is not available
shinyjs::disabled(
shinyWidgets::prettySwitch(
inputId = paste0(isolate(.tab_name()),
dt_API$API[i]),
label = paste0("Query ", dt_API$API[i]),
status = "success",
inline = FALSE,
bigger = TRUE
)
)
}
)
}
# add buttons to the datatable object:
dt_API <- dt_API %>%
dplyr::mutate(
"Query API" = btn_vector) %>%
dplyr::mutate(
"hiddenColumn" = c(rep(0, nrow(.) - 1), 1))
DT::datatable(
dt_API,
selection = 'none',
escape = FALSE,
rownames = FALSE,
options = list(
ordering = FALSE,
paging = FALSE,
dom = 't',
scrollX = TRUE,
columnDefs = list(
list( # Hide the column with auxiliary information
visible = FALSE,
targets = ncol(dt_API) - 1
)
),
preDrawCallback = htmlwidgets::JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = htmlwidgets::JS(
'function() {
Shiny.bindAll(this.api().table().node()); }'
)
)
) %>%
DT::formatStyle(
columns = "Data availability",
backgroundColor = DT::styleEqual(
levels = c("TRUE", "FALSE"),
values = c("green", "red")
# Color = DT::styleEqual(
# levels = c("TRUE", "FALSE"),
# values = c("green", "red")
)
) %>%
DT::formatStyle(
columns = 1,
valueColumns = 'hiddenColumn',
`border-left` = DT::styleEqual(1, 'solid 3px')
) %>%
DT::formatStyle(
columns = ncol(dt_API) - 1,
valueColumns = 'hiddenColumn',
`border-right` = DT::styleEqual(1, 'solid 3px')
) %>%
DT::formatStyle(
columns = 1:ncol(dt_API),
valueColumns = 'hiddenColumn',
`border-bottom` = DT::styleEqual(1, 'solid 3px'),
`border-top` = DT::styleEqual(1, 'solid 3px')
) %>%
DT::formatStyle(
columns = 1:ncol(dt_API),
valueColumns = 'hiddenColumn',
`border-bottom` = DT::styleEqual(1, 'solid 3px'),
`border-top` = DT::styleEqual(1, 'solid 3px'),
fontWeight = DT::styleEqual(1, 'bold'),
fontSize = DT::styleEqual(1, '1.2rem'),
#`text-align` = DT::styleEqual(1, 'center'),
`vertical-align` = DT::styleEqual(1, 'center')
)
}
)
# Stop shiny from re-updating the drop-list:
exist_rv[[paste0(.tab_name(), "update_API")]] <- FALSE
}
}
})
# Update drop-down lists:----
## Reactive objects to prevent recursive updates:
update_DHS <- reactive({
# allow drop-list to update once:
if(is.null(exist_rv[[paste0(.tab_name(), "update_DHS")]]))
exist_rv[[paste0(.tab_name(), "update_DHS")]] <- TRUE
# make sure drop-list is re-updated when API is re-queried:
if(!isTRUE(exist_rv[[paste0(.tab_name(), "update_DHS")]]))
if(!isTRUE(input[[paste0(.tab_name(), "DHS")]]))
exist_rv[[paste0(.tab_name(), "update_DHS")]] <- TRUE
if(input$countries != "World" &
!is.null(input[[paste0(.tab_name(), "_DHS_S_dropList")]]) &
!is.null(exist_rv[[input$countries]])) {
return(
all(exist_rv[[paste0(.tab_name(), "update_DHS")]] &
input$countries != "World" &
isTRUE(exist_rv[[input$countries]]) &
isTRUE(input[[paste0(.tab_name(), "DHS")]]))
)
} else {
return(FALSE)
}
})
update_GHO <- reactive({
# allow drop-list to update once:
if(is.null(exist_rv[[paste0(.tab_name(), "update_GHO")]]))
exist_rv[[paste0(.tab_name(), "update_GHO")]] <- TRUE
# make sure drop-list is re-updated when API is re-queried:
if(!isTRUE(exist_rv[[paste0(.tab_name(), "update_GHO")]]))
if(!isTRUE(input[[paste0(.tab_name(), "GHO")]]))
exist_rv[[paste0(.tab_name(), "update_GHO")]] <- TRUE
if(input$countries != "World" &
!is.null(input[[paste0(.tab_name(), "_GHO_I_dropList")]]) &
!is.null(exist_rv[[input$countries]])) {
return(
all(exist_rv[[paste0(.tab_name(), "update_GHO")]] &
input$countries != "World" &
isTRUE(exist_rv[[input$countries]]) &
isTRUE(input[[paste0(.tab_name(), "GHO")]]))
)
} else {
return(FALSE)
}
})
update_WB <- reactive({
# allow drop-list to update once:
if(is.null(exist_rv[[paste0(.tab_name(), "update_WB")]]))
exist_rv[[paste0(.tab_name(), "update_WB")]] <- TRUE
# make sure drop-list is re-updated when API is re-queried:
if(!isTRUE(exist_rv[[paste0(.tab_name(), "update_WB")]]))
if(!isTRUE(input[[paste0(.tab_name(), "WB")]]))
exist_rv[[paste0(.tab_name(), "update_WB")]] <- TRUE
if(input$countries != "World" &
!is.null(input[[paste0(.tab_name(), "_WB_I_dropList")]]) &
!is.null(exist_rv[[input$countries]])) {
return(
all(exist_rv[[paste0(.tab_name(), "update_WB")]] &
input$countries != "World" &
isTRUE(exist_rv[[input$countries]]) &
isTRUE(input[[paste0(.tab_name(), "WB")]]))
)
} else {
return(FALSE)
}
})
## Observer functions that make use of the reactive objects above:
observe({
if(update_DHS()) {
if(input$countries != "World") {
# Render DHS surveys list:
dhs_S_dropList_choices <- Earth$country_data[[input$countries]]$
dhs_survey_years$SurveyYear
if(is.null(dhs_S_dropList_choices))
dhs_S_dropList_choices <- glue::glue("No DHS data found for {input$countries}")
updateSelectizeInput(
session = session,
inputId = paste0(.tab_name(), "_DHS_S_dropList"),
choices = dhs_S_dropList_choices,
server = TRUE
)
# Render DHS surveys indicators:
dhs_I_dropList_choices <- Earth$country_data[[input$countries]]$
dhs_indicators$Indicator
if(is.null(dhs_I_dropList_choices))
dhs_I_dropList_choices <- glue::glue("No DHS data found for {input$countries}")
updateSelectizeInput(
session = session,
inputId = paste0(.tab_name(), "_DHS_I_dropList"),
choices = dhs_I_dropList_choices,
server = TRUE
)
# Stop shiny from re-updating the drop-list:
exist_rv[[paste0(.tab_name(), "update_DHS")]] <- FALSE
}
}
})
observe({
if(update_GHO()) {
if(input$countries != "World") {
# Render GHO indicators:
gho_I_dropList_choices <- Earth$country_data[[input$countries]]$
get_gho_ind_list()$IndicatorName
if(is.null(gho_I_dropList_choices))
gho_I_dropList_choices <- glue::glue("No GHO data found for {input$countries}")
updateSelectizeInput(
session = session,
inputId = paste0(.tab_name(), "_GHO_I_dropList"),
choices = gho_I_dropList_choices,
server = TRUE
)
# Stop shiny from re-updating the drop-list:
exist_rv[[paste0(.tab_name(), "update_GHO")]] <- FALSE
}
}
})
observe({
if(update_WB()) {
if(input$countries != "World") {
# Render World Bank indicators:
updateSelectizeInput(
session = session,
inputId = paste0(.tab_name(), "_WB_I_dropList"),
choices = Earth$country_data[[input$countries]]$
wb_indicators$name,
server = TRUE
)
# Stop shiny from re-updating the drop-list:
exist_rv[[paste0(.tab_name(), "update_WB")]] <- FALSE
}
}
})
# Render user-requested data:----
## Render country DHS survey data:
observeEvent(
eventExpr = input[[paste0(.tab_name(), 'get_DHS_servey')]],
handlerExpr = {
# Let the user know shiny is processing their query:
waiter <- waiter::Waiter$new(
id = paste0(.tab_name(), 'get_DHS_servey'),
hide_on_render = FALSE
)
waiter$show()
on.exit(waiter$hide())
# Render country survey data:
output[[paste0(.tab_name(), "_DHS_S_Data")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
data_ = DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = TRUE,
pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
get_dhs_survey_data(
survey =
isolate(
input[[paste0(.tab_name(), "_DHS_S_dropList")]]
)
)
)
}
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## Render country DHS indicator data:
observeEvent(
eventExpr = input[[paste0(.tab_name(), 'get_DHS_indc')]],
handlerExpr = {
# Let the user know shiny is processing their query:
waiter <- waiter::Waiter$new(
id = paste0(.tab_name(), 'get_DHS_indc'),
hide_on_render = FALSE
)
waiter$show()
on.exit(waiter$hide())
# Render country survey data:
output[[paste0(.tab_name(), "_DHS_I_Data")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = T, pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
get_dhs_ind_data(
indicator_name =
isolate(
input[[paste0(.tab_name(), "_DHS_I_dropList")]]
),
filter_var = NULL
)
)
}
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## Render country GHO indicator data:
observeEvent(
eventExpr = input[[paste0(.tab_name(), 'get_GHO_indc')]],
handlerExpr = {
# Let the user know shiny is processing their query:
waiter <- waiter::Waiter$new(
id = paste0(.tab_name(), 'get_GHO_indc'),
hide_on_render = FALSE
)
waiter$show()
on.exit(waiter$hide())
# Render country survey data:
output[[paste0(.tab_name(), "_GHO_I_Data")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = T, pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
get_gho_ind_data(
indicator_code_ =
Earth$country_data[[isolate(input$countries)]]$
get_gho_ind_list() %>%
dplyr::filter(
isolate(
input[[paste0(.tab_name(), "_GHO_I_dropList")]]
) == IndicatorName
) %>%
dplyr::pull(IndicatorCode)
)
)
}
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
## Render country WB indicator data:
observeEvent(
eventExpr = input[[paste0(.tab_name(), 'get_WB_indc')]],
handlerExpr = {
# Let the user know shiny is processing their query:
waiter <- waiter::Waiter$new(
id = paste0(.tab_name(), 'get_WB_indc'),
hide_on_render = FALSE
)
waiter$show()
on.exit(waiter$hide())
# Query WB API:
wb_I_name <- input[[paste0(.tab_name(), "_WB_I_dropList")]]
wb_I_label <- Earth$country_data[[input$countries]]$
wb_indicators %>%
dplyr::filter(wb_I_name == name) %>%
dplyr::pull(indicator)
# Render country survey data:
output[[paste0(.tab_name(), "_WB_I_Data")]] <-
DT::renderDataTable(
server = FALSE,
expr = {
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
scrollX = T, pageLength = 10,
buttons = c('csv', 'excel')
),
Earth$country_data[[isolate(input$countries)]]$
set_wb_data(
indicator_label = isolate(
wb_I_label
)
)$
get_wb_ind_data()
)
}
)
},
ignoreInit = TRUE,
ignoreNULL = TRUE
)
# Render outputs on World tab:----
## Render world facilities map:
output$world_mapUI <- renderUI({
tagList(
leaflet::leafletOutput(
height = "70vh",
outputId = "world_map"
),
)
})
## Render world facilities data:
output$world_statsUI <- renderUI({
tagList(
DT::dataTableOutput(
outputId = "world_stats"
)
)
})
# Dynamic addition and removal country lists:----
react_vars <- reactiveValues(add_v = NULL,
rem_v = countries)
observeEvent(
eventExpr = input$add,
handlerExpr = {
react_vars$rem_v <- dplyr::setdiff(react_vars$rem_v, input$add_country)
react_vars$add_v <- dplyr::union(react_vars$add_v, input$add_country)
# reactive object to control dd-list's updating:
exist_rv[[input$add_country]] <- TRUE
},
ignoreInit = TRUE)
observeEvent(
eventExpr = input$remove,
handlerExpr = {
react_vars$add_v <- dplyr::setdiff(react_vars$add_v, input$remove_country)
react_vars$rem_v <- dplyr::union(react_vars$rem_v, input$remove_country)
},
ignoreInit = TRUE)
observeEvent(
eventExpr = c(input$add, input$remove),
handlerExpr = {
updateSelectInput(
session = session,
inputId = "add_country",
choices = react_vars$rem_v
)
updateSelectInput(
session = session,
inputId = "remove_country",
choices = react_vars$add_v
)
},
ignoreInit = TRUE)
observeEvent(
eventExpr = input$remove,
handlerExpr = {
# remove country tab:
removeTab(
inputId = "countries",
target = input$remove_country
)
},
ignoreInit = TRUE)
observeEvent(
eventExpr = input$remove,
handlerExpr = {
# reset country reactive objects:
exist_rv[[paste0(input$remove_country, "update_GHO")]] <- NULL
exist_rv[[paste0(input$remove_country, "update_DHS")]] <- NULL
exist_rv[[paste0(input$remove_country, "update_WB")]] <- NULL
# rest country name from reactive object to reset updating:
exist_rv[[input$remove_country]] <- NULL
},
ignoreInit = TRUE)
output$remove_list <- renderUI({
if(length(react_vars$add_v) > 0) {
tagList(
selectInput(
inputId = "remove_country",
label = "Remove country",
choices = c(react_vars$add_v),
selected = isolate(react_vars$add_v[1]),
selectize = TRUE
)
)
}
})
output$remove_button <- renderUI({
if(length(react_vars$add_v) > 0) {
tagList(
actionButton(
inputId = "remove",
label = "Remove")
)
}
})
# API key:----
output$api_key_ui <- renderUI({
if(is.null(api_key)) {
tagList(
textInput(
inputId = "api_key",
label = "Could not find an api key, please provide one:"
)
)
}
})
API_key <- reactive({
if(is.null(api_key)) {
input$api_key
} else {
api_key
}
})
# Theme switching:----
observe(session$setCurrentTheme(
if (isTRUE(input$light_mode)) light else dark
))
# output$api_key <- renderText({
# if(is.null(api_key)) {
# input$api_key
# } else {
# api_key
# }
# })
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.