r2d3maps: Create Maps with D3

#' Proxy for updating d3_map in Shiny
#'
#' @param shinyId single-element character vector indicating the output ID of the
#'   chart to modify (if invoked from a Shiny module, the namespace will be added
#'   automatically)
#' @param data An object containing data to map, must be the same object used in \code{d3_map}.
#' @param session the Shiny session object to which the chart belongs; usually the
#'   default value will suffice
#'
#' @export
#'
#' @name proxy
#'
#' @importFrom shiny getDefaultReactiveDomain
#'
#' @examples
#' \dontrun{
#'
#' # todo
#'
#' }
d3_map_proxy <- function(shinyId, data = NULL, session = shiny::getDefaultReactiveDomain()) {

  if (is.null(session)) {
    stop("d3_map_proxy must be called from the server function of a Shiny app")
  }

  if (!is.null(session$ns) && nzchar(session$ns(NULL)) && substring(shinyId, 1, nchar(session$ns(""))) != session$ns("")) {
    shinyId <- session$ns(shinyId)
  }

  structure(
    list(
      session = session,
      id = shinyId,
      x = structure(
        list(data = extract_data(data))
      )
    ),
    class = "d3_map_proxy"
  )
}

#' @export
#'
#' @rdname proxy
d3_cartogram_proxy <- function(shinyId, data = NULL, session = shiny::getDefaultReactiveDomain()) {

  if (is.null(session)) {
    stop("d3_cartogram_proxy must be called from the server function of a Shiny app")
  }

  if (!is.null(session$ns) && nzchar(session$ns(NULL)) && substring(shinyId, 1, nchar(session$ns(""))) != session$ns("")) {
    shinyId <- session$ns(shinyId)
  }

  structure(
    list(
      session = session,
      id = shinyId,
      x = structure(
        list(data = extract_data(data))
      )
    ),
    class = "d3_cartogram_proxy"
  )
}


# call r2d3maps proxy
.r2d3maps_proxy <- function(proxy, name, ...) {

  proxy$session$sendCustomMessage(
    type = sprintf("update-r2d3maps-%s-%s", name, proxy$id),
    message = list(id = proxy$id, data = list(...))
  )

  proxy
}



#' Update a continuous scale in Shiny
#'
#' @param proxy A \code{d3_map_proxy} object.
#' @param var New var to use on the map.
#' @param palette Color palette, you can use Viridis or Brewer color palette.
#' @param direction Sets the order of colors in the scale.
#'  If 1, the default, colors are ordered from darkest to lightest.
#'  If -1, the order of colors is reversed.
#' @param n_breaks Number of breaks to cut data (depending on \code{style}, number of breaks can be re-computed).
#' @param style Style for computing breaks, see \code{\link[classInt]{classIntervals}}.
#'
#' @export
#'
#'
#' @examples
#' \dontrun{
#'
#' if (interactive()) {
#'
#' library(r2d3maps)
#' library(shiny)
#'
#' # data about Paris
#' data("paris")
#'
#'
#' # app
#' ui <- fluidPage(
#'   fluidRow(
#'     column(
#'       width = 8, offset = 2,
#'       tags$h2("Proxy for continuous breaks scale"),
#'       d3Output(outputId = "mymap"),
#'       selectInput(
#'         inputId = "var", label = "Variable:",
#'         choices = grep(pattern = "AGE", x = names(paris), value = TRUE)
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'
#'   output$mymap <- renderD3({
#'     d3_map(shape = paris) %>%
#'       add_continuous_breaks(var = "AGE_00", palette = "Blues") %>%
#'       add_legend(d3_format = ".2s")
#'   })
#'
#'   observeEvent(input$var, {
#'     d3_map_proxy(shinyId = "mymap", data = paris) %>%
#'       update_continuous_breaks(var = input$var, palette = "Blues")
#'   }, ignoreInit = TRUE)
#'
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#'
#' }
update_continuous_breaks <- function(proxy, var, palette = NULL, direction = 1, n_breaks = 5, style = "pretty") {
  if (!any(c("d3_map_proxy", "d3_cartogram_proxy") %in% class(proxy)))
    stop("This function must be used with a d3_map_proxy object", call. = FALSE)
  data <- proxy$x$data
  if (is.null(data))
    stop("No data provided!", call. = FALSE)
  var_ <- data[[var]]
  if (is.null(var_)) {
    warning("Invalid variable!", call. = FALSE)
    return(invisible(proxy))
  }
  .r2d3maps_proxy(
    proxy = proxy,
    name = "continuous-breaks",
    color_var = var,
    scale = scale_breaks(
      data = data,
      vars = var,
      palette = palette,
      direction = direction,
      n_breaks = n_breaks,
      style = style
    )
  )
}




