R/components.R

In QuartzSoftwareLLC/shiny.fluToolKit: What the Package Does (One Line, Title Case)

#' Helper ui element with Qselect multiselect within an item
#'
#' @param input_id The id of the element.
#' @param label The label of the element.
#' @param option_list The options of the element.
#' @param default The default value of the element.
#' @importFrom shiny.quartz  Item
#' @importFrom shiny.mui Autocomplete.shinyInput
ItemSelect <- function(input_id, label, option_list, default = list(), xs= 12, sm = 12, ...) {
    Item(
        xs = xs, sm = sm,
        Autocomplete.shinyInput(input_id,
        ...,
            multiple = T,
            inputProps = list(label = label),
            value = list(default),
            options = option_list,
            disableCloseOnSelect = T
        )
    )
}

#' Display a stat
Stat <- function(id) {
    shiny.mui::Typography(variant = "h6", textOutput(id))
}

#' @importFrom shiny.quartz IconSwitch.shinyInput
#' @importFrom shiny.mui SettingsIcon Tooltip Box
CustomAgeButton <- function(ns) {
    Tooltip(title = "Customize", span(IconSwitch.shinyInput(ns("custom_age_switch"), SettingsIcon(), label = "Custom Ages", value = F)))
}

#' @importFrom shiny conditionalPanel
CustomAgeInput <- function(ns, data) {
       Item(xs = 12,  conditionalPanel(
            condition = "input.custom_age_switch",
            ns = ns,
            Autocomplete.shinyInput(ns("age_group"), inputProps = list(label = "Age Group(s)"), options = unique(data$age_group), sx = list(mb = 1), multiple = T, disableCloseOnSelect = T)
    ))
}

#' Applies global season filter and either global or custom age filter based on custom age switch
base_filter <- function(data, input, globalInput) {
    req(globalInput$ages)
    req(globalInput$seasons)
    filter <- globalInput$ages
    if (input$custom_age_switch) {
        filter <- input$age_group
    }

    data %>%
        subset(season %in% globalInput$seasons &
            age_group %in% filter)
}

#' gets ci output from a dataframe with value, lower_ci, and upper_ci columns
#' @importFrom dplyr mutate_all
get_ci <- function(data) {
    data %>% mutate_all(~ round(.x, 2)) -> rounded
    shiny.quartz::format_ci(
        rounded$value,
        rounded$lower_ci,
        rounded$upper_ci
    )
}

#' Outputs the burden related stats
#'
#' @param ns the namespace of the module
#' @importFrom shiny.mui Typography
#' @importFrom shiny.quartz Container Item QListItem
BurdenStats <- function(ns, suffix = "", prefix = "") {

    tagList(
        conditionalPanel(condition = "input.mean_switch", Typography("Showing Averages")),
    Container(
        item = T, xs = 12,
        list(
            c("illnesses", "Illnesses"),
            c("medical_visits", "Medical Visits"),
            c("hospitalizations", "Hospitalizations"),
            c("deaths", "Deaths")
        ) %>%
            lapply(\(x) Item(xs = 12, sm = 12, md = 6, lg = 3, QListItem(paste(prefix, x[2], suffix), secondary = textOutput(ns(x[1])))))
    )
    )
}

#' @param output the output of the module
#' @param getter_function function to retrieve metric based on measure
renderBurdenStats <- function(output, reactive_data) {
    get_result <- function(measurez) {
        renderText({
            reactive_data() %>%
                filter(measure == measurez) %>%
                dplyr::select(-measure) %>% # remove measure column because it messes with rounding
                get_ci()
        })
    }

    output$illnesses <- get_result("Symptomatic Illnesses")
    output$deaths <- get_result("Deaths")
    output$hospitalizations <- get_result("Hospitalizations")
    output$medical_visits <- get_result("Medical Visits")
}

#' @importFrom shiny.quartz QCard
CustomAgeCard <- function(title, data, ..., ns = NS(), Toolbar = "") {
    QCard(
        title = title,
        Toolbar = div(CustomAgeButton(ns), Toolbar),
        CustomAgeInput(ns, data),
        ...
    )
}

CustomAgeStat <- function(ns, title) {
    QListItem(title, CustomAgeButton(ns),
        secondary = textOutput(ns("result"))
    )
}

#' Toggles showing graphs
GraphsSwitch <- function(ns, value = F) {
    Tooltip(title = "Show Charts", span(IconSwitch.shinyInput(ns("graphs_switch"), BarChartIcon(), value = value)))
}