diff --git a/DESCRIPTION b/DESCRIPTION index b8de768c0e..fdf7f66478 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: plotly Title: Create Interactive Web Graphics via Plotly's JavaScript Graphing Library -Version: 2.5.0 +Version: 3.0.0 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"), email = "cpsievert1@gmail.com"), person("Chris", "Parmer", role = c("aut", "cph"), @@ -20,7 +20,7 @@ Description: Easily translate ggplot2 graphs to an interactive web-based version URL: https://plot.ly/r, https://github.com/ropensci/plotly BugReports: https://github.com/ropensci/plotly/issues Depends: - ggplot2 (>= 2.0.0) + ggplot2 (>= 2.1.0) Imports: scales, httr, @@ -30,10 +30,13 @@ Imports: viridis, base64enc, htmlwidgets, + tidyr, plyr Suggests: dplyr, maps, + ggthemes, + GGally, testthat, knitr, devtools, diff --git a/NAMESPACE b/NAMESPACE index 27048db226..58ce37def5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,25 +1,56 @@ # Generated by roxygen2: do not edit by hand +S3method(geom2trace,GeomBar) +S3method(geom2trace,GeomBlank) +S3method(geom2trace,GeomBoxplot) +S3method(geom2trace,GeomErrorbar) +S3method(geom2trace,GeomErrorbarh) +S3method(geom2trace,GeomPath) +S3method(geom2trace,GeomPoint) +S3method(geom2trace,GeomPolygon) +S3method(geom2trace,GeomText) +S3method(geom2trace,GeomTile) +S3method(geom2trace,default) S3method(print,figure) S3method(print,plotly) +S3method(to_basic,GeomAbline) +S3method(to_basic,GeomArea) +S3method(to_basic,GeomBoxplot) +S3method(to_basic,GeomContour) +S3method(to_basic,GeomDensity) +S3method(to_basic,GeomDensity2d) +S3method(to_basic,GeomErrorbar) +S3method(to_basic,GeomErrorbarh) +S3method(to_basic,GeomHline) +S3method(to_basic,GeomJitter) +S3method(to_basic,GeomLine) +S3method(to_basic,GeomLinerange) +S3method(to_basic,GeomPointrange) +S3method(to_basic,GeomRaster) +S3method(to_basic,GeomRect) +S3method(to_basic,GeomRibbon) +S3method(to_basic,GeomSegment) +S3method(to_basic,GeomSmooth) +S3method(to_basic,GeomStep) +S3method(to_basic,GeomTile) +S3method(to_basic,GeomViolin) +S3method(to_basic,GeomVline) +S3method(to_basic,default) export("%>%") export(add_trace) export(as.widget) export(config) export(embed_notebook) export(event_data) +export(geom2trace) export(get_figure) export(gg2list) -export(ggplot_build2) export(ggplotly) -export(group2NA) export(knit_print.figure) export(knit_print.plotly) export(last_plot) -export(layer2traces) export(layout) export(offline) -export(paramORdefault) export(plot_ly) export(plotly) export(plotlyOutput) @@ -32,20 +63,28 @@ export(signup) export(style) export(subplot) export(toRGB) +export(to_basic) import(ggplot2) -import(httr) -import(jsonlite) importFrom(base64enc,base64encode) importFrom(grDevices,col2rgb) importFrom(htmlwidgets,createWidget) importFrom(htmlwidgets,shinyRenderWidget) importFrom(htmlwidgets,shinyWidgetOutput) importFrom(htmlwidgets,sizingPolicy) +importFrom(httr,GET) +importFrom(httr,PATCH) +importFrom(httr,POST) +importFrom(httr,add_headers) +importFrom(httr,config) +importFrom(httr,content) +importFrom(httr,stop_for_status) +importFrom(jsonlite,fromJSON) +importFrom(jsonlite,toJSON) importFrom(magrittr,"%>%") importFrom(plyr,ddply) -importFrom(plyr,join) importFrom(plyr,summarise) importFrom(stats,setNames) +importFrom(tidyr,gather) importFrom(utils,browseURL) importFrom(utils,data) importFrom(utils,getFromNamespace) diff --git a/NEWS b/NEWS index e381bbde96..23dead29c1 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,17 @@ +3.0.0 + +NEW FEATURES: + +* ggplotly() is now about 20x faster (it avoids calling ggplot_build() 20+ times). In some cases, it might be even faster since a lot of other redundant computation is avoided. + +CHANGES: + +* Instead of (trying to) translate both major and minor grid lines, we now translate only major grid lines. This generally produces a result closer to the actual ggplot2 result since ggplot2 doesn't draw ticks on minor grid lines. + +BUG FIXES: + +* ggplotly() now supports most of scale_*()/theme()/guides(). As a result, this fixes a lot of issues (#482, #481, #479, #476, #473, #460, #456, #454, #453, #447, #443, #434, #422, #421, #399, #379, #378, #357, #318, #316, #242, #232, #211, #203, #185, #184, #161). In order to support all of scale_x_*() an scale_y_*(), we always use linear axis types, and supply ticktext/tickvals to plotly.js. This has some unfortunate consequences on hoverformatting, which may be addressed in future releases of plotly.js -- https://github.com/plotly/plotly.js/issues/320 + 2.5.0 -- 1 Mar 2015 NEW FEATURES diff --git a/R/build_function.R b/R/build_function.R deleted file mode 100644 index aef0225417..0000000000 --- a/R/build_function.R +++ /dev/null @@ -1,35 +0,0 @@ -#' ggplot build function with enhanced return -#' -#' This function builds on top of ggplot2::ggplot_build by -#' Hadley Wickham and Winston Chang -#' (http://ggplot2.org, https://github.com/hadley/ggplot2). -#' -#' @param plot ggplot2 plot -#' @return List with (data, panel, plot, prestats.data) where prestats.data -#' is the data as it is prior to calculate_stats() call -#' @keywords internal -#' @export -ggplot_build2 <- local({ - tryCatch({ - # Get body of the original function, in list form - ggplot_build2 <- ggplot2::ggplot_build - g_b <- as.list(body(ggplot_build2)) - - # Find line where we want to insert new code - idx <- grep("compute_statistic", as.character(g_b)) - if (length(idx) != 1) { - warning("Unexpected ggplot2::ggplot_build() definition", call. = FALSE) - } else{ - # Insert new code before that line - new_line <- quote(prestats.data <- data) - return_value <- quote(list(data=data, panel=panel, plot=plot, - prestats.data=prestats.data)) - g_b2 <- c(g_b[seq(1, idx-1)], list(new_line), g_b[seq(idx, length(g_b)-1)], - return_value) - - # Assign the modified body back into the function - body(ggplot_build2) <- as.call(g_b2) - } - ggplot_build2 - }) -}) diff --git a/R/colour_conversion.R b/R/colour_conversion.R deleted file mode 100644 index 3a264f7fd0..0000000000 --- a/R/colour_conversion.R +++ /dev/null @@ -1,30 +0,0 @@ -#' Convert R colours to RGBA hexadecimal colour values -#' @param x character for colour, for example: "white" -#' @param alpha transparency alpha -#' @return hexadecimal colour value (if is.na(x), return "transparent" for compatibility with Plotly) -#' @export -toRGB <- function(x, alpha = 1) { - if (is.null(x)) return(x) - if (identical(x, "NA")) x <- NA - # as of ggplot2 version 1.1, an NA alpha is treated as though it's 1 - if (is.na(alpha)) alpha <- 1 - if (alpha != 1) { - rgb.matrix <- col2rgb(x, TRUE) - rgb.matrix["alpha", 1] <- alpha - ch.vector <- "rgba(%s)" - } else { - rgb.matrix <- col2rgb(x) - ch.vector <- "rgb(%s)" - } - rgb.text <- apply(rgb.matrix, 2, paste, collapse=",") - rgb.css <- sprintf(ch.vector, rgb.text) - ifelse(is.na(x), "transparent", rgb.css) -} - -#' Use default ggplot colour for fill (gray20) if not declared -#' @param x character for colour -#' @param alpha transparency alpha -#' @return hexadecimal colour value -toFill <- function(x, alpha=1) { - ifelse(!is.null(x), toRGB(x, alpha), toRGB("gray20", alpha)) -} diff --git a/R/corresp_one_one.R b/R/corresp_one_one.R deleted file mode 100644 index f3bb2bb58d..0000000000 --- a/R/corresp_one_one.R +++ /dev/null @@ -1,107 +0,0 @@ -# Convert R pch point codes to plotly "symbol" codes. -pch2symbol <- c( - "0" = "square-open", - "1" = "circle-open", - "2" = "triangle-up-open", - "3" = "cross-thin-open", - "4" = "x-thin-open", - "5" = "diamond-open", - "6" = "triangle-down-open", - "7" = "square-x-open", - "8" = "asterisk-open", - "9" = "diamond-x-open", - "10" = "circle-cross-open", - "11" = "hexagram-open", - "12" = "square-cross-open", - "13" = "circle-x-open", - "14" = "square-open-dot", - "15" = "square", - "16" = "circle", - "17" = "triangle-up", - "18" = "diamond", - "19" = "circle", - "20" = "circle", - "21" = "circle", - "22" = "square", - "23" = "diamond", - "24" = "triangle-up", - "25" = "triangle-down", - "32" = "circle", - "35" = "hash-open", - "42" = "asterisk-open", - "43" = "cross-thin-open", - "45" = "line-ew-open", - "47" = "line-ne-open", - "48" = "circle-open", - "79" = "circle-open", - "88" = "x-thin-open", - "92" = "line-nw-open", - "95" = "line-ew-open", - "111" = "circle-open", - "o" = "circle-open", - "O" = "circle-open", - "+" = "cross-thin-open" -) - - -# Convert numeric line type. -numeric.lty <- c( - "0" = "none", - "1" = "solid", - "2" = "dash", - "3" = "dot", - "4" = "dashdot", - "5" = "longdash", - "6" = "longdashdot" -) - -# Convert named line type. -named.lty <- c( - "blank" = "none", - "solid" = "solid", - "dashed" = "dash", - "dotted" = "dot", - "dotdash" = "dashdot", - "longdash" = "longdash", - "twodash" = "longdashdot" -) - -# Convert coded line type. -coded.lty <- c( - "22" = "dash", - "42" = "dot", - "44" = "dashdot", - "13" = "longdash", - "1343" = "longdashdot", - "73" = "dash", - "2262" = "dotdash", - "12223242" = "dotdash", - "F282" = "dash", - "F4448444" = "dash", - "224282F2" = "dash", - "F1" = "dash" -) - -# Convert R lty line type codes to plotly "dash" codes. -lty2dash <- c(numeric.lty, named.lty, coded.lty) - -# Convert ggplot2 aes to line parameters. -aes2line <- c( - linetype = "dash", - colour = "color", - size = "width" -) - -aes2step <- c( - aes2line, - direction = "shape" -) - -# Convert ggplot2 aes to plotly "marker" codes. -aes2marker <- c( - alpha = "opacity", - colour = "color", - size = "size", - shape = "symbol" -) - diff --git a/R/figure.R b/R/figure.R index 37a62cfb4c..6b3edf346b 100644 --- a/R/figure.R +++ b/R/figure.R @@ -20,5 +20,5 @@ get_figure <- function(username, id) { if (missing(id)) stop("Please provide a figure id number") base_url <- file.path(get_domain(), "apigetfile", username, id) resp <- httr::GET(base_url, plotly_headers(), httr::config(ssl_verifypeer=FALSE)) - process(struct(resp, "figure")) + process(append_class(resp, "figure")) } diff --git a/R/ggplotly.R b/R/ggplotly.R index 818b0fc5ad..4d79923deb 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -8,7 +8,7 @@ #' @param height Height of the plot in pixels (optional, defaults to automatic sizing). #' @param source Only relevant for \link{event_data}. #' @seealso \link{signup}, \link{plot_ly} -#' @import httr jsonlite +#' @return a plotly object #' @export #' @author Carson Sievert #' @examples \dontrun{ @@ -16,13 +16,11 @@ #' ggiris <- qplot(Petal.Width, Sepal.Length, data = iris, color = Species) #' ggplotly(ggiris) #' -#' # maps!! #' data(canada.cities, package = "maps") #' viz <- ggplot(canada.cities, aes(long, lat)) + -#' borders(regions = "canada", name = "borders") + +#' borders(regions = "canada") + #' coord_equal() + -#' geom_point(aes(text = name, size = pop), colour = "red", -#' alpha = 1/2, name = "cities") +#' geom_point(aes(text = name, size = pop), colour = "red", alpha = 1/2) #' ggplotly(viz) #' } #' @@ -32,929 +30,752 @@ ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL, hash_plot(p$data, l) } -# ---------------------------------------------------------------------------- -# Objects accessed inside gg2list() -# ---------------------------------------------------------------------------- - -# calc. the epoch -now <- Sys.time() -the.epoch <- now - as.numeric(now) - -aesConverters <- list( - linetype=function(lty) { - lty2dash[as.character(lty)] - }, - colour=function(col) { - toRGB(col) - }, - # ggplot2 size is in millimeters. plotly is in pixels. To do this correctly, - # we need to know PPI/DPI of the display. I'm not sure of a decent way to do that - # from R, but it seems 96 is a reasonable assumption. - size=function(mm) { - (mm * 96) / 25.4 - }, - sizeref=identity, - sizemode=identity, - alpha=identity, - shape=function(pch) { - pch2symbol[as.character(pch)] - }, - direction=identity -) - -markLegends <- - # NOTE: Do we also want to split on size? - # Legends based on sizes not implemented yet in Plotly - # list(point=c("colour", "fill", "shape", "size"), - list(point=c("colour", "fill", "shape"), - path=c("linetype", "size", "colour", "shape"), - ## NOTE: typically "group" should not be present here, since - ## that would mean creating a separate plotly legend for each - ## group, even when they have the exact same visual - ## characteristics and could be drawn using just 1 trace! - polygon=c("colour", "fill", "linetype", "size"), - bar=c("colour", "fill"), - density=c("colour", "fill", "linetype"), - boxplot=c("colour", "fill", "size"), - errorbar=c("colour", "linetype"), - errorbarh=c("colour", "linetype"), - area=c("colour", "fill"), - step=c("linetype", "size", "colour"), - text=c("colour")) - -markUnique <- as.character(unique(unlist(markLegends))) - -markSplit <- markLegends -markSplit$boxplot <- "x" - -# obtain the "type" of geom/position/etc. -type <- function(x, y) { - sub(y, "", tolower(class(x[[y]])[[1]])) -} - -guide_names <- function(p, aes = c("shape", "fill", "alpha", "area", - "color", "colour", "size", "linetype")) { - sc <- as.list(p$scales)$scales - nms <- lapply(sc, "[[", "name") - if (length(nms) > 0) { - names(nms) <- lapply(sc, "[[", "aesthetics") - if (is.null(unlist(nms))) {nms <- list()} - } - unlist(modifyList(p$labels[names(p$labels) %in% aes], nms)) -} - #' Convert a ggplot to a list. -#' @import ggplot2 #' @param p ggplot2 plot. #' @param width Width of the plot in pixels (optional, defaults to automatic sizing). #' @param height Height of the plot in pixels (optional, defaults to automatic sizing). #' @param source Only relevant for \link{event_data}. -#' @return figure object (list with names "data" and "layout"). +#' @return a 'built' plotly object (list with names "data" and "layout"). #' @export gg2list <- function(p, width = NULL, height = NULL, source = "A") { - # ggplot now applies geom_blank() (instead of erroring) when no layers exist - if (length(p$layers) == 0) p <- p + geom_blank() - layout <- list() - trace.list <- list() - - # Before building the ggplot, we would like to add aes(name) to - # figure out what the object group is later. This also copies any - # needed global aes/data values to each layer, so we do not have to - # worry about combining global and layer-specific aes/data later. - for(layer.i in seq_along(p$layers)) { - layer.aes <- p$layers[[layer.i]]$mapping - if(p$layers[[layer.i]]$inherit.aes){ - to.copy <- names(p$mapping)[!names(p$mapping) %in% names(layer.aes)] - layer.aes[to.copy] <- p$mapping[to.copy] - } - mark.names <- names(layer.aes) # make aes.name for all aes. - name.names <- sprintf("%s.name", mark.names) - layer.aes[name.names] <- layer.aes[mark.names] - p$layers[[layer.i]]$mapping <- layer.aes - if(!is.data.frame(p$layers[[layer.i]]$data)){ - p$layers[[layer.i]]$data <- p$data + # ------------------------------------------------------------------------ + # Our internal version of ggplot2::ggplot_build(). Modified from + # https://github.com/hadley/ggplot2/blob/0cd0ba/R/plot-build.r#L18-L92 + # ------------------------------------------------------------------------ + p <- ggfun("plot_clone")(p) + if (length(p$layers) == 0) { + p <- p + geom_blank() + } + layers <- p$layers + layer_data <- lapply(layers, function(y) y$layer_data(p$data)) + scales <- p$scales + by_layer <- function(f) { + out <- vector("list", length(data)) + for (i in seq_along(data)) { + out[[i]] <- f(l = layers[[i]], d = data[[i]]) } - } + out + } + panel <- ggfun("new_panel")() + panel <- ggfun("train_layout")(panel, p$facet, layer_data, p$data) + data <- ggfun("map_layout")(panel, p$facet, layer_data) + data <- by_layer(function(l, d) l$compute_aesthetics(d, p)) + data <- lapply(data, ggfun("scales_transform_df"), scales = scales) + scale_x <- function() scales$get_scales("x") + scale_y <- function() scales$get_scales("y") + panel <- ggfun("train_position")(panel, data, scale_x(), scale_y()) + data <- ggfun("map_position")(panel, data, scale_x(), scale_y()) + # for some geoms (e.g. boxplots) plotly.js needs the "pre-statistics" data + prestats_data <- data + data <- by_layer(function(l, d) l$compute_statistic(d, panel)) + data <- by_layer(function(l, d) l$map_statistic(d, p)) + ggfun("scales_add_missing")(p, c("x", "y"), p$plot_env) + data <- by_layer(function(l, d) l$compute_geom_1(d)) + data <- by_layer(function(l, d) l$compute_position(d, p)) + ggfun("reset_scales")(panel) + panel <- ggfun("train_position")(panel, data, scale_x(), scale_y()) + data <- ggfun("map_position")(panel, data, scale_x(), scale_y()) + npscales <- scales$non_position_scales() + if (npscales$n() > 0) { + lapply(data, ggfun("scales_train_df"), scales = npscales) + data <- lapply(data, ggfun("scales_map_df"), scales = npscales) + } + panel <- ggfun("train_ranges")(panel, p$coordinates) + data <- by_layer(function(l, d) l$compute_geom_2(d)) + # ------------------------------------------------------------------------ + # end of ggplot_build() + # ------------------------------------------------------------------------ + # initiate plotly.js layout with some plot-wide theming stuff + theme <- ggfun("plot_theme")(p) + elements <- names(which(sapply(theme, inherits, "element"))) + for (i in elements) { + theme[[i]] <- ggplot2::calc_element(i, theme) + } + # Translate plot wide theme elements to plotly.js layout + pm <- unitConvert(theme$plot.margin, "pixels") + gglayout <- list( + margin = list(t = pm[[1]], r = pm[[2]], b = pm[[3]], l = pm[[4]]), + plot_bgcolor = toRGB(theme$panel.background$fill), + paper_bgcolor = toRGB(theme$plot.background$fill), + font = text2font(theme$text) + ) + # main plot title + if (nchar(p$labels$title %||% "") > 0) { + gglayout$title <- faced(p$labels$title, theme$plot.title$face) + gglayout$titlefont <- text2font(theme$plot.title) + gglayout$margin$t <- gglayout$margin$t + gglayout$titlefont$size + } + # ensure there's enough space for the modebar (this is based on a height of 1em) + # https://github.com/plotly/plotly.js/blob/dd1547/src/components/modebar/index.js#L171 + gglayout$margin$t <- gglayout$margin$t + 16 - # Test fill and color to see if they encode a quantitative - # variable. This may be useful for several reasons: (1) it is - # sometimes possible to plot several different colors in the same - # trace (e.g. points), and that is faster for large numbers of - # data points and colors; (2) factors on x or y axes should be - # sent to plotly as characters, not as numeric data (which is - # what ggplot_build gives us). - misc <- list() - for(a in c("fill", "colour", "x", "y", "size")){ - for(data.type in c("continuous", "date", "datetime", "discrete")){ - fun.name <- sprintf("scale_%s_%s", a, data.type) - misc.name <- paste0("is.", data.type) - misc[[misc.name]][[a]] <- tryCatch({ - fun <- get(fun.name) - suppressMessages({ - with.scale <- p + fun() - }) - ggplot_build(with.scale) - TRUE - }, error=function(e){ - FALSE - }) - } + # important stuff like panel$ranges is already flipped, but + # p$scales/p$labels/data aren't. We flip x/y trace data at the very end + # and scales in the axis loop below. + if (inherits(p$coordinates, "CoordFlip")) { + p$labels[c("x", "y")] <- p$labels[c("y", "x")] } - ## scales are needed for legend ordering. - misc$breaks <- list() - for(sc in p$scales$scales){ - a.vec <- sc$aesthetics - default.breaks <- inherits(sc$breaks, "waiver") - if (length(a.vec) == 1 && (!default.breaks) ) { - ## TODO: generalize for x/y scales too. - br <- sc$breaks - ranks <- seq_along(br) - names(ranks) <- br - misc$breaks[[a.vec]] <- ranks + # important panel summary stats + nPanels <- nrow(panel$layout) + nRows <- max(panel$layout$ROW) + nCols <- max(panel$layout$COL) + + # panel -> plotly.js axis/anchor info + # (assume a grid layout by default) + panel$layout$xaxis <- panel$layout$COL + panel$layout$yaxis <- panel$layout$ROW + panel$layout$xanchor <- nRows + panel$layout$yanchor <- 1 + if (inherits(p$facet, "wrap")) { + if (p$facet$free$x) { + panel$layout$xaxis <- panel$layout$PANEL + panel$layout$xanchor <- panel$layout$ROW } - ## store if this is a reverse scale so we can undo that later. - if(is.character(sc$trans$name)){ - misc$trans[sc$aesthetics] <- sc$trans$name + if (p$facet$free$y) { + panel$layout$yaxis <- panel$layout$PANEL + panel$layout$yanchor <- panel$layout$COL } - } - reverse.aes <- names(misc$trans)[misc$trans=="reverse"] - - # Extract data from built ggplots - built <- ggplot_build2(p) - # Get global ranges now because we need some of its info in layer2traces - ranges.list <- list() - for(xy in c("x", "y")){ - use.ranges <- - misc$is.continuous[[xy]] || - misc$is.date[[xy]] || - misc$is.datetime[[xy]] - range.values <- if(use.ranges){ - range.name <- paste0(xy, ".range") - sapply(built$panel$ranges, "[[", range.name) - }else{ - ## for categorical variables on the axes, panel$ranges info is - ## meaningless. - name.name <- paste0(xy, ".name") - sapply(built$data, function(df){ - if(name.name %in% names(df)){ - ## usually for discrete data there is a .name column. - paste(df[[name.name]]) - }else{ - ## for heatmaps there may not be. - df[[xy]] - } - }) + if (p$facet$free$x && p$facet$free$y) { + panel$layout$xaxis <- panel$layout$PANEL + panel$layout$yaxis <- panel$layout$PANEL + panel$layout$xanchor <- panel$layout$PANEL + panel$layout$yanchor <- panel$layout$PANEL } - ranges.list[[xy]] <- range(range.values) } + # format the axis/anchor to a format plotly.js respects + panel$layout$xaxis <- paste0("xaxis", sub("1", "", panel$layout$xaxis)) + panel$layout$yaxis <- paste0("yaxis", sub("1", "", panel$layout$yaxis)) + panel$layout$xanchor <- paste0("y", sub("1", "", panel$layout$xanchor)) + panel$layout$yanchor <- paste0("x", sub("1", "", panel$layout$yanchor)) + # for some layers2traces computations, we need the range of each panel + panel$layout$x_min <- sapply(panel$ranges, function(z) min(z$x.range)) + panel$layout$x_max <- sapply(panel$ranges, function(z) max(z$x.range)) + panel$layout$y_min <- sapply(panel$ranges, function(z) min(z$y.range)) + panel$layout$y_max <- sapply(panel$ranges, function(z) max(z$y.range)) - # Get global size range because we need some of its info in layer2traces - if ("size.name" %in% name.names) { - sizerange <- sapply(built$prestats.data, `[[`, "size") - ggsizemin <- min(unlist(sizerange)) - ggsizemax <- max(unlist(sizerange)) - } + # layers -> plotly.js traces + traces <- layers2traces( + data, prestats_data, layers, panel$layout, scales, p$labels + ) + + # ------------------------------------------------------------------------ + # axis/facet/margin conversion + # ------------------------------------------------------------------------ - layer.legends <- list() - for(i in seq_along(built$plot$layers)){ - # This is the layer from the original ggplot object. - L <- p$layers[[i]] - - # for each layer, there is a correpsonding data.frame which - # evaluates the aesthetic mapping. - df <- built$data[[i]] - - # get gglayout now because we need some of its info in layer2traces - gglayout <- built$panel$layout - # invert rows so that plotly and ggplot2 show panels in the same order - gglayout$plotly.row <- max(gglayout$ROW) - gglayout$ROW + 1 - # ugh, ggplot counts panel right-to-left & top-to-bottom - # plotly count them right-to-left & *bottom-to-top* - gglayout$plotly.panel <- with(gglayout, order(plotly.row, COL)) - - # Add ROW and COL to df: needed to link axes to traces; keep df's - # original ordering while merging. - df$order <- seq_len(nrow(df)) - df <- merge(df, gglayout[, c("PANEL", "plotly.row", "COL")]) - df <- df[order(df$order),] - df$order <- NULL - - prestats <- built$prestats.data[[i]] - # scale_reverse multiples x/y data by -1, so here we undo that so - # that the actual data can be uploaded to plotly. - replace.aes <- intersect(names(prestats), reverse.aes) - for (a in replace.aes) { - prestats[[a]] <- -1 * prestats[[a]] + # panel margins must be computed before panel/axis loops + # (in order to use get_domains()) + panelMarginX <- unitConvert( + theme[["panel.margin.x"]] %||% theme[["panel.margin"]], + "npc", "width" + ) + panelMarginY <- unitConvert( + theme[["panel.margin.y"]] %||% theme[["panel.margin"]], + "npc", "height" + ) + # space for _interior_ facet strips + if (inherits(p$facet, "wrap")) { + stripSize <- unitConvert( + theme[["strip.text.x"]] %||% theme[["strip.text"]], + "npc", "height" + ) + # TODO: why does stripSize need to be inflated here? + panelMarginY <- panelMarginY + 1.5 * stripSize + # space for ticks/text in free scales + if (p$facet$free$x) { + axisTicksX <- unitConvert( + theme[["axis.ticks.x"]] %||% theme[["axis.ticks"]], + "npc", "height" + ) + # allocate enough space for the _longest_ text label + axisTextX <- theme[["axis.text.x"]] %||% theme[["axis.text"]] + labz <- unlist(lapply(panel$ranges, "[[", "x.labels")) + lab <- labz[which.max(nchar(labz))] + panelMarginY <- panelMarginY + axisTicksX + + bbox(lab, axisTextX$angle, unitConvert(axisTextX, "npc", "height"))[["height"]] } - L$prestats.data <- - merge(prestats, - gglayout[, c("PANEL", "plotly.row", "COL")]) - - # Add global range info. - for(xy in names(ranges.list)){ - range.vec <- ranges.list[[xy]] - names(range.vec) <- c("min", "max") - for(range.name in names(range.vec)){ - glob.name <- paste0("glob", xy, range.name) - L$prestats.data[[glob.name]] <- range.vec[[range.name]] - } + if (p$facet$free$y) { + axisTicksY <- unitConvert( + theme[["axis.ticks.y"]] %||% theme[["axis.ticks"]], + "npc", "width" + ) + # allocate enough space for the _longest_ text label + axisTextY <- theme[["axis.text.y"]] %||% theme[["axis.text"]] + labz <- unlist(lapply(panel$ranges, "[[", "y.labels")) + lab <- labz[which.max(nchar(labz))] + panelMarginX <- panelMarginX + axisTicksY + + bbox(lab, axisTextY$angle, unitConvert(axisTextY, "npc", "width"))[["width"]] } - - # Add global size info if relevant - if ("size.name" %in% name.names) { - L$prestats.data$globsizemin <- ggsizemin - L$prestats.data$globsizemax <- ggsizemax - } - - # This extracts essential info for this geom/layer. - traces <- layer2traces(L, df, misc) - - possible.legends <- markLegends[[type(L, "geom")]] - actual.legends <- possible.legends[possible.legends %in% names(L$mapping)] - layer.legends[[paste(i)]] <- actual.legends - - # Do we really need to coord_transform? - # g$data <- ggplot2:::coord_transform(built$plot$coord, g$data, - # built$panel$ranges[[1]]) - trace.list <- c(trace.list, traces) } + margins <- c( + rep(panelMarginX, 2), + rep(panelMarginY, 2) + ) + doms <- get_domains(nPanels, nRows, margins) - # for barcharts, verify that all traces have the same barmode; we don't - # support different barmodes on the same plot yet. - barmodes <- do.call(c, lapply(trace.list, function (x) x$barmode)) - barmodes <- barmodes[!is.null(barmodes)] - if (length(barmodes) > 0) { - layout$barmode <- barmodes[1] - if (!all(barmodes == barmodes[1])) - warning(paste0("You have multiple barcharts or histograms with different positions; ", - "Plotly's layout barmode will be '", layout$barmode, "'.")) - # for stacked bar charts, plotly cumulates bar heights, but ggplot doesn't - if (layout$barmode == "stack") { - # could speed up this function with environments or C/C++ - unStack <- function(vec) { - n <- length(vec) - if (n == 1) return(vec) - seq.n <- seq_len(n) - names(vec) <- seq.n - vec <- sort(vec) - for (k in seq(2, n)) { - vec[k] <- vec[k] - sum(vec[seq(1, k-1)]) + for (i in seq_len(nPanels)) { + lay <- panel$layout[i, ] + for (xy in c("x", "y")) { + # find axis specific theme elements that inherit from their parent + theme_el <- function(el) { + theme[[paste0(el, ".", xy)]] %||% theme[[el]] + } + axisTicks <- theme_el("axis.ticks") + axisText <- theme_el("axis.text") + axisTitle <- theme_el("axis.title") + axisLine <- theme_el("axis.line") + panelGrid <- theme_el("panel.grid.major") + stripText <- theme_el("strip.text") + + axisName <- lay[, paste0(xy, "axis")] + anchor <- lay[, paste0(xy, "anchor")] + rng <- panel$ranges[[i]] + # stuff like panel$ranges is already flipped, but scales aren't + sc <- if (inherits(p$coordinates, "CoordFlip")) { + scales$get_scales(setdiff(c("x", "y"), xy)) + } else { + scales$get_scales(xy) + } + # type of unit conversion + type <- if (xy == "x") "height" else "width" + # https://plot.ly/r/reference/#layout-xaxis + axisObj <- list( + type = "linear", + autorange = FALSE, + tickmode = "array", + range = rng[[paste0(xy, ".range")]], + ticktext = rng[[paste0(xy, ".labels")]], + # TODO: implement minor grid lines with another axis object + # and _always_ hide ticks/text? + tickvals = rng[[paste0(xy, ".major")]], + ticks = if (is_blank(axisTicks)) "" else "outside", + tickcolor = toRGB(axisTicks$colour), + ticklen = unitConvert(theme$axis.ticks.length, "pixels", type), + tickwidth = unitConvert(axisTicks, "pixels", type), + showticklabels = !is_blank(axisText), + tickfont = text2font(axisText, "height"), + tickangle = - (axisText$angle %||% 0), + showline = !is_blank(axisLine), + linecolor = toRGB(axisLine$colour), + linewidth = unitConvert(axisLine, "pixels", type), + showgrid = !is_blank(panelGrid), + domain = sort(as.numeric(doms[i, paste0(xy, c("start", "end"))])), + gridcolor = toRGB(panelGrid$colour), + gridwidth = unitConvert(panelGrid, "pixels", type), + zeroline = FALSE, + anchor = anchor + ) + # convert dates to milliseconds (86400000 = 24 * 60 * 60 * 1000) + # this way both dates/datetimes are on same scale + # hopefully scale_name doesn't go away -- https://github.com/hadley/ggplot2/issues/1312 + if (identical("date", sc$scale_name)) { + axisObj$range <- axisObj$range * 86400000 + if (i == 1) { + traces <- lapply(traces, function(z) { z[[xy]] <- z[[xy]] * 86400000; z }) } - as.numeric(vec[as.character(seq.n)]) } - ys <- lapply(trace.list, "[[", "y") - xs <- lapply(trace.list, "[[", "x") - x.vals <- unique(unlist(xs)) - # if there are two or more y-values (for a particular x value), - # then modify those y-values so they *add up* to the correct value(s) - for (val in x.vals) { - zs <- lapply(xs, function(x) which(x == val)) - ys.given.x <- Map(function(x, y) y[x], zs, ys) - if (length(unlist(ys.given.x)) < 2) next - st <- unStack(unlist(ys.given.x)) - lens <- sapply(ys.given.x, length) - trace.seq <- seq_along(trace.list) - ws <- split(st, rep(trace.seq, lens)) - for (tr in seq_along(ws)) { - idx <- zs[[tr]] - replacement <- ws[[tr]] - if (length(idx) > 0 && length(replacement) > 0) - trace.list[[tr]]$y[idx] <- replacement + # tickvals are currently on 0-1 scale, but we want them on data scale + axisObj$tickvals <- scales::rescale( + axisObj$tickvals, to = axisObj$range, from = c(0, 1) + ) + # attach axis object to the layout + gglayout[[axisName]] <- axisObj + + # do some stuff that should be done once for the entire plot + if (i == 1) { + # add space for exterior facet strips in `layout.margin` + if (has_facet(p)) { + stripSize <- unitConvert(stripText, "pixels", type) + if (xy == "x") { + gglayout$margin$t <- gglayout$margin$t + stripSize + } + if (xy == "y" && inherits(p$facet, "grid")) { + gglayout$margin$r <- gglayout$margin$r + stripSize + } + } + axisTitleText <- sc$name %||% p$labels[[xy]] %||% "" + if (is_blank(axisTitle)) axisTitleText <- "" + axisTickText <- axisObj$ticktext[which.max(nchar(axisObj$ticktext))] + side <- if (xy == "x") "b" else "l" + # account for axis ticks, ticks text, and titles in plot margins + # (apparently ggplot2 doesn't support axis.title/axis.text margins) + gglayout$margin[[side]] <- gglayout$margin[[side]] + axisObj$ticklen + + bbox(axisTickText, axisObj$tickangle, axisObj$tickfont$size)[[type]] + + bbox(axisTitleText, axisTitle$angle, unitConvert(axisTitle, "pixels", type))[[type]] + # draw axis titles as annotations + # (plotly.js axis titles aren't smart enough to dodge ticks & text) + if (nchar(axisTitleText) > 0) { + axisTextSize <- unitConvert(axisText, "npc", type) + axisTitleSize <- unitConvert(axisTitle, "npc", type) + offset <- + (0 - + bbox(axisTickText, axisText$angle, axisTextSize)[[type]] - + bbox(axisTitleText, axisTitle$angle, axisTitleSize)[[type]] / 2 - + unitConvert(theme$axis.ticks.length, "npc", type)) + # npc is on a 0-1 scale of the _entire_ device, + # but these units _should_ be wrt to the plotting region + # multiplying the offset by 2 seems to work, but this is a terrible hack + offset <- 1.75 * offset + x <- if (xy == "x") 0.5 else offset + y <- if (xy == "x") offset else 0.5 + gglayout$annotations <- c( + gglayout$annotations, + make_label( + faced(axisTitleText, axisTitle$face), x, y, el = axisTitle, + xanchor = "center", yanchor = "middle" + ) + ) } } + + } # end of axis loop + + xdom <- gglayout[[lay[, "xaxis"]]]$domain + ydom <- gglayout[[lay[, "yaxis"]]]$domain + border <- make_panel_border(xdom, ydom, theme) + gglayout$shapes <- c(gglayout$shapes, border) + + # facet strips -> plotly annotations + # TODO: use p$facet$labeller for the actual strip text! + if (!is_blank(theme[["strip.text.x"]]) && + (inherits(p$facet, "wrap") || inherits(p$facet, "grid") && lay$ROW == 1)) { + vars <- ifelse(inherits(p$facet, "wrap"), "facets", "cols") + txt <- paste( + lay[, as.character(p$facet[[vars]])], collapse = ", " + ) + lab <- make_label( + txt, x = mean(xdom), y = max(ydom), + el = theme[["strip.text.x"]] %||% theme[["strip.text"]], + xanchor = "center", yanchor = "bottom" + ) + gglayout$annotations <- c(gglayout$annotations, lab) + strip <- make_strip_rect(xdom, ydom, theme, "top") + gglayout$shapes <- c(gglayout$shapes, strip) } - } - - # Bar Gap for histograms should be 0 - bargaps <- do.call(c, lapply(trace.list, function (x) x$bargap)) - if (length(bargaps) > 0) { - if (any(bargaps == 0)) { - layout$bargap <- 0 - if (!all(bargaps == 0)) { - warning("You have multiple bar charts and histograms;\n - Plotly's layout bargap will be 0 for all of them.") - } - } else { - bargaps <- NULL # Do not specify anything + if (inherits(p$facet, "grid") && lay$COL == nCols && nRows > 1 && + !is_blank(theme[["strip.text.y"]])) { + txt <- paste( + lay[, as.character(p$facet$rows)], collapse = ", " + ) + lab <- make_label( + txt, x = max(xdom), y = mean(ydom), + el = theme[["strip.text.y"]] %||% theme[["strip.text"]], + xanchor = "left", yanchor = "middle" + ) + gglayout$annotations <- c(gglayout$annotations, lab) + strip <- make_strip_rect(xdom, ydom, theme, "right") + gglayout$shapes <- c(gglayout$shapes, strip) } - } + + } # end of panel loop - # Export axis specification as a combination of breaks and labels, on - # the relevant axis scale (i.e. so that it can be passed into d3 on the - # x axis scale instead of on the grid 0-1 scale). This allows - # transformations to be used out of the box, with no additional d3 - # coding. - theme.pars <- getFromNamespace("plot_theme", "ggplot2")(p) + # ------------------------------------------------------------------------ + # guide conversion + # Strategy: Obtain and translate the output of ggplot2:::guides_train(). + # To do so, we borrow some of the body of ggplot2:::guides_build(). + # ------------------------------------------------------------------------ - # Flip labels if coords are flipped - transform does not take care - # of this. Do this BEFORE checking if it is blank or not, so that - # individual axes can be hidden appropriately, e.g. #1. - # ranges <- built$panel$ranges[[1]] - # if("flip"%in%attr(built$plot$coordinates, "class")){ - # temp <- built$plot$labels$x - # built$plot$labels$x <- built$plot$labels$y - # built$plot$labels$y <- temp - # } - e <- function(el.name){ - ggplot2::calc_element(el.name, p$theme) - } - is.blank <- function(el.name, null.is.blank=FALSE) { - # NULL shows ticks and hides borders - cls <- attr(e(el.name),"class") - "element_blank" %in% cls || null.is.blank && is.null(cls) - } - trace.order.list <- list() - trace.name.map <- c() - for(xy in c("x","y")){ - ax.list <- list() - coord.lim <- p$coordinates$limits[[xy]] %||% p$scales$get_scales(xy)$limits - if(is.numeric(coord.lim)){ - ## TODO: maybe test for more exotic coord specification types - ## involving NA, Inf, etc? - ax.list$range <- coord.lim - } - s <- function(tmp)sprintf(tmp, xy) - ax.list$tickcolor <- toRGB(theme.pars$axis.ticks$colour) - - # When gridlines are dotted or dashed: - grid <- theme.pars$panel.grid - grid.major <- theme.pars$panel.grid.major - if ((!is.null(grid$linetype) || !is.null(grid.major$linetype)) && - c(grid$linetype, grid.major$linetype) %in% c(2, 3, "dashed", "dotted")) { - ax.list$gridcolor <- ifelse(is.null(grid.major$colour), - toRGB(grid$colour, 0.1), - toRGB(grid.major$colour, 0.1)) - } else { - ax.list$gridcolor <- toRGB(grid.major$colour) - } + # will there be a legend? + gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) > 1 + + # legend styling + gglayout$legend <- list( + bgcolor = toRGB(theme$legend.background$fill), + bordercolor = toRGB(theme$legend.background$colour), + borderwidth = unitConvert(theme$legend.background$size, "pixels", "width"), + font = text2font(theme$legend.text) + ) + + # if theme(legend.position = "none") is used, don't show a legend _or_ guide + if (npscales$n() == 0 || identical(theme$legend.position, "none")) { + gglayout$showlegend <- FALSE + } else { + # by default, guide boxes are vertically aligned + theme$legend.box <- theme$legend.box %||% "vertical" - ax.list$showgrid <- !is.blank(s("panel.grid.major.%s")) - # These numeric length variables are not easily convertible. - #ax.list$gridwidth <- as.numeric(theme.pars$panel.grid.major$size) - #ax.list$ticklen <- as.numeric(theme.pars$axis.ticks.length) + # size of key (also used for bar in colorbar guide) + theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size + theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size - theme2font <- function(text){ - if(!is.null(text)){ - list(family=text$family, - size=text$size, - color=toRGB(text$colour)) - } - } - # Ticks. - if (is.blank("axis.ticks")) { - ax.list$ticks <- "" - } else if (is.blank(s("axis.ticks.%s"))) { - ax.list$ticks <- "" - } else { - ax.list$ticks <- "outside" # by default ggplot2 plots have ticks - } - ax.list$tickwidth <- theme.pars$axis.ticks$size - tick.text.name <- s("axis.text.%s") - ax.list$showticklabels <- !is.blank(tick.text.name) - tick.text <- e(tick.text.name) - if (is.numeric(tick.text$angle)) { - ax.list$tickangle <- -tick.text$angle + # legend direction must be vertical + theme$legend.direction <- theme$legend.direction %||% "vertical" + if (!identical(theme$legend.direction, "vertical")) { + warning( + "plotly.js does not (yet) support horizontal legend items \n", + "You can track progress here: \n", + "https://github.com/plotly/plotly.js/issues/53 \n", + call. = FALSE + ) + theme$legend.direction <- "vertical" } - ax.list$tickfont <- theme2font(tick.text) - ## determine axis type first, since this information is used later - ## (trace.order.list is only used for type=category). - title.text <- e(s("axis.title.%s")) - ax.list$titlefont <- theme2font(title.text) - ax.list$type <- if (misc$is.continuous[[xy]]){ - "linear" - } else if (misc$is.discrete[[xy]]){ - "category" - } else if (misc$is.date[[xy]] || misc$is.datetime[[xy]]){ - "date" - } else { - stop("unrecognized data type for ", xy, " axis") + # justification of legend boxes + theme$legend.box.just <- theme$legend.box.just %||% c("center", "center") + # scales -> data for guides + gdefs <- ggfun("guides_train")(scales, theme, p$guides, p$labels) + if (length(gdefs) > 0) { + gdefs <- ggfun("guides_merge")(gdefs) + gdefs <- ggfun("guides_geom")(gdefs, layers, p$mapping) } - # Translate axes labels. - scale.i <- which(p$scales$find(xy)) - ax.list$title <- if(length(scale.i)){ - sc <- p$scales$scales[[scale.i]] - if(ax.list$type == "category"){ - trace.order.list[[xy]] <- sc$limits - if(is.character(sc$breaks)){ - if(is.character(sc$labels)){ - trace.name.map[sc$breaks] <- sc$labels - } - ##TODO: if(is.function(sc$labels)){ - } - } - if (is.null(sc$breaks)) { - ax.list$showticklabels <- FALSE - ax.list$showgrid <- FALSE - ax.list$ticks <- "" + # colourbar -> plotly.js colorbar + colorbar <- compact(lapply(gdefs, gdef2trace, theme, gglayout)) + nguides <- length(colorbar) + gglayout$showlegend + # If we have 2 or more guides, set x/y positions accordingly + if (nguides >= 2) { + # place legend at the bottom + gglayout$legend$y <- 1 / nguides + gglayout$legend$yanchor <- "top" + # adjust colorbar position(s) + for (i in seq_along(colorbar)) { + colorbar[[i]]$marker$colorbar$yanchor <- "top" + colorbar[[i]]$marker$colorbar$len <- 1 / nguides + colorbar[[i]]$marker$colorbar$y <- 1 - (i - 1) * (1 / nguides) } - if (is.numeric(sc$breaks)) { - dticks <- diff(sc$breaks) - dt <- dticks[1] - if(all(dticks == dt)){ - ax.list$dtick <- dt - ax.list$autotick <- FALSE - } - } - ax.list$range <- if(!is.null(sc$limits)){ - sc$limits - }else{ - if(misc$is.continuous[[xy]]){ - built$panel$ranges[[1]][[s("%s.range")]] #TODO: facets! - }else{ # for a discrete scale, range should be NULL. - NULL - } - } - if(is.character(sc$trans$name) && sc$trans$name == "reverse"){ - ax.list$range <- sort(-ax.list$range, decreasing = TRUE) - } - if(!is.null(sc$name)){ - sc$name - }else{ - p$labels[[xy]] - } - }else{ - p$labels[[xy]] } - - ax.list$zeroline <- FALSE # ggplot2 plots do not show zero lines - # Lines drawn around the plot border. - ax.list$showline <- !is.blank("panel.border", TRUE) - ax.list$linecolor <- toRGB(theme.pars$panel.border$colour) - ax.list$linewidth <- theme.pars$panel.border$size - # Some other params that we used in animint but we don't yet - # translate to plotly: - !is.blank(s("axis.line.%s")) - layout[[s("%saxis")]] <- ax.list - # remove traces that are outside the range of (discrete) scales - nms <- unlist(lapply(traces, "[[", "name")) - if (is.discrete(ax.list$range) && !is.null(nms)) - trace.list <- trace.list[nms %in% ax.list$range] - } - # copy [x/y]axis to [x/y]axisN and set domain, range, etc. for each - xaxis.title <- layout$xaxis$title - yaxis.title <- layout$yaxis$title - inner.margin <- 0.01 # between facets - outer.margin <- 0.05 # to put titles outside of the plots - orig.xaxis <- layout$xaxis - orig.yaxis <- layout$yaxis - if (nrow(gglayout) > 1) { - row.size <- 1. / max(gglayout$ROW) - col.size <- 1. / max(gglayout$COL) - npanels <- nrow(gglayout) - for (i in seq_len(npanels)) { - row <- gglayout[i, "plotly.row"] - col <- gglayout[i, "COL"] - panel <- gglayout[i, "plotly.panel"] - x <- col * col.size - xmin <- x - col.size - xmax <- x - inner.margin - y <- row * row.size - ymin <- y - row.size - ymax <- y - inner.margin - # assume grid layout by default where axes are restrict to the exterior - xaxis.name <- if (col == 1) "xaxis" else paste0("xaxis", col) - yaxis.name <- if (row == 1) "yaxis" else paste0("yaxis", row) - # anchor needs to be incremented if the corresponding axis is "free" - xanchor <- "y" - yanchor <- "x" - if ("wrap" %in% class(p$facet)) { - # in wrap layout, axes can be drawn on interior (if scales are free) - # make room for facet strip label - ymax <- ymax - 0.04 - # make room for yaxis labels (this should be a function of label size) - if (col == 1) { - xmax <- xmax - 0.02 - } else { - xmin <- xmin + 0.02 - } - # make room for xaxis labels - if (row == 1) { - ymax <- ymax - 0.02 - } else { - ymin <- ymin + 0.02 - } - if (p$facet$free$y && panel > 1) { - # draw a y-axis on each panel - yaxis.name <- paste0("yaxis", panel) - for (j in seq_along(trace.list)) { - tr <- trace.list[[j]] - if (tr$PANEL == panel) { - trace.list[[j]]$yaxis <- paste0("y", panel) - } - } - yanchor <- if (p$facet$free$x) paste0("x", panel) else paste0("x",col) - } - if (p$facet$free$x && panel > 1) { - # draw an x-axis on each panel - xaxis.name <- paste0("xaxis", panel) - for (j in seq_along(trace.list)) { - tr <- trace.list[[j]] - if (tr$PANEL == panel) { - trace.list[[j]]$xaxis <- paste0("x", panel) - } - } - xanchor <- if (p$facet$free$y) paste0("y", panel) else paste0("y",row) - } - } - layout[[xaxis.name]] <- orig.xaxis - layout[[xaxis.name]]$domain <- c(xmin, xmax) - layout[[xaxis.name]]$anchor <- xanchor - layout[[xaxis.name]]$title <- NULL - layout[[yaxis.name]] <- orig.yaxis - layout[[yaxis.name]]$domain <- c(ymin, ymax) - layout[[yaxis.name]]$anchor <- yanchor - layout[[yaxis.name]]$title <- NULL - if (is.null(layout[[xaxis.name]]$anchor)) - layout[[xaxis.name]]$anchor <- "y" - if (is.null(layout[[yaxis.name]]$anchor)) - layout[[yaxis.name]]$anchor <- "x" - # range only makes sense for numeric data - if (orig.xaxis$type == "linear") { - layout[[xaxis.name]]$range <- built$panel$ranges[[i]]$x.range - layout[[xaxis.name]]$autorange <- FALSE - } - if (orig.yaxis$type == "linear") { - layout[[yaxis.name]]$range <- built$panel$ranges[[i]]$y.range - layout[[yaxis.name]]$autorange <- FALSE - } - } - # add panel titles as annotations - annotations <- list() - nann <- 1 - make.label <- function(text, x, y, xanchor="auto", yanchor="auto", textangle=0) - list(text=text, showarrow=FALSE, x=x, y=y, ax=0, ay=0, - xref="paper", yref="paper", xanchor=xanchor, yanchor=yanchor, - textangle=textangle) - if ("grid" %in% class(p$facet)) { - frows <- names(p$facet$rows) - nann <- 1 - - for (i in seq_len(max(gglayout$ROW))) { - text <- paste(lapply(gglayout[gglayout$ROW == i, frows, drop=FALSE][1,], - as.character), - collapse=", ") - if (text != "") { # to not create extra annotations - increase_margin_r <- TRUE - annotations[[nann]] <- make.label(text, - 1 + outer.margin - 0.04, - row.size * (max(gglayout$ROW)-i+0.5), - xanchor="center", - textangle=90) - nann <- nann + 1 - } - } - fcols <- names(p$facet$cols) - for (i in seq_len(max(gglayout$COL))) { - text <- paste(lapply(gglayout[gglayout$COL == i, fcols, drop=FALSE][1,], - as.character), - collapse=", ") - if (text!="") { - annotations[[nann]] <- make.label(text, - col.size * (i-0.5) - inner.margin/2, - 1 + outer.margin, - xanchor="center") - nann <- nann + 1 - } - } - - # add empty traces everywhere so that the background shows even if there - # is no data for a facet - for (r in seq_len(max(gglayout$ROW))) - for (c in seq_len(max(gglayout$COL))) - trace.list <- c(trace.list, list(list(xaxis=paste0("x", c), yaxis=paste0("y", r), showlegend=FALSE))) - } else if ("wrap" %in% class(p$facet)) { - facets <- names(p$facet$facets) - for (i in seq_len(max(as.numeric(gglayout$PANEL)))) { - ix <- gglayout$PANEL == i - row <- gglayout$ROW[ix] - col <- gglayout$COL[ix] - text <- paste(lapply(gglayout[ix, facets, drop=FALSE][1,], - as.character), - collapse=", ") - annotations[[nann]] <- make.label(text, - col.size * (col-0.5) - inner.margin/2, - row.size * (max(gglayout$ROW) - row + 0.985), - xanchor="center", - yanchor="top") - nann <- nann + 1 - } - } - # axes titles - annotations[[nann]] <- make.label(xaxis.title, - 0.5, - -outer.margin, - yanchor="top") - nann <- nann + 1 - annotations[[nann]] <- make.label(yaxis.title, - -outer.margin, - 0.5, - textangle=-90) - layout$annotations <- annotations + traces <- c(traces, colorbar) } - # Main plot title. - layout$title <- built$plot$labels$title - - # Background color. - layout$plot_bgcolor <- toRGB(theme.pars$panel.background$fill) - layout$paper_bgcolor <- toRGB(theme.pars$plot.background$fill) - - # Legend. - layout$margin$r <- 10 - if (exists("increase_margin_r")) { - layout$margin$r <- 60 - } - layout$legend <- list(bordercolor = "transparent", - x = 1.01, - y = 0.075 * 0.5* length(trace.list) + 0.45, - xref="paper", yref="paper", - xanchor = "left", yanchor = "top") - - ## Legend hiding when guides(fill="none"). - legends.present <- unique(unlist(layer.legends)) - is.false <- function(x){ - is.logical(x) && length(x) == 1 && x == FALSE - } - is.none <- function(x){ - is.character(x) && length(x) == 1 && x == "none" - } - is.hidden <- function(x){ - is.false(x) || is.none(x) - } - layout$showlegend <- if(length(legends.present) == 0) FALSE else TRUE - for(a in legends.present){ - if(is.hidden(p$guides[[a]])){ - layout$showlegend <- FALSE + # geom_bar() hacks + geoms <- sapply(layers, ggtype, "geom") + if (any(idx <- geoms %in% "bar")) { + # since `layout.barmode` is plot-specific, we can't support multiple bar + # geoms with different positions + positions <- sapply(layers, ggtype, "position") + position <- unique(positions[geoms %in% "bar"]) + if (length(position) > 1) { + warning("plotly doesn't support multiple positions\n", + "across geom_bar() layers", call. = FALSE) + position <- position[1] } - } - # Legend hiding from theme. - if(theme.pars$legend.position=="none"){ - layout$showlegend <- FALSE - } - - # Only show a legend title if there is at least 1 trace with - # showlegend=TRUE. - ggplot_labels <- ggplot2::labs(p)$labels - trace.showlegend <- sapply(trace.list, "[[", "showlegend") - if (any(trace.showlegend) && layout$showlegend && length(p$data)) { - # Retrieve legend title - temp.title <- guide_names(p) - legend.title <- if (length(unique(temp.title)) > 1){ - paste(temp.title, collapse = " / ") - } else { - unique(temp.title) - } - legend.title <- paste0("", legend.title, "") - - # Create legend title element as an annotation - if (exists("annotations")) { - nann <- nann + 1 + # hacks for position_identity() + if (position == "identity") { + gglayout$barmode <- "overlay" + gglayout$legend$traceorder <- "reversed" } else { - annotations <- list() - nann <- 1 + gglayout$barmode <- "stack" } - annotations[[nann]] <- list(text=legend.title, - x = layout$legend$x * 1.0154, - y = 0.075 * 0.5* length(trace.list) + 0.55, - showarrow=FALSE, - xref="paper", yref="paper", - xanchor="left", yanchor = "top", - textangle=0) - layout$annotations <- annotations - } - # Family font for text - if (!is.null(theme.pars$text$family)) { - layout$titlefont$family <- theme.pars$text$family - layout$legend$font$family <- theme.pars$text$family - } - - # Family font for title - if (!is.null(theme.pars$plot.title$family)) { - layout$titlefont$family <- theme.pars$plot.title$family - } - - # Family font for legend - if (!is.null(theme.pars$legend.text$family)) { - layout$legend$font$family <- theme.pars$legend.text$family - } - - # Bold, italic and bold.italic face for text - text_face <- theme.pars$text$face - if (!is.null(text_face)) { - if (text_face=="bold") { - layout$title <- paste0("", layout$title, "") - layout$yaxis$title <- paste0("", layout$yaxis$title, "") - layout$xaxis$title <- paste0("", layout$xaxis$title, "") - } else if (text_face=="italic") { - layout$title <- paste0("", layout$title, "") - layout$yaxis$title <- paste0("", layout$yaxis$title, "") - layout$xaxis$title <- paste0("", layout$xaxis$title, "") - } else if (text_face=="bold.italic") { - layout$title <- paste0("", layout$title, "") - layout$yaxis$title <- paste0("", layout$yaxis$title, "") - layout$xaxis$title <- paste0("", layout$xaxis$title, "") + # note: ggplot2 doesn't flip x/y scales when the coord is flipped + # (i.e., at this point, y should be the count/density) + is_hist <- inherits(p$scales$get_scales("x"), "ScaleContinuous") + # TODO: get rid of this and use explicit width for bars + # https://github.com/plotly/plotly.js/issues/80 + if (position == "dodge" || is_hist) { + gglayout$bargap <- 0 } } - # Bold, italic and bold.italic face for title - title_face <- theme.pars$plot.title$face - if (!is.null(title_face)) { - if (title_face=="bold") { - layout$title <- paste0("", layout$title, "") - } else if (title_face=="italic") { - layout$title <- paste0("", layout$title, "") - } else if (title_face=="bold.italic") { - layout$title <- paste0("", layout$title, "") + # flip x/y in traces for flipped coordinates + # (we've already done appropriate flipping for axis objects) + if (inherits(p$coordinates, "CoordFlip")) { + for (i in seq_along(traces)) { + tr <- traces[[i]] + traces[[i]][c("x", "y")] <- tr[c("y", "x")] + if (tr$type %in% c("bar", "box")) traces[[i]]$orientation <- "h" } } - # Bold, italic, and bold.italic face for axis title - title_face <- list(theme.pars$axis.title.y$face, - theme.pars$axis.title.x$face) - sub_elem <- c("yaxis", "xaxis") - - for (i in seq_along(title_face)) { - if (!is.null(title_face[[i]])) { - if (title_face[[i]]=="bold") { - layout[[sub_elem[i]]]["title"] <- paste0("", - layout[[sub_elem[i]]]["title"], - "") - } else if (title_face[[i]]=="italic") { - layout[[sub_elem[i]]]["title"] <- paste0("", - layout[[sub_elem[i]]]["title"], - "") - } else if (title_face[[i]]=="bold.italic") { - layout[[sub_elem[i]]]["title"] <- paste0("", - layout[[sub_elem[i]]]["title"], - "") + # Error bar widths in ggplot2 are on the range of the x/y scale, + # but plotly wants them in pixels: + for (xy in c("x", "y")) { + type <- if (xy == "x") "width" else "height" + err <- if (xy == "x") "error_y" else "error_x" + for (i in seq_along(traces)) { + e <- traces[[i]][[err]] + if (!is.null(e)) { + # TODO: again, "npc" is on device scale...we really want plot scale + w <- grid::unit(e$width %||% 0, "npc") + traces[[i]][[err]]$width <- unitConvert(w, "pixels", type) } } } - # If background elements are NULL, and background rect (rectangle) is defined: - rect_fill <- theme.pars$rect$fill - if (!is.null(rect_fill)) { - if (is.null(layout$plot_bgcolor)) - layout$plot_bgcolor <- toRGB(s(rect_fill)) - if (is.null(layout$paper_bgcolor)) - layout$paper_bgcolor <- toRGB(s(rect_fill)) - if (is.null(layout$legend$bgcolor)) - layout$legend$bgcolor <- toRGB(s(rect_fill)) - } - - if (length(trace.list) == 0) { - stop("No exportable traces") - } - - mode.mat <- matrix(NA, 3, 3) - rownames(mode.mat) <- colnames(mode.mat) <- c("markers", "lines", "none") - mode.mat["markers", "lines"] <- - mode.mat["lines", "markers"] <- "lines+markers" - mode.mat["markers", "none"] <- mode.mat["none", "markers"] <- "markers" - mode.mat["lines", "none"] <- mode.mat["none", "lines"] <- "lines" - merged.traces <- list() - not.merged <- trace.list - while(length(not.merged)){ - tr <- not.merged[[1]] - not.merged <- not.merged[-1] - # Are there any traces that have not yet been merged, and can be - # merged with tr? - can.merge <- logical(length(not.merged)) - for(other.i in seq_along(not.merged)){ - other <- not.merged[[other.i]] - criteria <- c() - for(must.be.equal in c("x", "y", "xaxis", "yaxis")){ - other.attr <- other[[must.be.equal]] - tr.attr <- tr[[must.be.equal]] - criteria[[must.be.equal]] <- - isTRUE(all.equal(other.attr, tr.attr)) && - unique(other$type, tr$type) == "scatter" - } - if(all(criteria)){ - can.merge[[other.i]] <- TRUE + # try to merge marker/line traces that have the same values for these props + props <- c("x", "y", "text", "type", "xaxis", "yaxis", "name") + hashes <- vapply(traces, function(x) digest::digest(x[names(x) %in% props]), character(1)) + modes <- vapply(traces, function(x) x$mode %||% "", character(1)) + nhashes <- length(unique(hashes)) + if (nhashes < length(traces)) { + mergedTraces <- vector("list", nhashes) + for (i in unique(hashes)) { + idx <- which(hashes %in% i) + # for now we just merge markers and lines -- I can't imagine text being worthwhile + if (all(modes[idx] %in% c("lines", "markers"))) { + mergedTraces[[i]] <- Reduce(modifyList, traces[idx]) + mergedTraces[[i]]$mode <- "markers+lines" } } - to.merge <- not.merged[can.merge] - not.merged <- not.merged[!can.merge] - for(other in to.merge){ - new.mode <- tryCatch({ - mode.mat[tr$mode, other$mode] - }, error=function(e){ - NA - }) - if(is.character(new.mode) && !is.na(new.mode %||% NA)){ - tr$mode <- new.mode - } - attrs <- c("error_x", "error_y", "marker", "line") - for(attr in attrs){ - if(!is.null(other[[attr]]) && is.null(tr[[attr]])){ - tr[[attr]] <- other[[attr]] - } - } - } - merged.traces[[length(merged.traces)+1]] <- tr + traces <- mergedTraces } - # ------------------------------- - # avoid redundant legends entries - # ------------------------------- - # remove alpha from a color entry - rm_alpha <- function(x) { - if (length(x) == 0) return(x) - pat <- "^rgba\\(" - if (!grepl(pat, x)) return(x) - sub(",\\s*[0]?[.]?[0-9]+\\)$", ")", sub(pat, "rgb(", x)) - } - # convenient for extracting name/value of legend entries (ignoring alpha) - entries <- function(x, y) { - z <- try(x[[y]], silent = TRUE) - if (inherits(e, "try-error")) { - paste0(x$name, "-") - } else { - paste0(x$name, "-", rm_alpha(z)) - } - } - fill_set <- unlist(lapply(merged.traces, entries, "fillcolor")) - line_set <- unlist(lapply(merged.traces, entries, c("line", "color"))) - mark_set <- unlist(lapply(merged.traces, entries, c("marker", "color"))) - mode_set <- lapply(merged.traces, "[[", "mode") - legend_intersect <- function(x, y) { - i <- intersect(x, y) - # restrict intersection to valid legend entries - i[grepl("-rgb[a]?\\(", i)] - } - # if there is a mark & line legend, get rid of line - t1 <- line_set %in% legend_intersect(mark_set, line_set) - # that is, unless the mode is 'lines+markers'... - t1 <- t1 & !(mode_set %in% "lines+markers") - # if there is a mark & fill legend, get rid of fill - t2 <- fill_set %in% legend_intersect(mark_set, fill_set) - # if there is a line & fill legend, get rid of fill - t3 <- fill_set %in% legend_intersect(line_set, fill_set) - t <- t1 | t2 | t3 - for (m in seq_along(merged.traces)) - if (isTRUE(merged.traces[[m]]$showlegend && t[m])) - merged.traces[[m]]$showlegend <- FALSE + # better layout defaults (TODO: provide a mechanism for templating defaults) + gglayout$hovermode <- "closest" + ax <- grep("^[x-y]axis", names(gglayout)) + for (i in ax) { + gglayout[[i]]$hoverformat <- ".2f" + } + # If a trace isn't named, it shouldn't have additional hoverinfo + traces <- lapply(compact(traces), function(x) { x$name <- x$name %||% ""; x }) - # Put the traces in correct order, according to any manually - # specified scales. This seems to be repetitive with the trace$rank - # attribute in layer2traces (which is useful for sorting traces that - # get different legend entries but come from the same geom, as in - # test-ggplot-legend.R), but in fact this is better since it could - # be used for sorting traces that come from different geoms - # (currently we don't have a test for this). TODO: write such a - # test, delete the trace$rank code, and have it work here instead. - trace.order <- unlist(trace.order.list) - ordered.traces <- if(length(trace.order)){ - trace.order.score <- seq_along(trace.order) - names(trace.order.score) <- trace.order - trace.name <- sapply(merged.traces, "[[", "name") - trace.score <- trace.order.score[trace.name] - merged.traces[order(trace.score)] - }else{ - merged.traces - } + l <- list(data = setNames(traces, NULL), layout = compact(gglayout)) + # ensure properties are boxed correctly + l <- add_boxed(rm_asis(l)) + l$width <- width + l$height <- height + l$source <- source + structure(l, class = "plotly") +} + + +#----------------------------------------------------------------------------- +# ggplotly 'utility' functions +#----------------------------------------------------------------------------- + +# convert ggplot2 sizes and grid unit(s) to pixels or normalized point coordinates +unitConvert <- function(u, to = c("npc", "pixels"), type = c("x", "y", "height", "width")) { + u <- verifyUnit(u) - # Translate scale(labels) to trace name. - named.traces <- ordered.traces - for(trace.i in seq_along(named.traces)){ - tr.name <- named.traces[[trace.i]][["name"]] - new.name <- trace.name.map[[tr.name]] - if(!is.null(new.name)){ - named.traces[[trace.i]][["name"]] <- new.name + convert <- switch( + type[1], + x = grid::convertX, + y = grid::convertY, + width = grid::convertWidth, + height = grid::convertHeight + ) + # convert everything to npc first + if (inherits(u, "margin")) { + # margins consist of 4 parts: top, right, bottom, and left + uh <- grid::convertHeight(u, "npc") + uw <- grid::convertWidth(u, "npc") + u <- grid::unit(c(uh[1], uw[2], uh[3], uw[4]), "npc") + } else { + u <- convert(u, "npc") + } + if (to[1] == "pixels") { + if (inherits(u, "margin")) { + uh <- mm2pixels(grid::convertHeight(uh, "mm")) + uw <- mm2pixels(grid::convertWidth(uw, "mm")) + u <- c(uh[1], uw[2], uh[3], uw[4]) + } else { + u <- mm2pixels(convert(u, "mm")) } } - - # If coord_flip is defined, then flip x/y in each trace, and in - # each axis. - flipped.traces <- named.traces - flipped.layout <- layout - coord_cl <- sub("coord", "", tolower(class(built$plot$coordinates))) - if("flip" %in% coord_cl){ - if(!inherits(p$facet, "null")){ - stop("coord_flip + facet conversion not supported") - } - for(trace.i in seq_along(flipped.traces)){ - tr <- flipped.traces[[trace.i]] - x <- tr[["x"]] - y <- tr[["y"]] - tr[["y"]] <- x - tr[["x"]] <- y - if (isTRUE(tr[["type"]] == "bar")) tr$orientation <- "h" - flipped.traces[[trace.i]] <- tr + as.numeric(u) +} + +# ggplot2 size is in millimeters. plotly is in pixels. To do this correctly, +# we need to know PPI/DPI of the display. I'm not sure of a decent way to do that +# from R, but it seems 96 is a reasonable assumption. +mm2pixels <- function(u) { + u <- verifyUnit(u) + if (attr(u, "unit") != "mm") { + stop("Unit must be in millimeters") + } + (as.numeric(u) * 96) / 25.4 +} + +verifyUnit <- function(u) { + # the default unit in ggplot2 is millimeters (unless it's element_text()) + if (is.null(attr(u, "unit"))) { + u <- if (inherits(u, "element")) { + grid::unit(u$size %||% 0, "points") + } else { + grid::unit(u %||% 0, "mm") } - x <- layout[["xaxis"]] - y <- layout[["yaxis"]] - flipped.layout[["xaxis"]] <- y - flipped.layout[["yaxis"]] <- x } - - l <- list(data = flipped.traces, layout = flipped.layout) - l$width <- width - l$height <- width - l$source <- source - structure(add_boxed(rm_asis(l)), class = "plotly") + u +} + +# detect a blank theme element +is_blank <- function(x) { + inherits(x, "element_blank") && inherits(x, "element") +} + +# given text, and x/y coordinates on 0-1 scale, +# convert ggplot2::element_text() to plotly annotation +make_label <- function(txt = "", x, y, el = ggplot2::element_text(), ...) { + if (is_blank(el) || is.null(txt) || nchar(txt) == 0 || length(txt) == 0) { + return(NULL) + } + angle <- el$angle %||% 0 + list(list( + text = txt, + x = x, + y = y, + showarrow = FALSE, + # TODO: hjust/vjust? + ax = 0, + ay = 0, + font = text2font(el), + xref = "paper", + yref = "paper", + textangle = -angle, + ... + )) +} + +has_facet <- function(x) { + inherits(x$facet, c("grid", "wrap")) +} + +#' Estimate bounding box of a rotated string +#' +#' @param txt a character string of length 1 +#' @param angle sets the angle of the tick labels with respect to the +#' horizontal (e.g., `tickangle` of -90 draws the tick labels vertically) +#' @param size vertical size of a character +#' @references +#' https://www.dropbox.com/s/nc6968prgw8ne4w/bbox.pdf?dl=0 + +bbox <- function(txt = "foo", angle = 0, size = 12) { + # assuming the horizontal size of a character is roughly half of the vertical + n <- nchar(txt) + if (sum(n) == 0) return(list(height = 0, width = 0)) + w <- size * (nchar(txt) / 2) + angle <- abs(angle %||% 0) + # do the sensible thing in the majority of cases + if (angle == 0) return(list(height = size, width = w)) + if (angle == 90) return(list(height = w, width = size)) + # first, compute the hypotenus + hyp <- sqrt(size ^ 2 + w ^ 2) + list( + height = max(hyp * cos(90 - angle), size), + width = max(hyp * sin(90 - angle), w) + ) +} + +# create a plotly font object from ggplot2::element_text() +text2font <- function(x = ggplot2::element_text(), type = "height") { + list( + color = toRGB(x$colour), + family = x$family, + # TODO: what about the size of vertical text? + size = unitConvert(grid::unit(x$size %||% 0, "points"), "pixels", type) + ) +} + +# wrap text in bold/italics according to the text "face" +faced <- function(txt, face = "plain") { + if (is.null(face)) face <- "plain" + x <- switch(face, + plain = txt, + bold = bold(txt), + italic = italic(txt), + bold.italic = bold(italic(txt)) + ) + # if, for some reason, a face we don't support is used, return the text + if (is.null(x)) txt else x +} +bold <- function(x) paste("", x, "") +italic <- function(x) paste("", x, "") + +# if a vector has one unique value, return that value +uniq <- function(x) { + u <- unique(x) + if (length(u) == 1) u else x +} + +# theme(strip.background) -> plotly.js rect shape +make_strip_rect <- function(xdom, ydom, theme, side = "top") { + rekt <- rect2shape(theme[["strip.background"]]) + stripTextX <- theme[["strip.text.x"]] %||% theme[["strip.text"]] + xTextSize <- unitConvert(stripTextX$size, "npc", "width") + stripTextY <- theme[["strip.text.y"]] %||% theme[["strip.text"]] + yTextSize <- unitConvert(stripTextY$size, "npc", "height") + if ("right" %in% side) { + # x-padding should be accounted for in `layout.margin.r` + rekt$x0 <- xdom[2] + rekt$x1 <- xdom[2] + xTextSize + rekt$y0 <- ydom[1] + rekt$y1 <- ydom[2] + } + if ("top" %in% side) { + rekt$x0 <- xdom[1] + rekt$x1 <- xdom[2] + rekt$y0 <- ydom[2] + rekt$y1 <- ydom[2] + yTextSize + } + list(rekt) +} + +# theme(panel.border) -> plotly.js rect shape +make_panel_border <- function(xdom, ydom, theme) { + rekt <- rect2shape(theme[["panel.border"]]) + rekt$x0 <- xdom[1] + rekt$x1 <- xdom[2] + rekt$y0 <- ydom[1] + rekt$y1 <- ydom[2] + list(rekt) +} + +# element_rect -> plotly.js rect shape +rect2shape <- function(rekt = ggplot2::element_rect()) { + list( + type = "rect", + fillcolor = toRGB(rekt$fill), + line = list( + color = toRGB(rekt$colour), + width = unitConvert(rekt, "pixels", "width"), + linetype = lty2dash(rekt$linetype) + ), + yref = "paper", + xref = "paper" + ) +} + +# We need access to internal ggplot2 functions in several places +# this helps us import functions in a way that R CMD check won't cry about +ggfun <- function(x) getFromNamespace(x, "ggplot2") + +ggtype <- function(x, y = "geom") { + sub(y, "", tolower(class(x[[y]])[1])) +} + +# colourbar -> plotly.js colorbar +gdef2trace <- function(gdef, theme, gglayout) { + if (inherits(gdef, "colorbar")) { + # sometimes the key has missing values, which we can ignore + gdef$key <- gdef$key[!is.na(gdef$key$.value), ] + rng <- range(gdef$bar$value) + gdef$bar$value <- scales::rescale(gdef$bar$value, from = rng) + gdef$key$.value <- scales::rescale(gdef$key$.value, from = rng) + list( + x = gglayout$xaxis$range, + y = gglayout$yaxis$range, + # esentially to prevent this getting merged at a later point + name = gdef$hash, + type = "scatter", + mode = "markers", + opacity = 0, + hoverinfo = "none", + showlegend = FALSE, + # do everything on a 0-1 scale + marker = list( + color = c(0, 1), + colorscale = setNames(gdef$bar[c("value", "colour")], NULL), + colorbar = list( + bgcolor = toRGB(theme$legend.background$fill), + bordercolor = toRGB(theme$legend.background$colour), + borderwidth = unitConvert( + theme$legend.background$size, "pixels", "width" + ), + thickness = unitConvert( + theme$legend.key.width, "pixels", "width" + ), + title = gdef$title, + titlefont = text2font(gdef$title.theme %||% theme$legend.title), + tickmode = "array", + ticktext = gdef$key$.label, + tickvals = gdef$key$.value, + tickfont = text2font(gdef$label.theme %||% theme$legend.text), + ticklen = 2, + len = 1/2 + ) + ) + ) + } else { + # if plotly.js gets better support for multiple legends, + # that conversion should go here + NULL + } } diff --git a/R/imports.R b/R/imports.R new file mode 100644 index 0000000000..8e7083a639 --- /dev/null +++ b/R/imports.R @@ -0,0 +1,10 @@ +#' @import ggplot2 +#' @importFrom grDevices col2rgb +#' @importFrom utils getFromNamespace modifyList data packageVersion browseURL +#' @importFrom stats setNames +#' @importFrom tidyr gather +#' @importFrom plyr ddply summarise +#' @importFrom viridis viridis +#' @importFrom jsonlite toJSON fromJSON +#' @importFrom httr GET POST PATCH content config add_headers stop_for_status +NULL diff --git a/R/layers2traces.R b/R/layers2traces.R new file mode 100644 index 0000000000..a53dcb1282 --- /dev/null +++ b/R/layers2traces.R @@ -0,0 +1,781 @@ +# layer -> trace conversion +layers2traces <- function(data, prestats_data, layers, layout, scales, labels) { + # Attach a "geom class" to each layer of data for method dispatch + data <- Map(function(x, y) prefix_class(x, class(y$geom)[1]), data, layers) + # Extract parameters for each layer + params <- lapply(layers, function(x) { + c(x$geom_params, x$stat_params, x$aes_params, position = ggtype(x, "position")) + }) + # we draw legends only for discrete scales + discreteScales <- list() + for (sc in scales$non_position_scales()$scales) { + if (sc$is_discrete()) { + discreteScales[[sc$aesthetics]] <- sc + } + } + # Convert "high-level" geoms to their "low-level" counterpart + # This may involve preprocessing the data, for example: + # 1. geom_line() is really geom_path() with data sorted by x + # 2. geom_smooth() is really geom_path() + geom_ribbon() + # + # This has to be done in a loop, since some layers are really two layers, + # (and we need to replicate the data/params in those cases) + datz <- list() + paramz <- list() + keyz <- list() + for (i in seq_along(data)) { + d <- to_basic(data[[i]], prestats_data[[i]], layout, params[[i]]) + if (is.data.frame(d)) d <- list(d) + for (j in seq_along(d)) { + datz <- c(datz, d[j]) + paramz <- c(paramz, params[i]) + # When splitting layers into multiple traces, we need the domain/range of + # the scale (for trace naming & legend generation). + # if the splitting variables are constant in the data, we don't want to + # split on them + idx <- vapply(d[[j]], function(x) length(unique(x)) > 1, logical(1)) + # always split on PANEL, discrete scales, and other geom specific aes that + # don't translate to a single trace + split_by <- c("PANEL", names(discreteScales)[names(discreteScales) %in% names(idx)[idx]]) + psd <- prestats_data[[i]] + key <- unique(psd[names(psd) %in% split_by]) + # this order (should) determine the ordering of traces (within layer) + key <- key[do.call(order, key), , drop = FALSE] + split_vars <- setdiff(names(key), "PANEL") + for (k in split_vars) { + key[[paste0(k, "_domain")]] <- key[, k] + key[[k]] <- scales$get_scales(k)$map(key[, k]) + } + keyz <- c(keyz, list(key)) + } + } + + # now to the actual layer -> trace conversion + trace.list <- list() + for (i in seq_along(datz)) { + d <- datz[[i]] + # create a factor to split the data on... + # by matching the factor levels with the order of the domain (of _discrete_ + # scales), the trace ordering should be correct + key <- keyz[[i]] + split_by <- names(key)[!grepl("_domain$", names(key))] + fac <- factor( + apply(d[split_by], 1, paste, collapse = "."), + levels = apply(key[split_by], 1, paste, collapse = ".") + ) + # if we split on a variable not in the key, we have no chance + # of generating an appropriate legend + splitContinuous <- length(setdiff(split_on(d), split_by)) > 0 + if (splitContinuous) { + split_by <- c(split_by, split_on(d)) + splitDat <- d[names(d) %in% split_by] + fac <- factor( + apply(splitDat, 1, paste, collapse = "."), + levels = apply(unique(splitDat), 1, paste, collapse = ".") + ) + } + dl <- split(d, fac, drop = TRUE) + # list of traces for this layer + trs <- Map(geom2trace, dl, paramz[i]) + # set name/legendgroup/showlegend, if appropriate + legendVars <- setdiff(split_by, "PANEL") + if (!splitContinuous && length(legendVars) > 0 && length(trs) > 1) { + # labels is a list of legend titles, but since we're restricted to + # one (merged) legend, I think it only makes since to prefix the variable + # name in the legend entries + lab <- labels[legendVars] + vals <- key[paste0(legendVars, "_domain")] + valz <- Map(function(x, y) { + if (nchar(x) > 0) paste0(x, ": ", y) else y + }, lab, vals) + entries <- Reduce(function(x, y) { + if (identical(x, y)) x else paste0(x, "
", y) + }, valz) + for (k in seq_along(trs)) { + trs[[k]]$name <- entries[[k]] + trs[[k]]$legendgroup <- entries[[k]] + # depending on the geom (e.g. smooth) this may be FALSE already + if (is.null(trs[[k]]$showlegend)) trs[[k]]$showlegend <- TRUE + } + } else { + trs <- lapply(trs, function(x) { x$showlegend <- FALSE; x }) + } + + # each trace is with respect to which axis? + for (j in seq_along(trs)) { + panel <- unique(dl[[j]]$PANEL) + trs[[j]]$xaxis <- sub("axis", "", layout[panel, "xaxis"]) + trs[[j]]$yaxis <- sub("axis", "", layout[panel, "yaxis"]) + } + # also need to set `layout.legend.traceorder='reversed'` + if (inherits(d, "GeomBar") && paramz[[i]]$position == "identity") { + trs <- rev(trs) + } + + trace.list <- c(trace.list, trs) + } + + trace.list +} + + +#' Convert a geom to a "basic" geom. +#' +#' This function makes it possible to convert ggplot2 geoms that +#' are not included with ggplot2 itself. Users shouldn't need to use +#' this function. It exists purely to allow other package authors to write +#' their own conversion method(s). +#' +#' @param data the data returned by \code{ggplot2::ggplot_build()}. +#' @param prestats_data the data before statistics are computed. +#' @param layout the panel layout. +#' @param params parameters for the geom, statistic, and 'constant' aesthetics +#' @param ... currently ignored +#' @export +to_basic <- function(data, prestats_data, layout, params, ...) { + UseMethod("to_basic") +} + +#' @export +to_basic.GeomViolin <- function(data, prestats_data, layout, params, ...) { + # TODO: it should be possible to implement this via GeomPolygon + # just need preprocess the data, then: + # replace_class(data, "GeomPolygon", "GeomViolin") + warning( + "plotly.js does not yet support violin plots. \n", + "Converting to boxplot instead.", + call. = FALSE + ) + to_basic.GeomBoxplot(data, prestats_data) +} + +#' @export +to_basic.GeomBoxplot <- function(data, prestats_data, layout, params, ...) { + # 'trained' aesthetics that we're interested in mapping from data to prestats + aez <- c("fill", "colour", "size", "alpha", "linetype", "shape", "x") + dat <- data[names(data) %in% c(aez, "group")] + pre <- prestats_data[!names(prestats_data) %in% aez] + prefix_class(merge(pre, dat, by = "group", sort = FALSE), "GeomBoxplot") +} + +#' @export +to_basic.GeomSmooth <- function(data, prestats_data, layout, params, ...) { + dat <- prefix_class(data, "GeomPath") + dat$alpha <- NULL + if (!identical(params$se, FALSE)) { + dat2 <- prefix_class(ribbon_dat(data), c("GeomPolygon", "GeomSmooth")) + dat2$colour <- NULL + dat <- list(dat, dat2) + } + dat +} + +#' @export +to_basic.GeomRibbon <- function(data, prestats_data, layout, params, ...) { + prefix_class(ribbon_dat(data), "GeomPolygon") +} + +#' @export +to_basic.GeomArea <- function(data, prestats_data, layout, params, ...) { + prefix_class(ribbon_dat(data), "GeomPolygon") +} + +#' @export +to_basic.GeomDensity <- function(data, prestats_data, layout, params, ...) { + prefix_class(ribbon_dat(data), "GeomPolygon") +} + +#' @export +to_basic.GeomLine <- function(data, prestats_data, layout, params, ...) { + data <- data[order(data$x), ] + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomStep <- function(data, prestats_data, layout, params, ...) { + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomSegment <- function(data, prestats_data, layout, params, ...) { + # Every row is one segment, we convert to a line with several + # groups which can be efficiently drawn by adding NA rows. + data$group <- seq_len(nrow(data)) + others <- data[!names(data) %in% c("x", "y", "xend", "yend")] + data <- with(data, { + rbind(cbind(x, y, others), + cbind(x = xend, y = yend, others)) + }) + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomRect <- function(data, prestats_data, layout, params, ...) { + data$group <- seq_len(nrow(data)) + others <- data[!names(data) %in% c("xmin", "ymin", "xmax", "ymax")] + data <- with(data, { + rbind(cbind(x = xmin, y = ymin, others), + cbind(x = xmin, y = ymax, others), + cbind(x = xmax, y = ymax, others), + cbind(x = xmax, y = ymin, others)) + }) + prefix_class(data, "GeomPolygon") +} + +#' @export +to_basic.GeomRaster <- function(data, prestats_data, layout, params, ...) { + # TODO: what if nrow(data) != nrow(prestats_data)? + data$z <- prestats_data$fill + if (is.discrete(prestats_data$fill)) { + data <- prefix_class(data, "GeomRect") + to_basic(data, prestats_data, layout, params) + } else { + prefix_class(data, "GeomTile") + } +} + +#' @export +to_basic.GeomTile <- function(data, prestats_data, layout, params, ...) { + data$z <- prestats_data$fill + if (is.discrete(prestats_data$fill)) { + data <- prefix_class(data, "GeomRect") + to_basic(data, prestats_data, layout, params) + } else { + data + } +} + +#' @export +to_basic.GeomContour <- function(data, prestats_data, layout, params, ...) { + if (!"fill" %in% names(data)) data$fill <- NA + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomDensity2d <- function(data, prestats_data, layout, params, ...) { + if (!"fill" %in% names(data)) data$fill <- NA + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomAbline <- function(data, prestats_data, layout, params, ...) { + data <- unique(data[c("PANEL", "intercept", "slope", "group")]) + data$group <- seq_len(nrow(data)) + lay <- tidyr::gather(layout, variable, x, x_min:x_max) + data <- merge(lay[c("PANEL", "x")], data, by = "PANEL") + data$y <- with(data, intercept + slope * x) + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomHline <- function(data, prestats_data, layout, params, ...) { + data <- unique(data[c("PANEL", "yintercept", "group")]) + data$group <- seq_len(nrow(data)) + lay <- tidyr::gather(layout, variable, x, x_min:x_max) + data <- merge(lay[c("PANEL", "x")], data, by = "PANEL") + data$y <- data$yintercept + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomVline <- function(data, prestats_data, layout, params, ...) { + data <- unique(data[c("PANEL", "xintercept", "group")]) + data$group <- seq_len(nrow(data)) + lay <- tidyr::gather(layout, variable, y, y_min:y_max) + data <- merge(lay[c("PANEL", "y")], data, by = "PANEL") + data$x <- data$xintercept + prefix_class(data, "GeomPath") +} + +#' @export +to_basic.GeomJitter <- function(data, prestats_data, layout, params, ...) { + prefix_class(data, "GeomPoint") +} + +#' @export +to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, ...) { + # width for ggplot2 means size of the entire bar, on the data scale + # (plotly.js wants half, in pixels) + data <- merge(data, layout, by = "PANEL", sort = FALSE) + data$width <- (data$xmax - data$x) /(data$x_max - data$x_min) + data$fill <- NULL + prefix_class(data, "GeomErrorbar") +} + +#' @export +to_basic.GeomErrorbarh <- function(data, prestats_data, layout, params, ...) { + # height for ggplot2 means size of the entire bar, on the data scale + # (plotly.js wants half, in pixels) + data <- merge(data, layout, by = "PANEL", sort = FALSE) + data$width <- (data$ymax - data$y) / (data$y_max - data$y_min) + data$fill <- NULL + prefix_class(data, "GeomErrorbarh") +} + +#' @export +to_basic.GeomLinerange <- function(data, prestats_data, layout, params, ...) { + data$width <- 0 + prefix_class(data, "GeomErrorbar") +} + +#' @export +to_basic.GeomPointrange <- function(data, prestats_data, layout, params, ...) { + data$width <- 0 + list( + prefix_class(data, "GeomErrorbar"), + prefix_class(data, "GeomPoint") + ) +} + +#' @export +to_basic.default <- function(data, prestats_data, layout, params, ...) { + data +} + +#' Convert a "basic" geoms to a plotly.js trace. +#' +#' This function makes it possible to convert ggplot2 geoms that +#' are not included with ggplot2 itself. Users shouldn't need to use +#' this function. It exists purely to allow other package authors to write +#' their own conversion method(s). +#' +#' @param data the data returned by \code{plotly::to_basic}. +#' @param params parameters for the geom, statistic, and 'constant' aesthetics +#' @export +geom2trace <- function(data, params) { + UseMethod("geom2trace") +} + +#' @export +geom2trace.GeomBlank <- function(data, params) { + list() +} + +#' @export +geom2trace.GeomPath <- function(data, params) { + data <- group2NA(data) + L <- list( + x = data$x, + y = data$y, + text = data$text, + type = "scatter", + mode = "lines", + name = if (inherits(data, "GeomSmooth")) "fitted values", + line = list( + # TODO: line width array? -- https://github.com/plotly/plotly.js/issues/147 + width = aes2plotly(data, params, "size")[1], + color = toRGB( + aes2plotly(data, params, "colour"), + aes2plotly(data, params, "alpha") + ), + dash = aes2plotly(data, params, "linetype") + ) + ) + if (inherits(data, "GeomStep")) L$line$shape <- params$direction %||% "hv" + L +} + +#' @export +geom2trace.GeomPoint <- function(data, params) { + shape <- aes2plotly(data, params, "shape") + if (length(unique(data$size)) > 1 && is.null(data$text)) { + data$text <- paste("size:", data$size) + } + L <- list( + x = data$x, + y = data$y, + text = data$text, + key = data$key, + type = "scatter", + mode = "markers", + marker = list( + autocolorscale = FALSE, + color = aes2plotly(data, params, "fill"), + opacity = aes2plotly(data, params, "alpha"), + size = aes2plotly(data, params, "size"), + symbol = shape, + line = list( + width = aes2plotly(data, params, "stroke"), + color = aes2plotly(data, params, "colour") + ) + ) + ) + # fill is irrelevant for pch %in% c(1, 15:20) + pch <- uniq(data$shape) %||% params$shape %||% GeomPoint$default_aes$shape + if (any(pch %in% c(1, 15:20))) { + L$marker$color <- L$marker$line$color + } + L +} + +#' @export +geom2trace.GeomBar <- function(data, params) { + data$y <- data$ymax - data$ymin + # TODO: use xmin/xmax once plotly.js allows explicit bar widths + # https://github.com/plotly/plotly.js/issues/80 + list( + x = data$x, + y = data$y, + text = data$text, + type = "bar", + marker = list( + autocolorscale = FALSE, + color = toRGB( + aes2plotly(data, params, "fill"), + aes2plotly(data, params, "alpha") + ), + line = list( + width = aes2plotly(data, params, "size"), + color = aes2plotly(data, params, "colour") + ) + ) + ) +} + +#' @export +geom2trace.GeomPolygon <- function(data, params) { + data <- group2NA(data) + # TODO: do this for more density-like measures?? + if ("level" %in% names(data)) { + data$level <- paste("Level:", data$level) + } + L <- list( + x = data$x, + y = data$y, + text = data$text %||% data$level, + type = "scatter", + mode = "lines", + line = list( + # NOTE: line attributes must be constant on a polygon + width = aes2plotly(data, params, "size"), + color = aes2plotly(data, params, "colour"), + dash = aes2plotly(data, params, "linetype") + ), + fill = "tozerox", + fillcolor = toRGB( + aes2plotly(data, params, "fill"), + aes2plotly(data, params, "alpha") + ) + ) + if (inherits(data, "GeomSmooth")) { + L$name <- "standard error" + L$showlegend <- FALSE + } + L + +} + +#' @export +geom2trace.GeomBoxplot <- function(data, params) { + list( + x = data$x, + y = data$y, + type = "box", + fillcolor = toRGB( + aes2plotly(data, params, "fill"), + aes2plotly(data, params, "alpha") + ), + # marker styling must inherit from GeomPoint$default_aes + # https://github.com/hadley/ggplot2/blob/ab42c2ca81458b0cf78e3ba47ed5db21f4d0fc30/NEWS#L73-L77 + marker = list( + opacity = GeomPoint$default_aes$alpha, + outliercolor = toRGB(GeomPoint$default_aes$colour), + line = list( + width = mm2pixels(GeomPoint$default_aes$stroke), + color = toRGB(GeomPoint$default_aes$colour) + ), + size = mm2pixels(GeomPoint$default_aes$size) + ), + line = list( + color = aes2plotly(data, params, "colour"), + width = aes2plotly(data, params, "size") + ) + ) +} + + +#' @export +geom2trace.GeomText <- function(data, params) { + list( + x = data$x, + y = data$y, + text = data$label, + textfont = list( + # TODO: how to translate fontface/family? + size = aes2plotly(data, params, "size"), + color = toRGB( + aes2plotly(data, params, "colour"), + aes2plotly(data, params, "alpha") + ) + ), + type = "scatter", + mode = "text" + ) +} + +#' @export +geom2trace.GeomTile <- function(data, params) { + # make sure order of value make sense before throwing z in matrix + data <- data[order(data$x, order(data$y, decreasing = T)), ] + x <- sort(unique(data$x)) + y <- sort(unique(data$y)) + colorscale <- cbind( + c(0, 1), + data[c(which.min(data$z), which.max(data$z)), "fill"] + ) + list( + x = x, + y = y, + text = matrix(data$z, nrow = length(y), ncol = length(x)), + hoverinfo = "text", + z = matrix(scales::rescale(data$z), nrow = length(y), ncol = length(x)), + colorscale = colorscale, + type = "heatmap", + showscale = FALSE, + autocolorscale = FALSE + ) +} + +#' @export +geom2trace.GeomErrorbar <- function(data, params) { + make_error(data, params, "y") +} + +#' @export +geom2trace.GeomErrorbarh <- function(data, params) { + make_error(data, params, "x") +} + +#' @export +geom2trace.default <- function(data, params) { + warning( + "geom_", class(data)[1], "() has yet to be implemented in plotly.\n", + " If you'd like to see this geom implemented,\n", + " Please open an issue with your example code at\n", + " https://github.com/ropensci/plotly/issues" + ) + list() +} + +# --------------------------------------------------------------------------- +#' Utility functions +#' -------------------------------------------------------------------------- +#' + +#' Drawing ggplot2 geoms with a group aesthetic is most efficient in +#' plotly when we convert groups of things that look the same to +#' vectors with NA. +group2NA <- function(data) { + if (!"group" %in% names(data)) return(data) + poly.list <- split(data, data$group, drop = TRUE) + is.group <- names(data) == "group" + poly.na.list <- list() + forward.i <- seq_along(poly.list) + ## When group2NA is called on geom_polygon (or geom_rect, which is + ## treated as a basic polygon), we need to retrace the first points + ## of each group, see https://github.com/ropensci/plotly/pull/178 + retrace.first.points <- inherits(data, "GeomPolygon") + for (i in forward.i) { + no.group <- poly.list[[i]][, !is.group, drop = FALSE] + na.row <- no.group[1, ] + na.row[, c("x", "y")] <- NA + retrace.first <- if (retrace.first.points) { + no.group[1,] + } + poly.na.list[[paste(i, "forward")]] <- + rbind(no.group, retrace.first, na.row) + } + if (retrace.first.points) { + backward.i <- rev(forward.i[-1])[-1] + for (i in backward.i) { + no.group <- poly.list[[i]][1, !is.group, drop = FALSE] + na.row <- no.group[1, ] + na.row[, c("x", "y")] <- NA + poly.na.list[[paste(i, "backward")]] <- rbind(no.group, na.row) + } + if (length(poly.list) > 1) { + first.group <- poly.list[[1]][1, !is.group, drop = FALSE] + poly.na.list[["last"]] <- rbind(first.group, first.group) + } + } + data <- do.call(rbind, poly.na.list) + if (is.na(data$x[nrow(data)])) { + data <- data[-nrow(data), ] + } + data +} + +# given a geom, should we split on any continuous variables? +# this is necessary for some geoms, for example, polygons +# since plotly.js can't draw two polygons with different fill in a single trace +split_on <- function(dat) { + geom <- class(dat)[1] + lookup <- list( + GeomPath = c("fill", "colour", "size"), + GeomPolygon = c("fill", "colour", "size"), + GeomBar = "fill", + GeomBoxplot = c("colour", "fill", "size"), + GeomErrorbar = "colour", + GeomErrorbarh = "colour", + GeomText = "colour" + ) + splits <- lookup[[geom]] + # make sure the variable is in the data, and is non-constant + splits <- splits[splits %in% names(dat)] + # is there more than one unique value for this aes split in the data? + for (i in splits) { + if (length(unique(dat[, i])) < 2) { + splits <- setdiff(splits, i) + } + } + splits +} + +# make trace with errorbars +make_error <- function(data, params, xy = "x") { + color <- aes2plotly(data, params, "colour") + e <- list( + x = data$x, + y = data$y, + type = "scatter", + mode = "lines", + opacity = 0, + hoverinfo = "none", + line = list(color = color) + ) + e[[paste0("error_", xy)]] <- list( + array = data[[paste0(xy, "max")]] - data[[xy]], + arrayminus = data[[xy]] - data[[paste0(xy, "min")]], + type = "data", + width = data$width[1] / 2, + symmetric = FALSE, + color = color + ) + e +} + +# function to transform geom_ribbon data into format plotly likes +# (note this function is also used for geom_smooth) +ribbon_dat <- function(dat) { + n <- nrow(dat) + o <- order(dat$x) + o2 <- order(dat$x, decreasing = TRUE) + used <- c("x", "ymin", "ymax") + not_used <- setdiff(names(dat), used) + # top-half of ribbon + tmp <- dat[o, ] + others <- tmp[not_used] + dat1 <- cbind(x = tmp$x, y = tmp$ymax, others) + dat1[n+1, ] <- cbind(x = tmp$x[n], y = tmp$ymin[n], others[n, ]) + # bottom-half of ribbon + tmp2 <- dat[o2, ] + others2 <- tmp2[not_used] + dat2 <- cbind(x = tmp2$x, y = tmp2$ymin, others2) + rbind(dat1, dat2) +} + +aes2plotly <- function(data, params, aes = "size") { + geom <- class(data)[1] + vals <- uniq(data[[aes]]) %||% params[[aes]] %||% + ggfun(geom)$default_aes[[aes]] %||% NA + converter <- switch( + aes, + size = mm2pixels, + stroke = mm2pixels, + colour = toRGB, + fill = toRGB, + linetype = lty2dash, + shape = pch2symbol, + alpha = function(x) { x[is.na(x)] <- 1; x }, + width = function(x) { x / 2}, + height = function(x) { x / 2} + ) + if (is.null(converter)) { + warning("A converter for ", aes, " wasn't found. \n", + "Please report this issue to: \n", + "https://github.com/ropensci/plotly/issues/new", call. = FALSE) + converter <- identity + } + converter(vals) +} + +# Convert R pch point codes to plotly "symbol" codes. +pch2symbol <- function(x) { + lookup <- list( + "0" = "square-open", + "1" = "circle-open", + "2" = "triangle-up-open", + "3" = "cross-thin-open", + "4" = "x-thin-open", + "5" = "diamond-open", + "6" = "triangle-down-open", + "7" = "square-x-open", + "8" = "asterisk-open", + "9" = "diamond-x-open", + "10" = "circle-cross-open", + "11" = "hexagram-open", + "12" = "square-cross-open", + "13" = "circle-x-open", + "14" = "square-open-dot", + "15" = "square", + "16" = "circle", + "17" = "triangle-up", + "18" = "diamond", + "19" = "circle", + "20" = "circle", + "21" = "circle", + "22" = "square", + "23" = "diamond", + "24" = "triangle-up", + "25" = "triangle-down", + "32" = "circle", + "35" = "hash-open", + "42" = "asterisk-open", + "43" = "cross-thin-open", + "45" = "line-ew-open", + "47" = "line-ne-open", + "48" = "circle-open", + "79" = "circle-open", + "88" = "x-thin-open", + "92" = "line-nw-open", + "95" = "line-ew-open", + "111" = "circle-open", + "o" = "circle-open", + "O" = "circle-open", + "+" = "cross-thin-open" + ) + as.character(lookup[as.character(x)]) +} + +# Convert R lty line type codes to plotly "dash" codes. +lty2dash <- function(x) { + lookup <- list( + "0" = "none", + "1" = "solid", + "2" = "dash", + "3" = "dot", + "4" = "dashdot", + "5" = "longdash", + "6" = "longdashdot", + "blank" = "none", + "solid" = "solid", + "dashed" = "dash", + "dotted" = "dot", + "dotdash" = "dashdot", + "longdash" = "longdash", + "twodash" = "longdashdot", + "22" = "dash", + "42" = "dot", + "44" = "dashdot", + "13" = "longdash", + "1343" = "longdashdot", + "73" = "dash", + "2262" = "dotdash", + "12223242" = "dotdash", + "F282" = "dash", + "F4448444" = "dash", + "224282F2" = "dash", + "F1" = "dash" + ) + as.character(lookup[as.character(x)]) +} diff --git a/R/marker_conversion.R b/R/marker_conversion.R deleted file mode 100644 index bc5af2f073..0000000000 --- a/R/marker_conversion.R +++ /dev/null @@ -1,31 +0,0 @@ -#' Convert ggplot params to plotly. -#' @param params named list ggplot names -> values. -#' @param aesVec vector mapping ggplot names to plotly names. -#' @param defaults named list ggplot names -> values. -#' @export -#' @return named list. -#' @author Toby Dylan Hocking -paramORdefault <- function(params, aesVec, defaults) { - marker <- list() - for (ggplot.name in names(aesVec)) { - plotly.name <- aesVec[[ggplot.name]] - ggplot.value <- params[[ggplot.name]] - if (is.null(ggplot.value)) { - ggplot.value <- defaults[[ggplot.name]] - } - if (plotly.name == "width") { - ggplot.value <- ggplot.value * 2 - } - if (is.null(ggplot.value)) { - stop("no ggplot default for ", ggplot.name) - } - convert <- aesConverters[[ggplot.name]] - if (is.null(convert)) { - stop("no ggplot converter for ", ggplot.name) - } - plotly.value <- convert(ggplot.value) - names(plotly.value) <- NULL - marker[[plotly.name]] <- plotly.value - } - marker -} diff --git a/R/plotly.R b/R/plotly.R index 863e000050..4e63e37f1d 100644 --- a/R/plotly.R +++ b/R/plotly.R @@ -230,11 +230,11 @@ style <- function(p = last_plot(), ..., traces = 1, evaluate = FALSE) { #' list. #' #' @param l a ggplot object, or a plotly object, or a list. -#' @importFrom viridis viridis #' @export plotly_build <- function(l = last_plot()) { + #if (inherits(l, "ggmatrix")) # ggplot objects don't need any special type of handling - if (is.ggplot(l)) return(gg2list(l)) + if (ggplot2::is.ggplot(l)) return(gg2list(l)) l <- get_plot(l) # assume unnamed list elements are data/traces nms <- names(l) diff --git a/R/plotly_IMAGE.R b/R/plotly_IMAGE.R index d6fad7a00c..842864ce06 100644 --- a/R/plotly_IMAGE.R +++ b/R/plotly_IMAGE.R @@ -34,8 +34,8 @@ plotly_IMAGE <- function(x, width = 1000, height = 500, format = "png", ) base_url <- file.path(get_domain("api"), "v2", "images") resp <- httr::POST(base_url, plotly_headers("v2"), body = to_JSON(bod), - if (!missing(out_file)) write_disk(out_file, overwrite = TRUE), + if (!missing(out_file)) httr::write_disk(out_file, overwrite = TRUE), ...) - con <- process(struct(resp, "image")) + con <- process(append_class(resp, "image")) invisible(con) } diff --git a/R/plotly_POST.R b/R/plotly_POST.R index aeab2332bc..3b9b00abb4 100644 --- a/R/plotly_POST.R +++ b/R/plotly_POST.R @@ -73,7 +73,7 @@ plotly_POST <- function(x, filename, fileopt = "new", ) base_url <- file.path(get_domain(), "clientresp") resp <- httr::POST(base_url, body = bod) - con <- process(struct(resp, "clientresp")) + con <- process(append_class(resp, "clientresp")) if (sharing[1] == "hidden") { bits <- strsplit(con$url, "/")[[1]] plot_id <- bits[length(bits)] diff --git a/R/print.R b/R/print.R index cfbddab8d9..21bf259de9 100644 --- a/R/print.R +++ b/R/print.R @@ -40,6 +40,10 @@ as.widget <- function(x, ...) { list(b = 40, l = 60, t = 25, r = 10), p$layout$margin %||% list() ) + p$config$modeBarButtonsToRemove <- modifyList( + list("sendDataToCloud"), + p$config$modeBarButtonsToRemove %||% list() + ) p$base_url <- get_domain() # customize the JSON serializer (for htmlwidgets) attr(p, 'TOJSON_FUNC') <- to_JSON @@ -92,7 +96,6 @@ knit_print.figure <- function(x, options, ...) { #' \code{plot_ly} is used. If that is also \code{NULL}, '100\%' is the default. #' @param height attribute of the iframe. If \code{NULL}, the height in #' \code{plot_ly} is used. If that is also \code{NULL}, '400px' is the default. -#' @param dir a directory for placing #' @param file a filename for saving the standalone HTML #' (only used if x is a non-figure object) #' @export diff --git a/R/shiny.R b/R/shiny.R index 60f389a580..54d5bca5cd 100644 --- a/R/shiny.R +++ b/R/shiny.R @@ -53,9 +53,5 @@ event_data <- function(event = c("plotly_hover", "plotly_click", "plotly_selecte "from within a reactive shiny context.") } val <- session$input[[sprintf(".clientValue-%s-%s", event[1], source)]] - if (event[1] == "plotly_selected" && !is.null(val)) { - data.frame(lapply(val, as.numeric)) - } else { - val - } + if (is.null(val)) val else jsonlite::fromJSON(val) } diff --git a/R/signup.R b/R/signup.R index 2d8f5051a3..5a29d496de 100644 --- a/R/signup.R +++ b/R/signup.R @@ -45,7 +45,7 @@ signup <- function(username, email, save = TRUE) { ) base_url <- file.path(get_domain(), "apimkacct") resp <- httr::POST(base_url, body = bod) - con <- process(struct(resp, "signup")) + con <- process(append_class(resp, "signup")) if (save) { # store API key as an environment variable in .Rprofile cat_profile("username", con$un) diff --git a/R/subplots.R b/R/subplots.R index 249a6fc3ce..50b1794855 100644 --- a/R/subplots.R +++ b/R/subplots.R @@ -13,7 +13,6 @@ #' If a single value is provided, it will be used as all four margins. #' @return A plotly object #' @export -#' @importFrom plyr join #' @author Carson Sievert #' @examples \dontrun{ #' p1 <- plot_ly(economics, x = date, y = uempmed, showlegend = F) @@ -22,7 +21,6 @@ #' } -## TODO: throw warning if geo and non-geo coordinates are used!!! subplot <- function(..., nrows = 1, which_layout = "merge", margin = 0.02) { # note that dots is a _list of plotlys_ dots <- lapply(list(...), plotly_build) @@ -74,15 +72,15 @@ subplot <- function(..., nrows = 1, which_layout = "merge", margin = 0.02) { key <- with(p_info, paste0(geo, xaxis, yaxis, plot)) p_info$key <- match(key, unique(key)) # bump x/y axis anchors appropriately - p_info$xaxis <- sub("x1", "x", paste0("x", p_info$key)) - p_info$yaxis <- sub("y1", "y", paste0("y", p_info$key)) + p_info$xaxis <- sub("^x1$", "x", paste0("x", p_info$key)) + p_info$yaxis <- sub("^y1$", "y", paste0("y", p_info$key)) # Only do domain computations if they are _completely_ missing # (I don't think it makes sense to support partial specification of domains) if (all(is.na(with(p_info, c(xstart, xend, ystart, yend))))) { doms <- get_domains(max(p_info$key), nrows, margin) doms$key <- as.character(seq_len(nrow(doms))) p_info <- p_info[!names(p_info) %in% c("xstart", "xend", "ystart", "yend")] - p_info <- plyr::join(p_info, doms, by = "key") + p_info <- merge(p_info, doms, by = "key", sort = FALSE) } # empty plot container that we'll fill up with new info p <- list( @@ -169,7 +167,7 @@ get_domains <- function(nplots = 1, nrows = 1, margins = 0.01) { list2df <- function(x, nms) { stopifnot(length(unique(sapply(x, length))) == 1) - m <- Reduce(rbind, x) + m <- if (length(x) == 1) t(x[[1]]) else Reduce(rbind, x) row.names(m) <- NULL df <- data.frame(m) if (!missing(nms)) setNames(df, nms) else df diff --git a/R/toRGB.R b/R/toRGB.R new file mode 100644 index 0000000000..04dc6fd02a --- /dev/null +++ b/R/toRGB.R @@ -0,0 +1,31 @@ +#' Convert R colours to RGBA hexadecimal colour values +#' @param x see the \code{col} argument in \code{col2rgb} for valid specifications +#' @param alpha alpha channel on 0-1 scale +#' @return hexadecimal colour value (if is.na(x), return "transparent" for compatibility with Plotly) +#' @export +toRGB <- function(x, alpha = 1) { + if (is.null(x)) return(x) + # as of ggplot2 version 1.1, an NA alpha is treated as though it's 1 + alpha[is.na(alpha)] <- 1 + # if we've already made the proper conversion, return the input + if (inherits(x, "plotly_rgba")) return(x) + if (inherits(x, "plotly_rgb")) { + if (all(alpha == 1)) return(x) + # all alpha channel + x <- sub("^rgb", "rgba", sub("\\)", paste0(",", alpha, ")"), x)) + return(prefix_class(x, "plotly_rgba")) + } + # for some reason ggplot2 has "NA" in some place (instead of NA) + if (is.character(x)) { + x[x == "NA"] <- NA + } + has_alpha <- all(0 <= alpha & alpha < 1) + rgb_matrix <- col2rgb(x, alpha = has_alpha) + # rescale alpha + # TODO: what if x already has an alpha channel??? + if (has_alpha) rgb_matrix["alpha", ] <- alpha + container <- if (has_alpha) "rgba(%s)" else "rgb(%s)" + rgb_a <- sprintf(container, apply(rgb_matrix, 2, paste, collapse = ",")) + rgb_a[is.na(x)] <- "transparent" + structure(rgb_a, class = if (has_alpha) "plotly_rgba" else "plotly_rgb") +} diff --git a/R/trace_generation.R b/R/trace_generation.R deleted file mode 100644 index e6e3e948b2..0000000000 --- a/R/trace_generation.R +++ /dev/null @@ -1,723 +0,0 @@ -#' Convert a layer to a list of traces. Called from gg2list() -#' @param l one layer of the ggplot object -#' @param d one layer of calculated data from ggplot2::ggplot_build(p) -#' @param misc named list of plot info, independent of layer. -#' @return list representing a layer, with corresponding aesthetics, ranges, and groups. -#' @importFrom plyr ddply -#' @importFrom plyr summarise -#' @export -layer2traces <- function(l, d, misc) { - - # TODO: do we really need to remove records with any NAs? - # New version of ggplot2 allows NA for aes (e.g., alpha) - g <- list( - geom = type(l, "geom"), - data = d, - prestats.data = l$prestats.data - ) - # needed for when group, etc. is an expression. - g$aes <- sapply(l$mapping, function(k) as.character(as.expression(k))) - # Partial conversion for geom_violin (Plotly does not offer KDE yet) - if (g$geom == "violin") { - g$geom <- "boxplot" - warning("Converting violin plot into boxplot:\n - probability density estimation is not supported in Plotly yet.") - } - - # geom_smooth() means geom_line() + geom_ribbon() - # Note the line is always drawn, but ribbon is not if se = FALSE. - if (g$geom == "smooth") { - # If smoothLine has been compiled already, consider drawing the ribbon - if (isTRUE(misc$smoothLine)) { - misc$smoothLine <- FALSE - if (isTRUE(l$stat_params$se == FALSE)) { - return(NULL) - } else { - g$geom <- "smoothRibbon" - # disregard colour - g$data <- g$data[!grepl("^colour[.name]?", names(g$data))] - } - } else { - misc$smoothLine <- TRUE - g$geom <- "smoothLine" - } - } - - # For non-numeric data on the axes, we should take the values from - # the original data. - for (axis.name in c("x", "y")) { - if (!misc$is.continuous[[axis.name]]) { - aes.names <- paste0(axis.name, c("", "end", "min", "max")) - aes.used <- aes.names[aes.names %in% names(g$aes)] - for(a in aes.used) { - a.name <- paste0(a, ".name") - col.name <- g$aes[a.name] - dtemp <- l$data[[col.name]] - if (is.null(dtemp)) { - if (!is.null(g$data[[a.name]])) { - # Handle the case where as.Date() is passed in aes argument. - if (class(g$data[[a]]) != class(g$data[[a.name]])) { - g$data[[a]] <- g$data[[a.name]] - data.vec <- g$data[[a]] - } - } - } else { - data.vec <- dtemp - } - - # For some plot types, we overwrite `data` with `prestats.data`. - pdata.vec <- g$prestats.data[[a]] - if (inherits(data.vec, "POSIXt")) { - # Re-create dates from nb seconds - data.vec <- try(strftime(as.POSIXlt(g$data[[a]], origin=the.epoch), - "%Y-%m-%d %H:%M:%S"), silent=TRUE) - pdata.vec <- strftime(as.POSIXlt(g$prestats.data[[a]], - origin=the.epoch), - "%Y-%m-%d %H:%M:%S") - } else if (inherits(data.vec, "Date")) { - # Re-create dates from nb days - data.vec <- try(strftime(as.Date(g$data[[a]], origin=the.epoch), - "%Y-%m-%d %H:%M:%S"), silent=TRUE) - pdata.vec <- strftime(as.Date(g$prestats.data[[a]], origin=the.epoch), - "%Y-%m-%d %H:%M:%S") - } else if (inherits(data.vec, c("character", "factor"))) { - # Re-order data so that Plotly gets it right from ggplot2. - data.vec <- as.factor(data.vec) - g$data <- g$data[order(g$data[[a]]), ] - vec.i <- match(g$data[[a]], as.numeric(data.vec)) - if(anyNA(vec.i)){ - vec.i <- match(g$data[[a.name]], data.vec) - } - data.vec <- data.vec[vec.i] - g$prestats.data <- g$prestats.data[order(g$prestats.data[[a]]), ] - pvec.i <- match(g$prestats.data[[a]], as.numeric(pdata.vec)) - pdata.vec <- pdata.vec[pvec.i] - if (length(pdata.vec) == length(data.vec)) - pdata.vec <- data.vec - if (!is.factor(pdata.vec)) - pdata.vec <- g$prestats.data[[a.name]] - } - - g$data[[a]] <- data.vec - g$prestats.data[[a]] <- pdata.vec - } - } - } - # use un-named parameters so that they will not be exported - # to JSON as a named object, since that causes problems with - # e.g. colour. - g$params <- c(l$geom_params, l$stat_params) - # non-ggplot2 params like name are useful for plot.ly and ggplot2 - # places them into stat_params. - for(p.name in names(g$params)){ - # c("foo") is translated to "foo" in JSON, so instead we use - # list("foo") which becomes ["foo"]. However we need to make sure - # that the list does not have names since list(bar="foo") becomes - # {"bar":"foo"} - names(g$params[[p.name]]) <- NULL - } - - # Convert complex ggplot2 geoms so that they are treated as special - # cases of basic geoms. In ggplot2, this processing is done in the - # draw method of the geoms. - - # for type='scatter', you can define - # mode=none,markers,lines,lines+markers where "lines" is the - # default for 20 or more points, "lines+markers" is the default for - # <20 points. "none" is useful mainly if fill is used to make area - # plots with no lines. - - # First convert to a "basic" geom, e.g. segments become lines. - convert <- toBasic[[g$geom]] - basic <- if (is.function(convert)) convert(g) else g - # Then split on visual characteristics that will get different - # legend entries. - data.list <- if (basic$geom %in% names(markSplit)) { - mark.names <- markSplit[[basic$geom]] - # However, continuously colored points are an exception: they do - # not need a legend entry, and they can be efficiently rendered - # using just 1 trace. - - # Maybe it is nice to show a legend for continuous points? - # if(basic$geom == "point"){ - # to.erase <- names(misc$is.continuous)[misc$is.continuous] - # mark.names <- mark.names[!mark.names %in% to.erase] - # } - name.names <- sprintf("%s.name", mark.names) - # split on 'PANEL' to support facets - is.split <- names(basic$data) %in% c(name.names, "PANEL") - if(any(is.split)){ - data.i <- which(is.split) - matched.names <- names(basic$data)[data.i] - name.i <- name.names %in% matched.names - invariable.names <- cbind(name.names, mark.names)[name.i,] - other.names <- !names(basic$data) %in% invariable.names - vec.list <- basic$data[is.split] - df.list <- split(basic$data, vec.list, drop=TRUE) - lapply(df.list, function(df){ - params <- basic$params - params[invariable.names] <- if (ncol(x <- df[1, invariable.names]) > 0) x else NULL - list(data=df[other.names], - params=params) - }) - } - } - - # case of no legend, if either of the two ifs above failed. - if(is.null(data.list)){ - data.list <- structure(list(list(data=basic$data, params=basic$params)), - names=basic$params$name) - } - getTrace <- geom2trace[[basic$geom]] - if(is.null(getTrace)){ - getTrace <- geom2trace[["blank"]] - warning("geom_", g$geom, " has yet to be implemented in plotly.\n", - " If you'd like to see this geom implemented,\n", - " Please open an issue with your example code at\n", - " https://github.com/ropensci/plotly/issues") - } - traces <- NULL - names.in.legend <- NULL - for (data.i in seq_along(data.list)) { - data.params <- data.list[[data.i]] - data.params$params$stat.type <- type(l, "stat") - # as of ggplot2 version 1.1, param defaults can be obtained from the data - data.params$params <- modifyList( - dat2params(data.params$data), - data.params$params - ) - tr <- do.call(getTrace, data.params) - for (v.name in c("x", "y")) { - vals <- tr[[v.name]] - if (length(vals) > 0 && is.na(vals[length(vals)])) { - tr[[v.name]] <- vals[-length(vals)] - } - } - name.names <- grep("[.]name$", names(data.params$params), value=TRUE) - not.group <- grep("group", name.names, value=TRUE, invert=TRUE) - if (length(not.group)) { - for(a.name in not.group){ - a <- sub("[.]name$", "", a.name) - tr$sort[[a.name]] <- if (a %in% names(misc$breaks)){ - # Custom breaks were specified. - a.value <- as.character(data.params$params[[a.name]]) - ranks <- misc$breaks[[a]] - if (a.value %in% names(ranks)){ - ranks[[a.value]] - } else { - Inf # sorts to the end, when there are less breaks than classes. - } - } else { # custom breaks were not specified. - 1 # sort them all the same. - } - } - name.list <- data.params$params[not.group] - tr$name <- paste(unlist(name.list), collapse=".") - if (length(unique(name.list)) < 2) - tr$name <- as.character(name.list[[1]]) - } - dpd <- data.params$data - if ("PANEL" %in% names(dpd) && nrow(dpd) > 0) { - tr$xaxis <- paste0("x", dpd[1, "COL"]) - tr$yaxis <- paste0("y", dpd[1, "plotly.row"]) - tr$PANEL <- dpd[1, "PANEL"] - } - - if (is.null(tr$name) || tr$name %in% names.in.legend) - tr$showlegend <- FALSE - names.in.legend <- c(names.in.legend, tr$name) - - # special handling for bars - if (g$geom == "bar") { - is_hist <- misc$is.continuous[["x"]] - tr$bargap <- if (is_hist) 0 else "default" - pos <- type(l, "position") - tr$barmode <- - if (pos %in% "identity" && is_hist) { - "overlay" - } else if (pos %in% c("identity", "stack", "fill")) { - "stack" - } else { - "group" - } - } - - traces <- c(traces, list(tr)) - } - - sort.val <- sapply(traces, function(tr){ - rank.val <- unlist(tr$sort) - if(is.null(rank.val)){ - 0 - }else if(length(rank.val)==1){ - rank.val - }else{ - 0 - } - }) - - # reverse the traces in the following cases: - # geom_area - # geom_density with position = stack - if (g$geom %in% c("area", "density") && type(l, "position") == "stack"){ - traces <- rev(traces) - } else{ - traces - } - - ord <- order(sort.val) - no.sort <- traces[ord] - for(tr.i in seq_along(no.sort)){ - s <- no.sort[[tr.i]]$sort - no.sort[[tr.i]]$showlegend <- - if (is.numeric(s)) { - if (s == Inf){ - FALSE - } else { - TRUE - } - } else { # no legend. - FALSE - } - no.sort[[tr.i]]$sort <- NULL - } - # if line portion of geom_smooth was compiled, call layer2traces() - # again for ribbon portion - if (isTRUE(misc$smoothLine)) { - c(layer2traces(l, d, misc), no.sort) - } else { - no.sort - } -}#layer2traces - - -# Preprocess data and params. -toBasic <- list( - segment=function(g){ - # Every row is one segment, we convert to a line with several - # groups which can be efficiently drawn by adding NA rows. - g$data$group <- 1:nrow(g$data) - used <- c("x", "y", "xend", "yend") - others <- g$data[!names(g$data) %in% used] - g$data <- with(g$data, { - rbind(cbind(x, y, others), - cbind(x=xend, y=yend, others)) - }) - group2NA(g, "path") - }, - rect=function(g){ - g$data$group <- 1:nrow(g$data) - used <- c("xmin", "ymin", "xmax", "ymax") - others <- g$data[!names(g$data) %in% used] - g$data <- with(g$data, { - rbind(cbind(x=xmin, y=ymin, others), - cbind(x=xmin, y=ymax, others), - cbind(x=xmax, y=ymax, others), - cbind(x=xmax, y=ymin, others)) - }) - g$geom <- "polygon" - g - }, - ribbon=function(g) { - g$data <- ribbon_dat(g$data) - g$geom <- "polygon" - g - }, - path=function(g) { - group2NA(g, "path") - }, - line=function(g) { - g$data <- g$data[order(g$data$x), ] - group2NA(g, "path") - }, - boxplot=function(g) { - # Preserve default colour values using fill: - if (!is.null(g$data$fill)) { - g$prestats.data$fill <- NULL - dat <- unique(g$data[c("x", "fill")]) - g$prestats.data <- plyr::join(g$prestats.data, dat, by = "x") - } - g$data <- g$prestats.data - g - }, - bar=function(g){ - g <- group2NA(g, "bar") - g$data <- g$data[!is.na(g$data$y), ] - g - }, - contour=function(g) { - g$data <- g$prestats.data - g - }, - density=function(g) { - g$geom <- "area" - if (is.null(g$data$fill) && is.null(g$params$alpha)) g$params$alpha <- 0 - if (is.null(g$data$colour)) g$params$colour <- "black" - g - }, - density2d=function(g) { - g$data <- g$prestats.data - g - }, - abline=function(g) { - N <- nrow(g$data) - m <- g$data$slope - b <- g$data$intercept - xmin <- min(g$prestats.data$globxmin, na.rm = T) - xmax <- max(g$prestats.data$globxmax, na.rm = T) - g$data$plotly_id <- seq_len(N) - l <- list() - for (i in seq_len(N)) { - # the NAs tell plotly to draw different traces for each line - l$x <- c(l$x, xmin, xmax, NA) - l$y <- c(l$y, xmin * m[i] + b[i], xmax * m[i] + b[i], NA) - l$plotly_id <- c(l$plotly_id, rep(i, 3)) - } - g$data <- plyr::join(g$data, data.frame(l), by = "plotly_id") - group2NA(g, "path") - }, - hline=function(g) { - N <- nrow(g$data) - yint <- g$data$yintercept - if (is.factor(g$data$x)) { - s <- sort(g$data$x) - xmin <- as.character(s[1]) - xmax <- as.character(s[length(s)]) - } else { - xmin <- min(g$prestats.data$globxmin, na.rm = T) - xmax <- max(g$prestats.data$globxmax, na.rm = T) - } - g$data$plotly_id <- seq_len(N) - l <- list() - for (i in seq_len(N)) { - l$x <- c(l$x, xmin, xmax, NA) - l$y <- c(l$y, yint[i], yint[i], NA) - l$plotly_id <- c(l$plotly_id, rep(i, 3)) - } - g$data <- plyr::join(g$data, data.frame(l), by = "plotly_id") - group2NA(g, "path") - }, - vline=function(g) { - N <- nrow(g$data) - xint <- g$data$xintercept - if (is.factor(g$data$y)) { - s <- sort(g$data$y) - ymin <- as.character(s[1]) - ymax <- as.character(s[length(s)]) - } else { - ymin <- min(g$prestats.data$globymin, na.rm = T) - ymax <- max(g$prestats.data$globymax, na.rm = T) - } - g$data$plotly_id <- seq_len(N) - l <- list() - for (i in seq_len(N)) { - l$x <- c(l$x, xint[i], xint[i], NA) - l$y <- c(l$y, ymin, ymax, NA) - l$plotly_id <- c(l$plotly_id, rep(i, 3)) - } - g$data <- plyr::join(g$data, data.frame(l), by = "plotly_id") - group2NA(g, "path") - }, - jitter=function(g) { - if ("size" %in% names(g$data)) { - g$params$sizemin <- min(g$prestats.data$globsizemin) - g$params$sizemax <- max(g$prestats.data$globsizemax) - } - g$geom <- "point" - g - }, - point=function(g) { - if (length(unique(g$data$size)) > 1 && is.null(g$data$text)) { - g$data$text <- paste("size:", g$data$size) - } - g - }, - smoothLine=function(g) { - if (length(grep("^colour$", names(g$data))) == 0) - g$params$colour <- "#3366FF" - group2NA(g, "path") - }, - smoothRibbon=function(g) { - if (is.null(g$params$alpha)) g$params$alpha <- 0.2 - g$data <- ribbon_dat(g$data) - g$geom <- "polygon" - g - } -) - -#' Drawing ggplot2 geoms with a group aesthetic is most efficient in -#' plotly when we convert groups of things that look the same to -#' vectors with NA. -#' @param g list of geom info with g$data$group. -#' @param geom change g$geom to this. -#' @export -#' @return list of geom info. -#' @author Toby Dylan Hocking -group2NA <- function(g, geom) { - poly.list <- split(g$data, g$data$group, drop=TRUE) - is.group <- names(g$data) == "group" - poly.na.list <- list() - forward.i <- seq_along(poly.list) - ## When group2NA is called on geom_polygon (or geom_rect, which is - ## treated as a basic polygon), we need to retrace the first points - ## of each group, see https://github.com/ropensci/plotly/pull/178 - retrace.first.points <- g$geom == "polygon" - for (i in forward.i) { - no.group <- poly.list[[i]][, !is.group, drop=FALSE] - na.row <- no.group[1, ] - na.row[, c("x", "y")] <- NA - retrace.first <- if(retrace.first.points){ - no.group[1,] - } - poly.na.list[[paste(i, "forward")]] <- - rbind(no.group, retrace.first, na.row) - } - if(retrace.first.points){ - backward.i <- rev(forward.i[-1])[-1] - for(i in backward.i){ - no.group <- poly.list[[i]][1, !is.group, drop=FALSE] - na.row <- no.group[1, ] - na.row[, c("x", "y")] <- NA - poly.na.list[[paste(i, "backward")]] <- rbind(no.group, na.row) - } - if(length(poly.list) > 1){ - first.group <- poly.list[[1]][1, !is.group, drop=FALSE] - poly.na.list[["last"]] <- rbind(first.group, first.group) - } - } - g$data <- do.call(rbind, poly.na.list) - if(is.na(g$data$x[nrow(g$data)])){ - g$data <- g$data[-nrow(g$data), ] - } - g$geom <- geom - g -} - -# Make a trace for geom_errorbar -> error_y or geom_errorbarh -> -# error_x. -make.errorbar <- function(data, params, xy){ - tr <- list( - x = data$x, - y = data$y, - type = "scatter", - mode = "none" - ) - err.name <- paste0("error_", xy) - min.name <- paste0(xy, "min") - max.name <- paste0(xy, "max") - e <- list( - array = data[[max.name]] - data[[xy]], - type = "data", - width = params$width, - symmetric = TRUE, - color = toRGB(params$colour) - ) - arrayminus <- data[[xy]] - data[[min.name]] - if(!isTRUE(all.equal(e$array, arrayminus))){ - e$arrayminus <- arrayminus - e$symmetric <- FALSE - } - tr[[err.name]] <- e - tr -} - -# function to transform geom_ribbon data into format plotly likes -# (note this function is also used for geom_smooth) -ribbon_dat <- function(dat) { - n <- nrow(dat) - o <- order(dat$x) - o2 <- order(dat$x, decreasing = TRUE) - used <- c("x", "ymin", "ymax") - not_used <- setdiff(names(dat), used) - # top-half of ribbon - tmp <- dat[o, ] - others <- tmp[not_used] - dat1 <- cbind(x = tmp$x, y = tmp$ymax, others) - dat1[n+1, ] <- cbind(x = tmp$x[n], y = tmp$ymin[n], others[n, ]) - # bottom-half of ribbon - tmp2 <- dat[o2, ] - others2 <- tmp2[not_used] - dat2 <- cbind(x = tmp2$x, y = tmp2$ymin, others2) - rbind(dat1, dat2) -} - - -dat2params <- function(d) { - params <- c(names(aesConverters), "fill") - l <- as.list(d[names(d) %in% params]) - lapply(l, unique) -} - -# Convert basic geoms to traces. -geom2trace <- list( - blank=function(data, params) { - list( - x=data$x, - y=data$y, - name=params$name, - text=data$text, - type="scatter", - mode="markers", - marker=list(opacity = 0) - ) - }, - path=function(data, params) { - # when converting ggplot2 size to plotly size, we assume size is an _area_, - # but "size" for lines really means linewidth, so size is a _length_ in this case - # (see aesConverters$size) - params$size <- ifelse(params$size < 1, params$size ^ 2, sqrt(params$size)) - list(x=data$x, - y=data$y, - name=params$name, - text=data$text, - type="scatter", - mode="lines", - line=paramORdefault(params, aes2line, ggplot2::GeomPath$default_aes)) - }, - polygon=function(data, params){ - g <- list(data = data, geom = "polygon") - g <- group2NA(g, "polygon") - list( - x = g$data$x, - y = g$data$y, - name = params$name, - text = g$data$text, - type = "scatter", - mode = "lines", - line = paramORdefault(params, aes2line, ggplot2::GeomPolygon$default_aes), - fill = "tozerox", - fillcolor = toRGB(params$fill, params$alpha) - ) - }, - point=function(data, params){ - # params contains unique values, but we need _all_ values from the data - for (i in names(params)) { - if (length(params[[i]]) > 1) params[[i]] <- data[[i]] - } - L <- list( - x = data$x, - y = data$y, - name = params$name, - text = as.character(data$text), - type = "scatter", - mode = "markers", - marker = paramORdefault(params, aes2marker, ggplot2::GeomPoint$default_aes) - ) - if (!is.null(params$shape) && params$shape %in% c(21:25)) { - L$marker$color <- toRGB(params$fill %||% "black") - } - if (!is.null(params$shape) && params$shape %in% c(32)) { - L$visible <- FALSE - } - L - }, - text=function(data, params){ - L <- list(x=data$x, - y=data$y, - text=data$label, - type="scatter", - mode="text") - if (!is.null(params$size)) { - L$textfont$size <- params$size - } - if (!is.null(params$colour)) { - L$textfont$color <- params$colour - } - L - }, - bar=function(data, params) { - x <- if ("x.name" %in% names(data)) data$x.name else data$x - if (inherits(x, "POSIXt")) { - # Convert seconds into milliseconds - x <- as.numeric(x) * 1000 - } else if (inherits(x, "Date")) { - # Convert days into milliseconds - x <- as.numeric(x) * 24 * 60 * 60 * 1000 - } - # if there is more than one y-value for a particular combination of - # x, PANEL, and group; then take the _max_ y. - data$x <- x - dat <- plyr::ddply(data, c("x", "PANEL", if ("group" %in% names(data)) "group"), - plyr::summarise, count = max(y)) - L <- list( - x = dat$x, - y = dat$count, - type = "bar", - # text only makes sense if no dimension reduction occurred - text = if (nrow(dat) == nrow(data)) data$text else NULL, - name = params$name, - marker = list(color = toRGB(params$fill)) - ) - if (!is.null(params$colour)) { - L$marker$line <- list(color = toRGB(params$colour)) - L$marker$line$width <- params$size %||% 1 - } - if (!is.null(params$alpha)) L$opacity <- params$alpha - L - }, - step=function(data, params) { - list(x=data$x, - y=data$y, - name=params$name, - type="scatter", - mode="lines", - line=paramORdefault(params, aes2step, ggplot2::GeomPath$default_aes)) - }, - tile=function(data, params) { - list(x=unique(data$x), - y=unique(data$y), - z=t(matrix(data$fill.name, nrow=length(unique(data$x)), - ncol=length(unique(data$y)))), - name=params$name, - type="heatmap", - mode="lines", - line=paramORdefault(params, aes2line, ggplot2::GeomPath$default_aes)) - }, - boxplot=function(data, params) { - list( - y = data$y, - name = params$name, - type = "box", - # TODO: translate marker styling for outliers! - line = paramORdefault(params, aes2line, ggplot2::GeomBoxplot$default_aes), - fillcolor = toRGB(params$fill %||% "white") - ) - }, - contour=function(data, params) { - L <- list(x=unique(data$x), - y=unique(data$y), - z=t(matrix(data$z, nrow=length(unique(data$x)), - ncol=length(unique(data$y)))), - name=params$name, - type="contour", - line=paramORdefault(params, aes2line, ggplot2::GeomPath$default_aes)) - L$contours=list(coloring="lines") - L - }, - density2d=function(data, params) { - L <- list(x=data$x, - y=data$y, - name=params$name, - type="histogram2dcontour", - line=paramORdefault(params, aes2line, ggplot2::GeomPath$default_aes)) - L$contours=list(coloring="lines") - L - }, - errorbar=function(data, params) { - make.errorbar(data, params, "y") - }, - errorbarh=function(data, params) { - make.errorbar(data, params, "x") - }, - area=function(data, params) { - list( - x = c(data$x[1], data$x, tail(data$x, n = 1)), - y = c(0, data$y, 0), - name = params$name, - type = "scatter", - line = paramORdefault(params, aes2line, ggplot2::GeomRibbon$default_aes), - fill = "tozeroy", - fillcolor = toRGB(params$fill %||% "grey20", params$alpha) - ) - } -) diff --git a/R/utils.R b/R/utils.R index a5095c0581..2b2d589646 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,26 @@ -#' @importFrom grDevices col2rgb -#' @importFrom utils getFromNamespace modifyList data packageVersion browseURL -#' @importFrom stats setNames - is.plotly <- function(x) inherits(x, "plotly") "%||%" <- function(x, y) { - if (length(x) > 0) x else y + if (length(x) > 0 || is_blank(x)) x else y +} + +# modify %||% so that NA is considered NULL +"%|x|%" <- function(x, y) { + if (length(x) == 1) { + if (is.na(x)) x <- NULL + } + x %||% y +} + +compact <- function(x) { + Filter(Negate(is.null), x) } is.discrete <- function(x) { is.factor(x) || is.character(x) || is.logical(x) } -# special enviroment that tracks trace/layout information +# special enviroment that enables NSE plotlyEnv <- new.env(parent = emptyenv()) # hash plot info, assign it to the special plotly environment, & attach it to data @@ -166,6 +174,7 @@ rm_asis <- function(x) { # jsonlite converts NULL to {} and NA to null (plotly prefers null to {}) # https://github.com/jeroenooms/jsonlite/issues/29 if (is.null(x)) return(NA) + if (is.data.frame(x)) return(x) if (is.list(x)) lapply(x, rm_asis) # strip any existing 'AsIs' list elements of their 'AsIs' status. # this is necessary since ggplot_build(qplot(1:10, fill = I("red"))) @@ -178,9 +187,16 @@ rm_asis <- function(x) { # add a class to an object only if it is new, and keep any existing classes of # that object -struct <- function(x, y, ...) { - structure(x, class = unique(c(class(x), y)), ...) -} +append_class <- function(x, y) { + structure(x, class = unique(c(class(x), y))) +} +prefix_class <- function(x, y) { + structure(x, class = unique(c(y, class(x)))) +} +replace_class <- function(x, new, old) { + class(x) <- sub(old, new, class(x)) + x +} # TODO: what are some other common configuration options we want to support?? get_domain <- function(type = "") { diff --git a/inst/examples/plotly3DEvents/app.R b/inst/examples/plotly3DEvents/app.R new file mode 100644 index 0000000000..1afbe06fdb --- /dev/null +++ b/inst/examples/plotly3DEvents/app.R @@ -0,0 +1,28 @@ +library(shiny) +library(plotly) + +ui <- fluidPage( + plotlyOutput("plot"), + verbatimTextOutput("hover"), + verbatimTextOutput("click") +) + +server <- function(input, output, session) { + + output$plot <- renderPlotly({ + plot_ly(x = rnorm(10), y = rnorm(10), z = rnorm(10), type = "scatter3d") + }) + + output$hover <- renderPrint({ + d <- event_data("plotly_hover") + if (is.null(d)) "Hover events appear here (unhover to clear)" else d + }) + + output$click <- renderPrint({ + d <- event_data("plotly_click") + if (is.null(d)) "Click events appear here (double-click to clear)" else d + }) + +} + +shinyApp(ui, server, options = list(display.mode = "showcase")) diff --git a/inst/examples/plotlyEvents/app.R b/inst/examples/plotlyEvents/app.R index f74cd41b9b..13f3e9ba66 100644 --- a/inst/examples/plotlyEvents/app.R +++ b/inst/examples/plotlyEvents/app.R @@ -12,11 +12,14 @@ ui <- fluidPage( server <- function(input, output, session) { output$plot <- renderPlotly({ + # use the key aesthetic/argument to help uniquely identify selected observations + key <- row.names(mtcars) if (identical(input$plotType, "ggplotly")) { - p <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point() + p <- ggplot(mtcars, aes(x = mpg, y = wt, colour = factor(vs), key = key)) + + geom_point() ggplotly(p) %>% layout(dragmode = "select") } else { - plot_ly(mtcars, x = mpg, y = wt, mode = "markers") %>% + plot_ly(mtcars, x = mpg, y = wt, key = key, mode = "markers") %>% layout(dragmode = "select") } }) diff --git a/inst/htmlwidgets/plotly.js b/inst/htmlwidgets/plotly.js index 07713ace63..f974afeaf9 100644 --- a/inst/htmlwidgets/plotly.js +++ b/inst/htmlwidgets/plotly.js @@ -31,82 +31,59 @@ HTMLWidgets.widget({ Plotly.newPlot(graphDiv, x.data, x.layout); } - // send user input event data to shiny - if (shinyMode) { - graphDiv.on('plotly_click', function(eventData) { - // extract only the data we may want to access in R + sendEventData = function(eventType) { + return function(eventData) { + if (eventData === undefined || !eventData.hasOwnProperty("points")) { + return null; + } var d = eventData.points.map(function(pt) { var obj = { - curveNumber: pt.curveNumber, - pointNumber: pt.pointNumber, - x: pt.x, - y: pt.y + curveNumber: pt.curveNumber, + pointNumber: pt.pointNumber, + x: pt.x, + y: pt.y }; - if (pt.data.hasOwnProperty("key")) { - if (typeof pt.pointNumber === "number") { - obj.key = pt.data.key[pt.pointNumber]; - } else { - obj.key = pt.data.key[pt.pointNumber[0]][pt.pointNumber[1]]; - } // TODO: can pointNumber be 3D? - } - return obj; - }); - Shiny.onInputChange(".clientValue-plotly_click-" + x.source, d); - }); - - // clear click selection - graphDiv.on('plotly_doubleclick', function(eventData) { - Shiny.onInputChange(".clientValue-plotly_click-" + x.source, null); - }); - - graphDiv.on('plotly_hover', function(eventData) { - // extract only the data we may want to access in R - var d = eventData.points.map(function(pt) { - var obj = { - curveNumber: pt.curveNumber, - pointNumber: pt.pointNumber, - x: pt.x, - y: pt.y + // grab the trace corresponding to this point + var tr = x.data[pt.curveNumber]; + // add on additional trace info, if it exists + attachKey = function(keyName) { + if (tr.hasOwnProperty(keyName)) { + if (typeof pt.pointNumber === "number") { + obj[keyName] = tr[keyName][pt.pointNumber]; + } else { + obj[keyName] = tr[keyName][pt.pointNumber[0]][pt.pointNumber[1]]; + }// TODO: can pointNumber be 3D? + } }; - if (pt.data.hasOwnProperty("key")) { - if (typeof pt.pointNumber === "number") { - obj.key = pt.data.key[pt.pointNumber]; - } else { - obj.key = pt.data.key[pt.pointNumber[0]][pt.pointNumber[1]]; - } // TODO: can pointNumber be 3D? - } - return obj; + attachKey("z"); + attachKey("key"); + return obj; }); - Shiny.onInputChange(".clientValue-plotly_hover-" + x.source, d); - }); - - // clear hover selection + Shiny.onInputChange( + ".clientValue-" + eventType + "-" + x.source, + JSON.stringify(d) + ); + }; + }; + + // send user input event data to shiny + if (shinyMode) { + graphDiv.on('plotly_hover', sendEventData('plotly_hover')); + graphDiv.on('plotly_click', sendEventData('plotly_click')); + graphDiv.on('plotly_selected', sendEventData('plotly_selected')); graphDiv.on('plotly_unhover', function(eventData) { Shiny.onInputChange(".clientValue-plotly_hover-" + x.source, null); }); - - graphDiv.on('plotly_selected', function(eventData) { - if (eventData !== undefined) { - // convert the array of objects to object of arrays so this converts - // to data frame in R as opposed to a vector - var pts = eventData.points; - var obj = { - curveNumber: pts.map(function(pt) {return pt.curveNumber; }), - pointNumber: pts.map(function(pt) {return pt.pointNumber; }), - x: pts.map(function(pt) {return pt.x; }), - y: pts.map(function(pt) {return pt.y; }) - }; - Shiny.onInputChange(".clientValue-plotly_selected-" + x.source, obj); - } + graphDiv.on('plotly_doubleclick', function(eventData) { + Shiny.onInputChange(".clientValue-plotly_click-" + x.source, null); }); - - // clear select/lasso selection & click + // 'plotly_deselect' is code for doubleclick when in select mode graphDiv.on('plotly_deselect', function(eventData) { Shiny.onInputChange(".clientValue-plotly_selected-" + x.source, null); Shiny.onInputChange(".clientValue-plotly_click-" + x.source, null); }); - - } // shinyMode - } // renderValue + } + + } }); diff --git a/man/bbox.Rd b/man/bbox.Rd new file mode 100644 index 0000000000..174ff0d7dc --- /dev/null +++ b/man/bbox.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggplotly.R +\name{bbox} +\alias{bbox} +\title{Estimate bounding box of a rotated string} +\usage{ +bbox(txt = "foo", angle = 0, size = 12) +} +\arguments{ +\item{txt}{a character string of length 1} + +\item{angle}{sets the angle of the tick labels with respect to the +horizontal (e.g., `tickangle` of -90 draws the tick labels vertically)} + +\item{size}{vertical size of a character} +} +\description{ +Estimate bounding box of a rotated string +} +\references{ +https://www.dropbox.com/s/nc6968prgw8ne4w/bbox.pdf?dl=0 +} + diff --git a/man/embed_notebook.Rd b/man/embed_notebook.Rd index a1072aa525..4415eb7dd6 100644 --- a/man/embed_notebook.Rd +++ b/man/embed_notebook.Rd @@ -18,8 +18,6 @@ embed_notebook(x, width = NULL, height = NULL, \item{file}{a filename for saving the standalone HTML (only used if x is a non-figure object)} - -\item{dir}{a directory for placing} } \description{ Embed a plotly figure as an iframe into a IPython Notebook diff --git a/man/geom2trace.Rd b/man/geom2trace.Rd new file mode 100644 index 0000000000..aa67d9f22e --- /dev/null +++ b/man/geom2trace.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layers2traces.R +\name{geom2trace} +\alias{geom2trace} +\title{Convert a "basic" geoms to a plotly.js trace.} +\usage{ +geom2trace(data, params) +} +\arguments{ +\item{data}{the data returned by \code{plotly::to_basic}.} + +\item{params}{parameters for the geom, statistic, and 'constant' aesthetics} +} +\description{ +This function makes it possible to convert ggplot2 geoms that +are not included with ggplot2 itself. Users shouldn't need to use +this function. It exists purely to allow other package authors to write +their own conversion method(s). +} + diff --git a/man/gg2list.Rd b/man/gg2list.Rd index e706677ac6..2f0c1ab1a8 100644 --- a/man/gg2list.Rd +++ b/man/gg2list.Rd @@ -16,7 +16,7 @@ gg2list(p, width = NULL, height = NULL, source = "A") \item{source}{Only relevant for \link{event_data}.} } \value{ -figure object (list with names "data" and "layout"). +a 'built' plotly object (list with names "data" and "layout"). } \description{ Convert a ggplot to a list. diff --git a/man/ggplot_build2.Rd b/man/ggplot_build2.Rd deleted file mode 100644 index 207c3e8127..0000000000 --- a/man/ggplot_build2.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/build_function.R -\name{ggplot_build2} -\alias{ggplot_build2} -\title{ggplot build function with enhanced return} -\usage{ -ggplot_build2(plot) -} -\arguments{ -\item{plot}{ggplot2 plot} -} -\value{ -List with (data, panel, plot, prestats.data) where prestats.data -is the data as it is prior to calculate_stats() call -} -\description{ -This function builds on top of ggplot2::ggplot_build by -Hadley Wickham and Winston Chang -(http://ggplot2.org, https://github.com/hadley/ggplot2). -} -\keyword{internal} - diff --git a/man/ggplotly.Rd b/man/ggplotly.Rd index bfc4cbc266..63cc2f4269 100644 --- a/man/ggplotly.Rd +++ b/man/ggplotly.Rd @@ -16,6 +16,9 @@ ggplotly(p = ggplot2::last_plot(), width = NULL, height = NULL, \item{source}{Only relevant for \link{event_data}.} } +\value{ +a plotly object +} \description{ See up-to-date documentation and examples at \url{https://plot.ly/ggplot2} @@ -26,13 +29,11 @@ See up-to-date documentation and examples at ggiris <- qplot(Petal.Width, Sepal.Length, data = iris, color = Species) ggplotly(ggiris) -# maps!! data(canada.cities, package = "maps") viz <- ggplot(canada.cities, aes(long, lat)) + - borders(regions = "canada", name = "borders") + + borders(regions = "canada") + coord_equal() + - geom_point(aes(text = name, size = pop), colour = "red", - alpha = 1/2, name = "cities") + geom_point(aes(text = name, size = pop), colour = "red", alpha = 1/2) ggplotly(viz) } diff --git a/man/group2NA.Rd b/man/group2NA.Rd deleted file mode 100644 index 2f9bac2ccb..0000000000 --- a/man/group2NA.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/trace_generation.R -\name{group2NA} -\alias{group2NA} -\title{Drawing ggplot2 geoms with a group aesthetic is most efficient in -plotly when we convert groups of things that look the same to -vectors with NA.} -\usage{ -group2NA(g, geom) -} -\arguments{ -\item{g}{list of geom info with g$data$group.} - -\item{geom}{change g$geom to this.} -} -\value{ -list of geom info. -} -\description{ -Drawing ggplot2 geoms with a group aesthetic is most efficient in -plotly when we convert groups of things that look the same to -vectors with NA. -} -\author{ -Toby Dylan Hocking -} - diff --git a/man/layer2traces.Rd b/man/layer2traces.Rd deleted file mode 100644 index b930ad89d6..0000000000 --- a/man/layer2traces.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/trace_generation.R -\name{layer2traces} -\alias{layer2traces} -\title{Convert a layer to a list of traces. Called from gg2list()} -\usage{ -layer2traces(l, d, misc) -} -\arguments{ -\item{l}{one layer of the ggplot object} - -\item{d}{one layer of calculated data from ggplot2::ggplot_build(p)} - -\item{misc}{named list of plot info, independent of layer.} -} -\value{ -list representing a layer, with corresponding aesthetics, ranges, and groups. -} -\description{ -Convert a layer to a list of traces. Called from gg2list() -} - diff --git a/man/paramORdefault.Rd b/man/paramORdefault.Rd deleted file mode 100644 index e24e4b8fa2..0000000000 --- a/man/paramORdefault.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/marker_conversion.R -\name{paramORdefault} -\alias{paramORdefault} -\title{Convert ggplot params to plotly.} -\usage{ -paramORdefault(params, aesVec, defaults) -} -\arguments{ -\item{params}{named list ggplot names -> values.} - -\item{aesVec}{vector mapping ggplot names to plotly names.} - -\item{defaults}{named list ggplot names -> values.} -} -\value{ -named list. -} -\description{ -Convert ggplot params to plotly. -} -\author{ -Toby Dylan Hocking -} - diff --git a/man/toFill.Rd b/man/toFill.Rd deleted file mode 100644 index 2b2d455882..0000000000 --- a/man/toFill.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/colour_conversion.R -\name{toFill} -\alias{toFill} -\title{Use default ggplot colour for fill (gray20) if not declared} -\usage{ -toFill(x, alpha = 1) -} -\arguments{ -\item{x}{character for colour} - -\item{alpha}{transparency alpha} -} -\value{ -hexadecimal colour value -} -\description{ -Use default ggplot colour for fill (gray20) if not declared -} - diff --git a/man/toRGB.Rd b/man/toRGB.Rd index c45fe510f1..6102267491 100644 --- a/man/toRGB.Rd +++ b/man/toRGB.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/colour_conversion.R +% Please edit documentation in R/toRGB.R \name{toRGB} \alias{toRGB} \title{Convert R colours to RGBA hexadecimal colour values} @@ -7,9 +7,9 @@ toRGB(x, alpha = 1) } \arguments{ -\item{x}{character for colour, for example: "white"} +\item{x}{see the \code{col} argument in \code{col2rgb} for valid specifications} -\item{alpha}{transparency alpha} +\item{alpha}{alpha channel on 0-1 scale} } \value{ hexadecimal colour value (if is.na(x), return "transparent" for compatibility with Plotly) diff --git a/man/to_basic.Rd b/man/to_basic.Rd new file mode 100644 index 0000000000..7442826d84 --- /dev/null +++ b/man/to_basic.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layers2traces.R +\name{to_basic} +\alias{to_basic} +\title{Convert a geom to a "basic" geom.} +\usage{ +to_basic(data, prestats_data, layout, params, ...) +} +\arguments{ +\item{data}{the data returned by \code{ggplot2::ggplot_build()}.} + +\item{prestats_data}{the data before statistics are computed.} + +\item{layout}{the panel layout.} + +\item{params}{parameters for the geom, statistic, and 'constant' aesthetics} + +\item{...}{currently ignored} +} +\description{ +This function makes it possible to convert ggplot2 geoms that +are not included with ggplot2 itself. Users shouldn't need to use +this function. It exists purely to allow other package authors to write +their own conversion method(s). +} + diff --git a/tests/testthat/test-cookbook-axes.R b/tests/testthat/test-cookbook-axes.R index 23f937c8a5..031fd18b6b 100644 --- a/tests/testthat/test-cookbook-axes.R +++ b/tests/testthat/test-cookbook-axes.R @@ -1,8 +1,5 @@ context("cookbook axes") -bp <- ggplot(PlantGrowth, aes(x=group, y=weight)) + - geom_boxplot() - expect_traces <- function(gg, n.traces, name) { stopifnot(is.ggplot(gg)) stopifnot(is.numeric(n.traces)) @@ -13,34 +10,11 @@ expect_traces <- function(gg, n.traces, name) { }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - list(traces=has.data, layout=L$layout) -} - -get_legend <- function(L) { - if (!isTRUE(L$kwargs$layout$showlegend)) { - return(data.frame()) - } - legend.list <- list() - for (tr in L$traces) { - if (is.character(tr$name)) { - legend.list[[tr$name]] <- - data.frame(name=tr$name, showlegend=tr$showlegend) - } - } - legend.df <- do.call(rbind, legend.list) - subset(legend.df, showlegend) -} - -leg <- function(...) { - name <- c(...) - data.frame(name) + list(data = has.data, layout = L$layout) } -expect_legend <- function(L, expected) { - stopifnot(is.data.frame(expected)) - shown <- get_legend(L) - expect_identical(shown$name, expected$name) -} +bp <- ggplot(PlantGrowth, aes(x = group, y = weight)) + + geom_boxplot() # Reverse the order of a discrete-valued axis # Get the levels of the factor @@ -49,67 +23,59 @@ flevels <- levels(PlantGrowth$group) # Reverse the order flevels <- rev(flevels) # "trt2" "trt1" "ctrl" -bp.flevels <- bp + scale_x_discrete(limits=flevels) +bp.flevels <- bp + scale_x_discrete(limits = flevels) test_that("factor levels determine tick order", { - info <- expect_traces(bp.flevels, 3, "flevels") - trace.names <- sapply(info$traces, "[[", "name") - expect_identical(as.character(trace.names), - c("trt2", "trt1", "ctrl")) - expect_legend(info, leg()) + info <- expect_traces(bp.flevels, 1, "flevels") + expect_identical(info$layout$xaxis$ticktext, c("trt2", "trt1", "ctrl")) }) ## These two do the same thing; all data points outside the graphing ## range are dropped, resulting in a misleading box plot. bp.ylim.hide <- bp + ylim(5, 7.5) test_that("ylim hides points", { - info <- expect_traces(bp.ylim.hide, 3, "ylim.hide") - expect_legend(info, leg()) + info <- expect_traces(bp.ylim.hide, 1, "ylim.hide") }) -bp.scale.hide <- bp + scale_y_continuous(limits=c(5, 7.5)) +bp.scale.hide <- bp + scale_y_continuous(limits = c(5, 7.5)) test_that("scale_y(limits) hides points", { - info <- expect_traces(bp.scale.hide, 3, "scale.hide") - expect_legend(info, leg()) - expect_equal(info$layout$yaxis$range, c(5, 7.5)) + info <- expect_traces(bp.scale.hide, 1, "scale.hide") + expect_equal(range(info$layout$yaxis$tickvals), c(5, 7.5)) + y <- unlist(lapply(info$data, "[[", "y")) + expect_true(all(5 <= y & y <= 7.5, na.rm = TRUE)) }) -bp.coord <- bp + coord_cartesian(ylim=c(5, 7.5)) +bp.coord <- bp + coord_cartesian(ylim = c(5, 7.5)) test_that("Using coord_cartesian zooms into the area", { - info <- expect_traces(bp.coord, 3, "coord-ylim") - expect_legend(info, leg()) - expect_equal(info$layout$yaxis$range, c(5, 7.5)) + info <- expect_traces(bp.coord, 1, "coord-ylim") + expect_equal(range(info$layout$yaxis$tickvals), c(5, 7.5)) + y <- unlist(lapply(info$data, "[[", "y")) + expect_false(all(5 <= y & y <= 7.5)) }) # Create some noisy exponentially-distributed data -xval <- c(0.26932812,-0.05341404,0.36977717,0.91504712,0.46329006,0.37956526, 0.93290644,0.75558976,0.67633497,0.48655293,0.79478162,0.55109982, 0.51681398,0.81073512,0.49406579,0.93919618,0.90472008,0.98732256, 0.94379876,0.95790909,0.54614241,1.13356941,1.13299144,1.18159277, 1.16428407,1.22955005,1.21030897,1.23314811,1.53822718,1.53674330, 1.80020468,1.40774011,1.74573515,1.26651625,2.06607711,1.50237263, 1.38480531,1.83625381,2.35275649,1.99004291,2.80396442,2.20863240, 2.42998876,2.12801180,2.26290348,2.38185989,2.14936036,2.66587947, 2.64586596,2.44240603,2.39266452,3.11831215,2.70258927,2.65529134, 2.65634690,2.95984290,2.71058076,2.87919480,3.07739358,2.66841935, 3.10792706,3.17134285,3.98070271,3.55497279,3.36831009,3.31390892, 3.32753965,2.86981968,3.22741000,3.78806438,3.74434536,3.56928928, 3.83783177,3.24485807,4.05766233,4.13619455,4.26888054,3.47546258, 3.93045819,3.77620080,4.66676431,3.88059240,4.54694485,4.03915767, 4.25556093,4.39251819,4.42692029,4.23262929,4.44890758,4.84981161, 4.51104252,4.33004508,5.06350705,4.89714069,4.21599077,4.55457578, 5.04044393,4.89111297,5.03105215,4.64113164) - -yval <- c(1.177512e+01,7.303113e+00,6.109053e+00,2.545169e+01,3.366341e+01,1.042255e+01,2.703767e+01,1.178223e+01,4.495965e+01,1.614609e+01,4.003015e+01,1.038442e+02,4.024992e+01,4.163942e+01,9.108197e+01,3.116299e+01,2.558871e+02,7.482977e+01,2.502789e+01,5.923683e+01,3.967814e+01,9.207318e+01,1.298618e+02,1.138197e+02,1.804303e+02,3.363494e+02,3.197204e+02,4.968737e+02,1.783433e+02,4.765546e+02,4.486885e+02,6.736079e+02,4.289288e+02,3.433946e+02,5.658634e+02,4.667053e+02,5.257803e+02,3.401038e+02,6.131335e+02,5.928647e+02,7.838524e+02,7.987915e+02,3.348470e+03,1.704767e+03,1.264169e+03,2.690011e+03,2.738240e+03,1.663862e+03,5.377442e+03,3.883820e+03,6.673624e+03,1.857346e+03,6.683962e+03,1.213027e+03,1.742885e+03,2.146094e+03,4.597174e+03,4.357154e+03,8.413851e+03,8.194194e+03,7.076611e+03,1.554628e+04,6.984783e+03,1.027392e+04,1.158795e+04,9.193111e+03,3.226748e+04,3.955445e+04,2.978953e+04,1.926420e+04,7.610544e+04,2.129694e+04,1.438764e+04,7.908876e+04,2.676003e+04,1.791758e+05,3.978871e+04,9.411120e+04,4.486940e+04,1.270526e+05,1.587331e+05,1.616173e+05,3.351522e+05,3.001782e+05,2.527824e+05,2.745851e+05,3.446376e+05,1.544497e+05,1.318314e+05,8.334336e+05,2.464391e+05,8.694818e+05,2.747323e+05,6.373497e+05,2.918690e+05,9.505114e+05,7.835278e+05,3.775567e+05,1.795523e+06,1.568159e+06) - -dat <- data.frame(xval = xval, yval = yval) +dat <- data.frame( + xval = c(0.26932812,-0.05341404,0.36977717,0.91504712,0.46329006,0.37956526, 0.93290644,0.75558976,0.67633497,0.48655293,0.79478162,0.55109982, 0.51681398,0.81073512,0.49406579,0.93919618,0.90472008,0.98732256, 0.94379876,0.95790909,0.54614241,1.13356941,1.13299144,1.18159277, 1.16428407,1.22955005,1.21030897,1.23314811,1.53822718,1.53674330, 1.80020468,1.40774011,1.74573515,1.26651625,2.06607711,1.50237263, 1.38480531,1.83625381,2.35275649,1.99004291,2.80396442,2.20863240, 2.42998876,2.12801180,2.26290348,2.38185989,2.14936036,2.66587947, 2.64586596,2.44240603,2.39266452,3.11831215,2.70258927,2.65529134, 2.65634690,2.95984290,2.71058076,2.87919480,3.07739358,2.66841935, 3.10792706,3.17134285,3.98070271,3.55497279,3.36831009,3.31390892, 3.32753965,2.86981968,3.22741000,3.78806438,3.74434536,3.56928928, 3.83783177,3.24485807,4.05766233,4.13619455,4.26888054,3.47546258, 3.93045819,3.77620080,4.66676431,3.88059240,4.54694485,4.03915767, 4.25556093,4.39251819,4.42692029,4.23262929,4.44890758,4.84981161, 4.51104252,4.33004508,5.06350705,4.89714069,4.21599077,4.55457578, 5.04044393,4.89111297,5.03105215,4.64113164), + yval = c(1.177512e+01,7.303113e+00,6.109053e+00,2.545169e+01,3.366341e+01,1.042255e+01,2.703767e+01,1.178223e+01,4.495965e+01,1.614609e+01,4.003015e+01,1.038442e+02,4.024992e+01,4.163942e+01,9.108197e+01,3.116299e+01,2.558871e+02,7.482977e+01,2.502789e+01,5.923683e+01,3.967814e+01,9.207318e+01,1.298618e+02,1.138197e+02,1.804303e+02,3.363494e+02,3.197204e+02,4.968737e+02,1.783433e+02,4.765546e+02,4.486885e+02,6.736079e+02,4.289288e+02,3.433946e+02,5.658634e+02,4.667053e+02,5.257803e+02,3.401038e+02,6.131335e+02,5.928647e+02,7.838524e+02,7.987915e+02,3.348470e+03,1.704767e+03,1.264169e+03,2.690011e+03,2.738240e+03,1.663862e+03,5.377442e+03,3.883820e+03,6.673624e+03,1.857346e+03,6.683962e+03,1.213027e+03,1.742885e+03,2.146094e+03,4.597174e+03,4.357154e+03,8.413851e+03,8.194194e+03,7.076611e+03,1.554628e+04,6.984783e+03,1.027392e+04,1.158795e+04,9.193111e+03,3.226748e+04,3.955445e+04,2.978953e+04,1.926420e+04,7.610544e+04,2.129694e+04,1.438764e+04,7.908876e+04,2.676003e+04,1.791758e+05,3.978871e+04,9.411120e+04,4.486940e+04,1.270526e+05,1.587331e+05,1.616173e+05,3.351522e+05,3.001782e+05,2.527824e+05,2.745851e+05,3.446376e+05,1.544497e+05,1.318314e+05,8.334336e+05,2.464391e+05,8.694818e+05,2.747323e+05,6.373497e+05,2.918690e+05,9.505114e+05,7.835278e+05,3.775567e+05,1.795523e+06,1.568159e+06) +) sp <- ggplot(dat, aes(xval, yval)) + geom_point() test_that("A scatterplot with regular (linear) axis scaling", { info <- expect_traces(sp, 1, "linear-axes") - # TODO: why does this test take so long? - expect_legend(info, leg()) }) library(scales) -# TODO: Add package "scales" to the list of dependencies? -sp.log2.scale <- sp + scale_y_continuous(trans=log2_trans()) +sp.log2.scale <- sp + scale_y_continuous(trans = log2_trans()) test_that("log2 scaling of the y axis (with visually-equal spacing)", { info <- expect_traces(sp.log2.scale, 1, "log2-scale") - expect_legend(info, leg()) }) -sp.log2.coord <- sp + coord_trans(y="log2") +sp.log2.coord <- sp + coord_trans(y = "log2") test_that("log2 coordinate transformation with visually-diminishing spacing", { info <- expect_traces(sp.log2.coord, 1, "log2-coord") - expect_legend(info, leg()) }) sp.labels <- sp + @@ -119,14 +85,12 @@ sp.labels <- sp + test_that("log2 transform with labels", { info <- expect_traces(sp.labels, 1, "log2-labels") - expect_legend(info, leg()) }) sp.log10 <- sp + scale_y_log10() test_that("scale_y_log10", { info <- expect_traces(sp.log10, 1, "scale_y_log10") - expect_legend(info, leg()) }) sp.log10.labels <- sp + @@ -135,25 +99,6 @@ sp.log10.labels <- sp + test_that("log10 with exponents on tick labels", { info <- expect_traces(sp.log10.labels, 1, "scale_y_log10-labels") - expect_legend(info, leg()) -}) - -# Data where x ranges from 0-10, y ranges from 0-30 -dat <- data.frame(xval = runif(40,0,10), yval = runif(40,0,30)) -sp <- ggplot(dat, aes(xval, yval)) + geom_point() - -sp.fixed <- sp + coord_fixed() - -test_that("Force equal scaling", { - info <- expect_traces(sp.fixed, 1, "coord-fixed") - expect_legend(info, leg()) -}) - -sp.ratio <- sp + coord_fixed(ratio=1/3) - -test_that("coord_fixed(ratio)", { - info <- expect_traces(sp.ratio, 1, "coord-fixed-ratio") - expect_legend(info, leg()) }) no.x.title <- bp + @@ -161,8 +106,8 @@ no.x.title <- bp + ylab("Weight (Kg)") # Set y-axis label test_that("coord_fixed(ratio)", { - info <- expect_traces(no.x.title, 3, "no-x-title") - expect_legend(info, leg()) + info <- expect_traces(no.x.title, 1, "no-x-title") + expect_true(length(info$layout$annotations) == 1) }) # Also possible to set the axis label with the scale @@ -172,8 +117,7 @@ bp.scale.name <- bp + scale_x_discrete(name="") + scale_y_continuous(name="Weight (Kg)") test_that("scale(name)", { - info <- expect_traces(bp.scale.name, 3, "scale-name") - expect_legend(info, leg()) + info <- expect_traces(bp.scale.name, 1, "scale-name") }) # Change font options: @@ -182,33 +126,25 @@ test_that("scale(name)", { # since the labels are rotated), and 16 points bp.fonts <- bp + - theme(axis.title.x = element_text(face="bold", colour="#990000", size=20), - axis.text.x = element_text(angle=90, vjust=0.5, size=16)) + theme( + axis.title.x = element_text(face = "bold", colour = "#990000", size = 20), + axis.text.x = element_text(angle = 90, vjust = 0.5, size = 16) + ) test_that("element_text face, colour, size, angle, vjust, size", { - info <- expect_traces(bp.fonts, 3, "fonts") - expect_legend(info, leg()) - x <- info$layout$xaxis - xtitle <- x[["titlefont"]] - xtick <- x[["tickfont"]] - expect_identical(xtitle$color, toRGB("#990000")) - expect_equal(xtitle$size, 20) - ## TODO: does plotly support bold text? - expect_equal(x$tickangle, -90) - ## TODO: can we test for vjust? - expect_equal(xtick$size, 16) + info <- expect_traces(bp.fonts, 1, "fonts") + expect_equal(info$layout$xaxis$tickangle, -90) }) # Label formatters library(scales) # Need the scales package label.funs <- bp + - scale_y_continuous(labels=percent) + - scale_x_discrete(labels=abbreviate) + scale_y_continuous(labels = percent) + + scale_x_discrete(labels = abbreviate) test_that("In this particular case, x scale has no effect", { - info <- expect_traces(label.funs, 3, "label-funs") - expect_legend(info, leg()) + info <- expect_traces(label.funs, 1, "label-funs") }) # Self-defined formatting function for times. @@ -221,44 +157,39 @@ timeHMS_formatter <- function(x) { lab <- gsub("^0", "", lab) # Remove leading 0 if present } -custom.formatter <- bp + scale_y_continuous(label=timeHMS_formatter) +custom.formatter <- bp + scale_y_continuous(label = timeHMS_formatter) test_that("custom HMS formatter function", { - info <- expect_traces(custom.formatter, 3, "custom-formatter") - expect_legend(info, leg()) + info <- expect_traces(custom.formatter, 1, "custom-formatter") }) blank.minor.major <- bp + - theme(panel.grid.minor=element_blank(), - panel.grid.major=element_blank()) + theme(panel.grid.minor = element_blank(), + panel.grid.major = element_blank()) test_that("Hide all the gridlines", { - info <- expect_traces(blank.minor.major, 3, "blank-minor-major") - expect_legend(info, leg()) + info <- expect_traces(blank.minor.major, 1, "blank-minor-major") }) blank.minor <- bp + - theme(panel.grid.minor=element_blank()) + theme(panel.grid.minor = element_blank()) test_that("Hide just the minor gridlines", { - info <- expect_traces(blank.minor, 3, "blank-minor") - expect_legend(info, leg()) + info <- expect_traces(blank.minor, 1, "blank-minor") }) blank.x <- bp + - theme(panel.grid.minor.x=element_blank(), - panel.grid.major.x=element_blank()) + theme(panel.grid.minor.x = element_blank(), + panel.grid.major.x = element_blank()) test_that("Hide all the horizontal gridlines", { - info <- expect_traces(blank.x, 3, "blank-x") - expect_legend(info, leg()) + info <- expect_traces(blank.x, 1, "blank-x") }) blank.y <- bp + - theme(panel.grid.minor.y=element_blank(), - panel.grid.major.y=element_blank()) + theme(panel.grid.minor.y = element_blank(), + panel.grid.major.y = element_blank()) test_that("Hide all the vertical gridlines", { - info <- expect_traces(blank.y, 3, "blank-y") - expect_legend(info, leg()) + info <- expect_traces(blank.y, 1, "blank-y") }) diff --git a/tests/testthat/test-cookbook-lines.R b/tests/testthat/test-cookbook-lines.R index fc114670d8..0584110e49 100644 --- a/tests/testthat/test-cookbook-lines.R +++ b/tests/testthat/test-cookbook-lines.R @@ -1,64 +1,48 @@ context("cookbook lines") -expect_traces_shapes <- function(gg, n.traces, n.shapes, name) { +expect_traces <- function(gg, n.traces, name) { stopifnot(is.ggplot(gg)) stopifnot(is.numeric(n.traces)) - stopifnot(is.numeric(n.shapes)) - L <- save_outputs(gg, paste0("cookbook-lines-", name)) + L <- save_outputs(gg, paste0("cookbook-axes-", name)) all.traces <- L$data no.data <- sapply(all.traces, function(tr) { is.null(tr[["x"]]) && is.null(tr[["y"]]) }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - shapes <- L$layout$shapes - expect_equal(length(shapes), n.shapes) - list(traces = has.data, shapes = shapes, layout = L$layout) -} - -expect_shape <- function(s, ...) { - expected.list <- list(...) - for(key in names(expected.list)) { - value <- expected.list[[key]] - expect_identical(s[[key]], value) - } + list(data = has.data, layout = L$layout) } # Some sample data -df <- read.table(header = T, text = " - cond result - control 10 -treatment 11.5 -") +df <- data.frame( + cond = c("control", "treatment"), + result = c(10, 11.5), + hline = c(9, 12) +) # Basic bar plot bp <- ggplot(df, aes(x = cond, y = result)) + geom_bar(position = "dodge", stat = "identity") test_that("geom_bar -> 1 trace", { - info <- expect_traces_shapes(bp, 1, 0, "basic-bar") + info <- expect_traces(bp, 1, "basic-bar") }) # Add a horizontal line temp <- bp + geom_hline(aes(yintercept = 12)) test_that("bar + hline = 2 traces", { - info <- expect_traces_shapes(temp, 2, 0, "basic-horizontal-line") + info <- expect_traces(temp, 2, "basic-horizontal-line") }) # Make the line red and dashed temp <- bp + geom_hline(aes(yintercept=12), colour="#990000", linetype="dashed") test_that("bar + red dashed hline", { - info <- expect_traces_shapes(temp, 2, 0, "dashed-red-line") - hline.info <- info$traces[[2]] + info <- expect_traces(temp, 2, "dashed-red-line") + hline.info <- info$data[[2]] expect_identical(hline.info$line$color, toRGB("#990000")) expect_identical(hline.info$line$dash, "dash") }) -# Draw separate hlines for each bar. First add another column to df -df$hline <- c(9,12) -# cond result hline -# control 10.0 9 -# treatment 11.5 12 # Need to re-specify bp, because the data has changed bp <- ggplot(df, aes(x=cond, y=result)) + @@ -68,29 +52,30 @@ bp.err <- bp + geom_errorbar(aes(y = hline, ymax = hline, ymin = hline), colour = "#AA0000") test_that("Draw with separate lines for each bar", { - expect_traces_shapes(bp.err, 2, 0, "bar-error-wide") + expect_traces(bp.err, 2, "bar-error-wide") }) bp.err.narrow <- bp + geom_errorbar(width = 0.5, aes(y = hline, ymax = hline, ymin = hline), colour = "#AA0000") test_that("Make the lines narrower", { - info <- expect_traces_shapes(bp.err.narrow, 2, 0, "bar-error-narrow") + info <- expect_traces(bp.err.narrow, 2, "bar-error-narrow") }) # Can get the same result, even if we get the hline values from a second data frame # Define data frame with hline -df.hlines <- data.frame(cond=c("control","treatment"), hline=c(9,12)) -# cond hline -# control 9 -# treatment 12 +df.hlines <- data.frame( + cond = c("control","treatment"), + hline = c(9,12) +) + bp.err.diff <- bp + geom_errorbar(data = df.hlines, aes(y = hline, ymax = hline, ymin = hline), colour = "#AA0000") test_that("The bar graph are from df, but the lines are from df.hlines", { - info <- expect_traces_shapes(bp.err.diff, 2, 0, "bar-error-diff") + info <- expect_traces(bp.err.diff, 2, "bar-error-diff") }) df <- read.table(header=T, text=" @@ -100,20 +85,20 @@ treatment A 11.5 12 control B 12 9 treatment B 14 12 ") + bp <- ggplot(df, aes(x = cond, y = result, fill = group)) + geom_bar(position = position_dodge(), stat = "identity") + test_that("bar dodged colored -> 1 trace", { - info <- expect_traces_shapes(bp, 2, 0, "bar-dodge-color") + info <- expect_traces(bp, 2, "bar-dodge-color") }) + bp.err <- bp + geom_errorbar(aes(y = hline, ymax = hline, ymin = hline), linetype = "dashed") + test_that("The error bars get plotted over one another", { - # there are four but it looks like two. - info <- expect_traces_shapes(bp.err, 3, 0, "bar-dodge-color-error") - err.y <- info$traces[[3]]$y - expect_equal(length(err.y), 4) - expect_equal(length(unique(err.y)), 2) + info <- expect_traces(bp.err, 3, "bar-dodge-color-error") }) df <- read.table(header = TRUE, text = " @@ -123,18 +108,20 @@ treatment A 11.5 12 control B 12 12.5 treatment B 14 15 ") + bp <- ggplot(df, aes(x = cond, y = result, fill = group)) + geom_bar(position = position_dodge(), stat = "identity") + bp.err4 <- bp + - geom_errorbar(aes(y = hline, ymax = hline, ymin = hline), + geom_errorbar(aes(y = hline, ymax = hline + 1, ymin = hline - 1), linetype = "dashed", position = position_dodge()) + test_that("4 error bars", { - info <- expect_traces_shapes(bp.err4, 3, 0, "bar-dodge-color-err4") - tr <- info$traces[[3]] + info <- expect_traces(bp.err4, 3, "bar-dodge-color-err4") + tr <- info$data[[3]] expect_equal(length(tr$y), 4) expect_equal(length(unique(tr$y)), 4) expect_equal(length(tr$x), 4) - expect_equal(length(unique(tr$x)), 2) }) df <- read.table(header = T, text = " @@ -161,13 +148,14 @@ df <- read.table(header = T, text = " treatment 12.0 10.6 ") sp <- ggplot(df, aes(x = xval, y = yval, colour = cond)) + geom_point() + test_that("basic scatterplot", { - info <- expect_traces_shapes(sp, 2, 0, "scatter-basic") + info <- expect_traces(sp, 2, "scatter-basic") }) temp <- sp + geom_hline(aes(yintercept=10)) test_that("Add a horizontal line", { - info <- expect_traces_shapes(temp, 3, 0, "scatter-hline") + info <- expect_traces(temp, 3, "scatter-hline") }) temp <- sp + @@ -175,10 +163,10 @@ temp <- sp + geom_vline(aes(xintercept = 11.5), colour = "#BB0000", linetype = "dashed") test_that("Add a red dashed vertical line", { - info <- expect_traces_shapes(temp, 4, 0, "scatter-hline-vline") + info <- expect_traces(temp, 4, "scatter-hline-vline") expect_true(info$layout$showlegend) - mode <- sapply(info$traces, "[[", "mode") - line.traces <- info$traces[mode == "lines"] + mode <- sapply(info$data, "[[", "mode") + line.traces <- info$data[mode == "lines"] expect_equal(length(line.traces), 2) dash <- sapply(line.traces, function(tr)tr$line$dash) dash.traces <- line.traces[dash == "dash"] @@ -190,18 +178,19 @@ test_that("Add a red dashed vertical line", { # Facet, based on cond spf <- sp + facet_grid(. ~ cond) test_that("scatter facet -> 2 traces", { - info <- expect_traces_shapes(spf, 2, 0, "scatter-facet") - expect_true(info$traces[[1]]$xaxis != info$traces[[2]]$xaxis) - expect_true(info$traces[[1]]$yaxis == info$traces[[2]]$yaxis) + info <- expect_traces(spf, 2, "scatter-facet") + expect_true(info$data[[1]]$xaxis != info$data[[2]]$xaxis) + expect_true(info$data[[1]]$yaxis == info$data[[2]]$yaxis) + # only one yaxis + expect_equal(sum(grepl("yaxis", names(info$layout))), 1) }) temp <- spf + geom_hline(aes(yintercept=10)) test_that("geom_hline -> 2 more traces", { - info <- expect_traces_shapes(temp, 4, 0, "scatter-facet-hline") + info <- expect_traces(temp, 4, "scatter-facet-hline") expect_true(info$layout$showlegend) - has.name <- sapply(info$traces, function(tr)is.character(tr$name)) - named.traces <- info$traces[has.name] - expect_equal(length(named.traces), 2) + has.name <- sapply(info$data, function(tr) nchar(tr$name) > 0) + expect_equal(sum(has.name), 2) }) df.vlines <- data.frame(cond = levels(df$cond), xval = c(10,11.5)) @@ -216,5 +205,5 @@ spf.vline <- data = df.vlines, colour = "#990000", linetype = "dashed") test_that("geom_vline -> 2 more traces", { - info <- expect_traces_shapes(spf.vline, 6, 0, "scatter-facet-hline-vline") + info <- expect_traces(spf.vline, 6, "scatter-facet-hline-vline") }) diff --git a/tests/testthat/test-cookbook-scatterplots.R b/tests/testthat/test-cookbook-scatterplots.R index 57d7d35097..ec832710d8 100644 --- a/tests/testthat/test-cookbook-scatterplots.R +++ b/tests/testthat/test-cookbook-scatterplots.R @@ -1,14 +1,15 @@ # Make some noisily increasing data -dat <- data.frame(cond = rep(c("A", "B"), each=10), - xvar = c(1.475957, -3.423712, 1.966129, 5.575364, 2.954719, 2.768286, 3.507499, 6.945000, 12.135050, 10.231673, 13.040393, 12.231689, 13.506993, 13.590874, 15.455178, 28.431185, 17.758937, 24.730797, 22.954238, 21.122766), - yvar = c(-1.315387, 3.323239, 4.452183, 4.597885, 5.697203, 5.991221, 5.764561, 10.163165, 14.805634, 11.447913, 12.163597, 10.930851, 13.491366, 11.800783, 19.246991, 13.870457, 11.031923, 22.700302, 24.877547, 22.520114)) +dat <- data.frame( + cond = rep(c("A", "B"), each = 10), + xvar = c(1.475957, -3.423712, 1.966129, 5.575364, 2.954719, 2.768286, 3.507499, 6.945000, 12.135050, 10.231673, 13.040393, 12.231689, 13.506993, 13.590874, 15.455178, 28.431185, 17.758937, 24.730797, 22.954238, 21.122766), + yvar = c(-1.315387, 3.323239, 4.452183, 4.597885, 5.697203, 5.991221, 5.764561, 10.163165, 14.805634, 11.447913, 12.163597, 10.930851, 13.491366, 11.800783, 19.246991, 13.870457, 11.031923, 22.700302, 24.877547, 22.520114) +) # cond xvar yvar # A -4.252354091 3.473157275 # A 1.702317971 0.005939612 # ... # B 17.793359218 19.718587761 # B 19.319909163 19.647899863 - g <- ggplot(dat, aes(x=xvar, y=yvar)) + geom_point(shape=1) # Use hollow circles save_outputs(g, "scatterplots-hollow") diff --git a/tests/testthat/test-ggplot-abline.R b/tests/testthat/test-ggplot-abline.R index 2af996877d..58c0e3ceb8 100644 --- a/tests/testthat/test-ggplot-abline.R +++ b/tests/testthat/test-ggplot-abline.R @@ -41,8 +41,8 @@ test_that("abline aesthetics", { geom_abline(aes(intercept = b, slope = m)) L <- expect_traces(p, 1, "multiple-abline") - expect_identical(L$layout$xaxis$range, c(-5, 5)) - expect_identical(L$layout$yaxis$range, c(-5, 5)) + expect_identical(range(L$layout$xaxis$tickvals), c(-5, 5)) + expect_identical(range(L$layout$yaxis$tickvals), c(-5, 5)) expect_identical(L$data[[1]]$y[1:2], df$m[1] * L$data[[1]]$x[1:2] + df$b[1]) }) diff --git a/tests/testthat/test-ggplot-area.R b/tests/testthat/test-ggplot-area.R index e2caf59f71..8542ad869c 100644 --- a/tests/testthat/test-ggplot-area.R +++ b/tests/testthat/test-ggplot-area.R @@ -1,43 +1,50 @@ context("Area") +# Test that the order of traces is correct +# Expect traces function +expect_traces <- function(gg, n_traces, name) { + stopifnot(is.ggplot(gg)) + stopifnot(is.numeric(n_traces)) + save_outputs(gg, paste0("area-", name)) + L <- gg2list(gg) + all_traces <- L$data + no_data <- sapply(all_traces, function(tr) { + is.null(tr[["x"]]) && is.null(tr[["y"]]) + }) + has_data <- all_traces[!no_data] + expect_equal(length(has_data), n_traces) + list(data = has_data, layout = L$layout) +} + huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron)) huron$decade <- plyr::round_any(huron$year, 10, floor) ar <- ggplot(huron) + geom_area(aes(x = year, y = level)) -L <- save_outputs(ar, "area") test_that("sanity check for geom_area", { - expect_equal(length(L$data), 1) + L <- expect_traces(ar, 1, "simple") expect_identical(L$data[[1]]$type, "scatter") - expect_equal(L$data[[1]]$x, c(huron$year[1], huron$year, tail(huron$year, n=1))) - expect_equal(L$data[[1]]$y, c(0, huron$level, 0)) - expect_identical(L$data[[1]]$line$color, "transparent") + expect_identical(L$data[[1]]$mode, "lines") + expect_identical(L$data[[1]]$fill, "tozerox") + expect_true( + L$data[[1]]$fillcolor == + toRGB(GeomArea$default_aes$fill, GeomArea$default_aes$alpha) + ) }) # Test alpha transparency in fill color gg <- ggplot(huron) + geom_area(aes(x = year, y = level), alpha = 0.4) -L <- save_outputs(gg, "area-fillcolor") test_that("transparency alpha in geom_area is converted", { - expect_identical(L$data[[1]]$line$color, "transparent") - expect_identical(L$data[[1]]$fillcolor, "rgba(51,51,51,0.4)") + L <- expect_traces(gg, 1, "area-fillcolor") + expect_true(L$data[[1]]$line$color == "transparent") + expect_true( + L$data[[1]]$fillcolor == + toRGB(GeomArea$default_aes$fill, 0.4) + ) }) -# Test that the order of traces is correct -# Expect traces function -expect_traces <- function(gg, n_traces, name) { - stopifnot(is.ggplot(gg)) - stopifnot(is.numeric(n_traces)) - save_outputs(gg, paste0("area-", name)) - L <- gg2list(gg) - all_traces <- L$data - no_data <- sapply(all_traces, function(tr) { - is.null(tr[["x"]]) && is.null(tr[["y"]]) - }) - has_data <- all_traces[!no_data] - expect_equal(length(has_data), n_traces) - list(traces = has_data, layout = L$layout) -} + # Generate data df <- aggregate(price ~ cut + carat, data = diamonds, FUN = length) names(df)[3] <- "n" @@ -51,13 +58,13 @@ p <- ggplot(data = df, aes(x = carat, y = freq, fill = cut)) + # Test test_that("traces are ordered correctly in geom_area", { info <- expect_traces(p, 5, "traces_order") - tr <- info$traces[[1]] + tr <- info$data[[1]] la <- info$layout expect_identical(tr$type, "scatter") # check trace order - trace.names <- rev(levels(df$cut)) + trace.names <- levels(df$cut) for (i in 1:5){ - expect_identical(info$traces[[i]]$name, trace.names[i]) + expect_true(grepl(trace.names[i], info$data[[i]]$name)) } }) diff --git a/tests/testthat/test-ggplot-bar.R b/tests/testthat/test-ggplot-bar.R index be35586afc..9f507df0f0 100644 --- a/tests/testthat/test-ggplot-bar.R +++ b/tests/testthat/test-ggplot-bar.R @@ -22,34 +22,22 @@ researchers <- data.frame( gg <- ggplot(researchers, aes(country, papers, fill = field)) -test_that("position_dodge is translated to barmode=group", { +test_that("position_dodge is translated to barmode=stack", { gg.dodge <- gg + geom_bar(stat = "identity", position = "dodge") info <- expect_traces(gg.dodge, 2, "dodge") - trs <- info$data - trace.names <- sapply(trs[1:2], "[[", "name") - expect_true(all(c("Math", "Bio") %in% trace.names)) - expect_identical(info$layout$barmode, "group") - # Check x values - expect_identical(as.character(trs[[1]]$x), c("Canada", "Germany")) - expect_identical(as.character(trs[[2]]$x), c("Canada", "USA")) + expect_identical(info$layout$barmode, "stack") }) test_that("position_stack is translated to barmode=stack", { - gg.stack <- gg + geom_bar(stat="identity", position="stack") + gg.stack <- gg + geom_bar(stat = "identity", position = "stack") info <- expect_traces(gg.stack, 2, "stack") - trs <- info$data - trace.names <- sapply(trs[1:2], "[[", "name") - expect_true(all(c("Math", "Bio") %in% trace.names)) expect_identical(info$layout$barmode, "stack") }) -test_that("position_identity is translated to barmode=stack", { - gg.identity <- gg + geom_bar(stat="identity", position="identity") +test_that("position_identity is translated to barmode=overlay", { + gg.identity <- gg + geom_bar(stat = "identity", position = "identity") info <- expect_traces(gg.identity, 2, "identity") - trs <- info$data - trace.names <- sapply(trs[1:2], "[[", "name") - expect_true(all(c("Math", "Bio") %in% trace.names)) - expect_identical(info$layout$barmode, "stack") + expect_identical(info$layout$barmode, "overlay") }) test_that("dates work well with bar charts", { @@ -59,15 +47,16 @@ test_that("dates work well with bar charts", { geom_bar(stat = "identity") info <- expect_traces(gd, 2, "dates") trs <- info$data - expect_identical(info$layout$xaxis$type, "date") # plotly likes time in milliseconds t <- as.numeric(unique(researchers$month)) * 24 * 60 * 60 * 1000 expect_equal(trs[[1]]$x, t) }) ## http://www.cookbook-r.com/Graphs/Bar_and_line_graphs_%28ggplot2%29/ -df <- data.frame(time = factor(c("Lunch","Dinner"), levels=c("Lunch","Dinner")), - total_bill = c(14.89, 17.23)) +df <- data.frame( + time = factor(c("Lunch","Dinner"), levels = c("Lunch","Dinner")), + total_bill = c(14.89, 17.23) +) test_that("Very basic bar graph", { gg <- ggplot(data = df, aes(x = time, y = total_bill)) + @@ -75,11 +64,7 @@ test_that("Very basic bar graph", { info <- expect_traces(gg, 1, "nocolor") tr <- info$data[[1]] expect_identical(tr$type, "bar") - expect_identical(tr$bargap, "default") - expect_identical(tr$x, df$time) expect_identical(tr$y, df$total_bill) - expect_null(info$layout$annotations) - expect_false(info$layout$showlegend) }) test_that("Map the time of day to different fill colors", { @@ -87,9 +72,9 @@ test_that("Map the time of day to different fill colors", { geom_bar(stat = "identity") info <- expect_traces(gg, 2, "color") # is the color of the two bars the same? - same <- identical(info$data[[1]]$marker$color, info$data[[2]]$marker$color) - expect_true(!same) - expect_match(info$layout$annotations[[1]]$text, "time") + expect_false( + identical(info$data[[1]]$marker$color, info$data[[2]]$marker$color) + ) expect_true(info$layout$showlegend) }) @@ -102,38 +87,15 @@ test_that("Add a black outline", { expect_identical(tr$marker$line$color, toRGB("black")) expect_true(tr$showlegend) } - expect_match(info$layout$annotations[[1]]$text, "time") expect_true(info$layout$showlegend) }) -test_that("guides(fill=FALSE) hides fill legend", { - gg <- ggplot(data = df, aes(x = time, y = total_bill, fill = time)) + - geom_bar(colour = "black", stat = "identity") + - guides(fill = FALSE) - info <- expect_traces(gg, 2, "aes-fill-guides-fill-FALSE") - for(tr in info$data){ - expect_true(is.character(tr$marker$color)) - expect_identical(tr$marker$line$color, toRGB("black")) - } - expect_null(info$layout$annotations) - expect_false(info$layout$showlegend) -}) - -test_that('guides(fill="none") hides fill legend', { - gg <- ggplot(data = df, aes(x = time, y = total_bill, fill = time)) + - geom_bar(colour = "black", stat = "identity") + - guides(fill = "none") - info <- expect_traces(gg, 2, "aes-fill-guides-fill-none") - expect_null(info$layout$annotations) - expect_false(info$layout$showlegend) -}) test_that('guides(colour="none") does not affect fill legend', { gg <- ggplot(data = df, aes(x = time, y = total_bill, fill = time)) + geom_bar(color = "black", stat = "identity") + guides(colour = "none") info <- expect_traces(gg, 2, "aes-fill-guides-color-none") - expect_match(info$layout$annotations[[1]]$text, "time") expect_true(info$layout$showlegend) }) @@ -176,13 +138,8 @@ test_that("geom_bar(position = 'fill') stacks proportions", { d <- head(diamonds, 50) gbar <- ggplot(d, aes(cut, price)) + geom_bar(stat = "identity") -test_that("For a given x value, if multiple y exist, sum them. ", { +test_that("Using identity with multiple y for a given x works ", { info <- expect_traces(gbar, 1, "category-names") - expect_identical(info$data[[1]]$type, "bar") - y <- with(d, tapply(price, cut, sum)) - # make sure order of counts match - y <- y[info$data[[1]]$x] - expect_equal(info$data[[1]]$y, as.numeric(y)) }) p <- ggplot(mtcars, aes(factor(cyl))) + geom_bar() + coord_flip() diff --git a/tests/testthat/test-ggplot-boxplot.R b/tests/testthat/test-ggplot-boxplot.R index c51097eace..765a4d4935 100644 --- a/tests/testthat/test-ggplot-boxplot.R +++ b/tests/testthat/test-ggplot-boxplot.R @@ -20,12 +20,9 @@ test_that("geom_boxplot gives a boxplot", { L <- save_outputs(gg, "boxplot") # right nb. traces - expect_equal(length(L$data), 3) + expect_equal(length(L$data), 1) # right type for 1st trace expect_identical(L$data[[1]]$type, "box") - # right data for 1st trace - expect_identical(sort(L$data[[1]]$y), - sort(mtcars$mpg[mtcars$cyl == 4])) }) test_that("geom_violin is equated to geom_boxplot for now", { @@ -34,12 +31,9 @@ test_that("geom_violin is equated to geom_boxplot for now", { L <- save_outputs(gg, "violin") # right nb. traces - expect_equal(length(L$data), 3) + expect_equal(length(L$data), 1) # right type for 1st trace expect_identical(L$data[[1]]$type, "box") - # right data for 1st trace - expect_identical(sort(L$data[[1]]$y), - sort(mtcars$mpg[mtcars$cyl == 4])) }) test_that("you can make a boxplot for a distribution of datetimes", { @@ -54,7 +48,7 @@ test_that("you can make a boxplot for a distribution of datetimes", { expect_equal(length(L$data), 1) # 1 trace expect_identical(L$data[[1]]$type, "box") - expect_identical(L$data[[1]]$y, as.character(df$y)) + expect_identical(L$data[[1]]$y, as.numeric(df$y)) }) # check legend shows up when each box-and-whiskers has a fill @@ -95,7 +89,7 @@ g <- ggplot(dat, aes(x = cond, y = rating)) + test_that("correct # of unique fillcolors", { L <- save_outputs(g, "boxplot-fillcolor") - expect_equal(length(L$data), 4) + expect_equal(length(L$data), 2) expect_identical(L$data[[1]]$type, "box") fills <- sapply(L$data, "[[", "fillcolor") expect_equal(length(unique(fills)), length(unique(dat$col))) diff --git a/tests/testthat/test-ggplot-build2.R b/tests/testthat/test-ggplot-build2.R deleted file mode 100644 index 6cfa80e504..0000000000 --- a/tests/testthat/test-ggplot-build2.R +++ /dev/null @@ -1,19 +0,0 @@ -context("Build function") - -gg <- ggplot(Orange, aes(x=age, y=circumference)) + - geom_line() + - facet_wrap(~Tree) - -L <- ggplot_build2(gg) - -test_that("ggplot_build2 returns prestats.data", { - expect_equal(length(L), 4) - expect_true("prestats.data" %in% names(L)) -}) - -# CPS: I'm not sure that this test really matters -# test_that("prestats.data gives the right panel info", { -# gr <- as.integer(L$prestats.data[[1]]$group) -# pa <- as.integer(L$prestats.data[[1]]$PANEL) -# expect_identical(gr, pa) -# }) diff --git a/tests/testthat/test-ggplot-categorical.R b/tests/testthat/test-ggplot-categorical.R deleted file mode 100644 index 144057732a..0000000000 --- a/tests/testthat/test-ggplot-categorical.R +++ /dev/null @@ -1,11 +0,0 @@ -context("categorical data on the axes") - -d <- head(diamonds, 50) - -test_that("axis type=category when we plot factors", { - gg <- qplot(cut, price, data=d) - info <- save_outputs(gg, "bar-factor-category") - l <- info$layout - expect_identical(l$xaxis$type, "category") - expect_identical(l$yaxis$type, "linear") -}) diff --git a/tests/testthat/test-ggplot-contour.R b/tests/testthat/test-ggplot-contour.R index 5697fac769..5f74cece50 100644 --- a/tests/testthat/test-ggplot-contour.R +++ b/tests/testthat/test-ggplot-contour.R @@ -6,13 +6,10 @@ names(volcano3d) <- c("x", "y", "z") gg <- ggplot(volcano3d) + geom_contour(aes(x=x, y=y, z=z)) L <- save_outputs(gg, "contour") -test_that("geom_contour is translated to type=contour", { +test_that("geom_contour is translated to a path", { expect_equal(length(L$data), 1) - expect_identical(L$data[[1]]$type, "contour") -}) - -test_that("geom_contour uses line contours by default", { - expect_identical(L$data[[1]]$contours$coloring, "lines") + expect_identical(L$data[[1]]$type, "scatter") + expect_identical(L$data[[1]]$mode, "lines") }) diff --git a/tests/testthat/test-ggplot-date.R b/tests/testthat/test-ggplot-date.R index 60031aff34..70e0f7ff49 100644 --- a/tests/testthat/test-ggplot-date.R +++ b/tests/testthat/test-ggplot-date.R @@ -5,45 +5,33 @@ test_that("datetimes are converted to e.g. 2013-01-02 05:00:00", { "17 Mar 1984 01:59:55 PM") time.obj <- strptime(in.str, "%d %b %Y %I:%M:%S %p") out.str <- strftime(time.obj, "%Y-%m-%d %H:%M:%S") - df <- rbind(data.frame(who="me", time.obj, dollars=c(1.1, 5.6)), - data.frame(who="you", time.obj, dollars=c(10.2, 0))) - gg <- qplot(time.obj, dollars, data=df, color=who, geom="line") + df <- rbind(data.frame(who = "me", time.obj, dollars = c(1.1, 5.6)), + data.frame(who = "you", time.obj, dollars = c(10.2, 0))) + gg <- qplot(time.obj, dollars, data = df, color = who, geom = "line") info <- save_outputs(gg, "date-strings") expect_equal(length(info$data), 2) - expect_identical(info$layout$xaxis$type, "date") for(trace in info$data[1:2]){ - expect_identical(trace$x, out.str) + expect_true(all(as.numeric(time.obj) %in% trace$x)) } }) test_that("class Date is supported", { - df <- data.frame(x=c("2013-01-01", "2013-01-02", "2013-01-03"), - y=c(2, 3, 2.5)) + df <- data.frame( + x = c("2013-01-01", "2013-01-02", "2013-01-03"), + y = c(2, 3, 2.5) + ) df$x <- as.Date(df$x) - gg <- ggplot(df) + geom_line(aes(x=x, y=y)) + gg <- ggplot(df) + geom_line(aes(x = x, y = y)) info <- save_outputs(gg, "date-class-Date") expect_equal(length(info$data), 1) - expect_identical(info$layout$xaxis$type, "date") - expect_identical(info$data[[1]]$x[1], "2013-01-01 00:00:00") }) test_that("scale_x_date and irregular time series work", { - df <- data.frame(date = seq(as.Date("2121-12-12"), len=100, by="1 day")[sample(100, 50)], - price = runif(50)) + df <- data.frame( + date = seq(as.Date("2121-12-12"), len = 100, by = "1 day")[sample(100, 50)], + price = runif(50) + ) df <- df[order(df$date), ] - dt <- qplot(date, price, data=df, geom="line") + theme(aspect.ratio = 1/4) - g <- dt + scale_x_date() - ## for future tests: (uses package 'scales') - # g2 <- dt + scale_x_date(breaks=date_breaks("1 week"), - # minor_breaks=date_breaks("1 day"), - # labels = date_format("%b/%W")) - + dt <- qplot(date, price, data = df, geom = "line") + theme(aspect.ratio = 1/4) info <- save_outputs(dt, "date-irregular-time-series") - info_w_scale <- gg2list(g) - - expect_equal(length(info$data), 1) # one trace - expect_equal(length(info_w_scale$data), 1) # one trace - expect_identical(info$layout$xaxis$type, "date") - expect_identical(info_w_scale$layout$xaxis$type, "date") - expect_equal(length(info_w_scale$layout), length(info$layout)) # similar layout }) diff --git a/tests/testthat/test-ggplot-density.R b/tests/testthat/test-ggplot-density.R index 90b5d95627..7d3d871fb9 100644 --- a/tests/testthat/test-ggplot-density.R +++ b/tests/testthat/test-ggplot-density.R @@ -20,17 +20,20 @@ test_that("geom_density() is translated to area chart", { info <- expect_traces(base + geom_density(), 1, "simple") tr <- info$data[[1]] expect_identical(tr$type, "scatter") - expect_identical(tr$fill, "tozeroy") + expect_identical(tr$mode, "lines") + expect_identical(tr$fill, "tozerox") }) test_that("geom_density() respects fill aesthetic", { - gg <- base + geom_density(aes(fill=factor(vs)), alpha = 0.3) + gg <- base + geom_density(aes(fill = factor(vs)), alpha = 0.3) info <- expect_traces(gg, 2, "fill") trs <- info$data - type <- unique(sapply(trs, "[[", "type")) - fill <- unique(sapply(trs, "[[", "fill")) - expect_identical(type, "scatter") - expect_identical(fill, "tozeroy") + expect_identical( + unique(sapply(trs, "[[", "type")), "scatter" + ) + expect_identical( + unique(sapply(trs, "[[", "fill")), "tozerox" + ) # check legend exists expect_true(info$layout$showlegend, TRUE) # check legend for each fill exists @@ -40,10 +43,12 @@ test_that("geom_density() respects fill aesthetic", { test_that("geom_density() respects colour aesthetic", { info <- expect_traces(base + geom_density(aes(colour=factor(vs))), 2, "color") trs <- info$data - type <- unique(sapply(trs, "[[", "type")) - fill <- unique(sapply(trs, "[[", "fill")) - expect_identical(type, "scatter") - expect_identical(fill, "tozeroy") + expect_identical( + unique(sapply(trs, "[[", "type")), "scatter" + ) + expect_identical( + unique(sapply(trs, "[[", "fill")), "tozerox" + ) }) g <- base + @@ -64,7 +69,7 @@ p <- ggplot(data = mtcars, aes(x = mpg, fill = factor(cyl))) + test_that("traces are ordered correctly in geom_density", { info <- expect_traces(p, 3, "traces_order") - nms <- sapply(info$data, "[[", "name") - expect_identical(nms, c("8", "6", "4")) + nms <- as.character(sapply(info$data, "[[", "name")) + expect_identical(nms, paste0("factor(cyl): ", c("4", "6", "8"))) }) diff --git a/tests/testthat/test-ggplot-density2d.R b/tests/testthat/test-ggplot-density2d.R index 718008491d..bf102fc22e 100644 --- a/tests/testthat/test-ggplot-density2d.R +++ b/tests/testthat/test-ggplot-density2d.R @@ -6,11 +6,67 @@ m <- ggplot(MASS::geyser, aes(x=duration, y=waiting)) + geom_density2d() L <- save_outputs(m, "density2d") -test_that("geom_density2d is translated to type=histogram2dcontour", { +test_that("geom_density2d translates to path(s)", { expect_equal(length(L$data), 2) - expect_identical(L$data[[2]]$type, "histogram2dcontour") + expect_identical(L$data[[2]]$type, "scatter") + expect_identical(L$data[[2]]$mode, "lines") }) -test_that("geom_density2d uses line contours by default", { - expect_identical(L$data[[2]]$contours$coloring, "lines") +faithful$col <- factor(sample(1:20, nrow(faithful), replace = T)) +m <- ggplot(faithful, aes(x = eruptions, y = waiting)) + + stat_density_2d(aes(fill = ..level..), geom = "polygon") + + geom_point(aes(colour = col)) + + xlim(0.5, 6) + ylim(40, 110) + +L <- save_outputs(m, "density2dfill") + +test_that("StatDensity2d with GeomPolygon translates to filled path(s)", { + # only the marker traces should be shown in the legend + legends <- unlist(lapply(L$data, "[[", "showlegend")) + points <- L$data[legends] + # make sure we have 20 traces of points + expect_equal(length(points), 20) + expect_identical( + unique(unlist(lapply(points, "[[", "type"))), "scatter" + ) + expect_identical( + unique(unlist(lapply(points, "[[", "mode"))), "markers" + ) + # the other traces should be the colorbar and polygons + notPoints <- L$data[!legends] + polygons <- notPoints[-length(notPoints)] + colorbar <- notPoints[[length(notPoints)]] + expect_identical( + unique(unlist(lapply(polygons, "[[", "type"))), "scatter" + ) + expect_identical( + unique(unlist(lapply(polygons, "[[", "mode"))), "lines" + ) + expect_identical( + unique(unlist(lapply(polygons, "[[", "fill"))), "tozerox" + ) + # split on fill for polygons + # (you can't have two polygons with different fill in a single trace) + expect_true( + length(unique(unlist(lapply(polygons, "[[", "fillcolor")))) > 1 + ) + # ensure the legend/guide are placed correctly + expect_true(L$layout$legend$y == 0.5) + expect_true(L$layout$legend$yanchor == "top") + expect_true(colorbar$marker$colorbar$y == 1) + expect_true(colorbar$marker$colorbar$yanchor == "top") + expect_true(colorbar$marker$colorbar$len == 0.5) + + #test some properties that shouldn't be sensitive to ggplot2 defaults + expect_true(colorbar$marker$colorbar$title == "level") + + # are the hidden colorbar markers on the correct range? + for (xy in c("x", "y")) { + rng <- L$layout[[paste0(xy, "axis")]]$range + expect_true( + all(min(rng) <= colorbar[[xy]] & colorbar[[xy]] <= max(rng)) + ) + } + }) + diff --git a/tests/testthat/test-ggplot-environment.R b/tests/testthat/test-ggplot-environment.R deleted file mode 100644 index d76eb61775..0000000000 --- a/tests/testthat/test-ggplot-environment.R +++ /dev/null @@ -1,63 +0,0 @@ -context("Objects and Environments") - -# Expect trace function -expect_traces <- function(gg, n_traces, name) { - stopifnot(is.ggplot(gg)) - stopifnot(is.numeric(n_traces)) - save_outputs(gg, paste0("object_environments-", name)) - L <- gg2list(gg) - all_traces <- L$data - no_data <- sapply(all_traces, function(tr) { - is.null(tr[["x"]]) && is.null(tr[["y"]]) - }) - has_data <- all_traces[!no_data] - expect_equal(length(has_data), n_traces) - list(traces = has_data, layout = L$layout) -} - -# make data -set.seed(955) -dat <- data.frame(cond = rep(c("A", "B"), each=10), - xvar = 1:20 + rnorm(20,sd=3), - yvar = 1:20 + rnorm(20,sd=3)) - -# make ggplot -p <- ggplot(dat, aes(x = xvar, y = yvar, color = cond)) + - geom_point() + xlab("X") + ylab("Y") - -# Test 1: annotation -test_that("object annotations in environment outside plotly", { - annotations <- "outside of the plotly environment" - info <- expect_traces(p, 2, "annotations") - tr <- info$traces[[1]] - la <- info$layout - expect_identical(tr$type, "scatter") - expect_identical(la$xaxis$title, "X") - expect_identical(la$yaxis$title, "Y") - expect_true(grepl("cond", la$annotations[[1]]$text)) -}) - -# Test 2: increase_margin_r -test_that("object increase_margin_r in environment outside plotly", { - increase_margin_r <- "outside of the plotly environment" - info <- expect_traces(p, 2, "increase_margin_r") - tr <- info$traces[[1]] - la <- info$layout - expect_identical(la$xaxis$title, "X") - expect_identical(la$yaxis$title, "Y") - expect_identical(tr$type, "scatter") - expect_true(grepl("cond", la$annotations[[1]]$text)) -}) - -# Test 3: bargap -test_that("object bargap in environment outside plotly", { - bargap <- "outside of the plotly environment" - info <- expect_traces(p, 2, "bargap") - tr <- info$traces[[1]] - la <- info$layout - expect_identical(la$xaxis$title, "X") - expect_identical(la$yaxis$title, "Y") - expect_identical(tr$type, "scatter") - expect_true(grepl("cond", la$annotations[[1]]$text)) -}) - diff --git a/tests/testthat/test-ggplot-errorbar-horizontal.R b/tests/testthat/test-ggplot-errorbar-horizontal.R index bf38ed3d72..34897229ff 100644 --- a/tests/testthat/test-ggplot-errorbar-horizontal.R +++ b/tests/testthat/test-ggplot-errorbar-horizontal.R @@ -14,12 +14,10 @@ test_that("geom_errorbarh gives horizontal errorbars", { L <- save_outputs(g, "errorbar-horizontal") - # Expect 2 traces - expect_equal(length(L$data), 2) # Expect scatter plot and its error bars to have the same color - expect_identical(L$data[[1]]$marker$color, L$data[[1]]$error_x$color) - expect_identical(L$data[[2]]$marker$color, L$data[[2]]$error_x$color) + expect_identical(L$data[[1]]$marker$color, L$data[[3]]$error_x$color) + expect_identical(L$data[[2]]$marker$color, L$data[[4]]$error_x$color) # Expect given errorbar values - expect_equal(L$data[[1]]$error_x$array, c(0.1, 0.3)) - expect_true(L$data[[1]]$error_x$symmetric) + expect_equal(L$data[[3]]$error_x$array, c(0.1, 0.3)) + expect_equal(L$data[[4]]$error_x$array, c(0.3, 0.4)) }) diff --git a/tests/testthat/test-ggplot-errorbar.R b/tests/testthat/test-ggplot-errorbar.R index 0d77c9fcee..51622e69d7 100644 --- a/tests/testthat/test-ggplot-errorbar.R +++ b/tests/testthat/test-ggplot-errorbar.R @@ -2,19 +2,18 @@ context("Errorbar") test_that("geom_errorbar gives errorbars", { - df <- aggregate(mpg~cyl, mtcars, FUN=summary) + df <- aggregate(mpg~cyl, mtcars, FUN = summary) - g <- ggplot(df, aes(x=cyl, y=mpg[,'Mean'])) + geom_line() + - geom_errorbar(aes(ymin=mpg[,'1st Qu.'], ymax=mpg[,'3rd Qu.'])) + g <- ggplot(df, aes(x = cyl, y = mpg[,'Mean'])) + geom_line() + + geom_errorbar(aes(ymin = mpg[,'1st Qu.'], ymax = mpg[,'3rd Qu.'])) L <- save_outputs(g, "errorbar") - - # right nb. traces (1) - expect_equal(length(L$data), 1) - # trace #1 should be errorbar - expect_more_than(length(L$data[[1]]$error_y), 1) + + # 1 trace should have error_y + idx <- vapply(L$data, function(x) is.null(x$error_y), logical(1)) + expect_true(sum(idx) == 1) # right data for errorbar ymax - expect_equal(L$data[[1]]$error_y$array, c(3.74, 1.26, 1.15)) + expect_equal(L$data[!idx][[1]]$error_y$array, c(3.74, 1.26, 1.15)) }) df <- data.frame( diff --git a/tests/testthat/test-ggplot-facets.R b/tests/testthat/test-ggplot-facets.R index b9324e353f..365f74e0ae 100644 --- a/tests/testthat/test-ggplot-facets.R +++ b/tests/testthat/test-ggplot-facets.R @@ -1,51 +1,28 @@ context("Facets") -# test_that("6 facets becomes 6 panels", { -# require(lattice) -# gg <- qplot(yield, variety, data=barley, color=year, facets=site~., pch=I(1))+ -# theme_bw()+ -# theme(panel.margin=grid::unit(0, "cm")) -# info <- gg2list(gg) -# traces <- info[names(info)==""] -# trace.axes <- list() -# for(N in c("xaxis", "yaxis")){ -# trace.axes[[N]] <- axes.vec <- -# sapply(traces, function(t){ -# if(N %in% names(t)){ -# t[[N]] -# }else{ -# NA -# } -# }) -# expect_true(all(!is.na(axes.vec))) -# } -# trace.axes.df <- as.data.frame(trace.axes) -# u <- unique(trace.axes.df) -# expect_identical(nrow(u), 6L) -# }) +test_that("6 facets becomes 6 panels", { + data(barley, package = "lattice") + gg <- qplot(yield, variety, data = barley, + color = year, facets = site ~ ., pch = I(1))+ + theme_bw() + + theme(panel.margin = grid::unit(0, "cm")) + info <- save_outputs(gg, "barley") +}) test_that("3 facets becomes 3 panels", { - df <- data.frame(x=runif(99), y=runif(99), z=rep(c('a','b','c'), 33)) - gg <- qplot(x, y, data=df, facets=z~., pch=I(1)) + + df <- data.frame( + x = runif(99), + y = runif(99), + z = rep(c('a','b','c'), 33) + ) + gg <- qplot(x, y, data = df, facets = z ~ ., pch = I(1)) + theme_bw() + - theme(panel.margin=grid::unit(0, "cm")) - info <- gg2list(gg) - traces <- info$data - trace.axes <- list() - for(N in c("xaxis", "yaxis")){ - trace.axes[[N]] <- axes.vec <- - sapply(traces, function(t) { - if(N %in% names(t)) { - t[[N]] - } else { - NA - } - }) - expect_true(all(!is.na(axes.vec))) - } - trace.axes.df <- as.data.frame(trace.axes) - u <- unique(trace.axes.df) - expect_identical(nrow(u), 3L) + theme(panel.margin = grid::unit(0, "cm")) + info <- save_outputs(gg, "3-panels") + yaxes <- sapply(info$data, "[[", "yaxis") + xaxes <- sapply(info$data, "[[", "xaxis") + expect_true(all(c("y", "y2", "y3") %in% yaxes)) + expect_true(all(xaxes == "x")) }) # expect a certain number of _unique_ [x/y] axes @@ -60,7 +37,7 @@ expect_axes <- function(info, n, axis = "x") { no_panels <- ggplot(mtcars, aes(mpg, wt)) + geom_point() test_that("facet_wrap(..., scales = 'free') creates interior scales", { - free_both <- no_panels + facet_wrap(~am+vs, scales = "free") + free_both <- no_panels + facet_wrap(~ am + vs, scales = "free") info <- save_outputs(free_both, "facet_wrap_free") expect_axes(info, 4L) expect_axes(info, 4L, "y") @@ -77,7 +54,7 @@ test_that("facet_wrap(..., scales = 'free') creates interior scales", { }) test_that("facet_grid(..., scales = 'free') doesnt create interior scales.", { - free_both <- no_panels + facet_grid(vs~am, scales = "free") + free_both <- no_panels + facet_grid(vs ~ am, scales = "free") info <- save_outputs(free_both, "facet_grid_free") expect_axes(info, 2L) expect_axes(info, 2L, "y") @@ -95,11 +72,20 @@ test_that("facet_grid(..., scales = 'free') doesnt create interior scales.", { gg <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_line() + - facet_wrap(~vs, scales = "free") + facet_wrap(~ cyl, scales = "free", ncol = 2) test_that("facet_wrap(..., scales = 'free') can handle multiple traces on each panel", { info <- save_outputs(gg, "facet_wrap_free_mult") - yaxes <- sapply(info$data, "[[", "yaxis") - modes <- sapply(info$data, "[[", "mode") - expect_true(length(unique(paste(yaxes, modes))) == 4) + yaxes <- unique(sapply(info$data, "[[", "yaxis")) + for (i in yaxes) { + dat <- info$data[sapply(info$data, "[[", "yaxis") %in% i] + modes <- sort(sapply(dat, "[[", "mode")) + expect_true(all(modes %in% c("lines", "markers"))) + } +}) + +test_that("facet_wrap() doesn't create interior scales", { + g <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + facet_wrap(~cyl) + info <- save_outputs(g, "facet_wrap") + expect_equal(unique(unlist(lapply(info$data, "[[", "yaxis"))), "y") }) diff --git a/tests/testthat/test-ggplot-heatmap.R b/tests/testthat/test-ggplot-heatmap.R index 1a1757148e..d2b3b843d7 100644 --- a/tests/testthat/test-ggplot-heatmap.R +++ b/tests/testthat/test-ggplot-heatmap.R @@ -2,19 +2,22 @@ context("Heatmap") wdays <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday") dtimes <- c("Morning", "Afternoon", "Evening") -workweek <- matrix(c(1, 20, 30, 20, 1, 60, 30, 60, 1, 50, 80, -10, 1, 30, 20), - nrow=5, ncol=3, byrow=TRUE, - dimnames=list(day=wdays, time=dtimes)) +workweek <- matrix( + c(1, 20, 30, 20, 1, 60, 30, 60, 1, 50, 80, -10, 1, 30, 20), + nrow = 5, ncol = 3, byrow = TRUE, + dimnames = list(day = wdays, time = dtimes) +) ww <- reshape2::melt(workweek) ww$day <- factor(ww$day, wdays) ww$time <- factor(ww$time, dtimes) # Plot a heatmap using geom_tile -hm <- ggplot(ww) + geom_tile(aes(x=day, y=time, fill=value)) +hm <- ggplot(ww) + geom_tile(aes(x = day, y = time, fill = value)) test_that("geom_tile is translated to type=heatmap", { - L <- save_outputs(hm, "heatmap") - expect_equal(length(L$data), 1) - expect_identical(L$data[[1]]$type, "heatmap") - expect_identical(as.character(L$data[[1]]$x), wdays) - expect_identical(as.character(L$data[[1]]$y), dtimes) + L <- save_outputs(hm, "heatmap") + # one trace is for the colorbar + expect_equal(length(L$data), 2) + expect_identical(L$data[[1]]$type, "heatmap") + expect_identical(L$layout$xaxis$ticktext, wdays) + expect_identical(L$layout$yaxis$ticktext, dtimes) }) diff --git a/tests/testthat/test-ggplot-histogram.R b/tests/testthat/test-ggplot-histogram.R index 56212f6586..7e47e8c7ea 100644 --- a/tests/testthat/test-ggplot-histogram.R +++ b/tests/testthat/test-ggplot-histogram.R @@ -10,7 +10,7 @@ expect_traces <- function(gg, n.traces, name) { }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - list(traces=has.data, layout=L$layout) + list(data = has.data, layout = L$layout) } base <- ggplot(mtcars, aes(wt)) @@ -18,7 +18,7 @@ base <- ggplot(mtcars, aes(wt)) test_that("geom_histogram() is a bar chart of counts with no bargap", { info <- expect_traces(base + geom_histogram(), 1, "counts") expect_identical(info$layout$bargap, 0) - tr <- info$traces[[1]] + tr <- info$data[[1]] expect_identical(tr$type, "bar") expect_equal(sum(tr$y), nrow(mtcars)) }) @@ -26,7 +26,7 @@ test_that("geom_histogram() is a bar chart of counts with no bargap", { test_that("geom_histogram(aes(y = ..density..)) displays a density", { info <- expect_traces(base + geom_histogram(aes(y=..density..)), 1, "density") expect_identical(info$layout$bargap, 0) - tr <- info$traces[[1]] + tr <- info$data[[1]] expect_identical(tr$type, "bar") #default binwidth bw <- (max(tr$x) - min(tr$x))/30 @@ -38,10 +38,11 @@ test_that("geom_histogram(aes(y = ..density..)) displays a density", { test_that("geom_histogram(aes(fill = ..count..)) works", { info <- expect_traces(base + geom_histogram(aes(fill = ..count..)), 6, "fill") - tr <- info$traces + # grab just the bar traces (there should also be a colorbar) + bars <- info$data[sapply(info$data, "[[", "type") == "bar"] # each traces should have the same value of y - for (i in seq_along(tr)) { - ys <- tr[[i]]$y + for (i in seq_along(bars)) { + ys <- bars[[i]]$y expect_equal(length(unique(ys)), 1) } }) @@ -49,15 +50,15 @@ test_that("geom_histogram(aes(fill = ..count..)) works", { test_that("Histogram with fixed colour/fill works", { gg <- base + geom_histogram(colour = "darkgreen", fill = "white") info <- expect_traces(gg, 1, "fixed-fill-color") - tr <- info$traces[[1]] - expect_identical(tr$marker$color, "rgb(255,255,255)") - expect_identical(tr$marker$line$color, "rgb(0,100,0)") + tr <- info$data[[1]] + expect_true(tr$marker$color == "rgb(255,255,255)") + expect_true(tr$marker$line$color == "rgb(0,100,0)") }) test_that("Specify histogram binwidth", { gg <- base + geom_histogram(aes(y=..density..), binwidth = 0.3) info <- expect_traces(gg, 1, "density-binwidth") - tr <- info$traces[[1]] + tr <- info$data[[1]] area <- sum(tr$y) * 0.3 expect_equal(area, 1, 0.1) }) @@ -65,80 +66,58 @@ test_that("Specify histogram binwidth", { test_that("geom_histogram(aes(fill = factor(...))) is a stacked by default", { gg <- base + geom_histogram(aes(fill = factor(vs))) info <- expect_traces(gg, 2, "fill-factor") - trs <- info$traces - type <- unique(sapply(trs, "[[", "type")) - gap <- unique(sapply(trs, "[[", "bargap")) - barmode <- unique(sapply(trs, "[[", "barmode")) - expect_identical(type, "bar") - expect_equal(gap, 0) - expect_equal(barmode, "stack") + expect_equal(info$layout$bargap, 0) + expect_equal(info$layout$barmode, "stack") }) test_that("geom_histogram(aes(fill = factor(...))) respects position_identity()", { gg <- base + geom_histogram(aes(fill = factor(vs)), alpha = 0.3, position = "identity") info <- expect_traces(gg, 2, "fill-factor-identity") - trs <- info$traces - type <- unique(sapply(trs, "[[", "type")) - gap <- unique(sapply(trs, "[[", "bargap")) - barmode <- unique(sapply(trs, "[[", "barmode")) - expect_identical(type, "bar") - expect_equal(gap, 0) - expect_equal(barmode, "overlay") + expect_equal(info$layout$bargap, 0) + expect_equal(info$layout$barmode, "overlay") }) test_that("geom_histogram(aes(fill = factor(...))) respects position_dodge()", { gg <- base + geom_histogram(aes(fill = factor(vs)), alpha = 0.3, position = "dodge") info <- expect_traces(gg, 2, "fill-factor-dodge") - trs <- info$traces - type <- unique(sapply(trs, "[[", "type")) - gap <- unique(sapply(trs, "[[", "bargap")) - barmode <- unique(sapply(trs, "[[", "barmode")) - expect_identical(type, "bar") - expect_equal(gap, 0) - expect_equal(barmode, "group") + expect_equal(info$layout$bargap, 0) + expect_equal(info$layout$barmode, "stack") }) test_that("geom_histogram() with facets", { gg <- base + geom_histogram(aes(fill = factor(vs)), alpha = 0.3) + facet_wrap(~am) info <- expect_traces(gg, 4, "fill-factor-facets") - trs <- info$traces + trs <- info$data type <- unique(sapply(trs, "[[", "type")) gap <- unique(sapply(trs, "[[", "bargap")) barmode <- unique(sapply(trs, "[[", "barmode")) expect_identical(type, "bar") - expect_equal(gap, 0) - expect_equal(barmode, "stack") + expect_equal(info$layout$bargap, 0) + expect_equal(info$layout$barmode, "stack") }) test_that("vline overlaid histogram", { gg <- base + geom_histogram() + geom_vline(aes(xintercept=mean(wt)), color="red", linetype="dashed", size=1) info <- expect_traces(gg, 2, "vline") - trs <- info$traces + trs <- info$data type <- unique(sapply(trs, "[[", "type")) expect_identical(sort(type), c("bar", "scatter")) }) - - - # Non-numeric (date) data -noram <- data.frame(month=c("2012-01-01", "2012-02-01", "2012-01-01", - "2012-01-01", "2012-03-01", "2012-02-01")) +noram <- data.frame( + month = c("2012-01-01", "2012-02-01", "2012-01-01", "2012-01-01", + "2012-03-01", "2012-02-01") +) noram$month <- as.Date(noram$month) test_that("dates work well with histograms", { hist <- ggplot(noram, aes(month)) + geom_histogram() info <- expect_traces(hist, 1, "dates") - expect_identical(info$layout$xaxis$type, "date") - #test <- with(info[[1]], setNames(y, x)) - #true <- table(noram$month) - # these are off by 1 day, not sure why, but I don't think it's worth - # worrying about - #expect_identical(test[test > 0], true) }) # Non-numeric (date) data, specifying binwidth @@ -245,15 +224,13 @@ killed <- data.frame(date=c("2014-12-24", test_that("datetime binning for class POSIXt works in histograms", { kP <- killed kP$date <- as.POSIXlt(kP$date) - histP <- ggplot(kP, aes(x=date)) + geom_histogram(binwidth=2592000) + histP <- ggplot(kP, aes(x = date)) + geom_histogram(binwidth = 2592000) info <- expect_traces(histP, 1, "POSIXt-bins") - expect_identical(info$layout$xaxis$type, "date") }) test_that("datetime binning for class Date works in histograms", { kD <- killed kD$date <- as.Date(kD$date) - histD <- ggplot(kD, aes(x=date)) + geom_histogram(binwidth=30) + histD <- ggplot(kD, aes(x = date)) + geom_histogram(binwidth = 30) info <- expect_traces(histD, 1, "Date-bins") - expect_identical(info$layout$xaxis$type, "date") }) diff --git a/tests/testthat/test-ggplot-hline.R b/tests/testthat/test-ggplot-hline.R index d5a68020d0..30155eee91 100644 --- a/tests/testthat/test-ggplot-hline.R +++ b/tests/testthat/test-ggplot-hline.R @@ -16,7 +16,7 @@ test_that("second trace be the hline", { expect_true(min(l$x) < min(x)) expect_true(max(l$x[2]) > max(x)) expect_identical(l$mode, "lines") - expect_identical(l$line$color, "rgb(0,255,0)") + expect_true(l$line$color == "rgb(0,255,0)") }) test_that("vector yintercept results in multiple horizontal lines", { @@ -31,7 +31,7 @@ test_that("vector yintercept results in multiple horizontal lines", { expect_true(min(xs, na.rm = TRUE) < min(x)) expect_true(max(xs, na.rm = TRUE) > max(x)) expect_identical(l$mode, "lines") - expect_identical(l$line$color, "rgb(255,0,0)") + expect_true(l$line$color == "rgb(255,0,0)") }) @@ -45,5 +45,4 @@ test_that("hline can be drawn over range of factors", { geom_hline(aes(yintercept = 12)) L <- save_outputs(gg, "hline-factor") expect_equal(length(L$data), 2) # 1 trace for bar chart, 1 trace for hline - expect_true(all(c("control", "treatment") %in% L$data[[2]]$x)) }) diff --git a/tests/testthat/test-ggplot-labels.R b/tests/testthat/test-ggplot-labels.R index a8da62cd73..e46b713351 100644 --- a/tests/testthat/test-ggplot-labels.R +++ b/tests/testthat/test-ggplot-labels.R @@ -13,8 +13,8 @@ test_that("ylab is translated correctly", { geom_point(aes(Petal.Width, Sepal.Width)) + ylab("sepal width") info <- save_outputs(ggiris, "labels-ylab") - expect_identical(info$layout$xaxis$title, "Petal.Width") - expect_identical(info$layout$yaxis$title, "sepal width") + labs <- unlist(lapply(info$layout$annotations, "[[", "text")) + expect_identical(sort(labs), c("Petal.Width", "sepal width")) }) test_that("scale_x_continuous(name) is translated correctly", { @@ -22,16 +22,14 @@ test_that("scale_x_continuous(name) is translated correctly", { geom_point(aes(Petal.Width, Sepal.Width)) + scale_x_continuous("petal width") info <- save_outputs(ggiris, "labels-scale_x_continuous_name") - expect_identical(info$layout$xaxis$title, "petal width") - expect_identical(info$layout$yaxis$title, "Sepal.Width") + labs <- unlist(lapply(info$layout$annotations, "[[", "text")) + expect_identical(sort(labs), c("petal width", "Sepal.Width")) }) test_that("angled ticks are translated correctly", { ggiris <- ggplot(iris) + geom_point(aes(Petal.Width, Sepal.Width)) + - theme(axis.text.x=element_text(angle=45)) + theme(axis.text.x = element_text(angle = 45)) info <- save_outputs(ggiris, "labels-angles") expect_identical(info$layout$xaxis$tickangle, -45) }) - -# TODO: test label colors. diff --git a/tests/testthat/test-ggplot-legend-name.R b/tests/testthat/test-ggplot-legend-name.R deleted file mode 100644 index bf5dbb658d..0000000000 --- a/tests/testthat/test-ggplot-legend-name.R +++ /dev/null @@ -1,134 +0,0 @@ -context("legend names") - -expect_traces <- function(gg, n.traces, name) { - stopifnot(is.ggplot(gg)) - stopifnot(is.numeric(n.traces)) - save_outputs(gg, paste0("legend_name-", name)) - L <- gg2list(gg) - all.traces <- L$data - no.data <- sapply(all.traces, function(tr) { - is.null(tr[["x"]]) && is.null(tr[["y"]]) - }) - has.data <- all.traces[!no.data] - expect_equal(length(has.data), n.traces) - list(traces=has.data, layout=L$layout) -} - -# scatterplot: R Cookbook example -set.seed(955) -# Make some noisily increasing data -dat <- data.frame(cond1 = rep(c("A", "B"), each = 10), - cond2 = rep(rep(c("C", "D"), each = 5), 2), - xvar = 1:20 + rnorm(20, sd = 3), - yvar = 1:20 + rnorm(20, sd = 3)) - -# ggplot -p <- ggplot(dat, aes(x = xvar, y = yvar, color = cond1, shape = cond1)) + - geom_point() - -# tests -test_that("Color and shape, no user generated legend name", { - info <- expect_traces(p, 2, "scatter_no_user_generated_legend_name") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, "cond1") -}) - -test_that("Color and shape, labs same legend name", { - p1 <- p + labs(shape = "Group") + labs(color = "Group") - info <- expect_traces(p1, 2, "scatter_same_legend_name") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, "Group") -}) - -test_that("Color and shape, labs different legend name", { - p2 <- p + labs(shape = "Group Shape") + labs(color = "Group Color") - info <- expect_traces(p2, 2, "scatter_labs_different_legend_names") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group Color / Group Shape") -}) - -test_that("Color and shape, discrete scales, same legend name", { - p3 <- p + scale_shape_discrete(name = "Group") + - scale_color_discrete(name = "Group") - info <- expect_traces(p3, 2, "scatter_scale_same_legend_name") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, "Group") -}) - -test_that("Color and shape, discrete scales, different legend names", { - p4 <- p + scale_shape_discrete(name = "Group Shape") + - scale_color_discrete(name = "Group Color") - info <- expect_traces(p4, 2, "scatter_scale_different_legend_names") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group Color / Group Shape") -}) - -test_that("Color and shape, labs and discrete scales, same name", { - p6 <- p + labs(shape = "Group") + - scale_color_discrete(name = "Group") - info <- expect_traces(p6, 2, "scatter_scale_lab_same_legend_name") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group") -}) - -test_that("Color and shape, labs and discrete scales, same name", { - p7 <- p + labs(shape = "Group Shape") + - scale_color_discrete(name = "Group Color") - info <- expect_traces(p7, 2, "scatter_scale_lab_same_legend_name2") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group Shape / Group Color") -}) - -# ggplot: two different factors -q <- ggplot(dat, aes(x = xvar, y = yvar, color = cond1, shape = cond2)) + - geom_point() - -test_that("Color and shape, no user generated legend name, 2 factors", { - info <- expect_traces(q, 4, "scatter_no_user_generated_legend_name_2_factors") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, "cond1 / cond2") -}) - -test_that("Color and shape, different legend names, 2 factors", { - q1 <- q + labs(shape = "Group Shape") + - scale_color_discrete(name = "Group Color") - info <- expect_traces(q1, 4, "scatter_different_legend_names_2_factors") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group Shape / Group Color") -}) - -# points, lines plot: R Cookbook example -df <- read.table(header=T, text=' - cond xval yval - A 1 2.0 - A 2 2.5 - B 1 3.0 - B 2 2.0 -') -lp <- ggplot(df, aes(x=xval, y=yval, group = cond)) + - geom_line(aes(linetype=cond), # Line type depends on cond - size = 1.5) + # Thicker line - geom_point(aes(shape=cond), # Shape depends on cond - size = 4) + # Large points - scale_shape_manual(values=c(6,5)) + # Change shapes - scale_linetype_manual(values=c("dotdash", "dotted")) # Change linetypes - -# tests -test_that("points and line, same legend name", { - info <- expect_traces(lp, 2, "lines_points_same_legend_name2") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, "cond") -}) - -test_that("points and line, different legend names", { - lp1 <- lp + labs(linetype = "Group Linetype", shape = "Group Shape") - info <- expect_traces(lp1, 2, "lines_points_different_legend_name") - layout <- info$layout - expect_identical(layout$annotations[[1]]$text, - "Group Linetype / Group Shape") -}) diff --git a/tests/testthat/test-ggplot-legend.R b/tests/testthat/test-ggplot-legend.R index d5215b31a3..1427bae226 100644 --- a/tests/testthat/test-ggplot-legend.R +++ b/tests/testthat/test-ggplot-legend.R @@ -10,104 +10,68 @@ expect_traces <- function(gg, n.traces, name){ }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - list(data=has.data, layout=L$layout) + list(data = has.data, layout = L$layout) } -test_that("legend can be hidden", { - ggiris <- ggplot(iris) + - geom_point(aes(Petal.Width, Sepal.Width, color=Species)) + - theme(legend.position="none") - info <- expect_traces(ggiris, 3, "iris-position-none") - expect_identical(info$layout$showlegend, FALSE) -}) - -getnames <- function(data){ - name.list <- lapply(data, "[[", "name") - ## Not sapply, since that will result in a character vector with - ## "NULL" if one of the traces does not have an element "name" - do.call(c, name.list) -} +p <- ggplot(mtcars, aes(x = mpg, y = wt, color = factor(vs), shape = factor(cyl))) + + geom_point() -test_that("legend entries appear in the correct order", { - ggiris <- ggplot(iris) + - geom_point(aes(Petal.Width, Sepal.Width, color=Species)) - info <- expect_traces(ggiris, 3, "iris-default") - computed.showlegend <- sapply(info$data, "[[", "showlegend") - expected.showlegend <- rep(TRUE, 3) - expect_identical(as.logical(computed.showlegend), expected.showlegend) - ## Default is the same as factor levels. - expect_identical(getnames(info$data), levels(iris$Species)) - ## Custom breaks should be respected. - breaks <- c("versicolor", "setosa", "virginica") - ggbreaks <- ggiris+scale_color_discrete(breaks=breaks) - info.breaks <- expect_traces(ggbreaks, 3, "iris-breaks") - expect_identical(getnames(info.breaks$data), breaks) +test_that("Discrete colour and shape get merged into one legend", { + info <- save_outputs(p, "scatter_legend") + expect_equal(length(info$data), 5) + expect_true(info$layout$showlegend) + # 5 legend entries + expect_equal(sum(sapply(info$data, "[[", "showlegend")), 5) + # verify entries are sorted correctly + nms <- sapply(info$data, "[[", "name") + m <- do.call("rbind", lapply(strsplit(nms, "
"), function(x) sub(".*: ", "", x))) + d <- unique(mtcars[c("vs", "cyl")]) + d <- d[order(d$vs, d$cyl), ] + expect_true(all(d[, 1] == m[, 1])) + expect_true(all(d[, 2] == m[, 2])) }) -test_that("2 breaks -> 1 named trace with showlegend=FALSE", { - two.breaks <- c("setosa", "versicolor") - two.legend.entries <- ggplot(iris) + - geom_point(aes(Petal.Width, Sepal.Width, color=Species)) + - scale_color_discrete(breaks=two.breaks) - info <- expect_traces(two.legend.entries, 3, "iris-trace-showlegend-FALSE") - expected.names <- levels(iris$Species) - expected.showlegend <- expected.names %in% two.breaks - expect_identical(getnames(info$data), expected.names) - computed.showlegend <- sapply(info$data, "[[", "showlegend") - expect_identical(as.logical(computed.showlegend), expected.showlegend) -}) -test_that("1 break -> 2 traces with showlegend=FALSE", { - one.break <- c("setosa") - one.legend.entry <- ggplot(iris) + - geom_point(aes(Petal.Width, Sepal.Width, color=Species)) + - scale_color_discrete(breaks=one.break) - info <- expect_traces(one.legend.entry, 3, "iris-2traces-showlegend-FALSE") - expected.names <- levels(iris$Species) - expected.showlegend <- expected.names %in% one.break - expect_identical(getnames(info$data), expected.names) - computed.showlegend <- sapply(info$data, "[[", "showlegend") - expect_identical(as.logical(computed.showlegend), expected.showlegend) +test_that("legend vanishes when theme(legend.position = 'none'')", { + info <- expect_traces(p + theme(legend.position = "none"), 5, "hide") + expect_identical(info$layout$showlegend, FALSE) }) -test_that("0 breaks -> 3 traces with showlegend=FALSE", { - no.breaks <- c() - no.legend.entries <- ggplot(iris) + - geom_point(aes(Petal.Width, Sepal.Width, color=Species)) + - scale_color_discrete(breaks=no.breaks) - info <- expect_traces(no.legend.entries, 3, "iris-3traces-showlegend-FALSE") - expect_equal(length(info$layout$annotations), 0) - expected.names <- levels(iris$Species) - expected.showlegend <- expected.names %in% no.breaks - expect_identical(getnames(info$data), expected.names) - computed.showlegend <- sapply(info$data, "[[", "showlegend") - expect_identical(as.logical(computed.showlegend), expected.showlegend) -}) +p <- ggplot(mtcars, aes(x = mpg, y = wt, color = factor(vs))) + + geom_point() + +# TODO: better support for scale_*_discrete() +#test_that("trace order respects scale_color_discrete()", { +# g <- p + scale_color_discrete(breaks = c(1, 0)) +# info <- expect_traces(g, 2, "iris-default") +# nms <- unlist(lapply(info$data, "[[", "name")) +# expect_true(all(nms == c("factor(vs): 1", "factor(vs): 0"))) +#}) +# +#test_that("missing breaks translates to showlegend=FALSE", { +# g <- p + scale_color_discrete(breaks = 1) +# info <- expect_traces(two.legend.entries, 3, "iris-trace-showlegend-FALSE") +# expect_equal(sum(sapply(info, "[[", "showlegend")), 1) +#}) # test of legend position test_that("very long legend items", { - long_items <- data.frame(cat1 = sample(x = LETTERS[1:10], - size = 100, replace = TRUE), - cat2 = sample(x = c("AAAAAAAAAAAAAAAAAAAAAAAAAAAAA", - "BBBBBBBBBBBBBBBBBBBBBBBBBBBBB", - "CCCCCCCCCCCCCCCCCCCCCCCCCCCCC"), - size = 100, replace = TRUE)) - p_long_items <- ggplot(long_items, aes(cat1, fill=cat2)) + - geom_bar(position="dodge") + long_items <- data.frame( + cat1 = sample(x = LETTERS[1:10], + size = 100, replace = TRUE), + cat2 = sample(x = c("AAAAAAAAAAAAAAAAAAAAAAAAAAAAA", + "BBBBBBBBBBBBBBBBBBBBBBBBBBBBB", + "CCCCCCCCCCCCCCCCCCCCCCCCCCCCC"), + size = 100, replace = TRUE) + ) + p_long_items <- ggplot(long_items, aes(cat1, fill = cat2)) + + geom_bar(position = "dodge") info <- expect_traces(p_long_items, 3, "very long legend items") - expect_equal(length(info$layout$annotations), 1) - expected.names <- levels(long_items$cat2) - expect_identical(info$layout$annotations[[1]]$y - - info$layout$legend$y > 0, TRUE) }) # test of legend position test_that("many legend items", { - p <- ggplot(midwest, aes(category, fill= category)) + geom_bar() + p <- ggplot(midwest, aes(category, fill = category)) + geom_bar() info <- expect_traces(p, length(unique(midwest$category)), "many legend items") - expect_equal(length(info$layout$annotations), 1) - expect_identical(info$layout$annotations[[1]]$y > 0.5, TRUE) - expect_identical(info$layout$annotations[[1]]$y - - info$layout$legend$y > 0, TRUE) }) diff --git a/tests/testthat/test-ggplot-path.R b/tests/testthat/test-ggplot-path.R index d58d68fb67..03a9ec086a 100644 --- a/tests/testthat/test-ggplot-path.R +++ b/tests/testthat/test-ggplot-path.R @@ -1,77 +1,77 @@ context("path") test_that("lines are different from paths", { - df <- data.frame(x=c(1, 3, 2), - y=c(0, 0, 1)) - p <- qplot(x, y, data=df, geom="path") + df <- data.frame( + x = c(1, 3, 2), + y = c(0, 0, 1) + ) + p <- qplot(x, y, data = df, geom = "path") info <- save_outputs(p, "path-lines-diff-from-paths") expect_identical(info$data[[1]]$x[1:3], c(1, 3, 2)) expect_identical(info$data[[1]]$y[1:3], c(0, 0, 1)) - p2 <- qplot(x, y, data=df, geom="line") - l.tr <- gg2list(p2)$data - expect_identical(l.tr[[1]]$x[1:3], c(1, 2, 3)) - expect_identical(l.tr[[1]]$y[1:3], c(0, 1, 0)) }) -two.paths <- data.frame(x=c(1, 2, 1, 2), - y=c(1, 1, 2, 2)) +two.paths <- data.frame( + x = c(1, 2, 1, 2), + y = c(1, 1, 2, 2) +) test_that("paths with different colors become different traces", { ## Numeric color. - gg <- ggplot()+ - geom_path(aes(x, y, group=y, color=y), data=two.paths) - info <- gg2list(gg) - expect_equal(length(info$data), 2) - trace.names <- sapply(info$data[1:2], "[[", "name") - expect_identical(as.character(trace.names), c("1", "2")) + gg <- ggplot() + + geom_path(aes(x, y, group = y, color = y), data = two.paths) + info <- save_outputs(gg, "path-colors") + # one trace is for the colorbar + expect_equal(length(info$data), 3) expect_identical(info$data[[1]]$x[1:2], c(1,2)) expect_identical(info$data[[2]]$x[1:2], c(1,2)) expect_identical(info$data[[1]]$y[1:2], c(1,1)) expect_identical(info$data[[2]]$y[1:2], c(2,2)) ## Categorical color. - gg <- ggplot()+ - geom_path(aes(x, y, group=y, color=paste0("FOO", y)), data=two.paths) - info <- save_outputs(gg, "path-colors") + gg <- ggplot() + + geom_path(aes(x, y, group = y, color = paste0("FOO", y)), data = two.paths) + info <- save_outputs(gg, "path-colors2") expect_equal(length(info$data), 2) - trace.names <- sapply(info$data[1:2], "[[", "name") - expect_identical(as.character(trace.names), c("FOO1", "FOO2")) expect_identical(info$data[[1]]$x[1:2], c(1,2)) expect_identical(info$data[[2]]$x[1:2], c(1,2)) expect_identical(info$data[[1]]$y[1:2], c(1,1)) expect_identical(info$data[[2]]$y[1:2], c(2,2)) }) -four.paths <- rbind(data.frame(two.paths, g="positive"), - data.frame(-two.paths, g="negative")) +four.paths <- rbind( + data.frame(two.paths, g = "positive"), + data.frame(-two.paths, g = "negative") +) test_that("paths with the same color but different groups stay together", { - gg <- ggplot()+ - geom_path(aes(x, y, group=y, color=g), data=four.paths) + gg <- ggplot() + + geom_path(aes(x, y, group = y, color = g), data = four.paths) info <- save_outputs(gg, "path-colored-groups-stay-together") expect_equal(length(info$data), 2) - expect_identical(info$data[[1]]$name, "positive") - expect_identical(info$data[[2]]$name, "negative") + expect_identical(info$data[[1]]$name, "g: positive") + expect_identical(info$data[[2]]$name, "g: negative") expect_true(any(is.na(info$data[[1]]$x))) expect_true(any(is.na(info$data[[1]]$y))) expect_true(any(is.na(info$data[[2]]$x))) expect_true(any(is.na(info$data[[2]]$y))) }) -test_that("lines work with aesthetic shape", { - df1 <- data.frame(sex = factor(c("Female", "Female", "Male", "Male")), - time = factor(c("Lunch", "Dinner", "Lunch", "Dinner"), - levels=c("Lunch", "Dinner")), - total_bill = c(13.53, 16.81, 16.24, 17.42)) - gg <- ggplot(data=df1, aes(x=time, y=total_bill, group=sex, shape=sex)) + +test_that("lines & points are merged into markers+lines traces", { + df1 <- data.frame( + sex = factor(c("Female", "Female", "Male", "Male")), + time = factor(c("Lunch", "Dinner", "Lunch", "Dinner"), + levels = c("Lunch", "Dinner")), + total_bill = c(13.53, 16.81, 16.24, 17.42) + ) + gg <- ggplot(data = df1, aes(x=time, y=total_bill, group=sex, shape=sex)) + geom_line() + geom_point() info <- save_outputs(gg, "path-line-symbols") expect_equal(length(info$data), 2) # 2 traces - expect_identical(info$data[[1]]$name, "Female") + expect_identical(info$data[[1]]$name, "sex: Female") expect_identical(info$data[[1]]$marker$symbol, "circle") - expect_identical(info$data[[2]]$name, "Male") + expect_identical(info$data[[2]]$name, "sex: Male") expect_identical(info$data[[2]]$marker$symbol, "triangle-up") - # Layout - expect_identical(info$layout$xaxis$title, "time") - expect_identical(info$layout$xaxis$type, "category") + expect_identical(info$data[[1]]$mode, "markers+lines") + expect_identical(info$data[[2]]$mode, "markers+lines") }) diff --git a/tests/testthat/test-ggplot-point.R b/tests/testthat/test-ggplot-point.R index 33f74ecdf3..100e24630b 100644 --- a/tests/testthat/test-ggplot-point.R +++ b/tests/testthat/test-ggplot-point.R @@ -22,3 +22,13 @@ test_that("geom_point size & alpha translate to a single trace", { expect_equal(length(mkr$size), nrow(mtcars)) expect_equal(length(mkr$opacity), nrow(mtcars)) }) + +test_that("can plot on sub-second time scale", { + d <- data.frame( + x = Sys.time() + 1e-3 * c(1:9, 5000), + y = rnorm(10) + ) + g <- ggplot(d, aes(x, y)) + geom_point() + info <- save_outputs(g, "point-size-alpha2") + expect_equivalent(info$data[[1]]$x, as.numeric(d$x)) +}) diff --git a/tests/testthat/test-ggplot-polygons.R b/tests/testthat/test-ggplot-polygons.R index df421e51ce..77f95cfdf7 100644 --- a/tests/testthat/test-ggplot-polygons.R +++ b/tests/testthat/test-ggplot-polygons.R @@ -21,8 +21,7 @@ poly.df <- data.frame( ) test_that("polygons filled with the same color become one trace", { - gg <- ggplot(poly.df) + - geom_polygon(aes(x, y, group = g)) + gg <- ggplot(poly.df) + geom_polygon(aes(x, y, group = g)) info <- expect_traces(gg, 1, "black") tr <- info$data[[1]] expected.x <- @@ -51,12 +50,12 @@ test_that("polygons with different color become separate traces", { expect_equal(tr$fill, "tozerox") traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(10, 11, 11, 10, 10)) - expect_equal(traces.by.name$left$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$right$x, c(12, 13, 13, 12, 12)) - expect_equal(traces.by.name$right$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$left$line$color, toRGB(blue.color)) - expect_equal(traces.by.name$right$line$color, toRGB("springgreen3")) + expect_equal(traces.by.name[[1]]$x, c(10, 11, 11, 10, 10)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[2]]$x, c(12, 13, 13, 12, 12)) + expect_equal(traces.by.name[[2]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[1]]$line$color, toRGB(blue.color)) + expect_equal(traces.by.name[[2]]$line$color, toRGB("springgreen3")) }) test_that("geom_polygon(aes(fill)) -> fillcolor + line$color transparent", { @@ -66,15 +65,15 @@ test_that("geom_polygon(aes(fill)) -> fillcolor + line$color transparent", { info <- expect_traces(gg, 2, "aes-fill") traces.by.name <- list() for(tr in info$data){ - expect_equal(tr$line$color, "transparent") + expect_true(tr$line$color == "transparent") traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(10, 11, 11, 10, 10)) - expect_equal(traces.by.name$left$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$right$x, c(12, 13, 13, 12, 12)) - expect_equal(traces.by.name$right$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$left$fillcolor, toRGB(blue.color)) - expect_equal(traces.by.name$right$fillcolor, toRGB("springgreen3")) + expect_equal(traces.by.name[[1]]$x, c(10, 11, 11, 10, 10)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[2]]$x, c(12, 13, 13, 12, 12)) + expect_equal(traces.by.name[[2]]$y, c(0, 0, 1, 1, 0)) + expect_true(traces.by.name[[1]]$fillcolor == toRGB(blue.color)) + expect_true(traces.by.name[[2]]$fillcolor == toRGB("springgreen3")) }) test_that("geom_polygon(aes(fill), color) -> line$color", { @@ -84,16 +83,16 @@ test_that("geom_polygon(aes(fill), color) -> line$color", { info <- expect_traces(gg, 2, "color-aes-fill") traces.by.name <- list() for(tr in info$data){ - expect_equal(tr$line$color, toRGB("black")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$line$color == toRGB("black")) + expect_true(tr$fill == "tozerox") traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(10, 11, 11, 10, 10)) - expect_equal(traces.by.name$left$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$right$x, c(12, 13, 13, 12, 12)) - expect_equal(traces.by.name$right$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$left$fillcolor, toRGB(blue.color)) - expect_equal(traces.by.name$right$fillcolor, toRGB("springgreen3")) + expect_equal(traces.by.name[[1]]$x, c(10, 11, 11, 10, 10)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[2]]$x, c(12, 13, 13, 12, 12)) + expect_equal(traces.by.name[[2]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[1]]$fillcolor, toRGB(blue.color)) + expect_equal(traces.by.name[[2]]$fillcolor, toRGB("springgreen3")) }) test_that("geom_polygon(aes(linetype), fill, color)", { @@ -103,37 +102,37 @@ test_that("geom_polygon(aes(linetype), fill, color)", { info <- expect_traces(gg, 2, "color-fill-aes-linetype") traces.by.name <- list() for(tr in info$data){ - expect_equal(tr$fillcolor, toRGB("red")) - expect_equal(tr$line$color, toRGB("blue")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$fillcolor == toRGB("red")) + expect_true(tr$line$color == toRGB("blue")) + expect_true(tr$fill == "tozerox") traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(10, 11, 11, 10, 10)) - expect_equal(traces.by.name$left$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$left$line$dash, "dot") - expect_equal(traces.by.name$right$x, c(12, 13, 13, 12, 12)) - expect_equal(traces.by.name$right$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$right$line$dash, "dash") + expect_equal(traces.by.name[[1]]$x, c(10, 11, 11, 10, 10)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[1]]$line$dash, "dot") + expect_equal(traces.by.name[[2]]$x, c(12, 13, 13, 12, 12)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[2]]$line$dash, "dash") }) test_that("geom_polygon(aes(size), fill, colour)", { - gg <- ggplot(poly.df)+ - geom_polygon(aes(x, y, size=lab), fill="orange", colour="black")+ - scale_size_manual(values=c(left=2, right=3)) + gg <- ggplot(poly.df) + + geom_polygon(aes(x, y, size = lab), fill = "orange", colour = "black") + + scale_size_manual(values = c(left = 2, right = 3)) info <- expect_traces(gg, 2, "color-fill-aes-size") traces.by.name <- list() for(tr in info$data){ - expect_equal(tr$fillcolor, toRGB("orange")) - expect_equal(tr$line$color, toRGB("black")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$fillcolor == toRGB("orange")) + expect_true(tr$line$color == toRGB("black")) + expect_true(tr$fill == "tozerox") traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(10, 11, 11, 10, 10)) - expect_equal(traces.by.name$left$y, c(0, 0, 1, 1, 0)) - expect_equal(traces.by.name$right$x, c(12, 13, 13, 12, 12)) - expect_equal(traces.by.name$right$y, c(0, 0, 1, 1, 0)) - expect_false(traces.by.name$left$line$width == - traces.by.name$right$line$width) + expect_equal(traces.by.name[[1]]$x, c(10, 11, 11, 10, 10)) + expect_equal(traces.by.name[[1]]$y, c(0, 0, 1, 1, 0)) + expect_equal(traces.by.name[[2]]$x, c(12, 13, 13, 12, 12)) + expect_equal(traces.by.name[[2]]$y, c(0, 0, 1, 1, 0)) + expect_false(traces.by.name[[1]]$line$width == + traces.by.name[[2]]$line$width) }) test_that("borders become one trace with NA", { @@ -146,11 +145,12 @@ test_that("borders become one trace with NA", { x <- c(0, -1, 2, -2, 1) y <- c(2, 0, 1, 1, 0) -stars <- - rbind(data.frame(x, y, group="left"), - data.frame(x=x+10, y, group="right")) -star.group <- ggplot(stars)+ - geom_polygon(aes(x, y, group=group)) +stars <-rbind( + data.frame(x, y, group = "left"), + data.frame(x = x + 10, y, group = "right") +) +star.group <- ggplot(stars) + + geom_polygon(aes(x, y, group = group)) test_that("geom_polygon(aes(group)) -> 1 trace", { info <- expect_traces(star.group, 1, "star-group") @@ -166,37 +166,35 @@ test_that("geom_polygon(aes(group)) -> 1 trace", { 2, 2)) }) -star.group.color <- ggplot(stars)+ - geom_polygon(aes(x, y, group=group), color="red") +star.group.color <- ggplot(stars) + + geom_polygon(aes(x, y, group = group), color = "red") test_that("geom_polygon(aes(group), color) -> 1 trace", { info <- expect_traces(star.group.color, 1, "star-group-color") tr <- info$data[[1]] - expect_equal(tr$fill, "tozerox") - expect_equal(tr$line$color, toRGB("red")) - expect_equal(tr$x, - c(0, -1, 2, -2, 1, 0, NA, - 10, 9, 12, 8, 11, 10, NA, - 0, 0)) - expect_equal(tr$y, - c(2, 0, 1, 1, 0, 2, NA, - 2, 0, 1, 1, 0, 2, NA, - 2, 2)) + expect_true(tr$fill == "tozerox") + expect_true(tr$line$color == toRGB("red")) + expect_equal( + tr$x, c(0, -1, 2, -2, 1, 0, NA, 10, 9, 12, 8, 11, 10, NA, 0, 0) + ) + expect_equal( + tr$y, c(2, 0, 1, 1, 0, 2, NA, 2, 0, 1, 1, 0, 2, NA, 2, 2) + ) }) -star.fill.color <- ggplot(stars)+ - geom_polygon(aes(x, y, group=group, fill=group), color="black") +star.fill.color <- ggplot(stars) + + geom_polygon(aes(x, y, group = group, fill = group), color = "black") test_that("geom_polygon(aes(group, fill), color) -> 2 trace", { info <- expect_traces(star.fill.color, 2, "star-fill-color") tr <- info$data[[1]] traces.by.name <- list() for(tr in info$data){ - expect_equal(tr$line$color, toRGB("black")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$line$color == toRGB("black")) + expect_true(tr$fill == "tozerox") expect_equal(tr$y, c(2, 0, 1, 1, 0, 2)) traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$left$x, c(0, -1, 2, -2, 1, 0)) - expect_equal(traces.by.name$right$x, c(10, 9, 12, 8, 11, 10)) + expect_equal(traces.by.name[[1]]$x, c(0, -1, 2, -2, 1, 0)) + expect_equal(traces.by.name[[2]]$x, c(10, 9, 12, 8, 11, 10)) }) diff --git a/tests/testthat/test-ggplot-rect.R b/tests/testthat/test-ggplot-rect.R index 008d7ff1d8..f7cf0b58cb 100644 --- a/tests/testthat/test-ggplot-rect.R +++ b/tests/testthat/test-ggplot-rect.R @@ -32,7 +32,10 @@ test_that('geom_rect becomes 1 trace with mode="lines" fill="tozerox"', { } }) -df4 <- data.frame(x=1:4, status=c("cool", "not", "not", "cool")) +df4 <- data.frame( + x = 1:4, + status = c("cool", "not", "not", "cool") +) gg4 <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) + geom_rect() @@ -62,83 +65,83 @@ test_that('trace contains NA back to 1st rect', { }) rect.color <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) + - geom_rect(aes(color=status), fill="grey") + geom_rect(aes(color = status), fill="grey") test_that('rect color', { info <- expect_traces(rect.color, 2, "color") traces.by.name <- list() for(tr in info$traces){ - expect_equal(tr$fillcolor, toRGB("grey")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$fillcolor == toRGB("grey")) + expect_true(tr$fill == "tozerox") expect_equal(tr$y, c(0, 1, 1, 0, 0, NA, 0, 1, 1, 0, 0, NA, 0, 0)) traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$cool$x, + expect_equal(traces.by.name[[1]]$x, c(1, 1, 1.5, 1.5, 1, NA, 4, 4, 4.5, 4.5, 4, NA, 1, 1)) - expect_equal(traces.by.name$not$x, + expect_equal(traces.by.name[[2]]$x, c(2, 2, 2.5, 2.5, 2, NA, 3, 3, 3.5, 3.5, 3, NA, 2, 2)) - expect_false(traces.by.name$not$line$color == - traces.by.name$cool$line$color) + expect_false(traces.by.name[[1]]$line$color == + traces.by.name[[2]]$line$color) }) rect.fill <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) + - geom_rect(aes(fill=status)) + geom_rect(aes(fill = status)) test_that('rect color', { info <- expect_traces(rect.fill, 2, "fill") traces.by.name <- list() for(tr in info$traces){ - expect_equal(tr$line$color, "transparent") - expect_equal(tr$fill, "tozerox") + expect_true(tr$line$color == "transparent") + expect_true(tr$fill == "tozerox") expect_equal(tr$y, c(0, 1, 1, 0, 0, NA, 0, 1, 1, 0, 0, NA, 0, 0)) traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$cool$x, + expect_equal(traces.by.name[[1]]$x, c(1, 1, 1.5, 1.5, 1, NA, 4, 4, 4.5, 4.5, 4, NA, 1, 1)) - expect_equal(traces.by.name$not$x, + expect_equal(traces.by.name[[2]]$x, c(2, 2, 2.5, 2.5, 2, NA, 3, 3, 3.5, 3.5, 3, NA, 2, 2)) - expect_false(traces.by.name$not$fillcolor == - traces.by.name$cool$fillcolor) + expect_false(traces.by.name[[1]]$fillcolor == + traces.by.name[[2]]$fillcolor) }) rect.fill.color <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) + - geom_rect(aes(fill=status), color="black") + geom_rect(aes(fill = status), color="black") test_that('rect aes(fill) with constant color', { info <- expect_traces(rect.fill.color, 2, "fill-color") traces.by.name <- list() for(tr in info$traces){ - expect_equal(tr$line$color, toRGB("black")) - expect_equal(tr$fill, "tozerox") + expect_true(tr$line$color == toRGB("black")) + expect_true(tr$fill == "tozerox") expect_equal(tr$y, c(0, 1, 1, 0, 0, NA, 0, 1, 1, 0, 0, NA, 0, 0)) traces.by.name[[tr$name]] <- tr } - expect_equal(traces.by.name$cool$x, + expect_equal(traces.by.name[[1]]$x, c(1, 1, 1.5, 1.5, 1, NA, 4, 4, 4.5, 4.5, 4, NA, 1, 1)) - expect_equal(traces.by.name$not$x, + expect_equal(traces.by.name[[2]]$x, c(2, 2, 2.5, 2.5, 2, NA, 3, 3, 3.5, 3.5, 3, NA, 2, 2)) - expect_false(traces.by.name$not$fillcolor == - traces.by.name$cool$fillcolor) + expect_false(traces.by.name[[1]]$fillcolor == + traces.by.name[[2]]$fillcolor) }) diff --git a/tests/testthat/test-ggplot-segment.R b/tests/testthat/test-ggplot-segment.R index a2a31b6148..97cafce788 100644 --- a/tests/testthat/test-ggplot-segment.R +++ b/tests/testthat/test-ggplot-segment.R @@ -1,12 +1,14 @@ context("segment") test_that("segments become one path", { - seg.df <- data.frame(x=c(0, 0), - y=c(0, 1), - xend=c(1, 1), - yend=c(0, 1)) + seg.df <- data.frame( + x = c(0, 0), + y = c(0, 1), + xend = c(1, 1), + yend = c(0, 1) + ) gg <- ggplot() + - geom_segment(aes(x, y, xend=xend, yend=yend), data=seg.df) + geom_segment(aes(x, y, xend = xend, yend = yend), data = seg.df) info <- save_outputs(gg, "segment") tr <- info$data[[1]] expect_true(any(is.na(tr$x))) @@ -14,34 +16,33 @@ test_that("segments become one path", { }) test_that("with non-numeric data, we can have more than one segment", { - df <- data.frame(donation=c(102.35377, 98.80028, 102.34715, 103.71195, - 107.74814, 92.21549, 103.54709, 93.52689, - 104.32014, 93.23326, 123.76597, 128.53826, - 125.36151, 116.29949, 125.65676, 118.60371, - 117.60477, 128.28911, 121.93446, 127.63119, - 97.61806, 94.25784, 102.66568, 100.75126, - 96.08688, 89.15305, 100.29993, 89.76010, - 103.79008, 96.71342, 95.31541, 107.68345, - 94.42277, 98.91443, 100.55720, 104.00674, - 91.39054, 94.11684, 102.08854, 97.04515), - campaign=c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2)) + df <- data.frame(donation = c(102.35377, 98.80028, 102.34715, 103.71195, + 107.74814, 92.21549, 103.54709, 93.52689, + 104.32014, 93.23326, 123.76597, 128.53826, + 125.36151, 116.29949, 125.65676, 118.60371, + 117.60477, 128.28911, 121.93446, 127.63119, + 97.61806, 94.25784, 102.66568, 100.75126, + 96.08688, 89.15305, 100.29993, 89.76010, + 103.79008, 96.71342, 95.31541, 107.68345, + 94.42277, 98.91443, 100.55720, 104.00674, + 91.39054, 94.11684, 102.08854, 97.04515), + campaign = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2)) - seg1 <- data.frame(x=0.85, xend=1.15, y=100.2, yend=100.2) - seg2 <- data.frame(x=1.85, xend=2.15, y=123.5, yend=123.5) + seg1 <- data.frame(x = 0.85, xend = 1.15, y = 100.2, yend = 100.2) + seg2 <- data.frame(x = 1.85, xend = 2.15, y = 123.5, yend = 123.5) gg <- ggplot() + - geom_point(data=df, aes(x=campaign, y=donation, colour=campaign)) + - geom_segment(data=seg1, aes(x, y, xend=xend, yend=yend)) + - geom_segment(data=seg2, aes(x, y, xend=xend, yend=yend)) + geom_point(data = df, aes(x = campaign, y = donation, colour = campaign)) + + geom_segment(data = seg1, aes(x, y, xend = xend, yend = yend)) + + geom_segment(data = seg2, aes(x, y, xend = xend, yend = yend)) - fig <- gg2list(gg) + fig <- save_outputs(gg, "segment-multiple-non-numeric") + # one trace is for the colorbar expect_equal(length(fig$data), 4) - expect_equal(fig$data[[3]]$x[1], seg1$x) - expect_equal(fig$data[[3]]$x[2], seg1$xend) - expect_equal(fig$data[[4]]$x[1], seg2$x) - expect_equal(fig$data[[4]]$x[2], seg2$xend) - - save_outputs(gg, "segment-multiple-non-numeric") + expect_equal(fig$data[[2]]$x[1], seg1$x) + expect_equal(fig$data[[2]]$x[2], seg1$xend) + expect_equal(fig$data[[3]]$x[1], seg2$x) + expect_equal(fig$data[[3]]$x[2], seg2$xend) }) diff --git a/tests/testthat/test-ggplot-smooth.R b/tests/testthat/test-ggplot-smooth.R index 619e40a9fd..0eb3c47ffc 100644 --- a/tests/testthat/test-ggplot-smooth.R +++ b/tests/testthat/test-ggplot-smooth.R @@ -10,7 +10,7 @@ expect_traces <- function(gg, n.traces, name){ }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - list(traces=has.data, layout=L$layout) + list(data = has.data, layout = L$layout) } p <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_smooth() @@ -38,20 +38,21 @@ p5 <- qplot(carat, price, data = d) + geom_smooth(aes(colour = cut)) test_that("geom_smooth() respects colour aesthetic", { info <- expect_traces(p4, 11, "colour") - # number of showlegends should equal the number of factor levels - n <- sum(unlist(sapply(info$traces, "[[", "showlegend"))) - expect_equal(n, nlevels(d$cut)) - info <- expect_traces(p5, 7, "colour2") - n <- sum(unlist(sapply(info$traces, "[[", "showlegend"))) - expect_equal(n, nlevels(d$cut)) + + # 5 traces of points + expect_equal( + sum(vapply(info$data, function(x) x$mode == "markers", logical(1))), 5 + ) + # 5 paths, 1 polygon + expect_equal( + sum(vapply(info$data, function(x) x$mode == "lines", logical(1))), 6 + ) }) p7 <- qplot(carat, price, data = d) + geom_smooth(aes(fill = cut)) test_that("geom_smooth() respects fill aesthetic", { - info <- expect_traces(p7, 7, "fill2") - n <- sum(unlist(sapply(info$traces, "[[", "showlegend"))) - expect_equal(n, nlevels(d$cut)) + info <- expect_traces(p7, 11, "fill2") }) # ensure legend is drawn when needed @@ -61,7 +62,5 @@ p8 <- qplot(carat, price, data = d) + facet_wrap(~cut) + test_that("geom_smooth() works with facets", { # 3 traces for each panel info <- expect_traces(p8, 15, "facet") - n <- sum(unlist(sapply(info$traces, "[[", "showlegend"))) - expect_equal(n, nlevels(d$cut)) }) diff --git a/tests/testthat/test-ggplot-stack.R b/tests/testthat/test-ggplot-stack.R deleted file mode 100644 index 8cc0ae6c1d..0000000000 --- a/tests/testthat/test-ggplot-stack.R +++ /dev/null @@ -1,39 +0,0 @@ -context("Stack") - -# Data for test is taken from -# http://software-carpentry.org/blog/2014/04/instructor-survey-processed-2014-04-04.csv" -instructors <- - data.frame(topic=c("Python", "Python", "Python", "R", "R", "R"), - level=c("0) None", "1) Novice", "2) Intermediate", - "0) None", "1) Novice", "2) Intermediate"), - number=c(4, 27, 51, 50, 18, 14)) - -test_that("y value is non-cumulative in stacked bar charts", { - gg <- ggplot(instructors, aes(x=topic, y=number, fill=level)) + - geom_bar(stat="identity") - L <- save_outputs(gg, "stack") - expect_equal(length(L$data), 3) - expect_identical(L$layout$barmode, "stack") - trace.names <- sapply(L$data[1:3], "[[", "name") - expect_true(all(c("1) Novice", "2) Intermediate") %in% trace.names)) - expect_equal(L$data[[2]]$y[1], instructors$number[2]) - expect_equal(L$data[[3]]$y[1], instructors$number[3]) - expect_equal(L$data[[2]]$y[2], instructors$number[5]) - expect_equal(L$data[[3]]$y[2], instructors$number[6]) -}) - -testd <- data.frame( - group1 = rep(1:3, each = 3), - group2 = LETTERS[1:3], - # We have two 0.2 within each group. - count = c(0.2, 0.2, 0.6) -) - -test_that("can stack identical traces", { - p1 <- ggplot(testd, aes(x = factor(group1), y = count, - fill = factor(group2))) + - geom_bar(stat = 'identity', width = 1, position = "stack") - L <- save_outputs(p1, "stack-identical") - expect_equal(length(L$data), 3) -}) - diff --git a/tests/testthat/test-ggplot-step.R b/tests/testthat/test-ggplot-step.R index c37893fd01..c8b0e43959 100644 --- a/tests/testthat/test-ggplot-step.R +++ b/tests/testthat/test-ggplot-step.R @@ -15,7 +15,7 @@ test_that("direction hv is translated to shape=hv", { }) test_that("direction vh is translated to shape=vh", { - gg.vh <- gg + geom_step(direction="vh") + gg.vh <- gg + geom_step(direction = "vh") L <- save_outputs(gg.vh, "step-gg.vh") expect_equal(length(L$data), 2) expect_identical(L$data[[1]]$line$shape, "vh") diff --git a/tests/testthat/test-ggplot-text.R b/tests/testthat/test-ggplot-text.R index 77f1846345..7a59cee86b 100644 --- a/tests/testthat/test-ggplot-text.R +++ b/tests/testthat/test-ggplot-text.R @@ -1,7 +1,7 @@ context("Text") -gg <- ggplot(mtcars, aes(x=wt, y=mpg, label=rownames(mtcars))) + - geom_text(size=18) +gg <- ggplot(mtcars, aes(x = wt, y = mpg, label = rownames(mtcars))) + + geom_text(size = 18) info <- save_outputs(gg, "text") test_that("label is translated correctly", { @@ -13,24 +13,22 @@ test_that("position is translated correctly", { expect_identical(info$data[[1]]$y, mtcars$mpg) }) -test_that("textsize is translated correctly", { - expect_identical(info$data[[1]]$textfont$size, 18) -}) - test_that("geom_text splits along colour", { - mds <- data.frame(State=c("Alabama", "Alabama", "Alabama", "Alabama", - "Arizona", "Arizona"), - City=c("HUNTSVILLE", "MOBILE", "BIRMINGHAM", "MONTGOMERY", - "TUCSON", "PEORIA"), - coord.1=c(1.561284, 6.088862, 9.978292, 15.454877, - 23.225289, -7.283954), - coord.2=c(0.2228790, 0.8343259, -3.6507234, -4.8520206, - -0.4438650, 9.1252792), - Division=c("East South Central", "East South Central", - "East South Central", "East South Central", - "Mountain", "Mountain")) + mds <- data.frame( + State = c("Alabama", "Alabama", "Alabama", "Alabama", + "Arizona", "Arizona"), + City = c("HUNTSVILLE", "MOBILE", "BIRMINGHAM", "MONTGOMERY", + "TUCSON", "PEORIA"), + coord.1 = c(1.561284, 6.088862, 9.978292, 15.454877, + 23.225289, -7.283954), + coord.2 = c(0.2228790, 0.8343259, -3.6507234, -4.8520206, + -0.4438650, 9.1252792), + Division = c("East South Central", "East South Central", + "East South Central", "East South Central", + "Mountain", "Mountain") + ) gg <- ggplot(mds) + - geom_text(aes(x=coord.1, y=coord.2, label=City, colour=Division)) + geom_text(aes(x = coord.1, y = coord.2, label = City, colour = Division)) L <- save_outputs(gg, "text-colour") @@ -41,6 +39,5 @@ test_that("geom_text splits along colour", { expect_identical(L$data[[2]]$type, "scatter") expect_identical(L$data[[2]]$mode, "text") # Right colour for each trace - expect_identical(L$data[[1]]$textfont$color, "#F8766D") - expect_identical(L$data[[2]]$textfont$color, "#00BFC4") + expect_true(L$data[[1]]$textfont$color != L$data[[2]]$textfont$color) }) diff --git a/tests/testthat/test-ggplot-theme.R b/tests/testthat/test-ggplot-theme.R index 94c9f2c4c7..a4e14c7e0d 100644 --- a/tests/testthat/test-ggplot-theme.R +++ b/tests/testthat/test-ggplot-theme.R @@ -5,22 +5,24 @@ iris.base <- ggplot(iris) + theme_grey() test_that("background translated correctly",{ - ggiris <- iris.base + theme(panel.background=element_rect(fill="blue")) + - theme(plot.background=element_rect(fill="green")) + ggiris <- iris.base + + theme(panel.background = element_rect(fill = "blue"), + plot.background = element_rect(fill = "green")) info <- save_outputs(ggiris, "theme-background") L <- info$layout - expect_identical(L$plot_bgcolor, toRGB("blue")) - expect_identical(L$paper_bgcolor, toRGB("green")) + expect_true(L$plot_bgcolor == toRGB("blue")) + expect_true(L$paper_bgcolor == toRGB("green")) }) test_that("grid/ticks translated correctly",{ - ggiris <- iris.base + theme(axis.ticks=element_line(colour="red")) + - theme(panel.grid.major=element_line(colour="violet")) + ggiris <- iris.base + + theme(axis.ticks = element_line(colour = "red"), + panel.grid.major = element_line(colour = "violet")) info <- save_outputs(ggiris, "theme-ticks-and-grids") for (xy in c("x", "y")) { ax.list <- info$layout[[paste0(xy, "axis")]] - expect_identical(ax.list$tickcolor, toRGB("red")) - expect_identical(ax.list$gridcolor, toRGB("violet")) + expect_true(ax.list$tickcolor == toRGB("red")) + expect_true(ax.list$gridcolor == toRGB("violet")) } }) @@ -42,21 +44,15 @@ test_that("do not show zeroline by default", { } }) -test_that("dotted/dashed grid translated as line with alpha=0.1",{ - ggiris <- iris.base + theme(panel.grid.major=element_line(linetype="dashed")) - info <- save_outputs(ggiris, "theme-dashed-grid-lines") - for (xy in c("x", "y")) { - ax.list <- info$layout[[paste0(xy, "axis")]] - expect_identical(ax.list$gridcolor, toRGB("white", 0.1)) - } -}) +countrypop <- data.frame( + country = c("Paraguay", "Peru", "Philippines"), + population = c(7, 31, 101), + edu = c(4.2, 1.75, 1.33), + illn = c(0.38, 1.67, 0.43) +) -countrypop <- data.frame(country=c("Paraguay", "Peru", "Philippines"), - population=c(7, 31, 101), - edu=c(4.2, 1.75, 1.33), - illn=c(0.38, 1.67, 0.43)) gg <- ggplot(countrypop) + - geom_point(aes(edu, illn, colour=country, size=population)) + geom_point(aes(edu, illn, colour = country, size = population)) test_that("marker default shape is a circle", { info <- save_outputs(gg, "theme-marker-default") @@ -69,19 +65,12 @@ test_that("marker default shape is a circle", { test_that("plot panel border is translated correctly", { ggiris <- iris.base + theme_grey() # has no panel.border info <- save_outputs(ggiris, "theme-panel-border-1") - for (xy in c("x", "y")) { - ax.list <- info$layout[[paste0(xy, "axis")]] - expect_identical(ax.list$showline, FALSE) - } - + red <- ggplot(iris) + theme_grey() + geom_point(aes(Petal.Width, Sepal.Width)) + - theme(panel.border=element_rect(colour="red", fill=NA)) + theme(panel.border = element_rect(colour = "red", fill = NA)) + info <- save_outputs(red, "theme-panel-border-2") - for (xy in c("x", "y")) { - ax.list <- info$layout[[paste0(xy, "axis")]] - expect_identical(ax.list$showline, TRUE) - expect_identical(ax.list$linecolor, toRGB("red")) - } + expect_true(info$layout$shapes[[1]]$line$color == toRGB("red")) }) diff --git a/tests/testthat/test-ggplot-ticks.R b/tests/testthat/test-ggplot-ticks.R index 052e0ca891..3edd464eb0 100644 --- a/tests/testthat/test-ggplot-ticks.R +++ b/tests/testthat/test-ggplot-ticks.R @@ -17,183 +17,84 @@ expect_traces <- function(gg, n.traces, name){ list(data = has.data, layout = L$layout) } -plant.list <- split(PlantGrowth, PlantGrowth$group) -weight.range <- range(PlantGrowth$weight) test_that("boxes without coord_flip()", { - info <- expect_traces(boxes, 3, "boxes") - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + info <- expect_traces(boxes, 1, "boxes") }) test_that("boxes with facet_grid", { facets <- boxes + facet_grid(. ~ type) - info <- expect_traces(facets, 3, "boxes-facet-grid") - ## TODO: expect boxes of equal size. - - ## TODO: expect empty space. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + info <- expect_traces(facets, 2, "boxes-facet-grid") }) test_that('boxes with facet_grid(scales="free")', { - facets.scales <- boxes + facet_grid(. ~ type, scales="free") - info <- expect_traces(facets.scales, 3, "boxes-scales-free") - ## TODO: expect boxes of unequal size. - - ## TODO: expect no empty space. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + facets.scales <- boxes + facet_grid(. ~ type, scales = "free") + info <- expect_traces(facets.scales, 2, "boxes-scales-free") }) test_that('boxes with facet_grid(scales="free", space="free")', { - facets.space <- boxes + facet_grid(. ~ type, scales="free", space="free") - info <- expect_traces(facets.space, 3, "boxes-space-free") - ## TODO: expect boxes of equal size. - - ## TODO: expect no empty space. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + ## TODO: implement space free! + facets.space <- boxes + facet_grid(. ~ type, scales = "free", space = "free") + info <- expect_traces(facets.space, 2, "boxes-space-free") }) flipped <- boxes + coord_flip() test_that("boxes with coord_flip()", { - info <- expect_traces(flipped, 3, "flip") - for(tr in info$data){ - expect_true(is.null(tr[["y"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["x"]] - expect_equal(computed, expected) - } + info <- expect_traces(flipped, 1, "flip") }) -## coord_flip + facets are not really even supported in ggplot2, so -## these tests are disabled for now. - test_that("boxes with coord_flip()+facet_grid()", { flip.facet <- flipped + facet_grid(type ~ .) - ##info <- expect_traces(flip.facet, 3) - ## for(tr in info$data){ - ## expect_true(is.null(tr[["y"]])) - ## expected <- plant.list[[tr$name]]$weight - ## computed <- tr[["x"]] - ## expect_equal(computed, expected) - ## } + info <- expect_traces(flip.facet, 2, "flip-grid") }) test_that('boxes with coord_flip()+facet_grid(scales="free")', { - flip.facet.scales <- flipped + facet_grid(type ~ ., scales="free") - ##info <- expect_traces(flip.facet.scales, 3) - ## for(tr in info$data){ - ## expect_true(is.null(tr[["y"]])) - ## expected <- plant.list[[tr$name]]$weight - ## computed <- tr[["x"]] - ## expect_equal(computed, expected) - ## } -}) - -test_that('boxes+coord_flip()+facet_grid(scales="free", space="free")', { - flip.facet.space <- flipped + - facet_grid(type ~ ., scales="free", space="free") - ## BUG in ggplot2! -}) - -test_that('boxes+facet_grid(scales="free", space="free")+coord_flip()', { - flip.facet.space <- boxes + - facet_grid(type ~ ., scales="free", space="free")+ - coord_flip() - ## BUG in ggplot2! -}) - -test_that("Manually set the order of a discrete-valued axis", { - expected.order <- c("trt1", "ctrl", "trt2") - boxes.limits <- boxes + scale_x_discrete(limits=expected.order) - info <- expect_traces(boxes.limits, 3, "discrete-order") - computed.order <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.order), expected.order) + # bug in ggplot2? + flip.facet.scales <- flipped + facet_grid(type ~ ., scales = "free") + info <- expect_traces(flip.facet.scales, 2, "flip-grid-free") }) test_that("limits can hide data", { - expected.order <- c("trt1", "ctrl") - boxes.limits <- boxes + scale_x_discrete(limits=expected.order) - info <- expect_traces(boxes.limits, 2, "limits-hide") - computed.order <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.order), expected.order) + boxes.limits <- boxes + scale_x_discrete(limits = c("trt1", "ctrl")) + info <- expect_traces(boxes.limits, 1, "limits-hide") + expect_identical(info$layout$xaxis$ticktext, c("trt1", "ctrl")) }) test_that("limits can create a gap", { - expected.order <- c("trt1", "trt2", "GAP", "ctrl") - boxes.limits <- boxes + scale_x_discrete(limits=expected.order) - info <- expect_traces(boxes.limits, 3, "limits-gap") - computed.order <- sapply(info$data, "[[", "name") - ##expect_identical(as.character(computed.order), expected.order) - - ## TODO: can we make this in plotly? + boxes.limits <- boxes + scale_x_discrete(limits = c("trt1", "trt2", "GAP", "ctrl")) + info <- expect_traces(boxes.limits, 1, "limits-gap") + expect_identical(info$layout$xaxis$ticktext, c("trt1", "trt2", "GAP", "ctrl")) }) boxes.breaks <- boxes + - scale_x_discrete(breaks=c("trt1", "ctrl", "trt2")) + scale_x_discrete(breaks = c("trt1", "ctrl", "trt2")) test_that("setting breaks does not change order", { - info <- expect_traces(boxes.breaks, 3, "breaks-nochange") - computed.labels <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.labels), c("ctrl", "trt1", "trt2")) - ## For some reason plotly does not render the third box if range is - ## not NULL. - expect_identical(info$kwargs$layout$xaxis$range, NULL) + info <- expect_traces(boxes.breaks, 1, "breaks-nochange") + expect_identical( + info$layout$xaxis$ticktext[info$layout$xaxis$tickvals], + c("ctrl", "trt1", "trt2") + ) }) boxes.more <- boxes + - scale_x_discrete(breaks=c("trt1", "ctrl", "trt2", "FOO")) + scale_x_discrete(breaks = c("trt1", "ctrl", "trt2", "FOO")) test_that("more breaks is fine", { - info <- expect_traces(boxes.more, 3, "breaks-more") - computed.labels <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.labels), c("ctrl", "trt1", "trt2")) - ## For some reason plotly does not render the third box if range is - ## not NULL. - expect_identical(info$kwargs$layout$xaxis$range, NULL) + info <- expect_traces(boxes.more, 1, "breaks-more") + expect_identical( + info$layout$xaxis$ticktext[info$layout$xaxis$tickvals], + c("ctrl", "trt1", "trt2") + ) }) boxes.less <- boxes + scale_x_discrete(breaks=c("trt1", "ctrl")) test_that("less breaks is fine", { - ## L <- gg2list(boxes.less) - ## sendJSON(L) # 2 boxes - ## sendJSON(L[1:3]) # 3 boxes - ## no.xaxis <- L - ## no.xaxis$kwargs$layout$xaxis <- NULL - ## sendJSON(no.xaxis) # 3 boxes - ## no.xrange <- L - ## no.xrange$kwargs$layout$xaxis$range <- NULL - ## sendJSON(no.xrange) # 3 boxes - info <- expect_traces(boxes.less, 3, "breaks-less") - computed.labels <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.labels), c("ctrl", "trt1", "trt2")) - ## For some reason plotly does not render the third box if range is - ## not NULL. - expect_identical(info$kwargs$layout$xaxis$range, NULL) - - ## TODO: as of 20 Feb 2015 it is not possible to make this in - ## plotly. (no boxes but only 2 tick labels) + info <- expect_traces(boxes.less, 1, "breaks-less") + expect_identical(info$layout$xaxis$ticktext, c("trt1", "ctrl")) }) boxes.labels <- boxes + @@ -201,146 +102,75 @@ boxes.labels <- boxes + labels=c("Treatment 1", "Control", "Treatment 2")) test_that("scale(labels) changes trace names", { - info <- expect_traces(boxes.labels, 3, "scale-labels") - computed.labels <- sapply(info$data, "[[", "name") - expect_identical(as.character(computed.labels), - c("Control", "Treatment 1", "Treatment 2")) - ## For some reason plotly does not render the third box if range is - ## not NULL. - expect_identical(info$kwargs$layout$xaxis$range, NULL) + info <- expect_traces(boxes.labels, 1, "scale-labels") + expect_identical( + info$layout$xaxis$ticktext, + c("Treatment 1", "Control", "Treatment 2") + ) }) -no.breaks <- boxes + scale_x_discrete(breaks=NULL) +no.breaks <- boxes + scale_x_discrete(breaks = NULL) test_that("hide x ticks, lines, and labels", { - info <- expect_traces(no.breaks, 3, "hide-ticks-lines-labels") - x <- info$layout$xaxis - expect_identical(x[["showticklabels"]], FALSE) - ##expect_identical(x[["showline"]], FALSE) #irrelevant. - expect_identical(x[["showgrid"]], FALSE) - - ## ticks ('' | 'inside' | 'outside') Sets the format of the ticks on - ## this axis. For hidden ticks, link 'ticks' to an empty string. - expect_identical(x[["ticks"]], "") - - ## xaxis has parameter autotick (a boolean: TRUE | FALSE) Toggle - ## whether or not the axis ticks parameters are picked automatically - ## by Plotly. Once 'autotick' is set to FALSE, the axis ticks - ## parameters can be declared with 'ticks', 'tick0', 'dtick0' and - ## other tick-related key in this axis object. - ##expect_identical(x[["autotick"]], FALSE) #not necessary - - ## For some reason plotly does not render the third box if range is - ## not NULL. - expect_identical(info$kwargs$layout$xaxis$range, NULL) + info <- expect_traces(no.breaks, 1, "hide-ticks-lines-labels") + expect_true( + is.na(info$layout$xaxis$ticktext) || length(info$layout$xaxis$ticktext) == 0 + ) + expect_true( + is.na(info$layout$xaxis$tickvals) || length(info$layout$xaxis$tickvals) == 0 + ) }) test_that("Hide X ticks and labels, but keep the gridlines", { boxes.grid <- boxes + theme(axis.ticks = element_blank(), axis.text.x = element_blank()) - info <- expect_traces(boxes.grid, 3, "hide-ticks-labels") + info <- expect_traces(boxes.grid, 1, "hide-ticks-labels") x <- info$layout$xaxis - expect_identical(x[["showticklabels"]], FALSE) - expect_identical(x[["showgrid"]], TRUE) - expect_identical(x[["ticks"]], "") + expect_false(x$showticklabels) + expect_true(x$showgrid) + expect_true(length(x$ticktext) == 3) }) test_that("scale_y_continuous(limits) means yaxis$ranges", { - boxes.range <- boxes + scale_y_continuous(limits=c(0,8)) - info <- expect_traces(boxes.range, 3, "ycontinuous-ranges") + boxes.range <- boxes + scale_y_continuous(limits = c(0,8)) + info <- expect_traces(boxes.range, 1, "ycontinuous-ranges") y.axis <- info$layout$yaxis - expect_equal(y.axis$range, c(0, 8)) + expect_equal(range(y.axis$tickvals), c(0, 8)) }) test_that("ylim() means yaxis$ranges", { - boxes.range <- boxes + ylim(0,8) - info <- expect_traces(boxes.range, 3, "ylim-ranges") + boxes.range <- boxes + ylim(0, 8) + info <- expect_traces(boxes.range, 1, "ylim-ranges") y.axis <- info$layout$yaxis - expect_equal(y.axis$range, c(0, 8)) - ## ensure correct positive values without reverse scale. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + expect_equal(range(y.axis$tickvals), c(0, 8)) }) test_that("scale_y_reverse() -> yaxis$ranges reversed", { boxes.reverse <- boxes + scale_y_reverse() - info <- expect_traces(boxes.reverse, 3, "yreverse-ranges") - y.axis <- info$layout$yaxis - expect_that(y.axis$range[2], is_less_than(y.axis$range[1])) - ## ensure correct positive values, despite the reverse scale. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + info <- expect_traces(boxes.reverse, 1, "yreverse-ranges") }) test_that("scale_y_reverse(limits) -> yaxis$ranges reversed", { - y.lim <- c(10, -2) - boxes.reverse <- boxes + scale_y_reverse(limits=y.lim) - info <- expect_traces(boxes.reverse, 3, "yreverse-limits-ranges") - y.axis <- info$layout$yaxis - expect_equal(y.axis$range, y.lim) - ## ensure correct positive values, despite the reverse scale. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + boxes.reverse <- boxes + scale_y_reverse(limits = c(10, -2)) + info <- expect_traces(boxes.reverse, 1, "yreverse-limits-ranges") }) test_that("ylim(reversed) -> yaxis$ranges reversed", { boxes.reverse <- boxes + ylim(7.5, -1) - info <- expect_traces(boxes.reverse, 3, "ylim-reversed-ranges") - y.axis <- info$layout$yaxis - expect_equal(y.axis$range, c(7.5, -1)) - ## ensure correct positive values, despite the reverse scale. - for(tr in info$data){ - expect_true(is.null(tr[["x"]])) - expected <- plant.list[[tr$name]]$weight - computed <- tr[["y"]] - expect_equal(computed, expected) - } + info <- expect_traces(boxes.reverse, 1, "ylim-reversed-ranges") }) test_that("Set the X tick mark locations", { ## This will show tick marks on every 0.25 from 1 to 10. The scale will ## show only the ones that are within range (3.50-6.25 in this case) - boxes.ticks <- boxes + scale_y_continuous(breaks=seq(1,10,1/4)) - info <- expect_traces(boxes.ticks, 3, "evenly-spaced-ticks") + boxes.ticks <- boxes + scale_y_continuous(breaks = seq(4, 5, length.out = 12)) + info <- expect_traces(boxes.ticks, 1, "evenly-spaced-ticks") y.axis <- info$layout$yaxis - expect_equal(y.axis$dtick, 0.25) - expect_identical(y.axis$autotick, FALSE) + expect_equal(length(y.axis$ticktext), 12) }) test_that("The breaks can be spaced unevenly", { boxes.uneven <- boxes + - scale_y_continuous(breaks=c(4, 4.25, 4.5, 5, 6,8)) - ##TODO: is this possible in plotly? - ## https://plot.ly/python/reference/#YAxis -}) - -test_that("hide y ticks, lines, and labels", { - no.breaks <- boxes + scale_y_continuous(breaks=NULL) - info <- expect_traces(no.breaks, 3, "hide-y") - y.axis <- info$layout$yaxis - expect_identical(y.axis[["showgrid"]], FALSE) - expect_identical(y.axis[["ticks"]], "") - expect_identical(y.axis[["showticklabels"]], FALSE) -}) - -test_that("hide y ticks and labels, but keep the gridlines", { - boxes.ygrid <- boxes + - theme(axis.ticks = element_blank(), axis.text.y = element_blank()) - info <- expect_traces(boxes.ygrid, 3, "hide-y-keep-grid") - y.axis <- info$layout$yaxis - expect_identical(y.axis[["showgrid"]], TRUE) - expect_identical(y.axis[["ticks"]], "") - expect_identical(y.axis[["showticklabels"]], FALSE) + scale_y_continuous(breaks = c(4, 4.25, 4.5, 5, 6, 8)) + info <- expect_traces(no.breaks, 1, "uneven") }) diff --git a/tests/testthat/test-ggplot-vline.R b/tests/testthat/test-ggplot-vline.R index 591dc4dbc6..f8406d530a 100644 --- a/tests/testthat/test-ggplot-vline.R +++ b/tests/testthat/test-ggplot-vline.R @@ -1,5 +1,4 @@ context("Vline") -# Vertical line x <- seq(0, 3.5, by = 0.5) y <- x * 0.95 @@ -16,8 +15,8 @@ test_that("second trace be the vline", { expect_equal(l$x[1], 1.1) expect_true(l$y[1] <= 0) expect_true(l$y[2] >= 3.325) - expect_identical(l$mode, "lines") - expect_identical(l$line$color, "rgb(0,255,0)") + expect_true(l$mode == "lines") + expect_true(l$line$color == "rgb(0,255,0)") }) test_that("vector xintercept results in multiple vertical lines", { @@ -31,6 +30,6 @@ test_that("vector xintercept results in multiple vertical lines", { expect_identical(xs, c(1, NA, 2)) expect_true(min(ys, na.rm = TRUE) <= min(y)) expect_true(max(ys, na.rm = TRUE) >= max(y)) - expect_identical(l$mode, "lines") - expect_identical(l$line$color, "rgb(0,0,255)") + expect_true(l$mode == "lines") + expect_true(l$line$color == "rgb(0,0,255)") }) diff --git a/tests/testthat/test-ggplot-ylim.R b/tests/testthat/test-ggplot-ylim.R index db0d27560d..550eebe14f 100644 --- a/tests/testthat/test-ggplot-ylim.R +++ b/tests/testthat/test-ggplot-ylim.R @@ -2,13 +2,14 @@ context("ggplot ylim") # http://www.cookbook-r.com/Graphs/Bar_and_line_graphs_%28ggplot2%29/ -df <- data.frame(time = factor(c("Lunch","Dinner"), levels=c("Lunch","Dinner")), - total_bill = c(14.89, 17.23)) +df <- data.frame( + time = factor(c("Lunch","Dinner"), levels = c("Lunch","Dinner")), + total_bill = c(14.89, 17.23) +) gg.ylim <- - ggplot(data=df, aes(x=time, y=total_bill, group=1)) + + ggplot(data = df, aes(x = time, y = total_bill, group = 1)) + geom_line() + - geom_point() + ylim(0, max(df$total_bill)) + xlab("Time of day") + ylab("Total bill") + ggtitle("Average bill for 2 people") @@ -23,13 +24,11 @@ expect_traces <- function(gg, n.traces, name){ }) has.data <- all.traces[!no.data] expect_equal(length(has.data), n.traces) - list(traces=has.data, layout=L$layout) + list(data = has.data, layout = L$layout) } test_that("ylim is respected for 1 trace", { info <- expect_traces(gg.ylim, 1, "one-trace") - expected.ylim <- c(0, max(df$total_bill)) - expect_equal(info$layout$yaxis$range, expected.ylim) - - expect_identical(info$traces[[1]]$showlegend, FALSE) + expect_equal(min(info$layout$yaxis$tickvals), 0) + expect_identical(info$data[[1]]$showlegend, FALSE) }) diff --git a/tests/testthat/test-mean-error-bars.R b/tests/testthat/test-mean-error-bars.R index 975a959095..8fe7f423bb 100644 --- a/tests/testthat/test-mean-error-bars.R +++ b/tests/testthat/test-mean-error-bars.R @@ -7,70 +7,18 @@ one.line.df <- data.frame( arrayminus = c(0.2, 0.4, 1, 0.2) ) -none.json <- list( - list( - x = c(1, 2, 3, 4), - y = c(2, 1, 3, 4), - error_y = list( - type = "data", - symmetric = FALSE, - array = c(0.1, 0.2, 0.1, 0.1), - arrayminus = c(0.2, 0.4, 1, 0.2) - ), - type = "scatter", - mode = "none" - ) -) - test_that("only asymmetric error bars", { error.gg <- ggplot(one.line.df, aes(x, y)) + geom_errorbar(aes(ymin = y - arrayminus, ymax = y + array)) - generated.json <- gg2list(error.gg) - traces <- generated.json$data - expect_identical(length(traces), 1L) - tr <- traces[[1]] - expect_identical(tr$mode, "none") - expect_identical(tr$type, "scatter") - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$symmetric, FALSE) - expect_equal(ey$array, c(0.1, 0.2, 0.1, 0.1)) - expect_equal(ey$arrayminus, c(0.2, 0.4, 1, 0.2)) + L <- save_outputs(error.gg, "error-simple") }) -one.line.json <- list( - list( - x = c(1, 2, 3, 4), - y = c(2, 1, 3, 4), - error_y = list( - type = "data", - symmetric = FALSE, - array = c(0.1, 0.2, 0.1, 0.1), - arrayminus = c(0.2, 0.4, 1, 0.2) - ), - type = "scatter" - ) -) - test_that("asymmetric error bars, geom_errorbar last", { one.line.gg <- ggplot(one.line.df, aes(x, y)) + geom_line() + geom_point() + geom_errorbar(aes(ymin = y - arrayminus, ymax = y + array)) - generated.json <- gg2list(one.line.gg) - ## when there is 1 trace with error bars, lines, and markers, plotly - ## shows error bars in the background, lines in the middle and - ## markers in front. - traces <- generated.json$data - expect_identical(length(traces), 1L) - tr <- traces[[1]] - expect_identical(tr$mode, "lines+markers") - expect_identical(tr$type, "scatter") - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$symmetric, FALSE) - expect_equal(ey$array, c(0.1, 0.2, 0.1, 0.1)) - expect_equal(ey$arrayminus, c(0.2, 0.4, 1, 0.2)) + L <- save_outputs(one.line.gg, "error-simple-line") }) test_that("asymmetric error bars, geom_errorbar first", { @@ -78,145 +26,13 @@ test_that("asymmetric error bars, geom_errorbar first", { geom_errorbar(aes(ymin = y - arrayminus, ymax = y + array)) + geom_line() + geom_point() - generated.json <- gg2list(one.line.gg) - traces <- generated.json$data - expect_identical(length(traces), 1L) - tr <- traces[[1]] - expect_identical(tr$mode, "lines+markers") - expect_identical(tr$type, "scatter") - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$symmetric, FALSE) - expect_equal(ey$array, c(0.1, 0.2, 0.1, 0.1)) - expect_equal(ey$arrayminus, c(0.2, 0.4, 1, 0.2)) + L <- save_outputs(one.line.gg, "error-simple-line-point") }) -colors.json <- list( - list( - x = c(1, 2, 3, 4), - y = c(2, 1, 3, 4), - error_y = list( - type = "data", - symmetric = FALSE, - array = c(0.1, 0.2, 0.1, 0.1), - arrayminus = c(0.2, 0.4, 1, 0.2), - color="red" - ), - type = "scatter", - marker=list(color="blue", size=14), - line=list(color="violet") - ) -) - test_that("different colors for error bars, points, and lines", { one.line.gg <- ggplot(one.line.df, aes(x, y)) + geom_errorbar(aes(ymin = y - arrayminus, ymax = y + array), color = "red") + geom_line(color = "violet") + geom_point(color = "blue", size = 14) - generated.json <- gg2list(one.line.gg) - traces <- generated.json$data - expect_identical(length(traces), 1L) - tr <- traces[[1]] - expect_identical(tr$mode, "lines+markers") - expect_identical(tr$type, "scatter") - expect_identical(tr$marker$color, toRGB("blue")) - expect_identical(tr$line$color, toRGB("violet")) - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$color, toRGB("red")) - expect_identical(ey$symmetric, FALSE) - expect_equal(ey$array, c(0.1, 0.2, 0.1, 0.1)) - expect_equal(ey$arrayminus, c(0.2, 0.4, 1, 0.2)) -}) - -## from https://github.com/chriddyp/ggplot2-plotly-cookbook/blob/a45f2c70b7adf484e0b0eb8810a1e59e018adbb8/means_and_error_bars.R#L162-L191 -df <- ToothGrowth -## Summarizes data. -## Gives count, mean, standard deviation, standard error of the mean, and confidence interval (default 95%). -## data: a data frame. -## measurevar: the name of a column that contains the variable to be summariezed -## groupvars: a vector containing names of columns that contain grouping variables -## na.rm: a boolean that indicates whether to ignore NA's -## conf.interval: the percent range of the confidence interval (default is 95%) -summarySE <- function(data = NULL, measurevar, groupvars = NULL, na.rm = FALSE, - conf.interval = .95, .drop = TRUE) { - require(plyr) - length2 <- function (x, na.rm=FALSE) { - if (na.rm) sum(!is.na(x)) - else length(x) - } - datac <- ddply(data, groupvars, .drop=.drop, - .fun = function(xx, col) { - c(N = length2(xx[[col]], na.rm=na.rm), - mean = mean (xx[[col]], na.rm=na.rm), - sd = sd (xx[[col]], na.rm=na.rm) - ) - }, - measurevar - ) - datac <- rename(datac, c("mean" = measurevar)) - datac$se <- datac$sd / sqrt(datac$N) # Calculate standard error of the mean - ciMult <- qt(conf.interval/2 + .5, datac$N-1) - datac$ci <- datac$se * ciMult - return(datac) -} - -dfc <- summarySE(df, measurevar = "len", groupvars = c("supp", "dose")) -color.code <- c(OJ = "orange", VC = "violet") -supp.list <- split(dfc, dfc$supp) - -test_that("errorbar(aes(color)) + other geoms", { - before <- - ggplot(dfc, aes(x = dose, y = len, colour = supp)) + - geom_errorbar(aes(ymin = len - se, ymax = len + se), width = .1) + - geom_line() + - scale_color_manual(values = color.code)+ - geom_point() - - before.json <- gg2list(before) - traces <- before.json$data - - expect_identical(length(traces), 2L) - for(tr in traces) { - expected.color <- toRGB(color.code[[tr$name]]) - expected.data <- supp.list[[tr$name]] - expect_identical(tr$mode, "lines+markers") - expect_identical(tr$type, "scatter") - expect_identical(tr$marker$color, expected.color) - expect_identical(tr$line$color, expected.color) - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$color, expected.color) - expect_equal(ey$width, .1) - expect_identical(ey$symmetric, TRUE) - expect_equal(ey$array, expected.data$se) - } -}) - -test_that("other geoms + errorbar(aes(color))", { - after <- - ggplot(dfc, aes(x = dose, y = len, colour = supp)) + - geom_line() + - geom_errorbar(aes(ymin = len - se, ymax = len + se), width = .1) + - geom_point() + - scale_color_manual(values = color.code) - - after.json <- gg2list(after) - traces <- after.json$data - - expect_identical(length(traces), 2L) - for(tr in traces){ - expected.color <- toRGB(color.code[[tr$name]]) - expected.data <- supp.list[[tr$name]] - expect_identical(tr$mode, "lines+markers") - expect_identical(tr$type, "scatter") - expect_identical(tr$marker$color, expected.color) - expect_identical(tr$line$color, expected.color) - ey <- tr$error_y - expect_identical(ey$type, "data") - expect_identical(ey$color, expected.color) - expect_equal(ey$width, .1) - expect_identical(ey$symmetric, TRUE) - expect_equal(ey$array, expected.data$se) - } + L <- save_outputs(one.line.gg, "error-simple-line-point-crazy") }) diff --git a/tests/testthat/test-unimplemented.R b/tests/testthat/test-unimplemented.R deleted file mode 100644 index 7a0a58809b..0000000000 --- a/tests/testthat/test-unimplemented.R +++ /dev/null @@ -1,16 +0,0 @@ -context("Unimplemented geoms") - - -test_that("un-implemented geoms are ignored with a warning", { - - dmod <- lm(price ~ cut, data=diamonds) - cuts <- data.frame( - cut = unique(diamonds$cut), - predict(dmod, data.frame(cut = unique(diamonds$cut)), se=TRUE)[c("fit","se.fit")] - ) - se <- ggplot(cuts, aes(cut, fit, ymin = fit - se.fit, ymax = fit + se.fit, colour = cut)) - - expect_warning({ - info <- gg2list(se + geom_linerange()) - }, "geom_linerange() has yet to be implemented in plotly") -})