refclasses_v_mutatr.R

library(stringr)
library(evaluate)
library(sinartra)
is.pass <- function(x) inherits(x,'pass')
#' Parse route (with parameters) into regular expression.
#'
#' @param route route url.
#' @return
#'   \item{match}{regular expression to match route}
#'   \item{params}{parameter names}
route_re <- function(route) {
  # Escape special characters that can occur in both urls and regexps
  route <- stringr::str_replace_all(route, "([.])", "\\\\\\1")

  # Extract parameters
  params <- stringr::str_extract_all(route, ":[a-zA-Z0-9_.]+|[*]")[[1]]

  keys <- stringr::str_replace_all(params, ":", "")
  keys[keys == "*"] <- "splat"

  match <- stringr::str_c("^", route, "$")
  match <- stringr::str_replace_all(match, ":[a-zA-Z0-9_.]+", "([^/?&#]+)")
  match <- stringr::str_replace_all(match, "[*]", "(.*?)")

  list(
    match = stringr::str_c(match, collapse = "/"),
    params = keys
  )
}

#' Generate functions to match specified route.
#'
#' @param route route url
#' @return
#'   \item{match}{function returning \code{TRUE} if argument matches route,
#'     \code{FALSE} otherwise}
#'   \item{params}{function that parses path and returns named list of
#'      parameters}
route_matcher <- function(route) {
  re <- route_re(route)

  list(
    match = function(path) stringr::str_detect(path, re$match),
    params = function(path) {
      matches <- stringr::str_match(path, re$match)[1, -1]
      if (length(re$params) > 0) {
        # c is simplest way convert from array to vector
        c(tapply(matches, re$params, "c", simplify = FALSE))
      } else {
        list()
      }
    }
  )
}

setRefClass("RefRouter",
    fields = list(matchers = "list"),
    methods = list(
        get = function(route,callback){
            rm <- route_matcher(route)
            rm$callback <- callback

            matchers[[length(matchers) + 1]] <<- rm
        },
        route = function(path,query){
            for(matcher in rev(matchers)) {
                if (matcher$match(path)) {
                    params <- matcher$params(path)
                    params$query <- query

                    call <- bquote(do.call(.(matcher$callback), .(params)))
                    res <- try_capture_stack(call, sys.frame())

                    if (is.error(res)) {
                        traceback <- str_c(create_traceback(res$calls), collapse = "\n")
                        return(str_c("ERROR: ", res$message, "\n\n", traceback))
                    }

                    if (!is.pass(res)) return(res)
                }
            }
        }
    )
)

x <- getRefClass('RefRouter')$new()
y <- Router$clone()

x$get('/foo',function(...)1)
y$get('/foo',function(...)1)

z <- data.frame(sinartra=numeric(),refclass=numeric())
z_i <- 1
iter <- 5000
for (i in seq(100,iter,by=100)){
    z[z_i,'sinartra'] <- system.time(for (j in 1:i) y$route('/foo',list()))[3]
    z[z_i,'refclass'] <- system.time(for (j in 1:i) x$route('/foo',list()))[3]
    z_i <- z_i + 1
}

z$sinartra/z$refclass