R/yaml_read_informant.R

In pointblank: Data Validation and Organization of Metadata for Local and Remote Tables

#
#                _         _    _      _                _    
#               (_)       | |  | |    | |              | |   
#  _ __    ___   _  _ __  | |_ | |__  | |  __ _  _ __  | | __
# | '_ \  / _ \ | || '_ \ | __|| '_ \ | | / _` || '_ \ | |/ /
# | |_) || (_) || || | | || |_ | |_) || || (_| || | | ||   < 
# | .__/  \___/ |_||_| |_| \__||_.__/ |_| \__,_||_| |_||_|\_\
# | |                                                        
# |_|                                                        
# 
# This file is part of the 'rich-iannone/pointblank' package.
# 
# (c) Richard Iannone <riannone@me.com>
# 
# For full copyright and license information, please look at
# https://rich-iannone.github.io/pointblank/LICENSE.html
#


#' Read a **pointblank** YAML file to create an *informant* object
#'
#' @description 
#' With `yaml_read_informant()` we can read a **pointblank** YAML file that
#' describes table information (typically generated by the [yaml_write()]
#' function. What's returned is a new *informant* object with the information
#' intact. The *informant* object can be given more information through use of
#' the `info_*()` functions.
#'   
#' @param filename The name of the YAML file that contains fields related to an
#'   *informant*.
#' @param path An optional path to the YAML file (combined with `filename`).
#' 
#' @return A `ptblank_informant` object.
#' 
#' @section Examples:
#' 
#' There's a YAML file available in the **pointblank** package that's called
#' `"informant-small_table.yml"`. The path for it can be accessed through
#' `system.file()`:
#' 
#' ```r
#' yml_file_path <- 
#'   system.file(
#'     "yaml", "informant-small_table.yml",
#'     package = "pointblank"
#'   )
#' ```
#' 
#' The YAML file can be read as an informant by using the
#' `yaml_read_informant()` function.
#' 
#' ```r
#' informant <- yaml_read_informant(filename = yml_file_path)
#' 
#' informant
#' ```
#' 
#' \if{html}{
#' \out{
#' `r pb_get_image_tag(file = "man_yaml_write_3.png")`
#' }
#' }
#' 
#' As can be seen from the information report, the available table metadata was
#' restored and reported. If you expect metadata to change with time, it might
#' be beneficial to use [incorporate()] to query the target table. Or, we can
#' perform this querying directly from the YAML file with
#' [yaml_informant_incorporate()].
#' 
#' @family pointblank YAML
#' @section Function ID:
#' 11-3
#' 
#' @export
yaml_read_informant <- function(
    filename,
    path = NULL
) {

  if (!is.null(path)) {
    filename <- file.path(path, filename)
  }
  
  initial_wd <- fs::path_abs(fs::path_wd())
  wd_path <- fs::as_fs_path(dirname(filename))
  
  if (!fs::dir_exists(wd_path)) {
    stop(
      "The `path` provided (", as.character(wd_path), ") does not exist.",
      call. = FALSE
    )
  }
  
  if (initial_wd != wd_path) {
    setwd(as.character(wd_path))
    on.exit(setwd(as.character(initial_wd)))
  }
  
  file_to_read <- basename(filename)
  
  informant_list <- 
    expr_from_informant_yaml(path = file_to_read, incorporate = FALSE)

  informant <- 
    informant_list$expr_str %>%
    rlang::parse_expr() %>%
    rlang::eval_tidy()
  
  informant$metadata <- informant_list$metadata
  informant
}

