R/obtn_county_table.R

In rfortherestofus/obtn: Oregon by the Numbers

#' Generate OBTN county table
#'
#' @param obtn_year Year for filter
#' @param selected_county County for filter
#' @param langugage Language, English or Spanish
#'
#' @return Table saved as an image
#' @export
#'
obtn_county_table <-
  function(obtn_year, selected_county, language = "English") {
    # spanish table
    if (language == "Spanish") {
      # load translations
      df_translations <-
        readxl::read_xlsx(
          system.file("utils/OBTN-SpanishTranslationForTables.xlsx", package = "obtn"),
          col_names = c("measure_sp"),
          col_types = c("text", "skip", "skip", "skip", "skip"),
          sheet = 1
        ) |>
        dplyr::mutate(category_sp = dplyr::case_when(is.na(dplyr::lag(measure_sp)) ~ measure_sp)) |>
        tidyr::fill(category_sp) |>
        dplyr::filter(!is.na(measure_sp) &
                        measure_sp != category_sp) |>
        # warning : positional matching
        dplyr::bind_cols(
          tables_county_data |>
            dplyr::filter(year == obtn_year &
                            geography == selected_county) |>
            dplyr::select(category, measure)
        )

      # define vects
      category_vect <- df_translations$category
      names(category_vect) <- df_translations$category_sp

      measure_vect <- df_translations$measure
      names(measure_vect) <- df_translations$measure_sp

      col_names <- c("Oregon", "Rural", "Urbana")

      top_name <- "Comunidad"

      measure_column_width <- 210
      selected_county_column_width <- 75
      oregon_rural_urban_column_widths <- 50
      fonts_labels_size <- convert_pt_to_px(9 * 0.74)

    } else if (language == "English") {
      col_names <- c("Oregon", "Rural", "Urban")

      top_name <- "Community"

      measure_column_width <- 165
      selected_county_column_width <- 85
      oregon_rural_urban_column_widths <- 65
      fonts_labels_size <- convert_pt_to_px(11.25 * 0.74)
    }

    # return(measure_column_width)

    # data cleaning is done in data-raw/import-data.R -> TABLES DATA section

    # first we filter the data on year and county
    tables_county_data_filtered <-
      tables_county_data %>%
      dplyr::mutate(value = tidyr::replace_na(value, "ID")) |>
      dplyr::filter(year == obtn_year &
                      geography == selected_county) %>%
      dplyr::select(-c(geography, rank, year)) %>%
      rlang::set_names(c("category", "measure", selected_county, col_names))

    if (language == "Spanish") {
      tables_county_data_filtered <- tables_county_data_filtered |>
        dplyr::mutate(
          category = forcats::fct_recode(category, !!!category_vect),
          measure = forcats::fct_recode(measure, !!!measure_vect),
          category = as.character(category),
          measure = as.character(measure)
        )
    }

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

    # we use all the utils functions made below to create table
    tbl_id <- "county-table"

    tbl <- tables_county_data_filtered |>
      gt::gt(groupname_col = "category", id = tbl_id) |>
      gt::cols_align(columns = -measure, "center") |>
      gt::cols_label_with(fn = stringr::str_to_upper) |>
      gt::sub_missing(missing_text = "") |>
      add_colors_and_bolds(selected_county = selected_county) |>
      set_fonts(column_labels_size_px = fonts_labels_size) |>
      set_measure_groups(padding_top_px = 3,
                         padding_bottom_px = 0,
                         id = tbl_id,
                         top_name = top_name) |>
      set_borders(selected_county = selected_county) |>
      # little hack to work into a function
      gt::cols_width(as.formula(paste0(
        "measure ~ gt::px(", measure_column_width, ")"
      )),
      as.formula(
        paste0(
          sprintf(ifelse(
            grepl(" ", selected_county), "`%s`", "%s"
          ), selected_county),
          " ~ gt::px(",
          selected_county_column_width,
          ")"
        )
      ),
      as.formula(
        paste0(
          "dplyr::everything() ~ gt::px(",
          oregon_rural_urban_column_widths,
          ")"
        )
      )) |>
      gt::tab_options(data_row.padding = gt::px(2.25))

    # 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,
        "-",
        "county-table-",
        stringr::str_replace_all(stringr::str_to_lower(selected_county), " ", "-"),
        "-",
        stringr::str_to_lower(language),
        ".png"
      )
    ), zoom = 6)


    tbl
  }

