R/radiator.R

In thierrygosselin/radiator: RADseq Data Exploration, Manipulation and Visualization using R

# radiator package startup message ---------------------------------------------
# .onAttach <- function(libname, pkgname) {
#   radiator.version <- utils::packageDescription("radiator", fields = "Version")
#   radiator.build <- utils::packageDescription("radiator", fields = "Built")
#   startup.message <- stringi::stri_join(
#     "******************************* IMPORTANT NOTICE *******************************\n",
#     "radiator v.", radiator.version, " was modified heavily.\n",
#     "Read functions documentation and available vignettes.\n\n",
#     "For reproducibility:\n",
#     "    radiator version: ", radiator.version,"\n",
#     "    radiator build date: ", radiator.build,"\n",
#     "    Keep zenodo DOI.\n",
#     "********************************************************************************",
#     sep = "")
#   packageStartupMessage(startup.message)
# }

# radiator_function_header -----------------------------------------------------
#' @title radiator_function_header
#' @description Generate function header
#' @rdname radiator_function_header
#' @keywords internal
#' @export
radiator_function_header <- function(f.name = NULL, start = TRUE, verbose = TRUE) {
  if (is.null(f.name)) invisible(NULL)
  if (start) {
    if (verbose) {
      message(stringi::stri_pad_both(str = "", width = 80L, pad = "#"))
      message(stringi::stri_pad_both(str = paste0(" radiator::", f.name, " "), width = 80L, pad = "#"))
      message(stringi::stri_pad_both(str = "", width = 80L, pad = "#"), "\n")
    }
  } else {
    if (verbose) {
      message(stringi::stri_pad_both(str = paste0(" completed ", f.name, " "), width = 80L, pad = "#"), "\n")
    }
  }
}# End radiator_function_header

# radiator common arguments ----------------------------------------------------
#' @name radiator_common_arguments
#' @title radiator common arguments
#' @description radiator common arguments
#' @rdname radiator_common_arguments
#' @export
#' @keywords internal

#' @param interactive.filter (optional, logical) Do you want the filtering session to
#' be interactive. Figures of distribution are shown before asking for filtering
#' thresholds.
#' Default: \code{interactive.filter = TRUE}.

#' @param gds (2 options) A Genomic Data Structure (GDS) file or object
#'
#' \emph{How to get GDS ?}
#' Look into \code{\link{tidy_genomic_data}},
#' \code{\link{read_vcf}},
#' \code{\link{tidy_vcf}} or \code{\link{write_gds}}.


#' @param data (4 options) A file or object generated by radiator:
#' \itemize{
#' \item tidy data
#' \item Genomic Data Structure (GDS)
#' }
#'
#' \emph{How to get GDS and tidy data ?}
#' Look into \code{\link{tidy_genomic_data}},
#' \code{\link{read_vcf}} or
#' \code{\link{tidy_vcf}}.


#' @param verbose (optional, logical) When \code{verbose = TRUE}
#' the function is a little more chatty during execution.
#' Default: \code{verbose = TRUE}.

#' @param parallel.core (optional) The number of core used for parallel
#' execution during import.
#' Default: \code{parallel.core = parallel::detectCores() - 1}.

#' @param random.seed (integer, optional) For reproducibility, set an integer
#' that will be used inside the function that requires randomness. With default,
#' a random number is generated and printed in the appropriate output.
#' Default: \code{random.seed = NULL}.



#' @param ... (optional) Advance mode that allows to pass further arguments
#' for fine-tuning the function. Also used for legacy arguments (see details or
#' special section)


# @inheritParams radiator_common_arguments


radiator_common_arguments <- function(
  interactive.filter = TRUE,
  gds,
  data,
  parallel.core = parallel::detectCores() - 1,
  verbose = TRUE,
  random.seed = NULL,
  ...) {
  data = NULL
  parallel.core <- NULL
  verbose <- NULL
  random.seed <- NULL
}#End radiator_common_arguments