#' Get an *informant* from **pointblank** YAML and `incorporate()`
#'
#' @description 
#' The `yaml_informant_incorporate()` function operates much like the
#' [yaml_read_informant()] function (reading a **pointblank** YAML file and
#' generating an *informant* with all information in place). The key difference
#' is that this function takes things a step further and incorporates aspects
#' from the the target table (defined by table-prep formula that is required in
#' the YAML file). The additional auto-invocation of [incorporate()] uses the
#' default options of that function. As with [yaml_read_informant()] the
#' informant is returned except, this time, it has been updated with the latest
#' information from the target table.
#'
#' @param filename The name of the YAML file that contains fields related to an
#'   *informant*.
#' @param path An optional path to the YAML file (combined with `filename`).
#' 
#' @return A `ptblank_informant` object.
#'
#' @section Examples:
#' 
#' There's a YAML file available in the **pointblank** package that's called
#' `"informant-small_table.yml"`. The path for it can be accessed through
#' `system.file()`:
#' 
#' ```r
#' yml_file_path <- 
#'   system.file(
#'     "yaml", "informant-small_table.yml",
#'     package = "pointblank"
#'   )
#' ```
#' 
#' The YAML file can be read as an informant by using the
#' `yaml_informant_incorporate()` function. If you expect metadata to change
#' with time, it's best to use `yaml_informant_incorporate()` instead of
#' [yaml_read_informant()] since the former will go the extra mile and perform
#' [incorporate()] in addition to the reading.
#' 
#' ```r
#' informant <- yaml_informant_incorporate(filename = yml_file_path)
#' 
#' informant
#' ```
#' 
#' \if{html}{
#' \out{
#' `r pb_get_image_tag(file = "man_yaml_write_3.png")`
#' }
#' }
#' 
#' As can be seen from the information report, the available table metadata was
#' restored and reported. If the metadata were to change with time, that would
#' be updated as well.
#'
#' @family pointblank YAML
#' @section Function ID:
#' 11-7
#'
#' @export
yaml_informant_incorporate <- function(
    filename,
    path = NULL
) {
  
  if (!is.null(path)) {
    filename <- file.path(path, filename)
  }
  
  informant_list <- 
    expr_from_informant_yaml(path = filename)
  
  informant <- 
    informant_list$expr_str %>%
    rlang::parse_expr() %>%
    rlang::eval_tidy()
  
  informant$metadata <- informant_list$metadata

  informant <- informant %>% incorporate()
  informant
}

expr_from_informant_yaml <- function(path,
                                     incorporate = FALSE) {
  
  # Read the YAML file with `yaml::read_yaml()`
  y <- yaml::read_yaml(file = path)
  
  # Perform checks on elements of `y`
  check_info_yaml_table(y)
  check_info_yaml_columns(y)
  check_info_yaml_others(y)
  
  # Backcompatibility with YAML files that have the deprecated `read_fn` key
  if ("read_fn" %in% names(y)) {
    
    read_fn_idx <- which(names(y) == "read_fn")
    names(y)[read_fn_idx] <- "tbl"
  }
  
  # Get the `tbl`, `table_name`, `info_label`, `lang`, and `locale`
  # values from the YAML file and create argument strings
  tbl <- paste0("  tbl = ", y$tbl)
  
  if (!is.null(y$table$name)) {
    tbl_name <- paste0("  tbl_name = \"", y$table$name, "\"")
  } else {
    tbl_name <- NULL
  }
  
  if (!is.null(y$info_label)) {
    label <- paste0("  label = \"", y$info_label, "\"")
  } else {
    label <- NULL
  }
  
  if (!is.null(y$lang) && y$lang != "en") {
    lang <- paste0("  lang = \"", y$lang, "\"")
  } else {
    lang <- NULL
  }
  
  if (!is.null(y$locale) && y$locale != "en") {
    locale <- paste0("  locale = \"", y$locale, "\"")
  } else {
    locale <- NULL
  }
  
  # Generate `info_snippet()` expressions
  info_snippets <- make_info_snippets(y$meta_snippets)
  
  # Generate the expression string
  expr_str <-
    paste0(
      "create_informant(\n",
      paste(c(tbl, tbl_name, label, lang, locale), collapse = ",\n"),
      "\n) ",
      info_snippets
    )
  
  # Add the `incorporate()` statement if needed (this is
  # for the `yaml_informant_incorporate()` function)
  if (incorporate) {
    expr_str <- paste0(expr_str, "%>%\nincorporate()")
  }
  
  y$tbl <- NULL
  y$read_fn <- NULL
  y$lang <- NULL
  y$locale <- NULL
  y$meta_snippets <- NULL
  y$type <- NULL
  y$tbl_name <- NULL
  y$info_label <- NULL

  list(
    expr_str = expr_str,
    metadata = y
  )
}

