R/build_func.R

In fognyc/bindr: Tools for Binding Raw Times-Series Hosted on Remote Site Into a Synchronized Factor Data Set

# If dplyr::select is in a package, using .data also prevents R CMD check from
# giving a NOTE about undefined global variables (provided that @importFrom
# rlang .data is inserted). Using rlang::.data (without @importFrom rlang .data)
# is another option. See Wickham, Hadley, R Packages, O'Reilly, 1st Edition,
# 2015, p. 89 for details

#' @importFrom rlang .data
#' @importFrom magrittr "%>%"

build_CREDIT_US_M <- function(src, catalog_entry){

  join_by = 'date'
  N <- length(src)
  str_pattern <- "FRED_[a-z,A-Z]{1,3}_"

  factor_list <- purrr::map(.x = 1:N, .f = function(.){

    root <- stringr::str_extract(src[[.]]$src_hdl, pattern = str_pattern)
    if(is.na(root)) {
      err_msg <- stringr::str_glue('The pattern ', str_pattern, ' is not in ',
                                   src[[.]]$src_hdl)
      stop(err_msg, call. = T)
    } else {
      root <- stringr::str_sub(string = root, start = 6L, end = 8)
    }

    bindr::assemble_factor(nm = root,
                           src_hdl = src[[.]]$src_hdl,
                           asset = stringr::str_glue(root, '_Corp'),
                           trade = 1,
                           src_dir = src[[.]]$src_dir,
                           arg_supp = list(join_by))

  })

  tbl <- plyr::join_all(dfs = factor_list,
                        by = join_by, type = 'left', match = 'all') %>%
    dplyr::mutate(dplyr::across(.data$Aaa, .fns = function(.x) .x/100))  %>%
    dplyr::mutate(dplyr::across(.data$Baa, .fns = function(.x) .x/100))  %>%
    dplyr::mutate(credit = .data$Baa - .data$Aaa)  %>%
    dplyr::mutate( year = lubridate::year(.data$date),
                   month = lubridate::month(.data$date)) %>%
    dplyr::mutate( year_month =
                     tsibble::yearmonth(as.character(.data$date))) %>%
    tsibble::as_tsibble(index = .data$year_month) %>%
    dplyr::select(.data$year, .data$month, .data$year_month,
                  .data$credit)

  # Check for incomplete records (i.e. with NA's), gaps and duplicates
  get_incomplete_record(tbl = tbl, show = TRUE)
  tbl <- tidyr::drop_na(data = tbl)
  stop_on_gap_duplicate(tbl)


  tbl <- remove_year_month_from(tbl)
  write_MACROECONOMIC_factor(tbl = tbl, cat_entry = catalog_entry)
  return(tbl)
}


build_INFLATION_US_M <- function(src, cat_entry){

  inflation(operation = cat_entry$arg_supp$operation,
            from_ = cat_entry$arg_supp$from_,
            error_on_join_NA = cat_entry$arg_supp$error_on_join_NA,
            MA_q = cat_entry$arg_supp$MA_q,
            as_factor = cat_entry$arg_supp$as_factor )
}


build_TERM_US_M <- function(src, catalog_entry){

  join_by = 'date'
  N <- length(src)
  str_pattern <- "FRED_[a-z,A-Z]{1}[0-9]{1,2}[a-z,A-Z]{1}"

  factor_list <- purrr::map(.x = 1:N, .f = function(.){

    root <- stringr::str_extract(src[[.]]$src_hdl, pattern = str_pattern)
    if(is.na(root)) {
      err_msg <- stringr::str_glue('The pattern ', str_pattern, ' is not in ',
                                   src[[.]]$src_hdl)
      stop(err_msg, call. = T)
    } else {
      root <- stringr::str_split(root, pattern = 'FRED_')[[1]][2]
    }

    bindr::assemble_factor(nm = root,
                           src_hdl = src[[.]]$src_hdl,
                           asset = root,
                           trade = 1,
                           src_dir = src[[.]]$src_dir,
                           arg_supp = list(join_by))

  })

  tbl <- plyr::join_all(dfs = factor_list,
                        by = join_by, type = 'left', match = 'all') %>%
    dplyr::mutate(dplyr::across(.data$T10Y, .fns = function(.x) .x/100))  %>%
    dplyr::mutate(dplyr::across(.data$T1Y, .fns = function(.x) .x/100))  %>%
    dplyr::mutate(term = .data$T10Y - .data$T1Y)  %>%
    dplyr::mutate( year = lubridate::year(.data$date),
                   month = lubridate::month(.data$date)) %>%
    dplyr::mutate( year_month =
                     tsibble::yearmonth(as.character(.data$date))) %>%
    tsibble::as_tsibble(index = .data$year_month) %>%
    dplyr::select(.data$year, .data$month, .data$year_month,
                  .data$term)

  # Check for incomplete records (i.e. with NA's), gaps and duplicates
  get_incomplete_record(tbl = tbl, show = TRUE)
  tbl <- tidyr::drop_na(data = tbl)
  stop_on_gap_duplicate(tbl)


  tbl <- remove_year_month_from(tbl)
  write_MACROECONOMIC_factor(tbl = tbl, cat_entry = catalog_entry)
  return(tbl)
}


