R 矢量化入口和出口

我想知道是否有一种矢量化的方法可以返回以下内容：

我有一个向量=

x = c(-4,-3,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12,11,10,9,8,7,6,5,4,3,2,1,0,-1,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12)

我想得到一个相同长度的向量，当它超过5时，它将设置为1（真），直到它下降到0（假）以下。我目前正在做一个for循环，如果上面的系列有大量的观察结果，这个循环将永远持续下去

答案应返回：

results = c(0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1)

---

有什么想法吗？

您可以使用逻辑值识别更改点，并查找该状态的更改：

findChangePoint <- function(y,cp){
  results <- 0*y
  state = 0 
  i = 1
  while (i <= length(y)){
    if((state ==0 ) & (y[i] >max(cp))){
      state = 1
    }
    if ((state == 1) && (y[i] <= min(cp))){
      state = 0
    }
    results[i] = state
    i = i+1
  }
  return(results)
}

---

findChangePoint使用软件包
zoo
，您可以使用：

results2 <- na.locf(c(NA,1,0)[(x>=5) + 2*(x<=0) + 1],na.rm=FALSE)

identical(results2, results)
#[1] TRUE

results2=5）+2*（xUPDATE：编辑、测试并添加基准测试。
（很抱歉，我昨天无法测试）


这是一个基本上是纯逻辑比较的解决方案，比
zoo

identical(results, UpAndDown(x))
# [1] TRUE

## 2,000 iterations, less than 0.1 seconds. 
> system.time(for(i in 1:2000) UpAndDown(x))
   user  system elapsed 
  0.080   0.001   0.082 

UpAndDown <- function(x, lowBound=0, upBound=5, numeric=TRUE) {
  ## This gets most of it
  high <-  (x >= upBound)
  low  <-  (x <= lowBound)

  res <- high & !low

  ## This grabs the middle portions
  fvs <- which(x==upBound)  
  zrs <- which(x==lowBound) 

  # The middle spots are those where zrs > fvs
  m <- which(zrs > fvs)

  # This is only iterating over a vector of a handufl of indecies
  #  It's not iterating over x
  mids <- unlist(lapply(m, function(i) seq(fvs[i], zrs[i]-1)), use.names=FALSE)
  res[mids] <- TRUE

  if (numeric)
    res <- as.numeric(res)

  # logical
  return(res)

}

这很难看，但它似乎适用于非常复杂的场景：

entex <- function(x,uplim,lwlim) {

  result <- vector("integer",0)
  upr <- which(x>=uplim)
  lwr <- which(x<=lwlim)

  while(length(upr) > 0) {
    if(min(upr) > max(lwr)) {
      result <- unique(c(result,upr))
      upr <- upr[upr > max(result)]
    } else
    {
      result <- unique(c(result,upr[1]:(min(lwr[lwr>upr[1]])-1)))
      lwr <- lwr[lwr > max(result)]
      upr <- upr[upr > max(result)]
    }
  }
  result
}

这真是一个很长的评论。。。
我突然想到这就是施密特触发器（opamp）的作用。这让我想知道是否有办法在可重置条件下运行
while
循环

