aseshms: Toolkit for ASES HMS Team

#' @importFrom stringr str_detect
searchXpdfFolder <- function(){
    r.parent <- dirname(R.home())
    
    dirs <- c(list.dirs(r.parent, recursive=FALSE),
              list.dirs(R.home(), recursive=FALSE))
    if (Sys.getenv("xpdfdir") != ""){
        xpdfdir <- Sys.getenv("xpdfdir")
    }else if (any(str_detect(dirs, "xpdfbin"))){
        xpdfdir <- dirs[str_detect(tolower(dirs), "xpdfbin")][1]
    }else{
        return(NULL)
    }
    return(paste(c(
        unlist(strsplit(xpdfdir, "[/\\\\]")), 
        paste0("bin", getOption("mach.arch"))), collapse="/"))
}

# ------------get enum--------------

#' Get enumeration value(s) based on the enum name(s)
#'
#' There is a builtin ENUM data set storing enumerations that are quite handy when
#' applying mso-family functions. 
#' @param enum_name vector, can be \describe{
#' \item{scalar character}{e.g., "msoChart". In this case, you can pass other characters
#' in \code{...}}
#' \item{vector character}{e.g, c("msoChart", "msoTable") or list("msoChart", 
#' "msoTable"). In this case, \code{...} is omitted.}
#' \item{scalar symbol}{e.g., msoChart. In this case, you can pass other symbols
#' in \code{...}}
#' \item{vector symbol}{e.g, c(msoChart, msoTable) or list(msoChart, 
#' msoTable). In this case, \code{...} is omitted.}
#' }
#' @param ... When \code{enum_name} is scalar, you can pass the rest of the enum_names
#' here.
#' @param family character vector of the enumeration families, e.g., "MsoFileType".
#' You can use \code{names(ENUM)} to check the full list. When it is defined, the
#' function will only search enumerations within the families specified. Default NULL,
#' i.e. the function will search the whole ENUM data set. You can only input the
#' initial letters of the families.
#' @param unlist logical, whether unlist the result. Default TRUE.
#' @param bare logical, whether only return bare enumeration numbers. Default FALSE.
#'
#' @return \describe{
#' \item{If \code{unlist} = TRUE}{return a vector, with a vector of 'family' attribute 
#' on the vector (of same length as the result)}
#' \item{If \code{unlist} = FALSE}{return a list, with a 'family' attribute on each element}
#' \item{If \code{enum_name} is NULL or NA}{return all the enumerations that match}
#' \item{If nothing is found}{return NA}
#' }
#' @export
#'
#' @seealso \code{\link{data:ENUM}}
#' @examples
#' \dontrun{
#' enum(msoChart)  # equivalent to enum("msoChart")
#' # msoChart 
#' #        3 
#' # attr(,"family")
#' # [1] "msoShapeType"
#' 
#' enum(msoChart, unlist=FALSE)  # or enum("msoChart", unlist=FALSE)
#' # $`msoChart`
#' # [1] 3
#' # attr(,"family")
#' # [1] "msoShapeType"
#' 
#' enum(msoChart, msoTable)  # or enum(c(msoChart, msoTable))
#'                           # or enum(msoChart, family="Mso")
#' # msoChart   msoTable 
#' #        3         19 
#' # attr(,"family")
#' # [1] "msoShapeType" "msoShapeType"
#' 
#' enum(msoChart, family=c("Xl", "Wd"))  # "msoChart" not in these families
#' # [1] NA
#' 
#' enum(NULL, family="XlAxisGroup")  # return all the enums of "XlAxisGroup"
#' #   xlPrimary xlSecondary 
#' #           1           2 
#' # attr(,"family")
#' # [1] "XlAxisGroup" "XlAxisGroup"
#' 
#' enum(msoChart, bare=TRUE)  # only return bare number
#' # [1] 3
#' 
#' # feel free to use purrr::as_mapper
#' getEnum <- function(family, enum_name) {
#'     purrr:::as_mapper(c(family, enum_name))
#' }
#' getEnum("MsoShapeType", "msoChart")
#' # [1] 3
#' }
enum <- function(enum_name, ..., family=NULL, unlist=TRUE, bare=FALSE){
    if (! exists("ENUM"))
        stop("ENUM data set not found. ",
             "Make sure you have loaded aseshms correctly.")
    
    if (! is.null(family)){
        stopifnot(is.character(family))
        family <- unlist(family)
        match_family <- vapply(family, function(fam){
            grepl(paste0("^", fam), names(ENUM))
        }, logical(length=length(ENUM)))
        match_family <- apply(match_family, 1, any)
        if (! any(match_family)) return(NA)
        ENUM <- ENUM[match_family]
    }
    # unlist ENUM
    x <- unlist(lapply(names(ENUM), function(nm){
        lapply(ENUM[[nm]], structure, family=nm)
    }), recursive=FALSE)
    
    enum_name <- as.character(substitute(enum_name))
    enum_name <- enum_name[!is.na(enum_name)]
    if (enum_name[1] %in% c("c", "list")){
        enum_name <- enum_name[-1]
        dots <- NULL
    }else{
        dots <- as.character(substitute(list(...)))[-1]
    }
    enum_name <- enum_name[! enum_name %in% c("NULL", "NaN")]
    
