R/highcharts-api-add.R

Defines functions hc_add_dependency hc_add_annotations hc_add_annotation hc_add_event_series hc_add_event_point hc_add_series_list hc_rm_series data_to_options data_to_series add_arg_to_df mutate_mapping hcaes_string hcaes hc_add_series.data.frame hc_add_series.lm hc_add_series.geo_list hc_add_series.geo_json hc_add_series.character hc_add_series.density hc_add_series.forecast hc_add_series.ohlc hc_add_series.xts hc_add_series.ts hc_add_series.numeric hc_add_series.default hc_add_series

Documented in hc_add_annotation hc_add_annotations hc_add_dependency hc_add_event_point hc_add_event_series hc_add_series hc_add_series.character hc_add_series.data.frame hc_add_series.density hc_add_series.forecast hc_add_series.geo_json hc_add_series.geo_list hc_add_series_list hc_add_series.lm hc_add_series.numeric hc_add_series.ohlc hc_add_series.ts hc_add_series.xts hcaes hcaes_string hc_rm_series mutate_mapping

#' Adding data to highchart objects
#'
#' @param hc A `highchart` `htmlwidget` object.
#' @param data An R object like numeric, list, ts, xts, etc.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @examples
#'
#' highchart() %>%
#'   hc_add_series(data = abs(rnorm(5)), type = "columnn") %>%
#'   hc_add_series(data = purrr::map(0:4, function(x) list(x, x)), type = "scatter", color = "blue")
#' @export
hc_add_series <- function(hc, data = NULL, ...) {
  assertthat::assert_that(is.highchart(hc))
  
  UseMethod("hc_add_series", data)
}


#' @export
hc_add_series.default <- function(hc, ...) {
  assertthat::assert_that(is.highchart(hc))
  
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.default")
  }
  
  validate_args("add_series", eval(substitute(alist(...))))
  
  hc$x$hc_opts$series <- append(hc$x$hc_opts$series, list(list(...)))
  
  hc
}


#' `hc_add_series` for numeric objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A numeric object
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @export
hc_add_series.numeric <- function(hc, data, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.numeric")
  }
  
  data <- fix_1_length_data(data)
  
  hc_add_series.default(hc, data = data, ...)
}


#' hc_add_series for time series objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A time series `ts` object.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @importFrom zoo as.Date
#' @importFrom stats time
#' @export
hc_add_series.ts <- function(hc, data, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.ts")
  }
  
  # http://stackoverflow.com/questions/29202021/
  timestamps <- data %>%
    stats::time() %>%
    zoo::as.Date() %>%
    datetime_to_timestamp()
  
  series <- list_parse2(data.frame(timestamps, as.vector(data)))
  
  hc_add_series(hc, data = series, ...)
}


#' hc_add_series for xts objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A `xts` object.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @importFrom xts is.xts
#' @importFrom quantmod is.OHLC
#' @export
hc_add_series.xts <- function(hc, data, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.xts")
  }
  
  if (is.OHLC(data)) {
    return(hc_add_series.ohlc(hc, data, ...))
  }
  
  timestamps <- datetime_to_timestamp(time(data))
  
  series <- list_parse2(data.frame(timestamps, as.vector(data)))
  
  hc_add_series(hc, data = series, ...)
}


#' @rdname hc_add_series.xts
#' @param type The way to show the `xts` object. Can be 'candlestick' or 'ohlc'.
#' @export
hc_add_series.ohlc <- function(hc, data, type = "candlestick", ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.xts.ohlc")
  }
  
  time <- datetime_to_timestamp(time(data))
  xdf <- cbind(time, as.data.frame(
    quantmod::OHLC(data)
  ))
  xds <- list_parse2(xdf)
  
  nm <- ifelse(!is.null(list(...)[["name"]]),
               list(...)[["name"]],
               str_extract(names(data)[1], "^[A-Za-z]+")
  )
  
  hc_add_series(hc, data = xds, name = nm, type = type, ...)
}


