R/compare_plot_report_lbe_rh.R

In pvrqualitasag/qgert: Qualitas Genetic Evaluation Routine Tools

###
###
###
###   Purpose:   Create a Rmd report with plots from two GE
###   started:   2019-07-02 (pvr)
###
### ########################################################## ###

## -- Creator Function for LBE_RH ----------------------------------------- ##

#' @title Comparison Plot Report Creator Function For Lineare Beschreibung For RH (LBE_RH)
#'
#' @description
#' A comparison plot report containing all generated plots of a GE side-by-side
#' with the plots from the previous GE are constructed for the trait
#' group LBE_RH.
#'
#' @param pn_cur_ge_label label of current genetic evaluation (GE)
#' @param pn_prev_ge_label label of previous GE
#' @param ps_cur_plot_root directory with plots of current evaluation
#' @param ps_prev_plot_root directory with plots from previous evaluation
#' @param ps_template template document for report
#' @param pl_plot_opts list of options specifying input for plot report creator
#' @param pb_debug flag whether debug output should be shown
#' @param plogger log4r logger object
#'
#' @examples
#' \dontrun{
#' create_ge_compare_plot_report_lbe_rh(pn_cur_ge_label  = 1908,
#'                                      pn_prev_ge_label = 1904,
#'                                      pb_debug = TRUE)
#' }
#'
#' @export create_ge_compare_plot_report_lbe_rh
create_ge_compare_plot_report_lbe_rh <- function(pn_cur_ge_label,
                                                 pn_prev_ge_label,
                                                 ps_cur_plot_root  = NULL,
                                                 ps_prev_plot_root = NULL,
                                                 ps_template       = system.file("templates", "compare_plots.Rmd.template", package = 'qgert'),
                                                 pl_plot_opts      = NULL,
                                                 pb_debug          = FALSE,
                                                 plogger           = NULL){
  # debugging message at the beginning
  if (pb_debug) {
    if (is.null(plogger)){
      lgr <- get_qgert_logger(ps_logfile = 'create_ge_compare_plot_report_lbe_rh.log', ps_level = 'INFO')
    } else {
      lgr <- plogger
    }
    qgert_log_info(plogger = lgr, ps_caller = 'create_ge_plot_report',
                   ps_msg = " Start of function create_ge_compare_plot_report_lbe_rh ... ")
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                   ps_msg    = paste0(" * Label of current GE: ", pn_cur_ge_label))
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                   ps_msg    = paste0(" * Label of previous GE: ", pn_prev_ge_label))
  }

  # if no options are specified, we have to get the default options
  l_plot_opts <- pl_plot_opts
  if (is.null(l_plot_opts)){
    l_plot_opts <- get_default_plot_opts_lbe_rh()
  }

  # check whether root of directory of current plots is specified
  s_cur_plot_root <- l_plot_opts$ge_dir_stem
  if (!is.null(ps_cur_plot_root)){
    s_cur_plot_root <- ps_cur_plot_root
  }

  # check whether root of directory of previous plots is specified
  s_prev_plot_root <- file.path(l_plot_opts$arch_dir_stem,
                                pn_prev_ge_label,
                                "lbe_rh/work")
  if (!is.null(ps_prev_plot_root)){
    s_prev_plot_root <- ps_prev_plot_root
  }


  # loop over breeds
  for (breed in l_plot_opts$vec_breed){
    # loop over breeds
    if (pb_debug)
      qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
               ps_msg    = paste0(" ** Loop for breed: ", breed, collapse = ""))
    # loop over both sexes
    for (sex in l_plot_opts$vec_sex){
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** Loop for sex: ", sex, collapse = ""))

      # put together all directory names, start with GE working directory
      s_ge_dir <- file.path(s_cur_plot_root, breed, paste0("compare", sex, collapse = ""))
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** GE workdir: ", s_ge_dir, collapse = ""))
      # archive directory
      s_arch_dir <- file.path(s_prev_plot_root, breed, paste0("compare", sex, collapse = ""))
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** Archive dir: ", s_arch_dir, collapse = ""))

      # Report text appears in all reports of this trait before the plots are drawn
      s_report_text <- glue::glue(l_plot_opts$report_text)
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** Report text: ", s_report_text))

      # target directory
      l_arch_dir_split <- fs::path_split(s_arch_dir)
      s_trg_dir <- file.path(pn_prev_ge_label, l_arch_dir_split[[1]][length(l_arch_dir_split[[1]])])
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** Target directory for restored plots: ", s_trg_dir))

      # specify the name of the report file
      s_rep_path <- file.path(s_ge_dir, paste0(l_plot_opts$rmd_report_stem, '_compare_', sex, '_', breed, '.Rmd', collapse = ''))
      if (pb_debug)
        qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
                 ps_msg    = paste0(" ** Path to report created: ", s_rep_path))

      # create the report
      create_ge_plot_report(ps_gedir      = s_ge_dir,
                            ps_archdir     = s_arch_dir,
                            ps_trgdir      = s_trg_dir,
                            ps_templ       = ps_template,
                            ps_report_text = s_report_text,
                            ps_rmd_report  = s_rep_path,
                            pb_debug       = pb_debug,
                            plogger        = plogger)
    }
  }

  # debugging message at the end
  if (pb_debug)
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_lbe_rh",
             ps_msg    = " * End of function create_ge_compare_plot_report_lbe")

  # return nothing
  return(invisible(NULL))
}