I have a distance matrix. For example :
d<-matrix(c(0,2,3,7,11,0,13,6,8,5,0,12,6,53,12,0), nrow = 4, ncol = 4)
d
[,1] [,2] [,3] [,4]
[1,] 0 11 8 6
[2,] 2 0 5 53
[3,] 3 13 0 12
[4,] 7 6 12 0
I want to create a neighbor matrix where distance is less than or equal to 5. In matrix nb, 1 indicates not a neighbor. However, they have no neighbor (excluding itself, for example, row 1 and row 4. I would like the one with the smallest distance to be their neighbor.
> nb=(d>=5)
> nb*1
[,1] [,2] [,3] [,4]
[1,] 0 1 1 1
[2,] 0 0 1 1
[3,] 0 1 0 1
[4,] 1 1 1 0
Expected result
[,1] [,2] [,3] [,4]
[1,] 0 1 1 0
[2,] 0 0 1 1
[3,] 0 1 0 1
[4,] 1 0 1 0
I have tried and I don't know how to get it efficiently without using loop. This is just an example, my actual data has over 9000 rows. Any suggestion would be helpful. Thank you so much!
I believe the following function does what you want.
fun <- function(Dist, n = 5){
nb <- (Dist > n)*1L
for(i in seq_len(nrow(nb))) {
tmp <- Dist[i, ]
tmp[tmp == 0] <- Inf
nb[i, which.min(tmp)] <- 0L
}
nb
}
fun(d)
# [,1] [,2] [,3] [,4]
#[1,] 0 1 1 0
#[2,] 0 0 0 1
#[3,] 0 1 0 1
#[4,] 1 0 1 0
fun(d, 10)
# [,1] [,2] [,3] [,4]
#[1,] 0 1 0 0
#[2,] 0 0 0 1
#[3,] 0 1 0 1
#[4,] 0 0 1 0
Related
Suppose I have a matrix, mat. Suppose further that the sum of one row of this matrix is equal to zero. Then, I need to set all the coming rows (the rows after the zero row) to zero. For example,
mat <- c(1,2,0,0,0,
3,4,0,2,1,
0,0,0,1,0,
1,2,0,0,0,
0,1,0,1,0)
mat <- matrix(mat,5,5)
mat
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 4 0 2 1
[3,] 0 0 0 0 0
[4,] 0 2 1 0 1
[5,] 0 1 0 0 0
All the entries of row 3 are zero. Hence, I want rows 4, and 5 to become zeros as well. I have a list of matrices and would like to apply the same to all the matrices using the lapply function. For simplicity, I make a list of 3 matrices similar to the mat.
mat <- c(1,2,0,0,0,
3,3,0,2,1,
0,0,0,4,0,
1,3,0,0,0,
0,1,0,1,0)
mat <- matrix(mat,5,5)
mat1 <- c(1,2,0,0,0,
3,4,0,2,1,
0,0,0,1,0,
1,2,0,0,0,
0,1,0,1,0)
mat1 <- matrix(mat1,5,5)
mat2 <- c(1,2,0,0,0,
3,4,0,2,1,
0,0,0,2,0,
1,2,0,0,0,
0,2,0,3,0)
mat2 <- matrix(mat2,5,5)
Mat <- list(mat1, mat2, mat3)
You did not actually post mat3 in your data so I just used mat3 <- matrix(1, 5, 5), i.e. a 5x5 matrix of ones. This was to ensure it could handle cases where there is no row where all values are zero.
This will return a list of matrices where all rows are zero after the first row of zeroes:
lapply(Mat, \(mat) {
first_zero_row <- which(rowSums(mat)==0)[1]
if(!is.na(first_zero_row)) {
mat[first_zero_row:nrow(mat),] <- 0
}
mat
})
Output:
[[1]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 4 0 2 1
[3,] 0 0 0 0 0
[4,] 0 0 0 0 0
[5,] 0 0 0 0 0
[[2]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 4 0 2 2
[3,] 0 0 0 0 0
[4,] 0 0 0 0 0
[5,] 0 0 0 0 0
[[3]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 1 1 1 1
[2,] 1 1 1 1 1
[3,] 1 1 1 1 1
[4,] 1 1 1 1 1
[5,] 1 1 1 1 1
Another option could be:
lapply(Mat, function(x) {x[cumsum(rowSums(x != 0) == 0) != 0, ] <- 0; x})
[[1]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 3 0 3 1
[3,] 0 0 0 0 0
[4,] 0 0 0 0 0
[5,] 0 0 0 0 0
[[2]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 4 0 2 1
[3,] 0 0 0 0 0
[4,] 0 0 0 0 0
[5,] 0 0 0 0 0
[[3]]
[,1] [,2] [,3] [,4] [,5]
[1,] 1 3 0 1 0
[2,] 2 4 0 2 2
[3,] 0 0 0 1 0
[4,] 0 2 2 0 3
[5,] 0 1 0 0 0
I am trying to generate matrices of m*n elements with binary data on the condition that the sum of the rows must equal 1.
For example, all the possible 2*2 matrices of binary data on condition that the row sums equal 1 are:
[,1] [,2]
[1,] 1 0
[2,] 1 0
[,1] [,2]
[1,] 0 1
[2,] 0 1
[,1] [,2]
[1,] 0 1
[2,] 1 0
[,1] [,2]
[1,] 1 0
[2,] 0 1
Can anyone help out with some neat code to achieve such an output? Or is there a function that can help with this?
A straightforward approach involves generating all vectors of length n containing n - 1 zeros and 1 one. This is reduced to all permutations of the multiset {0, 0, ... ,0, 1}. Let's say that there are K such permutations.
Once we have all of these, we generate the permutations of K with repetition of size m, where m is the desired number of rows. We use each of these results to subset the permutations of the zeros and ones.
Below, we have implemented this using the library RcppAlgos (disclosure: I am the author). The first part (i.e. generating permutations of multisets) is accomplished using the freqs parameter. The second part is accomplished using the FUN parameter, which allows one to pass arbitrary functions that act on each permutation.
library(RcppAlgos)
binMat <- function(m, n, row_sum = 1) {
perms <- if (n == row_sum) {
permuteGeneral(1, n, repetition = TRUE)
} else {
permuteGeneral(0:1, n, freqs = c(n - row_sum, row_sum))
}
permuteGeneral(nrow(perms), m, repetition = TRUE, FUN = function(x) {
perms[x, ]
})
}
Note, in the above that one can generate matrices with different row sums using the row_sum parameter.
Here is an example:
binMat(3, 2)
[[1]]
[,1] [,2]
[1,] 0 1
[2,] 0 1
[3,] 0 1
[[2]]
[,1] [,2]
[1,] 0 1
[2,] 0 1
[3,] 1 0
[[3]]
[,1] [,2]
[1,] 0 1
[2,] 1 0
[3,] 0 1
[[4]]
[,1] [,2]
[1,] 0 1
[2,] 1 0
[3,] 1 0
[[5]]
[,1] [,2]
[1,] 1 0
[2,] 0 1
[3,] 0 1
[[6]]
[,1] [,2]
[1,] 1 0
[2,] 0 1
[3,] 1 0
[[7]]
[,1] [,2]
[1,] 1 0
[2,] 1 0
[3,] 0 1
[[8]]
[,1] [,2]
[1,] 1 0
[2,] 1 0
[3,] 1 0
It's efficient as well:
system.time(testMany <- binMat(7, 7))
user system elapsed
1.936 0.062 1.999
testMany[[1]]
[,1] [,2] [,3] [,4] [,5] [,6] [,7]
[1,] 0 0 0 0 0 0 1
[2,] 0 0 0 0 0 0 1
[3,] 0 0 0 0 0 0 1
[4,] 0 0 0 0 0 0 1
[5,] 0 0 0 0 0 0 1
[6,] 0 0 0 0 0 0 1
[7,] 0 0 0 0 0 0 1
length(testMany)
[1] 823543
With base R this can be a solution,
# m : number of columns
# n : number of rows
my_fun <- function(m,n) {
a <- max(m,n)
mat <- diag(1, a, a)
x <- 1:nrow(mat)
y <- paste0(rep("x",n),collapse=",")
exp <- paste0("expand.grid(",y,")")
all_com <- eval(parse(text=exp ))
out <- lapply(1:nrow(all_com),function(x){
if(m>n) {
mat[as.numeric(all_com[x,]),]
}else{
mat <- mat[as.numeric(all_com[x,]),][,1:m]
mat <- mat[rowSums(mat)==1,]
}
})
out <- out[lapply(out,length) == m*n]
return(unique(out))
}
my_fun(2,2)
gives,
[[1]]
[,1] [,2]
[1,] 1 0
[2,] 1 0
[[2]]
[,1] [,2]
[1,] 0 1
[2,] 1 0
[[3]]
[,1] [,2]
[1,] 1 0
[2,] 0 1
[[4]]
[,1] [,2]
[1,] 0 1
[2,] 0 1
So I'm using r and I'd like to make a code that takes a value of n, creates a n x n matrix that has alternating 1's and 0's.
E.g:
I can't seem to do this without getting an error or warning and it won't work for all integers of n, any help would be appreciated, thanks.
what about this?
n <- 5L
matrix(seq(1:n^2) %% 2, nrow = n)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 1 0 1
[2,] 0 1 0 1 0
[3,] 1 0 1 0 1
[4,] 0 1 0 1 0
[5,] 1 0 1 0 1
Try the code below
m <- matrix(rep_len(c(1, 0), n^2), n)
or
m <- replace(m <- diag(n), !((row(m) - col(m)) %% 2), 1)
which gives
> m
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 1 0 1
[2,] 0 1 0 1 0
[3,] 1 0 1 0 1
[4,] 0 1 0 1 0
[5,] 1 0 1 0 1
I am trying to get the number of 1s (black pixels) connected by more than 1 other black pixel in a binary matrix. I have a matrix...
set.seed(1234)
mat <- matrix(rbinom(30, 1, 0.5), nrow = 5)
which outputs a matrix...
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 1 1 0 0 0
[2,] 1 1 1 1 0 0
[3,] 1 0 1 0 0 0
[4,] 1 0 1 1 0 0
I am now trying to figure out how to use this matrix to get the count (sum) of all black pixels that have more than 1 other black pixel connected such as...
[1,2] [1,3] [2,1] [2,2] [2,3] [3,1] [3,3] [4,3] = 8
Where 8 I would think would be the expected result. Is there a way to do this?
You can use diff in combination with apply to get the number of neighbour pixels having a 1.
f <- function(x) {
tt <- diff(x)==0 #See it there is no difference between Neighbors - Length is 1 less then x
(c(0, tt) + c(tt, 0)) * x #Add a Zero at the begin and end and multiply it with x to get the number of Neighbors in 1 direction
}
n <- t(apply(mat, 1, f)) + apply(mat, 2, f) #Use function f over rows and cols to get the number of Neighbors is two directions
sum(n>1)
#[1] 8
which(n>1, arr.ind = T)
row col
#[1,] 3 1
#[2,] 4 1
#[3,] 5 1
#[4,] 4 2
#[5,] 5 2
#[6,] 1 3
#[7,] 2 6
#[8,] 3 6
n
# [,1] [,2] [,3] [,4] [,5] [,6]
#[1,] 0 1 3 1 0 1
#[2,] 1 0 1 0 0 2
#[3,] 2 0 0 0 0 2
#[4,] 3 3 1 0 0 1
#[5,] 2 2 0 0 0 0
Data:
set.seed(1234)
mat <- matrix(rbinom(30, 1, 0.5), nrow = 5)
mat
# [,1] [,2] [,3] [,4] [,5] [,6]
#[1,] 0 1 1 1 0 1
#[2,] 1 0 1 0 0 1
#[3,] 1 0 0 0 0 1
#[4,] 1 1 1 0 0 1
#[5,] 1 1 0 0 0 0
I have a matrix that contains all the info necessary to construct 5x5 adjacency matrices. Each row represents one matrix:
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 1 1 1 1 1 1 1 0 1 0
[2,] 0 0 0 1 1 1 1 0 1 0
...
I want to create an adjacency matrix from the nth row of data. For the first row of have, the want matrix would look like this:
[,1] [,2] [,3] [,4] [,5]
[1,] 0 1 1 1 1
[2,] 1 0 1 1 1
[3,] 1 1 0 0 1
[4,] 1 1 0 0 0
[5,] 1 1 1 0 0
How do I get from have to want?
Here is an option using lower.tri and upper.tri
unlist(apply(mat, 1, function(x) {
m <- matrix(0, nrow = 5, ncol = 5)
m[lower.tri(m)] <- x
m[upper.tri(m)] <- x
list(m)
}), recursive = F)
#[[1]]
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0 1 1 1 1
#[2,] 1 0 1 1 0
#[3,] 1 1 0 1 1
#[4,] 1 1 0 0 0
#[5,] 1 1 1 0 0
#
#[[2]]
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0 0 0 1 1
#[2,] 0 0 0 1 0
#[3,] 0 1 0 1 1
#[4,] 0 1 0 0 0
#[5,] 1 1 1 0 0
The unlist(..., recursive = F) part seems somewhat awkward but is necessary to prevent apply from simplifying the result and dropping dims. An alternative would be to use lapply on a data.frame instead of a matrix:
lapply(as.data.frame(t(mat)), function(x) {
m <- matrix(0, nrow = 5, ncol = 5)
m[lower.tri(m)] <- x
m[upper.tri(m)] <- x
return(m)
})
giving the same result.
Sample data
mat <- as.matrix(read.table(text =
"1 1 1 1 1 1 1 0 1 0
0 0 0 1 1 1 1 0 1 0", header = F))
colnames(mat) <- NULL