check_info_yaml_table <- function(y) {
  
  # If `table` is present, perform a few validations on that component
  if ("table" %in% names(y)) {
    
    # Validate that 2nd-level elements have unique names
    if (any(duplicated(names(y[["table"]])))) {
      
      stop("Duplicate column names provided in `table`.", call. = FALSE)
    }
    
    # Get component names of `table`
    table_names <- names(y[["table"]])
    
    # Validate that there are only character vectors inside `table`
    checks <- 
      lapply(
        table_names,
        FUN = function(x) {
          x_names <- names(y[["table"]][x])
          
          for (z in x_names) {
            if (is.list(y[["table"]][[z]])) {
              
              stop(
                "All subcomponents inside of `table` should be a ",
                "character vector.",
                call. = FALSE
              )
            }
          }
        }
      )
  }
}

check_info_yaml_columns <- function(y) {
  
  # If `columns` is present, perform a few validations on that component
  if ("columns" %in% names(y)) {
    
    # Validate that 2nd-level elements have unique names
    if (any(duplicated(names(y[["columns"]])))) {
      
      stop("Duplicate column names provided in `columns`.", call. = FALSE)
    }
    
    # Get listed column names
    column_names <- names(y[["columns"]])
    
    # Validate that there is no more than only a single level below
    # the column names
    checks <- 
      lapply(
        column_names,
        FUN = function(x) {
          x_names <- names(y[["columns"]][x])
          
          for (z in x_names) {
            
            if (is.list(y[["columns"]][[z]])) {
              
              components_are_char <-
                unname(unlist(lapply(y[["columns"]][[z]], is.character)))
              
              if (!all(components_are_char)) {
                stop(
                  "All components inside of `columns/", z,
                  "` should either be text or text under a single heading.",
                  call. = FALSE
                )
              }
            }
          }
        }
      )
  }
}

check_info_yaml_others <- function(y) {
  
  # If any other items are present, perform a few validations on those
  exclusions <- c("table", "columns", "actions", "steps")
  other_names <- base::setdiff(names(y), exclusions)
  
  if (length(other_names) > 0) {
    
    # Validate that there is no more than only a single level below
    # the column names
    checks <- 
      lapply(
        other_names,
        FUN = function(x) {
          
          if (is.list(y[[x]])) {
            
            if (any(unname(unlist(lapply(y[[x]], Negate(is.character)))))) {
              
              idx <- which(unname(unlist(lapply(y[[x]], Negate(is.character)))))
              
              stop(
                "All components inside `", x, "/", names(y[[x]][idx]),
                "` should be a character vector.",
                call. = FALSE
              )
            }
            
          } else if (!is.list(y[[x]])) {
            if (!is.character(y[[x]])) {
              
              stop(
                "The component inside `", x, "` should be a character vector.",
                call. = FALSE
              )
            }
          }
        }
      )
  }
}

make_info_snippets <- function(snippets) {
  
  if (length(snippets) == 0) return("")
  
  str_exprs <- 
    vapply(
      seq_along(snippets),
      FUN.VALUE = character(1),
      USE.NAMES = FALSE,
      FUN = function(x) {
        
        snippet_name <- names(snippets[x])
        snippet_fun <- snippets[[x]]
        
        paste0(
          "%>% info_snippet(",
          "snippet_name = \"", snippet_name, "\", ",
          "fn = ", snippet_fun, ")"
        )
      }
    )
  
  paste(str_exprs, collapse = " ")
}