#' hc_add_series for forecast objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A `forecast` object.
#' @param addOriginal Logical value to add the original series or not.
#' @param addLevels Logical value to show predictions bands.
#' @param fillOpacity The opacity of bands.
#' @param name The name of the series.
#' @param ... Arguments defined in
#'   \url{http://api.highcharts.com/highcharts#chart}.
#' @export
hc_add_series.forecast <- function(hc, data, addOriginal = FALSE,
                                   addLevels = TRUE, fillOpacity = 0.1, name = NULL, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.forecast")
  }
  
  rid <- random_id()
  method <- data$method
  
  if (addOriginal) {
    hc <- hc_add_series(hc, data$x, name = ifelse(is.null(name), method, name), zIndex = 3, ...)
  }
  
  
  hc <- hc_add_series(hc, data$mean, name = ifelse(is.null(name), method, name), zIndex = 2, id = rid, ...)
  
  if (addLevels) {
    tmf <- datetime_to_timestamp(zoo::as.Date(time(data$mean)))
    nmf <- paste(ifelse(is.null(name), method, name), "level", data$level)
    
    for (m in seq(ncol(data$upper))) {
      dfbands <- tibble(
        t = tmf,
        l = as.vector(data$lower[, m]),
        u = as.vector(data$upper[, m])
      )
      
      hc <- hc %>%
        hc_add_series(
          data = list_parse2(dfbands),
          name = nmf[m],
          type = "arearange",
          fillOpacity = fillOpacity,
          zIndex = 1,
          lineWidth = 0,
          linkedTo = rid,
          ...
        )
    }
  }
  
  
  hc
}


#' hc_add_series for density objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A `density` object.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @export
hc_add_series.density <- function(hc, data, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.density")
  }
  
  data <- list_parse(data.frame(cbind(x = data$x, y = data$y)))
  
  hc_add_series(hc, data = data, ...)
}


#' hc_add_series for character and factor objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A \code{character} or \code{factor} object.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @export
hc_add_series.character <- function(hc, data, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.character")
  }
  
  series <- data %>%
    table() %>%
    as.data.frame(stringsAsFactors = FALSE) %>%
    setNames(c("name", "y")) %>%
    list_parse()
  
  hc_add_series(hc, data = series, ...)
}


#' @rdname hc_add_series.character
#' @export
hc_add_series.factor <- hc_add_series.character

#' hc_add_series for geo_json & geo_list objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A \code{geo_json} or \code{geo_list} object.
#' @param type Type of series. Can be 'mapline', 'mapoint'.
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/plotOptions.series}.
#' @export
hc_add_series.geo_json <- function(hc, data, type = NULL, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.geo_json")
  }
  
  stopifnot(hc$x$type == "map", !is.null(type))
  
  hc_add_series.default(hc, data = data, geojson = TRUE, type = type, ...)
}

#' @rdname hc_add_series.geo_json
#' @export
hc_add_series.geo_list <- function(hc, data, type = NULL, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.geo_list")
  }
  
  stopifnot(hc$x$type == "map", !is.null(type))
  
  hc_add_series.default(hc, data = data, geojson = TRUE, type = type, ...)
}

#' hc_add_series for lm and loess objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A \code{lm} or \code{loess} object.
#' @param type The type of the series: line, spline.
#' @param color A stringr color.
#' @param fillOpacity fillOpacity to the confidence interval.
#' @param ... Arguments defined in
#'   \url{http://api.highcharts.com/highcharts#chart}.
#' @importFrom broom augment
#' @importFrom rlang .data
#' @export
hc_add_series.lm <- function(hc, data, type = "line", color = "#5F83EE", fillOpacity = 0.1, ...) {
  if (getOption("highcharter.verbose")) {
    message(sprintf("hc_add_series.%s", class(data)))
  }
  
  data2 <- data %>%
    augment() %>%
    as.matrix.data.frame() %>%
    as.data.frame() %>%
    tibble::as_tibble()
  data2 <- arrange_(data2, .dots = names(data2)[2])
  data2 <- mutate(data2, x = names(data2)[2])
  data2 <- select(data2, !!!c(names(data2)[1]), .data$x, .data$.fitted, .data$.se.fit)
  
  rid <- random_id()
  
  hc %>%
    hc_add_series(data2,
                  type = type, hcaes_("x", ".fitted"),
                  id = rid, color = color, ...
    ) %>%
    hc_add_series(data2,
                  type = "arearange",
                  hcaes_("x",
                         low = ".fitted - 2 * .se.fit",
                         high = ".fitted + 2 * .se.fit"
                  ),
                  color = hex_to_rgba(color, fillOpacity),
                  linkedTo = rid, zIndex = -2, ...
    )
}

