I want to pass parameters to two functions. I try the ..., but seems the ... pass all the parameters to the first function. My trial code is below, but with errors.
f_add <- function(a = 1, b = 1){
return(a+b)
}
f_minus <- function(c = 1, d = 2){
return(c - d)
}
f_1 <- function(...){
f_add(...) + f_minus(...)
}
Errors:
f_1(a = 1, b =2 , c = 3, d = 4)
## Error in f_add(...) : unused arguments (c = 3, d = 4)
## Called from: f_add(...)
## Browse[1]> Q
So here I ask for any easy way to design the functions.
You can allow the function f_add and f_minus to take unnamed arguments, and ignore them:
f_add <- function(a = 1, b = 1, ...){
return(a+b)
}
f_minus <- function(c = 1, d = 2, ...){
return(c - d)
}
f_1 <- function(...){
f_add(...) + f_minus(...)
}
This admits your desired computation:
f_1(a=1, b=2, c=3, d=4)
## [1] 2
f_add <- function(a = 1, b = 1){
return(a+b)
}
f_minus <- function(c = 1, d = 2){
return(c - d)
}
f_1 <- function(a,b,c,d){
f_add(a,b) + f_minus(c,d)
}
f_1(a=1,b=100,c=2000,d=5)
2096
Related
When I run this R code I get Error in order(res2$seed): argument 1 is not a vector as an error message in the function call at first instance but when I change the range of i to be something different like in function call at second instance, I get the expected data frame format that I want.
The Function
abc <- function(a, z, n, ar11, p, d, q, sd = sd, j1, arr1, n_cores){
future::plan(future::multisession)
n_cores <- parallel::detectCores()
cl <- parallel::makeCluster(n_cores)
doParallel::registerDoParallel(cores = n_cores)
message('processing...')
`%dopar%` <- foreach::`%dopar%`
i <- a:z
res <- foreach::foreach(i = a:z, .packages = c('foreach', 'forecast')) %dopar% {
set.seed(i)
mod <- stats::arima.sim(n = n, model = list(ar = c(ar11), order = c(p, d, q)), sd = sd)
best.mod <- forecast::auto.arima(mod, ic = "aicc")
(cf <- best.mod$coef)
if (length(cf) == 0) {
rep(NA, 2)
} else if (all(grepl(c("ar1|intercept"), names(cf))) &
substr(cf["ar1"], 1, j1) %in% arr1) {
c(cf, seed = i)
} else {
rep(NA, 2)
}
}
message(' done!\n')
res1 = res[!sapply(res, anyNA)]
parallel::stopCluster(cl)
options(max.print = .Machine$integer.max)
res2 <- tibble::tibble(Reduce(function(...) merge(..., all = T), lapply(res1, function(x) as.data.frame(t(x)))))
res2[order(res2$seed), ]
res2 <- Reduce(function(...) merge(..., all = T), lapply(res1, function(x) as.data.frame(t(x))))
res2[order(res2$seed), ]
}
Call Function at First Instance
abc(a = 280000, z = 281000, n = 10, p = 1, d = 0, q = 0, ar11 = 0.8, sd = 1, j1 = 4, arr1 = "0.80")
#Error in order(res2$seed) : argument 1 is not a vector
Call Function at Second Instance
abc(a = 289800, z = 289989, n = 10, p = 1, d = 0, q = 0, ar11 = 0.8, sd = 1, j1 = 4, arr1 = "0.80")
#ar1 seed
#1 0.8000000 289805
#2 0.8000368 289989
I want to change Error in order(res2$seed): argument 1 is not a vector when need be to instruction for this R function useers to Try another range of seeds
You can either look before you leap by testing if the seed column exists:
abc <- function(a, z, n, ar11, p, d, q, sd = sd, j1, arr1, n_cores){
# ...code as in OP...
res2 <- tibble::tibble(Reduce(function(...) merge(..., all = T), lapply(res1, function(x) as.data.frame(t(x)))))
if (!("seed" %in% colnames(res2))) {
warning("Try another range of seeds", call. = FALSE)
} else {
res2[order(res2$seed), ]
}
}
abc(a = 280000, z = 281000, n = 10, p = 1, d = 0, q = 0, ar11 = 0.8, sd = 1, j1 = 4, arr1 = "0.80")
# processing...
# done!
#
# Warning message:
# Try another range of seeds
Or ask for forgiveness instead of permission using tryCatch() and suppressWarnings() for a slightly more generic approach:
abc <- function(a, z, n, ar11, p, d, q, sd = sd, j1, arr1, n_cores){
# ...code as in OP...
res2 <- tibble::tibble(Reduce(function(...) merge(..., all = T), lapply(res1, function(x) as.data.frame(t(x)))))
tryCatch(
suppressWarnings(res2[order(res2$seed), ]),
error = \(err) {
if (grepl("argument 1 is not a vector", err$message)) {
warning("Try another range of seeds", call. = FALSE)
} else {
stop(err)
}
}
)
}
abc(a = 280000, z = 281000, n = 10, p = 1, d = 0, q = 0, ar11 = 0.8, sd = 1, j1 = 4, arr1 = "0.80")
# processing...
# done!
#
# Warning message:
# Try another range of seeds
That said, it’s better in my opinion to throw an error than a warning when a function doesn’t return the expected output. Especially if other code will depend on the result of this function. You can throw an error with your desired message by replacing warning() with stop().
I have some R-function f, which fixes some parameters of some other function target (thanks to GKi for help):
target <- function(b1,b2,l1,l2,l3,o1,o2) return((b1+b2+l1+l2+l3+o1+o2)^2)
fixed <- c(b1 = 1, l1 = 2, l2 = 3, l3 = 4, o1 = 5)
variable <- c("o2","b2")
f <- function(fixed, variable) {
target_new <- function() {}
formals(target_new) <- setNames(rep(list(bquote()), length(variable)), variable)
for(i in variable) assign(i, as.symbol(i))
body(target_new) <- do.call("call", unlist(list("target", mget(variable), as.list(fixed))))
return(target_new)
}
f(fixed,variable)
> function (o2, b2)
> target(o2 = o2, b2 = b2, b1 = 1, l1 = 2, l2 = 3, l3 = 4, o1 = 5)
> <environment: 0x0000020a8e0c0c88>
I want to maximize target_new by nlm, so I need to concentrate its function arguments into a vector, i.e. the desired output of f(fixed,variable) is
> function (theta)
> target(o2 = theta[1], b2 = theta[2], b1 = 1, l1 = 2, l2 = 3, l3 = 4, o1 = 5)
How to modify the above code, so that the function can process the vector theta?
Please mind that the vectors fixed and variable can be of variable lengths.
You are making this too complicated.
f <- function(fixed, variable) {
function(theta) {
args <- c(as.list(theta), as.list(fixed))
names(args)[seq_along(variable)] <- variable
do.call(target, args)
}
}
fun <- f(fixed, variable)
#does it work?
all.equal(
nlm(fun, p = c(1, 2)),
nlm(function(theta) target(1,theta[2], 2, 3, 4, 5, theta[1]),
p = c(1, 2))
)
#[1] TRUE
Consider the following:
foo <- function(a = 1, b = 2, c = 3, d = 1, e = 2, f = 3, g = 4, h = 1) {
print(h)
bar(a = a, b = b, c = c, d = d, e = e, f = f, g = g)
foobar(c = c, e = e, g = g)
}
bar <- function(a, b, c, d, e, f, g) {
a + b + c + d + e + f * g
}
foobar <- function(c, e, g) {
if (c) {
print(g + e)
}
}
foo(1, 2, 3, 4,5, 6, 7, 8)
I have something similar to the above where I have subfunction calls that require a lot of the variables passed down from the level above it. Is there an easier way of doing lines 3 and 4 of this code, rather than manually listing out each variable each time it calls it?
Well, we can create a helper function to make this easier
call_match_args <- function(fun, data) {
fun <- match.fun(fun)
seeking <- names(formals(fun))
stopifnot(all(seeking %in% names(data)))
do.call(fun, data[seeking], envir=parent.frame())
}
this will take a function and a list and will pass all the values of the list that match the function parameters names as arguments. The do.call function takes care of turning the list into parameters.
Then we can change your foo function to look something like this
foo <- function(a = 1, b = 2, c = 3, d = 1, e = 2, f = 3, g = 4, h = 1) {
vars <- mget(ls())
print(vars$h)
call_match_args(bar, vars)
call_match_args(foobar, vars)
}
foo(1, 2, 3, 4,5, 6, 7, 8)
# [1] 8
# [1] 12
while bar and foobar can stay the same. The first step in the function it to take all the parameter values and put them in a list. Then you access them from that list and can pass that list to the call_match_args helper function.
The behaviour of modifyList is to modify lists recursively - i.e., in this case, the fixed is a nested list which will also be "modified":
default.options <- list(a = 1, b = 2, c = "hello", fixed = list(a = 1))
user.options <- list(b = 3, e = 0, fixed = list())
opts <- modifyList(default.options, user.options)
dput(opts)
# list(a = 1, b = 3, c = "hello", fixed = list(a = 1), e = 0)
But, what if I don't want it to follow the sublist fixed recursively, but just replace it as a whole, i.e. the desired result is this? :
list(a = 1, b = 3, c = "hello", fixed = list(), e = 0)
Is there a simple way to do this non-recursive list modification?
You can simply do:
default.options[names(user.options)] <- user.options
identical(default.options, list(a = 1, b = 3, c = "hello", fixed = list(), e = 0))
[1] TRUE
Seems to me the simple answer is just to copy and modify the source code of modfiyList() to remove the recursive part of it:
modify_list_nonrecursive <- function (x, val, keep.null = FALSE) {
stopifnot(is.list(x), is.list(val))
xnames <- names(x)
vnames <- names(val)
vnames <- vnames[nzchar(vnames)]
if (keep.null) {
for (v in vnames) {
x[v] <- val[v]
}
}
else {
for (v in vnames) {
x[[v]] <- val[[v]]
}
}
return(x)
}
default.options <- list(a = 1, b = 2, c = "hello", fixed = list(a = 1))
user.options <- list(b = 3, e = 0, fixed = list())
opts <- modifyList(default.options, user.options)
dput(opts)
# list(a = 1, b = 3, c = "hello", fixed = list(a = 1), e = 0)
opts <- modify_list_nonrecursive(default.options, user.options)
dput(opts)
# list(a = 1, b = 3, c = "hello", fixed = list(), e = 0)
The original source code of modifyList() was
modifyList
function (x, val, keep.null = FALSE)
{
stopifnot(is.list(x), is.list(val))
xnames <- names(x)
vnames <- names(val)
vnames <- vnames[nzchar(vnames)]
if (keep.null) {
for (v in vnames) {
x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]]))
list(modifyList(x[[v]], val[[v]], keep.null = keep.null))
else val[v]
}
}
else {
for (v in vnames) {
x[[v]] <- if (v %in% xnames && is.list(x[[v]]) &&
is.list(val[[v]]))
modifyList(x[[v]], val[[v]], keep.null = keep.null)
else val[[v]]
}
}
x
}
So you can see you just have to delete some conditionals with recursive calls and it works just fine!
Hi I want to convert a matrix of genotypes, encoded as triples to a matrix encoded as 0, 1, 2, i.e.
c(0,0,1) <-> 0; c(0,1,0) <-> 1; c(0,0,1) <-> 2
First here is some code to generate the matrix that needs to be reduced.
# generate genotypes
expand.G = function(n,p){
probs = runif(n = p)
G012.rows = matrix(rbinom(2,prob = probs,n=n*p),nrow = p)
colnames(G012.rows) = paste('s',1:n,sep = '')
rownames(G012.rows) = paste('g',1:p, sep = '')
G012.cols = t(G012.rows)
expand.geno = function(g){
if(g == 0){return(c(1,0,0))}
if(g == 1){return(c(0,1,0))}
if(g == 2){return(c(0,0,1))}
}
gtype = c()
for(i in 1:length(c(G012.cols))){
gtype = c(
gtype,
expand.geno(c(G012.cols)[i])
)
}
length(gtype)
G = matrix(gtype,byrow = T, nrow = p)
colnames(G) = paste('s',rep(1:n,each = 3),c('1','2','3'),sep = '')
rownames(G) = paste('g',1:p, sep = '')
print(G[1:10,1:15])
print(G012.rows[1:10,1:5])
return(G)
}
The output has 3n columns and p rows, where n is sample size and p is number of genotypes. Now we can reduce the matrix back to 0,1,2 coding with the following functions
reduce012 = function(x){
if(identical(x, c(1,0,0))){
return(0)
} else if(identical(x, c(0,1,0))){
return(1)
} else if(identical(x, c(0,0,1))){
return(2)
} else {
return(NA)
}
}
reduce.G = function(G.gen){
G.vec =
mapply(function(i,j) reduce012(as.numeric(G.gen[i,(3*j-2):(3*j)])),
i=expand.grid(1:(ncol(G.gen)/3),1:nrow(G.gen))[,2],
j=expand.grid(1:(ncol(G.gen)/3),1:nrow(G.gen))[,1]
)
G = matrix(G.vec, nrow = ncol(G.gen)/3, ncol = nrow(G.gen))
colnames(G) = rownames(G.gen)
return(G)
}
reduce.G.loop = function(G.gen){
G = matrix(NA,nrow = ncol(G.gen)/3, ncol = nrow(G.gen))
for(i in 1:nrow(G.gen)){
for(j in 1:(ncol(G.gen)/3)){
G[j,i] = reduce012(as.numeric(G.gen[i,(3*j-2):(3*j)]))
}
}
colnames(G) = rownames(G.gen)
return(G)
}
The output is n rows by p columns. It is incidental, but intentional, that the matrix encoded as 0,1,2 is the transpose of the matrix encoded as triples.
The code is not particularly fast. What is bothering me is that the the timing goes with n^2. Can you explain or supply more efficient code?
G = expand.G(1000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
G = expand.G(2000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
G = expand.G(4000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
You can simply make an accessor lookup table:
decode <- array(dim = c(3, 3, 3))
decode[cbind(1, 0, 0) + 1] <- 0
decode[cbind(0, 1, 0) + 1] <- 1
decode[cbind(0, 0, 1) + 1] <- 2
And then, just do:
matrix(decode[matrix(t(G + 1), ncol = 3, byrow = TRUE)], ncol = nrow(G))
This full vectorized R version will give you the same matrix, without dimnames and super fast.
Yet, if you have much larger matrices, you should really use Rcpp for both memory and timing issues.
This seems to be a about three times faster than your version (renamed reduce.G.orig):
reduce.G <- function(G) {
varmap = c("100"=0, "010"=1, "001"=2)
result <- do.call(rbind, lapply(1:(ncol(G)/3)-1, function(val)
varmap[paste(G[,3*val+1], G[,3*val+2], G[,3*val+3], sep="")]))
colnames(result) <- rownames(G)
result
}
system.time(reduce.G(G))
# user system elapsed
# 0.156 0.000 0.155
system.time(reduce.G.orig(G))
# user system elapsed
# 0.444 0.000 0.441
identical(reduce.G(G), reduce.G.orig(G))
# [1] TRUE