I'm implementing the Jacobi iterative method to solve linear systems Ax = b
I have the following code:
data.a <- c(3, -1, 1, 3, 6, 2, 3, 3, 7)
A <- matrix(data.a, nrow = 3, ncol = 3, byrow = TRUE)
b <- c(1, 0, 4)
Xo <- c(0,0,0)
X <- c(0, 0, 0)
#A is the matrix:
#3 -1 1
#3 6 2
#3 3 7
#b is the column vector:
#[1, 0, 4]
#and Xo is the previous X computed
for(i in 1:nrow(A)){
sum = 0
for(j in 1:ncol(A)){
if(j != i){
sum = sum + A[i,j]*Xo[j]
}
}
X[i] = -(1/A[i,i])*(sum - b[i])
}
The thing is, because I only multiply and sum up the values A[i][j]*Xo[j] for j != i
I am using nested for-loops and use the auxiliar variable sum.
My question is: Could I use something like
A[i,] %*% Xo
to compute the values of the sum without the nested-for loops?
edit: I found a solution
X[i] = -(1/A[i,i])*(A[i,]%*%Xo - A[i,i]*Xo[i] - b[i])
# I subtracted the term A[i,i]*Xo[i] from the product A*Xo
You can even remove the first loop by making a matrix R, whose elements are equal to A except that diagonal elements are zeros.
update <- function(x, A, b) {
D <- diag(diag(A))
R <- A - D
sums <- R %*% x
x <- (b - sums) / diag(D)
x
}
data.a <- c(3, -1, 1, 3, 6, 2, 3, 3, 7)
A <- matrix(data.a, nrow = 3, ncol = 3, byrow = TRUE)
b <- c(1, 0, 4)
x <- c(0, 0, 0)
for (i in 1:100) x <- update(x, A, b)
x
# verify the answer is correct
solve(A, b)
Related
I am writing a function for minimization using optim. The task is to solve some similar optimization tasks in loop.
# K and k are always the same (they are read from a file)
K <- matrix(data = c(1, 2, 1, 2, 1,
2, 16, 2, 1, 2,
1, 2, 8, 2, 1,
2, 1, 2, 16, 2,
1, 2, 1, 2, 32),
nrow = 5, ncol = 5, byrow = TRUE)
k <- c(-2, 4, 12, 0, 2)
# j will be changed
minimize <- function(beta){ #function to minimize (for beta)
value <- (1/2)*(t(beta)%*%K%*%beta) - t(k)%*%beta + j*abs(sum(beta)-n_s)
return(value)
}
myfunc <- function(K, k, m) #K is matrix, k is vector
{
j_values <- 10^seq(-5, 5, length = m)
for (i in 1:m)
{
current_j_value <- j_values[i]
#I want to set j in minimize function as current_j_value (and also my k and K from file)
# and then minimize it
myans <- optim(c(0, 0, 0, 0, 0), minimize) # using minimize(K, k, j) doesn't work
print(myans$par)
}
}
myfunc(K, k, 5)
My question is how to give arguments to my minimize function (to create it dynamically?) and then use it in optim.
If youw ant to include extra parameters in you minimize function you can add these in the optim call as from the documentation see ?optim the dots (...)
... Further arguments to be passed to fn and gr.
So including j, k, K and n_s in minimize
minimize <- function(beta, j, k, K, n_s){ #function to minimize (for beta)
value <- (1/2)*(t(beta)%*%K%*%beta) - t(k)%*%beta + j*abs(sum(beta)-n_s)
return(value)
}
and then adding these to the optim call (I have set n_s = 0) like,
myfunc <- function(K, k, m) #K is matrix, k is vector
{
j_values <- 10^seq(-5, 5, length = m)
for (i in 1:m)
{
current_j_value <- j_values[i]
#I want to set j in minimize function as current_j_value (and also my k and K from file)
# and then minimize it
myans <- optim(c(0, 0, 0, 0, 0), minimize, j = current_j_value, k = k, K = K, n_s = 0) # using minimize(K, k, j) doesn't work
print(myans$par)
}
}
Running this then,
> myfunc(K, k, 5)
[1] -6.7956860 0.7999990 1.9999999 0.5333326 0.1290324
[1] -6.7911329 0.7996483 2.0000002 0.5329818 0.1290322
[1] -5.3512894 0.6889257 1.9999436 0.4222287 0.1290095
[1] -2.80295781 0.61426579 1.95348934 0.24715200 -0.01194974
[1] -1.2999142 0.4313710 1.3088572 -0.5764644 0.1361504
All the code together
# K and k are always the same (they are read from a file)
K <- matrix(data = c(1, 2, 1, 2, 1,
2, 16, 2, 1, 2,
1, 2, 8, 2, 1,
2, 1, 2, 16, 2,
1, 2, 1, 2, 32),
nrow = 5, ncol = 5, byrow = TRUE)
k <- c(-2, 4, 12, 0, 2)
# j will be changed
minimize <- function(beta, j, k, K, n_s){ #function to minimize (for beta)
value <- (1/2)*(t(beta)%*%K%*%beta) - t(k)%*%beta + j*abs(sum(beta)-n_s)
return(value)
}
myfunc <- function(K, k, m) #K is matrix, k is vector
{
j_values <- 10^seq(-5, 5, length = m)
for (i in 1:m)
{
current_j_value <- j_values[i]
#I want to set j in minimize function as current_j_value (and also my k and K from file)
# and then minimize it
myans <- optim(c(0, 0, 0, 0, 0), minimize, j = current_j_value, k = k, K = K, n_s = 0) # using minimize(K, k, j) doesn't work
print(myans$par)
}
}
myfunc(K, k, 5)
I have my attempt to find the number of 1s connected by 6 or more other 1s below...
6_or_more <- function(x) {
diff <- diff(x) == 0
(c(0,diff) + c(diff,0)) * x
}
mat <-matrix(rbinom(10 * 5, 1, 0.5), ncol = 20, nrow = 20)
with(rle(as.vector(mat)), sum(lengths[values == 1] >= 5))
6_or_more_rows_columns <- lapply(files, function(y) sum(t(apply(y, 1, 6_or_more)) + apply(y, 2, 6_or_more) >= 6))
6_or_more_neighbours_data <- t(data.frame(6_or_more_rows_columns))
rownames(6_or_more_neighbours_data) <- NULL
6_or_more_neighbours <- 6_or_more_neighbours_data
6_or_more_neighbours
But this is outputted 0 as it is only checking to the top, bottom, left and right of each 1. How would I update this code to get it to check diagonally to each 1 too?
You might try gathering all consecutive values (left to right, top to bottom, and diagonal) in a list and then call rle on each list element. For example, using the following data:
set.seed(30948)
mat <- matrix(rbinom(10 * 5, 1, 0.5), ncol = 20, nrow = 20)
Combine rows, columns, and bottom-left and top-right diagonals in consecs, then call rle on each element and return the sum. I retrieve all the diagonals by calling diag on subsets of mat. Note that the corners are ignored because of 1:(ncol(mat)-1), and that I drop the first diagonal of the bottom-left corner with [-1] because it is already extracted in the prior lapply:
consecs <- c(lapply(1:ncol(mat), function(x) mat[, x]),
lapply(1:nrow(mat), function(x) mat[x, ]),
lapply(1:(ncol(mat)-1), function(x) diag(mat[, x:ncol(mat)])),
lapply(1:(nrow(mat)-1), function(x) diag(mat[x:nrow(mat), ]))[-1]
)
sum(sapply(consecs, function(x) with(rle(x), sum(lengths[values == 1] > 5))))
#[1] 14
Edit:
I gather from your comments that you want apply the above code to a list of matrices. To do that just put the code in a function and pass it into lapply:
# Create a list of matrices.
set.seed(30948)
mat_list <- list(mat1 = matrix(rbinom(10 * 5, 1, 0.5), ncol = 20, nrow = 20),
mat2 = matrix(rbinom(10 * 5, 1, 0.5), ncol = 20, nrow = 20),
mat3 = matrix(rbinom(10 * 5, 1, 0.5), ncol = 20, nrow = 20)
)
# Put the above code in a function.
compute_consecs <- function(mat){
consecs <- c(lapply(1:ncol(mat), function(x) mat[, x]),
lapply(1:nrow(mat), function(x) mat[x, ]),
lapply(1:(ncol(mat)-1), function(x) diag(mat[, x:ncol(mat)])),
lapply(1:(nrow(mat)-1), function(x) diag(mat[x:nrow(mat), ]))[-1]
)
sum(sapply(consecs, function(x) with(rle(x), sum(lengths[values == 1] > 5))))
}
# Apply the function to your list of matrices.
lapply(mat_list, compute_consecs)
#### OUTPUT ####
$mat1
[1] 14
$mat2
[1] 0
$mat3
[1] 7
How can I assign a value into a matrix based in a vector condition index. A working example is:
# Input:
r <- c(2, 1, 3)
m <- matrix(rep(0, 9), nrow = 3)
# Desired output
result <- matrix(c(0, 1, 0,
1, 0, 0,
0, 1, 0), nrow = 3)
result.
# I try with this notation but it does not work:
sapply(1:3, function(x)m[x, r[x]] <- 1)
We use row/column indexing to assign
m[cbind(seq_len(nrow(m)), r)] <- 1
Or using replace
replace(m, cbind(seq_len(nrow(m)), r), 1)
I have the following code:
beta <- c(1, 2, 3)
X1 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1,
0, 0, 1, 1),
nrow = 4,
ncol = 3)
Z1 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1),
nrow = 4,
ncol = 2)
Z2 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1),
nrow = 4,
ncol = 2)
library(MASS)
S1 <- mvrnorm(70, mu = c(0,0), Sigma = matrix(c(10, 3, 3, 2), ncol = 2))
S2 <- mvrnorm(40, mu = c(0,0), Sigma = matrix(c(10, 4, 4, 2), ncol = 2))
z <- list()
y <- list()
for(j in 1:dim(S1)[1]){
for(i in 1:dim(S2)[1]){
z[[i]] <- X1 %*% beta+Z1 %*% S1[j,]+Z2 %*% S2[i,]+matrix(rnorm(4, mean = 0 , sd = 0.27), nrow = 4)
Z <- unname(do.call(rbind, z))
}
y[[j]] <- Z
Y <- unname(do.call(rbind, y))
}
X1 is a 4x3, Z1 and Z2 are 4x2 matrices. So everytime X1 %*% beta+X2 %*% S1[j,]+X2 %*% S2[i,]+matrix(rnorm(4, mean = 0 , sd = sigma), nrow = 4) is called it outputs a 4x1 matrix. So far I store all these values in the inner and outer loop in two lists and then call rbind() to transform them into a matrix. Is there a way to directly store them in matrices?
You can avoid using lists if you rely on the apply functions and on vector recycling. I broke down your equation into its parts. (I hope I interpreted it accurately!)
Mb <- as.vector(X1 %*% beta)
M1 <- apply(S1,1,function(x) Z1 %*% x )
M2 <- apply(S2,1,function(x) Z2 %*% x ) + Mb
Mout <- apply(M1,2,function(x) M2 + as.vector(x))
as.vector(Mout) + rnorm(length(Mout), mean = 0 , sd = 0.27)
because the random numbers are added after the matrix multiplication (ie are not involved in any calculation), you can just put them in on the end.
Also note that you can't add a smaller matrix to a larger one, but if you make it a vector first then R will recycle it as necessary. So when Mb (a vector of length 4) is added to a matrix with 4 rows and n columns, it is recycled n times.
`I'm wondering how I would go about altering this code so that corresponding values of both vectors cannot be equal. As an example: if x = (1, 2, 2, 4, 8, 1, 7, 9, 5, 10) and y = (3, 2, 7, 8, 4, 10, 4, 8, 2, 1), the second values for both vectors equal 2. Is there any way I can tell R to re-sample in this second spot in vector x until it is not the same value in vector y?
x <- c(1:10)
y <- c(1:10)
sample_x <- sample(x, length(10), replace = TRUE)
z <- sample_x > y`
You could do:
while(any(x == y)) x <- sample(x)
Edit: Now I realize x and y probably come from a similar sample call with replace = TRUE, here is an interesting approach that avoids a while loop. It uses indices and modulo to ensure that the two samples do not match:
N <- 1:10 # vector to choose from (assumes distinct values)
L <- 20 # sample size - this might be length(N) as in your example
n <- length(N)
i <- sample(n, L, replace = TRUE)
j <- sample(n-1, L, replace = TRUE)
x <- N[i]
y <- N[1 + (i + j - 1) %% n]
while (any(ind <- x==y))
x[ind] <- sample(N, sum(ind), TRUE)
where N is what you are sampling from (or the max integer)
The advantage here is that if you do not need to resample all of x, then this will converge more quickly.
You can use function permn from library combinat to generate all permutations of vector of length 10.
ind <- permn(10)
xy_any_equal <- sapply(ind, function(i) any(x[i] == y))
if(sum(xy_any_equal) < length(xy_any_equal)) x_perm <- x[head(ind[!xy_any_equal],1)[[1]]]
exists(x_perm)