Merge pull request #16 from KWB-R/dev

Release v0.6.0

Author: hsonne

DESCRIPTION

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

NAMESPACE

@@ -27,6 +27,7 @@ export(assignArgumentDefaults)
 export(assignGlobally)
 export(assignPackageObjects)
 export(atLeastOneRowIn)
+export(backspace)
 export(breakInSequence)
 export(callWith)
 export(callWithStringsAsFactors)
@@ -141,9 +142,11 @@ export(isNaOrEmpty)
 export(isNullOrEmpty)
 export(isOddNumber)
 export(lastElement)
+export(left)
 export(limitToRange)
 export(linearCombination)
 export(listObjects)
+export(listToDepth)
 export(loadObject)
 export(makeUnique)
 export(matchesCriteria)
@@ -161,6 +164,7 @@ export(naToLastNonNa)
 export(nameByElement)
 export(noFactorDataFrame)
 export(objectSize)
+export(orderBy)
 export(pairwise)
 export(parallelNonNA)
 export(pasteColumns)
@@ -195,10 +199,12 @@ export(removeExtension)
 export(removeSpaces)
 export(renameAndSelect)
 export(renameColumns)
+export(repeated)
 export(resetRowNames)
 export(resolve)
 export(resolveAll)
 export(revertListAssignments)
+export(right)
 export(roundColumns)
 export(rowOrColumnwisePercentage)
 export(rowwisePercentage)
@@ -217,6 +223,7 @@ export(setLoaded)
 export(setMatrixColumns)
 export(shorten)
 export(sourceScripts)
+export(space)
 export(splitAlongDim)
 export(splitIntoFixSizedBlocks)
 export(startsToEnds)

NEWS.md

@@ -1,5 +1,9 @@
 # Current
 
+* new: listToDepth() 
+* new small helper functions: backspace(), left(), orderBy(), repeated(), 
+  right(), space()
+
 # [kwb.utils 0.5.1](https://github.com/KWB-R/kwb.utils/releases/tag/v0.5.1) <small>2020-04-20</small>
 
 * Fix bug in moveColumnsToFront(): keep data frame structure in case that the

R/listToDepth.R

