Performance 快速矢量化函数，用于检查值是否在间隔内

R中是否有一个函数可以有效地检查一个值是否大于一个值，是否小于另一个值？它也应该适用于向量

本质上，我正在寻找以下函数的更快版本：

> in.interval <- function(x, lo, hi) (x > lo & x < hi)
> in.interval(c(2,4,6), 3, 5)
[1] FALSE  TRUE FALSE

>in.interval lo&xin.区间（c（2,4,6,3,5）
[1] 假真假

这里的问题是，

x

必须被触摸两次，与更高效的方法相比，计算消耗的内存是前者的两倍。在内部，我假设它是这样工作的：

计算

tmp1 lo）

---

Compute

tmp2我能找到的主要加速是通过字节编译函数。即使是Rcpp解决方案（尽管使用Rcpp糖，而不是更深入的C解决方案）也比编译后的解决方案慢

library( compiler )
library( microbenchmark )
library( inline )

in.interval <- function(x, lo, hi) (x > lo & x < hi)
in.interval2 <- cmpfun( in.interval )
in.interval3 <- function(x, lo, hi) {
  sapply( x, function(xx) { 
    xx > lo && xx < hi }
          )
}
in.interval4 <- cmpfun( in.interval3 )
in.interval5 <- rcpp( signature(x="numeric", lo="numeric", hi="numeric"), '
NumericVector xx(x);
double lower = Rcpp::as<double>(lo);
double upper = Rcpp::as<double>(hi);

return Rcpp::wrap( xx > lower & xx < upper );
')

x <- c(2, 4, 6)
lo <- 3
hi <- 5

microbenchmark(
  in.interval(x, lo, hi),
  in.interval2(x, lo, hi),
  in.interval3(x, lo, hi),
  in.interval4(x, lo, hi),
  in.interval5(x, lo, hi)
)


编辑：在其他评论之后，这里有一个更快的Rcpp解决方案，使用给定绝对值的技巧：

library( compiler )
library( inline )
library( microbenchmark )

in.interval.oldRcpp <- rcpp( 
  signature(x="numeric", lo="numeric", hi="numeric"), '
    NumericVector xx(x);
    double lower = Rcpp::as<double>(lo);
    double upper = Rcpp::as<double>(hi);

    return Rcpp::wrap( (xx > lower) & (xx < upper) );
    ')

in.interval.abs <- rcpp( 
  signature(x="numeric", lo="numeric", hi="numeric"), '
    NumericVector xx(x);
    double lower = as<double>(lo);
    double upper = as<double>(hi); 

    LogicalVector out(x);
    for( int i=0; i < out.size(); i++ ) {
      out[i] = ( (xx[i]-lower) * (xx[i]-upper) ) <= 0;
    }
    return wrap(out);
    ')

in.interval.abs.sugar <- rcpp( 
  signature( x="numeric", lo="numeric", hi="numeric"), '
    NumericVector xx(x);
    double lower = as<double>(lo);
    double upper = as<double>(hi); 

    return wrap( ((xx-lower) * (xx-upper)) <= 0 );
    ')

x <- runif(1E5)
lo <- 0.5
hi <- 1

microbenchmark(
  in.interval.oldRcpp(x, lo, hi),
  in.interval.abs(x, lo, hi),
  in.interval.abs.sugar(x, lo, hi)
)

all.equal( in.interval.oldRcpp(x, lo, hi), in.interval.abs(x, lo, hi) )
all.equal( in.interval.oldRcpp(x, lo, hi), in.interval.abs.sugar(x, lo, hi) )

对于长x，
findInterval
比
in.interval
快

library(microbenchmark)

set.seed(123L)
x <- runif(1e6, 1, 10)
in.interval <- function(x, lo, hi) (x > lo & x < hi)

microbenchmark(
    findInterval(x, c(3, 5)) == 1L,
    in.interval(x, 3, 5),
    times=100)

如果不需要
==1L
，则速度更快；如果要找到的“间隔”大于1，则此功能非常有用

> system.time(findInterval(x, 0:10))
   user  system elapsed 
  3.644   0.112   3.763 

如果速度是关键，那么这个C实现虽然不能容忍整数而不是数字参数，但是速度很快

library(inline)
in.interval_c <- cfunction(c(x="numeric", lo="numeric", hi="numeric"),
'    int len = Rf_length(x);
     double lower = REAL(lo)[0], upper = REAL(hi)[0],
            *xp = REAL(x);
     SEXP out = PROTECT(NEW_LOGICAL(len));
     int *outp = LOGICAL(out);

     for (int i = 0; i < len; ++i)
         outp[i] = (xp[i] - lower) * (xp[i] - upper) <= 0;

     UNPROTECT(1);
     return out;')

与

在bin.cpp文件中重新讨论速度问题

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
SEXP bin1(SEXP x, SEXP lo, SEXP hi)
{
    const int len = Rf_length(x);
    const double lower = REAL(lo)[0], upper = REAL(hi)[0];
    SEXP out = PROTECT(Rf_allocVector(LGLSXP, len));

    double *xp = REAL(x);
    int *outp = LOGICAL(out);
    for (int i = 0; i < len; ++i)
    outp[i] = (xp[i] - lower) * (xp[i] - upper) <= 0;

    UNPROTECT(1);
    return out;
}

// [[Rcpp::export]]
LogicalVector bin2(NumericVector x, NumericVector lo, NumericVector hi)
{
    NumericVector xx(x);
    double lower = as<double>(lo);
    double upper = as<double>(hi); 

    LogicalVector out(x);
    for( int i=0; i < out.size(); i++ )
        out[i] = ( (xx[i]-lower) * (xx[i]-upper) ) <= 0;

    return out;
}

// [[Rcpp::export]]
LogicalVector bin3(NumericVector x, const double lower, const double upper)
{
    const int len = x.size();
    LogicalVector out(len);

    for (int i=0; i < len; i++)
        out[i] = ( (x[i]-lower) * (x[i]-upper) ) <= 0;

    return out;
}

使用常量
len
而不是
out.size（）
作为循环边界，并在不初始化逻辑向量的情况下分配逻辑向量（因为它将在循环中初始化，所以速度大约相等）。
如果可以处理
NA
s，您可以使用
.bincode
：

.bincode(c(2,4,6), c(3, 5))
[1] NA  1 NA

library(microbenchmark)
set.seed(42)
x = runif(1e8, 1, 10)
microbenchmark(in.interval(x, 3, 5),
               findInterval(x,  c(3, 5)),
               .bincode(x, c(3, 5)),
               times=5)

Unit: milliseconds
                      expr       min        lq    median       uq      max
1     .bincode(x, c(3, 5))  930.4842  934.3594  955.9276 1002.857 1047.348
2 findInterval(x, c(3, 5)) 1438.4620 1445.7131 1472.4287 1481.380 1551.419
3     in.interval(x, 3, 5) 2977.8460 3046.7720 3075.8381 3182.013 3288.020

正如@James在评论中所说的，诀窍是从x中减去low和high之间的中间值，然后检查该差值是否小于low和high之间距离的一半。或者，在代码中：

in.interval2 <- function(x, lo, hi) {
    abs(x-(hi+lo)/2) < (hi-lo)/2 
}

给予

对于1e8值，该函数在我的计算机上大约需要12秒。你想让它快多少？通过只访问一次x，您将如何准确地检查两个条件？你能告诉我们你想要的“更有效的方法”吗？@JorisMeys:6秒左右就好了：-）稍后会编辑这个问题。也许
findInterval
可以获得你问题的矢量化版本？@JorisMeys
abs（x-（hi+lo）/2-（hi-lo）/2<0
@James Thx。我已经弄明白了，但希望OP能利用充满他/她的大脑的灰质做点努力：）。当你把它放在评论中时，如果你愿意，你也可以给出答案。你检查过你的函数返回了什么吗？他们不一样
&&
只计算其操作数的第一个元素。哎呀，你说得对极了。你可以想象将调用包装在
sapply
或
map
中，但这仍然比其他解决方案慢。我已将您的代码放入要点中：。但是，它没有在我的系统上编译（Ubuntu12.10，最新的CRAN版本）：
编译代码中的错误（f，code，language=language，verbose=verbose）：…
，
错误：与…
@user946850中的“operator&”不匹配您使用的是
Rcpp
的最新版本吗？我相信，
&
操作符是在rcpp0.10.0中作为语法糖添加的；看见FWIW，它在Mac OS、R2.15.2、Rcpp_0.10.1上编译得很好。@user946850我在gist中添加了一个潜在的解决方案。应该使用0.10之前的Rcpp版本编译，但可能会稍微慢一点。或者，我可以想象，您应该能够在R会话中使用
install.packages（“Rcpp”，type=“source”）
从CRAN获得最新版本。我已经将您的解决方案嵌入了gist中。对于1E6元素，它的工作速度比和方法快，但是使用C++仍能使它倍增两倍。在RcppNow，大对象的重复对我来说是一件令人困惑的事情。在我的系统上，您给出的C解决方案实际上比简单的
x
运行得更快（大约2倍）（尝试将
x>lo&x
，
x
添加到基准测试中查看）。这是怎么发生的？我认为R中操作符的底层C实现已经相当优化了？或者，与我编译C函数时可能发生的任何事情相比，R的二进制版本是否以“安全”的方式编译？@CauchyDistributedRV
x
需要分配与我的代码相同数量的内存（用于返回逻辑），这两个函数都需要迭代所有值，很可能C编译器已经优化了我的
循环体，使之比高级语法所暗示的操作少得多，因此这两个循环的基本成本可能是相当的。R也会做很多我们认为理所当然的事情，例如，处理NAs，回收
hi
（一般来说，不仅仅是长度为1的特殊情况），检查数据类型之间是否需要强制，等等@user946850我稍微研究了一下速度差异，并在我的回答中添加了一部分。内部函数的巧妙使用。您可以通过
获得答案！is.na（.bincode（…）
。bincode
将其参数转换为整数，因此（在当前上下文中）会产生令人惊讶的结果--
。bincode（3.1,3,5）
是“na”；测试每种方法的结果的一致性。哦，我不好，很抱歉。适用于平面，只是比Rcpp ed解决方案稍微慢一点。这个想法很好，但在我的机器上，它比
.bincode
慢得多，而且Rcpp版本的性能与内部使用
&
的最好的其他Rcpp版本一样。查看结果要点（这里是测试7和8）。关于
（x-lo）*（hi-x）>0
？@Roland:
（x-lo）*（x-hi）当我在做的时候：你和罗兰的方法似乎都不允许测试左包含右独占（或者相反）
.bincode
可以做任何事情，除了左独占右独占（带
microbenchmark(
    findInterval(x, c(3, 5)) == 1L,
    in.interval.abs(x, 3, 5),
    in.interval(x, 3, 5),
    in.interval_c(x, 3, 5),
    !is.na(.bincode(x, c(3, 5))),
    times=100)

Unit: milliseconds
                            expr       min        lq    median        uq
1 findInterval(x, c(3, 5)) == 1L 23.419117 23.495943 23.556524 23.670907
2       in.interval.abs(x, 3, 5) 12.018486 12.056290 12.093279 12.161213
3         in.interval_c(x, 3, 5)  1.619649  1.641119  1.651007  1.679531
4           in.interval(x, 3, 5) 42.946318 43.050058 43.171480 43.407930
5   !is.na(.bincode(x, c(3, 5))) 15.421340 15.468946 15.520298 15.600758
        max
1 26.360845
2 13.178126
3  2.785939
4 46.187129
5 18.558425

#include <Rcpp.h>

using namespace Rcpp;

// [[Rcpp::export]]
SEXP bin1(SEXP x, SEXP lo, SEXP hi)
{
    const int len = Rf_length(x);
    const double lower = REAL(lo)[0], upper = REAL(hi)[0];
    SEXP out = PROTECT(Rf_allocVector(LGLSXP, len));

    double *xp = REAL(x);
    int *outp = LOGICAL(out);
    for (int i = 0; i < len; ++i)
    outp[i] = (xp[i] - lower) * (xp[i] - upper) <= 0;

    UNPROTECT(1);
    return out;
}

// [[Rcpp::export]]
LogicalVector bin2(NumericVector x, NumericVector lo, NumericVector hi)
{
    NumericVector xx(x);
    double lower = as<double>(lo);
    double upper = as<double>(hi); 

    LogicalVector out(x);
    for( int i=0; i < out.size(); i++ )
        out[i] = ( (xx[i]-lower) * (xx[i]-upper) ) <= 0;

    return out;
}

// [[Rcpp::export]]
LogicalVector bin3(NumericVector x, const double lower, const double upper)
{
    const int len = x.size();
    LogicalVector out(len);

    for (int i=0; i < len; i++)
        out[i] = ( (x[i]-lower) * (x[i]-upper) ) <= 0;

    return out;
}

> library(Rcpp)
> sourceCpp("bin.cpp")
> microbenchmark(bin1(x, 3, 5), bin2(x, 3, 5), bin3(x, 3, 5),                   
+                in.interval_c(x, 3, 5), times=1000)                            
Unit: milliseconds                                                              
                    expr       min        lq    median        uq      max       
1          bin1(x, 3, 5)  1.546703  2.668171  2.785255  2.839225 144.9574       
2          bin2(x, 3, 5) 12.547456 13.583808 13.674477 13.792773 155.6594       
3          bin3(x, 3, 5)  2.238139  3.318293  3.357271  3.540876 144.1249       
4 in.interval_c(x, 3, 5)  1.545139  2.654809  2.767784  2.822722 143.7500       

.bincode(c(2,4,6), c(3, 5))
[1] NA  1 NA

library(microbenchmark)
set.seed(42)
x = runif(1e8, 1, 10)
microbenchmark(in.interval(x, 3, 5),
               findInterval(x,  c(3, 5)),
               .bincode(x, c(3, 5)),
               times=5)

Unit: milliseconds
                      expr       min        lq    median       uq      max
1     .bincode(x, c(3, 5))  930.4842  934.3594  955.9276 1002.857 1047.348
2 findInterval(x, c(3, 5)) 1438.4620 1445.7131 1472.4287 1481.380 1551.419
3     in.interval(x, 3, 5) 2977.8460 3046.7720 3075.8381 3182.013 3288.020

in.interval2 <- function(x, lo, hi) {
    abs(x-(hi+lo)/2) < (hi-lo)/2 
}

x <- runif(1e6,1,10)
require(rbenchmark)
benchmark(
  in.interval(x, 3, 5),
  in.interval2(x, 3, 5),
  findInterval(x, c(3, 5)) == 1,
  !is.na(.bincode(x, c(3, 5))),
  order='relative',
  columns=c("test", "replications", "elapsed", "relative")
) 

                           test replications elapsed relative
4  !is.na(.bincode(x, c(3, 5)))          100    1.88    1.000
2         in.interval2(x, 3, 5)          100    1.95    1.037
3 findInterval(x, c(3, 5)) == 1          100    3.42    1.819
1          in.interval(x, 3, 5)          100    3.54    1.883