Merge pull request #11 from KWB-R/dev

Add some new functions (moved from other packages)

Author: hsonne

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: kwb.utils
 Title: General Utility Functions Developed at KWB
-Version: 0.4.4
+Version: 0.5.0
 Authors@R: 
     c(person(given = "Hauke",
              family = "Sonnenberg",

NAMESPACE

@@ -20,6 +20,7 @@ export(arglist)
 export(asColumnList)
 export(asNoFactorDataFrame)
 export(asRowList)
+export(assertFinalSlash)
 export(assertRowsAndColumns)
 export(assignAll)
 export(assignArgumentDefaults)
@@ -237,6 +238,7 @@ export(toLookupClass)
 export(toLookupList)
 export(toLookupTable)
 export(toNamedList)
+export(toPdf)
 export(toPositiveIndices)
 export(underscoreToPercent)
 export(unmerge)

NEWS.md

@@ -1,3 +1,16 @@
+# [kwb.utils 0.5.0](https://github.com/KWB-R/kwb.utils/releases/tag/v0.5.0) <small>2019-12-17</small>
+
+* new: toPdf()
+* new: assertFinalSlash()
+* new private functions:
+  + cache_and_return()
+  + clear_cache()
+  + get_cached()
+  + get_cached_file()
+  + run_cached()
+  + objectToText()
+  + textToObject()
+
 # [kwb.utils 0.4.4](https://github.com/KWB-R/kwb.utils/releases/tag/v0.4.4) <small>2019-08-10</small>
 
 * improved documentation (deploy docu also from "dev" branch, include NEWS.md)

R/array.R

@@ -35,7 +35,7 @@ mergeNamedArrays <- function(x, check_dim = TRUE)
   }
 
   # Stop if not all dimensions are of the same length
-  stopifnot(kwb.utils::allAreEqual(sapply(dimnames_list, length)))
+  stopifnot(allAreEqual(sapply(dimnames_list, length)))
 
   # Merge the dimension lists
   dim_names <- lapply(seq_along(dimnames_list[[1]]), function(i) {
@@ -71,7 +71,7 @@ mergeNamedArrays <- function(x, check_dim = TRUE)
 {
   # Define helper functions
   get_lengths <- function(x) sapply(x, length)
-  print_with_caption <- function(x) kwb.utils::printIf(TRUE, x)
+  print_with_caption <- function(x) printIf(TRUE, x)
 
   dim_a <- get_lengths(dimnames_a)
   dim_b <- get_lengths(dimnames_b)
@@ -94,7 +94,7 @@ mergeNamedArrays <- function(x, check_dim = TRUE)
 
       stop(
         "There are labels in a that are not in b in dimension ", i, ", e.g.:\n",
-        kwb.utils::stringList(utils::head(dimnames_a[[i]][! a_in_b]))
+        stringList(utils::head(dimnames_a[[i]][! a_in_b]))
       )
     }
   }

R/assertFinalSlash.R

@@ -0,0 +1,45 @@
+# assertFinalSlash -------------------------------------------------------------
+
+#' Make Sure that Strings End With Slash
+#' 
+#' @param x vector of character
+#' @param method integer value specifying the implementation method. \code{1}
+#'   (default): Find strings without ending slash and append slash to these
+#'   strings. \code{2}: Remove one or more slashes at the end and append slash
+#'   to all strings. \code{3}: Append slash to all strings and replace multiple
+#'   occurrences of slash at the end with one slash. Method 1 is the fastest but
+#'   does not replace multiple trailing slashes with only one trailing slash 
+#'   (see examples).
+#' @export
+#' @examples 
+#' assertFinalSlash(c("a", "b", "c"))
+#' assertFinalSlash(c("a/", "b/", "c/"))
+#' assertFinalSlash(c("a//", "b", "c/"))
+#' 
+#' # Use method 2 or 3 to replace multiple slashes with one slash
+#' assertFinalSlash(c("a//", "b", "c/"), method = 2)
+#' assertFinalSlash(c("a//", "b", "c/"), method = 3)
+assertFinalSlash <- function(x, method = 1L)
+{
+  stopifnot(method %in% 1:3)
+
+  if (method == 1L) {
+    # 1. Find strings without ending slash
+    # 2. Append slash at the end to these strings
+    endpos <- nchar(x)
+    no_slash <- substr(x, endpos, endpos) != "/"
+    `[<-`(x, no_slash, paste0(x[no_slash], "/"))
+
+  } else if (method == 2L) {
+
+    # 1. Remove one or more slashes at the end
+    # 2. Append slash at the end
+    paste0(gsub("/+$", "", x), "/")
+
+  } else if (method == 3L) {
+
+    # 1. Append slash at the end
+    # 2. Replace multiple occurrences of slash at the end with one slash
+    gsub("/+$", "/", paste0(x, "/"))
+  }
+}

R/cache.R

@@ -0,0 +1,64 @@
+# cache_and_return -------------------------------------------------------------
+cache_and_return <- function(x, name = deparse(substitute(x)))
+{
+  save(x, file = get_cached_file(name))
+  x
+}
+
+# clear_cache ------------------------------------------------------------------
+clear_cache <- function()
+{
+  files <- get_cached_file()
+  
+  if (length(files)) {
+    
+    catAndRun(messageText = sprintf(
+      "Clearing %d files from cache:\n  %s", 
+      length(files), stringList(basename(files))
+    ), expr = {
+      unlink(files)
+    })
+    
+  } else {
+    
+    cat("No cached files to clear.\n")
+  }
+}
+
+# get_cached -------------------------------------------------------------------
+get_cached <- function(name)
+{
+  if (file.exists(file <- get_cached_file(name))) {
+    loadObject(file, "x")
+  } else {
+    NULL
+  }
+}
+
+# get_cached_file --------------------------------------------------------------
+get_cached_file <- function(name = "")
+{
+  cache_dir <- file.path(tempdir(), "cache")
+  
+  createDirectory(cache_dir, dbg = FALSE)
+  
+  if (name == "") {
+    return(dir(cache_dir, "\\.RData", full.names = TRUE))
+  }
+  
+  file.path(cache_dir, paste0(name, ".RData"))
+}
+
+# run_cached -------------------------------------------------------------------
+run_cached <- function(name, expr)
+{
+  if (! is.null(object <- get_cached(name))) {
+    return(object)
+  }
+  
+  object <- eval(expr, envir = -1)
+  
+  cache_and_return(object, name = name)
+  
+  object
+}

R/column.R

@@ -101,9 +101,9 @@ checkForMissingColumns <- function(
 #' 
 columnToDate <- function(df, column, dbg = TRUE)
 {
-  df[[column]] <- kwb.utils::catAndRun(
+  df[[column]] <- catAndRun(
     sprintf("Converting column '%s' to Date", column), dbg = dbg,
-    as.Date(as.character(kwb.utils::selectColumns(df, column)))
+    as.Date(as.character(selectColumns(df, column)))
   )
 
   df
@@ -250,6 +250,7 @@ hsDelEmptyCols <- function(
 #' 
 hsRenameColumns <- function(dframe, renames)
 {
+  warningDeprecated("hsRenameColumns", "renameColumns")
   renameColumns(x = dframe, renamings = renames)
 }
 
@@ -584,9 +585,9 @@ removeEmptyColumns <- function(
 #' 
 renameAndSelect <- function(data, renames, columns = unlist(renames))
 {
-  data <- kwb.utils::hsRenameColumns(data, renames)
+  data <- renameColumns(data, renames)
 
-  kwb.utils::selectColumns(data, columns, drop = FALSE)
+  selectColumns(data, columns, drop = FALSE)
 }
 
 # renameColumns ----------------------------------------------------------------

R/csv.R

@@ -99,16 +99,16 @@ convertCsvFile <- function(
   args <- c(args_read, arguments[argnames])
 
   # Read data from file_in  
-  kwb.utils::catIf(dbg, sprintf("Reading from '%s' ... ", file_in))
+  catIf(dbg, sprintf("Reading from '%s' ... ", file_in))
 
   x <- do.call(utils::read.table, args)
 
-  kwb.utils::catIf(dbg, "ok.\n")
+  catIf(dbg, "ok.\n")
 
   # If no target file name is given, create one
   if (is.null(file_out)) {
 
-    extension <- kwb.utils::fileExtension(file_in)
+    extension <- fileExtension(file_in)
 
     pattern <- paste0("\\.", extension, "$")
 
@@ -133,11 +133,11 @@ convertCsvFile <- function(
   args <- c(args_write, arguments[argnames])
 
   # Write data to file_out
-  kwb.utils::catIf(dbg, sprintf("Writing to '%s' ... ", file_out))
+  catIf(dbg, sprintf("Writing to '%s' ... ", file_out))
 
   do.call(utils::write.table, args)
 
-  kwb.utils::catIf(dbg, "ok.\n")
+  catIf(dbg, "ok.\n")
 
   file_out
 }

R/dataFrame.R

@@ -139,8 +139,8 @@ compareDataFrames <- function(
 
   # Are the data frames identical after removing all attributes?
   result$identicalExceptAttributes <- identical(
-    kwb.utils::removeAttributes(x),
-    kwb.utils::removeAttributes(y)
+    removeAttributes(x),
+    removeAttributes(y)
   )
 
   # Do the data frames have the same number of rows?
@@ -170,8 +170,8 @@ compareDataFrames <- function(
     c(
       identical = identical(x[[column]], y[[column]]),
       identicalExceptAttributes = identical(
-        kwb.utils::removeAttributes(x[[column]]),
-        kwb.utils::removeAttributes(y[[column]])
+        removeAttributes(x[[column]]),
+        removeAttributes(y[[column]])
       ),
       equalValues = all(x[[column]] == y[[column]])
     )
@@ -606,10 +606,12 @@ safeRowBindOfListElements <- function(x, elementName)
 
 # splitIntoFixSizedBlocks ------------------------------------------------------
 
-#' Split into blocks of same size
+#' Split into Blocks of Same Size
 #' 
-#' Split a data frame or matrix into blocks of the same size (= data frames of 
-#' matrices with the same number of rows)
+#' Split a data frame or a matrix into blocks of the same size, i.e. data frames 
+#' or matrices with the same number of rows (except the last one that is shorter
+#' unless the total number of rows is a multiple of the number of rows per 
+#' block).
 #' 
 #' @param data data frame or matrix
 #' @param blocksize number of rows in each block into which \code{data} is split

R/dictionary.R

@@ -25,7 +25,7 @@ writeDictionary <- function(dictionary, file)
   header_lines <- c(
     header_lines,
     "This file has been generated using kwb.utils::writeDictionary()", 
-    sprintf("on %s by user %s", Sys.Date(), kwb.utils::user())
+    sprintf("on %s by user %s", Sys.Date(), user())
   )
 
   header_lines <- paste("#", header_lines)
@@ -55,9 +55,9 @@ readDictionaries <- function(folder, pattern = "^dictionary_(.*)[.]txt$")
 {
   files <- dir(folder, pattern, full.names = TRUE)
 
-  dictionaries <- lapply(files, kwb.utils::readDictionary, sorted = FALSE)
+  dictionaries <- lapply(files, readDictionary, sorted = FALSE)
 
-  config_names <- kwb.utils::subExpressionMatches(pattern, basename(files))
+  config_names <- subExpressionMatches(pattern, basename(files))
 
   structure(dictionaries, names = sapply(config_names, "[[", 1))
 }

R/encode_decode.R

@@ -22,7 +22,7 @@ encode <- function(x, level = 1, chars = printable_chars(level))
 {
   x <- as.factor(x)
 
-  m <- kwb.utils::intToNumeralSystem(seq_along(levels(x)), base = length(chars))
+  m <- intToNumeralSystem(seq_along(levels(x)), base = length(chars))
 
   result <- matrix(
     chars[m + 1], 
@@ -31,7 +31,7 @@ encode <- function(x, level = 1, chars = printable_chars(level))
     dimnames = dimnames(m)
   ) 
 
-  result <- do.call(paste0, kwb.utils::asColumnList(result))
+  result <- do.call(paste0, asColumnList(result))
 
   encoded_indices <- gsub(pattern = "^0+", replacement = "", result)
 
@@ -97,5 +97,5 @@ printable_chars <- function(level = 1)
 #' 
 decode <- function(x)
 {
-  unname(kwb.utils::getAttribute(x, "codes")[x])
+  unname(getAttribute(x, "codes")[x])
 }

R/io.R

@@ -86,7 +86,7 @@ catLines <- function(x)
 #' 
 catNewLineIf <- function(condition)
 {
-  kwb.utils::catIf(condition, "\n")
+  catIf(condition, "\n")
 
   invisible(condition)
 }

R/lookup.R

@@ -39,19 +39,19 @@ toLookupClass <- function(
   keys, values, class = c("data.frame.1", "data.frame.2", "list", "vector")[1]
 )
 {
-  classes <- kwb.utils::toNamedList(
+  classes <- toNamedList(
     c("data.frame.1", "data.frame.2", "list", "vector")
   )
 
   if (class %in% c(classes$data.frame.1, classes$data.frame.2)) {
 
-    kwb.utils::toLookupTable(
+    toLookupTable(
       keys, values, as.twoColumnTable = (class == classes$data.frame.2)
     )
 
   } else if (class == classes$list) {
 
-    kwb.utils::toLookupList(keys, values)
+    toLookupList(keys, values)
 
   } else if (class == classes$vector) {