aseshms: Toolkit for ASES HMS Team

#' Quick vectorized call of \code{ifelse}
#'
#' \code{ifelse(is.null(x), y, x)} is less handy in some situations. You can use 
#' \code{ifnull(x, y)} instead. It is a vectorized implementation of \code{ifelse} 
#' equivalents. Moreover, it supports recursive conversion for lists. It is inspired
#' by \code{Nz} function in VBA.
#' @param x Vector, matrix, data.frame, array or list. The elements of x that do 
#' not meet the criteria function (e.g., is.null, is.na, ...), will be returned as-is. 
#' The elements of x that meet the \code{criteria} function, will be converted to y.
#' @param y Scalar, if a vector is given, only the first element will be used. 
#' The elements of x that meet the \code{criteria} function, will be converted to y.
#' @param criteria A vectorized function that returns a logical value, e.g., 
#' \code{is.null}, \code{is.na}. You can also compose a function on your own.
#' @return The same structure as \code{x}, with those elements meets \code{criteria} 
#' replaced with \code{y}
#' 
#' @export
#' 
#' @examples 
#' \dontrun{
#' ifna(c(1, 4, NA), 0)  # returns
#' # [1] 1  4  0
#' 
#' # iif also supports recursive conversion
#' ifnull(list(3, list(NULL), c(3, 5)), 0)  # returns
#' # [[1]]
#' # [1] 3
#' # 
#' # [[2]]
#' # [[2]][[1]]
#' # [1] 0
#' # 
#' # [[3]]
#' # [1] 3 5
#' 
#' ifzero(data.frame(A=c(1, 0, -2), B=c(-1, 0, 3)), 99)  # returns
#' #    A   B
#' # 1  1  -1
#' # 2 99  99
#' # 3 -2   3
#' 
#' # User-defined function 
#' iif(matrix(c(1, 0, -2, -1, 0, 3), nrow=2), 0, function(v) v < 0)
#' ## Replace all the negative values with 0
#' #      [,1] [,2] [,3]
#' # [1,]    1    0    0
#' # [2,]    0    0    3
#'
#' # Also works for high-dimensional array
#' iif(array(1:6, dim=c(1, 3, 2)), NA, function(v) v %% 2 == 0)
#' ## Replace all the even numbers with NA
#' # ,, 1
#' #      [,1]  [,2]  [,3]
#' # [1,]    1    NA     3
#' #
#' # , , 2
#' #      [,1]  [,2]  [,3]
#' # [1,]   NA     5    NA
#' }
iif <- function(x, y, criteria=is.null){
    stopifnot(inherits(criteria, "function"))
    if (! "logical" %in% class(criteria(1)))
        stop("'criteria' must be a function that yields logical values.")
    UseMethod(".iif", x)
}

#' @export
.iif.list <- function(x, y, criteria=is.null){
    lapply(x, function(v) {
        if (is.list(v)){
            v <- .iif.list(v, y, criteria=criteria)
        }else{
            which.matches <- tryCatch(
                criteria(v), error=function(e) e, final="Error occured.")
            if (! inherits(which.matches, "error")){
                which.matches[is.na(which.matches)] <- FALSE
                if (any(which.matches)) v[which.matches] <- y[[1]]
            }else{
                warning(which.matches)
            }
        }
        return(v)
    })
}

#' @export
.iif.data.frame <- function(x, y, criteria=is.null){
    x <- .iif.list(x, y, criteria)
    return(as.data.frame(x, stringsAsFactors=FALSE))
}

#' @export
.iif.matrix <- function(x, y, criteria=is.null){
    xdim <- dim(x)
    o <- apply(x, 2, function(v) {
        which.matches <- tryCatch(
            criteria(v), error=function(e) e, final="Error occured.")
        which.matches[is.na(which.matches)] <- FALSE
        if (! inherits(which.matches, "error")){
            if (any(which.matches)) v[which.matches] <- y[[1]]
        }else{
            warning(which.matches)
        }
        return(v)
    })
    if (is.null(dim(o))){
        dim(o) <- xdim
    }else if (xdim[1] != xdim[2] && all(dim(o) == rev(xdim))) {
        o <- t(o)
    }
    return(o)
}

#' @export
.iif.vector <- function(x, y, criteria=is.null){
    if (any(criteria(x))) x[criteria(x)] <- y[[1]]
    return(x)
}

#' @export
.iif.default <- .iif.vector

#' @export
#' @rdname iif
ifnull <- function(x, y) iif(x, y, criteria=is.null)
#' @export
#' @rdname iif
ifna <- function(x, y) iif(x, y, criteria=is.na)
#' @export
#' @rdname iif
ifnan <- function(x, y) iif(x, y, criteria=is.nan)
#' \code{ifblank} replaces elements in x where nchar(x)==0 with y.
#' @export
#' @rdname iif
ifblank <- function(x, y) iif(x, y, criteria=Vectorize(function(v) nchar(v)==0))
#' \code{ifempty} replaces elements in x where length(x)==0 with y.
#' @export
#' @rdname iif
ifempty <- function(x, y) iif(x, y, criteria=Vectorize(function(v) length(v)==0))
#' @export
#' @rdname iif
ifzero <- function(x, y) iif(x, y, criteria=Vectorize(function(v) identical(v, 0)))