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!
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
My data:
df_1 <- data.frame(
x = replicate(
n = 3,
expr = runif(n = 30, min = 20, max = 100)
),
y = sample(
x = 1:3, size = 30, replace = TRUE
)
)
The follow code with lapply works:
lapply(X = names(df_1)[c(1:3)], FUN = function(x) {
pairwise.t.test(
x = df_1[, x],
g = df_1[['y']],
p.adj = 'bonferroni'
)
})
But, with apply doesn't:
apply(X = names(df_1)[c(1:3)], MARGIN = 2, FUN = function(x) {
pairwise.t.test(
x = df_1[, x],
g = df_1[['y']],
p.adj = 'bonferroni'
)
})
Error in apply(X = names(df_1)[c(1:3)], MARGIN = 2, FUN = function(x) { :
dim(X) must have a positive length
Why the problem? Are they not equivalent?
For apply you should instead use
apply(X = df_1[1:3], MARGIN = 2, FUN = function(x) {
pairwise.t.test(
x = x,
g = df_1[['y']],
p.adj = 'bonferroni'
)
})
that is because from ?apply
apply returns a vector if MARGIN has length 1 and an array of dimension dim(X)[MARGIN] otherwise.
In your attempt you are using names(df_1)[c(1:3)] as argument to apply which has
dim(names(df_1)[c(1:3)])[2]
#NULL
Hence, you get the error.
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
I have list out like this:
u <- list(a = list(b = 1, c = 2),
x = list(k = list(ka = 1, kb = 3),
l = list(la = 1, la = 4)))
v <- list(a = list(b = 1, c = 2),
x = list(m = list(ma = 5, mb = 8),
n = list(na = 5, nb = 8)))
w <- list(a = list(b = 1, c = 2),
x = list(o = list(oa = 4, ob = 1),
p = list(pa = 8, pb = 0)))
out <- list(u, v, w)
I would like to create another list where there are elements k, l, m, n, o, p and names of the list elements are preserved. I found a solution, but looks sub-optimal:
x <- lapply(out, function(y) y[['x']])
o <- list()
for (a in x) {
o <- c(o, a)
}
> str(o, max.level = 1)
List of 6
$ k:List of 2
$ l:List of 2
$ m:List of 2
$ n:List of 2
$ o:List of 2
$ p:List of 2
Is there a better way?
The loop could be replaced with unlist:
res <- unlist( lapply(out,"[[","x"), recursive=FALSE)
identical(res,o)
# [1] TRUE
My lapply is the same as in the OP; it's just a shortcut.
As #akrun suggested, you could more closely mirror the OP's loop with
do.call("c", lapply(out, '[[', 'x'))