Nothing
#' Converts a ggplot object to a list that can be used by CanvasXpress.
#'
#' @param o the ggplot object
#' @param ... additional parameters to the function
#'
#' @export
ggplot.as.list <- function(o, ...) {
if (!(requireNamespace("ggplot2", quietly = TRUE))) {
stop("The ggplot2 package is required to use this functionality.")
} else if (!("ggplot") %in% class(o)) {
stop("Not a ggplot object")
}
target <- "canvas"
bld <- ggplot2::ggplot_build(o)
cx <- list(
renderTo = target,
data = data_to_matrix(o),
aes = gg_mapping(o),
scales = gg_scales(o),
coords = gg_coordinates(o),
theme = gg_theme(o),
labels = gg_labels(o),
facet = gg_facet(o),
order = gg_order(o),
layers = as.vector(NULL),
geoms = as.vector(NULL),
isGGPlot = TRUE,
config = list(...),
isR = TRUE)
layers <- sapply(o$layers, function(x) class(x$geom)[1])
proto_geom <- sapply( sapply( o$layers, "[[", "geom"), function(x) class(x)[[1]][1] )
proto_stat <- sapply( sapply( o$layers, "[[", "stat"), function(x) class(x)[[1]][1] )
for (i in 1:length(layers)) {
l <- layers[i]
p <- gg_proc_layer(o, i)
if ((l == "GeomTile") && (proto_stat[i] == "StatBin2d")) {
l = "GeomBin2d"
} else if ((l == "GeomPoint") && !is.null(p$position) && (p$position == "jitter")) {
l = "GeomJitter"
} else if ((l == "GeomBar") && (proto_stat[i] == "StatBin")) {
l = "GeomHistogram"
} else if ((l == "GeomPath") && (proto_stat[i] == "StatQqLine")) {
l = "GeomQqLine"
} else if ((l == "GeomPoint") && (proto_stat[i] == "StatQq")) {
l = "GeomQq"
} else if (l == "GeomErrorbar" || l == "GeomErrorbarh" || l == "GeomRibbon") {
ll = o$layers[[i]]
if (class(bld$data[[i]]$xmin)[1] == "numeric") {
p$xmin = bld$data[[i]]$xmin
if (rlang::as_label(ll$mapping[["xmin"]]) %in% colnames(o$data)) {
p$x = rlang::as_label(ll$mapping[["xmin"]])
}
}
if (class(bld$data[[i]]$xmax)[1] == "numeric") {
p$xmax = bld$data[[i]]$xmax
if (rlang::as_label(ll$mapping[["xmax"]]) %in% colnames(o$data)) {
p$x = rlang::as_label(ll$mapping[["xmax"]])
}
}
if (class(bld$data[[i]]$ymin)[1] == "numeric") {
p$ymin = bld$data[[i]]$ymin
if (rlang::as_label(ll$mapping[["ymin"]]) %in% colnames(o$data)) {
p$y = rlang::as_label(ll$mapping[["ymin"]])
}
}
if (class(bld$data[[i]]$ymax)[1] == "numeric") {
p$ymax = bld$data[[i]]$ymax
if (rlang::as_label(ll$mapping[["ymax"]]) %in% colnames(o$data)) {
p$y = rlang::as_label(ll$mapping[["ymax"]])
}
}
}
p$stat = proto_stat[i]
q <- list()
q[[l]] <- p
cx$geoms <- append(cx$geoms, l)
cx$layers <- append(cx$layers, q)
}
jsonlite::toJSON(cx, pretty = TRUE, auto_unbox = TRUE)
}
# -- internal helper functions -- #
gg_order <- function(o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
Filter(Negate(is.null), sapply(o$data, levels))
}
gg_facet <- function (o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
f = o$facet$params$facets
if(!is.null(f)) {
f = list(
facet = ls(f),
facetLevels = sort(unique(o$data[[ls(f)]])),
facetType = "wrap",
facetXFree = o$facet$params$free$x,
facetYFree = o$facet$params$free$y,
facetXSpace = o$facet$params$space_free$x,
facetYSpace = o$facet$params$space_free$y
)
if (!is.null(o$facet$params$ncol) && !is.null(o$facet$params$nrow)) {
f$facetCols = o$facet$params$ncol
f$facetRows = o$facet$params$nrow
} else if (is.null(o$facet$params$ncol) && !is.null(o$facet$params$nrow)) {
f$facetRows = o$facet$params$nrow
f$facetCols = ceiling(length(f$facetLevels) / f$facetRows)
} else if (!is.null(o$facet$params$ncol) && is.null(o$facet$params$nrow)) {
f$facetCols = o$facet$params$ncol
f$facetRows = ceiling(length(f$facetLevels) / f$facetCols)
} else {
if (length(f$facetLevels) < 4) {
f$facetRows = 1
f$facetCols = length(f$facetLevels)
} else {
f$facetCols = ceiling(sqrt(length(f$facetLevels)))
f$facetRows = ceiling(length(f$facetLevels) / f$facetCols)
}
}
f$facetTopology = paste(f$facetRows, "X", f$facetCols, sep = "")
} else if (!is.null(o$facet$params$rows) || !is.null(o$facet$params$cols)) {
f = list(
facetType = "grid",
facetXFree = o$facet$params$free$x,
facetYFree = o$facet$params$free$y,
facetXSpace = o$facet$params$space_free$x,
facetYSpace = o$facet$params$space_free$y
)
if (length(o$facet$params$rows) > 0 && length(o$facet$params$cols) > 0) {
f$facet = c(ls(o$facet$params$rows)[1], ls(o$facet$params$cols)[1])
f$facetLevelsRows = sort(unique(o$data[[ls(o$facet$params$rows)]]))
f$facetLevelsCols = sort(unique(o$data[[ls(o$facet$params$cols)]]))
f$facetRows = length(f$facetLevelsRows)
f$facetCols = length(f$facetLevelsCols)
} else if (length(o$facet$params$rows) > 0) {
f$facet = ls(o$facet$params$rows)
f$facetLevelsRows = sort(unique(o$data[[ls(o$facet$params$rows)]]))
f$facetRows = length(f$facetLevels)
f$facetCols = 1
} else if (length(o$facet$params$cols) > 0) {
f$facet = ls(o$facet$params$cols)
f$facetLevelsCols = sort(unique(o$data[[ls(o$facet$params$cols)]]))
f$facetRows = 1
f$facetCols = length(f$facetLevels)
}
f$facetTopology = paste(f$facetRows, "X", f$facetCols, sep = "")
}
f
}
gg_theme <- function(o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
t = list()
atts = ls(o$theme)
if (length(atts) > 0) {
for (a in atts) {
if (is.list(o$theme[[a]])) {
atts2 = ls(o$theme[[a]])
for (b in atts2) {
v = as.character(o$theme[[a]][[b]])
if (length(v) > 0) {
t[[paste(a,b,sep=".")]] = v
}
}
} else {
v = as.character(o$theme[[a]])
if (length(v) > 0) {
t[[a]] = v
}
}
}
}
t
}
gg_scales <- function (o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
r = list();
n = length(o$scales$scales)
if (n > 0) {
for (i in 1:n) {
s = o$scales$scales[[i]]
if (s$aesthetics[1] == "colour" || s$aesthetics[1] == "fill") {
if (!is.null(s$scale_name) && stringr::str_detect(s$scale_name, "gradient")) {
if (s$scale_name == "gradient2") {
s$train(c(-1,1))
} else {
s$train(c(0,1))
}
r$colorSpectrum = s$break_positions()
} else {
p = s$palette(1)
if (!is.null(names(p))) {
k = names(p)
names(p) <- NULL
q = list()
for (j in 1:length(k)) {
q[[k[j]]] = p[j]
}
r$colorKey = q
} else {
r$colors = p
}
}
} else if (s$aesthetics[1] == "x") {
if (!is.null(s$limits)) {
r$setMinX = s$limits[1]
r$setMaxX = s$limits[2]
}
if (!is.null(s$trans$name) && s$trans$name != "identity") {
r$xAxisTransform = stringr::str_replace(s$trans$name, "-", "")
}
if (is.character(s$name)) {
r$xAxisTitle = s$name
}
} else if (s$aesthetics[1] == "y") {
if (!is.null(s$limits)) {
r$setMinY = s$limits[1]
r$setMaxY = s$limits[2]
}
if (!is.null(s$trans$name) && s$trans$name != "identity") {
r$yAxisTransform = stringr::str_replace(s$trans$name, "-", "")
}
if (is.character(s$name)) {
r$yAxisTitle = s$name
}
}
}
}
r
}
gg_coordinates <- function (o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
r = list();
if (!is.null(o$coordinates$limits$x)) {
r$setMinX = o$coordinates$limits$x[1]
r$setMaxX = o$coordinates$limits$x[2]
}
if (!is.null(o$coordinates$limits$y)) {
r$setMinY = o$coordinates$limits$y[1]
r$setMaxY = o$coordinates$limits$y[2]
}
r
}
gg_labels <- function (o) {
if (missing(o)) {
o = ggplot2::last_plot()
}
r = list();
l = c("x", "y", "z", "title", "subtitle", "caption", "colour", "shape", "size")
for (i in l) {
if (!is.null(o$labels[[i]])) {
if (i %in% c("title", "subtitle")) {
r[[i]] = o$labels[[i]]
} else if (i == "caption") {
r["citation"] = o$labels[[i]]
} else if (i %in% c("colour", "shape", "size")) {
if (i == "colour") {
r["colorLegendTitle"] = o$labels[[i]]
} else {
r[[paste(i, "LegendTitle", sep = "")]] = o$labels[[i]]
}
} else {
r[[paste(i, "AxisTitle", sep = "")]] = o$labels[[i]]
}
}
}
r
}
gg_mapping <- function(o) {
if (missing(o)) {
o <- ggplot2::last_plot()
}
r <- list()
m <- c("x", "y", "z", "xmin", "xmax", "ymin", "ymax", "zmin", "zmax", "weight", "group", "colour", "fill", "size", "alpha", "linetype", "label", "vjust", "sample")
e <- TRUE
for (i in m) {
if (!is.null(o$mapping[[i]])) {
e <- FALSE
l <- rlang::as_label(o$mapping[[i]])
if (i == "colour") {
r[["color"]] <- l
} else {
r[[i]] <- l
}
}
}
if (e) {
gg_mapping(o$layers[[1]])
} else {
r
}
}
gg_proc_layer <- function (o, idx) {
l = o$layers[[idx]]
r = list()
q = as.vector(NULL)
if (!is.null(l$mapping)) {
atts = ls(l$mapping)
if (length(atts) > 0) {
for (a in atts) {
b = rlang::as_label(l$mapping[[a]])
f = regexpr("factor", b)[1]
s = regexpr("after_", b)[1]
t = regexpr("stage", b)[1]
g = regexpr("cut_", b)[1]
if (s > 0 || t > 0) {
next
}
if (g > 0) {
p = strsplit(b, split = "\\(" )[[1]]
p[2] = stringr::str_replace(p[2], "\\)", "")
w = strsplit(p[2], split = ",")[[1]]
b = list()
c = list()
c[[w[1]]] = as.numeric(w[2])
b[[p[1]]] = c
r[[a]] = b
} else if (f > 0) {
b = stringr::str_replace(stringr::str_replace(b, "factor\\(", ""), "\\)", "")
q = append(q, b)
if (!(a %in% c("x", "y", "z"))) {
if (a == "colour") {
r[["color"]] = b
} else {
r[[a]] = b
}
}
} else {
if (a == "colour") {
r[["color"]] = b
} else {
r[[a]] = b
}
}
}
}
}
prps = c("aes_params", "geom_params", "stat_params", "position")
skip = c("compute_panel", "preserve", "setup_data", "setup_params", "super", "compute_layer", "orientation", "contour", "distribution", "length")
skip2 = c("na.rm", "reverse", "vjust")
skip_values = list(
na.rm = FALSE,
reverse = FALSE,
vjust = 1
)
for (p in prps) {
if (!is.null(l[[p]])) {
atts = ls(l[[p]])
if (length(atts) > 0) {
for (a in atts) {
if (a %in% skip) {
next
}
if (a %in% skip2 && (is.null(l[[p]][[a]]) || skip_values[a] == l[[p]][[a]])) {
next
}
b = l[[p]][[a]]
if (is.vector(b)) {
f = regexpr("factor", b)[1]
if (is.character(f) && f > 0) {
b = stringr::str_replace(stringr::str_replace(b, "factor\\(", ""), "\\)", "")
}
if (is.null(r[[a]])) {
if (a == "colour") {
r[["color"]] = b
} else {
r[[a]] = b
}
}
}
}
}
}
}
if (!is.na(l$show.legend) && l$show.legend == FALSE) {
r$showLegend = FALSE;
}
if (length(q) > 0) {
r$stringVariableFactors = unique(q)
r$stringSampleFactors = unique(q)
r$asVariableFactors = unique(q)
r$asSampleFactors = unique(q)
}
pos = class(l$position)[1]
pos = ifelse(pos == "PositionJitter", "jitter", ifelse(pos == "PositionFill", "fill", ifelse(pos == "PositionStack", "stack", ifelse(pos == "PositionDodge", "dodge", "normal"))))
if (pos != "normal") {
r$position = pos
}
if (class(l$stat)[1] == "StatSina") {
r$sina = TRUE
} else if (class(l$stat)[1] == "StatStreamDensity") {
r$stream = TRUE
}
if (is.data.frame(l$data)) {
dl = ggplot2::ggplot_build(o)$data[[idx]]
r$data = list()
if ("x" %in% colnames(dl) && "y" %in% colnames(dl)) {
r$data$x = as.numeric(dl[["x"]])
r$data$y = as.numeric(dl[["y"]])
} else {
dl = l$data
nd = data.frame(lapply(dl, as.character), stringsAsFactors = FALSE)
nd = tibble::add_column(nd, Id = row.names(dl), .before = 1)
nd = tibble::add_row(nd, .before = 1)
nd[1,] = colnames(nd)
r$data = as.matrix(nd)
}
}
r
}
data_to_matrix <- function(o) {
layers <- sapply(o$layers, function(x) class(x$geom)[1])
m = c("x", "y", "z")
d = o$data
nd = data.frame(lapply(d, as.character), stringsAsFactors = FALSE)
for (i in m) {
if (!is.null(o$mapping[[i]])) {
q = rlang::as_label(o$mapping[[i]])
if (q %in% colnames(o$data) || q == "1") {
## Nothing to do
} else {
u = as.numeric(ggplot2::ggplot_build(o)$data[[1]][[i]])
nd[q] = u
}
}
}
for (i in 1:length(layers)) {
l <- layers[i]
for (j in m) {
if (!is.null(o$layers[[i]]$mapping[[j]])) {
q = rlang::as_label(o$layers[[i]]$mapping[[j]])
if (q %in% colnames(o$data)) {
## Nothing to do
} else {
u = as.numeric(ggplot2::ggplot_build(o)$data[[i]][[j]])
nd[q] = u
}
}
}
}
nd = tibble::add_column(nd, Id = row.names(d), .before = 1)
nd = tibble::add_row(nd, .before = 1)
nd[1,] = colnames(nd)
as.matrix(nd)
}
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.