tooltip = "all", dynamicTicks = FALSE,

layerData = 1, originalData = TRUE, source = "A", ...) {

UseMethod("ggplotly", p)

tooltip = "all", dynamicTicks = FALSE,

layerData = 1, originalData = TRUE, source = "A", ...) {

p

height = NULL, tooltip = "all", dynamicTicks = FALSE,

layerData = 1, originalData = TRUE, source = "A", ...) {

dots <- list(...)

# provide a sensible crosstalk if none is already provided (makes ggnostic() work at least)

if (!crosstalk_key() %in% names(p$data)) {

p$data[[crosstalk_key()]] <- p$data[[".rownames"]] %||% seq_len(nrow(p$data))

attr(p$data, "set") <- dots[["set"]] %||% new_id()

}

subplotList <- list()

for (i in seq_len(p$ncol)) {

columnList <- list()

for (j in seq_len(p$nrow)) {

thisPlot <- p[j, i]

if (i == 1) {

# should the first column contain axis labels?

if (p$showYAxisPlotLabels %||% TRUE) thisPlot <- thisPlot + ylab(p$yAxisLabels[j])

} else {

# y-axes are never drawn on the interior, and diagonal plots are densities,

# so it doesn't make sense to synch zoom actions on y

thisPlot <- thisPlot + ylab(NULL) +

theme(

axis.ticks.y = element_blank(),

axis.text.y = element_blank()

)

}

columnList <- c(

columnList, list(ggplotly(

thisPlot, tooltip = tooltip, dynamicTicks = dynamicTicks,

layerData = layerData, originalData = originalData, source = source,

width = width, height = height

))

)

}

# conditioned on a column in a ggmatrix, the x-axis should be on the

# same scale.

s <- subplot(columnList, nrows = p$nrow, margin = 0.01, shareX = TRUE,

titleY = TRUE, titleX = TRUE)

subplotList <- c(subplotList, list(s))

}

s <- subplot(subplotList, nrows = 1, margin = 0.01,

titleY = TRUE, titleX = TRUE) %>%

hide_legend() %>%

layout(dragmode = "select")

if (nchar(p$title %||% "") > 0) {

s <- layout(s, title = p$title)

}

for (i in seq_along(p$xAxisLabels)) {

s$x$layout[[sub("^xaxis1$", "xaxis", paste0("xaxis", i))]]$title <- p$xAxisLabels[[i]]

}

if (length(p$yAxisLabels)) {

s$x$layout$margin$l <- s$x$layout$margin$l + 50

}

config(s)

height = NULL, tooltip = "all", dynamicTicks = FALSE,

layerData = 1, originalData = TRUE, source = "A", ...) {

l <- gg2list(p, width = width, height = height, tooltip = tooltip,

dynamicTicks = dynamicTicks, layerData = layerData,

originalData = originalData, source = source, ...)

config(as_widget(l))

tooltip = "all", dynamicTicks = FALSE,

layerData = 1, originalData = TRUE, source = "A", ...) {

# To convert relative sizes correctly, we use grid::convertHeight(),

# which may open a new *screen* device, if none is currently open.

# To avoid undesirable side effects, we may need to open a

# non-interactive device and close it on exit...

# https://github.com/att/rcloud.htmlwidgets/issues/2

# Note that we never have to open a non-interactive device

# in RStudio since it ships with one. Plus, calling dev.size()

# adds it to dev.list() & should ensure grid can query the correct device size

rStudioDevSize <- if (is_rstudio()) grDevices::dev.size("px")

if (is.null(grDevices::dev.list())) {

dev_fun <- if (system.file(package = "Cairo") != "") {

Cairo::Cairo

} else if (capabilities("png")) {

grDevices::png

} else if (capabilities("jpeg")) {

grDevices::jpeg

} else {

stop(

"No graphics device is currently open and no cairo or bitmap device is available.\n",

"A graphics device is required to convert sizes correctly. You have three options:",

" (1) Open a graphics device (with the desired size) using ggplotly()",

" (2) install.packages('Cairo')",

" (3) compile R to use a bitmap device (png or jpeg)",

call. = FALSE

)

}

dev_fun(file = tempfile(), width = width %||% 640, height = height %||% 480)

on.exit(grDevices::dev.off(), add = TRUE)

}

# check the value of dynamicTicks

dynamicValues <- c(FALSE, TRUE, "x", "y")

if (length(setdiff(dynamicTicks, dynamicValues))) {

stop(

sprintf(

"`dynamicValues` accepts the following values: '%s'",

paste(dynamicValues, collapse = "', '")

), call. = FALSE

)

}

# we currently support ggplot2 >= 2.2.1 (see DESCRIPTION)

# there are too many naming changes in 2.2.1.9000 to realistically

if (!is_dev_ggplot2()) {

message(

"We recommend that you use the dev version of ggplot2 with `ggplotly()`\n",

"Install it with: `devtools::install_github('tidyverse/ggplot2')`"

)

if (!identical(dynamicTicks, FALSE)) {

warning(

"You need the dev version of ggplot2 to use `dynamicTicks`", call. = FALSE

)

}

return(

gg2list_legacy(

p, width = width, height = height, tooltip = tooltip,

layerData = layerData, originalData = originalData, source = source, ...

)

)

}

# ------------------------------------------------------------------------

# Our internal version of ggplot2::ggplot_build(). Modified from

# https://github.com/hadley/ggplot2/blob/0cd0ba/R/plot-build.r#L18-L92

# ------------------------------------------------------------------------

plot <- ggfun("plot_clone")(p)

if (length(plot$layers) == 0) {

plot <- plot + geom_blank()

}

layers <- plot$layers

layer_data <- lapply(layers, function(y) y$layer_data(plot$data))

# save crosstalk sets before this attribute gets squashed

sets <- lapply(layer_data, function(y) attr(y, "set"))

scales <- plot$scales

# Apply function to layer and matching data

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

}

