195 lines
4.3 KiB
R
195 lines
4.3 KiB
R
|
|
#' @title Convert a \code{data.frame} to a \code{list}
|
|
#'
|
|
#' @description Convert data to a format suitable for ApexCharts.js
|
|
#'
|
|
#' @param data A \code{data.frame} or an object coercible to \code{data.frame}.
|
|
#' @param add_names Use names of columns in output. Can be logical to
|
|
#' reuse \code{data} names or a character vector of new names.
|
|
#'
|
|
#' @return A \code{list} that can be used to specify data in \code{\link{ax_series}} for example.
|
|
#'
|
|
#' @export
|
|
#' @importFrom stats setNames
|
|
#'
|
|
#' @examples
|
|
#'
|
|
#' # All iris dataset
|
|
#' parse_df(iris)
|
|
#'
|
|
#' # Keep variables names
|
|
#' parse_df(iris[, 1:2], add_names = TRUE)
|
|
#'
|
|
#' # Use custom names
|
|
#'
|
|
#' parse_df(iris[, 1:2], add_names = c("x", "y"))
|
|
#'
|
|
parse_df <- function(data, add_names = FALSE) {
|
|
data <- as.data.frame(data)
|
|
names_ <- names(data)
|
|
l <- lapply(
|
|
X = data[],
|
|
FUN = function(x) {
|
|
if (inherits(x, "Date")) {
|
|
# js_date(x)
|
|
as.numeric(x) * 1000 * 60*60*24
|
|
} else if (inherits(x, "POSIXt")) {
|
|
# js_date(x)
|
|
as.numeric(x) * 1000
|
|
} else if (inherits(x, "factor")) {
|
|
as.character(x)
|
|
} else {
|
|
# if (!identical(add_names, FALSE)) {
|
|
# formatNoSci(x)
|
|
# } else {
|
|
# x
|
|
# }
|
|
x
|
|
}
|
|
}
|
|
)
|
|
ll <- lapply(
|
|
X = seq_len(nrow(data)),
|
|
FUN = function(i) {
|
|
res <- lapply(l, `[[`, i)
|
|
if (identical(add_names, FALSE)) {
|
|
res <- unname(res)
|
|
}
|
|
if (is.character(add_names) & length(add_names) == length(names_)) {
|
|
res <- setNames(res, nm = add_names)
|
|
}
|
|
return(res)
|
|
}
|
|
)
|
|
return(ll)
|
|
}
|
|
|
|
|
|
|
|
#' @importFrom htmlwidgets JS
|
|
js_date <- function(x) {
|
|
if (inherits(x, "POSIXt"))
|
|
x <- format(x, format = "%Y-%m-%d %H:%M:%S")
|
|
lapply(sprintf("new Date('%s').getTime()", x), JS)
|
|
}
|
|
|
|
parse_timeline_data <- function(.list) {
|
|
if (is.null(.list$group)) {
|
|
lapply(
|
|
X = seq_len(length(.list[[1]])),
|
|
FUN = function(i) {
|
|
val <- lapply(.list, `[[`, i)
|
|
l <- list(
|
|
x = as.character(val$x),
|
|
y = js_date(c(val$start, val$end))
|
|
)
|
|
if (!is.null(val$fill)) {
|
|
l$fillColor <- val$fill
|
|
}
|
|
l
|
|
}
|
|
)
|
|
} else {
|
|
grouped <- as.data.frame(.list, stringsAsFactors = FALSE)
|
|
grouped$group <- NULL
|
|
grouped <- split(
|
|
x = grouped,
|
|
f = .list$group
|
|
)
|
|
grouped <- lapply(grouped, as.list)
|
|
lapply(
|
|
X = names(grouped),
|
|
FUN = function(name) {
|
|
list(
|
|
name = name,
|
|
data = parse_timeline_data(grouped[[name]])
|
|
)
|
|
}
|
|
)
|
|
}
|
|
}
|
|
|
|
|
|
parse_dumbbell_data <- function(.list) {
|
|
if (is.null(.list$group)) {
|
|
lapply(
|
|
X = seq_len(length(.list[[1]])),
|
|
FUN = function(i) {
|
|
val <- lapply(.list, `[[`, i)
|
|
l <- list(
|
|
x = as.character(val$y),
|
|
y = list(val$x, val$xend)
|
|
)
|
|
if (!is.null(val$fill)) {
|
|
l$fillColor <- val$fill
|
|
}
|
|
l
|
|
}
|
|
)
|
|
} else {
|
|
grouped <- as.data.frame(.list, stringsAsFactors = FALSE)
|
|
grouped$group <- NULL
|
|
grouped <- split(
|
|
x = grouped,
|
|
f = .list$group
|
|
)
|
|
grouped <- lapply(grouped, as.list)
|
|
lapply(
|
|
X = names(grouped),
|
|
FUN = function(name) {
|
|
list(
|
|
name = name,
|
|
data = parse_dumbbell_data(grouped[[name]])
|
|
)
|
|
}
|
|
)
|
|
}
|
|
}
|
|
|
|
|
|
|
|
parse_candlestick_data <- function(.list) {
|
|
list(list(
|
|
type = "candlestick",
|
|
data = lapply(
|
|
X = seq_len(length(.list[[1]])),
|
|
FUN = function(i) {
|
|
val <- lapply(.list, `[[`, i)
|
|
list(
|
|
# x = js_date(val$x)[[1]],
|
|
x = as.numeric(val$x) * 1000,
|
|
y = c(val$open, val$high, val$low, val$close)
|
|
)
|
|
}
|
|
)
|
|
))
|
|
}
|
|
|
|
|
|
#' @importFrom graphics boxplot
|
|
parse_boxplot_data <- function(.list, serie_name = NULL) {
|
|
if (!is.numeric(.list$y) & is.numeric(.list$x)) {
|
|
.list[c("x", "y")] <- .list[c("y", "x")]
|
|
}
|
|
boxed <- boxplot(y ~ x, data = .list, plot = FALSE)
|
|
list(dropNulls(list(
|
|
serie_name = serie_name,
|
|
type = "boxPlot",
|
|
data = lapply(
|
|
X = seq_along(boxed$names),
|
|
FUN = function(i) {
|
|
list(
|
|
x = boxed$names[i],
|
|
y = c(
|
|
boxed$stats[1, i],
|
|
boxed$stats[2, i],
|
|
boxed$stats[3, i],
|
|
boxed$stats[4, i],
|
|
boxed$stats[5, i]
|
|
)
|
|
)
|
|
}
|
|
)
|
|
)))
|
|
}
|