Nothing
#' Prepare arguments before sending them to the javascript program.
#'
#' Globally the function reorder data by layerId and time and then it split it
#' by layerId. It also compute some useful values like labels for legend,
#' domain of data, number of data columns.
#'
#' @param options Object created with .preprocessArgs()
#' @param chartdata Data to represent with minicharts
#' @param popupArgs object created with function popupArgs()
#' @param onChange see addMinicharts()
#'
#' @return
#' A list with the following elements:
#' - options: graphical options, split by layerId. Each element contains
#' elements "dyn" (data.frame with values that vary with time), "static"
#' and "timeSteps" (number of time steps)
#' - chartdata: numeric matrix split by layerId
#' - maxValues: maximal value observed in chartdata (NULL if chartdata is NULL)
#' - ncols: number of columns in chartdata
#' - popupArgs: List containing additional data to display in popups (or the
#' popup HTML) split by layerId
#' - legendLab: Labels to use in legends
#' - onChange: Javascript function that will be executed when charts are
#' updated
#'
#' @noRd
#'
.prepareJSArgs <- function(options, chartdata = NULL, popupArgs = NULL,
onChange = NULL, timeFormat = NULL,
initialTime = NULL) {
static <- c("layerId", "lat", "lat0", "lat1", "lng", "lng0", "lng1")
staticOptions <- options$staticOptions
options <- options$options
time <- options$time
correctOrder <- order(options$layerId, options$time)
options <- options[correctOrder, ]
if (is.null(chartdata)) {
legendLab <- NULL
maxValues <- NULL
ncols <- 0
} else {
# When adding only one minichart, chartdata can be a vector or a data frame, so it
# needs to be converted to a matrix with correct lines and columns
if (nrow(options) == 1 && is.vector(chartdata)) {
chartdata <- matrix(chartdata, nrow = 1)
} else {
if (is.vector(chartdata)) {
chartdata <- matrix(chartdata, ncol = 1, nrow = nrow(options))
}
}
# Save column names for legend and transform data in a matrix without names
if (!is.null(popupArgs)) {
if (is.null(popupArgs$labels)) popupArgs$labels <- colnames(chartdata)
legendLab <- popupArgs$labels
} else {
legendLab <- colnames(chartdata)
}
chartdata <- unname(as.matrix(chartdata))
# Save additional information about data before splitting it
maxValues <- max(abs(chartdata))
ncols <- ncol(chartdata)
# sort data and split it by layer
chartdata <- chartdata[correctOrder, ] %>%
split(options$layerId, drop = TRUE) %>%
lapply(matrix, ncol = ncols) %>%
unname()
}
# Popup additional data
if (!is.null(popupArgs$supValues)) {
if (is.null(popupArgs$supLabels)) popupArgs$supLabels <- colnames(popupArgs$supValues)
if (is.null(popupArgs$supLabels) && !is.null(popupArgs$labels)) {
popupArgs$supLabels <- rep("", ncol(popupArgs$supValues))
} else if (is.null(popupArgs$labels) && !is.null(popupArgs$supLabels)) {
popupArgs$labels <-rep("", ncols)
}
popupArgs$supValues <- popupArgs$supValues[correctOrder, ] %>%
as.matrix() %>%
split(options$layerId, drop = TRUE) %>%
lapply(matrix, ncol = ncol(popupArgs$supValues)) %>%
unname()
}
# Popup html
if (!is.null(popupArgs$html)) {
popupArgs$html <- popupArgs$html[correctOrder] %>%
as.character() %>%
split(options$layerId, drop = TRUE) %>%
lapply(.I) %>%
unname()
}
# If there is only one variable in chartdata, we draw circles with different radius
# else we draw bar charts by default.
if ("type" %in% names(staticOptions) && staticOptions$type == "auto") {
staticOptions$type <- ifelse (!is.null(ncols) && ncols == 1, "polar-area", "bar")
}
# Ensure layerId is a character vector
if ("layerId" %in% names(options)) options$layerId <- as.character(options$layerId)
# Finally split options by layer
options <- split(options, options$layerId, drop = TRUE) %>%
unname() %>%
lapply(function(df) {
df$time <- NULL
res <- list(dyn = df, static = list(), timeSteps = nrow(df))
# Add common static options
for (var in names(staticOptions)) {
res$static[[var]] <- staticOptions[[var]]
}
# Add individual static options
for (var in static) {
if (var %in% names(df)) {
res$dyn[[var]] <- NULL
res$static[[var]] <- df[[var]][1]
}
}
res
})
# Ensure labels will always be translated as arrays in JSON
if(!is.null(popupArgs)) {
popupArgs$labels <- .I(popupArgs$labels)
popupArgs$supLabels <- .I(popupArgs$supLabels)
}
# Prepare onChange argument
if (!is.null(onChange)) {
onChange <- sprintf("(function(opts, popup, d3){%s})", onChange)
onChange <- JS(onChange)
}
# Prepare time labels
timeLabels <- sort(unique(time))
if (!is.null(timeFormat)) {
timeLabels <- format(timeLabels, format = timeFormat)
if (!is.null(initialTime)) {
initialTime <- format(initialTime, format = timeFormat)
}
}
timeLabels <- as.character(timeLabels)
if (!is.null(initialTime)) initialTime <- as.character(initialTime)
list(
options = options,
chartdata = chartdata,
maxValues = maxValues,
ncols = ncols,
popupArgs = popupArgs,
legendLab = .I(legendLab),
onChange = onChange,
timeLabels = .I(timeLabels),
initialTime = initialTime
)
}
.I <- function(x) {
if(is.null(x)) x <- list()
I(x)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.