color, colors = NULL, alpha = 1, symbol, symbols = NULL,

size, sizes = c(10, 100), 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$color <- if (!missing(color)) color

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

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

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

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

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

# tack on scale ranges

attrs$colors <- colors

attrs$alpha <- alpha

attrs$symbols <- symbols

attrs$linetypes <- linetypes

attrs$sizes <- sizes

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

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

)

setNames(

tibble::as_tibble(dendextend::get_nodes_xy(node)),

c("x", "y")

)

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

)

)

htmltools::htmlDependency(

"typedarray", "0.1",

src = depPath("typedarray"),

script = "typedarray.min.js"

)

htmltools::htmlDependency(

"plotlyjs", "1.31.2.9000",

src = depPath("plotlyjs"),

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

stylesheet = "plotly-htmlwidgets.css"

)

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

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

p