R/make_industry_table.R

In djpr-data/djprlabourdash: DJSIR Jobs Dashboard

#' @title Create a table for the industry ppq
#' @param data A data frame containing data to summarise
#' @param destination "dashboard", "briefing" or "ppqs
#' @param years_in_sparklines Period of time to include in the sparkline line
#' charts.
#' @param row_order Vector of series IDs, in the order in which you wish the
#' corresponding rows to be included in the output table
#' @param highlight_rows Vector of series IDs, corresponding to rows
#' in the table to highlight.
#' Highlighted rows are bolded and have a top border; non-highlighted rows
#' are indented. If `NULL` then all rows are non-bold, non-indented.
#' @param notes Optional notes to add to caption. Source will be inferred
#' automatically based on the data using `caption_auto()`.
#' @param title Character vector to use as the table title. Will only be used
#' when `destination` is "briefing".
#' @param rename_indicators logical; default is `TRUE`. If `TRUE`, the
#' `rename_indicators()` function will be used to rename certain indicators.
#' @param pretty_round Logical; `TRUE` by default. If `TRUE`, figures will be
#' rounded using `pretty_round()`. This means (for eg.) figures below 50
#' will be rounded to 0. If `FALSE`, figures will not be rounded with
#' `pretty_round()`.
#'
#' @export
#'
#' @examples
#' # dash_data <- load_dash_data()
#' \dontrun{
#' make_industry_table(
#'   data = filter_dash_data(series_ids = c(
#'     "A84601662A",
#'     "A84601680F",
#'     "A84601683L",
#'     "A84601686V",
#'     "A84601665J",
#'     "A84601704L",
#'     "A84601707V",
#'     "A84601710J",
#'     "A84601638A",
#'     "A84601653X",
#'     "A84601689A",
#'     "A84601656F",
#'     "A84601713R",
#'     "A84601668R",
#'     "A84601695W",
#'     "A84601698C",
#'     "A84601650T",
#'     "A84601671C",
#'     "A84601641R",
#'     "A84601716W"
#'   ),
#'   row_order = c(
#'     "A84601662A",
#'     "A84601680F",
#'     "A84601683L",
#'     "A84601686V",
#'     "A84601665J",
#'     "A84601704L",
#'     "A84601707V",
#'     "A84601710J",
#'     "A84601638A",
#'     "A84601653X",
#'     "A84601689A",
#'     "A84601656F",
#'     "A84601713R",
#'     "A84601668R",
#'     "A84601695W",
#'     "A84601698C",
#'     "A84601650T",
#'     "A84601671C",
#'     "A84601641R",
#'     "A84601716W"
#'   ),
#'   highlight_rows = c("A84601662A")
#' )
#' }
make_industry_table <- function(data,
                                destination = "ppqs",
                                years_in_sparklines = 3,
                                row_order = NULL,
                                highlight_rows = NULL,
                                notes = NULL,
                                title = "",
                                rename_indicators = FALSE,
                                pretty_round = TRUE) {
  stopifnot(inherits(data, "data.frame"))
  stopifnot(nrow(data) >= 1)

  # Change value of indicator column for specific series IDs
  if (rename_indicators) {
    df <- rename_indicators(data)
  } else {
    df <- data
  }

  # Create a summary dataframe with one row per unique indicator
  summary_df <- create_summary_df(data,
    years_in_sparklines = years_in_sparklines,
    pretty_round = pretty_round
  )

  # creating 'current value %' for most current data, for each industry
  valuepc_df <- df %>%
    dplyr::filter(.data$date == max(.data$date)) %>%
    dplyr::mutate(valuepc = .data$value / max(.data$value) * 100) %>%
    dplyr::select(
      .data$series_id,
      .data$indicator,
      .data$valuepc
    )

  # Join valuepc column to summary_df and drop sparklines
  summary_df <- summary_df %>%
    dplyr::arrange(.data$indicator) %>%
    dplyr::left_join(valuepc_df) %>%
    dplyr::mutate(valuepc = paste0(round2(valuepc, 1), "%")) %>%
    dplyr::select(
      .data$indicator, .data$series_id, -.data$`Last 3 years`,
      4, .data$valuepc, dplyr::everything()
    )

  # Reorder dataframe if row_order is specified
  if (!is.null(row_order)) {
    # Check that all series IDs in the data are in `row_order`
    if (!all(summary_df$series_id %in% row_order)) {
      stop("`row_order` was specified, but not all series IDs are included")
    }
    summary_df <- summary_df %>%
      dplyr::mutate(order = match(.data$series_id, row_order)) %>%
      dplyr::arrange(.data$order) %>%
      dplyr::select(-.data$order)
  }

  # Set highlight rows as numeric vector
  if (!is.null(highlight_rows)) {
    highlight_rows <- which(summary_df$series_id %in% highlight_rows)
  }

  # Add note about release date if earlier than rest of data
  date_notes <- df %>%
    dplyr::group_by(.data$series_id, .data$indicator) %>%
    dplyr::summarise(max_date = max(.data$date)) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(indicator = dplyr::if_else(
      .data$max_date == max(.data$max_date),
      .data$indicator,
      paste0(.data$indicator, " (", format(.data$max_date, "%B %Y"), ")")
    )) %>%
    dplyr::select(.data$series_id, .data$indicator)

  summary_df <- summary_df %>%
    dplyr::ungroup() %>%
    dplyr::select(-.data$indicator) %>%
    dplyr::left_join(date_notes, by = "series_id") %>%
    dplyr::select(.data$indicator, dplyr::everything())

  summary_df <- summary_df %>%
    dplyr::rename(
      ` ` = .data$indicator,
      `% of total` = .data$valuepc
    )

  names(summary_df) <- toupper(names(summary_df))

  # Define columns to include in output table
  cols_to_include <- names(summary_df)[names(summary_df) != "SERIES_ID"]

  # Drop "Change during govt" column if all values are NA
  # This occurs if all data series in the table commenced after Nov 2014
  if (all(is.na(summary_df$`SINCE NOV 2014`))) {
    cols_to_include <- cols_to_include[cols_to_include != "SINCE NOV 2014"]
    cols_to_include <- cols_to_include[cols_to_include != "SINCE NOV 2014 PC"]
  }

  # Drop "LAST 3 YEARS"
  cols_to_include <- cols_to_include[cols_to_include != "LAST 3 YEARS"]

  # Create a basic flextable using the supplied dataframe
  flex <- summary_df %>%
    flextable::flextable(col_keys = cols_to_include)

  # Set lineheight -----
  flex <- flex %>%
    flextable::line_spacing(space = 1)

  # Ensure the flextable fits the container (eg. Word doc) it is placed in
  flex <- flex %>%
    flextable::autofit(add_w = 0, add_h = 0, part = "all")

  # Centre content
  flex <- flex %>%
    flextable::align(
      j = 3:flextable::ncol_keys(flex),
      i = 1,
      align = "justify"
    ) %>%
    flextable::valign()

  # Add an extra header row
  header_row <- c(
    "",
    "Current figures",
    "Change in latest period",
    "Change in past year",
    "Change since COVID-19",
    "Change during govt"
  )

  flex <- flex %>%
    flextable::add_header_row(values = header_row, colwidths = c(1, 2, 1, 1, 1, 1))

  # Add borders
  flex <- flex %>%
    flextable::border_remove()

  flex <- flex %>%
    flextable::border(
      i = 1,
      border.top = flextable::fp_border_default()
    ) %>%
    flextable::border(i = nrow(summary_df), border.bottom = flextable::fp_border_default())

  # Ensure font, font size, and bolding is correct
  font_family <- "Arial"
  font_size_main <- 9
  font_size_secondary <- 8

  flex <- flex %>%
    flextable::font(fontname = font_family) %>%
    flextable::font(fontname = font_family, part = "header") %>%
    flextable::fontsize(size = font_size_main) %>%
    flextable::fontsize(size = font_size_main, i = 1, part = "header") %>%
    flextable::fontsize(size = font_size_secondary, i = 2, part = "header") %>%
    flextable::bold(i = 1, part = "header")

  # Right align columns other than the first one (row label/indicator)
  flex <- flex %>%
    flextable::align(j = -1, align = "right") %>%
    flextable::align(j = -1, align = "right", part = "header")

  # Bold highlight rows, indent non-highlight rows
  if (!is.null(highlight_rows)) {
    flex <- flex %>%
      flextable::bold(i = highlight_rows, j = 1)

    all_rows <- seq_len(nrow(summary_df))
    non_highlight_rows <- all_rows[!all_rows %in% highlight_rows]

    flex <- flex %>%
      flextable::padding(i = non_highlight_rows, j = 1, padding.left = 20)

    flex <- flex %>%
      flextable::border(
        i = highlight_rows,
        border.top = flextable::fp_border_default()
      )
  }

  # Add caption / footer
  if (is.null(notes)) {
    caption_notes <- NULL
  } else {
    caption_notes <- notes
  }

  table_caption <- caption_auto(df,
    notes = caption_notes
  )

  # Add footer caption
  flex <- flex %>%
    flextable::add_footer(` ` = table_caption) %>%
    flextable::merge_at(
      j = 1:flextable::ncol_keys(flex),
      part = "footer"
    ) %>%
    flextable::font(fontname = font_family) %>%
    flextable::fontsize(
      size = font_size_secondary * 1.2,
      part = "footer"
    ) %>%
    flextable::color(
      part = "footer",
      color = "#343a40"
    ) %>%
    flextable::line_spacing(
      part = "footer",
      space = 1
    ) %>%
    flextable::font(
      fontname = font_family,
      part = "footer"
    )

  # Resize columns
  flex <- flex %>%
    flextable::width(
      j = c(3:flextable::ncol_keys(flex)),
      width = 0.88
    ) %>%
    flextable::width(
      j = 1,
      width = 2
    )

  flex
}