R/generate_results.R

In tidytlg: Create TLGs using the 'tidyverse'

#' Generate Results using Table and Column Metadata
#'
#' @param table_metadata dataframe containing table metadata (see
#'   ?table_metadata for details)
#' @param column_metadata_file An excel file with the data for column_metadata.
#'   The file is read in with `readxl::read_excel()`. Should not be used with
#'   `column_metadata` argument. Results in a dataframe containing the column
#'   metadata that is passed to tlgsetup (see `tlgsetup()` for details). If a
#'   column_metadata dataframe is passed in too, this is ignored.
#' @param column_metadata A dataframe containing the column metadata. This will
#'   be used in place of `column_metadata_file`.
#' @param env environment to find dataframe specified in the table metadata
#'   (defaults to parent environment)
#' @param tbltype If used, this will be used to subset the `column_metadata` based
#'   on the `tbltype` column.
#' @param add_count Passed to `bind_table()` should counts be added for
#'   `tablebyvars`?
#'
#' @return dataframe of results
#' @export
generate_results <-
  function(table_metadata,
           column_metadata_file = NULL,
           column_metadata = NULL,
           env = parent.frame(),
           tbltype = NULL,
           add_count = FALSE) {
    if (is.null(table_metadata)) {
      stop("Argument table_metadata to function generate_results is required
         but no value has been supplied",
        call. = FALSE
      )
    }

    if (!("anbr" %in% names(table_metadata))) {
      table_metadata$anbr <- 1:nrow(table_metadata)
    }

    # check incoming metadata
    arglist <- list()
    args_to_chk <- names(formals())[names(formals()) != "..."]
    purrr::walk(
      args_to_chk,
      .f = function(x) {
        arglist[[x]] <<- eval(rlang::sym(x))
      }
    )
    check_generate_results(arglist)

    if (is.null(column_metadata) && !is.null(column_metadata_file)) {
      column_metadata <- read_excel(column_metadata_file, sheet = 1) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U2190", "\U2190")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U2192", "\U2192")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U2264", "\U2264")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U2265", "\U2265")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U2260", "\U2260")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U00b1", "\U00b1")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U03b1", "\U03b1")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U03b2", "\U03b2")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U03bc", "\U03bc")
        }) %>%
        mutate_if(is.character, function(x) {
          x %>% stringr::str_replace_all("\\\\U00ab", "\U00ab")
        })
    } else if (is.null(column_metadata_file) &&
      is.null(column_metadata)) {
      stop(
        "Either column_metadata_file or column_metadata must be supplied
      to generate_results"
      )
    }

    chunks <- split(table_metadata, as.numeric(rownames(table_metadata)))

    # pass each record to the funtion and return one set of results for each list
    # element
    result_list <- purrr::map(seq_len(length(chunks)), function(i) {
      do_tidytlg(chunks[[i]],
        column_metadata = column_metadata,
        column_metadata_file = column_metadata_file,
        tbltype = tbltype,
        env = env
      )
    })

    tablebys <- unique(unlist(purrr::map(chunks, ~ extract2(., "tablebyvar"))))

    res <- bind_table(result_list,
      tablebyvar = tablebys,
      add_count = add_count,
      colvar = "colnbr",
      add_format = FALSE
    ) %>%
      add_format(tableby = tablebys)

    attr(res, "column_metadata") <- column_metadata %>%
      # Per JCEV-16: Any non breaking space(utf8 160) should be collapsed into space
      # (utf8 32)
      mutate(
        tbltype = gsub("\u00A0", " ", tbltype)
      ) %>%
      filter(tbltype == !!tbltype)

    structure(
      res,
      class = c("tidytlg.metadata_table", class(res))
    )
  }

do_tidytlg <-
  function(x,
           column_metadata,
           column_metadata_file,
           tbltype,
           env = parent.frame()) {
    # The dfs are characters, so this takes them and turns them into the actual
    # data.frames
    x <- as.list(x)
    x <- x[!purrr::map_lgl(x, is.na)]
    if ("statlist" %in% names(x)) {
      st <- if (class(x$statlist)[1] == "list") x$statlist[[1]] else x$statlist
    }
    x <- purrr::map(x[names(x) != "statlist"], unlist)
    if (exists("st")) x$statlist <- st
    x$df <- get(x$df, envir = env) %>%
      tlgsetup(
        var = x$colvar,
        column_metadata = column_metadata,
        column_metadata_file = column_metadata_file,
        tbltype = tbltype
      )
    if (!is.null(x$denom_df) && exists(x$denom_df, envir = env)) {
      x$denom_df <- get(x$denom_df, envir = env) %>%
        tlgsetup(
          var = x$colvar,
          column_metadata = column_metadata,
          column_metadata_file = column_metadata_file,
          tbltype = tbltype
        )
    }

    x$colvar <- "colnbr"
    # If a value is a function argument, pass it into the function. Otherwise
    # append it to the output table
    do.call(x$func, x)
  }