R/translate-utils.R

In Bioconductor/AnnotationFilter: Facilities for Filtering Bioconductor Annotation Resources

#' @include AnnotationFilter.R

## Functionality to translate a query condition to an AnnotationFilter.

#' Adapted from GenomicDataCommons.
#'
#' @importFrom methods is validObject initialize
#'
#' @noRd
.binary_op <- function(sep) {
    force(sep)
    function(e1, e2) {
        ## First create the class. Throws an error if not possible i.e. no
        ## class for the field available.
        field <- as.character(substitute(e1))
        class <- .fieldToClass(field)
        filter <- tryCatch({
            new(class, condition = sep, field = field)
        }, error = function(e) {
            stop("No AnnotationFilter class '", class, "' for field '",
                field, "' defined")
        })
        ## Fill with values.
        force(e2)
        if (is(filter, "CharacterFilter")) {
            e2 <- as.character(e2)
        } else if (is(filter, "IntegerFilter")) {
            e2 <- as.integer(e2)
        }
        initialize(filter, value = e2)
    }
}

#' Functionality to translate a unary operation into an AnnotationFilter.
#'
#' @noRd
.not_op <- function(sep) {
    force(sep)
    function(x) {
        if(is(x, "AnnotationFilterList") || is(x, "AnnotationFilter")) {
            if(x@not)
                x@not <- FALSE
            else
                x@not <- TRUE
            if(is(x, "AnnotationFilterList"))
                x@.groupingFlag <- FALSE
            return(x)
        }
#       else if (is(x, "AnnotationFilter")) 
#           AnnotationFilterList(x, logicOp=character(), not=TRUE)
        else
            stop('Arguments to "!" must be an AnnotationFilter or AnnotationFilerList.')
    }
}

.parenthesis_op <- function(sep) {
    force(sep)
    function(x) {
        if (is(x, "AnnotationFilterList")) {
            x@.groupingFlag <- FALSE
            x
        }
        else
            AnnotationFilterList(x, .groupingFlag=FALSE)
    }
}


#' Combine filters into a AnnotationFilterList combbined with \code{sep}
#'
#' @noRd
.combine_op <- function(sep) {
    force(sep)
    function(e1, e2) {
        op1 <- character()
        op2 <- character()
        if (is(e1, "AnnotationFilterList") && e1@.groupingFlag) {
            op1 <- logicOp(e1)
            e1 <- .aflvalue(e1)
        } else {
            e1 <- list(e1)
        }
        if (is(e2, "AnnotationFilterList") && e2@.groupingFlag) {
            op2 <- logicOp(e2)
            e2 <- .aflvalue(e2)
        } else {
            e2 <- list(e2)
        }
        input <- c(e1, e2)
        input[['logicOp']] <- c(op1, sep, op2)
        input[['.groupingFlag']] <- TRUE
        do.call("AnnotationFilterList", input)
    }
}

#' The \code{.LOG_OP_REG} is a \code{list} providing functions for
#' common logical operations to translate expressions into AnnotationFilter
#' objects.
#'
#' @noRd
.LOG_OP_REG <- list()
## Assign conditions.
.LOG_OP_REG$`==` <- .binary_op("==")
.LOG_OP_REG$`%in%` <- .binary_op("==")
.LOG_OP_REG$`!=` <- .binary_op("!=")
.LOG_OP_REG$`>` <- .binary_op(">")
.LOG_OP_REG$`<` <- .binary_op("<")
.LOG_OP_REG$`>=` <- .binary_op(">=")
.LOG_OP_REG$`<=` <- .binary_op("<=")
## Custom binary operators 
.LOG_OP_REG$`%startsWith%` <- .binary_op("startsWith")
.LOG_OP_REG$`%endsWith%` <- .binary_op("endsWith")
.LOG_OP_REG$`%contains%` <- .binary_op("contains")
## not conditional.
.LOG_OP_REG$`!` <- .not_op("!")
## parenthesis
.LOG_OP_REG$`(` <- .parenthesis_op("(")
## combine filters
.LOG_OP_REG$`&` <- .combine_op("&")
.LOG_OP_REG$`|` <- .combine_op("|")

`%startsWith%` <- function(e1, e2){}
`%endsWith%` <- function(e1, e2){}
`%contains%` <- function(e1, e2){}

#' @rdname AnnotationFilter
#'
#' @description \code{AnnotationFilter} \emph{translates} a filter
#'     expression such as \code{~ gene_id == "BCL2"} into a filter object
#'     extending the \code{\link{AnnotationFilter}} class (in the example a
#'     \code{\link{GeneIdFilter}} object) or an
#'     \code{\link{AnnotationFilterList}} if the expression contains multiple
#'     conditions (see examples below). Filter expressions have to be written
#'     in the form \code{~ <field> <condition> <value>}, with \code{<field>}
#'     being the default field of the filter class (use the
#'     \code{supportedFilter} function to list all fields and filter classes),
#'     \code{<condition>} the logical expression and \code{<value>} the value
#'     for the filter.
#'
#' @details Filter expressions for the \code{AnnotationFilter} class have to be
#'     written as formulas, i.e. starting with a \code{~}.
#'
#' @note Translation of nested filter expressions using the
#'     \code{AnnotationFilter} function is not yet supported.
#' 
#' @param expr A filter expression, written as a \code{formula}, to be
#'     converted to an \code{AnnotationFilter} or \code{AnnotationFilterList}
#'     class. See below for examples.
#'
#' @return \code{AnnotationFilter} returns an
#'     \code{\link{AnnotationFilter}} or an \code{\link{AnnotationFilterList}}.
#' 
#' @importFrom lazyeval f_eval
#'
#' @examples
#' 
#' ## Convert a filter expression based on a gene ID to a GeneIdFilter
#' gnf <- AnnotationFilter(~ gene_id == "BCL2")
#' gnf
#'
#' ## Same conversion but for two gene IDs.
#' gnf <- AnnotationFilter(~ gene_id %in% c("BCL2", "BCL2L11"))
#' gnf
#'
#' ## Converting an expression that combines multiple filters. As a result we
#' ## get an AnnotationFilterList containing the corresponding filters.
#' ## Be aware that nesting of expressions/filters does not work.
#' flt <- AnnotationFilter(~ gene_id %in% c("BCL2", "BCL2L11") &
#'                         tx_biotype == "nonsense_mediated_decay" |
#'                         seq_name == "Y")
#' flt
#' 
#' @export
AnnotationFilter <- function(expr) {
    res <- f_eval(expr, data = .LOG_OP_REG)
    if(is(res, "AnnotationFilterList")) res@.groupingFlag <- FALSE
    res
}