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

Вот одна идея, возможно, немного необычно: Вместо того чтобы работать непосредственно с основными объектами в вашем коде, вы можете создать одну функцию «геттер», который будет принимать только один аргумент : имя переменной, которую вы хотите создать в этой точке кода. Вы могли бы взять его как строку или, что еще лучше, использовать substitute(), чтобы разрешить использование некотируемого символа (фактически, я закончил с использованием as.character(substitute(var)), поэтому оба работают). Внутри функции вы можете найти «глобальное условие», чтобы решить, как подмножить переменную, если она вообще должна быть подмножеством. Для максимальной гибкости таблица поиска также может сопоставлять каждую переменную с определенным условием для этой переменной. Вот как я себе это:

## 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