R: Быстрый способ группировки строк матрицы, учитывая только место значений NA - PullRequest
Новая
       11

R: Быстрый способ группировки строк матрицы, учитывая только место значений NA

3 голосов
/ 01 октября 2019

Я пытаюсь сгруппировать строки матрицы по их уникальному расположению NA значений в каждом столбце.

Например, со следующей матрицей: 

1, 2, NA, 3 NA
2, 5, NA, 4, 5
3, 2,  1, 0, 7
5, 3, NA, 9, 3
0, 2,  1, 4, 6

Ответбудет выглядеть следующим образом: 

1, 2, 3, 2, 3

Указывает, что в одной группе было 3 разных группы, т.е. строки 2 и 4.

Проблема в том, что я не могу придумать быстрый способдля достижения этой цели. Вот моя текущая реализация: 

mat <- matrix(rnorm(10000*100), ncol=100)
mat[sample(length(mat), nrow(mat))] <- NA

getNAgroups <- function(x) {
  allnas  <- t(!is.na(x))
  nacases <- unique(allnas, MARGIN=2)
  groups  <- numeric(nrow(x))
  for(i in 1:ncol(nacases)) {
    groups[colMeans(allnas == nacases[,i]) == 1] <- i
  }
  groups
}

Что слишком медленно для целей, которые я имею в виду: 

system.time(getNAgroups(mat))
   user  system elapsed
  7.672   1.686   9.386

Ответы [ 5 ]

5 голосов
/ 01 октября 2019

Вот один из способов использовать совпадение в списке позиции NA: 

mat <- matrix(c(1, 2, NA, 3, NA,
2, 5, NA, 4, 5,
3, 2,  1, 0, 7,
5, 3, NA, 9, 3,
0, 2,  1, 4, 6), 5, byrow = TRUE)


categ <- apply(is.na(mat), 1, which)
match(categ, unique(categ))
1 голос
/ 01 октября 2019

Если вы не возражаете против порядка, вы можете использовать interaction для поиска групп. 

tt <- interaction(as.data.frame(is.na(mat)), drop = TRUE)
unclass(tt)
#[1] 3 2 1 2 1

Или, возможно, более производительный способ - использовать sweep и rowSums но работает только до 30 столбцов . 

tt  <- is.na(mat)
tt <- rowSums(sweep(tt, 2, cumprod(rep(2L,ncol(tt))), "*"))
match(tt, unique(tt))
#[1] 1 2 3 2 3

Или вы можете использовать библиотеку bit, которая не быстрее, но следует предыдущей идее и работает для многих строк и может помочь, когда память будетlimit. 

library("bit")
tt <- apply(is.na(mat), 1, as.bit)
match(tt, unique(tt))
#[1] 1 2 3 2 3

#For many columns
tt <- apply(apply(is.na(mat), 1, as.bit), 2, paste, collapse=" ")
match(tt, unique(tt))
#[1] 1 2 3 2 3

В качестве альтернативы packBits можно использовать как: 

tt  <- is.na(mat)
tt <- cbind(tt, matrix(TRUE, nrow(tt), ncol=(8 - ncol(tt) %% 8)))
tt <- packBits(t(tt))
tt <- split(tt, rep(seq_len(nrow(mat)), each=length(tt)/nrow(mat)))
match(tt, unique(tt))
#[1] 1 2 3 2 3

или более производительную версию, используя raw2hex из PKI или encryptr. 

library(PKI) #or library(encryptr)
tt  <- is.na(mat)
tt <- cbind(tt, matrix(TRUE, nrow(tt), ncol=(8 - ncol(tt) %% 8)))
tt <- raw2hex(packBits(t(tt)))
tt <- matrix(tt, ncol = nrow(mat))
tt <- apply(tt, 2, paste, collapse="")
match(tt, unique(tt))
[1] 1 2 3 2 3
1 голос
/ 01 октября 2019

Если речь идет о производительности, я бы попробовал следующий код: 

