Быстрое ограничение данных в R

Предположим, что у меня есть вектор vec, который длинный (начиная с 1E8 записей) и хотел бы связать его с диапазоном [a,b]. Я могу, конечно, кодировать vec[vec < a] = a и vec[vec > b] = b, но для этого требуется два прохода над данными и большое распределение памяти для временного индикаторного вектора (~ 800 МБ, дважды). Два прохода горит, потому что мы можем сделать лучше, если мы скопируем данные из основной памяти в локальный кеш только один раз (звонки в основную память плохие, как и промахи в кеше). И кто знает, насколько это может быть улучшено с помощью нескольких потоков, но пусть не станет жадным.:)

Есть ли хорошая реализация в базе R или какой-то пакет, который я пропускаю, или это работа для Rcpp (или моего старого друга data.table)?

Ответ 1

Наивное решение C

library(inline)

fun4 <-
    cfunction(c(x="numeric", a="numeric", b="numeric"), body4,
              language="C")
body4 <- "
    R_len_t len = Rf_length(x);
    SEXP result = Rf_allocVector(REALSXP, len);
    const double aa = REAL(a)[0], bb = REAL(b)[0], *xp = REAL(x);
    double *rp = REAL(result);

    for (int i = 0; i < len; ++i)
        if (xp[i] < aa)
            rp[i] = aa;
        else if (xp[i] > bb)
            rp[i] = bb;
        else
            rp[i] = xp[i];

    return result;
"
fun4 <-
    cfunction(c(x="numeric", a="numeric", b="numeric"), body4,
              language="C")

С простой параллельной версией (как указывает Дирк, это с CFLAGS = -fopenmp в ~/.R/Makevars и на платформе/компиляторе, поддерживающей openmp)

body5 <- "
    R_len_t len = Rf_length(x);
    const double aa = REAL(a)[0], bb = REAL(b)[0], *xp = REAL(x);
    SEXP result = Rf_allocVector(REALSXP, len);
    double *rp = REAL(result);

#pragma omp parallel for
    for (int i = 0; i < len; ++i)
        if (xp[i] < aa)
            rp[i] = aa;
        else if (xp[i] > bb)
            rp[i] = bb;
        else
            rp[i] = xp[i];

    return result;
"
fun5 <-
    cfunction(c(x="numeric", a="numeric", b="numeric"), body5,
              language="C")

И тесты

> z <- runif(1e7)
> benchmark(fun1(z,0.25,0.75), fun4(z, .25, .75), fun5(z, .25, .75),
+           replications=10)
                 test replications elapsed  relative user.self sys.self
1 fun1(z, 0.25, 0.75)           10   9.087 14.609325     8.335    0.739
2 fun4(z, 0.25, 0.75)           10   1.505  2.419614     1.305    0.198
3 fun5(z, 0.25, 0.75)           10   0.622  1.000000     2.156    0.320
  user.child sys.child
1          0         0
2          0         0
3          0         0
> identical(res1 <- fun1(z,0.25,0.75), fun4(z,0.25,0.75))
[1] TRUE
> identical(res1, fun5(z, 0.25, 0.75))
[1] TRUE

на моем четырехъядерном ноутбуке. Принимает числовой ввод, проверку ошибок, обработку НС и т.д.

Ответ 2

Просто для начала: неважно разница между вашим решением и решением pmin/pmax (пробовать вещи с n = 1e7, а не n = 1e8, потому что я нетерпелив) - pmin/pmax на самом деле незначительно медленнее.

fun1 <- function(x,a,b) {x[x<a] <- a; x[x>b] <- b; x}
fun2 <- function(x,a,b) pmin(pmax(x,a),b)
library(rbenchmark)
z <- runif(1e7)

benchmark(fun1(z,0.25,0.75),fun2(z,0.25,0.75),rep=50)

                 test replications elapsed relative user.self sys.self
1 fun1(z, 0.25, 0.75)           10  21.607  1.00000     6.556   15.001
2 fun2(z, 0.25, 0.75)           10  23.336  1.08002     5.656   17.605