# radiator_question ---------------------------------------------------------
#' @title radiator_question
#' @description Ask to enter a word or number
#' @rdname radiator_question
#' @keywords internal
#' @export
radiator_question <- function(x, answer.opt = NULL, minmax = NULL) {
  # Note to myself: tryCatch might be simpler here... investigate
  message(x)
  question <- function(x, answer.opt) {

    if (!is.null(answer.opt)) {
      answer.type <- (unique(class(answer.opt)))
      if (answer.type == "character") {
        x <-   match.arg(arg = readLines(n = 1), choices = answer.opt)
      }
      if (answer.type == "numeric") {
        x <-   match.arg(arg = as.numeric(readLines(n = 1)), choices = answer.opt)
      }
      if (answer.type == "integer") {
        x <-   match.arg(arg = as.integer(readLines(n = 1)), choices = answer.opt)
      }
    }
    answer.type <- NULL
    return(x)
  }
  safe_question <- purrr::safely(.f = question, otherwise = FALSE)
  answers.ok <- FALSE
  while (!answers.ok) {

    if (!is.null(minmax)) {
      # answer <- as.numeric(readLines(n = 1))
      answer <- readLines(n = 1)

      check.answer <- stringi::stri_detect_regex(str = answer, pattern = "[0-9]")
      if (check.answer) {
        answer <- as.numeric(answer)
        good.value <- (answer >= minmax[1] & answer <= minmax[2])
        if (!good.value) {
          answers.ok <- FALSE
          message("Please try again: ")
        } else {
          answers.ok <- TRUE
        }
        good.value <- NULL
      } else {
        answers.ok <- FALSE
        message("Please try again: ")
      }
    } else {
      answer <- safe_question(x, answer.opt = answer.opt)
      if (is.null(answer$error)) {
        answer <- answer$result
        answers.ok <- TRUE
      } else {
        answers.ok <- FALSE
        message("Please try again, options are: ",
                stringi::stri_join(answer.opt, collapse = " or "))
      }
    }
  }
  return(answer)
}#End radiator_question


# radiator_parameters-------------------------------------------------------------
#' @title radiator_parameters
#' @description Generate or update a filters parameters file and object.
#' Used internally in radiator, not usefull outside the package.
#' @rdname radiator_parameters
#' @export
#' @keywords internal

# Note to myself: might be able to increase timing here by reading a whitelist
# instead of markers.meta for gds file...
# Then figure out what to do with individuals and strata...

