140 lines
3.0 KiB
R
140 lines
3.0 KiB
R
|
|
null_or_empty <- function(x) {
|
|
is.null(x) || length(x) == 0
|
|
}
|
|
|
|
|
|
dropNullsOrEmpty <- function(x) {
|
|
x[!vapply(x, null_or_empty, FUN.VALUE = logical(1))]
|
|
}
|
|
|
|
dropNulls <- function(x) {
|
|
x[!vapply(x, is.null, FUN.VALUE = logical(1))]
|
|
}
|
|
|
|
`%||%` <- function(x, y) {
|
|
if (!is.null(x)) x else y
|
|
}
|
|
|
|
formatNoSci <- function(x) {
|
|
if (is.null(x)) return(NULL)
|
|
format(x, scientific = FALSE, digits = 15)
|
|
}
|
|
|
|
|
|
ununlist <- function(x) {
|
|
if (is.null(x))
|
|
return(x)
|
|
n <- names(x)
|
|
if (!is.null(n) && all(nzchar(n))) {
|
|
lapply(x, ununlist)
|
|
} else {
|
|
unlist(x)
|
|
}
|
|
}
|
|
|
|
|
|
to_posix <- function(x) {
|
|
if (!is.null(x)) {
|
|
x <- as.POSIXct(x/1000, origin = "1970-01-01", tz = "UTC")
|
|
}
|
|
x
|
|
}
|
|
|
|
|
|
to_hyphen <- function(x) {
|
|
tolower(gsub("([A-Z])", "-\\1", x))
|
|
}
|
|
|
|
make_styles <- function(styles) {
|
|
styles <- dropNulls(styles)
|
|
if (length(styles) < 1)
|
|
return(NULL)
|
|
styles <- sprintf("%s: %s;", to_hyphen(names(styles)), unlist(styles, use.names = FALSE))
|
|
paste(styles, collapse = " ")
|
|
}
|
|
|
|
|
|
|
|
#' Utility function to create ApexChart parameters JSON
|
|
#'
|
|
#' @template ax-default
|
|
#' @param name Slot's name to edit
|
|
#' @param ... Arguments for the slot
|
|
#'
|
|
#' @importFrom utils modifyList
|
|
#'
|
|
#' @noRd
|
|
.ax_opt <- function(ax, name, ...) {
|
|
|
|
if (is.null(ax$x$ax_opts[[name]])) {
|
|
ax$x$ax_opts[[name]] <- list(...)
|
|
} else {
|
|
ax$x$ax_opts[[name]] <- modifyList(
|
|
x = ax$x$ax_opts[[name]],
|
|
val = list(...),
|
|
keep.null = TRUE
|
|
)
|
|
}
|
|
ax$x$ax_opts[[name]] <- dropNullsOrEmpty(ax$x$ax_opts[[name]])
|
|
return(ax)
|
|
}
|
|
|
|
#' Utility function to create ApexChart parameters JSON
|
|
#'
|
|
#' @template ax-default
|
|
#' @param name Slot's name to edit
|
|
#' @param l List of arguments for the slot
|
|
#'
|
|
#' @importFrom utils modifyList
|
|
#'
|
|
#' @noRd
|
|
.ax_opt2 <- function(ax, name, l) {
|
|
|
|
if (is.null(ax$x$ax_opts[[name]])) {
|
|
ax$x$ax_opts[[name]] <- l
|
|
} else {
|
|
ax$x$ax_opts[[name]] <- modifyList(
|
|
x = ax$x$ax_opts[[name]],
|
|
val = l,
|
|
keep.null = TRUE
|
|
)
|
|
}
|
|
ax$x$ax_opts[[name]] <- dropNullsOrEmpty(ax$x$ax_opts[[name]])
|
|
return(ax)
|
|
}
|
|
|
|
# Get parameters from an \code{apexcharts} \code{htmlwidget} object.
|
|
.get_ax_opt <- function(ax, name) {
|
|
ax$x$ax_opts[[name]]
|
|
}
|
|
|
|
|
|
|
|
# From vignette('knit_print', package = 'knitr')
|
|
# and https://github.com/rstudio/htmltools/pull/108/files
|
|
|
|
register_s3_method <- function(pkg, generic, class, fun = NULL) { # nocov start
|
|
stopifnot(is.character(pkg), length(pkg) == 1)
|
|
stopifnot(is.character(generic), length(generic) == 1)
|
|
stopifnot(is.character(class), length(class) == 1)
|
|
|
|
if (is.null(fun)) {
|
|
fun <- get(paste0(generic, ".", class), envir = parent.frame())
|
|
} else {
|
|
stopifnot(is.function(fun))
|
|
}
|
|
|
|
if (pkg %in% loadedNamespaces()) {
|
|
registerS3method(generic, class, fun, envir = asNamespace(pkg))
|
|
}
|
|
|
|
# Always register hook in case package is later unloaded & reloaded
|
|
setHook(
|
|
packageEvent(pkg, "onLoad"),
|
|
function(...) {
|
|
registerS3method(generic, class, fun, envir = asNamespace(pkg))
|
|
}
|
|
)
|
|
} # nocov end
|