R：有效地子集许多对象

Question

我经常使用逻辑向量对其他向量、矩阵和数据框进行子集化（在基因组学领域，这很常见）。在这样的向量上会像这样：

condition <- myNucleotideVector == "G"

然后我处理符合该条件的子集。所以我经常以笨拙的代码结束，例如：

myNucleotideVector <- myNucleotideVector[condition]
object2 <- object2[condition]
dataframe1 <- dataframe1[conditon,]

或

result <- myNucleotideVector[condition] - object2[condition] + dataframe1[conditon,2]

重复 [condition] 多次。我可以将所有相同大小的向量和一个数据框放入子集，但我并不总是想这样做（特别是考虑到向量的长度，它可以是数百万）。

我正在寻找有效的解决方案。对于上面引用的第一个案例，我想到了一个函数，它将任何提供的对象作为参数并对其进行子集化。看起来像

subsetObjects <- function(..., condition, env = globalenv()) {          
    call <- as.character(match.call())
    names <- call[2:(length(call)-1)] #this isn't ideal as it doesn't consider the case where one would place 'condition' argument before the objects to subset
    for (name in names) {    
        value <- get(name, envir = env)
        assign(name, subset(value, subset = condition),envir = env)
    }
}

正如您在评论中看到的那样，它并不完美。也许有人可以提出更有效的建议。

对于第二种情况，我正在寻找类似于 with() 的东西，其中每个向量、矩阵或数据帧都会根据条件自动成为子集。看起来像

result <- withCondition(condition, expression)

如果没有这样的功能，我可以自己写一个，但我不知道该怎么做。

谢谢

让

Answer 1

这里有一个想法，也许有点不寻常：您可以创建一个 "getter" 函数，而不是直接使用代码中的底层对象，它只接受一个参数：变量的名称想要在代码中的那个点实例化。你可以把它当作一个字符串，或者更好的是，使用 substitute() 来允许使用不带引号的符号（实际上，我最终使用了 as.character(substitute(var))，所以两者都有效）。在函数内部，您可以查找 "global condition" 来决定如何对变量进行子集化，如果它应该被子集化的话。为了获得最大的灵活性，查找 table 还可以将每个变量映射到该变量的特定条件。这是我的设想：

## lookup table and getter
cond.to.vec <- list();
COND.NAME.GLOBAL <- '!global';
var.to.cond <- list();
cond.register <- function(name,vec=NULL) {
    prev.vec <- cond.to.vec[[name]];
    cond.to.vec[[name]] <<- vec;
    invisible(prev.vec);
};
cond.is.registered <- function(name) !is.null(cond.to.vec[[name]]);
cond.map <- function(var.name,cond.name=NULL) {
    ## remove previous mapping
    prev.mapping <- var.to.cond[[var.name]];
    var.to.cond[[var.name]] <<- NULL;
    ## omit cond.name arg to just remove
    if (is.null(cond.name)) return(invisible(prev.mapping));
    ## ensure cond.name has been registered
    if (!cond.is.registered(cond.name)) stop(paste0(cond.name,' not registered'));
    ## now add new cond.name mapping for var.name
    var.to.cond[[var.name]] <<- cond.name;
    invisible(prev.mapping);
};
cond.set <- function(var,cond.vec=NULL,sym=T) {
    var.name <- if (sym) as.character(substitute(var)) else var;
    cond.register(var.name,cond.vec);
    cond.map(var.name,if (is.null(cond.vec)) NULL else var.name);
};
cond.set.global <- function(vec=NULL) cond.register(COND.NAME.GLOBAL,vec);
cond.look.up <- function(var.name) {
    ## 1: specific condition
    cond.name <- var.to.cond[[var.name]];
    if (!is.null(cond.name)) return(cond.to.vec[[cond.name]]);
    ## 2: global condition
    vec <- cond.to.vec[[COND.NAME.GLOBAL]];
    if (!is.null(vec)) return(vec);
    ## 3: no condition
    T;
};

