如何在使用应用函数时添加要排除的条件

Question

假设我有这种格式的数据：

   playerID sp rp c 1b 2b 3b ss of dh primary
1  adamja01  0 31 0  4  0  0  0  0  0      RP
2 adamsau02  0  2 0  0  0  1  3  0  0      RP
3 adamsch01  1  2 0  6  0  0  0  0  0      RP
4 alberma01  0 34 0  0  0  0  0  0  0      RP
5 alcansa01  6  0 0  0  0  0  0  0  0      SP
6 alcanvi01  0 27 0  0  0  0  0  0  0      RP

我需要创建一个新列，它是一个字符串。该字符串列出给定行的值超过某个阈值的任何列名。

假设阈值存储在向量posThresh中，则可以使用以下方法获得所需的内容：

positions$altPos <- apply(positions[, 2:10], 1, function(x) 
  toString(names(positions)[2:10][x >= posThresh]))

此函数添加以下列：

     playerID sp rp  c 1b 2b 3b ss of dh  primary altPos
1    adamja01  0 31  0  0  0  0  0  0  0       RP     RP
2   adamsau02  0  2  0  0  0  0  0  0  0       RP     RP
3   adamsch01  1  2  0  0  0  0  0  0  0       RP  SP,RP
4   alberma01  0 34  0  0  0  0  0  0  0       RP     RP
5   alcansa01  6  0  0  0  0  0  0  0  0       SP     SP
6   alcanvi01  0 27  0  0  0  0  0  0  0       RP     RP

在第3行中，primary下的值现在在altPos下重复。但是，RP值在altPos下不是来自primary，而是来自列名rp。是否有一种方法可以生成相同的信息，但从字符串中排除与primary值相等的任何值？

基本上，任何超过阈值且不等于primary的列.我只是不能把格式写下来：>= threshold && <> primary

Answer 1

你可以这样调整你的功能。

posThresh <- 1

positions$altPos <- 
  apply(positions, 1, 
        function(x) {
          raw <- names(positions)[2:10][x[2:10] >= posThresh]
          excl <- tolower(as.character(x[grep("primary", names(positions))]))
          cln <- toString(raw[raw != excl])
          if (cln == "") return(NA)
          else return(cln)
        })

产生

> positions
   playerID sp rp c X1b X2b X3b ss of dh primary  altPos
1  adamja01  0 31 0   4   0   0  0  0  0      RP     X1b
2 adamsau02  0  2 0   0   0   1  3  0  0      RP X3b, ss
3 adamsch01  1  2 0   6   0   0  0  0  0      RP sp, X1b
4 alberma01  0 34 0   0   0   0  0  0  0      RP    <NA>
5 alcansa01  6  0 0   0   0   0  0  0  0      SP    <NA>
6 alcanvi01  0 27 0   0   0   0  0  0  0      RP    <NA>

编辑：

上面的函数已经在使用posThresh向量了。下面是一个也适用于矩阵的函数。最好包括一些异常处理，我已经这样做了。

validThresh <- function(positions, posThresh) {
  stopifnot(all(!is.na(posThresh)))
  if(!length(posThresh) == 1 & !is.matrix(posThresh) &
     !length(posThresh) == dim(positions[2:10])[2])
    stop("length of posThresh do not equal number of test columns!")
  if(!all(is.matrix(posThresh) & dim(posThresh) == dim(positions[2:10])))
    stop("posThresh and test matrix do not have the same dimensions!")
  mx <- positions[2:10] >= posThresh
  raw <- apply(mx, 1, function(mx) names(mx[mx == TRUE]))
  excl <- tolower(unlist(positions[grep("primary", names(positions))]))
  cln <- sapply(1:length(raw), function(i) 
    toString(raw[[i]][raw[[i]] != excl[i]]))
  return(ifelse(cln == "", NA, cln))
}

用法：

validThresh(positions, posThresh)

一些测试：

validThresh(positions, posThresh=1)
validThresh(positions, posThresh=NA)  # error
validThresh(positions, posThresh=c(6, 27, 1, 5, 1, 1, 3, 0, 1))
validThresh(positions, posThresh=c(1, 2, 2))  # error
validThresh(positions, posThresh=matrix(1, 6, 9))
validThresh(positions, posThresh=matrix(1, 7, 9))  # error

最后，像这样添加您的列：

positions$altPos <- validThresh(positions, posThresh)

数据

positions <- structure(list(playerID = structure(1:6, .Label = c("adamja01", 
"adamsau02", "adamsch01", "alberma01", "alcansa01", "alcanvi01"
), class = "factor"), sp = c(0L, 0L, 1L, 0L, 6L, 0L), rp = c(31L, 
2L, 2L, 34L, 0L, 27L), c = c(0L, 0L, 0L, 0L, 0L, 0L), X1b = c(4L, 
0L, 6L, 0L, 0L, 0L), X2b = c(0L, 0L, 0L, 0L, 0L, 0L), X3b = c(0L, 
1L, 0L, 0L, 0L, 0L), ss = c(0L, 3L, 0L, 0L, 0L, 0L), of = c(0L, 
0L, 0L, 0L, 0L, 0L), dh = c(0L, 0L, 0L, 0L, 0L, 0L), primary = structure(c(1L, 
1L, 1L, 1L, 2L, 1L), .Label = c("RP", "SP"), class = "factor")), row.names = c("1", 
"2", "3", "4", "5", "6"), class = "data.frame")

Answer 2

如果您愿意使用dplyr和tidyr，那么

library(dplyr)
library(tidyr)
df %>%
  gather(k, v, -playerID, -primary) %>%
  filter(v > 0, tolower(primary) != k) %>%
  group_by(playerID) %>%
  summarize(k = paste(k, collapse = ","))
# # A tibble: 6 x 2
#   playerID  k     
#   <fct>     <chr> 
# 1 adamja01  X1b   
# 2 adamsau02 X3b,ss
# 3 adamsch01 sp,X1b
# 4 alberma01 ""    
# 5 alcansa01 ""    
# 6 alcanvi01 ""    

在这里，您可以使用原始框架返回merge或left_join。