R/utility_functions.R

In migrbc: Production Rules Based Classification of Migration

#' @title Get Object Size
#' 
#' @description A function to get the size of an object
#' 
#' @param object The target object.
#' 
#' @return A named list object that contains information on the 
#'  size of an object and the size unit.
#'
#' @examples
#' res <- get_object_size(TRUE)
#' res$size
#' res$unit
#' 
get_object_size <- function(object) {
  check_size_res <- format(utils::object.size(object), units = "auto")
  size_num <- as.numeric(stringr::str_extract(check_size_res, "[0-9.]+"))
  size_unit <- (stringr::str_extract(check_size_res, "[aA-zZ]+"))
  list(size = size_num, unit = size_unit)
}

#' @title Setup Random Test Data
#' 
#' @description A function to generate test data for RBC for toy examples.
#' 
#' @param num_people The number of person instances.
#' @param initial_date The start crossing date.
#' @param numJourneys The number of journeys for each person.
#' @param min The minimum duration between journeys.
#' @param max The maximum duration between journeys.
#' @return A data frame object
#'
#' @examples
#' 
#' res <- setup_random_test_data(10, 
#'                               initial_date = '2001-01-01',
#'                               numJourneys = 5,
#'                               min = 0,
#'                               max = 10)
#' head(res)
#' 
#' @export
## NOT TEST
setup_random_test_data <- function(num_people = 10, 
                                   initial_date = "2001-01-01",
                                   numJourneys = 5,
                                   min = 0,
                                   max = 10) {
  
  res <- lapply(seq_len(num_people), function(index, numJourneys) {
    pId <- index
    dates <- get_random_dates(initial_date, numJourneys, min = min, max = max)
    res <- lapply(seq_along(dates), function(c_date_inx) {
      c_date <- as.character(dates[[c_date_inx]])
      jid <- c_date_inx
      c(journeyId = jid,
        personId = pId, 
        is_arrival = jid %% 2,
        date_crossing = c_date,
        journey_sequence = jid,
        res_status_before = 0, 
        res_status_after = 0, 
        journeyId_prev = 0)
    })
    res
  }, numJourneys)
  res <- unlist(res, recursive = FALSE)
  res <- as.data.frame(do.call(rbind, res), stringsAsFactors = FALSE)
  res
}

#' @title Get Random Dates
#' 
#' @description An internal function to create test data 
#' 
#' This function is used to generate random dates
#' for \code{setup_random_test_data}
#'
#' @param start_date The start crossing date.
#' @param num_of_dates The number of journeys for each person.
#' @param min The minimum duration between journeys.
#' @param max The maximum duration between journeys.
#' @param seed A random seed to generate random dates.
#'
#' @return A list of boarder crossing dates  
get_random_dates <- function(start_date, 
                             num_of_dates = 1000, 
                             min = 0, 
                             max = 100,
                             seed = NULL) {
  set.seed(seed)
  init_date <- as.Date(start_date, "%Y-%m-%d")
  days_elapse <- sort(round(stats::runif(n = (num_of_dates - 1), 
                                         min = min, 
                                         max = max)))
  res <- list()
  res[[length(res) + 1]] <- init_date
  for (i in days_elapse) {
    res[[length(res) + 1]] <- res[[length(res)]] + i
  }
  res
}

#' @title Initialize Futile Logger
#' 
#' @description This function is used to initialize the futile.logger
#'  so that the user can be notified with the current
#'  status of running RBC.
#'  
#' @param  log_level a parameter representing a threshold, which 
#' affects the visibility of a given logger. If the log level is at or 
#' higher in priority than the logger threshold,  a message will print. 
#' Otherwise the command will silently return. The value of the log_level 
#' is a number between 1 and 9. 9 or futile.logger::TRACE will show all 
#' messages in details.
#' @param log_path A path for the output log files generated by the 
#' logger. If NULL, all messages will be displayed in the calling 
#' environment.
#' 
#' @return it runs on side effects but also return a simple message.
#' @examples 
#' ## futile.logger::FATAL: 1
#' ## futile.logger::ERROR: 2
#' ## futile.logger::WARN:  4
#' ## futile.logger::INFO:  6
#' ## futile.logger::DEBUG: 8
#' ## futile.logger::TRACE: 9
#' 
#' ## to suppresse log messages to the console
#' migrbc::initialize_logger(log_level = 1)
#' 
#' ## to display all messages to the console
#' migrbc::initialize_logger(log_level = 9)
#' 
#' @export
## NOT TEST
initialize_logger <- function(log_level = 6, log_path = NULL) {
  name_logger <- "migrbc"
  if (is.na(log_level)) 
    stop(gettextf("'%s' is missing", "log_level"))
  
  if (!is.numeric(log_level)) 
    stop(gettextf("'%s' is non-numeric", "log_level"))
  
  if (!(log_level %in% 1:9)) 
    stop(gettext("'%s' has invalid value [%s]", "log_level", log_level))
  
  if (is.null(log_path)) {
    appender <- futile.logger::appender.console()
  } else {
    appender <- futile.logger::appender.file(log_path)
  }
  
  
  futile.logger::flog.appender(appender, name = name_logger)
  futile.logger::flog.threshold(log_level, name = name_logger)
  layout <- futile.logger::layout.format("[~l] [~t] [~n.~f] ~m")
  futile.logger::flog.layout(layout, name = "ROOT")
  msg1 <- sprintf("logger  '%s' has log_level=%d and writes to",
                  name_logger,
                  log_level)
  if (is.null(log_path))
    msg2 <- "the console" else msg2 <- sprintf("file '%s'", log_path)
  cat(msg1, msg2, "\n")
}