I want to make a special behavour for function when an argument b is NA. I don't want to do this with if so I prefer generic. This is my try:
foo <- function(x) {
UseMethod("foo", x)
}
foo.numeric <- function(x) {
print("numeric")
}
foo.default <- function(x) {
print("def")
}
foo.NA <- function(x) {
print("na")
}
now when I run foo(NA) i want to run foo.NA() but foo.default() is executed.
Related
Could someone please tell me how to combine wrapper function with if..else conditions? For example this wrapper:
wrapper<-function(x){
varcoef<-function(x){
sd(x)/mean(x)
}
apply(x,MARGIN = 2, FUN=varcoef)
}
wrapper(mtcars)
With:
if(is.matrix(x)==TRUE){
apply(x,2,function(x) sd(x)/mean(x))
} else if (is.data.frame(x)==TRUE){
apply(x,2,function(x) sd(x)/mean(x))
} else print(NULL)
Thank you!
Normally to handle different classes (matrix, data.frame) one creates a generic and dispatches to a method for each class as opposed to using if. This provides a modular approach in which new classes can be added without modifying the existing code -- just add a new method.
wrapper <- function(x, ...) {
varcoef <- function(x) sd(x) / mean(x)
UseMethod("wrapper")
}
wrapper.data.frame <- function(x, ...) {
is.num <- sapply(x, is.numeric)
apply(x[is.num], 2, varcoef)
}
wrapper.matrix <- function(x, ...) {
stopifnot(is.numeric(x))
apply(x, 2, varcoef)
}
# tests
wrapper(CO2)
m <- as.matrix(BOD)
wrapper(m)
If you want to use if anyways then:
wrapper <- function(x, ...) {
varcoef <- function(x) sd(x) / mean(x)
if (inherits(x, "data.frame")) {
is.num <- sapply(x, is.numeric)
apply(x[is.num], 2, varcoef)
} else {
stopifnot(is.numeric(x))
apply(x, 2, varcoef)
}
}
# tests
wrapper(CO2)
m <- as.matrix(BOD)
wrapper(m)
I am using the phyloseq package.
test <- function( ...){
bar <- unique(sampleData[,'pH'])
foo <- subset_samples(phyloseqObject, pH == as.numeric(bar[1]#.Data))
print(foo)
}
test(pH)
I want to pass pH as an argument to test() but unique() won't accept it as valid. I can pass 'pH' to test() but subset_samples() won't accept that as valid. I have tried coercing the argument to several different types with no luck.
SORCE for subset_samples:
subset_samples <- function(physeq, ...){
if( is.null(sample_data(physeq)) ){
cat("Nothing subset. No sample_data in physeq.\n")
return(physeq)
} else {
oldDF <- as(sample_data(physeq), "data.frame")
newDF <- subset(oldDF, ...)
if( class(physeq) == "sample_data" ){
return(sample_data(newDF))
} else {
sample_data(physeq) <- sample_data(newDF)
return(physeq)
}
}
}
Try this instead:
test=function(x,...){
bar=unique(mtcars[,x])
foo=subset(mtcars,mtcars[,x]==bar[1])
return(foo)
}
Building on what #desc said I managed to solve it like this:
test <- function(...){
bar <- unique(sampleData[,...])
foo <- subset_samples(phyloseqObject, eval(parse(bar#names)) == as.numeric(bar[1]))
print(foo)
}
test('pH')
have the following function:
setTypes <- function(df2, ...) {
fns <- as.list(substitute(list(...)))
for(i in 1:length(df2)) {
if(fns[i] == '') {
next
}
df2[i,] <- fns[i](df2[i,])
}
return(df2)
}
want to do this:
test<-setTypes(sls,c('','as.Date','','','as.numeric','as.numeric'))
idea is to change the types of the fields in a data frame without having to do sls$field <- as.numeric(sls$field) for every field.
I had written a function like this that worked:
fn <- function(t) {
return(t("55.55000"))
}
and the output is this:
> fn(as.numeric)
[1] 55.55
however, i can't figure out why either doing variable length argument as a list and calling it as list[index](input) doesn't work. or even passing a vector of functions like c(as.Date, as.numeric, as.character) and doing c[1]('2015-10-10') # as.Date('2015-10-10')
I am receiving the error 'attempt to apply non-function'.. I've also tried using call but to no avail. Help?
The problem is that class(c[1]) is a list use c[[1]] instead
Example code
v <- c(as.numeric,as.character)
v[[1]]("1")
v[[2]](1)
EDIT
Your example should be:
setTypes <- function(df2, ...) {
fns <- list(...)
for(i in 1:NCOL(df2)) {
if(is.function(fns[[i]])) {
df2[,i] <- fns[[i]](df2[,i])
}
}
return(df2)
}
df <- data.frame(v1 = c(1,2), v2 = c("1","2"))
setTypes(df,as.character,'',as.numeric)
I am trying to write a function which would take as argument a function call, evaluates numeric args of this function call and then return corresponding character vector. This is what I have came up with:
ConvertToCharacter <- function(function.call) {
call.str <- deparse(substitute(function.call))
return(call.str)
}
> a <- 1
> ConvertToCharacter(sum(2, a))
"sum(2, a)"
> ConvertToCharacter(ddply(mtcars, .(vs), summarize, col=mean(cyl)))
"ddply(mtcars, .(vs), summarize, col = mean(cyl))"
Now, I want the numeric args to be evaluated before getting converted into a character vector. So that ConvertToCharacter(sum(2, a)) would return "sum(2, 1)" instead. I tried passing env=parent.frame() to subsitute but it won't work. Any idea how I could go with this?
Thanks!
You need to recursively inspect your call, evaluate the symbols, and sub in the values for the numeric ones like so:
ConvertToCharacter <- function(function.call, env=parent.frame()) {
call <- substitute(function.call)
convert_recurse <- function(x, env) {
if(is.call(x)) {
return(as.call(lapply(x, match.fun(sys.call()[[1]]), env=env)))
} else if (
is.symbol(x) &&
is.numeric(try(val <- eval(x, env), silent=TRUE))
) {
return(val)
} else {
return(x)
}
}
deparse(convert_recurse(call, env))
}
a <- 1
ConvertToCharacter(sum(2, a))
lbsToKgs <- 2.2
ConvertToCharacter(ddply(mtcars, .(vs), summarize, col=mean(cyl), wtkg=mean(wt * lbsToKgs)))
And this is what you get:
# [1] "sum(2, 1)"
# [1] "ddply(mtcars, .(vs), summarize, col = mean(cyl), wtkg = mean(wt * "
# [2] " 2.2))"
Also, credit to Robert for the workaround the apply/Recall issue.
ConvertToCharacter <- function(function.call) {
library(stringr)
str_replace(deparse(substitute(function.call)),"a",eval(a,envir=.GlobalEnv))
}
I hope it helps
How do I partially bind/apply arguments to a function in R?
This is how far I got, then I realized that this approach doesn't work...
bind <- function(fun,...)
{
argNames <- names(formals(fun))
bindedArgs <- list(...)
bindedNames <- names(bindedArgs)
function(argNames[!argNames %in% bindedArgs])
{
#TODO
}
}
Thanks!
Here's a version of Curry that both preserves lazy evaluation of function argument, but constructs a function that prints moderately nicely:
Curry <- function(FUN, ...) {
args <- match.call(expand.dots = FALSE)$...
args$... <- as.name("...")
env <- new.env(parent = parent.frame())
if (is.name(FUN)) {
fname <- FUN
} else if (is.character(FUN)) {
fname <- as.name(FUN)
} else if (is.function(FUN)){
fname <- as.name("FUN")
env$FUN <- FUN
} else {
stop("FUN not function or name of function")
}
curry_call <- as.call(c(list(fname), args))
f <- eval(call("function", as.pairlist(alist(... = )), curry_call))
environment(f) <- env
f
}
It basically works by generating an anonymous function in exactly the same way you would if you were constructing the partial binding yourself.
Actually, this seems to work as a work around
bind <- function(fun,...)
{
boundArgs <- list(...)
formals(fun)[names(boundArgs)] <- boundArgs
fun
}
However, ideally I want the bound arguments to disappear completely from the new function so that calls to the new function can happen with name specification, e.g. with add <- function(a,b) a+b I would like (bind(add,a=2))(1) to return 3.
Have you tried looking at roxygen's Curry function?
> library(roxygen)
> Curry
function (FUN, ...)
{
.orig = list(...)
function(...) do.call(FUN, c(.orig, list(...)))
}
<environment: namespace:roxygen>
Example usage:
> aplusb <- function(a,b) {
+ a + 2*b
+ }
> oneplusb <- Curry(aplusb,1)
> oneplusb(2)
[1] 5
Edit:
Curry is concisely defined to accept named or unnamed arguments, but partial application of fun to arguments by way of formal() assignment requires more sophisticated matching to emulate the same functionality. For instance:
> bind <- function(fun,...)
+ {
+ argNames <- names(formals(fun))
+ boundArgs <- list(...)
+ boundNames <- names(boundArgs)
+ if(is.null(boundNames)) {
+ formals(fun)[1:length(boundArgs)] <- boundArgs
+ } else {
+ formals(fun)[match(names(boundArgs),argNames)] <- boundArgs
+ }
+ fun
+ }
> oneplusb <- bind(aplusb,1)
> oneplusb(2)
Error in 2 * b : 'b' is missing
Because the first argument in this function is still a, you need to specify which argument 2 is intended for (b=), or pass it as the second argument.
> oneplusb
function (a = 1, b)
{
a + 2 * b
}
> oneplusb(b=2) ## or oneplusb(,2)
[1] 5