AEDA: Automated Exploratory Data Analysis

# if a Sub Directory doesn't exist it Creates one (in the working directory) and moves
# the wd to the sub directory. It returns the original wd
createDir = function(sub.dir, save.mode = TRUE) {
  temp.wd = getwd()
  # In Save mode folder must not exist and has to be writable
  assertPathForOutput(sub.dir, overwrite = !save.mode)
  if (file.exists(sub.dir)) {
    setwd(file.path(temp.wd, sub.dir))
  } else {
    dir.create(file.path(temp.wd, sub.dir))
    setwd(file.path(temp.wd, sub.dir))
  }
  return(temp.wd)
}
# nolint start
# creates a random generated Variable name.
reportId = function(length = 16) {
  # Bad solution. Prbably not a good idea to fiddle with .Random.seed
  if (exists(".Random.seed")) {
    old = .Random.seed
    on.exit({.Random.seed <<- old})
  }
  ## Hacky solution for high precision time as integer
  # Shorten time since only small values are of interest
  f.5 = signif(as.numeric(as.POSIXct(Sys.time())), digits = 5)
  sh.time = (as.numeric(as.POSIXct(Sys.time())) - f.5)
  # this is now convertable to integer in ms
  ms.time = as.integer(sh.time * 1000)
  # set seed with ms time stamp
  Sys.sleep(0.01)
  set.seed(ms.time)
  # start rng string with z so its listed last when files sorted by name
  collapse(c("z",
    sample(c(letters, LETTERS, 0:9), size = length - 1, replace = TRUE)),
    sep = "")
  # chance for some id: 62^length to 1; ~ 10^28 to 1
}
# nolint end

# Takes an object and adds more attributes
addAttToObj = function(object, ...){
  att = list(...)
  for (i in names(object)) {
    att[[i]] = object[[i]]
  }
  setClasses(att, class(object))
}

# Takes an object and creates a new one with the same attributes plus "..."
makeS3Obj2 = function(classes, object, ...){
  result = addAttToObj(object, ...)
  class(result) = classes
  return(result)
}

# Wrapper for loading not already loaded librarys, input is a character vector
rmdLibrary = function(needed.pkgs, file){
  for (i in seq.int(length(needed.pkgs))){
    rmdLibrarySingle(needed.pkgs[i], file)
  }
}
# like rmdLibrary but input is a single character string
rmdLibrarySingle = function(needed.pkg, file){
  catf('if (!require("%s",character.only = TRUE)) {
    install.packages("%s",dep=TRUE)
    if(!require("%s",character.only = TRUE)) stop("Package not found")
    }', needed.pkg, needed.pkg, needed.pkg, file = file)
}

# Wrapper for loading data
rmdloadData = function(name, path, file){
  catf("%s = readRDS(\"%s.rds\")", name, path, file = file)
}

# Wrapper for writing lines
rmdWriteLines = function(vec, con){
  for (i in seq_along(vec)) {
    writeLines(vec[i], con = con)
  }
}
# Example: rmdWriteLines(letters, stdout())

# Collects needed packages
getPkgs = function(obj){
  unique(c(obj$needed.pkgs, obj$plot.code$needed.pkg))
}

# Saves an object and writes code to load it into the rmd file
saveLoadObj = function(obj, name, file, override = FALSE){
  #save object
  obj.file.name = paste0(name, ".rds")
  if (file.exists(obj.file.name) & !override)
    stop(paste0(obj.file.name, " already exists! Please rename the *.report object in function call write*Report() "))
  saveRDS(obj, file = obj.file.name)
  #load object; x$var.id is needed so the plo
  rmdloadData(obj$report.id, name, file)
}

# Checks if a rmd file exists and if it exists then increase the index. It returns
# the first file that doesnt exist.
rmdName = function(name, index = 1L, max.depth = 100L) {
  rmd.file = paste0(name, index, ".rmd")
  if (file.exists(rmd.file) & index <= max.depth) {
    index = index + 1L
    rmdName(name, index, max.depth)
  } else {
    if (index > max.depth) warning(paste0("Too many rmd-Files: \"", rmd.file, "\"", " will be overwritten"))
    return(rmd.file)
  }
}
#splits a list with j sublists into ceiling(j / k) list with each maximal k list
#done for mulitplot. e.g plotlist consists of 11 sublists, then we plot maximal 9 plots
#into one page, hence: here j = 11 and k = 9 results into 2 pages where on
#the first page 9 plots and on the second the rest 2