# Initialise panels, add extra data for margins & missing facetting

# variables, and add on a PANEL variable to data

layout <- ggfun("create_layout")(plot$facet, plot$coordinates)

data <- layout$setup(layer_data, plot$data, plot$plot_env)

# save the domain of the group for display in tooltips

groupDomains <- Map(function(x, y) {

tryCatch(

eval(y$mapping[["group"]] %||% plot$mapping[["group"]], x),

error = function(e) NULL

)

}, data, layers)

# for simple (StatIdentity) geoms, add crosstalk key to aes mapping

# (effectively adding it as a group)

# later on, for more complicated geoms (w/ non-trivial summary statistics),

# we construct a nested key mapping (within group)

layers <- Map(function(x, y) {

if (crosstalk_key() %in% names(y) && !"key" %in% names(x[["mapping"]]) &&

inherits(x[["stat"]], "StatIdentity")) {

x[["mapping"]] <- c(x[["mapping"]], key = as.name(crosstalk_key()))

}

x

}, layers, layer_data)

# Compute aesthetics to produce data with generalised variable names

data <- by_layer(function(l, d) l$compute_aesthetics(d, plot))

# add frame to group if it exists

data <- lapply(data, function(d) {

if (!"frame" %in% names(d)) return(d)

d$group <- with(d, paste(group, frame, sep = "-"))

d

})

# The computed aesthetic codes the groups as integers

# Here we build a map each of the integer values to the group label

group_maps <- Map(function(x, y) {

tryCatch({

x_group <- x[["group"]]

names(x_group) <- y

x_group <- x_group[!duplicated(x_group)]

x_group

}, error = function(e) NULL

)

}, data, groupDomains)

# Before mapping x/y position, save the domain (for discrete scales)

# to display in tooltip.

data <- lapply(data, function(d) {

d[["x_plotlyDomain"]] <- d[["x"]]

d[["y_plotlyDomain"]] <- d[["y"]]

d

})

# Transform all scales

data <- lapply(data, ggfun("scales_transform_df"), scales = scales)

# Map and train positions so that statistics have access to ranges

# and all positions are numeric

scale_x <- function() scales$get_scales("x")

scale_y <- function() scales$get_scales("y")

layout$train_position(data, scale_x(), scale_y())

data <- layout$map_position(data)

# build a mapping between group and key

# if there are multiple keys within a group, the key is a list-column

reComputeGroup <- function(x, layer = NULL) {

# 1-to-1 link between data & visual marks -- group == key

if (inherits(layer$geom, "GeomDotplot")) {

x <- split(x, x[["PANEL"]])

x <- lapply(x, function(d) {

d[["group"]] <- do.call("order", d[c("x", "group")])

d

})

x <- dplyr::bind_rows(x)

}

if (inherits(layer$geom, "GeomSf")) {

x <- split(x, x[["PANEL"]])

x <- lapply(x, function(d) {

d[["group"]] <- seq_len(nrow(d))

d

})

# I think this is safe?

x <- suppressWarnings(dplyr::bind_rows(x))

}

x

}

