Векторить эти вложенные петли в R

Question

Я обычно могу понять, как векторизовать с небольшим количеством мысли, но, несмотря на чтение через кучу StackOverflow q & a, я все еще в тупике! Я хочу заменить эти вложенные петли на подходящую функцию приложения, но если есть какой-то очевидный другой подход ко всей проблеме, которую я пропустил, не стесняйтесь говорить мне об этом!

Подумайте об этом примере в контексте теста, где первая строка является ключом, и каждая последующая строка является ответом студентов. В качестве вывода я хочу массив с 1 для каждого правильного ответа и 0 для каждого неправильного ответа. Для циклов for работают, но они очень медленны, когда вы масштабируете до тысяч строк и столбцов.

Вот мой воспроизводимый пример и заблаговременно за помощь!

#build sample data 
    dat <- array(dim=c(9,6)) 
    for (n in 1:9){ 
     dat[n,1:6] <- c(paste("ID00",n,sep=""), 
      sample(c("A","B","C","D"), size=5, replace=TRUE))} 
    dat[3,4]<-NA 
    key<-c("key","A","B","B","C","D") 
    dat <- rbind(key,dat) 

>dat 
[,1] [,2] [,3] [,4] [,5] [,6] 
"key" "A" "B" "B" "C" "D" 
"ID001" "B" "A" "D" "B" "C" 
"ID002" "C" "C" "C" "B" "B" 
"ID003" "A" "C" NA "D" "D" 
"ID004" "D" "B" "D" "A" "A" 
"ID005" "A" "C" "A" "C" "A" 
"ID006" "D" "D" "B" "B" "A" 
"ID007" "B" "D" "A" "D" "A" 
"ID008" "D" "D" "B" "D" "A" 
"ID009" "D" "C" "B" "D" "D" 

    #score file 
    dat2 <- array(dim=c(9,5)) 
    for (row in 2:10){ 
     for (column in 2:6){ 
     if (is.na(dat[row,column])){ 
      p <- NA 
     }else if (dat[row,column]==dat[1,column]){ 
      p <- 1 
     }else p <- 0 
     dat2[row-1,column-1]<-p 
     } 
    } 
> dat2 
     [,1] [,2] [,3] [,4] [,5] 
[1,] 0 0 0 0 0 
[2,] 0 0 0 0 0 
[3,] 1 0 NA 0 1 
[4,] 0 1 0 0 0 
[5,] 1 0 0 1 0 
[6,] 0 0 1 0 0 
[7,] 0 0 0 0 0 
[8,] 0 0 1 0 0 
[9,] 0 0 1 0 1 

Answer 1

Установите семена для воспроизводимости:

set.seed(1) 
dat <- array(dim=c(9,6)) 
for (n in 1:9){ 
    dat[n,1:6] <- c(paste("ID00",n,sep=""), 
     sample(c("A","B","C","D"), size=5, replace=TRUE))} 
dat[3,4]<-NA 
key<-c("key","A","B","B","C","D") 
dat <- rbind(key,dat) 

Это сделает работу:

key <- rep(dat[1, -1], each = nrow(dat) - 1L) ## expand "key" row 
dummy <- (dat[-1, -1] == key) + 0L ## vectorized/element-wise "==" 

В основном мы хотим векторизованную "==". Но нам нужно сначала развернуть dat[1,-1] до того же размера dat[-1,-1]. Наконец + 0L принуждение TRUE/FALSE матрицы к 1/0 матрицы.

# [,1] [,2] [,3] [,4] [,5] 
# 0 1 0 0 0 
# 0 0 0 1 0 
# 1 0 NA 0 1 
# 0 0 0 0 1 
# 0 0 0 0 0 
# 0 0 1 0 0 
# 0 0 1 0 1 
# 0 0 0 1 0 
# 0 0 0 1 0 

---

Я не проверить с эталоном сценария Грегора еще. Но вот моя.

set.seed(1) 
dat <- matrix(sample(LETTERS[4], 1000 * 1000, TRUE), 1000) 
key <- sample(LETTERS[1:4], 1000, TRUE) 
microbenchmark(rep(key, each = 1000) == dat, t(t(dat) == key)) 

#Unit: milliseconds 
#       expr  min  lq  mean median  uq 
# rep(key, each = 1000) == dat 32.16888 34.01138 42.61639 35.57526 40.27944 
#    t(t(dat) == key) 50.93348 52.96008 63.74475 56.04706 60.38750 
#  max neval cld 
# 81.96044 100 a 
# 106.54916 100 b 

Единственное различие между моим методом и Грегора является расширение rep(, each) ветеринарный врач rep_len расширение. Оба расширения имеют одинаковый объем памяти и после расширения, "==" выполняется по-разному. Я предполагаю, что дополнительные накладные расходы будут вызваны двумя t(), которые, по-видимому, оправдывают результат бенчмаркинга. Надеюсь, результат не зависит от платформы.

Answer 2

Это в основном то же самое, что и ответ Чжэюаня (полагаясь на векторизованный ==, а затем возвращающийся обратно на числовой), я просто переношу матрицу сначала, а не расширяя ключ.

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

Использование set.seed(1) перед генерацией данных ...

key = dat[1, -1] 
tdat = t(dat[-1, -1]) 
t((tdat == key) + 0L) 
# [,1] [,2] [,3] [,4] [,5] 
# 0 1 0 0 0 
# 0 0 0 1 0 
# 1 0 NA 0 1 
# 0 0 0 0 1 
# 0 0 0 0 0 
# 0 0 1 0 0 
# 0 0 1 0 1 
# 0 0 0 1 0 
# 0 0 0 1 0 

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

row.names(dat) = dat[, 1] 
dat = dat[, -1] 
key = dat[1, ] 

tdat = t(dat[-1, ]) 
result = t((tdat == key) + 0) 
result 
#  [,1] [,2] [,3] [,4] [,5] 
# ID001 0 1 0 0 0 
# ID002 0 0 0 1 0 
# ID003 1 0 NA 0 1 
# ID004 0 0 0 0 1 
# ID005 0 0 0 0 0 
# ID006 0 0 1 0 0 
# ID007 0 0 1 0 1 
# ID008 0 0 0 1 0 
# ID009 0 0 0 1 0 

rowSums(result) 
# ID001 ID002 ID003 ID004 ID005 ID006 ID007 ID008 ID009 
#  1  1 NA  1  0  1  2  1  1 

---

Упрощая входы и работает тест на умеренно размера данных, и довольно быстро. Двойная транспозиция немного быстрее.

gregor = function(key, dat) { 
    t(t(dat) == key) 
} 

zheyuan = function(key, dat) { 
    dat == rep(key, each = nrow(dat)) 
} 

library(microbenchmark) 
nr = 10000 
nc = 1000 
key = sample(1:10, nc, replace = T) 
dat = matrix(sample(1:10, nr * nc, replace = T), nrow = nr) 

print(microbenchmark(gregor(key, dat), zheyuan(key, dat)), signif = 4) 
# Unit: milliseconds 
#    expr min lq  mean median uq max neval cld 
# gregor(key, dat) 104.5 113.2 135.5970 128.2 144.5 336.2 100 a 
# zheyuan(key, dat) 196.0 202.8 215.7822 207.0 224.9 394.4 100 b 

identical(gregor(key, dat), zheyan(key, dat)) 
# [1] TRUE 

Answer 3

Если вы хотите в одной строке без for или apply, попробовать что-то вроде

dat2 <- matrix(as.numeric(dat==rep(dat[1,],each=nrow(dat))),nrow=nrow(dat))[-1,-1]