Highcharter map click event not working in Shiny module - r

Below is a Shiny app in which a Highcharter map is displayed.
When a user clicks a country, the name of the country is displayed below the map.
The app below works when it does not use modules. When implemented using a module, the country selected does not display anymore.
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
ns <- NS(id)
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
ns <- NS(id)
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS("function(event) {Shiny.onInputChange('hcmapclick',event.point.name);}")
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)
EDIT
Adding the module ID to the Shiny.onInputChange function as follows, does not solve the problem.
click_js <- JS("function(event) {console.log(event.point.name); Shiny.onInputChange('moduleID-hcmapclick', event.point.name);}")

You have to add the module ID to your call back function. We can do this programmatically by using the module id in paste0 inside the JS() call:
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS(paste0("function(event) {Shiny.onInputChange('",id,"-hcmapclick',event.point.name);}"))
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)

Related

R shiny, Editable DT table Module with reactive data as input

I am trying to create a editable shiny DT table module. It works well when I pass in iris data.
However, when I tried to pass a reactive value, the module does not work. Does anyone had similar experience before ? Could you share your thought?
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col,change){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
print(v$data)
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
observeEvent(change(),{
v$data<<-data
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
observe({print(data())})
v<-reactive({editableUIServer("test",data(),c(1), change_ppg = reactive(input$spec))})
}
# Run the application
shinyApp(ui = ui, server = server)
I changed a couple of lines and now it works. Not sure why it was wrong in the first place, though
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
# v<-reactive({editableUIServer("test",data =iris,c(1), change_ppg = reactive(input$spec))})
v<- reactive(editableUIServer("test",data(),c(1)))
observe(print(v()$data))
}
# Run the application
shinyApp(ui = ui, server = server)

How to pan and zoom svg file in shiny app

I have the shiny app below in which I want to pan and zoom the .svg.
library(shiny)
library(DiagrammeR)
library(tidyverse)
# probably don't need all of these:
library(DiagrammeRsvg)
library(svglite)
library(svgPanZoom)
library(rsvg)
library(V8)# only for svg export but also does not work
library(xml2)
ui <- fluidPage(
grVizOutput("grr",width = "100%",height = "90vh")
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <-
renderGrViz(reactives$graph
)
}
# Run the application
shinyApp(ui = ui, server = server)
I tried with the svgPanZoom package but could make it work. How does this work? Or an alternative option?
ui <- fluidPage(
svgPanZoomOutput("grr")
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <-
renderSvgPanZoom({
svgPanZoom(reactives$graph)
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can use the panzoom JavaScript library.
library(shiny)
library(DiagrammeR)
library(magrittr)
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js")
),
grVizOutput("grr", width = "100%", height = "90vh"),
tags$script(
HTML('panzoom($("#grr")[0])')
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)

Is it possible to pass leaflet map to another module?

I write an app which I try to modularize. In general, I added leaflet map to my app's body (in main module) and what I want to do is to write some other modules which refer to my main map (showing/hiding points on a map and other spatial operations). I try to refer to this map (being in main module) from other modules. In example below I passed map as reactive expression from main module but when I press button showing points on the map then the error shows up:
Error in if: missing value where TRUE/FALSE needed
Is it possible to pass map to another module at all? And use leafletProxy there?
Here is reproducible example:
library(shiny)
library(dplyr)
library(sf)
library(leaflet)
moduleServer <- function(id, module) {
callModule(module, id)
}
# Main module - UI 1 #
mod_btn_UI1 <- function(id) {
ns <- NS(id)
tagList(
leafletOutput(ns("map")),
mod_btn_UI2(ns("other"))
)
}
# Main module - Server 1 #
mod_btn_server1 <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
# here I pass map as reactive
passMap = reactive({input$map})
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = FALSE,
radius = 6)
})
mod_btn_server2("other", passMap)
})
}
# Other module - UI 2 #
mod_btn_UI2 <- function(id) {
ns <- NS(id)
tagList(
actionButton(inputId = ns("btn"), label = "show points")
)
}
# Other module - Server 2 #
mod_btn_server2 <- function(id, passMap){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
observeEvent(input$btn, {
leaflet::leafletProxy(passMap()) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = TRUE,
color = "red",
radius = 6)
})
})
}
# Final app #
ui <- fluidPage(
tagList(
mod_btn_UI1("test-btn"))
)
server <- function(input, output, session) {
mod_btn_server1("test-btn")
}
shinyApp(ui = ui, server = server)
It seems that you need to pass down the leaflet proxy as a reactive to the module for it to work.
Added a leaflet proxy instead of input name for the variable passMap in module mod_btn_server1:
proxymap <- reactive(leafletProxy('map'))
mod_btn_server2("other", proxymap)
In mod_btn_server2 you have then to change Passmap to be the leafletproxy itself removing the call to leafletproxy:
observeEvent(input$btn, {
passMap() %>%
leaflet::addCircleMarkers(
data = coords,
stroke = TRUE,
color = "red",
radius = 6)
})
The full code here:
library(shiny)
library(dplyr)
library(sf)
library(leaflet)
moduleServer <- function(id, module) {
callModule(module, id)
}
# Main module - UI 1 #
mod_btn_UI1 <- function(id) {
ns <- NS(id)
tagList(
leafletOutput(ns("map")),
mod_btn_UI2(ns("other"))
)
}
# Main module - Server 1 #
mod_btn_server1 <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
# here I pass map as reactive
passMap = reactive({input$map})
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = FALSE,
radius = 6)
})
proxymap <- reactive(leafletProxy('map'))
mod_btn_server2("other", proxymap)
})
}
# Other module - UI 2 #
mod_btn_UI2 <- function(id) {
ns <- NS(id)
tagList(
actionButton(inputId = ns("btn"), label = "show points")
)
}
# Other module - Server 2 #
mod_btn_server2 <- function(id, passMap){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
observeEvent(input$btn, {
passMap() %>%
leaflet::addCircleMarkers(
data = coords,
stroke = TRUE,
color = "red",
radius = 6)
})
})
}
# Final app #
ui <- fluidPage(
tagList(
mod_btn_UI1("test-btn"))
)
server <- function(input, output, session) {
mod_btn_server1("test-btn")
}
shinyApp(ui = ui, server = server)