radiator_parameters <- function(
  generate = FALSE,
  initiate = FALSE,
  update = TRUE,
  parameter.obj = NULL,
  data = NULL,
  filter.name = "",
  param.name = "",
  values = paste(NULL, NULL, sep = " / "),
  units = "individuals / strata / chrom / locus / markers",
  comments = "",
  path.folder = NULL,
  file.date = NULL,
  internal = FALSE,
  verbose = TRUE
) {
  if (internal && !verbose) return(NULL)
  res <- list()# initiate the list to store the results
  if (is.null(file.date)) file.date <- format(Sys.time(), "%Y%m%d@%H%M")

  # check for existing file
  if (is.null(path.folder)) path.folder <- getwd()
  if (!is.null(parameter.obj) && generate && !initiate) {
    generate <- initiate <- update <- FALSE
    res <- parameter.obj
  }
  if (!is.null(parameter.obj) && generate && initiate) generate <- FALSE
  if (is.null(parameter.obj) && update) rlang::abort("parameter.obj = NULL not accepted")
  if (internal) verbose <- FALSE

  # GENERATE filters parameters file
  if (generate) {

    filters.parameters.name <- generate_filename(
      name.shortcut = "filters_parameters",
      path.folder = path.folder,
      date = file.date,
      extension = "tsv"
    )$filename

    parameter.obj$filters.parameters.path <- res$filters.parameters.path <- filters.parameters.name

    res$filters.parameters <- tibble::tibble(
      FILTERS = as.character(),
      PARAMETERS = as.character(),
      VALUES = as.character(),
      BEFORE = as.character(),
      AFTER = as.character(),
      BLACKLIST = as.integer(),
      UNITS = as.character(),
      COMMENTS = as.character())

    readr::write_tsv(
      x = res$filters.parameters,
      file = filters.parameters.name
      )
    if (verbose) message("Filters parameters file generated: ", basename(filters.parameters.name))
  }#End generate

  # INITIATE filters parameters file
  if (initiate) {
    if (is.null(data)) rlang::abort("GDS or tidy data object required")
    res$info <- parameter.obj$info <- data_info(data)
    res$filters.parameters.path <- parameter.obj$filters.parameters.path
  }#End initiate

  # UPDATE filters parameters file
  if (update) {
    if (is.null(data)) rlang::abort("GDS or tidy data object required")
    info <- parameter.obj$info
    info.new <- data_info(data) # updating parameters

    res$filters.parameters <- tibble::tibble(
      FILTERS = filter.name,
      PARAMETERS = param.name,
      VALUES = if (!is.null(values)) {
        values
      } else {
        "not filtering"
      },
      BEFORE = paste(info$n.ind, info$n.pop, info$n.chrom, info$n.locus, info$n.snp, sep = " / "),
      AFTER = paste(info.new$n.ind, info.new$n.pop, info.new$n.chrom, info.new$n.locus, info.new$n.snp, sep = " / "),
      BLACKLIST = paste(info$n.ind - info.new$n.ind, info$n.pop - info.new$n.pop, info$n.chrom - info.new$n.chrom, info$n.locus - info.new$n.locus, info$n.snp - info.new$n.snp, sep = " / "),
      UNITS = units,
      COMMENTS = comments
    )

    readr::write_tsv(
      x = res$filters.parameters,
      file = parameter.obj$filters.parameters.path,
      append = TRUE,
      col_names = FALSE
    )
    if (verbose) message("Filters parameters file updated: ", basename(parameter.obj$filters.parameters.path))

    # update info
    res$info <- info.new
    res$filters.parameters.path <- parameter.obj$filters.parameters.path
  }#End update

  return(res)
}#End radiator_parameters

# data.info -------------------------------------------------------------
#' @title data_info
#' @description function generate tidy data main info
#' @rdname data_info
#' @keywords internal
#' @export
data_info <- function(x, verbose = FALSE) {
  res <- list()

  data.type <- class(x)[1]

  if (data.type == "tbl_df") {
    if (rlang::has_name(x, "POP_ID") || rlang::has_name(x, "STRATA")) {

      if (rlang::has_name(x, "POP_ID")) {
        res$n.pop <- length(unique(x$POP_ID))
      } else {
        res$n.pop <- length(unique(x$STRATA))
      }
    } else {
      res$n.pop <- NA_integer_
    }

    if (rlang::has_name(x, "INDIVIDUALS")) {
      res$n.ind <- length(unique(x$INDIVIDUALS))
    } else {
      res$n.ind <- NA_integer_
    }


    if (rlang::has_name(x, "MARKERS")) {
      res$n.snp <- length(unique(x$MARKERS))
    } else {
      res$n.snp <- NA_integer_
    }

    if (rlang::has_name(x, "LOCUS")) {
      res$n.locus <- length(unique(x$LOCUS))
    } else {
      res$n.locus <- NA_integer_
    }

    if (rlang::has_name(x, "CHROM")) {
      res$n.chrom <- length(unique(x$CHROM))
    } else {
      res$n.chrom <- NA_integer_
    }
  } else {
    i <- extract_markers_metadata(
      gds = x,
      markers.meta.select = c("CHROM", "LOCUS", "MARKERS"),
      whitelist = TRUE)
    res$n.chrom <- length(unique(i$CHROM))
    res$n.locus <- length(unique(i$LOCUS))
    res$n.snp <- length(unique(i$MARKERS))
    i <- extract_individuals_metadata(
      gds = x,
      ind.field.select = c("STRATA", "INDIVIDUALS"),
      whitelist = TRUE)
    res$n.pop <- length(unique(i$STRATA))
    res$n.ind <- length(unique(i$INDIVIDUALS))
    # res$n.chrom <- length(unique(gdsfmt::read.gdsn(gdsfmt::index.gdsn(node = x, path = "radiator/markers.meta/CHROM", silent = TRUE))))
    # res$n.locus <- length(unique(gdsfmt::read.gdsn(gdsfmt::index.gdsn(node = x, path = "radiator/markers.meta/LOCUS", silent = TRUE))))
    # res$n.snp <- length(unique(gdsfmt::read.gdsn(gdsfmt::index.gdsn(node = x, path = "radiator/markers.meta/MARKERS", silent = TRUE))))
    # res$n.pop <- length(unique(gdsfmt::read.gdsn(gdsfmt::index.gdsn(node = x, path = "radiator/individuals/STRATA", silent = TRUE))))
    # res$n.ind <- length(unique(gdsfmt::read.gdsn(gdsfmt::index.gdsn(node = x, path = "radiator/individuals/INDIVIDUALS", silent = TRUE))))
    res[is.null(res)] <- NA_integer_
  }

  if (verbose) {
    message("Number of chrom: ", res$n.chrom)
    message("Number of locus: ", res$n.locus)
    message("Number of SNPs: ", res$n.snp)
    message("Number of strata: ", res$n.pop)
    message("Number of individuals: ", res$n.ind)
  }
  return(res)
}