#' @rdname hc_add_series.lm
#' @export
hc_add_series.loess <- hc_add_series.lm

#' hc_add_series for data frames objects
#' @param hc A `highchart` `htmlwidget` object.
#' @param data A `data.frame` object.
#' @param type The type of the series: line, bar, etc.
#' @param mapping The mapping, same idea as \code{ggplot2}.
#' @param fast convert to json during the composition of a highchart object
#' @param ... Arguments defined in
#'   \url{http://api.highcharts.com/highcharts#chart}.
#' @importFrom rlang .data
#' @export
hc_add_series.data.frame <- function(hc, data, type = NULL, mapping = hcaes(), fast = FALSE, ...) {
  if (getOption("highcharter.verbose")) {
    message("hc_add_series.data.frame")
  }

  if (length(mapping) == 0) {
    if (has_name(data, "series")) {
      data <- rename(data, seriess = .data$series)
    }
    
    return(hc_add_series(hc, data = list_parse(data), type = type, ...))
  }
  
  data <- mutate_mapping(data, mapping)
  
  series <- data_to_series(data, mapping, type = type, fast = fast, ...)
  
  hc_add_series_list(hc, series)
}

#' Define aesthetic mappings.
#' Similar in spirit to \code{ggplot2::aes}
#' @param x,y,... List of name value pairs giving aesthetics to map to
#'   variables. The names for x and y aesthetics are typically omitted because
#'   they are so common; all other aesthetics must be named.
#' @importFrom rlang enexprs is_missing
#' @examples
#'
#' hcaes(x = xval, color = colorvar, group = grvar)
#' @export
hcaes <- function(x, y, ...) {
  # taken from https://github.com/tidyverse/ggplot2/commit/d69762269787ed0799ab4fb1f35638cc46b5b7e6
  exprs <- rlang::enexprs(x = x, y = y, ...)
  
  is_missing <- vapply(exprs, rlang::is_missing, logical(1))
  
  mapping <- structure(exprs[!is_missing], class = "uneval")
  
  class(mapping) <- c("hcaes", class(mapping))
  
  mapping
}

#' Define aesthetic mappings using strings.
#' Similar in spirit to \code{ggplot2::aes_string}
#' @param x,y,... List of name value pairs giving aesthetics to map to
#'   variables. The names for x and y aesthetics are typically omitted because
#'   they are so common; all other aesthetics must be named.
#' @examples
#' hchart(mtcars, "point", hcaes_string("hp", "mpg", group = "cyl"))
#'
#' hcaes_string(x = "xval", color = "colorvar", group = "grvar")
#' @export
hcaes_string <- function(x, y, ...) {
  mapping <- list(...)
  
  if (!missing(x)) {
    mapping["x"] <- list(x)
  }
  
  if (!missing(y)) {
    mapping["y"] <- list(y)
  }
  
  mapping <- lapply(mapping, function(x) {
    if (is.character(x)) {
      parse(text = x)[[1]]
    }
    else {
      x
    }
  })
  
  mapping <- structure(mapping, class = "uneval")
  
  mapping <- mapping[names(mapping) != ""]
  
  class(mapping) <- c("hcaes", class(mapping))
  
  mapping
}

#' @rdname hcaes_string
#' @export
hcaes_ <- hcaes_string


#' Modify data frame according to mapping
#' @param data A data frame object.
#' @param mapping A mapping from \code{hcaes} function.
#' @param drop A logical argument to you drop variables or not. Default is
#' \code{FALSE}
#' @importFrom lubridate is.Date
#' @importFrom rlang "!!!" "!!" ":=" parse_quo syms .data
#' @examples
#'
#' df <- head(mtcars)
#' mutate_mapping(data = df, mapping = hcaes(x = cyl, y = wt + cyl, group = gear))
#' mutate_mapping(data = df, mapping = hcaes(x = cyl, y = wt), drop = TRUE)
#' @export
mutate_mapping <- function(data, mapping, drop = FALSE) {
  stopifnot(is.data.frame(data), inherits(mapping, "hcaes"), inherits(drop, "logical"))
  
  # https://stackoverflow.com/questions/45359917/dplyr-0-7-equivalent-for-deprecated-mutate
  # https://www.johnmackintosh.com/2018-02-19-theory-free-tidyeval/
  
  tran <- as.character(mapping)
  newv <- names(mapping)
  list_names <- setNames(tran, newv) %>% lapply(rlang::parse_quo, env = globalenv())
  
  data <- dplyr::mutate(data, !!!list_names)
  # Reserverd  highcharts names (#241)
  if (has_name(data, "series")) {
    data <- dplyr::rename(data, seriess = .data$series)
  }
  
  if (drop) {
    newv <- rlang::syms(newv)
    data <- dplyr::select(data, !!!newv)
  }
  
  data
}

add_arg_to_df <- function(data, ...) {
  datal <- as.list(data)
  
  l <- map_if(list(...), function(x) is.list(x), list)
  
  datal <- append(datal, l)
  
  as_tibble(datal)
}

#' @importFrom dplyr mutate do arrange_
#' @importFrom tibble tibble tibble_
data_to_series <- function(data, mapping, type, fast = FALSE, ...) {
  
  # check type and fix
  type <- ifelse(type == "point", "scatter", type)
  type <- ifelse((has_name(mapping, "size") | has_name(mapping, "z")) & type == "scatter",
                 "bubble", type
  )
  
  # heatmap
  if (type == "heatmap") {
    if (!is.numeric(data[["x"]])) {
      data[["xf"]] <- as.factor(data[["x"]])
      data[["x"]] <- as.numeric(as.factor(data[["x"]])) - 1
    }
    if (!is.numeric(data[["y"]])) {
      data[["yf"]] <- as.factor(data[["y"]])
      data[["y"]] <- as.numeric(as.factor(data[["y"]])) - 1
    }
  }
  
  # x
  if (has_name(mapping, "x")) {
    if (is.Date(data[["x"]])) {
      data[["x"]] <- datetime_to_timestamp(data[["x"]])
    } else if (is.character(data[["x"]]) | is.factor(data[["x"]])) {
      data[["name"]] <- data[["x"]]
      data[["x"]] <- NULL
    }
  }
  
  # color
  if (has_name(mapping, "color")) {
    if (type == "treemap") {
      data <- rename(data, colorValue = .data$color)
    } else if (!all(is.hexcolor(data[["color"]]))) {
      data <- mutate(data, colorv = .data$color, color = highcharter::colorize(.data$color))
    }
  } else if (has_name(data, "color")) {
    data <- rename(data, colorv = .data$color)
  }
  
  # size
  if (type %in% c("bubble", "scatter")) {
    if (has_name(mapping, "size")) {
      data <- mutate(data, z = .data$size)
    }
  }
  
  # group
  if (!has_name(mapping, "group")) {
    data[["group"]] <- "group"
  }
  
  if (isTRUE(fast)) {
    # pre-convert data to json
    data <- data %>% 
      group_by(.data$group) %>% 
      do(data = jsonlite::toJSON(select(., -.data$group), 
                                 dataframe = "rows", 
                                 verbatim = TRUE)) %>% 
      ungroup()
  } else {
    data <- data %>%
      group_by(.data$group) %>%
      do(data = list_parse(select(., -.data$group))) %>%
      ungroup()
  }
  
  data$type <- type
  
  if (length(list(...)) > 0) {
    data <- add_arg_to_df(data, ...)
  }
  
  if (has_name(mapping, "group") & !has_name(list(...), "name")) {
    data <- rename(data, name = .data$group)
  }
  
  series <- list_parse(data)
  
  series
}

data_to_options <- function(data, type) {
  opts <- list()
  
  # x
  if (has_name(data, "x")) {
    if (is.Date(data[["x"]])) {
      opts$xAxis_type <- "datetime"
    } else if (is.character(data[["x"]]) | is.factor(data[["x"]])) {
      opts$xAxis_type <- "category"
    } else {
      opts$xAxis_type <- "linear"
    }
  }
  
  # y
  if (has_name(data, "x")) {
    if (is.Date(data[["y"]])) {
      opts$yAxis_type <- "datetime"
    } else if (is.character(data[["y"]]) | is.factor(data[["y"]])) {
      opts$yAxis_type <- "category"
    } else {
      opts$yAxis_type <- "linear"
    }
  }
  
  # showInLegend
  opts$series_plotOptions_showInLegend <- "group" %in% names(data)
  
  # colorAxis
  opts$add_colorAxis <-
    (type == "treemap" & "color" %in% names(data)) | (type == "heatmap")
  
  # heatmap
  if (type == "heatmap") {
    if (!is.numeric(data[["x"]])) {
      opts$xAxis_categories <- levels(as.factor(data[["x"]]))
    }
    if (!is.numeric(data[["y"]])) {
      opts$yAxis_categories <- levels(as.factor(data[["y"]]))
    }
  }
  
  opts
}


#' Removing series to highchart objects
#'
#' @param hc A `highchart` `htmlwidget` object.
#' @param names The series's names to delete.
#'
#' @export
hc_rm_series <- function(hc, names = NULL) {
  stopifnot(!is.null(names))
  
  positions <- hc$x$hc_opts$series %>%
    map("name") %>%
    unlist()
  
  position <- which(positions %in% names)
  
  hc$x$hc_opts$series[position] <- NULL
  
  hc
}

#' Shortcut for data series from a list of data series
#'
#' @param hc A `highchart` `htmlwidget` object.
#' @param x A `list` or a `data.frame` of series.
#'
#' @examples
#'
#' ds <- lapply(seq(5), function(x) {
#'   list(data = cumsum(rnorm(100, 2, 5)), name = x)
#' })
#'
#' highchart() %>%
#'   hc_plotOptions(series = list(marker = list(enabled = FALSE))) %>%
#'   hc_add_series_list(ds)
#' @export
hc_add_series_list <- function(hc, x) {
  assertthat::assert_that(is.highchart(hc), (is.list(x) | is.data.frame(x)))
  
  if (is.data.frame(x)) {
    x <- list_parse(x)
  }
  
  hc$x$hc_opts$series <- append(hc$x$hc_opts$series, x)
  
  hc
}

#' Helpers to use highcharter as input in shiny apps
#'
#' When you use highcharter in a shiny app, for example
#' \code{renderHighcharter('my_chart')}, you can access to the actions of the
#' user using and then use the \code{hc_add_event_point} via the
#' \code{my_chart} input (\code{input$my_chart}). That's a way you can
#' use a chart as an input.
#'
#' @param hc A `highchart` `htmlwidget` object.
#' @param series The name of type of series to apply the event.
#' @param event The name of event: click, mouseOut,  mouseOver. See
#'   \url{http://api.highcharts.com/highcharts/plotOptions.areasplinerange.point.events.select}
#'   for more details.
#'
#' @note Event details are accessible from hc_name_EventType, i.e. if a highchart is rendered against output$my_hc and
#'     and we wanted the coordinates of the user-clicked point we would use input$my_hc_click
#'
#' @export
hc_add_event_point <- function(hc, series = "series", event = "click") {
  fun <- paste0("function(){
  var pointinfo = {series: this.series.name, seriesid: this.series.id,
  name: this.name, x: this.x, y: this.y, category: this.category.name}
  window.x = this;
  console.log(pointinfo);

  if (typeof Shiny != 'undefined') { Shiny.onInputChange(this.series.chart.renderTo.id + '_' + '", event, "', pointinfo); }
}")
  
  fun <- JS(fun)
  
  eventobj <- structure(
    list(structure(
      list(structure(
        list(structure(
          list(fun),
          .Names = event
        )),
        .Names = "events"
      )),
      .Names = "point"
    )),
    .Names = series
  )
  
  hc$x$hc_opts$plotOptions <- rlist::list.merge(
    hc$x$hc_opts$plotOptions,
    eventobj
  )
  
  hc
}

#' @rdname hc_add_event_point
#' @export
hc_add_event_series <- function(hc, series = "series", event = "click") {
  fun <- paste0("function(){
  var seriesinfo = {name: this.name }
  console.log(seriesinfo);
  window.x = this;
  if (typeof Shiny != 'undefined') { Shiny.onInputChange(this.chart.renderTo.id + '_' + '", event, "', seriesinfo); }

}")
  fun <- JS(fun)
  
  eventobj <- structure(
    list(structure(
      list(structure(
        list(fun),
        .Names = event
      )),
      .Names = "events"
    )),
    .Names = series
  )
  
  hc$x$hc_opts$plotOptions <- rlist::list.merge(
    hc$x$hc_opts$plotOptions,
    eventobj
  )
  
  hc
}

#' Helper to add annotations from data frame or list
#' 
#' @param hc A `highchart` `htmlwidget` object. 
#' @param ... Arguments defined in \url{https://api.highcharts.com/highcharts/annotations}. 
#' 
#' @export
hc_add_annotation <- function(hc, ...) {
  assertthat::assert_that(is.highchart(hc))
  
  hc$x$hc_opts[["annotations"]] <- append(
    hc$x$hc_opts[["annotations"]],
    list(list(...))
  )
  
  hc
}

#' @rdname hc_add_annotation
#' @param x A \code{list} or a \code{data.frame} of annotations.
#' @details The \code{x} elements must have \code{xValue} and \code{yValue}
#'   elements
#' @export
hc_add_annotations <- function(hc, x) {
  assertthat::assert_that(is.highchart(hc), (is.list(x) | is.data.frame(x)))
  
  if (is.data.frame(x)) {
    x <- list_parse(x)
  }
  
  hc$x$hc_opts[["annotations"]] <- append(hc$x$hc_opts[["annotations"]], x)
  
  hc
}

#' Add modules or plugin dependencies to highcharts objects
#'
#' @param hc A `highchart` `htmlwidget` object.
#' @param name The partial path to the plugin or module,
#'   example: `"plugins/annotations.js"`
#' @examples
#'
#' data(mpg, package = "ggplot2")
#'
#' hchart(mpg, "point", hcaes(displ, hwy),
#'   regression = TRUE,
#'   regressionSettings = list(type = "polynomial", order = 5, hideInLegend = TRUE)
#' ) %>%
#'   hc_add_dependency("plugins/highcharts-regression.js")
#'
#' hchart(mpg, "point", hcaes(displ, hwy, group = drv), regression = TRUE) %>%
#'   hc_colors(c("#d35400", "#2980b9", "#2ecc71")) %>%
#'   hc_add_dependency("plugins/highcharts-regression.js")
#'   
#' @details See `vignette("modules")`   
#' @importFrom purrr map_chr
#' @importFrom htmltools htmlDependency
#' @importFrom yaml yaml.load_file
#' @export
hc_add_dependency <- function(hc, name = "plugins/annotations.js") {
  
  stopifnot(!is.null(name))
  
  yml <- system.file("htmlwidgets/highchart.yaml", package = "highcharter")
  yml <- yaml.load_file(yml)[[1]]
  
  hc_ver <- map_chr(yml, c("version"))[map_chr(yml, c("name")) == "highcharts"]
  
  dep <- htmlDependency(
    name = basename(name),
    version = hc_ver,
    src = c(file = system.file(
      sprintf("htmlwidgets/lib/highcharts/%s", dirname(name)),
      package = "highcharter"
    )),
    script = basename(name)
  )
  
  hc$dependencies <- c(hc$dependencies, list(dep))
  
  hc
}

Try the highcharter package in your browser

Any scripts or data that you put into this service are public.

highcharter documentation built on July 26, 2020, 9:07 a.m.