enter image description hereI want to create a 10 by 8 matrix from two matrices again with dimensions 10 by 8 by using for loops.
I have matrices a and e and I want to save the results of below code to a matrix. But when I run the code, the matrix chi is an empty matrix except with the last row of the last column. I am kind of newby to R, so any help is appreciated. Thanks.
chi <- matrix(nrow = 10, ncol = 8, byrow = T)
i <- nrow(a)
j <- ncol(a)
k <- nrow(e)
l <- ncol(e)
m <- nrow(chi)
n <- ncol(chi)
for (i in 1:nrow(a)) {
for (j in 1:ncol(a)) {
for (k in 1:nrow(e)) {
for (l in 1:ncol(e))
chi[m, n] <- ((a[i, j] - e[k, l]) ^ 2 / (e[k, l] * (1 - e[k, l])))
}
}
}
Reconsider using any nested for loops as you can simply run matrix algebra since all inputs, a and e, are equal length objects:
chi <- ((a - e) ^ 2 / (e * (1 - e)))
With your nested for loop approach, your attempted matrix cell assignment is overwritten with each inner loop pass and only the very last instance is saved.
To demonstrate, consider the following random matrices (seeded for reproducibility):
set.seed(1162018)
a <- matrix(runif(800), nrow = 10, ncol = 8)
e <- matrix(runif(800), nrow = 10, ncol = 8)
With following output:
chi2 <- ((a - e) ^ 2 / (e * (1 - e)))
chi2
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
# [1,] 1.090516287 5.314965506 0.30221649 4.3078030566 0.08185310 0.33991625 7.475638e-01 7.136321e+01
# [2,] 0.339472596 0.037831564 1.00181544 0.0075194551 0.27228312 20.74823838 2.308509e-04 1.264312e-04
# [3,] 0.001493967 0.009102797 17.76508355 0.0318190760 0.08133848 0.90538852 1.425952e-01 3.600838e-02
# [4,] 25.941857200 2.182678801 0.52170472 0.5485710933 0.57015681 0.09332506 2.631002e-01 4.897862e-01
# [5,] 4.341993499 0.075724451 0.03409925 0.0058830640 0.15290151 0.83227284 2.982630e+02 2.615268e-01
# [6,] 0.327661207 0.058150213 0.17328257 0.3161902785 4.48620227 0.14685330 2.996204e+00 1.888419e+01
# [7,] 0.456397833 1.446942556 0.51597191 0.2051742161 0.20440765 0.58169351 5.345522e+00 1.320896e-03
# [8,] 12.844776005 0.753941152 0.36425134 0.0003481929 0.34011118 2.38649404 1.082046e-01 1.817180e-01
# [9,] 0.042779101 0.119540004 1.41313002 0.1262586599 0.36583013 1.76476721 1.353301e+00 1.670491e-01
# [10,] 4.729182008 5.257386394 0.62181731 0.0000251250 0.32324943 0.08491841 6.627723e+00 2.127289e+00
Notice the very first, second, all the way to last elements of chi2 is consistent to your original formula as seen with using only single values. The all.equal() demonstrates no value difference between scientific notation or not.
((a[1, 1] - e[1, 1]) ^ 2 / (e[1, 1] * (1 - e[1, 1])))
# [1] 1.090516
((a[1, 2] - e[1, 2]) ^ 2 / (e[1, 2] * (1 - e[1, 2])))
# [1] 1.090516
# ...
((a[10, 8] - e[10, 8]) ^ 2 / (e[10, 8] * (1 - e[10, 8])))
# [1] 2.127289
all.equal(2.127289e+00, 2.127289)
# [1] TRUE
Incorrect For Loop Processing
However, adjusting your for loop to use chi[i,j] assignment which does yield values but on closer look does not accurately align to your original formula:
chi <- matrix(nrow = 10, ncol = 8, byrow = T)
i <- nrow(a)
j <- ncol(a)
k <- nrow(e)
l <- ncol(e)
m <- nrow(chi)
n <- ncol(chi)
for (i in 1:nrow(a)) {
for (j in 1:ncol(a)) {
for (k in 1:nrow(e)) {
for (l in 1:ncol(e))
chi[i,j] <- ((a[i, j] - e[k, l]) ^ 2 / (e[k, l] * (1 - e[k, l])))
}
}
}
chi
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
# [1,] 3.409875713 1.91797098 0.983457185 0.72023148 0.96731753 0.047236836 2.20811240 0.6073649
# [2,] 0.011756997 2.96049899 3.614632753 1.30476270 2.49116488 0.074379894 1.01941080 0.3796867
# [3,] 2.061628776 0.03227113 0.691592758 2.58226782 0.17603261 4.377353084 1.07957101 0.9584883
# [4,] 5.477395731 0.07409188 5.287871705 1.86472765 2.02597697 0.078780553 6.20319269 2.6099405
# [5,] 4.342937737 3.57579681 1.016981597 2.83351392 1.11431922 0.083484410 0.08412765 0.5525810
# [6,] 0.008175703 2.63310577 0.005053893 3.69703754 0.05993078 0.004768071 5.92075341 4.2435415
# [7,] 1.051921956 0.31217144 5.624012725 0.90161687 0.43301151 0.156739757 0.72284317 1.2243496
# [8,] 4.941310521 4.85504735 0.021515999 3.66512027 0.08358373 3.603038468 0.38618455 6.1389345
# [9,] 0.559136535 5.08204325 2.999036687 2.72726724 5.99168376 0.319859158 0.59398961 3.6221932
# [10,] 0.001668949 2.97353267 4.703763876 0.04979429 5.31715581 0.053267595 2.09966809 2.1272893
Here, the for loop returns only the very last instance since chi[i,j] is overwritten multiple times during loop. As a result, ALL elements of chi matrix uses the last element of e:
((a[1, 1] - e[10, 8]) ^ 2 / (e[10, 8] * (1 - e[10, 8])))
# [1] 3.409876
((a[1, 2] - e[10, 8]) ^ 2 / (e[10, 8] * (1 - e[10, 8])))
# [1] 1.917971
# ...
((a[10, 8] - e[10, 8]) ^ 2 / (e[10, 8] * (1 - e[10, 8])))
# [1] 2.127289
Conversely, with using chi[k,l] for assignment in loop.
for (i in 1:nrow(a)) {
for (j in 1:ncol(a)) {
for (k in 1:nrow(e)) {
for (l in 1:ncol(e))
chi[k,l] <- ((a[i, j] - e[k, l]) ^ 2 / (e[k, l] * (1 - e[k, l])))
}
}
}
chi
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
# [1,] 5.649285e-01 5.813300e+00 0.035949545 10.14845208 0.002533313 0.405749651 0.711058301 2.592142e+01
# [2,] 7.481556e+00 4.531135e-05 0.455696004 0.09284383 0.192074706 4.178867177 0.105489574 3.541626e-01
# [3,] 4.953702e-04 6.703029e+00 41.109139456 0.08957573 1.511080005 0.254656165 0.004840752 2.805246e-01
# [4,] 1.152237e+01 2.556255e-02 0.018652264 0.65975403 0.515919955 0.280219679 0.124379946 7.777978e-01
# [5,] 2.126765e+00 5.356927e-01 0.251885418 0.06540162 0.008580900 0.003271672 41.259025738 2.963719e-06
# [6,] 1.401345e-01 1.603721e-02 0.334385097 0.05865054 0.622973490 0.608273911 0.888928067 1.046868e+01
# [7,] 1.018507e-01 1.756129e-01 0.005676374 0.72309875 0.011666290 0.314863595 12.420604213 7.778975e-02
# [8,] 6.082752e+00 1.250805e-01 0.287099891 0.17209992 0.050136187 1.339028574 1.059674334 2.627769e-01
# [9,] 8.005223e-02 9.260464e-02 2.823995704 0.04935770 0.020361815 0.258144647 0.275514317 9.392584e-03
# [10,] 4.952038e-01 3.870331e+00 0.089420009 1.05729955 0.002429084 0.349966871 6.702385325 2.127289e+00
As a result, ALL matrix elements uses the last values of a:
((a[10, 8] - e[1, 1]) ^ 2 / (e[1, 1] * (1 - e[1, 1])))
# [1] 0.5649285
all.equal(5.649285e-01, 0.5649285)
# [1] TRUE
((a[10, 8] - e[1, 2]) ^ 2 / (e[1, 2] * (1 - e[1, 2])))
# [1] 5.8133
all.equal(5.813300e+00, 5.8133)
# [1] TRUE
# ...
((a[10, 8] - e[10, 8]) ^ 2 / (e[10, 8] * (1 - e[10, 8])))
# [1] 2.127289
Related
this my first question and I hope to collaborate in the community.
I am in a project in which I must fill the NA values with the average of their neighbors from a matrix of ncol = 10 and nrow = 10. I have developed the following code however it is very computationally inefficient:
Code
get_neighbor <- function(matrix, x=1,y=1){
z <- complex(real = rep(1:nrow(matrix), ncol(matrix)),
imaginary = rep(1:ncol(matrix), each = nrow(matrix)))
lookup <- lapply(seq_along(z), function(x){
# calcular la distantancia
dist <- which(abs(z - z[x]) < 2)
# sacar el elemento x del vecindario
dist[which(dist != x)]
})
index <- (y-1)*(nrow(matrix))+x
matrix[lookup[[index]]]
}
nn_mean <- function(a){
if(sum(is.na(a))!=ncol(a)*nrow(a)){
C <- permutations(2, 2, c(1,dim(a)[1]), repeats.allowed = T)
Borders <- data.frame(matrix(data = 0, ncol = 2, nrow = nrow(a)*2 + ncol(a)*2 - 4))
Borders[1:nrow(a), 1] <- 1:nrow(a); Borders[1:nrow(a), 2] <- 1
for(i in 2:(ncol(a)-1)){
Borders[i + nrow(a) - 1, 2] <- i; Borders[i + 2*(nrow(a) - 1) - 1, 2] <- i
Borders[i + nrow(a) - 1, 1] <- 1; Borders[i + 2*(nrow(a) - 1) - 1, 1] <- nrow(a)
}
Borders[1:ncol(a) + 3*(nrow(a))-4, 2] <- ncol(a)
Borders[1:ncol(a) + 3*(nrow(a))-4, 1] <- 1:ncol(a)
id <- which(is.na(a), arr.ind = T)
id <- data.frame(cbind(id, rep(0, nrow(id))))
while(nrow(id)!=0){
for(i in 1:nrow(id)){
id[i,3] <- sum(is.na(get_neighbor(a, id[i, 1], id[i, 2])))
}
max_na <- max(id[, 3])
for(i in 1:(nrow(a)*2 + ncol(a)*2 - 4)){
if(is.na(a[Borders[i, 1], Borders[i, 2]]) & sum(is.na(get_neighbor(a, Borders[i, 1], Borders[i, 2]))) == 5){
index <- which(id[,1] == Borders[i, 1] & id[,2] == Borders[i, 2])
id[index, 3] <- max_na +1
}
}
for(i in 1:4){
if(is.na(a[C[i,1], C[i,2]]) & sum(is.na(get_neighbor(a, C[i, 1], C[i, 2]))) == 3){
index <- which(id[,1] == C[i, 1] & id[,2] == C[i, 2])
id[index, 3] <- max_na +1
}
}
id <- id[order(id[,3]),]
index <- which(id[,3]== min(id[,3]))
for(i in 1:length(index)){
a[id[i, 1], id[i, 2]] <- mean(get_neighbor(a, id[i, 1], id[i, 2]), na.rm = T)
if(is.nan(a[id[i, 1], id[i, 2]])){a[id[i, 1], id[i, 2]] <- NA}
}
#print(a)
id <- which(is.na(a), arr.ind = T)
id <- data.frame(cbind(id, rep(0, nrow(id))))
}
}
return(a)
}
example
a <- matrix(data = runif(100, 0, 10), ncol = 10, nrow = 10)
a[a<2] <- NA
a
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 2.313512 NA 5.311104 2.832978 9.917106 2.734799 7.309386 NA 4.794476 6.479147
[2,] 8.855676 7.555101 8.369477 6.346744 7.727896 NA 9.019421 5.061894 9.116066 6.732293
[3,] 2.948539 7.440258 6.918414 2.155361 3.511407 5.601253 NA 6.561557 9.543535 4.082592
[4,] 8.455382 9.169974 NA 4.978224 6.202393 NA 9.435753 9.411371 NA 2.128417
[5,] 7.744456 3.333072 6.975128 5.876849 4.044768 2.948399 5.067653 NA 6.039412 7.350782
[6,] 8.793417 9.683755 8.053603 7.406450 6.348171 3.122946 9.378282 5.808363 7.923061 6.415419
[7,] 4.759612 3.431247 4.123641 6.899569 4.464683 6.588431 5.985248 7.962148 6.668238 4.503556
[8,] 5.992242 NA 7.099657 6.446650 NA 8.448873 5.884961 NA 2.209453 8.103988
[9,] 6.383036 NA NA 5.499157 6.972433 3.129470 3.284383 9.150565 8.484186 4.672878
[10,] NA NA 4.258936 NA 9.015525 NA NA NA NA 6.639832
nn_mean(a)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 2.313512 6.480974 5.311104 2.832978 9.917106 2.734799 7.309386 7.060248 4.794476 6.479147
[2,] 8.855676 7.555101 8.369477 6.346744 7.727896 6.545895 9.019421 5.061894 9.116066 6.732293
[3,] 2.948539 7.440258 6.918414 2.155361 3.511407 5.601253 7.111993 6.561557 9.543535 4.082592
[4,] 8.455382 9.169974 5.855910 4.978224 6.202393 5.258804 9.435753 9.411371 6.587278 2.128417
[5,] 7.744456 3.333072 6.975128 5.876849 4.044768 2.948399 5.067653 7.580556 6.039412 7.350782
[6,] 8.793417 9.683755 8.053603 7.406450 6.348171 3.122946 9.378282 5.808363 7.923061 6.415419
[7,] 4.759612 3.431247 4.123641 6.899569 4.464683 6.588431 5.985248 7.962148 6.668238 4.503556
[8,] 5.992242 5.298239 7.099657 6.446650 6.056158 8.448873 5.884961 6.203648 2.209453 8.103988
[9,] 6.383036 5.902524 5.834195 5.499157 6.972433 3.129470 3.284383 9.150565 8.484186 4.672878
[10,] 6.383036 5.731883 4.258936 6.436513 9.015525 5.600453 5.291218 6.689444 7.236865 6.639832
some idea or a function that is efficient?
This can be written in a even short and fast way in R:
nn_impute <- function(dat){
idx <- which(is.na(dat), TRUE)
impute <- function(x){
y <- expand.grid(x[1] + c(-1,0,1), x[2] + c(-1,0,1))
z <- !(y == 0 | y > nrow(dat) | y> ncol(dat))
mean(dat[as.matrix(y[rowSums(z) == 2,])], na.rm = TRUE)
}
dat[idx] <- apply(idx, 1, impute)
dat
}
nn_impute(a) ## Returns the filled in values
This code is around 38X faster than the provided code
I kept your code above, apart from nn_mean function, I defined an nn_mean2 function.
It works about 20x times faster than yours, but gives different results. Since I don't know why you wrote your function the way you did, i.e. your requirements, I can't tell why my approach is not suitable. but it is way faster. It naively uses your get_neighbour definition, averages the found neighbour values and substitutes them into the holes. You must be needing to do something else or our results would have matched I would have thought.
Here it is for consideration
nn_mean2 <- function(a){
res2 <- a
# get the missings
list_of_missing <- which(is.na(a))
list_of_missing_df <- data.frame(which(is.na(a),arr.ind = TRUE))
list_of_missing_df$missing_fills <- purrr::map_dbl(seq_len(nrow(list_of_missing_df)),
~{
mean(get_neighbor(a,
x=list_of_missing_df$row[.x],
y=list_of_missing_df$col[.x]),
na.rm=TRUE)
})
res2[list_of_missing] <- list_of_missing_df$missing_fills
res2
}
res2 <- nn_mean2(a)
microbenchmark::microbenchmark(n1 = nn_mean(a),
n2=nn_mean2(a))
# A tibble: 2 x 13
expression min median `itr/sec` mem_al~1 gc/se~2 n_itr n_gc total~3 result memory
<bch:expr> <bch:tm> <bch:tm> <dbl> <bch:by> <dbl> <int> <dbl> <bch:t> <list> <list>
1 n1 380ms 425ms 2.35 107.34MB 4.71 2 4 850ms <NULL> <Rprofmem>
2 n2 17ms 20.1ms 39.9 6.91MB 5.99 20 3 501ms <NULL> <Rprofmem>
# see the difference in values though
res1 - res2
Suppose that we have the following beale function :
custom_fun <- function(x, y) { # Create custom function in R
z <- (1.5 - x + x*y)^2+(2.25 - x + x*y^2)^2+(2.625 - x + x*y^3)^2
return(z)
}
and we have this list of positions in a matrix m:
[1] "list of respective positions"
[,1] [,2] [,3]
x: 2.482116 -0.7845145 -3.370810
y: -1.031615 1.2035550 1.203555
How can i compute custom_fun(x,y) in each column with an elegant way ?
I'm wanting to store those values in the last row of the matrix m.
Thank you for help!
You can use apply:
custom_fun <- function(x, y) { # Create custom function in R
z <- (1.5 - x + x*y)^2+(2.25 - x + x*y^2)^2+(2.625 - x + x*y^3)^2
return(z)
}
my_mat <- matrix(rnorm(10), nrow = 2, dimnames = list(c("x", "y"), NULL))
my_mat
#> [,1] [,2] [,3] [,4] [,5]
#> x 0.5631441 0.9349816 -1.0088734 -1.364570 -1.32633896
#> y 0.4978350 -1.3265677 0.4206566 -2.532265 -0.01913554
rbind(my_mat, `fun(x, y)` = apply(my_mat, 2, function(x) custom_fun(x[1], x[2])))
#> [,1] [,2] [,3] [,4] [,5]
#> x 0.5631441 0.9349816 -1.0088734 -1.364570 -1.32633896
#> y 0.4978350 -1.3265677 0.4206566 -2.532265 -0.01913554
#> fun(x, y) 9.3600306 9.4626106 26.4985306 749.993103 36.53218207
Created on 2020-06-21 by the reprex package (v0.3.0)
In R I have two matrices X and Z and I would like a
matrix W such that the row (i) of W contains row (i) of X interacted with row (i) of Z.
W(i) = X(i1)Z(i1) ... X(iJ)Z(i1) ... X(i1)Z(iK) ... X(iJ)Z(iK)
Here is an example in small scale doing what I want:
set.seed(1)
n <- 3
K <- 2
J <- 3
X <- matrix(rnorm(J*n),ncol=J)
Z <- matrix(rnorm(K*n),ncol=K)
W <- matrix(NA,nrow=n,ncol=K*J)
for (i in 1:n)
{
for (k in 1:K)
{
for (j in 1:J)
{
W[i,j + J*(k-1)] <- X[i,j] * Z[i,k]
}
}
}
Is there a clever way to do that?
I ended up doing
X[,sort(rep(1:J,K))] * Z[,rep(1:K,J)]
For this example, you can do
cbind(X * Z[, 1], X * Z[, 2])
# [,1] [,2] [,3] [,4] [,5] [,6]
#[1,] 0.1913117 -0.4871802 -0.1488552 0.3891785 -0.9910532 -0.3028107
#[2,] 0.2776285 0.4981436 1.1161854 -0.4067148 -0.7297608 -1.6351676
#[3,] -0.3257642 -0.3198541 0.2244645 -0.9400245 -0.9229703 0.6477142
Or more generally we can use apply for many more columns.
W[] <- apply(Z, 2, function(x) X * x)
which gives the same output as W which we get after running your loop.
W
# [,1] [,2] [,3] [,4] [,5] [,6]
#[1,] 0.1913117 -0.4871802 -0.1488552 0.3891785 -0.9910532 -0.3028107
#[2,] 0.2776285 0.4981436 1.1161854 -0.4067148 -0.7297608 -1.6351676
#[3,] -0.3257642 -0.3198541 0.2244645 -0.9400245 -0.9229703 0.6477142
I would like to generate a sequence of stochastic equations for 100 different seed using the following expression:
set.seed(123)
N <- 100
T <- 1
x <- 10
theta <- c (0 , 5 , 3.5)
Dt <- 1 /N
Y <- numeric (N +1)
Y [1] <- x
Z <- rnorm (N)
for (i in 1: N)
{Y[ i +1] <- Y[ i] + ( theta [1] - theta [2] * Y[ i ]) * Dt + theta [3] * sqrt ( Dt ) *Z [i ]
Y <- ts (Y , start =0 , deltat =1 /N )
Finally, I want to save the 100 "Y" time series into a matrix.
How can I create a loop that save every value for "Y" time series?
If you use replicate as a wrapper around that code as I suggested you will need to put in an additional reference to the Y variable outside the for-loop. Replicate naturally returns a matrix. Using 10 rather than 100 for testing:
set.seed(123)
N=10
> rep.mtx <- replicate( 10, {
+ T <- 1
+ x <- 10
+ theta <- c (0 , 5 , 3.5)
+ Dt <- 1 /N
+ Y <- numeric (N +1)
+ Y [1] <- x
+ Z <- rnorm (N)
+ for (i in 1: N)
+ {Y[ i +1] <- Y[ i] + ( theta [1] - theta [2] * Y[ i ]) * Dt + theta [3] * sqrt ( Dt ) *Z [i ]
+ Y <- ts(Y , start =0 , deltat =1 /N ) } ; Y} )
> rep.mtx
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 10.0000000 10.000000000 10.00000000 10.000000000 10.00000000 10.0000000 10.0000000 10.00000000 10.0000000 10.0000000
[2,] 4.3796671 6.354810283 3.81813573 5.472009398 4.23110027 5.2803722 5.4201839 4.45652809 5.0063798 6.0996073
[3,] 1.9350738 3.575646071 1.66781385 2.409420413 1.88542788 2.6085906 2.1541218 -0.32751756 2.9296172 3.6567678
[4,] 2.6927109 2.231395747 -0.30167191 2.195432765 -0.45782317 1.2568464 0.7082679 0.94938979 1.0545631 2.0926115
[5,] 1.4243939 1.238201192 -0.95757071 2.069632051 2.17168276 2.1431884 -0.7732224 -0.31024651 1.2404757 0.3513411
[6,] 0.8552923 0.003897195 -1.17057706 1.944139651 2.42281031 0.8217115 -1.5728667 -0.91660925 0.3762039 1.6816368
[7,] 2.3258752 1.979699020 -2.45211593 1.734254917 -0.03164826 2.0892811 -0.4504887 0.67679487 0.5553173 0.1764528
[8,] 1.6730784 1.540869016 -0.29879763 1.480201956 -0.46173593 -0.6695147 0.2708330 0.02321148 1.4916370 2.5091604
[9,] -0.5636270 -1.406211817 0.02035412 0.671577271 -0.74736079 0.3122915 0.1940814 -1.33948118 1.2274761 2.9508693
[10,] -1.0420203 0.073152826 -1.24950969 -0.002849978 0.48958280 0.2932273 1.1178037 -0.46907441 0.2529979 1.2145622
[11,] -1.0142676 -0.486707784 0.76296397 -0.422529220 0.15251875 0.3856172 2.8279298 -0.38826177 1.3979960 -0.5287587
I have two matrices, call them A (n x 2) and B (q x 2). I'd like to get an n x q x 2 array C, such that C[1,5,] represents the difference between the first row of A and the fifth row of B, taking the subtraction of the first element in the first row of A with the first element in the fifth row of B and the second element similarly subtracted.
I'm trying to perform this function via the outer function, but it also gives me the "non-diagonal" subtractions; i.e. it will also subtract A[1,1] - B[5,2] and A[1,2] - B[5,1] which I am not interested in. Does anyone have a fast, easy way to do this?
Current code
>diffs <- outer(A,B,FUN ='-')
>diffs[1,,5,]
[,1] [,2]
[1,] **-0.3808701** 0.7591052
[2,] 0.2629293 **1.4029046**
I've added the stars to indicate what I actually want.
Thanks for any help in advance
(EDIT)
Here's a simpler case for illustrative purposes
> A <- matrix(1:10, nrow = 5, ncol = 2)
> B <- matrix(4:9, nrow = 3, ncol = 2)
> A
[,1] [,2]
[1,] 1 6
[2,] 2 7
[3,] 3 8
[4,] 4 9
[5,] 5 10
> B
[,1] [,2]
[1,] 4 7
[2,] 5 8
[3,] 6 9
>diffs <- outer(A,B,FUN ='-')
>diffs[1,,3,] == (A[1,] - B[3,])
[,1] [,2]
[1,] TRUE FALSE
[2,] FALSE TRUE
>diffs[1,,3,]
[,1] [,2]
[1,] -5 -8
[2,] 0 -3
Before worrying about the shape of the output I think we should make sure we're getting the correct values.
A <- matrix(1:10, nrow=5, ncol=2)
B <- matrix(4:9, nrow=3, ncol=2)
# long-winded method
dia_long <- c(
c(A[1,] - B[1,]),
c(A[1,] - B[2,]),
c(A[1,] - B[3,]),
c(A[2,] - B[1,]),
c(A[2,] - B[2,]),
c(A[2,] - B[3,]),
c(A[3,] - B[1,]),
c(A[3,] - B[2,]),
c(A[3,] - B[3,]),
c(A[4,] - B[1,]),
c(A[4,] - B[2,]),
c(A[4,] - B[3,]),
c(A[5,] - B[1,]),
c(A[5,] - B[2,]),
c(A[5,] - B[3,]))
# loop method
comb <- expand.grid(1:nrow(A), 1:nrow(B))
dia_loop <- list()
for (i in 1:nrow(comb)) {
dia_loop[[i]] <- A[comb[i, 1], ] - B[comb[i, 2], ]
}
dia_loop <- unlist(dia_loop)
# outer/apply method
dia_outer <- apply(outer(A, B, FUN='-'), c(3, 1), diag)
# they all return the same values
all.identical <- function(l) {
all(sapply(2:length(l), FUN=function(x) identical(l[1], l[x])))
}
all.identical(lapply(list(dia_long, dia_loop, dia_outer), sort))
# TRUE
table(dia_long)
# dia_long
# -5 -4 -3 -2 -1 0 1 2 3
# 1 2 4 5 6 5 4 2 1
Are these the values you are looking for?
My solution: use nested lapply and sapply functions to extract the diagonals. I then needed to do some post-processing (not related to this specific problem), before I then turned it into an array. Should be noted that this is a q x 2 x n array, which turned out to be better for my purposes - this could be permuted with aperm from here though to solve the original question.
A <- matrix(1:10, nrow = 5, ncol = 2)
B <- matrix(4:9, nrow = 3, ncol = 2)
diffs <- outer(A,B, FUN = '-')
diffs <- lapply(X = 1:nrow(A),FUN = function(y){
t(sapply(1:ncol(B), FUN = function(x) diag(diffs[y,,x,])))})
diffs <- array(unlist(lapply(diffs, FUN = t)), dim = c(nrow(B),2,nrow(A)))