# radiator_results_message ------------------------------------------------------------
#' @title radiator_results_message
#' @description Message printed at the end of most radiator functions
#' @keywords internal
#' @export
radiator_results_message <- function(
  rad.message = NULL,
  filters.parameters,
  internal = FALSE,
  verbose = TRUE
) {
  if (!internal) {
    if (verbose) cat("################################### RESULTS ####################################\n")
    if (!is.null(rad.message)) message(rad.message)
    message("Number of individuals / strata / chrom / locus / SNP:")
    if (verbose) message("    Before: ", filters.parameters$filters.parameters$BEFORE)
    message("    Blacklisted: ", filters.parameters$filters.parameters$BLACKLIST)
    if (verbose) message("    After: ", filters.parameters$filters.parameters$AFTER)
  }
}#End radiator_results_message

# radiator_folder--------------------------------------------------------------------
#' @title radiator_folder
#' @description Generate the rad folders
#' @param path.folder path of the folder
#' @param prefix.int Use an integer prefix padded left with 0.
#' Default: \code{prefix.int = TRUE}.
#' @keywords internal
#' @export
#' @rdname radiator_folder
#' @author Thierry Gosselin \email{thierrygosselin@@icloud.com}

radiator_folder <- function(rad.folder, path.folder = NULL, prefix.int = TRUE) {
  if (is.null(path.folder)) path.folder <- getwd()
  if (prefix.int) {
    existing.dirs <- list.dirs(path = path.folder, full.names = FALSE, recursive = FALSE)
    if (length(existing.dirs) > 0) {
      check <- existing.dirs %>%
        stringi::stri_extract_first_regex(str = ., pattern = "^[0-9]*_") %>%
        stringi::stri_remove_na(x = .)

      if (length(check) > 0L) {
        check %<>%
          stringi::stri_extract_first_regex(
            str = .,
            pattern = "\\d{2}"
          ) %>%
          stringi::stri_replace_first_regex(
            str = .,
            pattern = "^[0]",
            # pattern = "0",
            replacement = ""
          ) %>%
          as.integer(x = .) %>%
          sort

        last.num <- utils::tail(x = check, 1)
        check.num <- length(check)
        if (identical(check.num, last.num)) {
          select.last <- max(check.num, last.num, na.rm = TRUE)
        } else {
          select.last <- check.num <- last.num
        }
        existing.dirs <- select.last + 1L
      } else {
        existing.dirs <- 1L
      }
    } else {
      existing.dirs <- 1L
    }

    rad.folder <- existing.dirs %>%
      as.character %>%
      stringi::stri_pad_left(str = ., width = 2, pad = 0) %>%
      stringi::stri_join(., "_", rad.folder)
  }
  radiator.folder.full.path <- file.path(path.folder, rad.folder)
  return(radiator.folder.full.path)
}#End radiator_folder


