R/wbs_tools.R

In Technomics/wbstools: Work Breakdown Structures

#' Functions for working with a wbs
#' 
#' @description
#' 
#' A collection of functions to make working with a work breakdown structure more streamlined.
#' 
#' @name wbstools_functions
#' @param x A wbs vector.
#' @param .data An object of type data.frame.
NULL

#' Split wbs into columns
#' 
#' @description
#' 
#' \code{wbs_parse()} divides each wbs element at the "." character. Each level is returned
#' as its integer value into columns.
#' 
#' @export
#' @inheritParams wbstools_functions
#' @return A tibble with added columns.
#' @examples 
#' x <- as_wbs(c("1", "1.1", "1.1.1", "1.2"))
#' wbs_parse(x)
#' 
wbs_parse <- function(x) {
  wbs_split <- stringr::str_split(x, pattern = "[.]", simplify = TRUE)
  colnames(wbs_split) <- paste0("level_", seq.int(ncol(wbs_split)))
  
  dplyr::as_tibble(wbs_split) %>%
    dplyr::mutate_all(as_wbs_int) %>% 
    dplyr::mutate_all(tidyr::replace_na, 0L) %>%
    tibble::add_column(wbs = as_wbs(x), .before = 1) %>% 
    tibble::rowid_to_column("id_wbs")
}


#' Create a wbs object
#' 
#' @description
#' 
#' \code{wbs_create()} is typically not called by itself by rather through \code{\link{as_wbs}()}.
#' See \code{\link{wbs_check}()} for more details on wbs validity checks.
#' \cr
#' Returns the vector with appropriate class attributes. Type 'wbs' is not yet assigned.
#' 
#' @details The following attributes are attached to the return vector.
#' \describe{
#'   \item{levels}{Number of levels the wbs goes down to.}
#' }
#' 
#' @export
#' @inheritParams wbs
#' @return A character vector with attributes.
#' @examples 
#' x <- wbs_create(c("1", "1.1", "1.1.1", "1.2"))
#' 
#' # notice the class is still character
#' class(x)
#' class(as_wbs(x))
#' 
wbs_create <- function(x, sep = ".", width = NULL, .force = FALSE) {
  x_clean <- stringr::str_remove(as.character(x), "[.]$")
  x_check <- wbs_check(x_clean, sep = ".", width = NULL)
  
  if (any(!x_check)) {
    if (.force) {
      warning(paste(sum(!x_check), "record(s) failed wbs_check(), replacing with '':",
                    paste(unique(x_clean[!x_check]), collapse = ", ")))
      x_clean[!x_check] <- ""
    } else {
      stop(paste(sum(!x_check), "record(s) failed wbs_check():",
                 paste(unique(x_clean[!x_check]), collapse = ", ")))
    }
  }
  
  n_levels <- max(stringr::str_count(x_clean, "[.]")) + 1
  
  # assign attributes
  attributes(x_clean) <- list(levels = n_levels)
  
  x_clean
}

#' Check is a valid wbs element
#' 
#' @description
#' 
#' \code{wbs_check()} determines if each element of a character vector is in a valid
#' wbs format.\cr
#' \enumerate{
#'   \item No empty levels (i.e., no back-to-back occurrences of the separator('..')).
#'   \item Only integers 0-9 and the separator ('.') are allowed.
#' }
#' 
#' @export
#' @inheritParams wbs
#' @return A logical vector where \code{TRUE} signifies a valid entry.
#' @examples 
#' x <- c("1", "1.1", "1.1.1", "1.2")
#' wbs_check(x)
#' 
wbs_check <- function(x, sep = ".", width = NULL) {
    
  x_err <-  tibble::tibble(double_sep = stringr::str_detect(x, "[.][.]"),
                           non_num = stringr::str_detect(x, "[^0-9.]"))
  
  # true if passes tests
  !(purrr::pmap_lgl(x_err, any))
}

