如何与同一组中序列中相邻的值进行比较

时间：2016-08-19 09:05:10

标签： r

让我说我有这样的事情：

set.seed(0)
the.df <- data.frame( x=rep(letters[1:3], each=4),
                        n=rep(0:3, 3),
                        val=round(runif(12)))
the.df


   x n val
1  a 0   1
2  a 1   0
3  a 2   0
4  a 3   1
5  b 0   1
6  b 1   0
7  b 2   1
8  b 3   1
9  c 0   1
10 c 1   1
11 c 2   0
12 c 3   0

在每个x内，从n==2开始（从小到大），我想将val设置为0（如果是之前的val（就{ {1}}）为0;否则，保持原样。

例如，在子集n中，我首先忽略x=="b"＆lt; 2.现在，在第7行中，由于前一个n为0（val），我将the.df$val[the.df$x=="b" & the.df$n==1]设置为0（val）。然后在第8行，现在前一个the.df$val[the.df$x=="b" & the.df$n==2] <- 0的{​​{1}}为0（我们只是设置它），我还想将val设置为0（n）。

想象一下val没有排序。因此，依赖于订单的程序需要排序。我也不能假设存在相邻的行（例如，行the.df$val[the.df$x=="b" & the.df$n==3] <- 0可能会丢失）。

最棘手的部分似乎是按顺序评估data.frame。我可以使用循环来做到这一点，但我想它会效率低下（我有数百万行）。有没有办法可以更有效地做到这一点？

编辑：想要输出

the.df[the.df$x=="a" & the.df$n==1, ]

另外，我不介意制作新列（例如，将所需的值放在那里）。

4 个答案:

答案 0 :(得分：6)

使用data.table我会尝试以下

library(data.table)
setDT(the.df)[order(n), 
          val := if(length(indx <- which(val[2:.N] == 0L))) 
            c(val[1:(indx[1L] + 1L)], rep(0L, .N - (indx[1L] + 1L))), 
          by = x]
the.df
#     x n val
#  1: a 0   1
#  2: a 1   0
#  3: a 2   0
#  4: a 3   0
#  5: b 0   1
#  6: b 1   0
#  7: b 2   0
#  8: b 3   0
#  9: c 0   1
# 10: c 1   1
# 11: c 2   0
# 12: c 3   0

这将同时按n对数据进行排序（如您所说，它在现实生活中没有排序）并按条件重新创建val（意味着如果条件不满意，val将是不变）。

希望在不久的将来this将被实施，然后代码可能

setDT(the.df)[order(n), val[n > 2] := if(val[2L] == 0) 0L, by = x]

这可能是性能和语法方面的一个很大改进

答案 1 :(得分：3)

基础R方法可能

df <- the.df[order(the.df$x, the.df$n),]
df$val <- ave(df$val, df$x, FUN=fun)

关于fun，@ DavidArenburg在简单R中的回答并且写得更有诗意可能

fun0 <- function(v) {
    idx <- which.max(v[2:length(v)] == 0L) + 1L
    if (length(idx))
        v[idx:length(v)] <- 0L
    v
}

首先将解决方案公式化为独立函数似乎是个好主意，因为这样很容易测试。 fun0因某些边缘情况而失败，例如

> fun0(0)
[1] 0 0 0
> fun0(1)
[1] 0 0 0
> fun0(c(1, 1))
[1] 1 0

更好的版本是

fun1 <- function(v) {
    tst <- tail(v, -1) == 0L
    if (any(tst)) {
        idx <- which.max(tst) + 1L
        v[idx:length(v)] <- 0L
    }
    v
}

甚至更好，关注@Arun 

fun <- function(v)
    if (length(v) > 2) c(v[1], cummin(v[-1])) else v

这与data.table解决方案具有竞争性（相同的数量级），对于~m-dz的定时的~10m行数据帧，排序和返回发生在小于1s内。在数百万行的秒钟中，进行进一步优化似乎并不值得。

尽管如此，当存在非常多的小组（例如，大小为5的每个2M）时，改进是通过使用组标识来抵消最小值来避免tapply()函数调用。例如，

df <- df[order(df$x, df$n),]
grp <- match(df$x, unique(df$x))    # strictly sequential groups
keep <- duplicated(grp)             # ignore the first of each group
df$val[keep] <- cummin(df$val[keep] - grp[keep]) + grp[keep]

答案 2 :(得分：2)

嗯，如果切换到data.table ...

，应该非常有效率 
library(data.table)

# Define the.df as a data.table (or use data.table::setDT() function)
set.seed(0)
the.df <- data.table(
  x = rep(letters[1:3], each = 4),
  n = rep(0:3, 3),
  val = round(runif(12))
)

