Last active
November 6, 2020 04:42
-
-
Save moodymudskipper/23ba69e2dd60639ae843aa71ab1c93f4 to your computer and use it in GitHub Desktop.
find classes
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # run from R GUI or you might have methods registered by IDE | |
| # first method scrape S3 method tables, classes with no methods are not found | |
| # second method parses code to find `class(foo) <- bar` lines and extracts string litterals if found, we could be a bit smarter there | |
| # and find more, but that will still not be exhaustive, because we have things like `class(x) <- cl` and we'd have to check the code | |
| # to see what `cl` is. | |
| # we could also check if some objects are built with `structure` | |
| # calls to `inherits` might also be checked | |
| # The C code should also be inspected or we won't find for instance the "error" or "try-error" classes. | |
| find_classes <- function(pkgs = c("base", "methods", "utils", "grDevices", "graphics", "stats")) { | |
| res <- lapply(pkgs, function(pkg) { | |
| env <- as.environment(asNamespace(pkg)) | |
| methods <- ls(getFromNamespace(".__S3MethodsTable__.", pkg)) | |
| split_ <- strsplit(methods, "\\.") | |
| res <- lapply(split_, function(x) { | |
| L <- length(x) | |
| if(L == 2) { | |
| fun_nms <- x[[2]] | |
| } else { | |
| fun_nms <- list() | |
| for(i in seq(L-1)) { | |
| fun_nm <- paste(x[1:i], collapse= ".") | |
| fun <- get0(fun_nm,mode = "function", envir = env) | |
| if(!is.null(fun)) { | |
| if(!is.null(body(fun)) && isS3stdGeneric(fun)) | |
| fun_nms <- append(fun_nms, paste(x[-(1:i)], collapse= ".")) | |
| } | |
| } | |
| } | |
| fun_nms | |
| }) | |
| sort(unique(unlist(res))) | |
| }) | |
| sort(unique(unlist(res))) | |
| } | |
| find_classes() | |
| #~~~~~~checking all `class(foo) <- bar` calls for strng litteral rhs (or `c` of thereof) | |
| #' Recurse Through a Call to Extract or Replace | |
| #' | |
| #' @param call a call | |
| #' @param find, a language object, a litteral, or a function with `call` | |
| #' and `ind` arguments returning a boolean. | |
| #' @param replace a language object, a litteral or a function with `call` | |
| #' and `ind` arguments returning a language object. | |
| #' @param output either | |
| #' `"call"` (default) to replace in the call, | |
| #' `"list"` to extract the matches (replaced if `replace` isn't `NULL`), or | |
| #' `"indices"` to extract the indices of the match into a list (`replace` will | |
| #' be ignored) | |
| #' @examples | |
| #' call <- quote(f(apple(1,2,3), orange(a, b, c), f(orange(d, e)))) | |
| #' call | |
| #' | |
| #' # find indices or locations of `orange` symbol | |
| #' call_apply(call, quote(orange), output = "i") | |
| #' | |
| #' # replace those with `pear` | |
| #' call_apply(call, quote(orange), quote(pear)) | |
| #' | |
| #' # replace 1 with 100 | |
| #' call_apply(call, 1, 100) | |
| #' | |
| #' # replace calls to orange with a `pear` symbol | |
| #' find_orange_call <- function(call, ind) | |
| #' is.call(call[[ind]]) && identical(call[[c(ind,1)]], quote(orange)) | |
| #' call_apply(call, find_orange_call, quote(pear)) | |
| #' | |
| #' # replace `orange` with a `pear` only if found at depth 3 | |
| #' find_orange_sym_d3 <- function(call, ind) | |
| #' identical(call[[ind]], quote(orange)) && length(ind) == 3 | |
| #' call_apply(call, find_orange_sym_d3, quote(pear)) | |
| #' | |
| #' # replace depth 2 syms with upper case | |
| #' find_d2_sym <- function(call, ind) is.symbol(call[[ind]]) && length(ind) == 2 | |
| #' sym_toupper <- function(call, ind) as.symbol(toupper(as.character(call[[ind]]))) | |
| #' call_apply(call, find_d2_sym, sym_toupper) | |
| #' | |
| #' # extract the latter | |
| #' call_apply(call, find_d2_sym, sym_toupper, out = "l") | |
| call_apply <- function(call, find, replace = NULL, output = c("call", "list", "indices")) { | |
| output = match.arg(output) | |
| fun_bool <- is.function(call) | |
| if(fun_bool) { | |
| call_bkp <- call | |
| call <- body(call) | |
| } | |
| if (is.symbol(call)) { | |
| call <- call("{", call) | |
| } | |
| #~~~~~~~~~~~~~~~~~~~~ | |
| # find | |
| if(!is.function(find)) | |
| find <- as.function(c( | |
| alist(call=, ind=), bquote(identical(call[[ind]], quote(.(find)))))) | |
| if(!is.null(replace) && !is.function(replace)) | |
| replace <- as.function(c( | |
| alist(call=, ind=), bquote(quote(.(replace))))) | |
| fetch_indices <- function(ind) { | |
| # return ind if target was found | |
| if(find(call, ind = ind)) return(ind) | |
| # if call is not a call we're on a leaf, nothing else to do | |
| if(!is.call(call[[ind]])) return(NULL) | |
| # go through items and recurse with updated ind | |
| lapply(seq_along(call[[ind]]), function(i) fetch_indices(c(ind, i))) | |
| } | |
| # get sparse nested list | |
| indices <- lapply(seq_along(call), fetch_indices) | |
| # use rapply to flatten it, as.call necessary not to flatten vectors | |
| indices <- rapply(indices, function(x) as.call(c(quote(c), x)), how = "unlist") | |
| # eval items | |
| indices <- lapply(indices, eval) | |
| if(output == "indices") return(indices) | |
| #~~~~~~~~~~~~~~~~~~~~ | |
| # replace | |
| if(output == "call") { | |
| res <- call | |
| for(ind in indices) { | |
| res[[ind]] <- replace(call, ind) | |
| } | |
| if(fun_bool) { | |
| body(call_bkp) <- res | |
| return(call_bkp) | |
| } | |
| return(res) | |
| } | |
| #~~~~~~~~~~~~~~~~~~~~~~ | |
| # extract | |
| if(is.null(replace)) | |
| replace <- as.function(c( | |
| alist(call=, ind=), quote(call[[ind]]))) | |
| lapply(indices, function(ind) replace(call, ind)) | |
| } | |
| find_class_assign_call <- function(call, ind) { | |
| is.call(call[[ind]]) && | |
| identical(call[[c(ind,1)]], quote(`<-`)) && | |
| is.call(call[[c(ind,2)]]) && | |
| identical(call[[c(ind,2,1)]], quote(`class`))} | |
| find_classes <- function(pkgs = c("base", "methods", "utils", "grDevices", "graphics", "stats")) { | |
| calls <- lapply(pkgs, function(pkg) { | |
| all_funs <- ls(asNamespace(pkg)) | |
| lapply(all_funs, function(fun_nm) { | |
| #print(fun_nm) | |
| fun <- getFromNamespace(fun_nm, ns = pkg) | |
| if(is.function(fun)) | |
| call_apply(fun, find_class_assign_call, output = "l") | |
| else | |
| NULL | |
| }) | |
| }) | |
| calls <- Filter(length, unlist(calls)) | |
| calls <- lapply(calls, function(x) { | |
| if(is.character(x[[3]])) x[[3]] else { | |
| if(is.call(x[[3]]) && identical(x[[c(3,1)]], quote(`c`))) { | |
| Filter(is.character, as.list(x[[3]])) | |
| } | |
| } | |
| }) | |
| calls <- Filter(length, unlist(calls)) | |
| sort(unique(calls)) | |
| } | |
| find_classes() |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment