Определите дубликаты островков в матрице и измените их значения

Question

У меня есть матрица:

m <- matrix(c(
  1,    1,    1,    0,    0,    0,
  0,    0,    0,    0,    0,    0,
  3,    0,    0,    0,    0,    0,
  3,    0,    0,    0,    0,    2,
  3,    0,    0,    0,    0,    0,
  3,    0,    0,    0,    2,    2),
  ncol = 6, byrow = TRUE)

     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    2 # <- island 3, value 2
[5,]    3    0    0    0    0    0
[6,]    3    0    0    0    2    2 # <- island  4, also value 2

В этой матрице есть четыре «острова», то есть ненулевые значения, разделенные нулями:

(1) остров, состоящий изтри 1, (2) четыре 3, (3) один 2 и (4) два 2.

Таким образом, два острова состоят из значения 2.Я хочу идентифицировать такие «дубликаты» островов и изменить значения одного из «островов» (подойдет любой) на следующий доступный номер (4 в данном случае):

     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    2
[5,]    3    0    0    0    0    0
[6,]    3    0    0    0    4    4

Answer 1

Этого легко достичь с пакетом TraMineR.

islander <- function(mat) {
  require(TraMineR)
  rows.mat.seq <- seqdef(mat)  # seeks all sequences in rows 
  cols.mat.seq <- seqdef(t(mat))  # tranposed version
  rows <- seqpm(rows.mat.seq, 22)$MIndex  # seeks for sub sequence 2-2 in rows
  cols <- seqpm(cols.mat.seq, 22)$MIndex  # seeks for sub sequence 2-2 in columns
  if (length(cols) == 0) {  # the row case
    mat[rows, which(mat[rows, ] == 2)] <- 4
    return(mat)
  } else {  # the column case
    mat[which(mat[, cols] == 2), cols] <- 4
    return(mat)
  }
}

Урожай

> islander(row.mat)
...
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    2
[5,]    3    0    0    0    0    0
[6,]    3    0    0    0    4    4

> islander(col.mat)
...
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    0
[5,]    3    0    0    0    0    4
[6,]    3    0    0    2    0    4

Примечание: Если ваш остров длиннее, вам нужно принять код, например, если длина острова 3, сделайте seqpm(., 222).Конечно, можно реализовать рассмотрение всех случаев в функции.

Данные

row.mat <- structure(c(1, 0, 3, 3, 3, 3, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 
                   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 2, 0, 2), .Dim = c(6L, 
                                                                                      6L))
col.mat <- structure(c(1, 0, 3, 3, 3, 3, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 
                    0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2), .Dim = c(6L, 
                                                                                       6L))

> row.mat
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    2
[5,]    3    0    0    0    0    0
[6,]    3    0    0    0    2    2
> col.mat
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    1    1    0    0    0
[2,]    0    0    0    0    0    0
[3,]    3    0    0    0    0    0
[4,]    3    0    0    0    0    0
[5,]    3    0    0    0    0    2
[6,]    3    0    0    2    0    2

Answer 2

Веселый вопрос!Давайте рассмотрим более сложный случай

(M <- matrix(c(1, 0, 3, 3, 3, 3, 1, 0, 0, 0, 0, 0, 1, 0, 3, 0, 2, 
               0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 2, 1, 0, 0, 2, 0, 2), 6, 6))
#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    1
# [2,]    0    0    0    0    0    0
# [3,]    3    0    3    3    0    0
# [4,]    3    0    0    0    0    2
# [5,]    3    0    2    0    0    0
# [6,]    3    0    0    0    2    2

Вот решение на основе графа.

library(igraph)
# Indices of nonzero matrix elements
idx <- which(M != 0, arr.ind = TRUE)
# Adjacency matrix for matrix entries
# Two entries are adjacent if their column or row number differs by one
# Also, due to idx, an implicit condition is also that the two entries are the same
adj <- 1 * (as.matrix(dist(idx, method = "manhattan")) == 1)
# Creating loops as to take into account singleton islands
diag(adj) <- 1
# A corresponding graphs
g <- graph_from_adjacency_matrix(adj, mode = "undirected")
# Connected components of this graph
cmps <- clusters(g)
# Going over unique values of M
for(i in 1:max(M)) {
  # Islands of value i
  un <- unique(cmps$membership[M[idx] == i])
  # More than one island?
  if(length(un) > 1)
    # If so, let's go over islands 2, 3, ...
    for(cmp in un[-1])
      # ... and replace corresponding matrix entries by max(M) + 1
      M[idx[cmps$membership == cmp, , drop = FALSE]] <- max(M) + 1
}

M
#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    4
# [2,]    0    0    0    0    0    0
# [3,]    3    0    7    7    0    0
# [4,]    3    0    0    0    0    6
# [5,]    3    0    2    0    0    0
# [6,]    3    0    0    0    5    5

Также отметим, что, используя только adj, мы могли бы найти все острова, если бы смогли найти егоперестановка, приводящая к блочно-диагональной матрице с максимальным количеством блоков.Тогда каждый блок будет соответствовать острову.Однако я не смог найти R-реализацию соответствующей процедуры.

Answer 3

'Острова' ненулевых значений могут быть идентифицированы как raster::clump*.Затем используйте вспомогательные функции data.table, чтобы определить, какие значения следует обновить.

library(raster)
library(data.table)

# get index of non-zero values. re-order to match the clump order
ix <- which(m != 0, arr.ind = TRUE)
ix <- ix[order(ix[ , "row"]), ]

# get clumps
cl <- clump(raster(m))
cl_ix <- cl@data@values

# put stuff in a data.table and order by x
d <- data.table(ix, x = m[ix], cl_ix = cl_ix[!is.na(cl_ix)])
setorder(d, x, cl_ix)

# for each x, create a counter of runs of clump index
d[ , g := rleid(cl_ix), by = x]

# for 'duplicated' runs...
# ...add to x based on runs of x and clump index runs
d[g > 1, x := max(d$x) + rleid(x, g)]

# update matrix
m2 <- m
m2[as.matrix(d[ , .(row, col)])] <- d$x

m
#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    1
# [2,]    0    0    0    0    0    0
# [3,]    3    0    3    3    0    0
# [4,]    3    0    0    0    0    2
# [5,]    3    0    2    0    0    0
# [6,]    3    0    0    0    2    2

m2
#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    4
# [2,]    0    0    0    0    0    0
# [3,]    3    0    7    7    0    0
# [4,]    3    0    0    0    0    2
# [5,]    3    0    5    0    0    0
# [6,]    3    0    0    0    6    6

---

* Обратите внимание, что функция clump требует наличия пакета igraph.

Answer 4

Это было сложнее, чем я думал, из-за условия «не оба», сейчас я добился результата с помощью цикла while, мы увидим, можно ли его улучшить:

(в основном мыпереместимся по ряду и проверим, найден ли остров, если это так, мы закончим наше исследование)

# some useful variables
i=1 # row counter
counter=0 # check if island is found
max_m <- max(m) #finds the max value in the matrix, to fill

while(counter == 0) {

  if (any(m[i, ] == 2)) { # check if we find the island in the row, otherwise skip
    row <- m[i, ]
    row[row == 2] <- max_m + 1 # here we change the value
    m[i, ] <- row
    counter <- counter + 1
  }

  i = i + 1 # we move up one row
  #cat("row number: ", i, "\n") # sanity check to see if it was an infinite loop
}
m
#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    0
# [2,]    0    0    0    0    0    0
# [3,]    3    0    0    0    0    0
# [4,]    3    0    0    0    0    4
# [5,]    3    0    0    0    0    0
# [6,]    3    0    0    0    2    2

Это далеко от совершенства, потому что мы движемся по рядам, поэтому, если первый остров находится через столбец, мы быизменить только первое значение.

Пример неожиданного результата:

#      [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    1    1    1    0    0    0
# [2,]    0    0    0    0    0    0
# [3,]    3    0    0    0    0    0
# [4,]    3    0    0    0    0    4
# [5,]    3    0    0    0    0    2 # problem here
# [6,]    3    0    0    0    0    0

Использованные данные:

m <- matrix(c(rep(1, 3),
              rep(0, 9),
              3, 
              rep(0, 5),
              3,
              rep(0, 4),
              2,
              3,
              rep(0, 5),
              3,
              rep(0,3),
              rep(2, 2)),ncol=6,nrow=6, byrow = T)