nestedKeys <- Map(function(x, y, z) {

key <- y[[crosstalk_key()]]

if (is.null(key) || inherits(z[["stat"]], "StatIdentity")) return(NULL)

x <- reComputeGroup(x, z)

tib <- tibble::as_tibble(x[c("PANEL", "group")])

tib[["key"]] <- key

nested <- tidyr::nest(tib, key, .key = key)

# reduce the dimensions of list column elements from 2 to 1

nested$key <- lapply(nested$key, function(x) x[[1]])

nested

}, data, layer_data, layers)

# for some geoms (e.g. boxplots) plotly.js needs the "pre-statistics" data

# we also now provide the option to return one of these two

prestats_data <- data

data <- by_layer(function(l, d) l$compute_statistic(d, layout))

data <- by_layer(function(l, d) l$map_statistic(d, plot))

# Make sure missing (but required) aesthetics are added

ggfun("scales_add_missing")(plot, c("x", "y"), plot$plot_env)

# Reparameterise geoms from (e.g.) y and width to ymin and ymax

data <- by_layer(function(l, d) l$compute_geom_1(d))

# compute_geom_1 can reorder the rows from `data`, making groupDomains

# invalid. We rebuild groupDomains based on the current `data` and the

# group map we built before.

groupDomains <- Map(function(x, y) {

tryCatch({

names(y)[match(x$group, y)]

}, error = function(e) NULL

)

}, data, group_maps)

# there are some geoms (e.g. geom_dotplot()) where attaching the key

# before applying the statistic can cause problems, but there is still a

# 1-to-1 corresponding between graphical marks and

# Apply position adjustments

data <- by_layer(function(l, d) l$compute_position(d, layout))

# Reset position scales, then re-train and map. This ensures that facets

# have control over the range of a plot: is it generated from what's

# displayed, or does it include the range of underlying data

layout$reset_scales()

layout$train_position(data, scale_x(), scale_y())

layout$setup_panel_params()

data <- layout$map_position(data)

# Train and map non-position scales

npscales <- scales$non_position_scales()

if (npscales$n() > 0) {

lapply(data, ggfun("scales_train_df"), scales = npscales)

# this for loop is unique to plotly -- it saves the "domain"

# of each non-positional scale for display in tooltips

for (sc in npscales$scales) {

data <- lapply(data, function(d) {

# scale may not be relevant for every layer data

if (any(names(d) %in% sc$aesthetics)) {

d[paste0(sc$aesthetics, "_plotlyDomain")] <- d[sc$aesthetics]

}

d

})

}

data <- lapply(data, ggfun("scales_map_df"), scales = npscales)

}

# Fill in defaults etc.

data <- by_layer(function(l, d) l$compute_geom_2(d))

# Let layer stat have a final say before rendering

data <- by_layer(function(l, d) l$finish_statistics(d))

# Let Layout modify data before rendering

data <- layout$finish_data(data)

# ------------------------------------------------------------------------

# end of ggplot_build()

# ------------------------------------------------------------------------

# if necessary, attach key

data <- Map(function(x, y, z) {

if (!length(y)) return(x)

x <- reComputeGroup(x, z)

# dplyr issue??? https://github.com/tidyverse/dplyr/issues/2701

attr(y$group, "n") <- NULL

suppressMessages(dplyr::left_join(x, y))

}, data, nestedKeys, layers)

# initiate plotly.js layout with some plot-wide theming stuff