    if (length(enum_name) > 0){
        enum_name <- c(enum_name, dots)
        if (! any(enum_name %in% names(x)))
            return(NA)
        x <- x[intersect(enum_name, names(x))]
    }
    if (unlist){
        x <- if (bare){
            unname(unlist(x))
        }else{
            structure(unlist(x), family=unname(
                unlist(vapply(x, attr, FUN.VALUE=character(length=1), 
                              which="family"))))
        }
    } else {
        if (bare) {
            x <- as.list(unname(unlist(x)))
        }
    }
    return(x)
}



# ------------widget list------------
widgetList <- function(...) {
    as.widgetList(list(...))
}

as.widgetList <- function(x) {
    if (! is.list(x)) stop("'x' must be a list")
    #       for (i in seq_along(x)) {
    #             if (!inherits(x[[i]], c('htmlwidget', 'html', 'shiny.tag', 'shiny.tag.list')))
    #                   stop("The element ", i, " in 'x' is not an HTML widget or tag")
    #       }
    structure(x, class = 'widgetList')
}

#' @importFrom knitr knit_print
knit_print.widgetList <- function(x, ..., options = NULL) {
    structure(lapply(x, knit_print, ..., options = options), class = 'knit_asis_list')
}

##----------pre-resiquite functions---------
evalFormula = function(x, data) { # by yihui xie
    if (!inherits(x, 'formula')) return(x)
    if (length(x) != 2) stop('The formula must be one-sided: ', deparse(x))
    eval(x[[2]], data, environment(x))
}
mergeList = function(x, y) { # by yihui xie
    if (!is.list(y) || length(y) == 0) return(x)
    yn = names(y)
    if (length(yn) == 0 || any(yn == '')) {
        warning('The second list to be merged into the first must be named')
        return(x)
    }
    for (i in yn) {
        xi = x[[i]]
        yi = y[[i]]
        if (is.list(xi)) {
            if (is.list(yi)) x[[i]] = mergeList(xi, yi)
        } else x[[i]] = yi
    }
    return(x)
}


is.DateChar <- function(x, format=NULL){
    if (length(x) > 1) warning("Only the 1st element will be used.")
    x <- x[[1]]
    if (is.null(x)) return(FALSE)
    if (is.na(x)) return(NA)
    if (is.null(format)) {
        x <- try(as.Date(x), silent=TRUE)
    }else{
        x <- try(as.Date(x, format=format), silent=TRUE)
    }
    return(is(x, "Date"))
}

is.TimeChar <- function(x, origin=NULL, tz=""){
    if (length(x) > 1) warning("Only the 1st element will be used.")
    x <- x[[1]]
    if (is.null(x)) return(FALSE)
    if (is.na(x)) return(NA)
    if (is.null(origin)){
        x <- try(as.POSIXlt(x, tz=tz), silent=TRUE)
    }else{
        x <- try(as.POSIXlt(x, origin=origin, tz=tz), silent=TRUE)
    }
    return(is(x, "POSIXt"))
}

#' @importFrom stringi stri_enc_isascii
isLatin <- function(x){
    if (is.factor(x)) x <- as.character(x)
    return(stri_enc_isascii(x))
}

#' #' Pipe Binary Operation (Deprecated)
#' #'
#' #' \code{\link{\%>\%}} is a great tool to chain a series of operations in a concise format.
#' #' Here provides binary operators combined with pipeline.
#' #' @param lhs Left hand side object
#' #' @param rhs Right hand side object
#' #'
#' #' @return A new object with the value \code{rhs opr rhs}
#' #' @importFrom magrittr %>%
#' #' @export
#' #' @export %>%
#' #' @seealso \code{\link{magrittr}}
#' #' @examples
#' #' ## simple object
#' #' a <- 3
#' #' a %>+% 1 %>-% 2 %>*% 3 %>/% 4
#' #'
#' #' ## vector
#' #' a <- 1:4
#' #' a %>+% 1 %>-% 2 %>*% 3 %>/% 4
#' #'
#' #' ## object operates object
#' #' a <- 1:4
#' #' b <- 1:2
#' #' c <- 3:4
#' #' a %>-% b %>+% c %>*% b %>/% c %>^% b %>root% c
#' #'
#' #' @rdname Pipeline.Binary.Operators
#' #'
#' `%>+%` <- function(lhs, rhs){
#'     opr <- deparse(match.call()[[1]])
#'     #browser()
#'     lhs <- deparse(substitute(lhs))
#'     rhs <- deparse(substitute(rhs))
#'     # combine into one string
#'     call <- paste(lhs, opr, rhs)
#'
#'     # match correct operator
#'     call <- gsub("%>\\*\\*%", "%>\\^%", call)
#'     call <- gsub("%>mod%", "%>%%%", call)
#'     call <- gsub("%>root%", "%>\\^1/%", call)
#'
#'     # format call
#'     call <- gsub("%>(\\S+)%\\s+(\\S+)", "%>% `\\1`\\(\\2\\) ", call)
#'     call <- gsub("%>\\^%\\s+(\\S+)", "%>% `\\^`\\(\\2\\)", call)
#'     call <- gsub("%>\\*%\\s+(\\S+)", "%>% `\\*`\\(\\2\\)", call)
#'     call <- gsub("`\\^1/`\\((\\S+)\\)", "`\\^`\\(1/\\1\\)", call) # root x^(1/y)
#'
#'     # evaluate
#'     eval(parse(text=call), envir=parent.frame())
#' }
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>-%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>*%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>/%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>^%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>**%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>root%` <- `%>+%`
#'
#' #' @export
#' #' @rdname Pipeline.Binary.Operators
#' `%>mod%` <- `%>+%`