R/LG_approx_scribe.R

In LAJordanger/localgaussSpec: Local Gaussian Spectral Analysis

#' Local Gaussian Approximations, scribe-function
#'
#' @description This function takes care of the bookkeeping when the
#'     local Gaussian (auto- and cross-) correlations are computed for
#'     the lag-h pairs for a single time series.  It can also digest a
#'     collection of samples from a parametric time series model.
#'
#' @details This function records its arguments and compares them to a
#'     previously stored information-object for the time series under
#'     investigation, in order to avoid redoing previously performed
#'     computations.  This function calls \code{LG_approx} when a new
#'     computation is required, the result is then saved to file, and
#'     the information-object is updated with the key details.
#'
#' @template main_dir_arg
#' @template data_dir_arg
#' @template TS_arg
#' @template lag_max_arg
#' @template LG_points_arg
#' @template bws_mixture_arg
#' @template bw_points_arg
#' @template bws_fixed_arg
#' @template bws_fixed_only_arg
#' @template content_details_arg
#' @template LG_type_arg
#' 
#' @return This function is a scribe that reads and records
#'     information, whereas another function performs the actual
#'     computation, see details for further information.  A list
#'     containing the following key-information is always returned to
#'     the workflow.
#'
#' \describe{
#'
#' \item{done_before}{Logical value that reveals if the computation
#' has been performed before.}
#'
#' \item{main_dir}{The \code{main_dir}-argument is included here.}
#'
#' \item{data_dir}{The \code{data_dir}-argument is included here.}
#'
#' }
#' 
#' @export

