Reputation: 25
Binary matrix in R: how to turn all 1 to 0 if they lie within N-steps of original zero
I apologise for the title, it will probably improve with suggestions.
I need to edit a binary matrix in R so that where ever there was a zero, I turn all surrounding entries to zero (if not zero already), if they lie within N steps of the original zero. The path can be L-shaped or straight, including diagonal, and diagonal path followed by straight path, as long as they are continuous unbroken paths.
So if N=2, the effect would be to expand the one zero in my example into a cloud of zeros, like this original matrix:
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 1 1 1 1 1 1 1 1 1 1
[2,] 1 1 1 1 1 1 1 1 1 1
[3,] 1 1 1 1 1 1 1 1 1 1
[4,] 1 1 1 1 1 1 0 1 1 1
[5,] 1 1 1 1 1 1 1 1 1 1
[6,] 1 1 1 1 1 1 1 1 1 1
[7,] 1 1 1 1 1 1 1 1 1 1
[8,] 1 1 1 1 1 1 1 1 1 1
[9,] 1 1 1 1 1 1 1 1 1 1
[10,] 1 1 1 1 1 1 1 1 1 1
with N=2 becomes
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 1 1 1 1 1 1 1 1 1 1
[2,] 1 1 1 1 0 1 0 1 0 1
[3,] 1 1 1 1 1 0 0 0 1 1
[4,] 1 1 1 1 0 0 0 0 0 1
[5,] 1 1 1 1 1 0 0 0 1 1
[6,] 1 1 1 1 0 1 0 1 0 1
[7,] 1 1 1 1 1 1 1 1 1 1
[8,] 1 1 1 1 1 1 1 1 1 1
[9,] 1 1 1 1 1 1 1 1 1 1
[10,] 1 1 1 1 1 1 1 1 1 1
and if N=3
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 1 1 1 0 1 1 0 1 1 0
[2,] 1 1 1 1 0 0 0 0 0 1
[3,] 1 1 1 1 0 0 0 0 0 1
[4,] 1 1 1 0 0 0 0 0 0 0
[5,] 1 1 1 1 0 0 0 0 0 1
[6,] 1 1 1 1 0 0 0 0 0 1
[7,] 1 1 1 0 1 1 0 1 1 0
[8,] 1 1 1 1 1 1 1 1 1 1
[9,] 1 1 1 1 1 1 1 1 1 1
[10,] 1 1 1 1 1 1 1 1 1 1
I need the solution to cope with any sensible number of N steps. In practice N will be 8 or 10, and the matrices are around 8000x8000 in size.
The reason I need to do this is that the entries in these matrices are pixels from an image that I made binary (black and white). The zeros correspond to white lines and I want to "grow" the lines by N pixels (to represent imprecision of sampling in an analysis).
I need to do this in R, and in this "simple" way, so that all my images from different sources end up being processed in a consistent reproducible way.
I confess that the solution is beyond me, at least in a reasonable time frame, and so I am asking for help on this one. Image processors like GIMP do this all the time, so I am sure there is a solution.
Thank you very much.
Upvotes: 1
Views: 226
Answers (3)
Reputation: 132864
Here is a solution that turns the eight neighbors to zero in a single step and does the following steps by recursion.
M <- matrix(1, ncol = 10, nrow = 10)
M[4, 7] <- 0
M[10, 1] <- 0
set0 <- function(M, n) {
stopifnot("invalid n" = is.numeric(n) & n > 0)
n <- ceiling(n)
#recursion
if (n > 1L) return(set0(set0(M, n - 1L), 1L))
#find zeros
zeros <- which(M == 0, arr.ind = TRUE)
#loop over zeros
for (i in seq_len(nrow(zeros))) {
#the eight neighbors
x <- zeros[i,1] + c(-1, -1, -1, 0, 0, 1, 1, 1)
y <- zeros[i,2] + c(-1, 0, 1, -1, 1, -1, 0, 1)
#check for out of matrix
remx <- x < 1 | x > ncol(M)
remy <- y < 1 | y > nrow(M)
ind <- cbind(x, y)
ind[remx,] <- NA
ind[remy,] <- NA
ind <- na.omit(ind)
#set to zero
M[ind] <- 0
}
M
}
M
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 1 1 1 1 1 1 1 1 1 1
# [2,] 1 1 1 1 1 1 1 1 1 1
# [3,] 1 1 1 1 1 1 1 1 1 1
# [4,] 1 1 1 1 1 1 0 1 1 1
# [5,] 1 1 1 1 1 1 1 1 1 1
# [6,] 1 1 1 1 1 1 1 1 1 1
# [7,] 1 1 1 1 1 1 1 1 1 1
# [8,] 1 1 1 1 1 1 1 1 1 1
# [9,] 1 1 1 1 1 1 1 1 1 1
#[10,] 0 1 1 1 1 1 1 1 1 1
set0(M, 1L)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 1 1 1 1 1 1 1 1 1 1
# [2,] 1 1 1 1 1 1 1 1 1 1
# [3,] 1 1 1 1 1 0 0 0 1 1
# [4,] 1 1 1 1 1 0 0 0 1 1
# [5,] 1 1 1 1 1 0 0 0 1 1
# [6,] 1 1 1 1 1 1 1 1 1 1
# [7,] 1 1 1 1 1 1 1 1 1 1
# [8,] 1 1 1 1 1 1 1 1 1 1
# [9,] 0 0 1 1 1 1 1 1 1 1
#[10,] 0 0 1 1 1 1 1 1 1 1
set0(M, 2L)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 1 1 1 1 1 1 1 1 1 1
# [2,] 1 1 1 1 0 0 0 0 0 1
# [3,] 1 1 1 1 0 0 0 0 0 1
# [4,] 1 1 1 1 0 0 0 0 0 1
# [5,] 1 1 1 1 0 0 0 0 0 1
# [6,] 1 1 1 1 0 0 0 0 0 1
# [7,] 1 1 1 1 1 1 1 1 1 1
# [8,] 0 0 0 1 1 1 1 1 1 1
# [9,] 0 0 0 1 1 1 1 1 1 1
#[10,] 0 0 0 1 1 1 1 1 1 1
Edit:
A faster version without the loop:
set0 <- function(M, n) {
stopifnot("invalid n" = is.numeric(n) & n > 0)
n <- ceiling(n)
#recursion
if (n > 1L) return(set0(set0(M, n - 1L), 1L))
#find zeros
zeros <- which(M == 0, arr.ind = TRUE)
zeros <- do.call(cbind, rep(list(zeros), 8))
zeros <- array(zeros, c(nrow(zeros), 2, 8))
step <- cbind(c(-1, -1, -1, 0, 0, 1, 1, 1),
c(-1, 0, 1, -1, 1, -1, 0, 1))
step <- do.call(cbind, rep(list(step), nrow(zeros)))
step <- array(step, c(8, 2, nrow(zeros)))
step <- aperm(step, c(3, 2, 1))
zeros <- zeros + step
#check for out of matrix
zeros[,1,][zeros[,1,] < 1 | zeros[,1,] > ncol(M)] <- NA
zeros[,2,][zeros[,2,] < 1 | zeros[,2,] > nrow(M)] <- NA
zeros <- aperm(zeros, c(1, 3, 2))
zeros <- matrix(zeros, ncol = 2)
zeros <- na.omit(zeros)
M[zeros] <- 0
M
}
Upvotes: 2
Reputation: 86
For low N this can be done with some loops but would also require some logic to cover cases where 0s are within N of an edge. This code fills a central square then an additional cell in the main meridians, which works exactly for N=2 and 3 as above.
#Make our data
Data <- matrix(1, nrow=10, ncol=10)
Data[4,7]<-0
#set N
N=2
#Determine where the 0s are
Zeros = Data==0
ZeroIndex=which(Zeros, arr.ind=T)
#Make output matrix
DataOut=Data
for (p in 1:sum(Zeros)){ #Per 0 point
Point=ZeroIndex[p,] #Get the indices of each point
#Transform central square
DataOut[(Point[1]-(N-1)):(Point[1]+(N-1)),(Point[2]-(N-1)):(Point[2]+(N-1))] <- 0
#Transform outer points in main meridians
DataOut[Point[1]-N, Point[2]] <- 0
DataOut[Point[1]+N, Point[2]] <- 0
DataOut[Point[1], Point[2]-N] <- 0
DataOut[Point[1], Point[2]+N] <- 0
DataOut[Point[1]-N, Point[2]-N] <- 0
DataOut[Point[1]-N, Point[2]+N] <- 0
DataOut[Point[1]+N, Point[2]-N] <- 0
DataOut[Point[1]+N, Point[2]+N] <- 0
}
Data
DataOut
For bigger N this will lose some fidelity at the edges but might be along the right lines (I expect altering the lines referencing N-1 will be the route to take)
Hope it helps, still something of a beginner to R so welcome to criticism/additions.
EDIT: Re-read the post and the line about L-shaped paths inspired this alternative which I suspect may work better for larger N. Again, edge detecting logic is probably needed.
#Make our data
Data <- matrix(1, nrow=10, ncol=10)
Data[4,7]<-0
#set N
N=3
#Determine where the 0s are
Zeros = Data==0
ZeroIndex=which(Zeros, arr.ind=T)
#Make output matrix
DataOut=Data
for (p in 1:sum(Zeros)){ #Per 0 point
Point=ZeroIndex[p,] #Get the indices of each point
#Transform outer points in main meridians
DataOut[Point[1]-N, Point[2]] <- 0
DataOut[Point[1]+N, Point[2]] <- 0
DataOut[Point[1], Point[2]-N] <- 0
DataOut[Point[1], Point[2]+N] <- 0
DataOut[Point[1]-N, Point[2]-N] <- 0
DataOut[Point[1]-N, Point[2]+N] <- 0
DataOut[Point[1]+N, Point[2]-N] <- 0
DataOut[Point[1]+N, Point[2]+N] <- 0
for (n in 1:N){
#Transform straight paths
DataOut[Point[1], Point[2]-n] <- 0
DataOut[Point[1], Point[2]+n] <- 0
DataOut[Point[1]+n, Point[2]] <- 0
DataOut[Point[1]-n, Point[2]] <- 0
DataOut[Point[1]-n, Point[2]-n] <- 0
DataOut[Point[1]+n, Point[2]+n] <- 0
DataOut[Point[1]+n, Point[2]-n] <- 0
DataOut[Point[1]-n, Point[2]+n] <- 0
#Transform L shaped paths
for (x in 1:n){
y=n-x
DataOut[Point[1]-y, Point[2]+x] <- 0
DataOut[Point[1]+y, Point[2]-x] <- 0
DataOut[Point[1]-y, Point[2]-x] <- 0
DataOut[Point[1]+y, Point[2]+x] <- 0
} #close x loop
for (y in 1:n){
x=n-y
DataOut[Point[1]-y, Point[2]+x] <- 0
DataOut[Point[1]+y, Point[2]-x] <- 0
DataOut[Point[1]-y, Point[2]-x] <- 0
DataOut[Point[1]+y, Point[2]+x] <- 0
} #close y loop
} #close n loop
}# closep loop
Data
DataOut
Upvotes: 1
Reputation: 174278
Here's a fully working solution that plays nicely at the edges. It makes use of expand.grid to get the positions, as well as taking advantage of array indexing:
get_moves <- function(n) {
df <- expand.grid(x = seq(n + 1) - 1, y = seq(n + 1) - 1)
df <- df[rowSums(df) <= n,]
`rownames<-`(as.matrix(setNames(unique(rbind(df,
within(df, x <- -x),
within(df, y <- -y),
within(df, {y<- -y; x <- -x}))), c("row", "col"))), NULL)
}
zero_indices <- function(mat, rownum, colnum, n)
{
indices <- get_moves(n)
indices[, 1] <- indices[, 1] + rownum
indices[, 2] <- indices[, 2] + colnum
indices <- indices[indices[, 1] >= 1, ]
indices <- indices[indices[, 2] >= 1, ]
indices <- indices[indices[, 2] <= ncol(mat), ]
indices[indices[, 1] <= nrow(mat), ]
indices
}
replace_zeros <- function(mat, n)
{
z <- which(mat == 0, arr.ind = TRUE)
mat[do.call(rbind, lapply(seq(nrow(z)), function(i) {
zero_indices(mat, z[i,1], z[i,2], n)}))] <- 0
mat
}
So let's test it on a sample 10 x 10 matrix:
mat <- matrix(1, nrow = 10, ncol = 10)
mat[3, 3] <- 0
mat[7, 8] <- 0
mat
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,] 1 1 1 1 1 1 1 1 1 1
#> [2,] 1 1 1 1 1 1 1 1 1 1
#> [3,] 1 1 0 1 1 1 1 1 1 1
#> [4,] 1 1 1 1 1 1 1 1 1 1
#> [5,] 1 1 1 1 1 1 1 1 1 1
#> [6,] 1 1 1 1 1 1 1 1 1 1
#> [7,] 1 1 1 1 1 1 1 0 1 1
#> [8,] 1 1 1 1 1 1 1 1 1 1
#> [9,] 1 1 1 1 1 1 1 1 1 1
#> [10,] 1 1 1 1 1 1 1 1 1 1
With n = 2 we get
replace_zeros(mat, 2)
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,] 1 1 0 1 1 1 1 1 1 1
#> [2,] 1 0 0 0 1 1 1 1 1 1
#> [3,] 0 0 0 0 0 1 1 1 1 1
#> [4,] 1 0 0 0 1 1 1 1 1 1
#> [5,] 1 1 0 1 1 1 1 0 1 1
#> [6,] 1 1 1 1 1 1 0 0 0 1
#> [7,] 1 1 1 1 1 0 0 0 0 0
#> [8,] 1 1 1 1 1 1 0 0 0 1
#> [9,] 1 1 1 1 1 1 1 0 1 1
#> [10,] 1 1 1 1 1 1 1 1 1 1
and with n = 3 we get:
replace_zeros(mat, 3)
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,] 1 0 0 0 1 1 1 1 1 1
#> [2,] 0 0 0 0 0 1 1 1 1 1
#> [3,] 0 0 0 0 0 0 1 1 1 1
#> [4,] 0 0 0 0 0 1 1 0 1 1
#> [5,] 1 0 0 0 1 1 0 0 0 1
#> [6,] 1 1 0 1 1 0 0 0 0 0
#> [7,] 1 1 1 1 0 0 0 0 0 0
#> [8,] 1 1 1 1 1 0 0 0 0 0
#> [9,] 1 1 1 1 1 1 0 0 0 1
#> [10,] 1 1 1 1 1 1 1 0 1 1
I suspect there are faster implementations possible, but this strikes a reasonable balance between speed and complexity.
Upvotes: 1
Related Questions
- How to create a binary matrix from single vector in R?
- binary matrix in R with specific ones in each column
- Converting this matrix to a binary matrix
- R: Filling matrix with ones after two zeros
- Create a binary matrix under certain conditions
- Set the subsequent two 0 after every 1 in a binary vector to 1
- Identify and replace all sum-to-zero rows in a list of binary matrices
- how to convert a matrix of values into a binary matrix
- Identify all elements adjacent to a 1 in a binary matrix
- How to flip N percent of enreries of binary matrix in R?