#' Update a gradient scale in Shiny
#'
#' @param proxy A \code{d3_map_proxy} object.
#' @param var New var to use on the map.
#' @param low,high Colours for low and high ends of the gradient.
#' @param range A length two vector to force range of data.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' if (interactive()) {
#'
#' library(r2d3maps)
#' library(shiny)
#'
#' # data about Paris
#' data("paris")
#'
#'
#' # app
#' ui <- fluidPage(
#'   fluidRow(
#'     column(
#'       width = 8, offset = 2,
#'       tags$h2("Proxy for continuous breaks scale"),
#'       d3Output(outputId = "mymap"),
#'       selectInput(
#'         inputId = "var", label = "Variable:",
#'         choices = grep(pattern = "AGE", x = names(paris), value = TRUE)
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'
#'   output$mymap <- renderD3({
#'     d3_map(shape = paris) %>%
#'       add_continuous_gradient(var = "AGE_00", low = "#FEE0D2", high = "#CB181D") %>%
#'       add_legend(d3_format = ".2s")
#'   })
#'
#'   observeEvent(input$var, {
#'     d3_map_proxy(shinyId = "mymap", data = paris) %>%
#'       update_continuous_gradient(var = input$var)
#'   }, ignoreInit = TRUE)
#'
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#'
#' }
update_continuous_gradient <- function(proxy, var, low = NULL, high = NULL, range = NULL) {
  if (!"d3_map_proxy" %in% class(proxy))
    stop("This function must be used with a d3_map_proxy object", call. = FALSE)
  data <- proxy$x$data
  if (is.null(data))
    stop("No data provided!", call. = FALSE)
  var_ <- data[[var]]
  if (is.null(var_)) {
    warning("Invalid variable!", call. = FALSE)
    return(invisible(proxy))
  }
  .r2d3maps_proxy(
    proxy = proxy,
    name = "continuous-gradient",
    color_var = var,
    scale = scale_gradient(
      data = data,
      vars =  var,
      low = low,
      mid = NULL,
      high = high,
      range = range
    )
  )
}



#' Update a legend in Shiny
#'
#' @param proxy A \code{d3_map_proxy} object.
#' @param title Title for the legend.
#' @param prefix A prefix of legend labels.
#' @param suffix A suffix of legend labels.
#' @param d3_format A string passed to \code{d3.format},
#'  see \url{https://github.com/d3/d3-format}.
#'  If used \code{prefix} and \code{suffix} are ignored.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' if (interactive()) {
#'
#' library(r2d3maps)
#' library(shiny)
#'
#' # data about Paris
#' data("paris")
#'
#'
#' # app
#' ui <- fluidPage(
#'   fluidRow(
#'     column(
#'       width = 8, offset = 2,
#'       tags$h2("Proxy for continuous breaks scale"),
#'       d3Output(outputId = "mymap"),
#'       selectInput(
#'         inputId = "var", label = "Variable:",
#'         choices = grep(pattern = "AGE", x = names(paris), value = TRUE)
#'       )
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'
#'   output$mymap <- renderD3({
#'     d3_map(shape = paris) %>%
#'       add_continuous_gradient(var = "AGE_00", low = "#FEE0D2", high = "#CB181D") %>%
#'       add_legend(d3_format = ".2s")
#'   })
#'
#'   observeEvent(input$var, {
#'     d3_map_proxy(shinyId = "mymap", data = paris) %>%
#'       update_continuous_gradient(var = input$var) %>%
#'       update_legend(title = tolower(gsub(
#'         pattern = "_", replacement = " ", x = input$var
#'       )), d3_format = ".1s")
#'   }, ignoreInit = TRUE)
#'
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#'
#' }
update_legend <- function(proxy, title = "", prefix = "", suffix = "", d3_format = NULL) {
  if (!"d3_map_proxy" %in% class(proxy))
    stop("This function must be used with a d3_map_proxy object", call. = FALSE)
  .r2d3maps_proxy(
    proxy = proxy,
    name = "legend",
    title = title,
    prefix = prefix,
    suffix = suffix,
    d3_format = d3_format
  )
}



#' Update tooltip in Shiny
#'
#' @param proxy A \code{d3_map_proxy} object.
#' @param value A \code{formula} or a \code{glue} string matching columns in \code{data}.
#' @param as_glue Use a \code{glue} string, if \code{FALSE}
#'  you can pass a character vector as tooltip.
#' @param .na Value to replace NA values with (if \code{value} is a \code{glue} string).
#'  Use \code{NULL} to don't display tooltip if there is NAs.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' if (interactive()) {
#'
#'
#'
#' }
#'
#' }
update_tootltip <- function(proxy, value = "<b>{name}</b><<scale_var>>", as_glue = TRUE, .na = "no data") {
  if (!"d3_map_proxy" %in% class(proxy))
    stop("This function must be used with a d3_map_proxy object", call. = FALSE)
  .r2d3maps_proxy(
    proxy = proxy,
    name = "tooltip",
    tooltip = TRUE,
    tooltip_value = make_tooltip(
      data = proxy$x$data,
      value = value,
      var = proxy$x$options$colors$color_var,
      as_glue = as_glue,
      .na = .na
    )
  )
}