Is it possible to refer to namespace from another module?

I want to refer to the namespace ns("map") from second server module mod_btn_server2. This module is nested in first server module mod_btn_server1. When I click 'Button 2' points should show up on a map but they didn't. Is it possible at all to refer to "map" from nested module?
Here's working example:
library(shiny)
library(mapboxer)
library(dplyr)
library(sf)
library(leaflet)
moduleServer <- function(id, module) {
callModule(module, id)
}
# UI 1 #
mod_btn_UI1 <- function(id) {
ns <- NS(id)
tagList(
actionButton(ns("btn1"), "Button 1"),
mod_btn_UI2(ns("moduleServer2")),
leafletOutput(ns("map"))
)
}
# Server 1 #
mod_btn_server1 <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
mod_btn_server2("moduleServer2", coords) # here is nested module2
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = FALSE,
radius = 6)
})
observeEvent(input$btn1, {
leaflet::leafletProxy("map", data = coords) %>%
leaflet::addCircles()
})
})
}
# Module 2 - UI #
mod_btn_UI2 <- function(id){
ns <- NS(id)
actionButton(ns("btn2"), "Button 2"),
}
# Module 2 - server #
mod_btn_server2 <- function(id, dataMod){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = dataMod,
stroke = TRUE,
color = "red",
radius = 6)
})
# and here I refer to 'map' located in the first module
observeEvent(input$btn2, {
leaflet::leafletProxy("map", data = dataMod) %>%
leaflet::addCircles()
})
})
}
# App #
ui <- fluidPage(
tagList(
mod_btn_UI1("test-btn"))
)
server <- function(input, output, session) {
mod_btn_server1("test-btn")
}
shinyApp(ui = ui, server = server)
As I mentioned in my comment above, the canonical way would be to capture the button push as an output of module moduleServer2 and use this as an input for test-btn where you perform the action.
However, if you want to mess around with the namespaces by yourself (not recommended), you can use the following solution. I had to adapt the leafletProxy function, because the normal implementation automatically adds the namespace of the calling module. This is what you don't want, because you want to use the namespace of a different module.
Now with code adapted to the edit:
library(shiny)
library(mapboxer)
library(dplyr)
library(sf)
library(leaflet)
leafletProxy2 <- function (mapId, session = shiny::getDefaultReactiveDomain(),
data = NULL, deferUntilFlush = TRUE)
{
if (is.null(session)) {
stop("leafletProxy must be called from the server function of a Shiny app")
}
structure(list(session = session, id = mapId, x = structure(list(),
leafletData = data), deferUntilFlush = deferUntilFlush,
dependencies = NULL), class = "leaflet_proxy")
}
# UI 1 #
mod_btn_UI1 <- function(id) {
ns <- NS(id)
tagList(
actionButton(ns("btn1"), "Button 1"),
mod_btn_UI2(ns("moduleServer2")),
leafletOutput(ns("map"))
)
}
# Server 1 #
mod_btn_server1 <- function(id){
moduleServer(id, function(input, output, session) {
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
mod_btn_server2("moduleServer2", coords) # here is nested module2
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = FALSE,
radius = 6)
})
observeEvent(input$btn1, {
leaflet::leafletProxy("map", data = coords) %>%
leaflet::addCircles()
})
})
}
# Module 2 - UI #
mod_btn_UI2 <- function(id){
ns <- NS(id)
actionButton(ns("btn2"), "Button 2")
}
# Module 2 - server #
mod_btn_server2 <- function(id, dataMod, btn){
moduleServer(id, function(input, output, session) {
# and here I refer to 'map' located in the first module
observeEvent(input$btn2, {
leafletProxy2("test-btn-map", data = dataMod) %>%
leaflet::addCircles(stroke = TRUE,
color = "red")
})
})
}
# App #
ui <- fluidPage(
tagList(
mod_btn_UI1("test-btn"))
)
server <- function(input, output, session) {
mod_btn_server1("test-btn")
}
shinyApp(ui = ui, server = server)
Here is a more canonical form that works with the correct input/output of modules and doesn't mess with namespaces:
library(shiny)
library(mapboxer)
library(dplyr)
library(sf)
library(leaflet)
# UI 1 #
mod_btn_UI1 <- function(id) {
ns <- NS(id)
tagList(
actionButton(ns("btn1"), "Button 1"),
mod_btn_UI2(ns("moduleServer2")),
leafletOutput(ns("map"))
)
}
# Server 1 #
mod_btn_server1 <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
coords <- quakes %>%
sf::st_as_sf(coords = c("long","lat"), crs = 4326)
external_btn <- mod_btn_server2("moduleServer2", coords) # here is nested module2
output$map <- leaflet::renderLeaflet({
leaflet::leaflet() %>%
leaflet::addTiles() %>%
leaflet::setView(172.972965,-35.377261, zoom = 4) %>%
leaflet::addCircleMarkers(
data = coords,
stroke = FALSE,
radius = 6)
})
observeEvent(input$btn1, {
leaflet::leafletProxy("map", data = coords) %>%
leaflet::addCircles()
})
observeEvent(external_btn(), {
leaflet::leafletProxy("map", data = coords) %>%
leaflet::addCircles(stroke = TRUE,
color = "red")
})
})
}
# Module 2 - UI #
mod_btn_UI2 <- function(id){
ns <- NS(id)
actionButton(ns("btn2"), "Button 2")
}
# Module 2 - server #
mod_btn_server2 <- function(id, dataMod){
moduleServer(id, function(input, output, session) {
return(reactive(input$btn2))
})
}
# App #
ui <- fluidPage(
tagList(
mod_btn_UI1("test-btn"))
)
server <- function(input, output, session) {
mod_btn_server1("test-btn")
}
shinyApp(ui = ui, server = server)