# generate_squeleton_folders----------------------------------------------------
#' @title generate_squeleton_folders
#' @description Generate squeleton folders
#' @keywords internal
#' @export
generate_squeleton_folders <- function(
  fp = 0L,
  path.folder = NULL,
  interactive.filter = TRUE,
  ...
) {

  # test
  # fp = 0L
  # file.date <- format(Sys.time(), "%Y%m%d@%H%M")
  # interactive.filter = TRUE

  if (is.null(path.folder)) path.folder <- getwd()
  folders.labels <- c(
    "filter_dart_reproducibility",
    "filter_individuals", "filter_individuals", "filter_individuals",
    "filter_common_markers",
    "filter_ma",
    "filter_coverage",
    "filter_genotyping",
    "filter_snp_position_read",
    "filter_snp_number",
    "filter_ld", "filter_ld",
    "detect_mixed_genomes",
    "detect_duplicate_genomes",
    "filter_hwe")

  if (!interactive.filter) {
    get.filters <- ls(envir = as.environment(1))
    need <- c(
      "filter.reproducibility",
      "filter.individuals.missing",
      "filter.individuals.heterozygosity",
      "filter.individuals.coverage.total",
      "filter.common.markers",
      "filter.ma",
      "filter.coverage",
      "filter.genotyping",
      "filter.snp.position.read",
      "filter.snp.number",
      "filter.short.ld",
      "filter.long.ld",
      "detect.mixed.genomes",
      "detect.duplicate.genomes",
      "filter.hwe")
    folders <- purrr::keep(.x = get.filters, .p = get.filters %in% need)
    wanted_filters <- function(x) {
      !is.null(rlang::eval_tidy(rlang::parse_expr(x)))
    }
    folders <- purrr::keep(.x = folders, .p = wanted_filters)
    folders <- factor(
      x = folders,
      levels = need,
      labels = folders.labels,
      ordered = TRUE
    ) %>%
      droplevels(.) %>%
      unique %>%
      sort %>%
      as.character
  } else {
    folders <- unique(folders.labels)
  }

  folders <- c("radiator", folders)

  res <- list()
  fp.loop <- fp
  temp <- NULL
  for (f in folders) {
    # message("Processing: ", f)
    temp <- folder_prefix(
      prefix.int = fp.loop,
      prefix.name = f,
      path.folder = path.folder)
    res[[f]] <- temp$folder.prefix
    fp.loop <- temp$prefix.int
  }
  return(res)
}#End generate_squeleton_folders
# generate_filename-------------------------------------------------------------
#' @title Filename radiator
#' @description Generate a filename object
#' @name generate_filename
#' @rdname generate_filename
#' @keywords internal
#' @export
generate_filename <- function(
  name.shortcut = NULL,
  path.folder = NULL,
  date = TRUE,
  extension = c(
    "tsv", "gds.rad", "rad", "gds", "gen", "dat",
    "genind", "genlight", "gtypes", "vcf", "colony",
    "bayescan", "gsisim", "hierfstat", "hzar", "ldna",
    "pcadapt", "related", "stockr", "structure", "arlequin",
    "arrow.parquet"
  )
) {

  if (is.null(path.folder)) path.folder <- getwd()

  # date and time-
  if (is.character(date)) {
    file.date <- stringi::stri_join("_", date)
  } else if (date) {
    file.date <- stringi::stri_join("_", format(Sys.time(), "%Y%m%d@%H%M"))
  } else {
    file.date <- ""
  }

  # path.folder
  if (!dir.exists(path.folder)) dir.create(path.folder)

  # Extension
  want <- c("tsv", "gds.rad", "rad", "gds", "gen", "dat", "genind", "genlight", "gtypes",
            "vcf", "colony", "bayescan", "gsisim", "hierfstat", "hzar", "ldna",
            "pcadapt", "plink", "related", "stockr", "structure", "arlequin",
            "arrow.parquet")
  extension <- match.arg(extension, want)

  # note to myself: currently excluded output :
  # "fineradstructure", "maverick", "plink", "betadiv"


  # with same extension
  # extension <- "tsv"
  if (extension %in% c("tsv", "gds.rad", "rad", "gds", "vcf", "colony", "ldna",
                       "arrow.parquet")) {
    extension <- stringi::stri_join(file.date, ".", extension)
  }


  # Radiator saveRDS
  # extension <- "genind"
  if (extension %in% c("genind", "genlight", "gtypes", "stockr")) {
    extension <- stringi::stri_join("_", extension, file.date, ".RData")
  }

  # Radiator tsv
  if (extension %in% c("tsv")) {
    extension <- stringi::stri_join("_", extension, file.date, ".tsv")
  }

  # Radiator txt
  if (extension %in% c("bayescan", "pcadapt", "related")) {
    extension <- stringi::stri_join("_", extension, file.date, ".txt")
  }

  # Radiator csv
  if (extension %in% c("hzar", "arlequin")) {
    extension <- stringi::stri_join("_", extension, file.date, ".csv")
  }

  # custom
  if (extension == "gen") extension <- stringi::stri_join("_genepop", file.date, ".gen")
  if (extension == "dat") extension <- stringi::stri_join("_fstat", file.date, ".dat")
  if (extension == "hierfstat") extension <- stringi::stri_join("_hierfstat", file.date, ".dat")
  if (extension == "structure") extension <- stringi::stri_join("_structure", file.date, ".str")

  # Filename
  if (is.null(name.shortcut)) {
    filename <- stringi::stri_join("radiator", extension)
  } else {
    filename.problem <- file.exists(stringi::stri_join(name.shortcut, extension))
    if (filename.problem) {
      filename <- stringi::stri_join(filename, "_radiator", extension)
    } else {
      filename <- stringi::stri_join(name.shortcut, extension)
    }
    filename.problem <- file.exists(filename)
    if (filename.problem) {
      filename <- stringi::stri_join("duplicated_", filename)
    }
  }


  # Include path.folder in returned object
  return(res = list(filename.short = filename, filename = file.path(path.folder, filename)))
}#End generate_filename