#' Not exported - Set measures groups for gt tables
set_measure_groups <- function(gt_tbl,
                               padding_top_px,
                               padding_bottom_px,
                               id = "county-table",
                               top_name = "Community") {
  gt_tbl |>
    gt::cols_label(measure = top_name) |>
    gt::opt_css(# Remove first group row
      paste0(
        'tr.gt_group_heading_row > th[id="',
        top_name,
        '"] {
        display: none;
      }'
      )) |>
    gt::opt_css(# Set heights of measure groups
      glue::glue(
          '#<<id>> .gt_group_heading {
          padding-top: <<padding_top_px>>px;
          padding-bottom: <<padding_bottom_px>>px;
        }
         #<<id>> .gt_col_heading {
          padding-top: 1px;
          padding-bottom: 2px;
         }
        #<<id>> .gt_col_heading[id="<<top_name>>"] {
          padding-top: 0px;
          padding-bottom: 0px;
         }
        ',
        .open = "<<",
        .close = ">>"
      ))
}

#' Not exported - Add colors and bold for gt tables
add_colors_and_bolds <- function(gt_tbl,
                                 emph_color_dark = tfff_dark_green,
                                 emph_color_light = "#dae2c6",
                                 selected_county) {
  gt_tbl |>
    gt::tab_style(
      # County column label
      style = list(
        gt::cell_fill(emph_color_dark),
        gt::cell_text(color = "white", font = "ProximaNova-Extrabld")
      ),
      locations = gt::cells_column_labels(column = selected_county)
    ) |>
    gt::tab_style(
      # County column rows
      style = list(
        gt::cell_fill(emph_color_light),
        gt::cell_text(font = "ProximaNova-Bold")
      ),
      locations = gt::cells_body(column = selected_county)
    ) |>
    gt::tab_style(
      # Measure group labels
      style = gt::cell_text(font = "ProximaNova-Bold", color = emph_color_dark),
      locations = list(
        gt::cells_column_labels(column = "measure"),
        gt::cells_row_groups()
      )
    )
}



#' Not exported - Convert pt to px
convert_pt_to_px <- function(pt) {
  pt * (10 / 7.5)
}


#' Not exported - Set fonts for gt tables
set_fonts <- function(gt_tbl,
                      general_size_px = convert_pt_to_px(8 * 0.84),
                      # as close as it gets to 9.5pt and 10pt
                      column_labels_size_px = convert_pt_to_px(11.25 * 0.74),
                      measure_group_labels_size_px = convert_pt_to_px(12 * 0.74),
                      measure_row_labels_size_px = convert_pt_to_px(8.5 * 0.84)) {
  gt_tbl |>
    gt::tab_options(table.font.size = gt::px(general_size_px),
                    table.font.names = "ProximaNova-Regular") |>
    gt::tab_style(
      # Measure group labels
      style = gt::cell_text(size = gt::px(3)),
      locations = list(gt::cells_body(column = "measure"))
    ) |>
    gt::tab_style(
      # Measure group labels
      style = gt::cell_text(size = gt::px(measure_group_labels_size_px)),
      locations = list(
        gt::cells_column_labels(column = "measure"),
        gt::cells_row_groups()
      )
    ) |>
    gt::tab_style(
      # Column labels
      style = gt::cell_text(size = gt::px(column_labels_size_px)),
      locations = gt::cells_column_labels(column = -measure)
    ) |>
    gt::tab_style(
      # Measure row labels
      style = gt::cell_text(size = gt::px(measure_row_labels_size_px)),
      locations = gt::cells_body(column = measure)
    ) |>
    gt::tab_style(
      # Description labels a little bit smaller than the rest
      style = gt::cell_text(size = gt::px(measure_row_labels_size_px - 0.5)),
      locations = gt::cells_body(column = measure)
    )
}

#' Not exported - Set borders for gt tables
set_borders <- function(gt_tbl, selected_county) {
  gt_tbl |>
    gt::tab_options(
      # General line widths
      table.border.top.width = gt::px(0),
      column_labels.border.top.width = gt::px(0),
      column_labels.border.bottom.width = gt::px(1),
      table_body.hlines.width = gt::px(1),
      table_body.border.top.width = gt::px(1),
      row_group.border.top.width = gt::px(1),
      row_group.border.bottom.width = gt::px(1)
    ) |>
    gt::tab_style(
      # Remove lines in body of first column
      locations = gt::cells_body(column = measure),
      style = gt::cell_borders(weight = gt::px(0))
    ) |>
    gt::tab_style(
      # Make line in highlighted column white
      locations = gt::cells_body(column = selected_county),
      style = gt::cell_borders(side = "top", color = "white")
    )
}

#' Not exported - To handle fonts
handle_fonts <- function() {
  fonts_and_paths <- systemfonts::system_fonts() |>
    dplyr::filter(stringr::str_detect(family, "Proxima")) |>
    dplyr::select(name, family, style, path)


  fonts_and_paths |>
    purrr::pwalk( ~ {
      l <- list(...)
      systemfonts::register_font(name = l$name, plain = l$path)
    })
}

# obtn_county_table(2024, "Washington", "Spanish")