R/obtn_measure_table.R

In rfortherestofus/obtn: Oregon by the Numbers

#' Generate OBTN measure table
#'
#' @param obtn_year Year for filter
#' @param selected_measure Measure for filter
#' @param export Do we export the table as image
#'
#' @return Table saved as an image
#' @export
#'
obtn_measure_table <-
  function(obtn_year,
           selected_measure,
           language = "English",
           export = TRUE) {
    # spanish levels
    df_translations <- readxl::read_xlsx(
      system.file("utils/OBTN-SpanishTranslationForTables.xlsx", package = "obtn"),
      sheet = 2
    )

    if (language == "Spanish") {
      NA_level <- "DI"

      # top category
      type_compute <- df_translations |>
        dplyr::filter(measure_origin == selected_measure) |>
        dplyr::pull(type)

      rank_name <- "Posición"
      county_name <- "Condado"

      # Get source info
      source_info <-
        df_translations |>
        dplyr::filter(measure_origin == selected_measure) |>
        dplyr::pull(source)

      rank_column_width <- 54
      county_column_width <- 79
      type_compute_column_width <- 68
    } else if (language == "English") {
      NA_level <- "ID"

      # top category - compute from the translation
      type_compute <- df_translations |>
        dplyr::filter(measure_origin == selected_measure) |>
        dplyr::mutate(
          type = forcats::fct_recode(
            type,
            "Amount" = "Cantidad",
            "Percentage" = "Porcentaje",
            "Population" = "Población"
          )
        ) |>
        dplyr::pull(type) |>
        as.character()

      rank_name <- "Rank"
      county_name <- "County"

      # Get source info
      source_info <-
        obtn_source_info |>
        dplyr::filter(year == obtn_year) %>%
        dplyr::filter(measure == selected_measure) |>
        dplyr::pull(source)

      rank_column_width <- 40
      county_column_width <- 90
      type_compute_column_width <- 70
    }
    # first we filter the data on year and county
    tables_measure_data_filtered <- obtn_data_by_measure %>%
      dplyr::filter(year == obtn_year) %>%
      dplyr::filter(measure == selected_measure) %>%
      dplyr::mutate(
        value = dplyr::case_when(
          measure %in% c("Mental Health Providers") ~ as.character(stringr::str_glue("{value}:1")),
          measure %in% c(
            "Land Area",
            "VMT per capita",
            "Vehicle Miles Traveled",
            "Total Population",
            "EV",
            "Mental Health Providers"
          ) ~ scales::comma(value, accuracy = 1),
          measure %in% c("Childcare Availability") ~ scales::comma(value, accuracy = 0.1),
          measure %in% comma_measures ~ scales::comma(value, accuracy = 0.1),
          measure %in% dollar_measures ~ scales::dollar(value, accuracy = 1),
          measure %in% c("Vaccination Rate 2yr olds") ~ scales::percent(value, accuracy = 1, scale = 1),
          tertile_text == "ID" ~ NA_character_,
          .default = scales::percent(value / 100, accuracy = 0.1)
        )
      ) %>%
      # This is for mental health providers because it shows NA:1
      # for counties with no data
      dplyr::mutate(value = stringr::str_replace(value, "NA:1", NA_character_)) %>%
      # In cases where rural, urban, or Oregon are the same as a county, the state-level row should come first
      # This calculates the number of times an observation appears
      dplyr::add_count(value_for_table) %>%
      # In cases where a value appears more than once and it is for a state-level row, state_tie becomes Y
      dplyr::mutate(state_tie = dplyr::case_when(n > 1 &
        stringr::str_detect(geography, "Oregon") ~ "Y")) %>%
      # We then use the state_tie variable to order correct
      dplyr::arrange(dplyr::desc(value_for_table), state_tie, geography) %>%
      dplyr::select(rank, geography, value) %>%
      dplyr::mutate(value = tidyr::replace_na(value, NA_level)) |>
      rlang::set_names(c(rank_name, county_name, type_compute))


    if (language == "Spanish") {
      tables_measure_data_filtered <- tables_measure_data_filtered |>
        dplyr::mutate({{ county_name }} := as.character(
          forcats::fct_recode(
            !!rlang::sym(county_name),
            "Área rural de Oregon" = "Rural Oregon",
            "Área urbana de Oregon" = "Urban Oregon"
          )
        ))
    }

    # load fonts
    # For some reason, font styles were all registered under the same name regardless
    # of whether the face was bold or something else.
    # This script grabs all the fonts and re-registers under a name like
    # ProximaNova-Bold or ProximaNova-Regular.
    # These new names have to be placed inside the R scripts
    handle_fonts()

    # px size
    size_body_text <- gt::px(12)
    size_area_labels <- gt::px(12)
    size_column_labels <- gt::px(12)
    size_source_note <- gt::px(10)

    # colors
    emph_color_dark <- tfff_dark_green
    emph_color_light <- "#a9c27f20"
    area_label_color <- "#004f3920"

    # number for regions
    # region_row_numbers <-
    #   which(is.na(tables_measure_data_filtered$Rank))

    region_row_numbers <-
      tables_measure_data_filtered |>
      dplyr::mutate(statewide = stringr::str_detect(!!rlang::sym(county_name), "Oregon")) |>
      dplyr::pull(statewide) |>
      which()

    # create table
    tbl <- tables_measure_data_filtered |>
      gt::gt() |>
      gt::cols_align("center", 1) |>
      gt::cols_align("right", 3) |>
      gt::sub_missing(missing_text = "") |>
      gt::tab_options(
        # Line widths
        table.border.top.width = gt::px(0),
        table.border.bottom.width = gt::px(0),
        table_body.border.bottom.width = gt::px(0),
        column_labels.border.top.width = gt::px(0),
        column_labels.border.bottom.width = gt::px(0),
        table_body.hlines.width = gt::px(0),
        table_body.border.top.width = gt::px(0),
        # Row heights
        data_row.padding = gt::px(1),
        column_labels.padding = gt::px(1.5),
        # General text settings
        table.font.color = "black",
        table.font.size = size_body_text,
        table.font.names = "ProximaNova-Regular"
      ) |>
      gt::tab_style(
        # Column labels formatting
        locations = gt::cells_column_labels(),
        style = list(
          gt::cell_fill(color = emph_color_dark),
          gt::cell_text(
            color = "white",
            font = "ProximaNova-Black",
            size = size_column_labels
          )
        )
      ) |>
      gt::tab_style(
        # Every other row coloring
        locations = gt::cells_body(rows = seq(
          1, nrow(tables_measure_data_filtered),
          by = 2
        )),
        style = gt::cell_fill(color = emph_color_light)
      ) |>
      gt::tab_style(
        # Area labels
        locations = gt::cells_body(rows = region_row_numbers),
        style = list(
          gt::cell_fill(color = area_label_color),
          gt::cell_text(font = "ProximaNova-BoldIt", size = size_area_labels)
        )
      ) |>
      gt::tab_style( # Source note
        locations = gt::cells_source_notes(),
        style = list(
          gt::cell_text(
            font = "ProximaNova-RegularIt",
            size = size_source_note,
            color = tfff_dark_gray
          )
        )
      ) |>
      gt::cols_width(
        as.formula(paste0(
          rank_name, " ~ gt::px(", rank_column_width, ")"
        )),
        as.formula(paste0(
          county_name, " ~ gt::px(", county_column_width, ")"
        )),
        as.formula(
          paste0(type_compute, " ~ gt::px(", type_compute_column_width, ")")
        )
      ) |>
      gt::tab_source_note(source_note = gt::html(paste0("<br>", source_info)))

    if (export) {
      # aspect ratio
      current_width <- 465
      desired_width <- 455
      desired_height <- 592
      desired_aspect_ratio_wh <- desired_width / desired_height


      # save to folder
      gt::gtsave(tbl,
        here::here(
          paste0(
            "inst/tables/",
            obtn_year,
            "/",
            obtn_year,
            "-",
            "measure-table-",
            stringr::str_replace_all(stringr::str_to_lower(selected_measure), " ", "-"),
            "-",
            stringr::str_to_lower(language),
            ".png"
          )
        ),
        expand = c(0, 15, 0, 0),
        zoom = 6
      )
    }

    tbl
  }


# obtn_measure_table(2024, selected_measure = "Migration", language = "Spanish")