R/look.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' lookup characters
#'
#' @param x one character vector
#' @param ... one or more keyword, started with nothing or ~, !~, =, !=, connected by '|'.
#' @param ignore.case logical. whether to ignore case.
#'
#' @return selected characters
#' @export
#'
look <- function(x,...,ignore.case=FALSE){
    if (is.data.frame(x)){
        n <- looki(x=colnames(x),...,ignore.case = ignore.case)
        x[,n,drop=FALSE]
    }else{
        x[looki(x=x,...,ignore.case = ignore.case)]
    }
}
#' lookup characters
#'
#' @param x one character vector
#' @param ... one or more keyword, started with nothing or ~, !~, =, !=, connected by '|'.
#' @param ignore.case logical. whether to ignore case.
#'
#' @return logical value.
#' @export
#'
lookl <- function(x,...,ignore.case=FALSE){
    if (is.data.frame(x)){
        n <- looki(x=colnames(x),...,ignore.case = ignore.case)
        x[,n,drop=FALSE]
    }else{
        looki(x=x,...,ignore.case = ignore.case)
    }
}
looki <- function(x,...,ignore.case=FALSE){
    lookup <- c(...)
    lookup <- do::Trim_left(lookup)
    kk <- do::left(lookup,1)
    (k1 <- (kk == '~') | (! kk %in% c('!','=')))
    (k3 <- kk %in% c('='))
    kk <- do::left(lookup,2)
    (k2 <- kk == '!~')
    (k4 <- kk == '!=')
    if (!any(k1) & !any(k2) & !any(k3) & !any(k4)) stop('no select rules')
    # get
    if (any(k1) & any(k3)){
        # grep
        (k1 <- lookup[k1] |> do::Replace0('~'))
        k1 <- gsub(' {0,}\\| {0,}','|',k1)
        k1g <- lapply(k1, function(i) grepl(i,x,ignore.case)) |> data.frame() |> rowSums() |> equal(length(k1))
        # %in%
        (k3 <- lookup[k3] |> do::Replace0('='))
        k3 <- gsub(' {0,}\\| {0,}','|',k3)
        if (ignore.case){
            k3g <- lapply(k3, function(i) tolower(x) %in% unique(unlist(strsplit(tolower(i),'\\|')))) |> data.frame() |> rowSums() |> equal(length(k3))
        }else{
            k3g <- lapply(k3, function(i) x %in% unique(unlist(strsplit(i,'\\|')))) |> data.frame() |> rowSums() |> equal(length(k3))
        }
        k13 <- k1g | k3g
    }else if (any(k1) & !any(k3)){
        # grep
        (k1 <- lookup[k1] |> do::Replace0('~'))
        k1 <- gsub(' {0,}\\| {0,}','|',k1)
        k1g <- lapply(k1, function(i) grepl(i,x,ignore.case)) |> data.frame() |> rowSums() |> equal(length(k1))
        k13 <- k1g
    }else if (!any(k1) & any(k3)){
        # %in%
        (k3 <- lookup[k3] |> do::Replace0('='))
        k3 <- gsub(' {0,}\\| {0,}','|',k3)
        if (ignore.case){
            k3g <- lapply(k3, function(i) tolower(x) %in% unique(unlist(strsplit(tolower(i),'\\|')))) |> data.frame() |> rowSums() |> equal(length(k3))
        }else{
            k3g <- lapply(k3, function(i) x %in% unique(unlist(strsplit(i,'\\|')))) |> data.frame() |> rowSums() |> equal(length(k3))
        }
        k13 <- k3g
    }else{
        k13 <- rep(TRUE,length(x))
    }
    # exclude
    if (any(k2) & any(k4)){
        # grepl
        (k2 <- lookup[k2] |> do::Replace0('!~'))
        k2 <- gsub(' {0,}\\| {0,}','|',k2)
        k2g <- lapply(k2, function(i) grepl(i,x,ignore.case)) |> data.frame() |> rowSums() |> equal(length(k2))

        # !%=%
        (k4 <- lookup[k4] |> do::Replace0('!='))
        k4 <- strsplit(k4,'\\|') |> unlist() |> unique()
        if (ignore.case){
            k4g <- lapply(k4, function(i) tolower(x) %in% unique(unlist(strsplit(tolower(i),'\\|')))) |> data.frame() |> rowSums() |> equal(length(k4))
        }else{
            k4g <- lapply(k4, function(i) x %in% unique(unlist(strsplit(i,'\\|')))) |> data.frame() |> rowSums() |> equal(length(k4))
        }
        k24 <- k2g | k4g
    }else if (any(k2) & !any(k4)){
        # grepl
        (k2 <- lookup[k2] |> do::Replace0('!~'))
        k2 <- gsub(' {0,}\\| {0,}','|',k2)
        k2g <- lapply(k2, function(i) grepl(i,x,ignore.case)) |> data.frame() |> rowSums() |> equal(length(k2))
        k24 <- k2g
    }else if (!any(k2) & any(k4)){
        #!&=%
        (k4 <- lookup[k4] |> do::Replace0('!='))
        k4 <- strsplit(k4,'\\|') |> unlist() |> unique()
        if (ignore.case){
            k4g <- lapply(k4, function(i) tolower(x) %in% unique(unlist(strsplit(tolower(i),'\\|')))) |> data.frame() |> rowSums() |> equal(length(k4))
        }else{
            k4g <- lapply(k4, function(i) x %in% unique(unlist(strsplit(i,'\\|')))) |> data.frame() |> rowSums() |> equal(length(k4))
        }
        k24 <- k4g
    }else{
        k24 <- rep(FALSE,length(x))
    }
    kg <- k13 & (!k24)
    kg
}
equal <- function(a,b) a==b