# generate_folder---------------------------------------------------------------

#' @title generate_folder
#' @description Generate a folder based on ...
#' @name generate_folder
#' @param rad.folder Name of the rad folder
#' @param internal (optional, logical) Is the function internal or not
#' @param append.date Include the date and time with the folder.
#' Default: \code{append.date = TRUE}.
#' @param file.date The file date included in as argument/value or with
#' default \code{file.date = NULL}, generated by the fucntion.
#' @inheritParams radiator_folder
#' @inheritParams radiator_common_arguments
#' @keywords internal
#' @export
#' @rdname generate_folder
#' @author Thierry Gosselin \email{thierrygosselin@@icloud.com}

generate_folder <- function(
    rad.folder = NULL,
    path.folder = NULL,
    internal = FALSE,
    append.date = TRUE,
    file.date = NULL,
    prefix.int = TRUE,
    verbose = FALSE
) {

  if (internal) {
    rad.folder <- NULL
    f.temp <- radiator.folder.full.path <- path.folder
  }

  if (!is.null(rad.folder)) {
    f.temp <- radiator.folder.full.path <- radiator_folder(
      rad.folder = rad.folder,
      path.folder = path.folder,
      prefix.int = prefix.int
      )
  }



  if (is.null(file.date)) {
    file.date <- format(Sys.time(), "%Y%m%d@%H%M")# Date and time
  }

  if (is.null(radiator.folder.full.path)) {
    radiator.folder.full.path <- getwd()
  } else {
    #working directory in the path?
    wd.present <- TRUE %in% unique(stringi::stri_detect_fixed(str = radiator.folder.full.path, pattern = c(getwd(), paste0(getwd(), "/"))))
    date.present <- TRUE %in% unique(stringi::stri_detect_fixed(str = radiator.folder.full.path, pattern = "@"))
    if (!date.present && append.date) radiator.folder.full.path <- stringi::stri_join(radiator.folder.full.path, file.date, sep = "_")
    if (!wd.present) radiator.folder.full.path <- file.path(getwd(), radiator.folder.full.path)
    if (verbose && !identical(f.temp, radiator.folder.full.path)) message("Folder created: ", basename(radiator.folder.full.path))
  }
  if (!dir.exists(radiator.folder.full.path)) dir.create(radiator.folder.full.path)
  return(radiator.folder.full.path)
}#End generate_folder


