Применяя функцию к матрице расстояний в R

Этот вопрос появился сегодня в списке рассылки manulatrr.

http://groups.google.com/group/manipulatr/browse_thread/thread/fbab76945f7cba3f

Я перефразирую.

Учитывая матрицу расстояний (вычисленную с помощью dist), примените функцию к строкам матрицы расстояния.

код:

library(plyr)
N <- 100
a <- data.frame(b=1:N,c=runif(N))
d <- dist(a,diag=T,upper=T)
sumd <- adply(as.matrix(d),1,sum)

Проблема заключается в том, что для применения функции по строкам вы должны хранить всю матрицу (а не только нижнюю треугольную часть, поэтому она использует слишком много памяти для больших матриц). В моем компьютере для матриц размерностей ~ 10000.

Любые идеи?

Ответ 1

Мое решение - получить индексы вектора расстояния, заданного строкой и размером матрицы. Я получил это от codeguru

int Trag_noeq(int row, int col, int N)
{
   //assert(row != col);    //You can add this in if you like
   if (row<col)
      return row*(N-1) - (row-1)*((row-1) + 1)/2 + col - row - 1;
   else if (col<row)
      return col*(N-1) - (col-1)*((col-1) + 1)/2 + row - col - 1;
   else
      return -1;
}

Переведя на R, предполагая, что индексы начинаются с 1, и предполагая, что нижняя тройка вместо верхней три матрицы получена.
EDIT: использование векторизованной версии, предоставленной rcs

noeq.1 <- function(i, j, N) {
    i <- i-1
    j <- j-1
    ix <- ifelse(i < j,
                 i*(N-1) - (i-1)*((i-1) + 1)/2 + j - i,
                 j*(N-1) - (j-1)*((j-1) + 1)/2 + i - j) * ifelse(i == j, 0, 1)
    ix
}

## To get the indexes of the row, the following one liner works:

getrow <- function(z, N) noeq.1(z, 1:N, N)

## to get the row sums

getsum <- function(d, f=sum) {
    N <- attr(d, "Size")
    sapply(1:N, function(i) {
        if (i%%100==0) print(i)
        f(d[getrow(i,N)])
    })
}

Итак, с примером:

sumd2 <- getsum(d)

Это было намного медленнее, чем as.matrix для малых матриц до векторизации. Но примерно в 3 раза медленнее после векторизации. В Intel Core2Duo 2ghz, применяя сумму за строкой матрицы размера 10000, заняло чуть более 100 секунд. Метод as.matrix терпит неудачу. Спасибо rcs!

Ответ 2

Прежде всего, для тех, кто этого еще не видел, я настоятельно рекомендую прочитать эту статью в r-wiki о оптимизации кода.

Здесь другая версия без использования ifelse (что относительно медленная функция):

noeq.2 <- function(i, j, N) {
    i <- i-1
    j <- j-1
    x <- i*(N-1) - (i-1)*((i-1) + 1)/2 + j - i
    x2 <- j*(N-1) - (j-1)*((j-1) + 1)/2 + i - j
    idx <- i < j
    x[!idx] <- x2[!idx]
    x[i==j] <- 0
    x
}

И тайминги на моем ноутбуке:

> N <- 1000
> system.time(sapply(1:N, function(i) sapply(1:N, function(j) noeq(i, j, N))))
   user  system elapsed 
  51.31    0.10   52.06 
> system.time(sapply(1:N, function(j) noeq.1(1:N, j, N)))
   user  system elapsed 
   2.47    0.02    2.67 
> system.time(sapply(1:N, function(j) noeq.2(1:N, j, N)))
   user  system elapsed 
   0.88    0.01    1.12

И lapply быстрее, чем sapply:

> system.time(do.call("rbind",lapply(1:N, function(j) noeq.2(1:N, j, N))))
   user  system elapsed 
   0.67    0.00    0.67

Ответ 3

Это векторный вариант функции noeq (любой аргумент i или j):

noeq.1 <- function(i, j, N) {
    i <- i-1
    j <- j-1
    ifelse(i < j,
           i*(N-1) - ((i-1)*i)/2 + j - i,
           j*(N-1) - ((j-1)*j)/2 + i - j) * ifelse(i == j, 0, 1)
}   

> N <- 4
> sapply(1:N, function(i) sapply(1:N, function(j) noeq(i, j, N)))
     [,1] [,2] [,3] [,4]
[1,]    0    1    2    3
[2,]    1    0    4    5
[3,]    2    4    0    6
[4,]    3    5    6    0
> sapply(1:N, function(i) noeq.1(i, 1:N, N))
     [,1] [,2] [,3] [,4]
[1,]    0    1    2    3
[2,]    1    0    4    5
[3,]    2    4    0    6
[4,]    3    5    6    0

Сроки выполняются на процессоре Intel Core 2 Duo с тактовой частотой 2,4 ГГц (Mac OS 10.6.1):

> N <- 1000
> system.time(sapply(1:N, function(j) noeq.1(1:N, j, N)))
   user  system elapsed 
  0.676   0.061   0.738 
> system.time(sapply(1:N, function(i) sapply(1:N, function(j) noeq(i, j, N))))
   user  system elapsed 
 14.359   0.032  14.410