theme <- ggfun("plot_theme")(plot)

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(plot$labels$title %||% "") > 0) {

gglayout$title <- faced(plot$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

# important stuff like layout$panel_params is already flipped, but

# plot$scales/plot$labels/data aren't. We flip x/y trace data at the very end

# and scales in the axis loop below.

if (inherits(plot$coordinates, "CoordFlip")) {

plot$labels[c("x", "y")] <- plot$labels[c("y", "x")]

}

# important panel summary stats

nPanels <- nrow(layout$layout)

nRows <- max(layout$layout$ROW)

nCols <- max(layout$layout$COL)

# panel -> plotly.js axis/anchor info

# (assume a grid layout by default)

layout$layout$xaxis <- layout$layout$COL

layout$layout$yaxis <- layout$layout$ROW

layout$layout$xanchor <- nRows

layout$layout$yanchor <- 1

if (inherits(plot$facet, "FacetWrap")) {

if (plot$facet$params$free$x) {

layout$layout$xaxis <- layout$layout$PANEL

layout$layout$xanchor <- layout$layout$ROW

}

if (plot$facet$params$free$y) {

layout$layout$yaxis <- layout$layout$PANEL

layout$layout$yanchor <- layout$layout$COL

layout$layout$xanchor <- nPanels

}

if (plot$facet$params$free$x && plot$facet$params$free$y) {

layout$layout$xaxis <- layout$layout$PANEL

layout$layout$yaxis <- layout$layout$PANEL

layout$layout$xanchor <- layout$layout$PANEL

layout$layout$yanchor <- layout$layout$PANEL

}

}

# format the axis/anchor to a format plotly.js respects

layout$layout$xaxis <- paste0("xaxis", sub("^1$", "", layout$layout$xaxis))

layout$layout$yaxis <- paste0("yaxis", sub("^1$", "", layout$layout$yaxis))

layout$layout$xanchor <- paste0("y", sub("^1$", "", layout$layout$xanchor))

layout$layout$yanchor <- paste0("x", sub("^1$", "", layout$layout$yanchor))

# for some layers2traces computations, we need the range of each panel

layout$layout$x_min <- sapply(layout$panel_params, function(z) min(z$x.range %||% z$x_range))

layout$layout$x_max <- sapply(layout$panel_params, function(z) max(z$x.range %||% z$x_range))

layout$layout$y_min <- sapply(layout$panel_params, function(z) min(z$y.range %||% z$y_range))

layout$layout$y_max <- sapply(layout$panel_params, function(z) max(z$y.range %||% z$y_range))

# layers -> plotly.js traces

plot$tooltip <- tooltip

data <- Map(function(x, y) {

tryCatch({ x$group_plotlyDomain <- y; x }, error = function(e) x)

}, data, groupDomains)

# reattach crosstalk key-set attribute

data <- Map(function(x, y) structure(x, set = y), data, sets)

traces <- layers2traces(data, prestats_data, layout, plot)

gglayout <- layers2layout(gglayout, layers, layout$layout)

# default to just the text in hover info, mainly because of this

# https://github.com/plotly/plotly.js/issues/320

traces <- lapply(traces, function(tr) {

tr$hoverinfo <- tr$hoverinfo %||%"text"

tr

})

# show only one legend entry per legendgroup

grps <- sapply(traces, "[[", "legendgroup")

traces <- Map(function(x, y) {

if (!is.null(x[["frame"]])) return(x)

x$showlegend <- isTRUE(x$showlegend) && y

x

}, traces, !duplicated(grps))

# ------------------------------------------------------------------------

# axis/facet/margin conversion

# ------------------------------------------------------------------------

# panel margins must be computed before panel/axis loops

# (in order to use get_domains())

panelMarginX <- unitConvert(

theme[["panel.spacing.x"]] %||% theme[["panel.spacing"]],

"npc", "width"

)

panelMarginY <- unitConvert(

theme[["panel.spacing.y"]] %||% theme[["panel.spacing"]],

"npc", "height"

)

# space for _interior_ facet strips

if (inherits(plot$facet, "FacetWrap")) {

stripSize <- unitConvert(

theme[["strip.text.x"]] %||% theme[["strip.text"]],

"npc", "height"

)

panelMarginY <- panelMarginY + stripSize

# space for ticks/text in free scales

if (plot$facet$params$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(layout$panel_params, "[[", "x.labels"))

lab <- labz[which.max(nchar(labz))]

panelMarginY <- panelMarginY + axisTicksX +

bbox(lab, axisTextX$angle, unitConvert(axisTextX, "npc", "height"))[["height"]]

}

if (plot$facet$params$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(layout$panel_params, "[[", "y.labels"))

lab <- labz[which.max(nchar(labz))]

panelMarginX <- panelMarginX + axisTicksY +

bbox(lab, axisTextY$angle, unitConvert(axisTextY, "npc", "width"))[["width"]]

}

}

margins <- c(

rep(panelMarginX, 2),

rep(panelMarginY, 2)

)

doms <- get_domains(nPanels, nRows, margins)