ss <- function(var,sym=T) {
    ## whitelist subsettables
    if (!typeof(var)%in%sapply(list(as.raw(0),T,0L,0,0i,'',list(),expression()),typeof))
        return(var);
    var.name <- if (sym) as.character(substitute(var)) else var;
    vec <- cond.look.up(var.name);
    if (length(dim(var)) == 2L) var[vec,] else var[vec];
};

## test data
set.seed(1);
N <- 10;
myNucleotideVector <- sample(c('A','C','T','G'),N,replace=T);
myNucleotideVectorNum <- sample(100:200,N,replace=T);
object2 <- seq_len(N);
dataframe1 <- data.frame(base=sample(c('A','C','T','G'),N,replace=T),x=sample(1:100,N));

## global condition
cond.set.global(myNucleotideVector == 'G');

## main code, uses global condition
result <- ss(myNucleotideVectorNum) - ss(object2) + ss(dataframe1)$x;

## register separate condition for object2
cond.set(object2,object2%%3 == 0);
result2 <- ss(myNucleotideVectorNum) - ss(object2) + ss(dataframe1)$x;

## unset/unregister all conditions to work with the entire data set
cond.set.global();
cond.set(object2);
result3 <- ss(myNucleotideVectorNum) - ss(object2) + ss(dataframe1)$x;

result;
## [1] 153 208 240
result2;
## [1] 154 208 238
result3;
##  [1] 168 175 266 153 252 208 240 203 196 206

现在我们可以用更多的函数来增强上面的代码，以提供一种应用子集条件的侵入性较小的方法：

ss.all.sub <- function(pt) {
    if (typeof(pt) == 'symbol') ## wrap all symbols in ss()
        as.call(list(as.symbol('ss'),pt))
    else if (typeof(pt) == 'language' && length(pt) >= 2L) ## handle function args
        as.call(c(pt[[1]], ## pass function symbol untouched
            if (as.character(pt[[1]]) == '$') ## special case for $ operator
                list(ss.all.sub(pt[[2]]),pt[[3]]) ## pass RHS untouched
            else
                lapply(pt[-1],ss.all.sub) ## recurse on all args
        ))
    else pt; ## pass literals and nullary calls untouched
};

ss.all <- function(expr) eval(ss.all.sub(substitute(expr)));

ss.with <- function(cond.arg,expr) {
    if (is.list(cond.arg)) {
        prevs <- vector('list',length(cond.arg));
        for (i in seq_along(cond.arg)) {
            name <- names(cond.arg)[i];
            prevs[i] <- list(
                if (isTRUE(name != '' && name != COND.NAME.GLOBAL))
                    cond.set(name,cond.arg[[i]],sym=F)
                else
                    cond.set.global(cond.arg[[i]])
            );
        };
    } else prev <- cond.set.global(cond.arg);
    res <- eval(ss.all.sub(substitute(expr)));
    if (is.list(cond.arg)) {
        for (i in seq_along(cond.arg)) {
            name <- names(cond.arg)[i];
            if (isTRUE(name != '' && name != COND.NAME.GLOBAL))
                cond.set(name,prevs[[i]],sym=F)
            else
                cond.set.global(prevs[[i]]);
        };
    } else cond.set.global(prev);
    res;
};

## demo parse tree substitution
ss.all.sub(substitute(myNucleotideVectorNum - object2 + dataframe1$x));
## ss(myNucleotideVectorNum) - ss(object2) + ss(dataframe1)$x

## demo using ss.with() to apply an inline condition
ss.with(myNucleotideVector == 'G',myNucleotideVectorNum - object2 + dataframe1$x);
## [1] 153 208 240
ss.with(
    list(myNucleotideVector == 'G',object2=object2%%3 == 0),
    myNucleotideVectorNum - object2 + dataframe1$x
);
## [1] 154 208 238
ss.with(T,myNucleotideVectorNum - object2 + dataframe1$x);
##  [1] 168 175 266 153 252 208 240 203 196 206

R：有效地子集许多对象

R: subset many objects efficiently

r

subset