Матрица понижающего матрица в R?

Question

Мой вопрос о том, как улучшить производительность функции, которая уменьшает выборку из столбцов матрицы без замены (например, «разрежение» матрицы ... Я знаю, что упоминалось об этом here, но я не мог найти ясный ответ: а) делает то, что мне нужно; б) делает это быстро).

Вот моя функция:

downsampled <- function(data,samplerate=0.8) { 
    data.test <- apply(data,2,function(q) { 
    names(q) <- rownames(data) 
    samplepool <- character() 
    for (i in names(q)) { 
     samplepool <- append(samplepool,rep(i,times=q[i])) 
    } 
    sampled <- sample(samplepool,size=samplerate*length(samplepool),replace = F) 
    tab <- table(sampled) 
    mat <- match(names(tab),names(q)) 
    toret=numeric(length <- length(q)) 
    names(toret) <- names(q) 
    toret[mat] <- tab 
    return(toret) 
    }) 
return(data.test) 
} 

мне нужна субдискретизация матрицы с миллионами записей. Я считаю, что это довольно медленно (здесь я использую матрицу 1000x1000, что составляет около 20-100x меньше, чем моего обычного размера данных):

mat <- matrix(sample(0:40,1000*1000,replace=T),ncol=1000,nrow=1000) 
colnames(mat) <- paste0("C",1:1000) 
rownames(mat) <- paste0("R",1:1000) 
system.time(matd <- downsampled(mat,0.8)) 

## user system elapsed 
## 69.322 21.791 92.512 

Есть ли более быстрый/простой способ выполнить эту операцию, я не подумали?

Answer 1

Одним из источников экономии будет удаление цикла for, который добавляет samplepool с использованием rep. Вот воспроизводимый пример:

myRows <- 1:5 
names(myRows) <- letters[1:5] 
# get the repeated values for sampling 
samplepool <- rep(names(myRows), myRows) 

В вашей функции, это будет

samplepool <- rep(names(q), q) 

Answer 2

Я думаю, что вы можете сделать это значительно быстрее. Если я понимаю, что вы пытаетесь сделать правильно, вы хотите понизить выборку каждой ячейки матрицы, так что если samplerate = 0.5 и ячейка матрицы равна mat[i,j] = 5, тогда вы хотите попробовать до 5 вещей, где каждая вещь имеет 0,5 вероятность отбора проб.

Чтобы ускорить процесс, а не делать все эти операции на столбцах матрицы, вы можете просто цикл по каждой ячейке матрицы, рисовать п вещи из этой клетки с помощью runif (например, если mat[i,j] = 5, вы может генерировать 5 случайных чисел от 0 до 1, а затем добавить число значений < samplerate) и, наконец, добавить количество вещей в новую матрицу. Я думаю, что это эффективно обеспечивает ту же схему сэмплирования, но гораздо эффективнее (как с точки зрения времени выполнения, так и с помощью строк кода).

# Sample matrix 
set.seed(23) 
n <- 1000 
mat <- matrix(sample(0:10,n*n,replace=T),ncol=n,nrow=n) 
colnames(mat) <- paste0("C",1:n) 
rownames(mat) <- paste0("R",1:n) 

# Old function 
downsampled<-function(data,samplerate=0.8) { 
    data.test<-apply(data,2,function(q){ 
    names(q)<-rownames(data) 
    samplepool<-character() 
    for (i in names(q)) { 
     samplepool=append(samplepool,rep(i,times=q[i])) 
    } 
    sampled=sample(samplepool,size=samplerate*length(samplepool),replace = F) 
    tab=table(sampled) 
    mat=match(names(tab),names(q)) 
    toret=numeric(length = length(q)) 
    names(toret)<-names(q) 
    toret[mat]<-tab 
    return(toret) 
    }) 
return(data.test) 
} 

# New function 
downsampled2 <- function(mat, samplerate=0.8) { 
    new <- matrix(0, nrow(mat), ncol(mat)) 
    colnames(new) <- colnames(mat) 
    rownames(new) <- rownames(mat) 
    for (i in 1:nrow(mat)) { 
     for (j in 1:ncol(mat)) { 
      new[i,j] <- sum(runif(mat[i,j], 0, 1) < samplerate) 
     } 
    } 
    return(new) 
} 

# Compare times 
system.time(downsampled(mat,0.8)) 
## user system elapsed 
## 26.840 3.249 29.902 
system.time(downsampled2(mat,0.8)) 
## user system elapsed 
## 4.704 0.247 4.918 

Используя пример матрицы 1000 X 1000, новая функция, которую я предоставил, работает примерно в 6 раз быстрее.