Say, I have a matrix m with 2 rows and 3 columns, together with a function which takes in an argument of numeric type and return a vector. For example,
f <- function(x){
rep(x,4)
}
If I use
t <- apply(m, MARGIN = c(1,2), FUN = f)
I will get a tensor t with dim(t) == c(4,2,3). But what I want is a tensor t with dim(t) == c(2,3,4). How can I do this conveniently? Thank you.
Use aperm, a generalized transposition:
tt <- <- apply(m, MARGIN = c(1,2), FUN = f)
aperm(tt, c(2,3,1))
See here: How to change order of array dimensions
Related
I have a function
eval_ = function(f, i) f(i)
for a list of functions, say
fns = list(function(x) x**2, function(y) -y)
and a vector of integers, say
is = 1:2
I would like to get eval_ evaluated at all combinations of fns and is.
I tried the following:
cross = expand.grid(fns, is)
names(cross) = c("f", "i")
results = sapply(1:nrow(cross), function(i) do.call(eval_, cross[i,]))
This throws an error:
Error in f(i) : could not find function "f"
I think that the underlying problem is, that cross is a data.frame and can not carry functions. Hence, it puts the function into a list and then carries a list (indeed, class(cross[1,][[1]]) yields "list". My ugly hack is to change the third line to:
results = sapply(
1:nrow(cross),
function(i) do.call(eval_, list(f = cross[i,1][[1]], i = cross[i,2]))
)
results
#[1] 1 -1 4 -2
This works, but it defeats the purpose of do.call and is very cumbersome.
Is there a nice solution for this kind of problem?
Note: I would like a solution that generalizes well to cases where the cross product is not only over two, but possibly an arbitrary amount of lists, e.g. functions that map R^n into R.
Edit:
For a more involved example, I think of the following:
fns = list(mean, sum, median)
is1 = c(1, 2, 4, 9), ..., isn = c(3,6,1,2) and my goal is to evaluate the functions on the cartesian product spanned by is1, ..., isn, e.g. on the n-dimensional vector c(4, ..., 6).
You can use mapply() for this:
eval_ <- function(f, i) f(i)
fns <- list(function(x) x**2, function(y) -y)
is <- 1:2
cross <- expand.grid(fns = fns, is = is)
cross$result <- mapply(eval_, cross$fn, cross$is)
print(cross)
#> fns is result
#> 1 function (x) , x^2 1 1
#> 2 function (y) , -y 1 -1
#> 3 function (x) , x^2 2 4
#> 4 function (y) , -y 2 -2
An attempt for my "more involved example" with n = 2.
Let X = expand.grid(c(1, 2, 4, 9), c(3,6,1,2)).
The following pattern generalizes to higher dimensions:
nfns = length(fns)
nn = nrow(X)
res = array(0, c(nfns, nn))
for(i in 1:nfns){
res[i,] = apply(X, MARGIN = 1, FUN = fns[[i]])
}
The shape of the margin of X (i.e. nrow(X)) must correspond to the shape of the slice res[i,] (i.e. nn). The function must map the complement of the margin of X (i.e. slices of the form X[i,]) to a scalar. Note that a function that is not scalar has components that are scalar, i.e. in a non-scalar case, we would loop over all components of the function.
Below, I'm wondering how to use BASE R function quantile() separately across elements in L that are named EFL and ESL?
Note: this is a toy example, L could contain any number of similarly named elements.
foo <- function(X) {
X <- as.matrix(X)
tab <- table(row(X), factor(X, levels = sort(unique(as.vector(X)))))
w <- diag(ncol(tab))
rosum <- rowSums(tab)
obs_oc <- tab * (t(w %*% t(tab)) - 1)
obs_c <- colSums(obs_oc)
max_oc <- tab * (rosum - 1)
max_c <- colSums(max_oc)
SA <- obs_c / max_c
h <- names(SA)
h[is.na(h)] <- "NA"
setNames(SA, h)
}
DAT <- read.csv("https://raw.githubusercontent.com/rnorouzian/m/master/X.csv", row.names = 1)
L <- replicate(50, foo(DAT[sample(1:nrow(DAT), replace = TRUE),]), simplify = FALSE)
# How to use `quantile()` separately across all similarly named elements (e.g., EFL, ESL) in `L[[i]]` i = 1,... 5
# quantile(all EFL elements across `L`)
# quantile(all ESL elements across `L`)
The previous solution I used do.call to rbind each list into a matrix and array and then calculate the quantile over each data.frame row.
sapply(as.data.frame(do.call(rbind, L)), quantile)
However, when there is a missing row, it does not take that into account. To accurately get the rows you need to fill the missing rows. I used data.table's rbindlist (you could also use plyr::rbind.fill) with fill=TRUE to fill the missing values. It requires each to be a data.frame/table/list, so I converted each to a data.frame, but before doing so you need to transpose (t()) the data so that the rows line up to each element. It could be written in a single line, but it's easier read what is happening in multiple lines.
L2 = lapply(L, function(x){as.data.frame(t(x))})
df = data.table::rbindlist(L2, fill=TRUE) # or plyr::rbind.fill(L2)
sapply(df, quantile, na.rm = TRUE)
You can also use purrr::transpose:
Lt <- purrr::tranpose(L)
quantile(unlist(Lt$EFL),.8)
quantile(unlist(Lt$ESL),.8)
I would like to clean up my code a bit and start to use more functions for my everyday computations (where I would normally use for loops). I have an example of a for loop that I would like to make into a function. The problem I am having is in how to step through the constraint vectors without a loop. Here's what I mean;
## represents spectral data
set.seed(11)
df <- data.frame(Sample = 1:100, replicate(1000, sample(0:1000, 100, rep = TRUE)))
## feature ranges by column number
frm <- c(438,563,953,963)
to <- c(548,803,1000,993)
nm <- c("WL890", "WL1080", "WL1400", "WL1375")
WL.ps <- list()
for (i in 1:length(frm)){
## finds the minimum value within the range constraints and returns the corresponding column name
WL <- colnames(df[frm[i]:to[i]])[apply(df[frm[i]:to[i]],1,which.min)]
WL.ps[[i]] <- WL
}
new.df <- data.frame(WL.ps)
colnames(new.df) <- nm
The part where I iterate through the 'frm' and 'to' vector values is what I'm having trouble with. How does one go from frm[1] to frm[2].. so-on in a function (apply or otherwise)?
Any advice would be greatly appreciated.
Thank you.
You could write a function which returns column name of minimum value in each row for a particular range of columns. I have used max.col instead of apply(df, 1, which.min) to get minimum value in a row since max.col would be efficient compared to apply.
apply_fun <- function(data, x, y) {
cols <- x:y
names(data[cols])[max.col(-data[cols])]
}
Apply this function using Map :
WL.ps <- Map(apply_fun, frm, to, MoreArgs = list(data = df))
I recently asked a similar question (link), but the example that I gave there was a little too simple, and the answers did not work for my actual use case. Again, I am using R and want to apply a function to a vector. The function returns a list, and I want the results to be formatted as a list of vectors, where the names of the output list correspond to the names in the list returned by the function, and the value for each list element is the vector of values over the elements of the input vector. The following example shows a basic set up, together with two ways of calculating the desired output (sum.of.differences and sum.of.differences.2). The first method (sum.of.differences) seems to be the easiest way to understand what the desired output; the second method (sum.of.differences.2) avoids two major problems with the first method -- computing the function twice for each element of the input vector, and being forced to give the names of the list elements explicitly. However, the second method also seems relatively complicated for such a fundamental task. Is there a more idiomatic way to get the desired results in R?
x <- rnorm(n = 10)
a <- seq(from = -1, to = +1, by = 0.01)
sum.of.differences.fun <- function(a) {
d <- x - a
list(
sum.of.absolute.differences = sum(abs(d)),
sum.of.squared.differences = sum(d^2)
)
}
sum.of.differences <- list(
sum.of.absolute.differences = sapply(
X = a,
FUN = function(a) sum.of.differences.fun(a)$sum.of.absolute.differences
),
sum.of.squared.differences = sapply(
X = a,
FUN = function(a) sum.of.differences.fun(a)$sum.of.squared.differences
)
)
sum.of.differences.2 <- (function(lst) {
processed.lst <- lapply(
X = names(lst[[1]]),
FUN = function(name) {
sapply(
X = lst,
FUN = function(x) x[[name]]
)
}
)
names(processed.lst) <- names(lst[[1]])
return(processed.lst)
})(lapply(X = a, FUN = sum.of.differences.fun))
What language did you learn before R? It seems as though you might be using design patterns from a different functional language (I'd guess Lisp). The following code is much simpler and the output is identical (aside from names) as far as I can tell.
x <- rnorm(n = 10)
a <- seq(from = -1, to = +1, by = 0.01)
funs <- c(
sumabsdiff = function(a) sum(abs(x - a)),
sumsquarediff = function(a) sum((x - a) ^ 2)
)
sumdiff <- lapply(
funs,
function(fun) sapply(a, fun)
)
I would like to use a function from the apply family (in R) to apply a function of two arguments to two matrices. I assume this is possible. Am I correct? Otherwise, it would seem that I have to put the two matrices into one, and redefine my function in terms of the new matrix.
Here's an example of what I'd like to do:
a <- matrix(1:6,nrow = 3,ncol = 2)
b <- matrix(7:12,nrow = 3,ncol = 2)
foo <- function(vec1,vec2){
d <- sample(vec1,1)
f <- sample(vec2,1)
result <- c(d,f)
return(result)
}
I would like to apply foo to a and b.
(Strictly answering the question, not pointing you to a better approach for you particular use here....)
mapply is the function from the *apply family of functions for applying a function while looping through multiple arguments.
So what you want to do here is turn each of your matrices into a list of vectors that hold its rows or columns (you did not specify). There are many ways to do that, I like to use the following function:
split.array.along <- function(X, MARGIN) {
require(abind)
lapply(seq_len(dim(X)[MARGIN]), asub, x = X, dims = MARGIN)
}
Then all you have to do is run:
mapply(foo, split.array.along(a, 1),
split.array.along(b, 1))
Like sapply, mapply tries to put your output into an array if possible. If instead you prefer the output to be a list, add SIMPLIFY = FALSE to the mapply call, or equivalently, use the Map function:
Map(foo, split.array.along(a, 1),
split.array.along(b, 1))
You could adjust foo to take one argument (a single matrix), and use apply in the function body.
Then you can use lapply on foo to sample from each column of each matrix.
> a <- matrix(1:6,nrow = 3,ncol = 2)
> b <- matrix(7:12,nrow = 3,ncol = 2)
> foo <- function(x){
apply(x, 2, function(z) sample(z, 1))
}
> lapply(list(a, b), foo)
## [[1]]
## [1] 1 6
## [[2]]
## [1] 8 12