Быстрое минимальное расстояние (интервал) между элементами 2 логических векторов (дубль 2)

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

       x     y
1  FALSE  TRUE
2  FALSE FALSE
3   TRUE FALSE
4  FALSE FALSE
5  FALSE  TRUE
6  FALSE FALSE
7  FALSE FALSE
8   TRUE FALSE
9  FALSE  TRUE
10  TRUE  TRUE
11 FALSE FALSE
12 FALSE FALSE
13 FALSE FALSE
14 FALSE  TRUE
15  TRUE FALSE
16 FALSE FALSE
17  TRUE  TRUE
18 FALSE  TRUE
19 FALSE FALSE
20 FALSE  TRUE
21 FALSE FALSE
22 FALSE FALSE
23 FALSE FALSE
24 FALSE FALSE
25  TRUE FALSE

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

## MWE EXAMPLE: THE DATA
x <- y <- rep(FALSE, 25)
x[c(3, 8, 10, 15, 17, 25)] <- TRUE
y[c(1, 5, 9, 10, 14, 17, 18, 20)] <- TRUE

## Code to Find Distances
xw <- which(x)
yw <- which(y)

min_dist <- function(xw, yw) {
    unlist(lapply(xw, function(x) {
        min(abs(x - yw))
    }))
}

min_dist(xw, yw)

Есть ли способ улучшить производительность в базе R? С помощью dplyr или же data.table?

Мои векторы намного длиннее (10000 + элементов).

Отредактируйте за скамью Флоделя. flodel есть проблема, которую я ожидал в своем MWE, и я не уверен, как ее исправить. Проблема возникает, если любая позиция x меньше минимальной позиции y.

x <- y <- rep(FALSE, 25)
x[c(3, 8, 9, 15, 17, 25)] <- TRUE
y[c(5, 9, 10, 13, 15, 17, 19)] <- TRUE


xw <- which(x)
yw <- which(y)

flodel <- function(xw, yw) {
   i <- findInterval(xw, yw)
   pmin(xw - yw[i], yw[i+1L] - xw, na.rm = TRUE)
}

flodel(xw, yw)

## [1] -2 -1 -6 -2 -2 20
## Warning message:
## In xw - yw[i] :
##   longer object length is not a multiple of shorter object length
Источник

2 ответа

Решение
flodel <- function(x, y) {
  xw <- which(x)
  yw <- which(y)
  i <- findInterval(xw, yw, all.inside = TRUE)
  pmin(abs(xw - yw[i]), abs(xw - yw[i+1L]), na.rm = TRUE)
}

GG1 <- function(x, y) {
  require(zoo)
  yy <- ifelse(y, TRUE, NA) * seq_along(y)
  fwd <- na.locf(yy, fromLast = FALSE)[x]
  bck <- na.locf(yy, fromLast = TRUE)[x]
  wx <- which(x)
  pmin(wx - fwd, bck - wx, na.rm = TRUE)
}

GG2 <- function(x, y) {
  require(data.table)
  dtx <- data.table(x = which(x))
  dty <- data.table(y = which(y), key = "y")
  dty[dtx, abs(x - y), roll = "nearest"] 
}

Пример данных:

x <- y <- rep(FALSE, 25)
x[c(3, 8, 10, 15, 17, 25)] <- TRUE
y[c(1, 5, 9, 10, 14, 17, 18, 20)] <- TRUE

X <- rep(x, 100)
Y <- rep(y, 100)

Модульный тест:

identical(flodel(X, Y), GG1(X, Y))
# [1] TRUE

тесты:

library(microbenchmark)
microbenchmark(flodel(X,Y), GG1(X,Y), GG2(X,Y))
# Unit: microseconds
#          expr       min         lq     median        uq        max neval
#  flodel(X, Y)   115.546   131.8085   168.2705   189.069   1980.316   100
#     GG1(X, Y)  2568.045  2828.4155  3009.2920  3376.742  63870.137   100
#     GG2(X, Y) 22210.708 22977.7340 24695.7225 28249.410 172074.881   100

[Отредактировано Мэттом Доулом] 24695 микросекунд = 0,024 секунды. Выводы, сделанные на микробенчмарках с крошечными данными, редко содержат значимые размеры данных.

[Редактировать flodel] Мои векторы имели длину 2500, что было довольно значимым, учитывая утверждение Тайлера (10k), но хорошо, давайте попробуем с векторами длины 2.5e7. Я надеюсь, что вы простите меня за использование system.time учитывая обстоятельства:

X <- rep(x, 1e6)
Y <- rep(y, 1e6)
system.time(flodel(X,Y))
#    user  system elapsed 
#   0.694   0.205   0.899 
system.time(GG1(X,Y))
#    user  system elapsed 
#  31.250  16.496 112.967 
system.time(GG2(X,Y))
# Error in `[.data.table`(dty, dtx, abs(x - y), roll = "nearest") : 
#   negative length vectors are not allowed

[Правка из Аруна] - Тест для 2.5e7 с использованием 1.8.11:
[Редактировать 2 из Аруна] - Обновление времени после недавнего более быстрого двоичного поиска / слияния Мэтта

require(data.table)
arun <- function(x, y) {
    dtx <- data.table(x=which(x))
    setattr(dtx, 'sorted', 'x')
    dty <- data.table(y=which(y))
    setattr(dty, 'sorted', 'y')
    dty[, y1 := y]
    dty[dtx, roll="nearest"][, abs(y-y1)]
}

# minimum of three consecutive runs
system.time(ans1 <- arun(X,Y))
#   user  system elapsed 
#  1.036   0.138   1.192 

# minimum of three consecutive runs
system.time(ans2 <- flodel(X,Y))
#   user  system elapsed 
#  0.983   0.197   1.221 

identical(ans1, ans2) # [1] TRUE
Источник

Вот два решения. Ни используйте цикл, ни примените функцию.

1) Первое совпадает с решением, которое я разместил на ваш предыдущий вопрос, если z равно 1, за исключением того, что упрощенные предположения позволяют нам несколько сократить его, и мы сократили ответ на 1 относительно этого.

library(zoo)

yy <- ifelse(y, TRUE, NA) * seq_along(y)
fwd <- na.locf(yy, fromLast = FALSE)[x]
bck <- na.locf(yy, fromLast = TRUE)[x]
wx <- which(x)
pmin(wx - fwd, bck - wx, na.rm = TRUE)

2) Второе решение - data.table. data.table может занять roll="nearest" аргумент, который кажется именно то, что вам нужно:

library(data.table)

dtx <- data.table(x = which(x))
dty <- data.table(y = which(y), key = "y")
dty[dtx, abs(x - y), roll = "nearest"]

Я не уверен, если это имеет значение, но я использую data.table версии 1.8.11 (версия CRAN в настоящее время 1.8.10).

Источник
Другие вопросы по тегам