Сходство / расстояние между многими парами матриц

Question

Я хочу количественно оценить групповое сходство, вычислив среднее расстояние между всеми наборами (многомерных) точек в каждой паре.

Я могу сделать это достаточно легко вручную для каждой пары групп вручную, например так:

library(dplyr)
library(tibble)
library(proxy)

# dummy data
set.seed(123)
df1 <- data.frame(x = rnorm(100,0,4), 
                  y = rnorm(100,1,5), 
                  z = rbinom(100, 1, 0.1))
df2 <- data.frame(x = rnorm(100,-1,3), 
                  y = rnorm(100,0,6), 
                  z = rbinom(100, 1, 0.1))
df3 <- data.frame(x = rnorm(100,-30,4), 
                  y = rnorm(100,10,2), 
                  z = rbinom(100, 1, 0.9))

# compute distance (unscaled, uncentred data)
dist(df1, df2, method = "gower") %>% mean
dist(df1, df3, method = "gower") %>% mean
dist(df2, df3, method = "gower") %>% mean

Но я хотел бы как-то векторизовать это, так как мои фактические данные имеют более 30 групп.Простой цикл for может добиться этого следующим образом:

# combine data and scale, centre
df <- rbind(df1, df2, df3) %>% 
  mutate(id = rep(1:3, each = 100))
df <- df %>% 
  select(-id) %>%
  transmute_all(scale) %>% 
  add_column(id = df$id)

# create empty matrix for comparisons
n <- df$id %>% unique %>% length
m <- matrix(nrow = n, ncol = n)

# loop through each pair once
for(i in 1:n) {
  for(j in 1:i) { #omit top right corner
    if(i == j) {
      m[i,j] <- NA #omit diagonal
    } else {
      m[i,j] <- dist(df[df$id == i,1:3], df[df$id == j,1:3], method = "gower") %>% mean
    }
  }
}

m
          [,1]      [,2] [,3]
[1,]        NA        NA   NA
[2,] 0.2217443        NA   NA
[3,] 0.8446070 0.8233932   NA

Однако этот метод предсказуемо плохо масштабируется;быстрый тест предполагает, что это займет более 90 часов с моими фактическими данными, в которых более 30 групп с 1000+ строками на группу.

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

Answer 1

Я не уверен, что это будет хорошо, но вот другой подход.Вы используете ls для получения имен матриц, combn для генерации пар из двух, а затем get для получения матриц для вычисления dist

do.call(rbind,
        combn(ls(pattern = "df\\d+"), 2, FUN = function(x)
            data.frame(pair = toString(x),
                       dist = mean(dist(get(x[1]), get(x[2]), method = "gower")),
                       stringsAsFactors = FALSE),
            simplify = FALSE
        ))
#      pair      dist
#1 df1, df2 0.2139304
#2 df1, df3 0.8315169
#3 df2, df3 0.8320911

Answer 2

proxy может работать со списками матриц в качестве входных данных, вам нужно только определить функцию-оболочку, которая делает то, что вы хотите:

nested_gower <- function(x, y, ...) {
  mean(proxy::dist(x, y, ..., method = "gower"))
}

proxy::pr_DB$set_entry(
  FUN = nested_gower,
  names = c("ngower"),
  distance = TRUE,
  loop = TRUE
)

df_list <- list(df1, df2, df3)
proxy::dist(df_list, df_list, method = "ngower")
     [,1]      [,2]      [,3]     
[1,] 0.1978306 0.2139304 0.8315169
[2,] 0.2139304 0.2245903 0.8320911
[3,] 0.8315169 0.8320911 0.2139049

Это все равно будет медленным, но должно быть быстрее, чемfor петли в простой R (proxy использует C на заднем плане).

Важно : обратите внимание, что диагональ полученной матрицы пересечения не имеет нулей.Если вы должны были позвонить dist, как proxy::dist(df_list, method = "ngower"), proxy будет предполагать, что distance(x, y) = distance(y, x) (симметрия), и что distance(x, x) = 0, последнее из которых неверно в этом случае.Передача двух аргументов dist предотвращает это предположение.Если вы действительно не заботитесь о диагонали, передайте только один аргумент, чтобы сэкономить дополнительное время, избегая вычислений в верхней треугольнике.В качестве альтернативы, если вы заботитесь о диагонали, но все же хотите избежать вычисления верхней треугольники, сначала вызовите dist с одним аргументом, а затем вызовите proxy::dist(df_list, df_list, method = "ngower", pairwise = TRUE).

Примечание: если вы хотите имитировать это поведениес пакетом gower (как предлагает db) вы можете определить функцию-обертку следующим образом:

nested_gower <- function(x, y, ...) {
  distmat <- sapply(seq_len(nrow(y)), function(y_row) {
      gower::gower_dist(x, y[y_row, , drop = FALSE], ...)
  })

  mean(distmat)
}

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

* Сначала используйте proxy::pr_DB$delete_entry("ngower"), если вы хотите переопределить функцию в proxy.

---

Если вы предпочитаете proxyВ версии матрицы расстояний Gower мне кажется, что вы можете использовать некоторые функции моего dtwclust пакета для параллельных вычислений:

library(dtwclust)
library(doParallel)

custom_dist <- new("tsclustFamily", dist = "ngower", control = list(symmetric = TRUE))@dist

workers <- makeCluster(detectCores())
registerDoParallel(workers)

distmat <- custom_dist(df_list)

stopCluster(workers); registerDoSEQ()

Это может будет быстрее для вашего реального случая использования (не так много для небольших выборочных данных здесь).То же самое касается диагонали (поэтому используйте custom_dist(df_list, df_list) или custom_dist(df_list, pairwise = TRUE)).См. Раздел 3.2 здесь и документацию tsclustFamily, если вам нужна дополнительная информация.

Answer 3

Вы можете взять каждую пару групп, объединить их, а затем просто вычислить матрицу различий в этой группе. Очевидно, это означает, что вы в некоторой степени сравниваете группу с самим собой, но она все еще может работать для вашего варианта использования, а с daisy это достаточно быстро для вашего размера данных.

library(cluster)

n <- 30
groups <- vector("list", 30)

# dummy data
set.seed(123)
for(i in 1:30) {
  groups[[i]] = data.frame(x = rnorm(1000,ceiling(runif(1, -10, 10)),ceiling(runif(1, 2, 4))), 
                           y = rnorm(1000,ceiling(runif(1, -10, 10)),ceiling(runif(1, 2, 4))), 
                           z = rbinom(1000,1,runif(1,0.1,0.9)))
}

m <- matrix(nrow = n, ncol = n)

# loop through each pair once
for(i in 1:n) {
  for(j in 1:i) { #omit top right corner
    if(i == j) {
      m[i,j] <- NA #omit diagonal
    } else {
      # concatenate groups
      dat <- rbind(df_list[[i]], df_list[[j]])

      # compute all distances (between groups and within groups), return matrix
      mm <- dat %>% 
        daisy(metric = "gower") %>%
        as.matrix

      # retain only distances between groups
      mm <- mm[(nrow(df_list[[i]])+1):nrow(dat) , 1:nrow(df_list[[i]])]

      # write mean distance to global comparison matrix
      m[i,j] <- mean(mm)
    }
  }
}