# folder_prefix-----------------------------------------------------------------
#' @title folder_prefix
#' @description Generate a seq and folder prefix
#' @name folder_prefix
#' @rdname folder_prefix
#' @keywords internal
#' @export
folder_prefix <- function(
  prefix.int = NULL,
  prefix.name = NULL,
  path.folder = NULL
) {
  if (is.null(path.folder)) {
    path.folder <- getwd()
  } else {
    if (stringi::stri_sub(str = path.folder, from = -1, length = 1) == "/") {
      path.folder <- stringi::stri_replace_last_regex(
        str = path.folder,
        pattern = "[/$]",
        replacement = "")
    }
  }

  if (is.null(prefix.int)) {
    prefix.int <- 0L
  } else {
    if (is.list(prefix.int)) {
      prefix.int <- as.integer(prefix.int$prefix.int) + 1L
    } else {
      prefix.int <- as.integer(prefix.int) + 1L
    }
  }

  if (is.null(prefix.name)) {
    folder.prefix <- stringi::stri_join(
      stringi::stri_pad_left(
        str = prefix.int, width = 2, pad = 0
      ), "_"
    )
  } else {
    folder.prefix <- stringi::stri_join(
      stringi::stri_pad_left(
        str = prefix.int, width = 2, pad = 0
      ),
      prefix.name,
      sep = "_"
    )
  }
  folder.prefix <- file.path(path.folder, folder.prefix)
  res = list(prefix.int = prefix.int, folder.prefix = folder.prefix)
}#End folder_prefix


# radiator_snakecase------------------------------------------------------------
#' @title radiator_snakecase
#' @description Transform CamelCase to SCREAMING snake_cases
#' @name radiator_snakecase
#' @rdname radiator_snakecase
#' @keywords internal
#' @export
radiator_snakecase <- function(x) {
  x |>
    stringi::stri_replace_all_regex("([A-Za-z])([A-Z])([a-z])", "$1_$2$3") |>
    stringi::stri_replace_all_fixed(".", "_") |>
    stringi::stri_replace_all_regex("([a-z])([A-Z])", "$1_$2") |>
    stringi::stri_trans_toupper()


}#End radiator_snakecase


# radiator_packages_dep---------------------------------------------------------
#' @title radiator_packages_dep
#' @description Verify required packages
#' @rdname radiator_packages_dep
#' @keywords internal
#' @export
radiator_packages_dep <- function(package, cran = TRUE, bioc = FALSE) {
  if (cran) bioc <- FALSE
  if (bioc) cran <- FALSE
  installer <- "devtools::install_github"
  if (cran) installer <- "install.packages"
  if (bioc) installer <- "BiocManager::install"
  how.to <- stringi::stri_join(installer, "('", package, "')")
  if (suppressPackageStartupMessages(!requireNamespace(package, quietly = TRUE))) {
    rlang::abort(
      paste0(paste0("Package required: ", package),
             paste0("\n       Install with: ", how.to))
    )
  }

}#End radiator_packages_dep

# radiator_packages_dep(package = "SeqArray", cran = FALSE, bioc = TRUE)
# requireNamespace
# installed.packages


# radiator_clock ---------------------------------------------------------------
#' @title radiator_tic
#' @description radiator tictoc function
#' @rdname radiator_tic
#' @keywords internal
#' @export
radiator_tic <- function(timing = proc.time()) {
    invisible(timing)
}# End radiator_tic

#' @title radiator_toc
#' @description radiator tictoc function
#' @rdname radiator_toc
#' @keywords internal
#' @export
radiator_toc <- function(
  timing,
  end.message = "Computation time, overall:",
  verbose = TRUE
) {
  if (verbose) message("\n", end.message, " ", round((proc.time() - timing)[[3]]), " sec")
}# End radiator_toc