How to call a shiny module from a shiny module?

How do I call a shiny module from within a shiny module with passing selections from the first module?
As an example I wrote a app to show the Star Wars subjects from dplyr in a DT::data table (module StarWars). The related films from the same data set should be shown in another DT::data table in another sub tab (module Films).
I pass the table selected subject in a reactive value sw_rows_selected_rct from module StarWars to module Films but browser() statement in module Films is not passed.
# Test call of modules inside modules
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films")))
}
ui_StarWars <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(ui_Films(
id = ns("Films"), title = "...by Films"
)))
}
ui <- shinyUI(navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
))
Films <-
function(input,
output,
session,
sw_data,
sw_selection) {
ns <- session$ns
sw_films_rct <- observe({
req(sw_data, is.data.frame(sw_selection))
browser() # not reached!!!
sw_films_rct <-
sw_data %>% {
if (is_null(sw_selection))
.
else
filter(., name == sw_selection$name)
}
})
output$StarWarsFilms <- DT::renderDataTable({
req(is.data.frame(sw_films_rct))
DT::datatable(sw_films_rct,
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct = reactiveVal()
ns <- session$ns
sw_rows_selected_rct = observeEvent(input$StarWars_rows_selected, {
req(sw_data, input$StarWars_rows_selected != 0)
browser()
sw_data[input$StarWars_rows_selected, ]
})
md_films <- callModule(
module = Films,
id = "Films",
sw_data = sw_data,
sw_selection = sw_rows_selected_rct
)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data))
DT::datatable(sw_data,
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct = reactive({
dplyr::starwars %>% mutate(films = NULL,
vehicles = NULL,
starships = NULL)
})
md_StarWars = callModule(module = StarWars,
id = "StarWars",
sw_data = sw_data_rct())
})
# Run the application
shinyApp(ui = ui, server = server)
Your code had a few errors. Remember, observe and observeEvents don't have return values. Set the value of your reactives through the nameofReactive(newValue). Your initial goal is possible if you give the reactive to the module, not the current value of the reactive, so that it can change throughout the course of using the app. In the module, you then have to you the value of the reactive, by using () on the reactive. Oh, and your last output had the wrong name (output$Films should be correct). Here is the working app:
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films"))
)
}
ui_StarWars <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(
ui_Films(id = ns("Films"), title = "...by Films"))
)
}
ui <- shinyUI(
navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
)
)
Films <-
function(input, output, session, sw_data, sw_selection) {
ns <- session$ns
sw_films_rct <- reactiveVal()
observe({
sw_films_rct(sw_data() %>% {if(is_null(sw_selection())) . else filter(., name == sw_selection()$name)})
})
output$Films <- DT::renderDataTable({
req(is.data.frame(sw_films_rct()))
DT::datatable(sw_films_rct(),
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct= reactiveVal()
ns <- session$ns
observeEvent(input$StarWars_rows_selected, {
req(sw_data(), input$StarWars_rows_selected != 0)
sw_rows_selected_rct(sw_data()[input$StarWars_rows_selected,])
})
md_films <- callModule(module = Films, id = "Films",
sw_data= sw_data,
sw_selection= sw_rows_selected_rct)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data()))
DT::datatable(sw_data(),
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct= reactive({dplyr::starwars %>% mutate(films = NULL, vehicles = NULL, starships = NULL)})
md_StarWars= callModule(module = StarWars, id = "StarWars", sw_data = sw_data_rct)
})
# Run the application
shinyApp(ui = ui, server = server)

Resources