R/var_args_list.R

In nc: Named Capture to Data Tables

subject_var_args <- function
### Parse the complete argument list including subject.
(...
### subject, regex/conversion.
){
  all.arg.list <- list(...)
  first.name <- names(all.arg.list[1])
  no.name <- identical(first.name, "") || identical(first.name, NULL)
  if(!no.name){
    stop(domain=NA, gettextf("first argument is named %s but must NOT be named; please include the subject to match as the first argument, with no name", first.name))
  }
  subject <- all.arg.list[[1]]
  stop_for_subject(subject)
  out.list <- var_args_list(all.arg.list[-1])
  out.list$subject <- subject
  out.list
### Result of var_args_list plus subject.
}

var_args_list <- structure(function
### Parse the variable-length argument list used in capture_first_vec,
### capture_first_df, and capture_all_str. This function is mostly
### intended for internal use, but is useful if you want to see the
### regex pattern generated by the variable argument syntax.
(...
### character vectors (for regex patterns) or functions (which specify
### how to convert extracted character vectors to other types). All
### patterns must be character vectors of length 1. If the pattern is
### a named argument in R, it becomes a capture group in the regex
### pattern. All patterns are pasted together to obtain the final
### pattern used for matching. Each named pattern may be followed by
### at most one function which is used to convert the previous named
### pattern. Patterns may also be lists, which are parsed recursively
### for convenience.
){
  var.arg.list <- list(...)
  fun.list <- list()
  pattern.list <- list()
  has.name <- FALSE
  group.i <- NULL
  while(length(var.arg.list)){
    var.arg <- var.arg.list[[1]]
    pattern.name <- names(var.arg.list)[1]
    valid.name <- if(is.character(pattern.name)){
      if(is.na(pattern.name))stop("group name must not be missing")
      0 < nchar(pattern.name)
    }else FALSE
    group.start <- if(valid.name){
      if(is.function(var.arg)){
        stop(domain=NA, gettextf("functions must not be named, problem: %s", pattern.name))
      }
      group.i <- length(fun.list)+1L
      fun.list[[group.i]] <- identity
      names(fun.list)[[group.i]] <- pattern.name
      has.name <- TRUE
      "("
    }else{
      "(?:"
    }
    var.arg.list <- var.arg.list[-1]
    if(is.character(var.arg)){
      if(length(var.arg) != 1){
        stop(
          "patterns must be character vectors of length 1")
      }
      if(is.na(var.arg)){
        stop("patterns must not be missing/NA")
      }
      if(is.character(names(var.arg))){
        dquote <- function(chr){
          out <- NULL
          con <- textConnection("out", "w", local=TRUE)
          dput(chr, con)
          close(con)
          out
        }
        list.code <- paste0(
          "list(",
          dquote(names(var.arg)),
          "=",
          dquote(unname(var.arg)),
          ")")
        stop(domain=NA, gettextf("pattern string must not be named; did you mean %s", list.code))
      }
      pattern.list[[length(pattern.list)+1L]] <- if(valid.name){
        paste0(group.start, var.arg, ")")
      }else{
        var.arg
      }
    }else if(is.function(var.arg)){
      if(is.null(group.i)){
        stop(domain=NA, gettext("too many functions; up to one function may follow each named pattern"))
      }
      fun.list[[group.i]] <- var.arg
      group.i <- NULL
    }else if(is.list(var.arg)){
      var.arg.list <- c(group.start, var.arg, ")", var.arg.list)
    }else{
      stop(domain=NA, gettext("arguments must be character (subject/patterns), functions (for converting extracted character vectors to other types), or list (parsed recursively)"))
    }
  }
  if(!has.name){
    stop("must have at least one named argument (capture group)")
  }
  ##value<< a list with two named elements
  list(
    fun.list=##<< list of conversion functions with names corresponding to capture group(s)
      if(length(fun.list))fun.list,
    pattern=##<< regular expression string with capture group(s)
      paste(pattern.list, collapse="")
  )
  ##end<<
}, ex=function(){

  pos.pattern <- list("[0-9]+", as.integer)
  nc::var_args_list(
    chrom="chr.*?",
    ":",
    chromStart=pos.pattern,
    list(
      "-",
      chromEnd=pos.pattern
    ), "?")

})