@@ -0,0 +1,195 @@
+# listToDepth ------------------------------------------------------------------
+
+#' List Elements Recursively up to Depth
+#' 
+#' @param path path to the element at which to start listing
+#' @param max_depth maximal depth level of which to list elements. A value of
+#'   \code{0} means non-recursive listing, a value of \code{NA} represents fully
+#'   recursive listing.
+#' @param full_info return only \code{path} and \code{isdir} information or
+#'   the full information provided by \code{FUN(full_info = TRUE)}?
+#' @param FUN function called to get the listing of the element given in
+#'   \code{path}. The function must accept a path as its first argument and it
+#'   must define the argument \code{full_info} second. It may accept further
+#'   arguments. It must always return a data frame. For \code{full_info = FALSE}
+#'   the data frame must have columns \code{file} and \code{isdir} (is the
+#'   "file" a directory?). For \code{full_info = TRUE} the function may return
+#'   further columns. The function must provide an empty data frame with the
+#'   expected columns when being called with \code{character()} as the first
+#'   argument. The function is expected to set the attribute "failed" to the
+#'   given path in case that the path could not be accessed (e.g. because of a
+#'   broken internet connection if the listing is done remotely). See
+#'   \code{kwb.utils:::listFiles} for an example implementation that somehow
+#'   simulates the behaviour of the \code{\link{dir}} function. See
+#'   \code{kwb.dwd::list_url()} for a more advanced usage of this function in
+#'   order to recursively list the files on an FTP server (FTP = file transfer
+#'   protocol).
+#' @param \dots further arguments passed to \code{FUN}
+#' @param depth start depth of recursion if \code{max_depth > 0}. This argument
+#'   is for internal use and not intended to be set by the user!
+#' @param prob_mutate probability to alter the path so that it becomes useless.
+#'   This is zero by default. Set the value only if you want to test how the
+#'   function behaves if the listing of a path fails.
+#' @return data frame containing at least the columns \code{file} and 
+#'   \code{isdir}. If \code{full_info = TRUE} the result data frame may contain
+#'   further columns, as provided by the function given in \code{FUN} for
+#'   \code{full_info = TRUE}.
+#' @export
+#' @examples 
+#' # Example list function provided in this package (file listing)
+#' FUN <- kwb.utils:::listFiles
+#' 
+#' # The list function must provide empty records when no path is given. The 
+#' # returned data frame must provide the columns "file" and "isdir" ...
+#' FUN()
+#' FUN(full_info = TRUE)
+#' 
+#' # ... even when being called with an empty character vector
+#' FUN(character())
+#' FUN(character(), full_info = TRUE)
+#' 
+#' # Call the function recursively up to the given depth level
+#' kwb.utils:::listToDepth(".", max_depth = 1, FUN = FUN)
+#' 
+listToDepth <- function(
+  path, 
+  max_depth = 0L, 
+  full_info = FALSE, 
+  FUN = listFiles, 
+  ..., 
+  depth = 0, 
+  prob_mutate = 0
+)
+{
+  # Helper function to mutate the path with a probability of "prob" 
+  mutate_or_not <- function(x, prob = 0.1) {
+    stopifnot(inRange(prob, 0, 1))
+    # Add some nonsense to the path if the TRUE/FALSE coin lands on TRUE
+    if (prob > 0 && sample(c(TRUE, FALSE), 1L, prob = c(prob, 1 - prob))) {
+      x <- paste0(x, "blabla")
+    }
+    x
+  }
+  
+  # kwb.utils::assignPackageObjects("kwb.utils")
+  # kwb.utils::assignArgumentDefaults(listToDepth)
+  # max_depth = 1;full_info=TRUE;set.seed(1)
+
+  # Call the user-defined function FUN to list the elements at the given path
+  info <- FUN(mutate_or_not(path, prob_mutate), full_info, ...)
+  #info <- FUN(mutate_or_not(path, prob_mutate), full_info)
+
+  # Which files represent directories?
+  is_directory <- selectColumns(info, "isdir")
+
+  # Are we already at maximum depth?
+  at_max_depth <- ! is.na(max_depth) && (depth == max_depth)
+
+  # Return the file list if no recursive listing is requested or if we are
+  # already at maximum depth or if there are no directories. The function is
+  # also returned from if info is empty (! any(is_directory) is TRUE).
+  if (at_max_depth || ! any(is_directory)) {
+    return(info)
+  }
+
+  # URLs representing directories
+  directories <- selectColumns(info, "file")[is_directory]
+
+  # Number of directories
+  n_directories <- length(directories)
+
+  # There must be directories if we arrive here!
+  stopifnot(n_directories > 0L)
+
+  # Indices to loop through
+  indices <- stats::setNames(seq_along(directories), directories)
+
+  # List all directories by calling this function recursively
+  subdir_infos <- lapply(indices, function(i) {
+
+    #i <- 1L
+
+    # Show the progress
+    cat(sprintf("%s%d/%d: ", space(depth), i, n_directories))
+
+    # Recursive call of this function
+    listToDepth(
+      path = paste0(assertFinalSlash(path), directories[i]),
+      max_depth = max_depth,
+      full_info = full_info,
+      FUN = FUN,
+      ...,
+      depth = depth + 1,
+      prob_mutate = prob_mutate
+    )
+  })
+
+  # We need a template just in case that no data could be retrieved
+  template <- FUN(full_info = full_info)
+
+  # Merge data frames with info on files in subdirectories
+  subdir_info <- mergeFileInfos(subdir_infos, template)
+
+  # Prepend info on files at this level
+  result <- rbind(info[! is_directory, ], subdir_info)
+
+  # Collect information on URLs that failed to be accessed
+  failed <- c(attr(info, "failed"), attr(subdir_info, "failed"))
+
+  # Return the sorted file information with newly composed attribute "failed"
+  structure(orderBy(result, "file"), failed = failed)
+}
+
+# mergeFileInfos ---------------------------------------------------------------
+mergeFileInfos <- function(file_infos, template)
+{
+  stopifnot(is.list(file_infos))
+
+  # Keep only non-empty data frames
+  dfs <- file_infos[sapply(file_infos, nrow) > 0L]
+
+  # Function to prepend a parent name "p" to column "file" in data frame "df"
+  prepend_parent <- function(df, p) {
+    parent <- assertFinalSlash(p)
+    child <- selectColumns(df, "file")
+    setColumns(df, file = paste0(parent, child), dbg = FALSE)
+  }
+
+  # Prepend the parent names to the filenames for the remaining data frames
+  result <- do.call(rbind, mapply(
+    prepend_parent, dfs, names(dfs), SIMPLIFY = FALSE, USE.NAMES = FALSE
+  ))
+
+  # If the result is NULL (no data frames to loop through) set the result to the
+  # empty file info record
+  result <- defaultIfNULL(result, template)
+
+  # Collect the information on URLs that could not be listed
+  failed <- unlist(excludeNULL(lapply(file_infos, attr, "failed"), FALSE))
+
+  # Merge the file lists returned for each directory
+  # Return the vector of files with an attribute "failed" holding the merged
+  # URLs of directories that could not be read
+  structure(result, failed = failed)
+}
+
+# listFiles --------------------------------------------------------------------
+listFiles <- function(path = ".", full_info = FALSE, ...)
+{
+  message("listing ", path)
+  
+  # Return empty data frame if path is empty
+  if (length(path) == 0L) {
+    return(listFiles(full_info = full_info)[FALSE, ])
+  }
+  
+  files <- dir(path, include.dirs = TRUE)
+  
+  result <- resetRowNames(file.info(file.path(path, files)))
+  
+  result$file <- files
+
+  FUN <- if (full_info) moveColumnsToFront else selectColumns
+  
+  FUN(result, c("file", "isdir"))
+}

