jbkunst / highcharter

R wrapper for highcharts
http://jkunst.com/highcharter/
Other
720 stars 148 forks source link

Can't update map proxy in a shiny app with modules #759

Closed astro-nomad closed 1 year ago

astro-nomad commented 2 years ago

We are unable to update the series in a modulized shiny app with hcpxy_update_series for a map object. The minimal example has paths between cities. The goal is when the user clicks the "Click Here" button, the observeEvent will update the map. However nothing happens.

We used this question (https://stackoverflow.com/questions/54419855/drawing-arbitrary-lines-on-a-highchart-map-in-r-library-highcharter) to build the paths between the origin and destination bubbles.

hcpxy_remove_series was successful in removing the exact series by ID. So we're sure the ID is not an issue.

We also ran https://github.com/jbkunst/highcharter-shiny/tree/master/02-proxy-functions locally. In this local app we changed line https://github.com/jbkunst/highcharter-shiny/blob/master/02-proxy-functions/app.R#L293 to data = sample(round(highcharter::citytemp$london + rnorm(12), 1), sample(1:12, 1)). This was successful in changing the series to a random number of bar charts so we're sure the series length does not need to match.

Here is an example where the map does not update with the new subset data.

library(shiny)
library(highcharter)

# path logic from https://stackoverflow.com/questions/54419855/drawing-arbitrary-lines-on-a-highchart-map-in-r-library-highcharter
usMap <- highcharter::hcmap('countries/us/custom/us-all-mainland', showInLegend = FALSE)

# extract the transformation-info
trafo <- mapTest$x$hc_opts$series[[1]]$usMap$`hc-transform`$default

# data
data <- list(
    class1orig = data.frame(name = c('New York'), lat = c(40.641766), lon = c(-73.780968), z = 3)
    , class1dest = data.frame(name = c('Chicago', 'Tampa'), lat = c(41.978611, 27.979168), lon = c(-87.904724, -82.539337), z = 3)
    , class1path = data.frame(name = c('New York to Chicago', 'New York to Tampa')
                              , path = c('M8892.24402322902,7526.00270614027,6112.01725925147,7408.72214961192'
                                         , 'M8892.24402322902,7526.00270614027,7682.15089059789,3927.10986165183'))
    , class2orig = data.frame(name = c('San Diego', 'San Francisco'), lat = c(32.731770, 37.615223), lon = c(-117.197624, -122.389977), z = 3)
    , class2dest = data.frame(name = c('Seattle'), lat = c(47.443546), lon = c(-122.301659), z = 3)
    , class2path = data.frame(name = c('San Diego to Seattle', 'San Francisco to Seattle')
                              , path = c('M-79.9890055731885,5480.73892313105,-73.6419170593119,9437.79555334059'
                                         , 'M-820.999174490182,6991.95045100256,-73.6419170593119,9437.79555334059'))
)

# module UI
thisModuleUI <- function(id) {

    ns <- NS(id)

    tabPanel(
        highchartOutput(ns('thisMap'))
        , actionButton(ns('thisButton'), 'Click Here')
    )

}

# module Server
thisModuleServer <- function(id, data) {

    moduleServer(
        id,
        function(input, output, session) {

            ns <- NS(id)

            output$thisMap <- renderHighchart({

                usMap %>% 
                    hc_add_series(data = data$class1orig # class 1 origin bubble
                                  , type = 'mapbubble'
                                  , name = 'Class 1'
                                  , id = 'class1orig') %>% 
                    hc_add_series(data = data$class1dest # class 1 destination bubble
                                  , type = 'mapbubble'
                                  , name = 'Class 1'
                                  , id = 'class1dest'
                                  , showInLegend = FALSE
                                  , linkedTo = 'class1orig') %>%
                    hc_add_series(data = data$class1path # class 1 path line
                                  , type = 'mapline'
                                  , name = 'Class 1'
                                  , id = 'class1path'
                                  , showInLegend = FALSE
                                  , linkedTo = 'class1orig') %>%
                    hc_add_series(data = data$class2orig # class 2 origin bubble
                                  , type = 'mapbubble'
                                  , name = 'Class 2'
                                  , id = 'class2orig') %>% 
                    hc_add_series(data = data$class2dest # class 2 destination bubble
                                  , type = 'mapbubble'
                                  , name = 'Class 2'
                                  , id = 'class2dest'
                                  , showInLegend = FALSE
                                  , linkedTo = 'class2orig') %>% 
                    hc_add_series(data = data$class2path # class 2 path line
                                  , type = 'mapline'
                                  , name = 'Class 2'
                                  , id = 'class2path'
                                  , showInLegend = FALSE
                                  , linkedTo = 'class2orig')

            })

            # update map proxy when button is clicked
            observeEvent(input$thisButton, {

                # first row of each dataframe
                data2 <- lapply(data, function(x) x[1,])

                # update map proxy
                highchartProxy(ns('thisMap')) %>% 
                    # hcpxy_remove_series(id = 'class1orig') %>% ## removing by id works
                    hcpxy_update_series(id = 'class1orig', data = data2$class1orig) %>% 
                    hcpxy_update_series(id = 'class1dest', data = data2$class1dest) %>%
                    hcpxy_update_series(id = 'class1path', data = data2$class1path) %>%
                    hcpxy_update_series(id = 'class2orig', data = data2$class2orig) %>%
                    hcpxy_update_series(id = 'class2dest', data = data2$class2dest) %>%
                    hcpxy_update_series(id = 'class2path', data = data2$class2path)

            })

        }
    )
}

# shiny UI
ui <- navbarPage(
    title = 'Hello'
    , thisModuleUI('thisModuleID')
)

# shiny server
server <- function(input, output, session) {
    thisModuleServer('thisModuleID', data)
}

# run app
shinyApp(ui = ui, server = server)
stale[bot] commented 1 year ago

This issue has been automatically marked as stale because it has not had recent activity. It will be closed if no further activity occurs. Thank you for your contributions. Feel free to reopen it if you find it necessary.