R/build_model.R

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

#' @importFrom rlang .data
#' @importFrom magrittr "%>%"
#'
build_model <- function(hdl, freq = c('M', 'Q')){

  # ----------------------------------------------------------------------------
  # Validation
  if(base::exists('register',
                  mode = 'list',
                  where = rlang::current_env()) == F){
    stop('The model registry does not exist in the current environmemt',
         call. = T)
  }

  freq = match.arg(freq)
  if( !(hdl %in% bindr::register$get_field_entries('hdl')) ) {
    cat('Valid handles are:', '\n')
    cat(unname(bindr::register$get_field_entries('hdl')), '\n\n')
    stop('Selected model handle is not in the register', call. = T)
  }

  obj <- bindr::register$get_entry(hdl = hdl,  frequency = freq)
  if(is.null(obj)) {
    msg <- stringr::str_glue(
      'Invalid combination of model handle and frequency.', '\n',
      "Call 'register$get_entries()' to view all valid entries")
    stop(msg, call. = T)
  }


  # ----------------------------------------------------------------------------
  # Processing...
  obj_factor <- obj$factor
  N <- length(obj_factor)

  factor_list <- purrr::map(.x = 1:N, .f = function(.){
    file_nm <- stringr::str_glue(obj_factor[[.]]$src_dir, '/',
                                 obj_factor[[.]]$src_hdl, '.csv')
    if(fs::file_exists(file_nm) == FALSE){
      err_msg <- stringr::str_glue(
        'File ', file_nm,
        ' does not exist and is required to assemble the model ',
        hdl, ' for the ', obj$region, ' region at frequency ',
        obj$frequency, '.')
      stop(err_msg, call. = T)
    }

    base::cat('calling assemble for ', obj_factor[[.]]$nm, ' ...', '\n')
    bindr::assemble_factor(nm = obj_factor[[.]]$nm,
                        src_hdl = obj_factor[[.]]$src_hdl,
                        asset = obj_factor[[.]]$asset,
                        trade = obj_factor[[.]]$trade,
                        src_dir = base::paste(obj_factor[[.]]$src_dir,
                                              '/', sep = ''),
                        arg_supp = obj_factor[[.]]$arg_supp,
                        is_built = obj_factor[[.]]$ is_built)

  })

  tbl <- plyr::join_all(dfs = factor_list,
                        by = obj$join_by, type = 'left', match = 'all')

  # ----------------------------------------------------------------------------
  # Add checks for gaps and duplicate
  tbl <- dplyr::mutate(.data = tbl,
                year_month_str = paste0(.data$year, '-',
                                        .data$month, '-01')) %>%
    dplyr::mutate(year_month = tsibble::yearmonth(.data$year_month_str)) %>%
    tsibble::as_tsibble(index = .data$year_month) %>%
    dplyr::select(-.data$year_month_str)

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


  return(tbl)
}