R/check.R

In rjtools: Preparing, Checking, and Submitting Articles to the 'R Journal'

#' A single article check
#'
#' @param path string, path to the directory that contains the .tex
#'     file (Ideally, this directory should contain .bib, .Rmd, and
#'     .tex with author names and two RJwrapper files:  RJwrapper.pdf
#'     and RJwrapper.tex)
#' @param file string, the file name if multiple files are detected
#'     under the \code{path} argument
#' @param dic string, the dictionary used for spelling check. See
#'     \code{dict} argument in [hunspell::hunspell()]
#' @param pkg string, optional. The name of the proposed package (if
#'     relevant), to be checked for activity on CRAN
#' @param ... additional arguments for spelling check with
#'     [hunspell::hunspell]
#' @param ask logical, if \code{TRUE} then checks may ask the user for
#'     interactive input of missing information.
#' @param logfile a connection for the output log, or a string with
#'     the filename of the output log or \code{NULL} if no log should
#'     be written
#' @details
#' Folder structure checks:
#'
#' * \code{check_filenames()}: the three files (.bib, .Rmd, and .tex) all present and have consistent names
#' * \code{check_structure()}: check validity of all filenames and depth of the directory structure
#' * \code{check_unnecessary_files()}: the template file (i.e., RJtemplate.tex) is not included in the directory
#' * \code{check_cover_letter()}: a motivational letter
#'
#' Content checks:
#'
#' * \code{check_title()}: article title is in title case
#' * \code{check_section()}: section sections are in sentence case
#' * \code{check_abstract()}: abstract should be plain text without package
#' markups (CRANpkg, BIOpkg, pkg), math notations($...$), citations, and other
#' formattings (highlight, italic, etc)
#' * \code{check_spelling()}: potential spelling mistakes
#' * \code{check_proposed_pkg()}: package proposed in the paper is on CRAN
#' * \code{check_pkg_label()}: packages marked up with \pkg{} are not available
#' on CRAN or BioConductor
#' * \code{check_packages_available()}: packages mentioned in the article are
#' available on CRAN
#' * \code{check_bib_doi}: whether bib entries have DOI or URL included, uncless
#' can't sourced online
#' * \code{check_csl}: no additional csl file should be used
#' consistent, either in sentence (preferred) or title case
#'
#' See \code{vignette("create_article", package = "rjtools")} for how to use the check functions
#' @rdname checks
#' @return list of all results (see \code{\link{log_error}} for
#'     details). You can use \code{unlist()} to get a character vector
#'     of the result statuses.
#'
#' @examples
#' your_article_path <- system.file("sample-article", package = "rjtools")
#' if (interactive()) initial_check_article(your_article_path)
#'
#' @export
initial_check_article <- function(path, dic = "en_US", pkg, ...,
                                  ask = interactive(),
                                  logfile=file.path(path, "initial_checks.log")) {
    if (missing(path))
        cli::cli_abort(
                 "The {.code path} argument is missing.
Please specify the file directory that contains the article {.field .tex} file.")

    if (is.character(logfile)) {
        logfile <- file(logfile, "a")
        on.exit(close(logfile))
    } else if (!inherits(logfile, "connection") && !is.null(logfile))
        stop("logfile must be a string or connection")

    if (!is.null(logfile)) {
        old.check.log.file <- getOption("check.log.file")
        on.exit(options(check.log.file=old.check.log.file), add=TRUE)
        options(check.log.file=logfile)
    }

    if (!"tex" %in% tools::file_ext(list.files(path = path)))
        stop("Please supply the directory that contains the .tex file")

    if (is.null(getOption("check.log.journal"))) {
        journal <- new.env(parent=emptyenv())
        options(check.log.journal=journal)
        on.exit(options(check.log.journal=NULL), add=TRUE)
    }

    if (!is.null(logfile))
        writeLines(c("Initial check results: ", ""), logfile)

    if (getOption("check.log.output", "cli") == "cli")
        cli::cli_h1(paste0("Initial check results: "))

    ## BEGIN CHECKS
    ## Folder structure checks:
    check_filenames(path)
    check_structure(path)
    check_folder_structure(path)
    check_unnecessary_files(path)
    check_cover_letter(path)

    ## Tex file checks:
    check_title(path, ...)
    check_section(path)
    check_abstract(path)
    check_spelling(path, dic, ...)
    check_proposed_pkg(pkg, ask)
    check_pkg_label(path)
    check_packages_available(path)
    check_bib_doi(path)
    check_csl(path)
    check_date(path, file)

    ## Show a numeric summary of successes, errors and notes
    journal_summary(file=logfile)

    ## return all results
    invisible(getOption("check.log.journal")$results)
}


##############################################
##############################################

#' @importFrom tools file_ext file_path_sans_ext
#' @rdname checks
#' @export
check_filenames <- function(path) {
    remaining_files <- remove_wrapper(path)
    exts <- tools::file_ext(remaining_files)

    ## do we really want to require R? We didn't use to ...
    files_exist <- c("tex", "bib", "R") %in% exts

    matching_filename <- remaining_files[exts %in% c("tex", "R")]

    single_filename <- tools::file_path_sans_ext(matching_filename)

    ## Check for all three files with matching names
    ## Find the file name that should match

    if (length(unique(single_filename)) != 1) {
        log_error("Submission does not have consistently named tex, R files")
    } else if (!all(files_exist)){
        log_error("Submission is missing a tex, bib or R file")
    } else{
        log_success("Submission has consistently named tex, bib, and R files")
    }
}

#' @rdname checks
#' @export
check_structure <- function(path) {
    all <- list.files(path, all.files=TRUE, include.dirs=TRUE, recursive=TRUE)
    depth <- nchar(gsub("[^/]+", "", all))
    if (max(depth) > 2)
        return(log_error("There are nested subdirectories. Please use at most two directory levels for the article."))
    if (length(dot <- grep("^\\.", gsub(".*/", "", all))))
        log_warning("The archive contains hidden files which will be removed: ", paste(all[dot], collapse=", "))
    nonascii <- function(x) { r <- charToRaw(x); any(r > 127 | r <= 0x20) }
    if (any(sapply(all, nonascii)))
        log_error("File or directory names contain spaces or non-ASCII characters. For portability only use ASCII characters and no spaces in file and directory names.")
    else
        log_success("File and directory names are compliant.")
}

#' @rdname checks
#' @export
check_folder_structure <- function(path){
  files <- list.files(path)
  file_exts <- tools::file_ext(files)

  concat <- function(x)  paste0(x, collapse = ", ")

  img_exts <- c("jpeg", "jpg", "png", "gif", "tiff", "svg")
  img_files <- files[file_exts %in% img_exts] |> concat()

  data_exts <- c("csv", "rda")
  data_files <- files[file_exts %in% data_exts] |> concat()

  r_files <- files[file_exts == "R"]
  log_aux <- files[file_exts %in% c("log", "aux", "out")] |> concat()
  file_txt <- tools::file_path_sans_ext(files)
  motivation <- files[file_exts %in% c("md", "doc", "docx")] |> concat()

  valid_exts <- c("Rproj", ".sty", "bib", "Rmd", "html", "R", "tex", "pdf", "")
  exts_checked <- c(img_exts, data_exts, "R", "log", "aux")
  non_standard <- files[!file_exts %in% c(valid_exts, exts_checked)]
  non_standard <- non_standard[!grepl("motivation", non_standard)] |> concat()
  non_standard <- non_standard[!grepl("RJournal", non_standard)] |> concat()

  if ((length(img_files) > 1) | (str_length(img_files) != 0)){
    log_error("It looks like there are image(s) in the main directory: {img_files}.
              If so, they should be organised into figures/ folder.")
  } else if ((length(data_files) > 1) | (str_length(data_files) != 0)){
    log_error("It looks like there are data file(s) in the main directory: {data_files}.
              If so, they should be organised into data/ folder.")
  } else if (length(r_files) > 1){
    r_files <- concat(r_files)
    log_error(
    "Multiple R files detected: {r_files}.
    Scripts should be organised in the scripts/ folder.
    The master R file generated from rendering should still be in the main directory.")
  } else if (str_length(log_aux) != 0){
    log_error("Auxiliary log and aux files detected: {log_aux}.
              They should be removed.")
  } else if (str_length(motivation) != 0){
    log_error("Possible motivation or cover letters detected in main folder: {motivation}.
              They should be placed in the motivation-letter/ folder.")
  } else if ((length(non_standard) > 1) | (str_length(non_standard) != 0)){
    log_warning(
      "Other non-standard file detected: {non_standard}.
      Should they be removed? ")
  } else{
    log_success("The paper is in good folder structure.")
  }

}

#' @rdname checks
#' @export
check_unnecessary_files <- function(path) {
    submission_files <- list.files(path)
    unnecessary_files <- "RJtemplate.tex"

    if (any(unnecessary_files %in% submission_files)) {
        unnecessary <- unnecessary_files[unnecessary_files %in% submission_files]
        log_error("Submission contains unnecessary files: ", unnecessary)
    } else {
        log_success("No problematic file found")
    }
}

#' @rdname checks
#' @export
check_cover_letter <- function(path){
    remaining_files <- remove_wrapper(path)
    if (!length(mot <- grep("motivation", remaining_files))) {
        log_note("Motivation letter is not detected, if applicable")
    } else {
        log_success("Possible motivation letter found: {paste0(remaining_files[mot], collapse = ', ')}")
    }
}


##############################################
##############################################
# Tex file checks:

#' @param ignore The words to ignore in title check, e.g. package name (data.table, toOoOlTiPs)
#' @importFrom tools toTitleCase
#' @rdname checks
#' @export
check_title <- function(path, ignore = ""){

  tex <- extract_tex(path)
  str <- sub(".*\\\\title\\{([^}]*)\\}.*","\\1", tex, perl = TRUE)
  res <- check_str(str, ignore)

  has_special_format <- grepl(
    "\\pkg\\{.*\\}|\\CRANpkg\\{.*\\}|\\BIOpkg\\{.*\\}", str)
  if (has_special_format){
    log_error("Article title should not contain any special format, such as the
              \\pkg, \\CRANpkg, \\BIOpkg markups used for package names.")
  }

  if (!res$result){
    log_error("Article title not in title case! Suggest title: {res$suggest}.")
  } else{
    log_success("Article title formatted in title case.")
  }

}


check_str <- function(str, ignore = ""){
  ignore <- paste0(ignore, collapse = "", sep = "|")
  str <- gsub(ignore, "", str) # remove ignored words
  str_in_title_case <- tools::toTitleCase(str)
  pass <- str_in_title_case == str

  list(result = pass, suggest = if (!pass) str_in_title_case else NULL)
}


#' @importFrom stringr str_extract
#' @importFrom utils available.packages
#' @rdname checks
#' @export
check_section <- function(path){

  tex <- extract_tex(path)

  str <- unlist(stringr::str_extract_all(tex,  "(?<=\\\\section\\{).*?(?=\\}[\\s]?[\\\\label]?)"))

  if (any(str_detect(str, "texorpdfstring"))){
    str <- unlist(stringr::str_extract_all(tex,  "(?<=\\\\section\\{).*?(?=\\}\\\\label)"))
  }

  clean_section_title <- function(str){
    if (str_detect(str, "texorpdfstring")){
      str <- str_extract(str, "(?<=\\}\\{).*?(?=\\})")
    }

    str
  }

  str <- lapply(str, clean_section_title)
  # remove the capital R
  dt <- do.call(rbind, lapply(str_remove(str, " R"), check_sentence_case))
  res <- paste0(str[!dt[["in_sentence_case"]]], collapse = ", ")
  if (nchar(res) != 0){
    log_error("Section {res} is not in sentence case!")
  } else{
    log_success("Section titles formatted in sentence case.")
  }

}

check_sentence_case <- function(str){
  remove_uppercase <- function(str){
    words <- stringr::str_split(str, " ", simplify = TRUE)
    out <- paste(words[(!stringr::str_to_upper(words) == words )| nchar(words) == 1 ],
                 collapse = " ")
    out
  }

  raw <- str
  str <- remove_uppercase(str)
  str <- strsplit(str, ": ")[[1]]

  data.frame(
    origin = raw,
    in_sentence_case = all(stringr::str_to_sentence(str) == str)
  )
}



#' @rdname checks
#' @export
check_abstract <- function(path){
  tex <- extract_tex_vec(path)
  idx_abs <- which(grepl("\\\\abstract\\{", tex))
  idx_intro <- which(grepl("\\\\section\\{Introduction\\}", tex))
  str <- paste0(tex[(idx_abs+1):(idx_intro-2)], collapse = " ")

  has_special_format <- check_abstract_str(str)

  if (has_special_format){
    log_error("Abstract should be plain text without package markups,
    mathmatic notations, citation, or other formattings."
    )
  } else{
    log_success("Abstract formatted in plain text.")
  }
}

check_abstract_str <- function(str){
  #pkgs
  pkgs <- grepl("\\pkg\\{.*\\}|\\CRANpkg\\{.*\\}|\\BIOpkg\\{.*\\}", str)

  # citation
  citations <- grepl("\\cite\\{.*\\}|\\citep|\\citet", str)

  others <-  grepl("texttt|\\$.*\\$|emph|proglang", str)

  any(c(pkgs, citations, others))
}

#' @importFrom stringr str_extract str_replace_all
#' @importFrom purrr map2 map
#' @importFrom hunspell hunspell dictionary
#' @importFrom tools toTitleCase
#' @rdname checks
#' @export
check_spelling <- function(path, dic = "en_US", ...){

  tex <- extract_tex_vec(path)

  detect_abstract <- purrr::map(tex, ~stringr::str_extract(.x,  "(?<=\\\\abstract\\{).*?"))
  abstract_loc <- match(detect_abstract[!is.na(detect_abstract)], detect_abstract)

  detect_bib <- purrr::map(tex, ~stringr::str_extract(.x,  "(?<=\\\\bibliography\\{).*?(?=\\})"))
  bib_loc <- match(detect_bib[!is.na(detect_bib)], detect_bib)

  # spell_to_remove is a pre-defined vector of latex commands
  # to be removed from spelling check
  to_replace <- paste(spell_to_remove, collapse = "|")
  tex2 <- stringr::str_replace_all(tex, to_replace, "")
  text_bw <- tex2[(abstract_loc + 1):(bib_loc - 1)]

  chunk_begin <- which(text_bw == "\\begin{Schunk}")
  chunk_end <- which(text_bw == "\\end{Schunk}")
  chunk_idx <- unlist(purrr::map2(chunk_begin, chunk_end, ~.x:.y))

  select_idx <- !c(1:length(text_bw)) %in% chunk_idx
  text_clean <- text_bw[select_idx]

  check_raw <- hunspell::hunspell(text_clean, format = "latex", dic = hunspell::dictionary(dic), ...)
  check <- unique(unlist(check_raw))
  check_out <- check[tolower(check) == check]

  if (length(check_out) != 0){
    log_note("A potential list of spelling to check: ", paste(check_out, collapse = ", "))
  } else{
    log_success("No spelling mistake detected")
  }

}

#' @rdname checks
#' @export
check_proposed_pkg <- function(pkg, ask=interactive()) {
    if (missing(pkg) || is.null(pkg)) {
        if (!ask)
            return(log_note("No proposed package supplied."))
        ## This is a really terrible hack ...
        pkg <- readline(prompt = "What's the name of the package being proposed in the article? Press Enter if none. ")
    }

    if (length(pkg) == 1 && nzchar(pkg)) {
        allCRANpkgs <- available.packages(type='source')[,1]
        if (!pkg %in% allCRANpkgs)
            log_note(text = "No CRAN activities detected for package {pkg}")
        else
            log_success(text = "CRAN activities have been detected for package {pkg}")
    } else
        log_success("No proposed package for the article, nothing to check.")
}

#' @rdname checks
#' @export
check_pkg_label <- function(path){
  tex <- extract_tex(path)
  with_pkg_markup <- unique(greg1("\\\\pkg\\{(.*?)\\}", tex))
  cran_idx <- which(with_pkg_markup %in% allCRANpkgs())
  cran_str <- paste0(with_pkg_markup[cran_idx],collapse = ", ")
  bio_idx <- which(with_pkg_markup %in% allBioCpkgs())
  bio_str <- paste0(with_pkg_markup[bio_idx],collapse = ", ")
  if (length(cran_idx) != 0){
    log_error("Package(s) available on CRAN: {cran_str}.
              please use \\CRANpkg rather than \\pkg.")
  } else if (length(bio_idx) != 0){
    log_error("Package(s) available on CRAN: {bio_str}.
            please use \\BIOpkg rather than \\pkg.")
  } else{
    log_success("No error with the use of \\pkg markup.")
  }


}

## get first group from all matches in all strings
greg1 <- function(pattern, strings)
  do.call(rbind, stringr::str_match_all(strings, pattern))[,2]

#' @param ignore The words to ignore in title check, use c(pkg, pkg, ...) for multiple quoted words
#' @importFrom stringr str_match_all
#' @importFrom utils available.packages
#' @importFrom BiocManager version
#' @rdname checks
#' @export
check_packages_available <- function(path, ignore) {
    if (missing(ignore)) ignore <- character()
    tex <- extract_tex(path)

    ## List of CRAN and BioC pkgs used in the text
    CRANpkgs <- unique(greg1("\\\\CRANpkg\\{(.*?)\\}", tex))
    BioCpkgs <- unique(greg1("\\\\BIOpkg\\{(.*?)\\}", tex))

    ## remove ignored ones
    CRANpkgs <- CRANpkgs[!(CRANpkgs %in% ignore)]
    BioCpkgs <- BioCpkgs[!(BioCpkgs %in% ignore)]

    allCRANpkgs <- allCRANpkgs()
    ## only bother with BioC if it is mentioned
    allBioCpkgs <- if (length(BioCpkgs)) {
        allBioCpkgs()
    } else character()

    res1 <- if (!all(CRANpkgs %in% allCRANpkgs)) {
        ## When one is missing from CRAN
        missing <- CRANpkgs[!(CRANpkgs %in% allCRANpkgs)]
        amount_missing <- length(missing)
        amount_pkgs <- length(CRANpkgs)

        log_error(text = "{amount_missing} of {amount_pkgs} package(s) not available on CRAN: {paste(missing, collapse = ', ')}")
    } else if (!all(BioCpkgs %in% allBioCpkgs)) {
        ## When one is missing from Bioconductor
        missing <- BioCpkgs[!(BioCpkgs %in% allBioCpkgs)]
        amount_missing <- length(missing)
        amount_pkgs <- length(BioCpkgs)

        log_error("{amount_missing} of {amount_pkgs} package(s) not available on Bioconductor: {paste(missing, collapse = ', ')}")
    } else {
        log_success("All packages marked-up with \\CRANpkg or \\BIOpkg are available on CRAN or Bioconductor.")
    }

    ## Check that all packages with a \pkg reference also have a \CRANpkg or \BIOpkg mention
    ## pkgs referred to in the text

    pkgs_used <-  unique(greg1("pkg\\{(.*?)\\}", tex))

    ## Start with full list of pkgs
    declared_pkgs <- pkgs_used %in% c(CRANpkgs, BioCpkgs)

    if (any(!declared_pkgs)) {
        ## Look for pkgs that were used in the text but did not have a CRANpkg{} commands
        pkgs_missing_ref <- unique(pkgs_used[!(declared_pkgs)])
        amount_missing <- length(pkgs_missing_ref)

        log_note("{amount_missing} package(s) used in the text without \\CRANpkg or \\BIOpkg commands: {paste(pkgs_missing_ref, collapse = ', ')}")
    }
    ## the last note is not passed as result but will be recorded in the journal
    res1
}

## Get CRAN list
allCRANpkgs <- function() {tools::CRAN_package_db()$Package}
allBioCpkgs <- function(){
  ## Get BioC list
  BioCver <- BiocManager::version()
  available.packages(repos = paste0("https://bioconductor.org/packages/", BioCver, "/bioc"), type='source')[,1]
}

read_bib <- function(path){
  files <- list.files(here::here(path), full.names = TRUE)
  bib_file <- files[tools::file_ext(files) == "bib"]
  a <- rmarkdown::pandoc_citeproc_convert(bib_file, type = "yaml")
  bib_list <- yaml::yaml.load(a)$reference
  return(bib_list)
}

#' @rdname checks
#' @export
check_bib_doi <- function(path){
  bib_list <- read_bib(path)
  id <- c()
  bib_tbl <- lapply(bib_list, function(x) {
    if (is.null(x$doi) && is.null(x$url)){
      id <- c(id, x$id)
    }
  })

  res <- paste0(do.call(rbind,bib_tbl), collapse = ", ")

  if (nchar(res) == 0){
    log_success("All the references contain DOI or URL")
  } else{
    log_warning("Citation should include a link to the reference, preferably a
    DOI, unless online resources cannot be found.
    References without DOI or URL: {res}.")
  }

}

#' @rdname checks
#' @export
check_csl <- function(path){
  files <- list.files(here::here(path), full.names = TRUE)
  rmd_file <- files[tools::file_ext(files) == "Rmd"]

  if (length(rmd_file) == 0) {
    csl_file <- files[tools::file_ext(files) == "csl"]
    if (length(csl_file) != 0) {res <- "has_csl"} else {res <- "good"}
  } else{
    if (length(rmd_file) > 1){
      html_basename <- basename(tools::file_path_sans_ext(
        files[tools::file_ext(files) == "html"]
      ))
      rmd_file <- rmd_file[grepl(html_basename, rmd_file)]
    }

    yaml <- rmarkdown::yaml_front_matter(rmd_file)
    yaml_nms <- names(yaml)
    if ("csl" %in% yaml_nms){ res <- "has_csl"} else {res <- "good"}

  }

  if (res == "has_csl"){
    log_error("Found CSL file {yaml[['csl']]} in the repository.
              No CSL file should be used in R Journal article.")
  } else{
    log_success("No customised csl file used. Good!")
  }

}

#' @rdname checks
#' @export
check_date <- function(path, file){
  files <- list.files(path)
  rmd_file <- files[tools::file_ext(files) == "Rmd"]
  rmd_file <- eliminate_mulitple(rmd_file, file)
  yaml <- rmarkdown::yaml_front_matter(rmd_file)
  if (as.Date(yaml[["date"]], format = "%Y-%m-%d") != Sys.Date()){
    log_error(
      "Please use a fixed article's date in the format of `%Y-%m-%d`,
      e.g. 2023-10-05. The date should match the date when the article
      is submitted. Dynamic date can cause issues on issue rendering.")
  } else{
    log_success("Article date is set fixed at the article submission date.")
  }
}


#' @importFrom stringr str_match str_count
output_summary <- function(path, file = stdout()) {

  completed_checks <- readLines(file.path(path, "initial_checks.log"))

  results <- lapply(X = c("SUCCESS", "ERROR", "NOTE"),
                    FUN = stringr::str_count,
                    string = completed_checks)

  results_tally <- lapply(results, sum)

  results_text <- paste("\n",
                        "SUCCESSES:", results_tally[[1]],"|",
                        "ERRORS:", results_tally[[2]], "|",
                        "NOTES:", results_tally[[3]], sep = " ")

  cat(results_text, "\n",
      sep = " ", file = file, append = TRUE)

  cli::cli_h3(results_text)

}

##############################################
##############################################
# helper functions

remove_wrapper <- function(path){
    submission_files <- list.files(path)
    ## remove both template and wrapper
    wrapper_files <- c("RJwrapper.tex", "RJtemplate.tex")
    submission_files[!(submission_files %in% wrapper_files)]
}

extract_tex_vec <- function(path){
    remaining <- remove_wrapper(path)
    name <- remaining[tools::file_ext(remaining) == "tex"]

    if (length(name) == 0)
        log_error(
        "Can't locate the .tex file under the current path,
        please specify the correct path that contains the .tex file")

    ## NOTE: this may match more files if there are stray ones, so we
    ##       concatenate them all
    if (length(name) > 1) {
        # this will print the msg for every check if there are multiple files
        #log_warning("Multiple .tex files found: {paste(name, collapse=', ')}")
        unlist(lapply(file.path(path, name), readLines))
    } else
        readLines(file.path(path, name))
}

extract_tex <- function(path){
  vec <- extract_tex_vec(path)
  paste0(vec , collapse = " ")
}

spell_to_remove <- c("(\\\\url\\{(.*)\\})",
                     "(\\\\href\\{(.*)\\})",
                     "(\\\\label\\{(.*)\\})",
                     "(\\\\nameref\\{(.*)\\})",
                     "(\\\\code\\{(.*)\\})",
                     "(\\\\CRANpkg\\{(.*)\\})",
                     "(\\\\pkg\\{(.*)\\})",
                     '("(.*)")',
                     "(\\\\textt\\{(.*)\\})",
                     "(\\\\emph\\{(.*)\\})",
                     "(\\\\file\\{(.*)\\})",
                     "(\\\\includegraphics\\[(.*)\\})",
                     "(emph)"
)

##############################################
## Note: this is seriously over-engineered, but the goal was to
## support the previous behavior, allow logging into files as well as
## in-session recording for automated use. We may not keep
## all of it in the end (e.g., it's unclear how useful are the
## conditions), so consider it experimental.
log_factory <- function(result = c("SUCCESS", "NOTE", "WARNING", "ERROR")) {
    result <- match.arg(result)

    function(text, ...,
             output = getOption("check.log.output", "cli"),
             file   = getOption("check.log.file", NULL),
             signal = getOption("check.log.conditions", FALSE),
             .envir = parent.frame()) {

        ## cli is brain-dead and always sends input through glue
        ## with no way to prevent that so we need a way to defer glue
        ## in that case
        cli.glue.fix <- FALSE
        output <- if (is.character(output))
                  switch(output,
                         cli = {
                             cli.glue.fix <- TRUE
                             switch(result,
                                    SUCCESS = cli::cli_alert_success,
                                    NOTE    = cli::cli_alert_info,
                                    WARNING = cli::cli_alert_warning,
                                    ERROR   = cli::cli_alert_danger) },
                         none = identity,
                         switch(result,
                                 SUCCESS =,
                                 NOTE    = function(x) cat(x, "\n", sep=''),
                                 WARNING =,
                                 ERROR   = message)
                         )
              else if (inherits(output, "connection")) {
                  function(x)
                      cat(x, "\n", sep='', file=output, append=TRUE)
              } else
                  stop("Invalid output specification")

        text <- glue::glue(result, ": ", text, ..., .envir = .envir)
        output(if (!cli.glue.fix) text else "{text}")

        ## Send output to the log file (if requested)
        if (!is.null(file))
            cat(text, "\n", sep = "", file = file, append = TRUE)

        ## we use the condition objects as result objects as well
        cond <-
            switch(result,
                   SUCCESS = structure(list(
                       message = text, call = sys.call(-1), trace = sys.calls()),
                       class = c("RJcheckSUCCESS", "RJcheckCondition",
                                 "condition")),
                   NOTE = structure(list(
                       message = text, call = sys.call(-1), trace = sys.calls()),
                       class = c("RJcheckNOTE", "RJcheckCondition",
                                 "message", "condition")),
                   WARNING = structure(list(
                       message = text, call = sys.call(-1), trace = sys.calls()),
                       class = c("RJcheckWARNING", "RJcheckCondition",
                                 "warning", "condition")),
                   ERROR = structure(list(
                       message = text, call = sys.call(-1), trace = sys.calls()),
                       class = c("RJcheckERROR", "RJcheckCondition",
                                 "error", "condition")))

        ## signal the condition only if asked
        if (isTRUE(getOption("check.log.conditions", FALSE)))
            signalCondition(cond)
        ## otherwise we just attach the info
        ## Note that with a simple c() you can drop this
        ## and just get the string with the final status.
        attr(result, "info") <- cond

        ## if the user asked for a journal, add it to the journal
        if (is.environment(ce <- getOption("check.log.journal")))
            ce$results <- c(ce$results, list(result))

        invisible(result)
    }
}

#' @title Logging functions
#'
#' @description \code{log_...} functions produce a log entry.
#'
#' @details
#' Most arguments are intended to be set with options to allow the use
#' of the checking mechanism both in interactive and automated
#' settings. There are four types of log entries: SUCCESS, NOTE,
#' WARNING and ERROR. If the \code{"check.log.journal"} option is set
#' to an environment then the entry is also added to the journal.
#'
#' @param text string, description of the error that occurred,
#'     will be passed to \code{\link{glue}}.
#' @param ... additional inputs for text passed to the \code{\link{glue}} function.
#' @param .envir the environment used to find the text string replacements
#' @param output type of the output, can either a string (\code{"cli"}
#'     to use the \code{cli} package (default), \code{"R"} for
#'     standard R facilities or \code{"none"} for no output) or a
#'     connection. It uses the \code{"check.log.output"} option if
#'     set.
#' @param file connection to log a copy of the output to or NULL
#'     (default) if no additional copy is desired. It uses the
#'     \code{"check.log.file"} option.
#' @param signal logical, if \code{TRUE} then a condition is signalled
#'     at the end of the function. All conditions have superclass
#'     \code{"RJcheckCondition"} and subclass \code{"RJCheck<result>"}
#'     where \code{<result>} is one of \code{SUCCESS}, \code{NOTE},
#'     \code{WARNING} and \code{ERROR}. They also have the
#'     corresponding standard R condition classes. Uses option
#'     \code{"check.log.conditions"}.
#'
#' @return \code{log_...} string with the result type. The
#'     corresponding condition object with a message and call is
#'     included in the \code{"info"} attribute (even if no condition
#'     is signalled).
#'
#' @keywords internal
log_error <- log_factory("ERROR")

#' @rdname log_error
log_success <- log_factory("SUCCESS")

#' @rdname log_error
log_note <- log_factory("NOTE")

#' @rdname log_error
log_warning <- log_factory("WARNING")


#' @description \code{journal_summary} prints a quick summary (status
#'     counts) based on the journal.
#'
#' @param journal environment of the journal
#' @rdname log_error
#' @return \code{journal_summary} table of the status counts
journal_summary <- function(journal=getOption("check.log.journal"),
                            file=stdout()) {
    if (!is.environment(journal))
        return(warning("No journal found."))
    res <- unlist(journal$results)
    ct <- table(factor(res, c("SUCCESS", "NOTE", "WARNING", "ERROR")))
    text <- paste(names(ct), ct, sep=": ", collapse=" | ")
    cat("", text, "", sep="\n")
    if (!is.null(file))
        cat("", text, "", sep="\n", file=file, append=TRUE)
    invisible(ct)
}

#' @description \code{simplify_journal} returns a simplified form of the
#'     results in the journal.
#'
#' @return \code{simplify_journal} string matrix with columns "result"
#'     (status), "test" (name of the calling function) and "message"
#' @rdname log_error
simplify_journal <- function(journal=getOption("check.log.journal")) {
    if (!is.environment(journal))
        return(warning("No journal found."))
    res <- journal$results
    t(sapply(res, function(o)
        c(result=c(o), test=as.character(attr(o, "info")$call[[1]]), message=c(attr(o, "info")$message))))
}


################################################################################

#' Various handy symbols to use in a command line UI
#'
#' Show symbols in console output
#'
#'
#' @name symbol
#' @aliases symbol
#' @keywords internal
symbol_utf8 <- list(
  "tick" = '\u2714',
  "cross" = '\u2716',
  "pointer" = '\u276F',
  "line" = '\u2500'
)

symbol_rstudio <- symbol_utf8
symbol_rstudio$tick <- "\u2713"
symbol_rstudio$cross <- "x"
symbol_rstudio$pointer <- ">"

symbol_win <- list(
  "tick" = '\u221A',
  "cross" = 'x',
  "line" = '-'
)

symbol_ascii <- list(
  "tick" = 'v',
  "cross" = 'x',
  "star" = '*',
  "line" = '-'
)