#' @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%` <- `%>+%`
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.