S4 methods metaprogramming in R - r

Here is an example:
setGeneric("loadBim",
function(pl_info, ...) {
standardGeneric("loadBim")
})
setMethod("loadBim",
signature(pl_info = "PlInfo"),
function(pl_info) {
loadFFDF(pl_info#ff_dir_trio["bim"])
})
setGeneric("loadFam",
function(pl_info, ...) {
standardGeneric("loadFam")
})
setMethod("loadFam",
signature(pl_info = "PlInfo"),
function(pl_info) {
loadFFDF(pl_info#ff_dir_trio["fam"])
})
setGeneric("loadFrq",
function(pl_info, ...) {
standardGeneric("loadFrq")
})
setMethod("loadFrq",
signature(pl_info = "PlInfo"),
function(pl_info) {
loadFFDF(pl_info#ff_dir_trio["frq"])
})
All these S4 methods are similar, they differ only for some file extension names: bim, fam, and frq. I am wondering is there some metaproramming technique available for simplifying them (generating them programmatically)?

I found out one solution:
loadPlinkMeta = gtools::defmacro(ext, method_name, expr = {
setGeneric(method_name,
function(pl_info, ...) {
standardGeneric(method_name)
})
setMethod(method_name,
signature(pl_info = "PlInfo"),
function(pl_info) {
loadFFDF(pl_info#ff_dir_trio[ext])
})
})
loadPlinkMeta("bim", "loadBim")
loadPlinkMeta("fam", "loadFam")
loadPlinkMeta("frq", "loadFrq")

Related

Creating Binary Search Tree in R

I have this code for creating a Binary Search Tree in a R6 class.
Creating a Node & BST class. In BST class, I am defining insert_recur function to create the BST by appropriately inserting the data.
library(R6)
Node <- R6Class(
classname = 'Node',
public = list(
val = NULL,
left = NULL,
right = NULL,
initialize = function(val = NULL, left = NULL, right = NULL){
self$val <- val
self$left <- left
self$right <- right
}
)
)
BST <- R6Class(
classname = 'BST',
public = list(
root = NULL,
# node = NULL,
insert = function(data){
if(is.null(self$root)){
self$node <- Node$new(data)
}else{
self$insert_recur(data, self$root)
}
},
insert_recur = function(data, cur_node){
if(data < cur_node$val){
if(is.null(cur_node$self)){
cur_node$left <- Node$new(data)
}else{
insert_recur(data, cur_node$left)
}
}else if(data > cur_node$val){
if(is.null(cur_node$self)){
cur_node$right <- Node$new(data)
}else{
insert_recur(data, cur_node$right)
}
}else{
print('value already in tree')
}
},
get_height = function(cur_node){
if(is.null(cur_node$val)){
return(-1)
}else{
return(max(self$get_height(cur_node$left),self$get_height(cur_node$right))+1)
}
}
)
)
bst <- BST$new()
bst$insert(3)
bst$insert(2)
bst$insert(1)
bst$insert(5)
bst$insert(6)
bst$insert(4)
bst$insert(7)
However I am getting this error -
Error in self$node <- Node$new(data) : cannot add bindings to a locked environment
If I put node <- NULL in the BST class, then the recursion fails & all nodes are NULL.
What will be the correct implementation?
Your Node implementation is fine. The BST isn't quite right though. It should have a NULL root node only. The problem lies in your insert_recur function. It's not possible for cur_node$self to ever be NULL, and the logic would seem to indicate that your if statements should be checking for the absence of cur_node$left and cur_node$right instead. Also, you need to remember to use self$insert_recur. The logic of your get_height argument doesn't seem right to me either. The following implementation seems to work as expected:
BST <- R6Class(
classname = 'BST',
public = list(
root = NULL,
insert = function(data) {
if(is.null(self$root)) {
self$root <- Node$new(data)
} else {
self$insert_recur(data, self$root)
}
},
insert_recur = function(data, cur_node) {
if(data < cur_node$val) {
if(is.null(cur_node$left)) {
cur_node$left <- Node$new(data)
} else {
self$insert_recur(data, cur_node$left)
}
} else if(data > cur_node$val){
if(is.null(cur_node$right)){
cur_node$right <- Node$new(data)
}else{
self$insert_recur(data, cur_node$right)
}
}else{
print('value already in tree')
}
},
get_height = function(cur_node){
if(is.null(cur_node$left) & is.null(cur_node$right)){
return(0)
}else{
return(max(self$get_height(cur_node$left),
self$get_height(cur_node$right)) + 1)
}
}
)
)
This allows
bst <- BST$new()
bst$insert(3)
bst$insert(2)
bst$insert(1)
bst$insert(5)
bst$insert(6)
bst$insert(4)
bst$insert(7)
bst$get_height(bst$root)
#> [1] 3
bst$get_height(bst$root$right)
#> [1] 2
Created on 2022-09-24 with reprex v2.0.2

Correct way to get response body of XHR requests generated by a page with RStudio Chromote

I'd like to use Chromote to gather the response body of the XHR calls made by a website, but I find the API a bit complex to master, especially the async pipeline.
I guess I need to first enable the Network functionality and then load the page (this can do), but then I need to:
list all XHR calls
filter them by recognizing patterns in the request URL
access the request body of the selected sources
Can someone provide any guidance or tutorial material on this regard?
UPDATE:
Ok, I switched to package crrri and made a general function for the purpose. The only missing part is some logic to decide when to close the connection and return the results:
get_website_resources <- function(url, url_filter = '*', type_filter = '*') {
library(crrri)
library(dplyr)
library(stringr)
library(jsonlite)
library(magrittr)
chrome <- Chrome$new()
out <- new.env()
out$l <- list()
client <- chrome$connect(callback = ~ NULL)
Fetch <- client$Fetch
Page <- client$Page
Fetch$enable(patterns = list(list(urlPattern="*", requestStage="Response"))) %...>% {
Fetch$requestPaused(callback = function(params) {
if (str_detect(params$request$url, url_filter) & str_detect(params$resourceType, type_filter)) {
Fetch$getResponseBody(requestId = params$requestId) %...>% {
resp <- .
if (resp$body != '') {
if (resp$base64Encoded) resp$body = base64_dec(resp$body) %>% rawToChar()
body <- list(list(
url = params$request$url,
response = resp
)) %>% set_names(params$requestId)
str(body)
out$l <- append(out$l, body)
}
}
}
Fetch$continueRequest(requestId = params$requestId)
})
} %...>% {
Page$navigate(url)
}
out$l
}
Cracked it. Here's the final function. It uses a crrri::perform_with_chrome wich force synch behaviour and run the rest of the process into a promise object with a resolve callback defined outside the promise itself which is called either if a number of resources are collected or if a certain amount of time has passed:
get_website_resources <- function(url, url_filter = '*', type_filter = '*', wait_for = 20, n_of_resources = NULL, interactive = F) {
library(crrri)
library(promises)
crrri::perform_with_chrome(function(client) {
Fetch <- client$Fetch
Page <- client$Page
if (interactive) client$inspect()
out <- new.env()
out$results <- list()
out$resolve_function <- NULL
out$pr <- promises::promise(function(resolve, reject) {
out$resolve_function <- resolve
Fetch$enable(patterns = list(list(urlPattern="*", requestStage="Response"))) %...>% {
Fetch$requestPaused(callback = function(params) {
if (str_detect(params$request$url, url_filter) & str_detect(params$resourceType, type_filter)) {
Fetch$getResponseBody(requestId = params$requestId) %...>% {
resp <- .
if (resp$body != '') {
if (resp$base64Encoded) resp$body = jsonlite::base64_dec(resp$body) %>% rawToChar()
body <- list(list(
url = params$request$url,
response = resp
)) %>% set_names(params$requestId)
#str(body)
out$results <- append(out$results, body)
if (!is.null(n_of_resources) & length(out$results) >= n_of_resources) out$resolve_function(out$results)
}
}
}
Fetch$continueRequest(requestId = params$requestId)
})
} %...>% {
Page$navigate(url)
} %>% crrri::wait(wait_for) %>%
then(~ out$resolve_function(out$results))
})
out$pr$then(function(x) x)
}, timeouts = max(wait_for + 3, 30), cleaning_timeout = max(wait_for + 3, 30))
}

tryCatch print the expression in the handler

Basically, try something as follows:
tryCatch(expr = {stop("stop message")},
error = function(e) {
cat(conditionMessage(e))
cat(as.character(expr))
})
with expect output to be something like: "stop(\"stop message\")", but fails as expr cannot be found... Any way to print expr within the scope without having to do something as follows?
expr <- eval('stop("stop message")')
tryCatch(expr = {expr},
error = function(e) {
cat(conditionMessage(e))
cat(as.character(expr))
})
I'm not sure I'd really recommend this, but you could walk up the call stack to find the tryCatch call and extract the parameter there. Here's a helper function to find a call in the call stack
findStackFun <- function(fun) {
for(cx in sys.calls()) {
if (deparse(cx[[1]]) == fun) {
return(cx)
}
}
return(NULL)
}
Then you could run
tryCatch(expr = {stop("stop message")},
error = function(e) {
cat(conditionMessage(e))
call <- findStackFun("tryCatch")
cat(deparse(call$expr))
})

Advanced error handling

I recently posed this question and thankfully was pointed to withRestarts() which seems pretty awesome and powerful to me :-) Now I'm eager to understand R's error handling capabilities in a bit more detail.
Actual questions
What is the recommended usage of simpleCondition()? Never used it before, but I thought it might be useful for designing custom errors and warnings that are in fact "true" conditions. Could it be used to build a database of specific conditions for which specific handlers are available?
Is there a way to "freeze" a certain state of the entire R workspace and return to it to restart a computation at a certain point? I'm aware of save.image(), but AFAIU, this doesn't store the "state" of the search path (search() or searchpaths()).
For those interested
Two code examples
illustration of my current use of withRestarts in dependence on this blog post
attempt to define a "custom condition"
I'd appreciate any comments/suggestion on what to do better ;-)
Example 1
require("forecast")
autoArimaFailsafe <- function(
x,
warning=function(w, ...) {
message("autoArimaFailsafe> warning:")
message(w)
invokeRestart("donothing")},
error=function(e, ...) {
message("autoArimaFailsafe> error:")
message(e)
invokeRestart("abort")}
) {
withRestarts(
out <- tryCatch(
{
expr <- expression(auto.arima(x=x))
return(eval(expr))
},
warning=warning,
error=error
),
donothing=function(...) {
return(eval(expr))
},
abort=function(...) {
message("aborting")
return(NULL)
}
)
}
data(AirPassengers)
autoArimaFailsafe(x=AirPassengers)
autoArimaFailsafe(x="a")
Example 2
require("forecast")
autoArimaFailsafe <- function(
x,
warning=function(w, ...) {
message("autoArimaFailsafe> warning")
invokeRestart("donothing")},
error=function(e, ...) {
message("autoArimaFailsafe> error")
invokeRestart("abort")},
condition=function(cond, ...) {
out <- NULL
message(cond)
condmsg <- conditionMessage(c=cond)
condclass <- class(cond)
if (any(class(cond) == "simpleWarning")) {
out <- warning(w=cond)
} else if (any(class(cond) == "simpleError")) {
out <- error(e=cond)
} else if (any(class(cond) == "simpleCondition")) {
if (condmsg == "invalid class: character") {
out <- invokeRestart("forcedefault")
}
}
return(out)
}
) {
withRestarts(
out <- tryCatch(
{
expr <- expression(auto.arima(x=x))
if (class(x) == "character") {
expr <- signalCondition(
simpleCondition("invalid class: character",
call=as.call(expr))
)
}
return(eval(expr))
},
condition=condition
),
donothing=function(...) {return(eval(expr))},
abort=function(...) {
message("aborting")
return(NULL)
},
forcedefault=function(...) {
data(AirPassengers)
expr <- expression(auto.arima(x=AirPassengers))
return(eval(expr))
}
)
}
autoArimaFailsafe(x=AirPassengers)
autoArimaFailsafe(x=NULL)
autoArimaFailsafe(x="a")
This post references the inspiration for R's condition handling.
For 1., I think of simpleCondition as illustrating how one can construct custom conditions, e.g,.
myCondition <-
function(message, call=NULL, type=c("overflow", "underflow", "zero"))
{
type <- match.arg(type) # only allowed types past here
class <- c(type, "my", "condition")
structure(list(message = as.character(message), call = call),
class = class)
}
is a constructor for making custom conditions
> myCondition("oops")
<overflow: oops>
> myCondition("oops", type="underflow")
<underflow: oops>
These conditions can be used in tryCatch or withCallingHandlers
xx <- tryCatch({
signalCondition(myCondition("oops", type="underflow"))
}, underflow=function(e) {
message("underflow: ", conditionMessage(e))
NA # return value, assigned to xx
})
These are S3 classes so can have a linear hierarchy -- bad and worse are both subclasses of error.
myError <-
function(message, call=NULL, type=c("bad", "worse"))
{
type <- match.arg(type)
class <- c(type, "error", "condition")
structure(list(message=as.character(message), call=call),
class=class)
}
One might also create an error that extends the 'simpleError' S3 class as cond <- simpleError("oops"); class(cond) = c("myerr", class(cond)
With tryCatch we just get access to a single handler, the first (in the sense described on ?tryCatch) to match the class of condition
tryCatch({
stop(myError("oops", type="worse"))
}, bad = function(e) {
message("bad error: ", conditionMessage(e))
}, worse = function(e) {
message("worse error: ", conditionMessage(e)) # here's where we end up
}, error=function(e) {
message("error: ", conditionMessage(e))
})
With withCallingHandlers we have the opportunity to hit multiple handlers, provided we don't invoke a restart
withCallingHandlers({
stop(myError("oops", type="bad"))
}, bad = function(e) { # here...
message("bad error: ", conditionMessage(e))
}, worse = function(e) {
message("worse error: ", conditionMessage(e))
}, error=function(e) { # ...and here...
message("error: ", conditionMessage(e))
}) # ...and top-level 'error'
withCallingHandlers({
x <- 1
warning(myError("oops", type="bad"))
"OK"
}, bad = function(e) { # here, but continue at the restart
message("bad warning: ", conditionMessage(e))
invokeRestart("muffleWarning")
}, worse = function(e) {
message("worse warning: ", conditionMessage(e))
})
I'm not so sure about your question 2; I think this is the situation that calling handlers are designed to address -- the entire frame where the condition was invoked is poised waiting to continue, once you invoke the restart.

How to patch an S4 method in an R package?

If you find a bug in a package, it's usually possible to patch the problem with fixInNamespace, e.g. fixInNamespace("mean.default", "base").
For S4 methods, I'm not sure how to do it though. The method I'm looking at is in the gWidgetstcltk package. You can see the source code with
getMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"))
I can't find the methods with fixInNamespace.
fixInNamespace(".svalue", "gWidgetstcltk")
Error in get(subx, envir = ns, inherits = FALSE) :
object '.svalue' not found
I thought setMethod might do the trick, but
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
},
where = "package:gWidgetstcltk"
)
Error in setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"), :
the environment "gWidgetstcltk" is locked; cannot assign methods for function ".svalue"
Any ideas?
How about the old-school way of getting the source, applying the change and rebuilding?
you can first get the generic out, and then fix the generic by setMethod in your global environment, and then assign it back to that namespace
.svalue <- gWidgetstcltk:::.svalue
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
}#,
#where = "package:gWidgetstcltk"
)
assignInNamespace(".svalue", .svalue, ns = "gWidgetstcltk")

Resources