for (i in seq_len(nPanels)) {

lay <- layout$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 <- layout$panel_params[[i]]

# panel_params is quite different for "CoordSf"

if ("CoordSf" %in% class(p$coordinates)) {

# see CoordSf$render_axis_v

direction <- if (xy == "x") "E" else "N"

idx <- rng$graticule$type == direction & !is.na(rng$graticule$degree_label)

tickData <- rng$graticule[idx, ]

# TODO: how to convert a language object to unicode character string?

rng[[paste0(xy, ".labels")]] <- as.character(tickData[["degree_label"]])

rng[[paste0(xy, ".major")]] <- tickData[[paste0(xy, "_start")]]

# If it doesn't already exist (for this panel),

# generate graticule (as done in, CoordSf$render_bg)

isGrill <- vapply(traces, function(tr) {

identical(tr$xaxis, lay$xaxis) &&

identical(tr$yaxis, lay$yaxis) &&

isTRUE(tr$`_isGraticule`)

}, logical(1))

if (sum(isGrill) == 0) {

# TODO: reduce the number of points (via coord_munch?)

d <- expand(rng$graticule)

d$x <- scales::rescale(d$x, rng$x_range, from = c(0, 1))

d$y <- scales::rescale(d$y, rng$y_range, from = c(0, 1))

params <- list(

colour = theme$panel.grid.major$colour,

size = theme$panel.grid.major$size,

linetype = theme$panel.grid.major$linetype

)

grill <- geom2trace.GeomPath(d, params)

grill$hoverinfo <- "none"

grill$showlegend <- FALSE

grill$`_isGraticule` <- TRUE

grill$xaxis <- sub("axis", "", lay$xaxis)

grill$yaxis <- sub("axis", "", lay$yaxis)

traces <- c(list(grill), traces)

}

# if labels are empty, don't show axis ticks

tickExists <- with(rng$graticule, sapply(degree_label, is.language))

if (sum(tickExists) == 0) {

theme$axis.ticks.length <- 0

} else{

# convert the special *degree expression in plotmath to HTML entity

# TODO: can this be done more generally for all ?

rng[[paste0(xy, ".labels")]] <- sub(

"\\*\\s+degree[ ]?[\\*]?", "&#176;", rng[[paste0(xy, ".labels")]]

)

}

}

# stuff like layout$panel_params is already flipped, but scales aren't

sc <- if (inherits(plot$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"

# get axis title

axisTitleText <- sc$name %||% plot$labels[[xy]] %||% ""

if (is_blank(axisTitle)) axisTitleText <- ""

# is this axis dynamic?

isDynamic <- isTRUE(dynamicTicks) || identical(dynamicTicks, xy)

if (isDynamic && !p$coordinates$is_linear()) {

warning(

"`dynamicTicks` is only supported for linear (i.e., cartesian) coordinates",

call. = FALSE

)

}

# determine axis types (note: scale_name may go away someday)

# https://github.com/hadley/ggplot2/issues/1312

isDate <- isTRUE(sc$scale_name %in% c("date", "datetime"))

isDateType <- isDynamic && isDate

isDiscrete <- identical(sc$scale_name, "position_d")

isDiscreteType <- isDynamic && isDiscrete

axisObj <- list(

# TODO: log type?

type = if (isDateType) "date" else if (isDiscreteType) "category" else "linear",

autorange = isDynamic,

range = rng[[paste0(xy, ".range")]] %||% rng[[paste0(xy, "_range")]],

tickmode = if (isDynamic) "auto" else "array",

ticktext = rng[[paste0(xy, ".labels")]],

tickvals = rng[[paste0(xy, ".major")]],

categoryorder = "array",

categoryarray = rng[[paste0(xy, ".labels")]],

nticks = nrow(rng),

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, type),

tickangle = - (axisText$angle %||% 0),

showline = !is_blank(axisLine),

linecolor = toRGB(axisLine$colour),

linewidth = unitConvert(axisLine, "pixels", type),

# TODO: always `showgrid=FALSE` and implement our own using traces

showgrid = !is_blank(panelGrid) && !"CoordSf" %in% class(p$coordinates),

domain = sort(as.numeric(doms[i, paste0(xy, c("start", "end"))])),

gridcolor = toRGB(panelGrid$colour),

gridwidth = unitConvert(panelGrid, "pixels", type),

zeroline = FALSE,

anchor = anchor,

title = faced(axisTitleText, axisTitle$face),

titlefont = text2font(axisTitle)

)

# set scaleanchor/scaleratio if these are fixed coordinates

fixed_coords <- c("CoordSf", "CoordFixed", "CoordMap", "CoordQuickmap")

if (inherits(p$coordinates, fixed_coords)) {

axisObj$scaleanchor <- anchor

ratio <- p$coordinates$ratio %||% 1

# a la CoordSf$aspect

if (inherits(p$coordinates, "CoordSf")) {

if (isTRUE(sf::st_is_longlat(rng$crs))) {

ratio <- cos(mean(rng$y_range) * pi/180)

}

}

axisObj$scaleratio <- if (xy == "y") ratio else 1 / ratio

}

# TODO: should we implement aspect ratios?

if (!is.null(theme$aspect.ratio)) {

warning(

"Aspect ratios aren't yet implemented, but you can manually set",

" a suitable height/width", call. = FALSE

)

}

# 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)

)

# inverse transform date data based on tickvals/ticktext

invert_date <- function(x, scale) {

if (inherits(scale, "ScaleContinuousDatetime")) {

as.POSIXct(x, origin = "1970-01-01", tz = scale$timezone)

} else {

as.Date(x, origin = "1970-01-01", tz = scale$timezone)

}

}

if (isDateType) {

axisObj$range <- invert_date(axisObj$range, sc)

traces <- lapply(traces, function(tr) {

tr[[xy]] <- invert_date(tr[[xy]], sc)

# TODO: are there other similar cases we need to handle?

if (identical("bar", tr$type)) {

tr[["width"]] <- invert_date(tr[["width"]], sc)

}

tr

})

}

# inverse transform categorical data based on tickvals/ticktext

if (isDiscreteType) {

traces <- lapply(traces, function(tr) {

# map x/y trace data back to the 'closest' ticktext label

# http://r.789695.n4.nabble.com/check-for-nearest-value-in-a-vector-td4369339.html

tr[[xy]]<- vapply(tr[[xy]], function(val) {

with(axisObj, ticktext[[which.min(abs(tickvals - val))]])

}, character(1))

tr

})

if ("dodge" %in% sapply(layers, ggtype, "position")) gglayout$barmode <- "dodge"

}

# attach axis object to the layout

gglayout[[axisName]] <- axisObj

# do some stuff that should be done once for the entire plot

if (i == 1) {

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]]

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))

}