limits <- c(5,0)
flop = 1
threshold<-limits[1]
for(j in 1:length(x) {

 while(x*(-1^(1-flop) < threshold) { 
do_stuff
}
threshold<-limits[flop+1]
flop <- !flop
}

限制您可以使用
rle（）
并避免编写for/while循环：

x <- c(-4,-3,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12,11,10,9,8,7,6,5,4,3,2,1,0,-1,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12)

result <- rep(99, length(x))
result[x >= 5] <- 1
result[x <= 0] <- 0

result
#  [1]  0  0  0  0  0 99 99 99 99  1  1  1  1  1  1  1  1  1  1  1  1  1  1  1 99
# [26] 99 99 99  0  0  0  0  0 99 99 99 99  1  1  1  1  1  1  1  1

# Run-length-encode it
result_rle <- rle(result)
# Find the 99's and replace them with the previous value
missing_idx <- which(result_rle$values == 99)
result_rle$values[missing_idx] <- result_rle$values[missing_idx - 1]
# Inverse of the RLE
result <- inverse.rle(result_rle)

# Check value
expected <- c(0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1)
identical(result, expected)
# TRUE

x看一下seq——它做的和你想用粘贴做的一样，除了
seq（）
不适用于向量，这就是我在
cp.up
和
cp.down
中所做的。结果证明答案是使用mapply。这不是一个预言家，但我可以打破这个答案，例如：
x@我怀疑Andy最近的邮件只允许使用整数值。使用类似的方法重新处理以浏览数据施密特触发器。我希望我能找到一个不需要询问每一行的解决方案。我喜欢漂亮的图片。：）+1不错，但我对使用
x==5
等浮点数非常谨慎。或者你的意思是
x>=5
？还有一件事：OP没有指定在中间区域启动时要做什么（
0@CarlWitthoft谢谢，为了避免浮点数出现问题，我改为
x>=5
。我很感兴趣。这是否适用于@thelatemail建议的更复杂的数据集？以及，它是如何工作的？@AndyClifton好的，为什么不复制代码并尝试一下呢？：-）。工作原理：将其分解。如果执行内部
c（NA，1,0）[（x>=5）+2*（x原始帖子是昨天从我的手机上发的。很抱歉，我无法测试它。它现在正在工作
# Small x
microbenchmark(UpAndDown=UpAndDown(x), Entex=entex(x,5,0), ZOO=na.locf(c(NA,1,0)[(x==5) + 2*(x<=0) + 1],na.rm=FALSE))

Unit: microseconds
      expr    min      lq  median      uq     max neval
 UpAndDown 31.573 36.1965 42.4240 46.9765 146.599   100
     Entex 40.113 46.1030 51.9605 57.3170 114.269   100
       ZOO 60.169 68.7335 78.2480 83.0360 176.159   100

# With Larger x

x <- c(seq(-10, 10), seq(11, -7), seq(-8, 15), seq(16, -28), seq(-29, 100), seq(101, -9)) 
x <- c(x, x, x)
length(x)
# [1] 1050

## CONFIRM VALUES
identical(UpAndDown(x), na.locf(c(NA,1,0)[(x==5) + 2*(x<=0) + 1]))
# [1] TRUE

## Benchmark
microbenchmark(
    UpAndDown=UpAndDown(x), 
    fcp=findChangePoint(x, c(5,1)), 
    Entex=entex(x,5,0), 
    ZOO=na.locf(c(NA,1,0)[(x==5) + 2*(x<=0) + 1],na.rm=FALSE)
  )

Unit: microseconds
      expr      min        lq    median        uq       max neval
 UpAndDown  141.149  162.9125  183.8080  206.9560   403.528   100
       fcp 5719.692 6056.1760 6379.4355 7376.7370 21456.502   100
     Entex  416.570  446.8780  469.7845  501.0985   795.853   100
       ZOO  192.449  209.1260  249.3805  281.4820   489.416   100

  ## ----------------------------##
    fvs <- which(high)
    zrs <- which(low)

    # This is only iterating over a vector of a handufl of indecies
    #  It's not iterating over x
    mids <- unlist(sapply(fvs, function(x) {
                                Z <- x<zrs; 
                                if (any(Z)) 
                                  seq(x, zrs[min(which(Z), na.rm=TRUE)]-1)
                            }
                  ), use.names=FALSE)

entex <- function(x,uplim,lwlim) {

  result <- vector("integer",0)
  upr <- which(x>=uplim)
  lwr <- which(x<=lwlim)

  while(length(upr) > 0) {
    if(min(upr) > max(lwr)) {
      result <- unique(c(result,upr))
      upr <- upr[upr > max(result)]
    } else
    {
      result <- unique(c(result,upr[1]:(min(lwr[lwr>upr[1]])-1)))
      lwr <- lwr[lwr > max(result)]
      upr <- upr[upr > max(result)]
    }
  }
  result
}

plot(x,pch=19,type="o")
abline(h=c(0,5),col="lightblue")
result <- entex(x,5,0)
abline(v=result,col="red")

x <- c(-0.6, -0.3, 0.5, 0.6, 3, 4.1, 6.7, 3.7, 7.5, 4.1, 6.8, 4.8, 3.3,
       1.6, 3.1, 2, 1.3, 2.9, 2.8, 1.9, 0, -0.5, -0.6, 0.3, 1.9, 5.1, 6.4)

limits <- c(5,0)
flop = 1
threshold<-limits[1]
for(j in 1:length(x) {

 while(x*(-1^(1-flop) < threshold) { 
do_stuff
}
threshold<-limits[flop+1]
flop <- !flop
}

x <- c(-4,-3,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12,11,10,9,8,7,6,5,4,3,2,1,0,-1,-2,-1,0,1,2,3,4,5,6,7,8,9,10,11,12)

result <- rep(99, length(x))
result[x >= 5] <- 1
result[x <= 0] <- 0

result
#  [1]  0  0  0  0  0 99 99 99 99  1  1  1  1  1  1  1  1  1  1  1  1  1  1  1 99
# [26] 99 99 99  0  0  0  0  0 99 99 99 99  1  1  1  1  1  1  1  1

# Run-length-encode it
result_rle <- rle(result)
# Find the 99's and replace them with the previous value
missing_idx <- which(result_rle$values == 99)
result_rle$values[missing_idx] <- result_rle$values[missing_idx - 1]
# Inverse of the RLE
result <- inverse.rle(result_rle)

# Check value
expected <- c(0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1)
identical(result, expected)
# TRUE