library(dplyr)
getNAgrps = function(df){
  df = df %>% 
    dplyr::mutate(NAgrp = '')
  lapply(1:nrow(df),function(i){
    df$NAgrp[i] <<- paste0(which(is.na(df[i,])),collapse=",")
  })

  return(df)
}

Эта функция принимает входные данные в качестве кадра данных. Чтобы преобразовать вашу матрицу в фрейм данных: 

library(dplyr)
dat = as_data_frame(mat)

Производительность выглядит следующим образом: 

> system.time(getNAgrps(mat))
   user  system  elapsed 
  0.005  0.000   0.006

Дайте мне знать, если это работает.

Примечание: вместо целого числагрупп, это вернет символьные векторы с позициями NA, разделенными запятыми.

1 голос
/ 01 октября 2019

Мы можем paste значения вместе по строкам и match это, чтобы получить уникальный индекс. 

vals <- apply(is.na(mat), 1, toString)
match(vals, unique(vals))
#[1] 1 2 3 2 3
0 голосов
/ 01 октября 2019 
set.seed(42)
mat <- matrix(rnorm(10000*100), ncol=100)
mat[sample(length(mat), nrow(mat))] <- NA

getNAgroups_Orig <- function(x) {
  allnas  <- t(!is.na(x))
  nacases <- unique(allnas, MARGIN=2)
  groups  <- numeric(nrow(x))
  for(i in 1:ncol(nacases)) {
    groups[colMeans(allnas == nacases[,i]) == 1] <- i
  }
  groups
}

getNAgroups_GKi <- function(mat) {
  tt  <- is.na(mat)
  tt <- rowSums(sweep(tt, 2, cumprod(rep(2L,ncol(tt))), "*"))
  match(tt, unique(tt))
}

getNAgroups_Clemsang <- function(mat) {
  categ <- apply(is.na(mat), 1, which)
  match(categ, unique(categ))
}

getNAgroups_RonakShah <- function(mat) {
  vals <- apply(is.na(mat), 1, toString)
  match(vals, unique(vals))
}

library("bit")
getNAgroups_bit <- function(mat) {
  tt <- apply(apply(is.na(mat), 1, as.bit), 2, paste, collapse=" ")
  match(tt, unique(tt))
}

getNAgroups_GKi2 <- function(mat) {
  tt  <- is.na(mat)
  tt <- cbind(tt, matrix(TRUE, nrow(tt), ncol=(8 - ncol(tt) %% 8)))
  tt <- packBits(t(tt))
  tt <- split(tt, rep(seq_len(nrow(mat)), each=length(tt)/nrow(mat)))
  match(tt, unique(tt))
}

library(PKI) #or library(encryptr)
getNAgroups_GKi3 <- function(mat) {
  tt  <- is.na(mat)
  tt <- cbind(tt, matrix(TRUE, nrow(tt), ncol=(8 - ncol(tt) %% 8)))
  tt <- raw2hex(packBits(t(tt)))
  tt <- matrix(tt, ncol = nrow(mat))
  tt <- apply(tt, 2, paste, collapse="")
  match(tt, unique(tt))
}


system.time(getNAgroups_Orig(mat))
#       User      System verstrichen 
#      6.928       1.316       8.244 

system.time(getNAgroups_GKi(mat))  ###IS NOT WORKING CORRECT DUE TO TOO MANY COLUMNS
#       User      System verstrichen
#      0.016       0.000       0.016 

system.time(getNAgroups_Clemsang(mat))
#       User      System verstrichen 
#      0.045       0.004       0.049 

system.time(getNAgroups_RonakShah(mat))
#       User      System verstrichen 
#      0.347       0.000       0.347

system.time(getNAgroups_bit(mat))
#       User      System verstrichen 
#      0.239       0.000       0.240

system.time(getNAgroups_GKi2(mat))
#       User      System verstrichen 
#      0.119       0.000       0.119 

system.time(getNAgroups_GKi3(mat))
#       User      System verstrichen 
#      0.046       0.000       0.046
...