R/brackets.R

In moodymudskipper/composer: compact function composition

#' Improved vector subsetting
#'
#' @param x a composer_vector
#' @param i standard indices used to subset
#' @param ... predicate subsetting functions applied on top off subset by indices
#' @export
#' @examples
#' vec <- co("A hello", "B hi")
#' vec[,~startsWith(.,"A")]
#' vec[1:2, ~startsWith(.,"A")]
#' vec[startsWith ="A"]
`[.composer_vector` <- function(x, i, ...) {
  x  <- unco(x)
  if (!missing(i)) x <- x[i]
  fs  <- list(...)
  if (length(fs)) {
    fs <- harmonize_funs(fs,NULL)
    x <- x[purrr::reduce(fs,~.y(x) & .x, .init = TRUE)]
  }
  co(x)
}


#' Apply composition of functions to vector
#'
#' It is essentially a wrapper around compose2 with additional feature for
#' easy string manipulation
#'
#' @param .x a composer_vector
#' @param .i a numeric vector, a character vector, a function or a formula
#' @param .j a numeric vector, a character vector, a function or a formula
#' @param ... additional arguments passed to compose2
#' @param .p a logical vector, a numeric vector, a function or a formula
#'
#' @export
#' @examples
#' vec <- co("A: hello there", "B: hi handsome")
#' vec[[4,-1,.p = 2:3]]
#' vec[[4,-1,.p = c(TRUE, FALSE)]] # recycled
#' vec[[4,-1,.p = ~startsWith(.,"A")]]
#' vec[["h."]]
#' vec[["(?<=\\s).*(?=\\s)"]]
#' vec[["e|a|o","X"]]
#' vec[[toupper]]
#' vec[[4,-1, ~toupper(.), paste = ";)"]]
#' str(vec[[.unco=T]])
`[[.composer_vector` <- function(.x, .i, .j, ..., .p = TRUE, .unco = FALSE) {
  .x <- unco(.x)

  # check arguments
  if (missing(.i) && !missing(.j))
    stop(".i can't be missing if .j is provided")

  if (!isTRUE(.p)) {
  # apply .p if it's a function/formula
  if (inherits(.p,"formula") || is.function(.p))
    .p <- purrr::as_mapper(.p)(.x) else if(
      is.numeric(.p) && max(.p) > length(.x))
      stop("incompatible index, max index is ",max(.p),
           " and vector has length ", length(.x))

  args    <- as.list(match.call()[-1])
  args$.x <- .x[.p]
  args$.p <- TRUE
  .x[.p]  <- do.call(`[[.composer_vector`,args)
  } else {

  if (!missing(.i)) {
    # use str_extract, str_replace_all or str_sub depending on
    # .i and .j arguments
    if (is.character(.i)) {
      missing_end <- missing(.j) || is_fun_or_form(.j)
      if (missing_end)
      { # i char j missing : str_extract
        .x <- stringr::str_extract(.x, .i)}
      else if (is.character(.j))
      { # i char j char : str_replace_all
        .x <- stringr::str_replace_all(.x, .i, .j)}
      else if (is.numeric(.j))
      { # i char j num : str_split
        split_ <- stringr::str_split(.x,.i)
        .x <- purrr::map_chr(split_,~`length<-`(.,max(lengths(split_)))[.j])
      }
    } else if (is.numeric(.i)) {
      # i num j num / missing / function/formula : str_sub
      if (missing(.j) && is.numeric(.i)) .j <- .i
      if (!is.numeric(.j)) .j <- purrr::as_mapper(.j)(.x)
      .x <- purrr::pmap_chr(list(as.character(.x), .i, .j), stringr::str_sub)
    }
    funs <- c(
      if (is_fun_or_form(.i)) .i,
      if (!missing(.j) && is_fun_or_form(.j)) .j,
      list(...))
  } else {
    funs <- list(...)
  }

  if (length(funs))
    .x <- rlang::invoke(compose2,funs)(.x)
  }
  if (.unco) .x else co(.x)
}



is_fun_or_form <- function(x){
  is.function(x) || inherits(x,"formula")
}