LG_approx_scribe <- function(
    main_dir,
    data_dir,
    TS,
    lag_max = ceiling(3*sqrt(length(TS))),
    LG_points,
    .bws_mixture = c("mixture", "local", "global"),
    bw_points = c(25, 35),
    .bws_fixed = NULL,
    .bws_fixed_only = FALSE,
    content_details = c("rho_only", "rho_log.fun", "rho_all"),
    LG_type = c("par_five", "par_one")) {
    ##  We need a spy_report to capture the arguments.
    spy_report <- spy()
    kill(lag_max, bw_points, content_details)
    ##  Sanity-check and update the arguments, and check them against
    ##  previous computations.  Note: This also adjusts
    ##  'spy_report$envir' by adding 'save_dir' based on 'main_dir'
    ##  and 'data_dir'.
    books <- LG_bookkeeping(spy_report = spy_report)
    ##  If the same computation already has been performed, we can
    ##  just return the relevant parts of 'books'.
    if (books$done_before)
        return(books[c("done_before", "main_dir", "data_dir")])
    ##  Compute the (ordinary global) auto- or cross-correlations.
    .TS_acr <- TS_acr(
        .TS_info = books$.TS_info,
        lag_max = spy_report$envir$lag_max)
    ##  Add information to the `info`-object.
    books$info[[books$bookmark]][[.TS_acr$.acr_type]] <-
        .TS_acr$.acr_content
    kill(.TS_acr)
    ##  Reminder: The setup below is a bit superfluous for the present
    ##  solution, but it could be of interest to build upon this later
    ##  on if memory-related partitions of the task should be included
    ##  at this part of the computation.
    loop_list <-
        list(list(
            data_files = NA_character_, #  In this case no file to load.
            arg_list = as.list(spy_report$envir,
                               all.names = TRUE)))
    names(loop_list) <- " "  #  Since its length is one.
    ##  Create a template for the data-frame needed for information
    ##  about file-names and memory-size (in MB) for the objects.
    L <- length(loop_list) * length(LG_type)
    data_files_df <- LG_default$file_info_df(L = L)
    ##  Initiate counter for updating of 'data_files_df'.
       row_nr <- 1
    ##  Create list-templates for storing of dimension-names and
    ##  'eflag' (the latter comes from 'localgauss', and it tells us
    ##  if the computation was successful, i.e. whether or not the
    ##  values can be trusted).
    dimnames.par_one <-list()
    dimnames.par_five <-list()
    convergence <-list()
    ##  Work through 'loop_list'
    for (part in names(loop_list)) {
        ##  Evaluate a call for 'LG_approx' based on 'part'.
        result <- eval(create_call(
            .cc_fun = LG_approx,
            loop_list[[part]]$arg_list,
            .cc_list = TRUE))
        ##  When required, do the 'par_one' case.
        if ("par_one" %in% result$LG_type) {
            ##  Save data for 'par_one', register the file-name.
            save_files.par_one <- LG_save(
                data = result$par_one_data,
                LG_type = "par_one",
                part = part,
                save_dir = books$save_dir)
            ##  Update 'dimnames.par_one', such that it contains the
            ##  information about the part stored in the file.
            dimnames.par_one <-
                c(dimnames.par_one, list(dimnames(result$par_one_data$on_diag)))
            names(dimnames.par_one)[length(dimnames.par_one)] <-
                save_files.par_one
            ##  Add information about 'par_one' to 'data_files_df'.
            data_files_df[row_nr, ] <- 
                list(part_a_of_b = part,
                     content = "par_one",
                     data_files = save_files.par_one,
                        object_size_MB=
                            as.numeric(object.size(result$data.0) / 1024^2))
        } 
        ##  When required, do the 'par_five' case.
        if ("par_five" %in% result$LG_type) {
            ##  Save data for 'par_five', register the file-name.
            save_files.par_five <- LG_save(
                data = result$par_five_data,
                LG_type = "par_five",
                part = part,
                save_dir = books$save_dir)
            ##  Update 'dimnames.par_five', such that it contains the
            ##  information about the part stored in the file.
            dimnames.par_five <-
                c(dimnames.par_five, list(dimnames(result$par_five_data$on_diag)))
            names(dimnames.par_five)[length(dimnames.par_five)] <-
                save_files.par_five
            ##  Add information about 'par_five' to 'data_files_df'.
            data_files_df[row_nr + (L - 1), ] <- 
                list(part_a_of_b = part,
                     content = "par_five",
                     data_files = save_files.par_five,
                     object_size_MB=
                         as.numeric(object.size(result$data.0) / 1024^2))
            ##  Add information about the convergence (based on 'eflag').
            convergence <- c(
                convergence,
                list(vapply(X = result$par_five_data,
                   FUN = function(x) {
                       if (! is.null(attributes(x)$convergence)) {
                           attributes(x)$convergence
                       } else
                           TRUE
                   },
                   FUN.VALUE = logical(1))))
            names(convergence)[length(convergence)] <- save_files.par_five
        } 
        ##  Update 'row_nr' for next loop.
        row_nr <- row_nr + L
    } ##  The end of the loop over 'loop_list'
    kill(row_nr, L, part, loop_list, result,
         save_files.par_one, save_files.par_five)
    ##  Add the data-frame and the relevant lists to the info-object.
    books$info[[books$bookmark]][["data_files_df"]] <- data_files_df
    if ("par_one" %in% LG_type)
        books$info[[books$bookmark]][["dimnames.par_one"]] <- dimnames.par_one
    if ("par_five" %in% LG_type)
        books$info[[books$bookmark]][["dimnames.par_five"]] <- dimnames.par_five
    books$info[[books$bookmark]][["convergence"]] <- convergence
    kill(LG_type, dimnames.par_one, dimnames.par_five)
    ##  Save the info-object to the info-file.  Remember to extract it
    ##  from 'books' in order to save 'info' instead of 'books$info'.
    info <- books$info
    save(info, file = books$info_path)
    ##  Modify 'data_files_df$data_files' to include the full path in
    ##  the _present_ operative system.
    data_files_df$data_files <- file.path(
        books$save_dir, 
        data_files_df$data_files)
    ##  Return information about 'done_before', 'main_dir' and
    ##  'data_dir' to the workflow.
    return(list(
        done_before = books$done_before,
        main_dir = books$main_dir,
        data_dir = books$data_dir))
}