splitGGplotList = function(mylist, k) {
  j = length(mylist)
  no.new.lists = ceiling(j / k)
  fact.vec = integer()
  for (v in seq_len(no.new.lists)) {
    tmp.vec = rep(v, times = k)
    fact.vec = c(fact.vec, tmp.vec)
  }
  fact.vec = fact.vec[1:j]
  out.list = split(mylist, fact.vec, use.names)
}


#helper to split a plot.list which is divided into
#plot.list_col1_col_1_ggplot into plot.list_col1_ggplot
split.list.gg.helper = function(nested.gg.list) {
  out.list = vector("list", length(nested.gg.list))
  for (idx in seq.int(length(nested.gg.list))) {
    out.list[[idx]] = nested.gg.list[[idx]][[1]]
  }
  names(out.list) = names(nested.gg.list)
  return(out.list)
}

#helper to open a r-code chunk block with options. Make sure to close the r-chunk with ''' at the end
#options is a list with chunk options: handles all kind of data types as it will be converted into character
#example: options = list(echo = FALSE, message = TRUE, ...)
writeRChunkOptions = function(chunkname, id, options = list(echo = FALSE, message = FALSE, warning = FALSE)) {
  a = "```{r "
  b = paste0(chunkname, "_",  id, ", ")
  c = paste(sprintf("%s = %s", names(options), options), collapse = ", ")
  d = paste0(a, b, c, "}")
  return(d)
}

writeRinline = function(r.code) {
  paste0("`r ", r.code, " `")
}

# S3 method to get id of an AEDA object
getId = function(x) UseMethod("getId")

getId.default = function(x){
  warning(paste0("getId does not know how to handle object of class \"",
    class(x), "\""))
}

getId.CorrReport = function(x){
  x$report.id
}

getId.BasicReport = function(x) {
  x$report.id
}

getId.NumSumReport = function(x) {
  x$report.id
}

getId.CatSumReport = function(x) {
  x$report.id
}

getId.ClusterAnalysisReport = function(x) {
  x$report.id
}

getId.MDSAnalysisReport = function(x) {
  x$report.id
}

getId.FAReport = function(x) {
  x$report.id
}

getId.PCAReport = function(x) {
  x$report.id
}

##
getType = function(x) UseMethod("getType")

getId.default = function(x){
  warning(paste0("getType does not know how to handle object of class \"",
    class(x), "\""))
}
getType.CorrReport = function(x){
  x$type
}

getType.NumSumReport = function(x){
  x$type
}
getType.BasicReport = function(x){
  x$type
}

getType.CatSumReport = function(x){
  x$type
}

getType.ClusterAnalysisReport = function(x){
  x$type
}

getType.MDSAnalysisReport = function(x){
  x$type
}

getType.FAReport = function(x){
  x$type
}

getType.PCAReport = function(x){
  x$type
}

# Wrapper for concatenate report id with a string
# idWrapper(report, "method")
# Jbssgsrsi342j$method
idWrapper = function(report, string){
  paste0(report$report.id, "$", string)
}


#write header for rmd files
# doc: https://rmarkdown.rstudio.com/html_document_format.html
writeHeader = function(title, con, subtitle = NULL, author = NULL,
  date = format(Sys.time(), "%d %B %Y"), toc =TRUE, df.print = "paged",
  theme = "cosmo", toc.depth = 2){
  writeLines("---", con = con)
  catf("title: \"%s\"", title, file = con)
  if (!is.null(subtitle)) catf("subtitle: \"%s\"", subtitle, file = con)
  if (!is.null(author)) catf("author: \"%s\"", author, file = con)
  if (!is.null(date)) catf("date: \"%s\"", date, file = con)
  catf("output:", file = con)
  catf("  html_document:", file = con)
  if (!is.null(theme)) catf("    theme: %s", theme, file = con)
  if (!is.null(toc)) catf("    toc: %s", toc, file = con)
  if (!is.null(toc.depth)) catf("    toc_depth: %s", toc.depth, file = con)
  if (!is.null(df.print)) catf("    df_print: %s", df.print, file = con)
  writeLines("---", con = con)
}

# simple wrapper for quickly changing encoding
rmdEncoding = function() "UTF-8"

expectIdentical = function(object, expected, null.ok = FALSE, ...){
  arg = list(...)
  if (is.null(object) & is.null(expected)){
    stop("Both args are NULL")
  }
  arg = append(arg, list(object = object, expected = expected))
  do.call(testthat::expect_identical, args = arg)
}