R/list_helpers.R

In avidclam/avidstart: Useful R helper functions for quick start of data analysis projects

#' Checks if argument fits the definition of a list leaf
#' 
#' Leaf in a list is a vector (non-list) or an object.
#' 
#' @param x any R data
#' @return TRUE or FALSE
#'
#' @examples
#' is_leaf(FALSE) # TRUE, because c(TRUE) is a vector, not a list
#' is_leaf(LETTERS) # TRUE, for the same reason
#' is_leaf(mtcars)# TRUE, because data.frame is an 'internally classed' R object
#' is_leaf(as.list(mtcars)) # FALSE, because argument is a list
#'
#' @seealso [is.object()] for the explanation of 'internally classed' object
#' @export
is_leaf <- function(x) is.object(x) || !is.list(x)

#' Error-proof wrapper around `names()`
#' 
#' Check names of an argument and always return character vector, no NAs or NULL
#' 
#' @return character vector of names or empty strings
#' 
#' @examples
#' get_names(NULL) # returns character(0)
#' get_names(0) # returns ""
#' get_names(list(x = 1, y = 2)) # returns c("x", "y")
#' 
#' @export
get_names <- function(x) {
  result <- names(x)
  if (length(result) == 0) rep("", length(x)) 
  else {
    result[is.na(result)] <- ""
    result
  }
}

delevel <- function(x) {
  if (missing(x) || is_leaf(x) || length(x) == 0) return(NULL)
  # Get branches
  xbr <- x[!sapply(x, is_leaf, simplify = TRUE)]
  if (length(xbr) > 0 ) {
    result <- do.call(c, c(xbr, list(use.names = FALSE)))
    nm <- do.call(c, c(lapply(xbr, get_names), list(use.names = FALSE)))
    if (sum(nchar(nm)) > 0) names(result) <- nm
    result
  } else list()
}

leafkeys <- function(x) {
  if (length(x) == 0) return(character(0))
  nm <- get_names(x)
  is_duplicate <- seq_along(nm) != sapply(nm, function(x) which(x == nm)[[1]])
  is_bad <- nm != make.names(nm) | is_duplicate
  is_num <- nchar(nm) == 0 | is_duplicate
  subkey <- replace_along(paste0("$", nm), is_bad, 
                          replace_along(paste0('[["', nm, '"]]'), is_num,
                                        paste0('[[', seq_along(nm), ']]')))
  unlist(
    mapply(
      function(xk, key) {
        if (is_leaf(xk)) key 
        else lapply(leafkeys(xk), function(leafkey) paste0(key, leafkey))},
      x, subkey, SIMPLIFY = FALSE, USE.NAMES = FALSE))
}