write_MACROECONOMIC_factor <- function(tbl, cat_entry){

  hdl_str <- stringr::str_glue(cat_entry$hdl, '_',
                               cat_entry$region, '_',
                               cat_entry$frequency)
  str_pattern <- '/Uncompressed'
  str_end <- stringr::str_locate(string = cat_entry$src_dir,
                                 pattern = str_pattern)[1] - 1
  dest_root_dir <- stringr::str_sub(string = cat_entry$src_dir,
                                    start = 1, end = str_end)

  path_df_audit <- stringr::str_glue(dest_root_dir, '/Audit/', hdl_str, '.pdf')
  path_df_series_csv <- stringr::str_glue(dest_root_dir, '/Uncompressed/',
                                          hdl_str, '.csv')

  tbl <- remove_year_month_from(tbl)
  readr::write_csv(x = tbl, path = path_df_series_csv)

  # ----------------------------------------------------------------------------
  # Auditing
  caption_str <- stringr::str_glue(stringr::str_to_title(cat_entry$hdl),
                                   ' Factor: File Paths') %>%
    as.character()
  tbl_path <- tibble::tibble(
    format = c('pdf', 'csv'),
    path_dir = c(fs::path_dir(path_df_audit),
                 fs::path_dir(path_df_series_csv))
  ) %>% xtable::xtable(caption = caption_str)

  caption_str <- stringr::str_glue(stringr::str_to_title(cat_entry$hdl),
                                   ' Factor: File Attributes') %>%
    as.character()
  tbl_attr <- tibble::tibble(
    file = c( fs::path_file(path_df_series_csv)),
    user = c( fs::file_info(path_df_series_csv)$user),
    device_id =
      c( as.character( fs::file_info(path_df_series_csv)$device_id )),
    permissions =
      c( as.character( fs::file_info(path_df_series_csv)$permissions )),
    size = c( fs::file_info(path_df_series_csv)$size),
    birth =
      c( as.character( fs::file_info(path_df_series_csv)$birth_time) )
  ) %>% xtable::xtable(caption = caption_str)

  caption_str <- stringr::str_glue(stringr::str_to_title(cat_entry$hdl),
                                   ' Factor: File Time Stamps') %>%
    as.character()
  tbl_times <- tibble::tibble(
    file = c( fs::path_file(path_df_series_csv)),
    modification =
      c( as.character( fs::file_info(path_df_series_csv)$modification_time )),
    access =
      c( as.character( fs::file_info(path_df_series_csv)$access_time) ),
    change =
      c( as.character( fs::file_info(path_df_series_csv)$change_time) )
  ) %>% xtable::xtable(caption = caption_str)

  arsenal::write2pdf(object = list(tbl_path,
                                   tbl_attr,
                                   tbl_times,
                                   stringr::str_glue('Derived Catalog Entry: ',
                                                     hdl_str,
                                                     '\n'),
                                   stringr::str_glue('Proprietary: ',
                                                     cat_entry$proprietary,
                                                     '\n'),
                                   stringr::str_glue(
                                     'Build Type: ',
                                     cat_entry$derivation_type, '\n'),
                                   stringr::str_glue(
                                     'Region: ',
                                     cat_entry$region, '\n'),
                                   stringr::str_glue(
                                     'Frequency: ',
                                     cat_entry$frequency, '\n'),
                                   stringr::str_glue(
                                     'Parent Handles: ',
                                     do.call(what = paste,
                                             args = cat_entry$parent_hdl),
                                     '\n'),
                                   'Tibble Tail:\n',
                                   utils::tail(tbl)),
                     file = path_df_audit, quiet = T)

  # ----------------------------------------------------------------------------
  # Set permission to 'r-' (read-only) for non-owners
  fs::file_chmod(path_df_audit, mode = '644')
  fs::file_chmod(path_df_series_csv, mode = '644')
}