Recently I've stumbled upon this bit of code:
y <- NULL
y[cbind(1:2, 1:2)] <- list( list(1,2), list(2,3))
From the second answer here.
But it doesn't seem to differ from y <- list(...), as the comparisons below show:
> identical(y, list( list(1,2), list(2,3)))
[1] TRUE
> identical(y, y[cbind(1:2, 1:2)])
[1] FALSE
What is going on in the bracket assignment here? Why it doesn't throw an error? And why is it different from the non-assigment version in the last line of code?
Matrix indexing only applies when y has dim. Combine this with standard R recycling and the fact that all matrices are actually vectors, and this behavior makes sense.
When you initialize y to NULL, you ensure it has no dim. Therefore, when you index y by a matrix, say ind, you get the same results as having called y[as.vector(ind)]
identical(y[ind], y[as.vector(ind)])
# [1] TRUE
If there are repeat values in ind and you are also assigning, then for each index, only the last value assigned ot it will remain. For example Lets assume we are executing
y <- NULL; y[cbind(1:2, 2:1)] <- list( list(1,2), list(3,4) )
# y has no dimension, so `y[cbind(1:2, 2:1)]`
# is the equivalent of `y[c(1:2, 2:1)]`
When you assign y[c(1, 2, 2, 1)] <- list("A", "B") , in effect what happens is analogous to:
y[[1]] <- "A"
y[[2]] <- "B"
y[[2]] <- "B" # <~~ 'Overwriting' previous value
y[[1]] <- "A" # <~~ 'Overwriting' previous value
Here is a further look at the indexing that occurs: (Notice how the first two letters are being repeated)
ind <- cbind(1:2, 1:2)
L <- as.list(LETTERS)
L[ind]
# [[1]]
# [1] "A"
#
# [[2]]
# [1] "B"
#
# [[3]]
# [1] "A"
#
# [[4]]
# [1] "B"
Here is the same thing, now with assignment. Notice how only the 3rd and 4th values being assigned have been kept.
L[ind] <- c("FirstWord", "SecondWord", "ThirdWord", "FourthWord")
L[ind]
# [[1]]
# [1] "ThirdWord"
#
# [[2]]
# [1] "FourthWord"
#
# [[3]]
# [1] "ThirdWord"
#
# [[4]]
# [1] "FourthWord"
Try a different index for further clarity:
ind <- cbind(c(3, 2), c(1, 3)) ## will be treated as c(3, 2, 1, 3)
L <- as.list(LETTERS)
L[ind] <- c("FirstWord", "SecondWord", "ThirdWord", "FourthWord")
L[1:5]
# [[1]]
# [1] "ThirdWord"
#
# [[2]]
# [1] "SecondWord"
#
# [[3]]
# [1] "FourthWord"
#
# [[4]]
# [1] "D"
#
# [[5]]
# [1] "E"
L[ind]
# [[1]]
# [1] "FourthWord"
#
# [[2]]
# [1] "SecondWord"
#
# [[3]]
# [1] "ThirdWord"
#
# [[4]]
# [1] "FourthWord"
Edit regarding #agstudy's questions:
Looking at the src for [ we have the following comments:
The special [ subscripting where dim(x) == ncol(subscript matrix)
is handled inside VectorSubset. The subscript matrix is turned
into a subscript vector of the appropriate size and then
VectorSubset continues.
Looking at the function static SEXP VectorSubset(SEXP x, SEXP s, SEXP call) the relevant check is the following:
/* lines omitted */
attrib = getAttrib(x, R_DimSymbol);
/* lines omitted */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
/* lines omitted */
...
Related
I'm looking for a speedy solution for randomly subsetting vectors nested in a list.
If we simulate the following data, we get a list l that holds 3 million vectors inside, each one is of length 5. But I want the length of each vector to vary. So I thought I should apply a function that randomly subsets each vector. The problem is, this method is not as speedy as I wished.
simulate data: the list l
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
head(l)
#> [[1]]
#> HmPsw Qk8NP Quo3T 8f0GH nZmjN
#> 1 3000001 6000001 9000001 12000001
#>
#> [[2]]
#> 2WtYS ZaHFl 6YjId jbGuA tAG65
#> 2 3000002 6000002 9000002 12000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F 5JRT5
#> 3 3000003 6000003 9000003 12000003
#>
#> [[4]]
#> tF2Kx r4ZCI Ooklo VOLHU M6z6H
#> 4 3000004 6000004 9000004 12000004
#>
#> [[5]]
#> tgdze w8d1B FYERK jlClo NQfsF
#> 5 3000005 6000005 9000005 12000005
#>
#> [[6]]
#> hXaH9 gsY1u CjBwC Oqqty dxJ4c
#> 6 3000006 6000006 9000006 12000006
Now that we have l, I wish to subset each vector randomly: meaning that the number of elements being subsetted (per vector) will be random. So one option is to set the following utility function:
randomly_subset_vec <- function(x) {
my_range <- 1:length(x)
x[-sample(my_range, sample(my_range))]
}
lapply(head(l), randomly_subset_vec)
#> [[1]]
#> Quo3T
#> 6000001
#>
#> [[2]]
#> 6YjId jbGuA
#> 6000002 9000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F
#> 3 3000003 6000003 9000003
#>
#> [[4]]
#> Ooklo
#> 6000004
#>
#> [[5]]
#> named integer(0)
#>
#> [[6]]
#> CjBwC Oqqty dxJ4c
#> 6000006 9000006 12000006
But running this procedure over the entire l takes forever. I've tried using rrapply which is a fast package for dealing with lists, and it takes "only" 110 seconds on my machine.
library(rrapply)
library(tictoc)
tic()
l_subsetted <- rrapply(object = l, f = randomly_subset_vec)
toc()
#> 110.23 sec elapsed
I will be happy with either of the following:
Is there a speedier alternative to:
rrapply(object = l, f = randomly_subset_vec)
Or more generally, is there a speedier way to start with my_named_vec and arrive at l_subsetted?
UPDATE 1 to fix the name behavior in stack for large objects
Your subsets don't include the full set, so this first removes a random element from each vector, then randomly retains all other elements:
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
system.time({
lenl <- lengths(l)
# use stack to unlist the list while keeping the originating list index for each value
vec_names <- names(unlist(l))
blnKeep <- replace(sample(c(FALSE, TRUE), length(vec_names), replace = TRUE), ceiling(runif(length(l))*lenl) + c(0, head(cumsum(lenl), -1)), FALSE)
temp <- stack(setNames(l, seq_along(l)))[blnKeep,]
# re-list
l_subsetted <- unname(split(setNames(temp$values, vec_names[blnKeep]), temp$ind))
})
#> user system elapsed
#> 22.999 0.936 23.934
head(l_subsetted)
#> [[1]]
#> HmPsw nZmjN
#> 1 12000001
#>
#> [[2]]
#> 2WtYS 6YjId
#> 2 6000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc
#> 3 3000003 6000003
#>
#> [[4]]
#> tF2Kx r4ZCI
#> 4 3000004
#>
#> [[5]]
#> FYERK NQfsF
#> 6000005 12000005
#>
#> [[6]]
#> gsY1u
#> 3000006
Created on 2021-11-01 by the reprex package (v2.0.0)
UPDATE 2 for vectors of uniformly distributed lengths:
#runr is correct in the comments that the above code will result in binomially-distributed vector lengths, while the OP's original code results in uniformly-distributed vector lengths. Below is an example of how to use the same idea to get uniformly-distributed vector lengths. The code is more complex, but the run-time seems to be a bit faster (possibly due to circumventing stack):
library(stringi)
set.seed(123)
vec_n <- 15e6
vec_vals <- 1:vec_n
vec_names <- stringi::stri_rand_strings(vec_n, 5)
my_named_vec <- setNames(vec_vals, vec_names)
split_func <- function(x, n) {
unname(split(x, rep_len(1:n, length(x))))
}
l <- split_func(my_named_vec, n = vec_n / 5)
system.time({
idx <- seq_along(l)
lenl <- lengths(l)
ul <- unlist(l)
# get a random number of elements to remove from each vector
nRemove <- ceiling(runif(length(l))*lenl)
nRemove2 <- nRemove
blnNotEmpty <- nRemove != lenl # will the subset vector have any elements?
blnKeep <- rep(TRUE, length(l))
# loop until the predetermined number of elements have been removed from each vector
while (length(nRemove)) {
# remove a random element from vectors that have too many
ul <- ul[-(ceiling(runif(length(idx))*lenl[idx]) + c(0, head(cumsum(lenl), -1))[idx])]
lenl[idx] <- lenl[idx] - 1L # decrement the vector lengths
blnKeep <- nRemove != 1
idx <- idx[blnKeep]
nRemove <- nRemove[blnKeep] - 1L # decrement the number of elements left to remove
}
l_subsetted <- rep(list(integer(0)), length(l))
l_subsetted[blnNotEmpty] <- unname(split(ul, rep.int(seq_along(l), lenl)))
})
#> user system elapsed
#> 18.396 0.935 19.332
head(l_subsetted)
#> [[1]]
#> Qk8NP Quo3T 8f0GH
#> 3000001 6000001 9000001
#>
#> [[2]]
#> integer(0)
#>
#> [[3]]
#> xSgZ6 ujPOc CTV5F 5JRT5
#> 3 6000003 9000003 12000003
#>
#> [[4]]
#> tF2Kx Ooklo VOLHU
#> 4 6000004 9000004
#>
#> [[5]]
#> tgdze w8d1B jlClo NQfsF
#> 5 3000005 9000005 12000005
#>
#> [[6]]
#> gsY1u CjBwC Oqqty dxJ4c
#> 3000006 6000006 9000006 12000006
# check that vector lengths are uniformly-distributed (lengths of 0-4 are equally likely)
table(lengths(l_subsetted))
#>
#> 0 1 2 3 4
#> 599633 599041 601209 600648 599469
Created on 2021-11-02 by the reprex package (v2.0.1)
Very rough and I'm not particularly proud of this. I'm sure there is a more elegant way but this ran in the matter of seconds on my machine
> # Make some fake data
> out <- lapply(1:3000000, function(i){sample(LETTERS, 5, replace = FALSE)})
> out[1:5]
[[1]]
[1] "D" "H" "C" "Y" "V"
[[2]]
[1] "M" "E" "H" "G" "S"
[[3]]
[1] "R" "P" "O" "L" "M"
[[4]]
[1] "C" "U" "G" "Q" "X"
[[5]]
[1] "Q" "L" "W" "O" "V"
> # Create list with ids to sample
> id <- lapply(1:3000000, function(i){sample(1:5, sample(1:5, 1), replace = FALSE)})
> id[1:5]
[[1]]
[1] 2
[[2]]
[1] 2 3 4 1 5
[[3]]
[1] 4
[[4]]
[1] 5
[[5]]
[1] 1 2
> # Extract the ids from the original data using the id list.
> # Like I said I'm not particularly proud of this but it gets the job
> # done quick enough on my computer
> out <- lapply(1:3000000, function(i){out[[i]][id[[i]]]})
> out[1:5]
[[1]]
[1] "H"
[[2]]
[1] "E" "H" "G" "M" "S"
[[3]]
[1] "L"
[[4]]
[1] "X"
[[5]]
[1] "Q" "L"
Simplify the sampling function:
randomly_subset_vec_2 <- function(x) {
my_range <- length(x)
x[-sample(my_range, sample(my_range, 1))]
}
This alone can give a significant speed-up.
And though I have not tested it, given the problem description, to remove some elements (minus sign before sample) is to keep the others. Why not extract some elements (no minus sign) thereby keeping those?
Simpler and faster: To sample directly from x is the fastest so far.
randomly_subset_vec_3 <- function(x) {
sample(x, sample(length(x), 1))
}
It seems that the largest bottleneck is running all the sample calls, so we could try the following. One way, is the solution by Julius Vainora. First, we generate funFast by Rcpp:
library(inline)
library(Rcpp)
src <-
'
int num = as<int>(size), x = as<int>(n);
Rcpp::NumericVector vx = Rcpp::clone<Rcpp::NumericVector>(x);
Rcpp::NumericVector pr = Rcpp::clone<Rcpp::NumericVector>(prob);
Rcpp::NumericVector rnd = rexp(x) / pr;
for(int i= 0; i<vx.size(); ++i) vx[i] = i;
std::partial_sort(vx.begin(), vx.begin() + num, vx.end(), Comp(rnd));
vx = vx[seq(0, num - 1)] + 1;
return vx;
'
incl <-
'
struct Comp{
Comp(const Rcpp::NumericVector& v ) : _v(v) {}
bool operator ()(int a, int b) { return _v[a] < _v[b]; }
const Rcpp::NumericVector& _v;
};
'
funFast <- cxxfunction(signature(n = "Numeric", size = "integer", prob = "numeric"),
src, plugin = "Rcpp", include = incl)
Then, define an alternative to your randomly_subset_vec using funFast instead of sample:
'randomly_subset_vec_2' <- function(x) {
range <- length(x)
probs <- rep(1/range, range)
o <- funFast(range, size = funFast(range, size = 1, prob = probs), prob = probs)
return(x[-o])
}
tic();obj <- rrapply(object = l, f = randomly_subset_vec_2);toc();
Maybe we can replace randomly_subset_vec with something simpler with sample and sample.int:
lapply(l, function(x) x[sample.int(5, sample(5, 1))])
More efficient is probably to replace the many individual sample calls by a single larger sample call. Below is an approach that samples a large logical matrix keep (since l initially has a rectangular format) and keep only the entries for which keep evaluates to TRUE:
system.time({
keep <- matrix(sample(c(TRUE, FALSE), size = vec_n, replace = TRUE), nrow = 5, ncol = length(l))
l1 <- lapply(seq_along(l), function(i) l[[i]][keep[, i]])
})
#> user system elapsed
#> 8.667 0.448 9.114
head(l1)
#> [[1]]
#> HmPsw Quo3T 8f0GH
#> 1 6000001 9000001
#>
#> [[2]]
#> 2WtYS ZaHFl 6YjId
#> 2 3000002 6000002
#>
#> [[3]]
#> xSgZ6 jM5Uw ujPOc CTV5F 5JRT5
#> 3 3000003 6000003 9000003 12000003
#>
#> [[4]]
#> M6z6H
#> 12000004
#>
#> [[5]]
#> tgdze w8d1B FYERK jlClo NQfsF
#> 5 3000005 6000005 9000005 12000005
#>
#> [[6]]
#> hXaH9 CjBwC Oqqty
#> 6 6000006 9000006
NB: here the order of the entries in l stays the same (i.e. no resampling), also list elements of l1 are not guaranteed to contain at least one value.
I'm putting this in a new answer so as to not further confuse my previous one.
I noticed from some of the comments that the vectors in l are intended to have all the same lengths (5) and that you may not need l at all. It's also a little unclear whether you want the lengths of l_subsetted to be between 0 and 4 or between 0 and 5. You also seem to be interested in the distribution of the lengths of l_subsetted (uniform vs. binomial).
Below is a generic function if length(unique(lengths(l))) == 1. It subsets directly from my_named_vec without creating l. It pretty consistently runs in the 5-13 second range.
set.seed(123)
vec_n <- 15e6L
my_named_vec <- setNames(1:vec_n, stringi::stri_rand_strings(vec_n, 5))
fSub <- function(nv, vecLen = 5L, maxLen = 5L, unif = FALSE) {
# subset each named vector from the list l (l is not generated):
# l <- unname(split(nv, rep_len(seq(length(nv)/vecLen), length(nv))))
# INPUTS:
# nv: named vector whose length is a multiple of vecLen
# vecLen: the length of the vectors in l
# maxLen: the maximum length of the subsetted vectors
# unif: FALSE = binomial subset vector lengths
# TRUE = uniform subset vector lengths
# OUTPUT: a list of named vectors subset from l
nrw <- length(nv)%/%vecLen # length of the output list
# get all possible logical indices for sampling each vector in l
mKeep <- as.matrix(expand.grid(rep(list(c(TRUE, FALSE)), vecLen)), ncol = vecLen)
nKeep <- rowSums(mKeep)
# remove logical indices that would result in vectors greater than maxLen
blnKeep <- nKeep <= maxLen
mKeep <- mKeep[blnKeep,]
nKeep <- nKeep[blnKeep]
if (unif) {
# sample mKeep with non-uniform probability in order to get uniform lengths
iKeep <- sample(length(nKeep), nrw, replace = TRUE, prob = 1/choose(vecLen, nKeep))
} else {
iKeep <- sample(length(nKeep), nrw, replace = TRUE)
}
blnKeep <- c(mKeep[iKeep,])
l <- rep(list(integer(0L)), nrw)
l[iKeep != length(nKeep)] <- unname(split(nv[blnKeep], rep(1:nrw, vecLen)[blnKeep]))
return(l)
}
lbinom5 <- fSub(my_named_vec) # binomial vector lengths (0 to 5)
lunif5 <- fSub(my_named_vec, unif = TRUE) # uniform vector lengths (0 to 5)
lbinom4 <- fSub(my_named_vec, maxLen = 4L) # binomial vector lenghts (0 to 4)
lunif4 <- fSub(my_named_vec, maxLen = 4L, unif = TRUE) # uniform vector lengths (0 to 4)
> microbenchmark::microbenchmark(
+ lbinom5 = {lbinom5 <- fSub(my_named_vec)},
+ lunif5 = {lunif5 <- fSub(my_named_vec, unif = TRUE)},
+ lbinom4 = {lbinom4 <- fSub(my_named_vec, maxLen = 4L)},
+ lunif4 = {lunif4 <- fSub(my_named_vec, maxLen = 4L, unif = TRUE)},
+ times = 10)
Unit: seconds
expr min lq mean median uq max neval
lbinom5 5.974837 8.060281 9.192600 9.014967 10.15609 13.01182 10
lunif5 5.240133 6.618115 9.688577 10.799230 11.44718 12.73518 10
lbinom4 5.082508 6.497218 8.636434 8.656817 11.40678 11.81519 10
lunif4 5.468311 6.639423 8.310269 7.919579 10.28546 11.28075 10
You can try the code below
lapply(
l,
function(x) {
head(sample(x), sample(length(x), 1))
}
)
I have a df (data) that I want to pass as an argument to a function fun.lag_cols to calculate (for each column in df) several lags. The results must be stored in a nested list, but my function seems to be missing (at least) one step.
data <- data.frame(x1 = rnorm(10,0,1)
, x2 = rnorm(10,2,3)
, x3 = rnorm(10,6,1))
fun.lag_cols <- function(x, lag_from = 0, lag_to = 2) {
x <- as.data.frame(x)
cols_x <- ncol(x)
lst_lag <- list()
for (i in 1:cols_x) {
for(j in lag_from:lag_to) {
lst_lag[[i]] <- dplyr::lag(x[,i],j)
}
}
return(lst_lag)
}
output <- fun.lag_cols(data)
In this particular example, I would like to see output as a list of 3 elements (x1, x2, x3), each element a new list of 3 (one per lag 0, 1, 2).
My code seems to store only lag2 (in general, the maximum lag) for each variable, clearly not the expected result.
I am open to different approaches, as long as they provide the final output (nested list).
Thanks
We could change the assignment of the 'lst_lag[[i]]' by concatenating the element with the lag value inside the nested loop. In the function, there are two changes - 1) initialize an output list with predefined length (vector('list', ncol(x))), 2) inside the nested loop, where we append those ith list elements with new child list elements by concatenating the already existing list with the new list created by wrapping the lag inside a list, while recursively updating the same list element (<-)
fun.lag_cols <- function(x, lag_from = 0, lag_to = 2) {
x <- as.data.frame(x)
cols_x <- ncol(x)
lst_lag <- vector('list', ncol(x))
for (i in 1:cols_x) {
for(j in lag_from:lag_to) {
lst_lag[[i]] <- c(lst_lag[[i]], list(dplyr::lag(x[,i],j)))
}
}
return(lst_lag)
}
-testing
fun.lag_cols(data)
[[1]]
[[1]][[1]]
[1] -1.40431393 -2.22551238 0.06090537 0.77941726 1.10733091 1.20657717 0.71614034 -0.17990135 0.22058894 0.33598415
[[1]][[2]]
[1] NA -1.40431393 -2.22551238 0.06090537 0.77941726 1.10733091 1.20657717 0.71614034 -0.17990135 0.22058894
[[1]][[3]]
[1] NA NA -1.40431393 -2.22551238 0.06090537 0.77941726 1.10733091 1.20657717 0.71614034 -0.17990135
[[2]]
[[2]][[1]]
[1] 1.1334651 1.2385579 1.8930347 -4.7379766 2.0169352 0.7210822 -1.0322536 4.5446643 1.4421923 1.1316508
[[2]][[2]]
[1] NA 1.1334651 1.2385579 1.8930347 -4.7379766 2.0169352 0.7210822 -1.0322536 4.5446643 1.4421923
[[2]][[3]]
[1] NA NA 1.1334651 1.2385579 1.8930347 -4.7379766 2.0169352 0.7210822 -1.0322536 4.5446643
[[3]]
[[3]][[1]]
[1] 4.324912 5.114774 4.517017 7.001338 5.218430 4.408571 7.233504 6.875883 5.848294 4.696724
[[3]][[2]]
[1] NA 4.324912 5.114774 4.517017 7.001338 5.218430 4.408571 7.233504 6.875883 5.848294
[[3]][[3]]
[1] NA NA 4.324912 5.114774 4.517017 7.001338 5.218430 4.408571 7.233504 6.875883
There is already a function available to do this i.e. shift from data.table which take a vectorized n
library(data.table)
shift(data, n = 0:2)
Using lapply :
fun.lag_cols <- function(x, lag_from = 0, lag_to = 2) {
val <- lag_from:lag_to
lapply(x, function(v)
setNames(lapply(val, function(n) dplyr::lag(v, n)), paste0('lag_', val)))
}
fun.lag_cols(data)
#$x1
#$x1$lag_0
# [1] -1.5095832 -0.2638919 0.5986575 3.3043298 0.9471048 -1.2154015
# [7] 0.8921754 -1.6614204 -0.2036500 0.9570701
#$x1$lag_1
# [1] NA -1.5095832 -0.2638919 0.5986575 3.3043298 0.9471048
# [7] -1.2154015 0.8921754 -1.6614204 -0.2036500
#$x1$lag_2
# [1] NA NA -1.5095832 -0.2638919 0.5986575 3.3043298
# [7] 0.9471048 -1.2154015 0.8921754 -1.6614204
#$x2
#$x2$lag_0
# [1] -4.8181366 4.1741754 4.6560021 -0.5167334 1.5284542 8.7717049
# [7] -0.2104695 2.4273092 1.4985899 2.7356401
#$x2$lag_1
# [1] NA -4.8181366 4.1741754 4.6560021 -0.5167334 1.5284542
# [7] 8.7717049 -0.2104695 2.4273092 1.4985899
#$x2$lag_2
# [1] NA NA -4.8181366 4.1741754 4.6560021 -0.5167334
# [7] 1.5284542 8.7717049 -0.2104695 2.4273092
#$x3
#$x3$lag_0
# [1] 7.712619 5.237124 5.798063 5.695696 5.127347 3.789074 5.830557
# [8] 3.801073 5.794048 5.227110
#$x3$lag_1
# [1] NA 7.712619 5.237124 5.798063 5.695696 5.127347 3.789074
# [8] 5.830557 3.801073 5.794048
#$x3$lag_2
# [1] NA NA 7.712619 5.237124 5.798063 5.695696 5.127347
# [8] 3.789074 5.830557 3.801073
I would like to extract list elements and their indices in R while removing items with 0 length. Let's say I have the following list in R:
l1 <- character(0)
l2 <- c("a","b")
l3 <- c("c","d","e")
list1 <- list(l1, l1, l2, l1, l3)
Then list1 returns the following:
[[1]]
character(0)
[[2]]
character(0)
[[3]]
[1] "a" "b"
[[4]]
character(0)
[[5]]
[1] "c" "d" "e"
I would like to somehow extract an object that displays the index/position for each non-empty element, as well as the contents of that element. So something that looks like this:
[[3]]
[1] "a" "b"
[[5]]
[1] "c" "d" "e"
The closest I've come to doing this is by removing the empty elements, but then I lose the original index/position of the remaining elements:
list2 <- list1[lapply(list1, length) > 0]
list2
[[1]]
[1] "a" "b"
[[2]]
[1] "c" "d" "e"
keep, will keep elements matching a predicate. negate(is_empty) creates a function that returns TRUE if a vector is not empty.
library("purrr")
names(list1) <- seq_along(list1)
keep(list1, negate(is_empty))
#> $`3`
#> [1] "a" "b"
#>
#> $`5`
#> [1] "c" "d" "e"
Overview
Keeping the indices required me to name each element in the list. This answer uses which() to set the condition that I apply to list1 to keep non-zero length elements.
# load data
l1 <- character(0)
l2 <- c("a","b")
l3 <- c("c","d","e")
list1 <- list( l1, l1, l2, l1, l3)
# name each element in the list
names( list1 ) <- as.character( 1:length( list1 ) )
# create a condition that
# keeps only non zero length elements
# from list1
non.zero.length.elements <-
which( lapply( X = list1, FUN = length ) != 0 )
# apply the condition to list1
# to view the non zero length elements
list1[ non.zero.length.elements ]
# $`3`
# [1] "a" "b"
#
# $`5`
# [1] "c" "d" "e"
# end of script #
I'm not sure exactly what 'extract an object that displays' means, but if you just want to print you can use this modified print.
I just slightly edited print.listof (it's not recursive! zero length subelements will be displayed):
print2 <- function (x, ...)
{
nn <- names(x)
ll <- length(x)
if (length(nn) != ll)
nn <- paste0("[[", seq.int(ll),"]]")
for (i in seq_len(ll)[lengths(x)>0]) {
cat(nn[i], "\n")
print(x[[i]], ...)
cat("\n")
}
invisible(x)
}
print2(list1)
[[3]]
[1] "a" "b"
[[5]]
[1] "c" "d" "e"
A very simple solution is to provide names to the elements of your list and then run your function again. There are several ways to name your elements.
l1 <- character(0)
l2 <- c("a","b")
l3 <- c("c","d","e")
list1 <- list(e1=l1, e2=l1, e3=l2, e4=l1, e5=l3)
list1
names(list1)<-paste0("element",seq(length(list1)))
list1[lapply(list1, length) > 0]
I'm struggling to work out how to code this sum in R; I'm guessing we can use a for loop somehow but can't get my head around it.
The equation I am trying to code is:
n-\sum_{k=0}^{n-1}choose(n-1,k)beta_kexp(kLn-k) for n=1,2,..
where:
beta_k is a vector I already have
L is a constant.
I've coded this manually but would like to put it into some kind of for loop.
mu3<-3-choose(2,1)*beta1*exp(-1*lambdaL*(3-1))-choose(2,2)*beta2*exp(-2*lambdaL*(3-2))
mu4<-4-choose(3,1)*beta1*exp(-1*lambdaL*(4-1))-choose(3,2)*beta2*exp(-2*lambdaL*(4-2))-choose(3,3)*beta3*exp(-3*lambdaL*(4-3))
mu5<-5-choose(4,1)*beta1*exp(-1*lambdaL*(5-1))-choose(4,2)*beta2*exp(-2*lambdaL*(5-2))-choose(4,3)*beta3*exp(-3*lambdaL*(5-3))-choose(4,4)*beta4*exp(-4*lambdaL*(5-4))
etc
lambdaL<-0.5
This is my list of beta's
betarec(10,0.5)
[1] 0.0000000 1.0000000 0.7869387 1.0278660 1.5510843 2.3702034 3.4694342
4.7718938
[9] 6.1685468 7.5667952 8.9154479
Thank you!
Consider a nested apply call with mapply iteratively passing n and k args to an embedded sapply to loop through all successive betas from 1 to current k and iteratively sum the results.
Input
lambdaL <- 0.5
beta <- c(0.0000000,1.0000000,0.7869387,1.0278660,1.5510843,2.3702034,
3.4694342,4.7718938,6.1685468,7.5667952,8.9154479)
Current version
mu3<-3-choose(2,1)*beta[1]*exp(-1*lambdaL*(3-1))-choose(2,2)*beta[2]*exp(-2*lambdaL*(3-2))
mu3
# [1] 2.632121
mu4<-4-choose(3,1)*beta[1]*exp(-1*lambdaL*(4-1))-choose(3,2)*beta[2]*exp(-2*lambdaL*(4-2))-choose(3,3)*beta[3]*exp(-3*lambdaL*(4-3))
mu4
# [1] 3.418404
mu5<-5-choose(4,1)*beta[1]*exp(-1*lambdaL*(5-1))-choose(4,2)*beta[2]*exp(-2*lambdaL*(5-2))-choose(4,3)*beta[3]*exp(-3*lambdaL*(5-3))-choose(4,4)*beta[4]*exp(-4*lambdaL*(5-4))
mu5
# [1] 4.405454
Loop version (output equivalent to previous version)
mu_formula <- function(n,k) {
n + sum(sapply(seq(k), function(i)
-choose((n-1),i)*beta[i]*exp(-i*lambdaL*(n-i))))
}
mu_vector <- setNames(mapply(mu_formula, 3:5, 2:4), paste0("mu", 3:5))
mu_vector
# mu3 mu4 mu5
# 2.632121 3.418404 4.405454
mu_list <- setNames(Map(mu_formula, 3:5, 2:4),paste0("mu", 3:5))
mu_list
# $mu3
# [1] 2.632121
# $mu4
# [1] 3.418404
# $mu5
# [1] 4.405454
Generalized Loop (for all betas)
mu_list <- setNames(Map(mu_formula,seq_along(beta)[-1]+1,seq_along(beta)[-1]),
paste0("mu",seq_along(beta)[-1]+1))
mu_list
# $mu3
# [1] 2.632121
# $mu4
# [1] 3.418404
# $mu5
# [1] 4.405454
# $mu6
# [1] 5.507972
# $mu7
# [1] 6.640989
# $mu8
# [1] 7.756735
# $mu9
# [1] 8.840919
# $mu10
# [1] 9.896983
# $mu11
# [1] 10.93315
# $mu12
# [1] 11.95646
I have a long list from a different source, for example:
c(moses, abi, yoyoma)
I want to have it as an object:
a <- c("moses", "abi", "yoyoma")
Is there a way to do that without manually adding the quotes to each name?
Thanks.
Quick way would be
cc <- function(...) sapply(substitute(...()), as.character)
cc(moses, abi, yoyoma)
# [1] "moses" "abi" "yoyoma"
A more flexible solution might be
cc <- function(..., simplify = TRUE, evaluate = FALSE) {
l <- eval(substitute(alist(...)))
ev <- if (evaluate) eval else identity
sapply(l, function(x) if (is.symbol(x)) as.character(x) else ev(x), simplify = simplify)
}
cc(moses, abi, yoyoma)
# [1] "moses" "abi" "yoyoma"
cc(one, two, 'three', four = 4)
# four
# "one" "two" "three" "4"
cc(one, two, 'three something' = rnorm(5), four = 4, simplify = FALSE)
# [[1]]
# [1] "one"
#
# [[2]]
# [1] "two"
#
# $`three something`
# rnorm(5)
#
# $four
# [1] 4
cc(one, two, 'three something' = rnorm(5), four = 4, simplify = FALSE, evaluate = TRUE)
# [[1]]
# [1] "one"
#
# [[2]]
# [1] "two"
#
# $`three something`
# [1] -1.1803114 0.3940908 -0.2296465 -0.2818132 1.3744525
#
# $four
# [1] 4
Just use function as.character()
as.character(a)
[1] "moses" "abi" "yoyoma"