Question

我正在R中编写一个Shiny应用程序，对于我的部分代码，我需要识别超出特定级别的数据帧的所有元素。诀窍是，每行的阈值不同。最终目标是有一个列表，其中元素[[1]]是一个两列数据帧，第一列是名称（取自原始列名称），第二列是执行（或没有，无论哪种方式）都通过布尔测试。

这是一个可重现的起点：

set.seed(20)
rows = 400
cols = 300
df <- data.frame(matrix(runif(rows*cols), nrow = rows), row.names = NULL)
colnames(df) <- paste0('col', 1:cols)
compare <- runif(rows)

df是原始数据，compare是应该与每行进行比较的值的向量。我已经编写了一个可以执行我想要的工作代码块，但它运行得相当慢，这对我的Shiny应用程序来说很麻烦。到达这个解决方案比我预期花了更长的时间，但我知道我并不总是最有效的程序员，特别是当它在R中应用循环时，所以我想知道是否有更快/更有效的方式这样做。

我目前的解决方案：

res <- lapply(1:nrow(df), function(x){
  currRow <- df[x,]
  tf <- currRow >= compare[x]
  ret2 <- data.frame(names(currRow)[tf], currRow[tf], row.names = NULL)
  colnames(ret2) <- c('Name', 'Value')
  ret2 <- ret2[complete.cases(ret2),]
  ret2 <- ret2[order(-ret2$Value),]
  return(ret2)
})

提前谢谢。

Answer 1

这里没什么特别的，只是利用data.table超快速排序和索引的优势。

这应该更快。

# Using apply (this is vectorized)
pes <- apply(df, 1, function(x){

    for(i in seq(compare))
    {
        # get indexes where the condition satisfies
        ix <- which(x >= compare[i])

        # get values
        val <- x[ix]

        # get column names
        nam <- names(x)[ix]

        # store above data
        df <- data.table(Name = nam, Value = val)
        df <- df[order(-Value)]
        df <- df[complete.cases(df)]
        return(df)
    }
})

Answer 2

lapply中的几乎所有代码都可以通过使用矩阵运算进行矢量化，从而使示例数据的性能提高约10倍。需要注意的关键是，您可以使用单个sweep进行所有比较以获得布尔值;其余的只是将结果纠缠在一个数据框列表中，同时确保每个原始行在列表中获得一个元素（即使没有列通过测试）：

f2 <- function() {
  x <- as.matrix(df)
  bool <- sweep(x, 1, compare, ">=")

  res <- data.frame(
    row   = as.vector(row(x)),
    Name  = colnames(x)[col(x)],
    Value = as.vector(x),
    pass  = as.vector(bool)
  )

  res <- res[order(-res$Value), ]

  lapply(split(res, res$row), function(x) {
    x <- x[complete.cases(x), ]
    x[x$pass, c("Name", "Value")]
  })
}

system.time(res1 <- f1()) # original
#>    user  system elapsed 
#>    3.17    0.02    3.18
system.time(res2 <- f2())
#>    user  system elapsed 
#>    0.27    0.01    0.28
all.equal(res1, res2, check.attributes = FALSE)
#> [1] TRUE

以下是设置：

set.seed(20)
rows <- 400
cols <- 300

df <- data.frame(matrix(runif(rows * cols), nrow = rows), row.names = NULL)
colnames(df) <- paste0('col', 1:cols)
compare <- runif(rows)

f1 <- function() {
  lapply(1:nrow(df), function(x){
    currRow <- df[x,]
    tf <- currRow >= compare[x]
    ret2 <- data.frame(names(currRow)[tf], currRow[tf], row.names = NULL)
    colnames(ret2) <- c('Name', 'Value')
    ret2 <- ret2[complete.cases(ret2),]
    ret2 <- ret2[order(-ret2$Value),]
    return(ret2)
  })
}

由reprex package创建于2018-03-17（v0.2.0）。

将数据帧行与不同的值进行比较，并提取true列表

2 个答案: