R/compare_plot_report_carcass_smn.R

In pvrqualitasag/qgert: Qualitas Genetic Evaluation Routine Tools

###
###
###
###   Purpose:   Create a Rmd report with plots from two GE
###   started:   2021-04-27 (skn)
###
### ########################################################## ###


## -- Creator Function for CARCASS SMN ----------------------------------------- ##

#' @title Comparison Plot Report Creator Function For Production (CARCASS SMN)
#'
#' @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 CARCASS SMN
#'
#' @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 ps_breed create comparison plot report for just one breed
#' @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_carcass_smn(pn_cur_ge_label  = 2008,
#'                                  pn_prev_ge_label = 2004,
#'                                  pb_debug = TRUE)
#' }
#'
#' @export create_ge_compare_plot_report_carcass_smn
create_ge_compare_plot_report_carcass_smn <- 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_carcass_smn.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_carcass_smn ... ")
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_carcass_smn",
                   ps_msg    = paste0(" * Label of current GE: ", pn_cur_ge_label))
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_carcass_smn",
                   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_carcass_smn()
  }

  # 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,
                                "vms/work/FLP_BK")
  if (!is.null(ps_prev_plot_root)){
    s_prev_plot_root <- ps_prev_plot_root
  }


  # put together all directory names, start with GE working directory
  s_ge_dir <- file.path(s_cur_plot_root)
  if (pb_debug)
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_carcass_smn",
             ps_msg    = paste0(" ** GE workdir: ", s_ge_dir, collapse = ""))
  # archive directory
  s_arch_dir <- file.path(s_prev_plot_root)
  if (pb_debug)
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_carcass_smn",
             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_carcass_smn",
             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_carcass_smn",
             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('ge_plot_report_carcass_compare.Rmd', collapse = ''))
  if (pb_debug)
    qgert_log_info(plogger = lgr, ps_caller = "create_ge_compare_plot_report_carcass_smn",
             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_carcass_smn",
             ps_msg    = " * End of function create_ge_compare_plot_report_carcass_smn")

  # return nothing
  return(invisible(NULL))
}