color, colors = NULL, alpha = NULL,

stroke, strokes = NULL, alpha_stroke = 1,

size, sizes = c(10, 100),

span, spans = c(1, 20),

symbol, symbols = NULL,

linetype, linetypes = NULL,

split, frame,

width = NULL, height = NULL, source = "A") {

if (!is.data.frame(data) && !crosstalk::is.SharedData(data)) {

stop("First argument, `data`, must be a data frame or shared data.", call. = FALSE)

}

# "native" plotly arguments

attrs <- list(...)

# warn about old arguments that are no longer supported

for (i in c("filename", "fileopt", "world_readable")) {

if (is.null(attrs[[i]])) next

warning("Ignoring ", i, ". Use `plotly_POST()` if you want to post figures to plotly.")

attrs[[i]] <- NULL

}

if (!is.null(attrs[["group"]])) {

warning(

"The group argument has been deprecated. Use `group_by()` or split instead.\n",

"See `help('plotly_data')` for examples"

)

attrs[["group"]] <- NULL

}

if (!is.null(attrs[["inherit"]])) {

warning("The inherit argument has been deprecated.")

attrs[["inherit"]] <- NULL

}

# tack on variable mappings

attrs$name <- if (!missing(name)) name

attrs$color <- if (!missing(color)) color

attrs$stroke <- if (!missing(stroke)) stroke

attrs$size <- if (!missing(size)) size

attrs$span <- if (!missing(span)) span

attrs$symbol <- if (!missing(symbol)) symbol

attrs$linetype <- if (!missing(linetype)) linetype

attrs$split <- if (!missing(split)) split

attrs$frame <- if (!missing(frame)) frame

# tack on scale ranges

attrs$colors <- colors

attrs$strokes <- strokes

attrs$alpha <- alpha

attrs$alpha_stroke <- alpha_stroke

attrs$sizes <- sizes

attrs$spans <- spans

attrs$symbols <- symbols

attrs$linetypes <- linetypes

# and, of course, the trace type

attrs$type <- type

# id for tracking attribute mappings and finding the most current data

id <- new_id()

# avoid weird naming clashes

plotlyVisDat <- data

p <- list(

visdat = setNames(list(function() plotlyVisDat), id),

cur_data = id,

attrs = setNames(list(attrs), id),

# we always deal with a _list_ of traces and _list_ of layouts

# since they can each have different data

layout = list(

width = width,

height = height,

# sane margin defaults (mainly for RStudio)

margin = list(b = 40, l = 60, t = 25, r = 10)

),

source = source

)

# ensure the collab button is shown (and the save/edit button is hidden) by default

config(as_widget(p))

p <- config(plot_ly(data, ...), mapboxAccessToken = mapbox_token())

# not only do we use this for is_mapbox(), but also setting the layout attr

# https://plot.ly/r/reference/#layout-mapbox

p$x$layout$mapType <- "mapbox"

geo2cartesian(p)

p <- plot_ly(data, ...)

if (isTRUE(offline)) {

if (system.file(package = "plotlyGeoAssets") == "") {

stop(

"The plotlyGeoAssets package is required to make 'offline' maps. ",

"Please install and try again.",

call. = FALSE

)

}

p$dependencies <- c(

list(plotlyGeoAssets::geo_assets()),

p$dependencies

)

}

# not only do we use this for is_geo(), but also setting the layout attr

# https://plot.ly/r/reference/#layout-geo

p$x$layout$mapType <- "geo"

geo2cartesian(p)

# get x/y locations of every node in the tree

allXY <- get_xy(d)

# get non-zero heights so we can split on them and find the relevant labels

non0 <- allXY[["y"]][allXY[["y"]] > 0]

# splitting on the minimum height would generate all terminal nodes anyway

split <- non0[min(non0) < non0]

# label is a list-column since non-zero heights have multiple labels

# for now, we just have access to terminal node labels

labs <- labels(d)

allXY$label <- vector("list", nrow(allXY))

allXY$label[[1]] <- labs

allXY$label[allXY$y == 0] <- labs

# collect all the *unique* non-trivial nodes

nodes <- list()

for (i in split) {

dsub <- cut(d, i)$lower

for (j in seq_along(dsub)) {

s <- dsub[[j]]

if (is.leaf(s)) next

if (any(vapply(nodes, function(x) identical(x, s), logical(1)))) next

nodes[[length(nodes) + 1]] <- s

}

}

heights <- sapply(nodes, function(x) attr(x, "height"))

labs <- lapply(nodes, labels)

# NOTE: this won't support nodes that have the same height

# but that isn't possible, right?

for (i in seq_along(heights)) {

allXY$label[[which(allXY$y == heights[i])]] <- labs[[i]]

}

tidy_segments <- dendextend::as.ggdend(d)$segments

allTXT <- allXY[allXY$y == 0, ]

blank_axis <- list(

title = "",

showticklabels = FALSE,

zeroline = FALSE

)

allXY$members <- sapply(allXY$label, length)

allTXT$label <- as.character(allTXT$label)

allXY %>%

plot_ly(x = ~y, y = ~x, color = I("black"), hoverinfo = "none",

height = height, width = width) %>%

add_segments(

data = tidy_segments, xend = ~yend, yend = ~xend, showlegend = FALSE

) %>%

add_markers(

data = allXY[allXY$y > 0, ], key = ~label, set = set, name = "nodes",

text = ~paste0("members: ", members), hoverinfo = "text"

) %>%

add_text(

data = allTXT, x = 0, y = ~x, text = ~label, key = ~label, set = set,

textposition = "middle left", name = "labels"

) %>%

layout(

dragmode = "select",

xaxis = c(blank_axis, list(range = c(xmin, extendrange(allXY[["y"]])[2]))),

yaxis = c(blank_axis, list(range = extendrange(allXY[["x"]])))

)

m <- dendextend::get_nodes_xy(node)

colnames(m) <- c("x", "y")

tibble::as_tibble(m)

if (inherits(x, "htmlwidget")) return(x)

# add plotly class mainly for printing method

# customize the JSON serializer (for htmlwidgets)

attr(x, 'TOJSON_FUNC') <- to_JSON

htmlwidgets::createWidget(

name = "plotly",

x = x,

width = x$layout$width,

height = x$layout$height,

sizingPolicy = htmlwidgets::sizingPolicy(

browser.fill = TRUE,

defaultWidth = '100%',

defaultHeight = 400

),

preRenderHook = plotly_build,

dependencies = c(

list(typedArrayPolyfill()),

crosstalk::crosstalkLibs(),

list(plotlyHtmlwidgetsCSS()),

list(plotlyMainBundle())

)

)

htmltools::htmlDependency(

name = "typedarray",

version = "0.1",

package = "plotly",

src = dependency_dir("typedarray"),

script = "typedarray.min.js",

all_files = FALSE

)

htmltools::htmlDependency(

name = "plotly-main",

version = "1.49.4",

package = "plotly",

src = dependency_dir("plotlyjs"),

script = "plotly-latest.min.js",

all_files = FALSE

)

htmltools::htmlDependency(

name = "plotly-htmlwidgets-css",

version = plotlyMainBundle()$version,

package = "plotly",

src = dependency_dir("plotlyjs"),

stylesheet = "plotly-htmlwidgets.css",

all_files = FALSE

)

if (!is.character(locale) || length(locale) != 1) {

stop("locale must be a character string (vector of length 1)", call. = FALSE)

}

locale_dir <- dependency_dir("plotlyjs", "locales")

locales_all <- sub("\\.js$", "", list.files(system.file(locale_dir, package = "plotly")))

if (!tolower(locale) %in% locales_all) {

stop(

"Invalid locale: '", locale, "'.\n\n",

sprintf("Supported locales include: '%s'", paste(locales_all, collapse = "', '")),

call. = FALSE

)

}

# some locales rely on a base/main locale (e.g. de-CH relies on de)

# https://codepen.io/etpinard/pen/pKvLVX?editors=1010

scripts <- paste0(locale, ".js")

if (grepl("-", locale)) {

locale_main <- strsplit(locale, "-")[[1]][1]

if (locale_main %in% locales_all) {

scripts <- c(scripts, paste0(locale_main, ".js"))

}

}

htmltools::htmlDependency(

name = paste0("plotly-locale-", locale),

version = plotlyMainBundle()$version,

package = "plotly",

src = list(file = locale_dir),

script = tolower(scripts),

all_files = FALSE

)

isTA <- vapply(p$dependencies, function(x) identical(x[["name"]], "typedarray"), logical(1))

p$dependencies <- p$dependencies[!isTA]

p