inst/shiny-examples/demoApp/server.R

################################################################################
#
# 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
  #   }
  # })

}
dark-peak-analytics/who_decide_AP documentation built on May 25, 2022, 8:31 p.m.