R/utils.R

@@ -0,0 +1,113 @@
+# backspace --------------------------------------------------------------------
+
+#' String of n Backspaces
+#' 
+#' @param n number of backspace characters
+#' @return vector of character of length one
+#' @export
+#' @examples
+#' update <- function(x) cat(backspace(3), x)
+#' x <- "value: 123"
+#' cat(x)
+#' cat(paste0(x, backspace(3), "987"))
+#' 
+backspace <- function(n)
+{
+  repeated("\b", n)
+}
+
+# left -------------------------------------------------------------------------
+
+#' Left Part of a String
+#' 
+#' @param x vector of character
+#' @param n number of characters to be kept from the beginning of each character
+#'   string within \code{x}
+#' @return vector of character
+#' @export
+#' @examples
+#' left("Good Morning", 4)
+#' 
+left <- function(x, n)
+{
+  substr(x, 1L, n)
+}
+
+# orderBy ----------------------------------------------------------------------
+
+#' Order a Data Frame by One or more Columns
+#' 
+#' @param df data frame
+#' @param by vector of column names specifying the columns by which to order
+#' @param \dots further arguments passed to \code{\link{order}}, such as
+#'   \code{decreasing}
+#' @return \code{df} being sorted and with newly renumbered rows
+#' @export
+#' @examples
+#' df <- data.frame(number = 4:1, letter = LETTERS[1:4])
+#' df
+#' orderBy(df, "number")
+#' orderBy(df, "letter", decreasing = TRUE)
+#' 
+orderBy <- function(df, by = NULL, ...)
+{
+  kwb.utils::resetRowNames(
+    df[order(kwb.utils::selectColumns(df, by), ...), , drop = FALSE]
+  )
+}
+
+# repeated ---------------------------------------------------------------------
+
+#' Repeated Substring
+#' 
+#' @param x substring to be repeated and pasted together to a new string
+#' @param n number of times to repeat the substring
+#' @return vector of character of length one
+#' @export
+#' @examples 
+#' repeated("no ", 2)
+#' repeated("yes ", 3)
+#' repeated("yes no ", 3)
+#' 
+repeated <- function(x, n)
+{
+  paste(rep(x, n), collapse = "")
+}
+
+# right ------------------------------------------------------------------------
+
+#' Right Part of a String
+#' 
+#' @param x vector of character
+#' @param n number of characters to be kept from the end of each character 
+#'   string within \code{x}
+#' @return vector of character
+#' @export
+#' @examples
+#' right("Good Morning", 7)
+#' 
+right <- function(x, n)
+{
+  nc <- nchar(x)
+  substr(x, nc - n + 1L, nc)
+}
+
+# space ------------------------------------------------------------------------
+
+#' Space String Used for Indentation
+#' 
+#' Chain together \code{depth * tabLength} spaces
+#' 
+#' @param depth depth of indentation
+#' @param tabLength number of spaces per indentation level
+#' @return vector of character of length one consisting of \code{depth *
+#'   tabLength} space characters
+#' @export
+#' @examples
+#' cat(sprintf("%s1\n%s2\n%s3\n", space(1), space(2), space(3)))
+#' cat(sprintf("%s1\n%s2\n%s3\n", space(1, 4), space(2, 4), space(3, 4)))
+#' 
+space <- function(depth = 1L, tabLength = 2L)
+{
+  repeated(" ", depth * tabLength)
+}