# add space for exterior facet strips in `layout.margin`

if (has_facet(plot)) {

stripSize <- unitConvert(stripText, "pixels", type)

if (xy == "x") {

gglayout$margin$t <- gglayout$margin$t + stripSize

}

if (xy == "y" && inherits(plot$facet, "FacetGrid")) {

gglayout$margin$r <- gglayout$margin$r + stripSize

}

# facets have multiple axis objects, but only one title for the plot,

# so we empty the titles and try to draw the title as an annotation

if (nchar(axisTitleText) > 0) {

# 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

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 = if (xy == "x") "center" else "right",

yanchor = if (xy == "x") "top" else "center",

annotationType = "axis"

)

)

}

}

}

if (has_facet(plot)) gglayout[[axisName]]$title <- ""

} # end of axis loop

# theme(panel.border = ) -> plotly rect shape

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

if (has_facet(plot)) {

col_vars <- ifelse(inherits(plot$facet, "FacetWrap"), "facets", "cols")

col_txt <- paste(

plot$facet$params$labeller(

lay[names(plot$facet$params[[col_vars]])]

), collapse = br()

)

if (is_blank(theme[["strip.text.x"]])) col_txt <- ""

if (inherits(plot$facet, "FacetGrid") && lay$ROW != 1) col_txt <- ""

if (nchar(col_txt) > 0) {

col_lab <- make_label(

col_txt, x = mean(xdom), y = max(ydom),

el = theme[["strip.text.x"]] %||% theme[["strip.text"]],

xanchor = "center", yanchor = "bottom"

)

gglayout$annotations <- c(gglayout$annotations, col_lab)

strip <- make_strip_rect(xdom, ydom, theme, "top")

gglayout$shapes <- c(gglayout$shapes, strip)

}

row_txt <- paste(

plot$facet$params$labeller(

lay[names(plot$facet$params$rows)]

), collapse = br()

)

if (is_blank(theme[["strip.text.y"]])) row_txt <- ""

if (inherits(plot$facet, "FacetGrid") && lay$COL != nCols) row_txt <- ""

if (nchar(row_txt) > 0) {

row_lab <- make_label(

row_txt, x = max(xdom), y = mean(ydom),

el = theme[["strip.text.y"]] %||% theme[["strip.text"]],

xanchor = "left", yanchor = "middle"

)

gglayout$annotations <- c(gglayout$annotations, row_lab)

strip <- make_strip_rect(xdom, ydom, theme, "right")

gglayout$shapes <- c(gglayout$shapes, strip)

}

}

} # end of panel loop

# ------------------------------------------------------------------------

# 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().

# ------------------------------------------------------------------------

# 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"

# 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

# 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"

}