R внешнее произведение факторов - пользовательское отображение - слишком медленное
С учетом двух факторов (каждый с одинаковым набором уровней), скажем,
lev <- c("alpha", "bravo", "charlie", "echo", "delta", "foxtrot")
A <- factor(sample(lev, 6000, TRUE))
B <- factor(sample(lev, 6000, TRUE))
Я хочу взять их внешний продукт с пользовательской функцией продукта, определенной следующим образом:
mapping <- matrix(c(
"green", "blue", "blue", "red", "red", "red",
"blue", "green", "blue", "red", "red", "red",
"blue", "blue", "green", "red", "red", "red",
"red", "red", "red", "green", "yellow", "red",
"red", "red", "red", "yellow", "green", "red",
"red", "red", "red", "red", "red", "green"),
nrow=6, ncol=6,
dimnames=list(lev, lev))
mapper <- function (X, Y) mapping[matrix(c(levels(X)[X], levels(Y)[Y]),
ncol=2, byrow=TRUE)]
A.B <- outer(A, B, FUN=mapper)
Ожидаемый результат (для значительно сокращенного тестового примера) должен быть чем-то вроде
> A
[1] alpha foxtrot echo charlie echo foxtrot bravo delta charlie
Levels: alpha bravo charlie delta echo foxtrot
> B
[1] alpha foxtrot delta bravo bravo alpha alpha bravo alpha
Levels: alpha bravo delta foxtrot
> outer(A, B, mapper)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
[1,] "red" "red" "red" "red" "red" "green" "green" "green" "green"
[2,] "red" "red" "red" "red" "red" "green" "green" "green" "green"
[3,] "red" "red" "red" "red" "red" "green" "green" "green" "green"
[4,] "red" "red" "red" "red" "red" "green" "green" "green" "green"
[5,] "blue" "blue" "blue" "blue" "blue" "red" "green" "green" "blue"
[6,] "red" "red" "red" "red" "green" "green" "green" "green" "green"
[7,] "red" "red" "red" "red" "green" "green" "green" "green" "green"
[8,] "red" "red" "red" "red" "green" "green" "green" "green" "green"
[9,] "red" "red" "red" "red" "green" "green" "green" "green" "green"
Это работает, но в полном объеме это неприятно медленно:
> system.time(outer(A, B, mapper))
user system elapsed
11.381 5.015 17.653
Кто-нибудь может порекомендовать более быстрый способ? В случае, если это помогает, матрица отображения гарантированно будет треугольной (т.е. mapping[a,b] == mapping[b,a] ∀ а, б.)
3 ответа
РЕДАКТИРОВАТЬ: Кажется, вопрос резко изменился, когда я отвечал, но оставить это здесь в любом случае.
Я предполагаю, что комментарий @joran верен, и вы имели в виду (и исправляете порядок в lev)
lev <- c("alpha", "bravo", "charlie", "delta", "echo", "foxtrot")
A <- factor(sample(lev, 6000, TRUE), levels=lev)
B <- factor(sample(lev, 6000, TRUE), levels=lev)
Также, mapping не является двумерным массивом (матрицей) или вложенной структурой данных (списком списков), как вы, кажется, думаете
> mapping
alpha.alpha alpha.bravo alpha.charlie alpha.delta alpha.echo
"green" "blue" "blue" "red" "red"
alpha.foxtrot bravo.alpha bravo.bravo bravo.charlie bravo.delta
"red" "blue" "green" "blue" "red"
bravo.echo bravo.foxtrot charlie.alpha charlie.bravo charlie.charlie
"red" "red" "blue" "blue" "green"
charlie.delta charlie.echo charlie.foxtrot delta.alpha delta.bravo
"red" "red" "red" "red" "red"
delta.charlie delta.delta delta.echo delta.foxtrot echo.alpha
"red" "green" "yellow" "red" "red"
echo.bravo echo.charlie echo.delta echo.echo echo.foxtrot
"red" "red" "yellow" "red" "red"
foxtrot.alpha foxtrot.bravo foxtrot.charlie foxtrot.delta foxtrot.echo
"red" "red" "red" "red" "red"
foxtrot.foxtrot
"green"
Теперь, если вы хотите сохранить это как список списков:
mapping <- list(
"alpha" = list("alpha"="green", "bravo"="blue", "charlie"="blue",
"delta"="red", "echo"="red", "foxtrot"="red"),
"bravo" = list("alpha"="blue", "bravo"="green", "charlie"="blue",
"delta"="red", "echo"="red", "foxtrot"="red"),
"charlie" = list("alpha"="blue", "bravo"="blue", "charlie"="green",
"delta"="red", "echo"="red", "foxtrot"="red"),
"delta" = list("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="green", "echo"="yellow", "foxtrot"="red"),
"echo" = list("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="yellow", "echo"="red", "foxtrot"="red"),
"foxtrot" = list("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="red", "echo"="red", "foxtrot"="green")
)
mapper = function(X, Y) mapping[[levels(X)[X]]][[levels(Y)[Y]]]
Обратите внимание, что я использую list вместо c в создании mapping и это mapper использует экстрактор ([[) не подмножество ([) обозначение.
Проверка это работает для одного значения:
> mapper(A[1], B[1])
[1] "red"
И только для нескольких значений:
> mapper(A[1:2], B[1:2])
Error in mapping[[levels(X)[X]]][[levels(Y)[Y]]] :
attempt to select more than one element
Итак, мы видим mapper не векторизовано (как и должно быть). Со страницы помощи outer:
FUNвызывается с этими двумя расширенными векторами в качестве аргументов. Следовательно, это должна быть векторизованная функция (или имя единицы), ожидающая не менее двух аргументов.
Простой, но не обязательно эффективный способ векторизации:
> Vectorize(mapper)(A[1:2], B[1:2])
[1] "red" "green"
Теперь это работает на подмножестве:
> outer(A[1:6], B[1:6], FUN=Vectorize(mapper))
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] "red" "yellow" "red" "red" "red" "red"
[2,] "red" "green" "red" "red" "red" "yellow"
[3,] "red" "green" "red" "red" "red" "yellow"
[4,] "blue" "red" "blue" "red" "blue" "red"
[5,] "green" "red" "green" "red" "green" "red"
[6,] "red" "red" "red" "green" "red" "red"
Давайте проверим время:
> system.time(outer(A[1:6], B[1:6], FUN=Vectorize(mapper)))
user system elapsed
0 0 0
> system.time(outer(A[1:60], B[1:60], FUN=Vectorize(mapper)))
user system elapsed
0.22 0.00 0.22
> system.time(outer(A[1:600], B[1:600], FUN=Vectorize(mapper)))
user system elapsed
23.97 0.01 24.01
Выглядит примерно линейно по длине внешнего произведения или квадратично по длине A или B. Я не ждал 40 минут, чтобы посмотреть, сработает ли 6000x6000.
Можем ли мы сделать это намного эффективнее? Двойная индексация в рекурсивную структуру (а затем необходимость использования Vectorize к тому же) это не так эффективно. Давайте использовать другую структуру данных: двумерный массив (матрица) и использовать индексирование на основе матрицы.
mapping <- matrix(c("green", "blue", "blue", "red", "red", "red",
"blue", "green", "blue", "red", "red", "red",
"blue", "blue", "green", "red", "red", "red",
"red", "red", "red", "green", "yellow", "red",
"red", "red", "red", "yellow", "red", "red",
"red", "red", "red", "red", "red", "green"),
nrow = 6, ncol = 6,
dimnames = list(lev, lev))
mapper <- function(X, Y) mapping[cbind(as.character(X), as.character(Y))]
И тестирование это
> A[1:6]
[1] echo delta delta charlie alpha foxtrot
Levels: alpha bravo charlie echo delta foxtrot
> B[1:6]
[1] alpha delta alpha foxtrot alpha echo
Levels: alpha bravo charlie echo delta foxtrot
> mapper(A[1], B[1])
[1] "red"
> mapper(A[1:2], B[1:2])
[1] "red" "green"
> outer(A[1:6], B[1:6], FUN=mapper)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] "red" "yellow" "red" "red" "red" "red"
[2,] "red" "green" "red" "red" "red" "yellow"
[3,] "red" "green" "red" "red" "red" "yellow"
[4,] "blue" "red" "blue" "red" "blue" "red"
[5,] "green" "red" "green" "red" "green" "red"
[6,] "red" "red" "red" "green" "red" "red"
Выглядит хорошо. Проверьте сроки:
> system.time(outer(A[1:6], B[1:6], FUN=mapper))
user system elapsed
0 0 0
> system.time(outer(A[1:60], B[1:60], FUN=mapper))
user system elapsed
0 0 0
> system.time(outer(A[1:600], B[1:600], FUN=mapper))
user system elapsed
0.22 0.00 0.22
> system.time(outer(A, B, FUN=mapper))
user system elapsed
7.80 1.48 9.30
Чуть более 9 секунд вместо ~40 минут для ускорения в 250 раз.
Так что ваши mapping переменная не совсем правильная. Если вы посмотрите на
str(mapping)
# Named chr [1:36] "green" "blue" "blue" "red" "red" "red" ...
# - attr(*, "names")= chr [1:36] "alpha.alpha" "alpha.bravo" "alpha.charlie" ...
Вы увидите, что это одномерный символьный вектор. Там имена элементов вставлены вместе с "." Я предполагаю, что это не то, что вы хотели. Возможно, вы использовали list() скорее, чем c()? Но если вы можете контролировать формат, почему бы не использовать простую матрицу
mapping <- structure(c("green", "blue", "blue", "red", "red", "red", "blue",
"green", "blue", "red", "red", "red", "blue", "blue", "green",
"red", "red", "red", "red", "red", "red", "green", "yellow",
"red", "red", "red", "red", "yellow", "red", "red", "red", "red",
"red", "red", "red", "green"), .Dim = c(6L, 6L), .Dimnames = list(
c("alpha", "bravo", "charlie", "echo", "delta", "foxtrot"
), c("alpha", "bravo", "charlie", "echo", "delta", "foxtrot"
)))
Так что есть строка и столбец для каждого значения lev и цвет ячейки - это цвет комбинации.
Тогда если вы делаете
#sample data
lev <- c("alpha", "bravo", "charlie", "echo", "delta", "foxtrot")
A <- factor(sample(lev, 6000, TRUE), levels=lev)
B <- factor(sample(lev, 6000, TRUE), levels=lev)
#run mapping
out <- outer(A, B, FUN=function(a,b) mapping[cbind(a,b)])
Теперь out будет иметь значения A вдоль строк и значения B вдоль столбцов и правильный цвет для взаимодействия между ними в качестве значения ячейки. Это работает довольно быстро
system.time(outer(A, B, FUN=function(a,b) mapping[cbind(a,b)]))
# user system elapsed
# 0.90 0.25 1.15
Я считаю, что это делает то, что вы хотите, примерно за 4 секунды (работает примерно в 4 раза быстрее, если вы не добавляете имена, но результат выглядит не так хорошо). Обратите внимание, очень важно: это работает, только если уровни одинаковы для A а также B и уровни такие же, как имена mapping.mx, Это потому что cbind приводит факторы к числовому, поэтому отображение является позиционным. Если не так, вы можете принуждать A а также B к характеру, и это будет работать, но будет еще медленнее.
names(A) <- A
names(B) <- B
mapping.mx <- do.call(rbind, mapping.lst) # see below for mapping.lst
system.time(res <- outer(A, B, function(x, y) mapping.mx[cbind(x, y)]))
# user system elapsed
# 3.33 0.62 3.95
str(res)
# chr [1:6000, 1:6000] "red" "green" "green" "blue" "green" "blue" ...
# - attr(*, "dimnames")=List of 2
# ..$ : chr [1:6000] "delta" "alpha" "alpha" "bravo" ...
# ..$ : chr [1:6000] "alpha" "alpha" "echo" "delta" ...
res[1:5, 1:5]
# alpha alpha echo delta charlie
# delta "red" "red" "yellow" "red" "red"
# alpha "green" "green" "red" "red" "blue"
# alpha "green" "green" "red" "red" "blue"
# bravo "blue" "blue" "red" "red" "blue"
# alpha "green" "green" "red" "red" "blue"
А также mapping.lst (в принципе, так же как и у вас, но поменял первый c к list):
mapping.lst <- list(
"alpha" = c("alpha"="green", "bravo"="blue", "charlie"="blue",
"delta"="red", "echo"="red", "foxtrot"="red"),
"bravo" = c("alpha"="blue", "bravo"="green", "charlie"="blue",
"delta"="red", "echo"="red", "foxtrot"="red"),
"charlie" = c("alpha"="blue", "bravo"="blue", "charlie"="green",
"delta"="red", "echo"="red", "foxtrot"="red"),
"delta" = c("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="green", "echo"="yellow", "foxtrot"="red"),
"echo" = c("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="yellow", "echo"="red", "foxtrot"="red"),
"foxtrot" = c("alpha"="red", "bravo"="red", "charlie"="red",
"delta"="red", "echo"="red", "foxtrot"="green")
)