#' Ordering permutation (wbs)
#' 
#' @description 
#' 
#' \code{order_wbs} returns a permutation which rearranges the wbs into ascending order.
#' 
#' @export
#' @inheritParams wbstools_functions
#' @param decreasing Not yet implemented argument.
#' @return An integer vector.
#' @examples
#' x <- as_wbs(c("1", "1.1", "1.2", "1.1.1", "1.10"))
#' order_wbs(x)
#' 
#' x[order_wbs(x)]
#' 
order_wbs <- function(x, decreasing = FALSE) {
  # decreasing = FALSE currently unused (unsure use case)
  
  wbs_parse(x) %>%
    dplyr::arrange_at(dplyr::vars(-dplyr::one_of(c("id_wbs", "wbs")))) %>%
    dplyr::pull(id_wbs)
}

#' Expand a wbs vector
#' 
#' @rdname wbs_expand
#' @export
#' 
wbs_expand.wbs <- function(x, ...) {
  x_parse <- sort(x) %>% 
    wbs_parse() %>%
    dplyr::mutate(lowest = as.integer(stringr::str_count(wbs, "[.]") + 1),
                  parent = as_wbs(ifelse(lowest == 1, "", stringr::str_remove(wbs, "[.]([0-9]+)$"))),
                  wbs = strip_attributes(wbs))
  
  count_child <- x_parse %>%
    dplyr::filter(lowest > 1) %>% 
    dplyr::count(parent, name = "n_child") %>% 
    dplyr::mutate(parent = strip_attributes(parent))
  
  missing_parent <- count_child %>% 
    dplyr::anti_join(x_parse, by = c("parent" = "wbs"))
  
  if (nrow(missing_parent) > 0) message(paste("some elements have children but are missing from the wbs:",
                                              paste(missing_parent$parent, collapse = ", "),
                                              "\n"))
  
  x_parse %>%
    dplyr::left_join(count_child, by = c("wbs" = "parent")) %>% 
    tidyr::replace_na(list(n_child = 0L)) %>% 
    dplyr::mutate(is_lowest = (n_child == 0L))
  
}

#' Expand a wbs column
#' 
#' @rdname wbs_expand
#' @export
#' 
wbs_expand.data.frame <- function(x, .wbs_col = NULL, ...) {
  wbs_col <- ifelse(is.null(.wbs_col), default_col_wbs(x), .wbs_col)
  
  wbs_expand(x[[wbs_col]])
}

#' Check wbs rollup sums
#' 
#' @description
#' 
#' \code{check_sums()} checks that each parent element is equal to the sum of its children.
#' 
#' @export
#' 
check_sums <- function() {
  
  
}

#' Rollup wbs values
#' 
#' @description
#' 
#' \code{rollup()} starts at the lowest level of the wbs and rolls up the data to each parent level.
#' 
#' @export
#' 
rollup <- function() {
  
  
}

#' Get wbs column
#' 
#' @description
#' 
#' \code{default_col_wbs()} returns the wbs column for a given \code{data.frame}. The function will look for the
#' first column of type wbs. If no columns are found, an error is returned. If more than one column is found,
#' a warning will be issued.
#' 
#' @export
#' @inheritParams wbstools_functions
#' @return A string with the column name.
#' 
default_col_wbs <- function(.data) {
  col_wbs <- which(sapply(.data, class) == "wbs")
  
  if (length(col_wbs) == 0) {
    stop(paste("no column of class 'wbs' detected"))
  } else {
    col_name <- names(.data)[col_wbs[1]]
    if (length(col_wbs) > 1) warning(paste("more than 'wbs' column detected, using", col_name))
  }
  
  col_name
}

#' Coerces to integer without warning
#' 
#' \lifecycle{questioning}
#' 
#' Should probably be in another tbd package such as \code{costmisc}.
#' 
#' @keywords internal
#' 
as_wbs_int <- function(x, na_regex = "[^0-9]") {
  x_na <- stringr::str_detect(x, na_regex)
  x[x_na] <- 0
  x <- as.integer(x)
  x[x_na] <- NA_integer_
  x
}

#' Strip attributes from object
#' 
#' \lifecycle{questioning}
#' 
#' Should probably be in another tbd package such as \code{costmisc}.
#' 
#' @keywords internal
#' 
strip_attributes <- function(x, .retain_class = TRUE) {
  x_class <- class(x)
  attributes(x) <- NULL
  
  if (.retain_class) structure(x, class = x_class) else x
}