m_dz <- function() {
  setorder(the.df, x, n)
  repeat{
    # Get IDs of rows to change
    # ids <- which(the.df[, (n > 1) & (val == 1) & (shift(val, 1L, type = "lag") == 0)])
    ids <- the.df[(n > 1) & (val == 1) & (shift(val, 1L, type = "lag") == 0), , which = TRUE]
    # If no IDs break
    if(length(ids) == 0){
      break
    }
    # Set val to 0
    # for (i in ids) set(the.df, i = i, j = "val", value = 0)
    set(the.df, i = ids, j = "val", value = 0)
  }
  return(the.df)
}

编辑：由于@ jangorecki's，上面的功能略有修改，即使用which = TRUE和set(the.df, i = ids, j = "val", value = 0)，这使得时间更加稳定（没有非常高的最大时间）。

编辑：与@David Arenburgs在更大的桌子上的答案进行时间比较m-dz()更新（@ FoldedChromatin的答案由于不同的结果而跳过）。

我的功能在中位数和上分位数方面略快一些，但在时间上有很大的差异（见最大...），我无法弄清楚为什么。希望时序方法是正确的（将结果返回给不同的对象等）。

任何更大的东西都会杀死我的电脑:( 

set.seed(0)
groups_ids <- replicate(300, paste(sample(LETTERS, 5, replace=TRUE), collapse = ""))

size1 <- length(unique(groups_ids))
size2 <- round(1e7/size1)

the.df1 <- data.table(
  x = rep(groups_ids, each = size2),  # 52 * 500 = 26000
  n = rep(0:(size2-1), size1), 
  val = round(runif(size1*size2))
)

the.df2 <- copy(the.df1)

# m-dz
m_dz <- function() {
  setorder(df1, x, n)
  repeat{
    ids <- df1[(n > 1) & (val == 1) & (shift(val, 1L, type = "lag") == 0), , which = TRUE]
    if(length(ids) == 0){
      break
    }
    set(df1, i = ids, j = "val", value = 0)
  }
  return(df1)
}

# David Arenburg
DavidArenburg <- function() {
  setorder(df2, x, n)
  df2[, val := if(length(indx <- which.max(val[2:.N] == 0) + 1L)) c(val[1:indx], rep(0L, .N - indx)), by = x]
  return(df2)
}

library(microbenchmark)
microbenchmark(
  res1 <- m_dz(),
  res2 <- DavidArenburg(),
  times = 100
)

# Unit: milliseconds
#                    expr      min       lq     mean   median       uq       max neval cld
#          res1 <- m_dz() 247.4136 268.5005 363.0117 288.4216 312.7307 7071.0960   100   a
# res2 <- DavidArenburg() 270.6074 281.3935 314.7864 303.5229 328.1210  525.8095   100   a

identical(res1, res2)

# [1] TRUE

编辑：（旧）结果更大的表：

set.seed(0)
groups_ids <- replicate(300, paste(sample(LETTERS, 5, replace=TRUE), collapse = ""))

size1 <- length(unique(groups_ids))
size2 <- round(1e8/size1)

# Unit: seconds
#                     expr      min       lq     mean   median       uq       max neval cld
#           res1 <- m_dz() 5.599855 5.800264 8.773817 5.923721 6.021132 289.85107   100   a
#          res2 <- m_dz2() 5.571911 5.836191 9.047958 5.970952 6.123419 310.65280   100   a
#  res3 <- DavidArenburg() 9.183145 9.519756 9.714105 9.723325 9.918377  10.28965   100   a

答案 3 :(得分：0)

为什么不使用by 

> set.seed(0)
> the.df <- data.frame( x=rep(letters[1:3], each=4),
                        n=rep(0:3, 3),
                        val=round(runif(12)))
> the.df
   x n val
1  a 0   1
2  a 1   0
3  a 2   0
4  a 3   1
5  b 0   1
6  b 1   0
7  b 2   1
8  b 3   1
9  c 0   1
10 c 1   1
11 c 2   0
12 c 3   0

> Mod.df<-by(the.df,INDICES=the.df$x,function(x){
    x$val[x$n==2]=0 
    Which=which(x$n==2 & x$val==0)+1 
    x$val[Which]=0 
    x})

> do.call(rbind,Mod.df)
     x n val
a.1  a 0   1
a.2  a 1   0
a.3  a 2   0
a.4  a 3   0
b.5  b 0   1
b.6  b 1   0
b.7  b 2   0
b.8  b 3   0
c.9  c 0   1
c.10 c 1   1
c.11 c 2   0
c.12 c 3   0
相关问题
最新问题