R Shiny mapview: only redraw layer, not entire map (i.e. leafletProxy) - r

I am trying to mimic or figure out how a similar function as leafletProxy works in mapview package inside a Shiny app (flexdashboard). The idea is that I have a parameterized database query that fetches a sf dataset (~4200 polygons) based on user inputs and then plots in mapview. However, it appears that everytime this is done the entire map is redrawn?
Below is a reproducible example using the default franconia dataset and a shiny input to control the line opacity. I also include my code (commented out) to show an example of how it will be used as intended (i.e. to dynamically redraw a polygon layer based on a database fetch)
Is there a way in shiny to draw a "base" map of all the background maps stylings once and then only redraw the new polygon data as they are retrieved?
Thanks!
---
title: "MRE"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(mapview)
library(shiny)
library(leaflet)
#library(RSQLite)
#library(sf)
```
Sidebar {.sidebar}
-----------------------------------------------------------------------
```{r}
# This is shiny input that will trigger entire map redraw
sliderInput("gridlines", "Grid Line Opacity", 0, 1, 0, step = 0.1, ticks = FALSE)
```
```{r}
### THIS IS MY ACTUAL CODE...For reference
# sp_grid <- reactive({
# db <- "../data/modeldata.db"
# con <- dbConnect(SQLite(), db )
#
# # set the sql based on user input
# sql <- 'SELECT id, Time,Cell_I, Cell_J, Cell_K, Cell_Botdepth_M, Zmax, Salinity, WKT_GEOMETRY
# FROM vwGridTK
# WHERE Time = :time
# AND Cell_K = :layer'
#
# df.grid <- dbGetQuery(con, sql, params = list(time = 0,
# layer = 1))
# dbDisconnect(con)
#
# st_as_sf(df.grid, wkt = "WKT_GEOMETRY") %>% st_set_crs(4326)
#
# })
```
Column {data-width=500}
-----------------------------------------------------------------------
### Reproducible Example
NOTE the shiny input to control opacity
```{r}
renderLeaflet({
m <- mapview(franconia, zcol = "district", alpha = input$gridlines)
m#map
})
```
Column {data-width=500}
-----------------------------------------------------------------------
### My Example
```{r}
# renderLeaflet({
# m <- mapview(sp_grid(), zcol = "Salinity",
# legend = TRUE, alpha = input$gridlines)
#
# m#map
#
# })
```

Related

Creating a dynamic number of flexdashboard tabs using reactive()

I am wondering if it is possible to create a number of tabs in flexdashboard which change according to some user input. As a toy example, I am trying to plot histograms of every numeric numeric column of a user-selected dataset, with each numeric column getting its own tab for a histogram. If the user changes the dataset, the dashboard should update and increase/decrease the number of tabs in the tabset, if the number of numeric columns in the newly selected dataset changes. For simplicity, I only included two datasets.
---
title: "Reactive GGPlot Tabs"
output:
flexdashboard::flex_dashboard:
theme:
version: 4
bootswatch: cosmo
runtime: shiny
---
```{r}
pacman::p_load(tidyverse, shiny, flexdashboard)
```
Sidebar {.sidebar}
-------------------------------------
<h5>Required Input</h5>
```{r}
selectInput(inputId = "dataset", label = "Data:",
choices = c('mtcars', 'iris'), selected = 'iris')
dataset = reactive({
set = as.character(input$dataset)
if(set=='iris'){data = iris} else{data = mtcars}
return(data)
})
```
```{r setup}
chart = reactive({
data = dataset()
num_cols <- unlist(lapply(data, is.numeric))
data = data[,num_cols] # only keep numeric columns for histogram
labels <- data %>% names # these will serve as labels for each tab
chart <- purrr::map(.x = data, ~ggplot(data, aes(x=.x))+geom_histogram()+theme_bw()) %>% setNames(labels) # assign names to each element to use later as tab titles
return(chart)
})
```
## Column {.tabset .tabset-fade}
```{r}
out <- reactive({
lapply(seq_along(chart()), function(i) {
a1 <- knitr::knit_expand(text = sprintf("### %s\n", names(chart())[i])) # tab header, auto extracts names of `chart`, %s indicates string
a2 <- knitr::knit_expand(text = "\n```{r, message = F, warning = F}") # start r chunk
a3 <- knitr::knit_expand(text = sprintf("\nchart()[[%d]]", i)) # extract graphs by "writing" out `chart[[1]]`, `chart[[2]]` etc. to be rendered later, %d indicates integer variable
a4 <- knitr::knit_expand(text = "\n```\n") # end r chunk
paste(a1, a2, a3, a4, collapse = '\n') # collapse together all lines with newline separator
})
})
```
`r reactive({knitr::knit(text = paste(out(), collapse = '\n'))})`
When this code is run, the dashboard displays the markdown chunk code, but does not render plots or tabs.
I am able to sightly modify this code to work without reactive, but I need the number of tabs to increase/decrease according to the chosen dataset. Also, I am not allowed to use facet_wrap.
Is this possible?

Connect more than one charts with the same table without affecting one another using crosstalk

I create the flexdashboard below in which I initially create four dataframes. Then three of these dataframes are displayed as charts(dcross2,store,supplier) and one (dcross1) as table.
What I want to achieve is to connect all of these four objects together with crosstalk package in a way thet when the user clicks on a bar the table will respond accordingly. Not the other charts only the table. I believe that Abcd is the key to achieve this since it is common in all dataframes but I do not know how to connect all of them together.
---
title: "Operaitonal dashboard"
author: "Report"
date: 'Date: `r Sys.Date()`'
output:
flexdashboard::flex_dashboard:
orientation: columns
theme: lumen
vertical_layout: scroll
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo=FALSE,
warning= FALSE,
message = FALSE)
library(crosstalk)
library(shiny)
library(plotly)
library(flexdashboard)
library(ggplot2)
library(dplyr)
library(reactable)
##The four dataframes
Abcd<-c("A","A","B","B")
Prod<-c(34,56,56,89)
Div<-c("Ent","Ent","App","High")
dcross1<-data.frame(Abcd,Prod,Div)%>%
SharedData$new()
Counts<-c(45,67,78,56)
dcross2<-data.frame(Div,Abcd,Counts)%>%
SharedData$new()
Store<-c(199,199)
Abcd<-c("A","B")
Oos<-c(500,400)
store<-data.frame(Store,Abcd,Oos)%>%
SharedData$new()
Man<-c("Corp","Adv","Corp","Adv")
Abcd<-c("A","B","A","B")
Counts<-c(45,56,34,78)
Scounts<-c(23,45,67,67)
Per<-c(1,2,3,5)
supplier<-data.frame(Man,Abcd,Counts,Scounts,Per)%>%
SharedData$new()
```
# Out of stock Report {data-icon="fa-cart-arrow-down" data-orientation=rows}
## Row {data-height="200"}
### Out Of Stock: Store Overview {data-width="200"}
```{r Oos Store}
daily_store_oos_gg<-
ggplot(store,
aes(x=Abcd,
y=Oos,
fill=as.factor(Abcd)
)) +
geom_bar(stat="identity", position="dodge")
# Convert to plotly object
daily_store_oos_ply <-
ggplotly(daily_store_oos_gg)
daily_store_oos_ply
```
### Out Of Stock: Division Overview {data-width="200"}
```{r Oos Division}
# Create ggplot object (Aggregated data)
store_division_oos_overview_gg<-
dcross2 %>%
ggplot(aes(x=Div,
y=Counts ,
fill=Abcd,
label = Counts)) +
geom_col(position="fill")
# Create plotly object
store_division_oos_overview_ply<-
ggplotly(store_division_oos_overview_gg)
store_division_oos_overview_ply
```
## Column {data-width=405}
### Supplier Overview Out of Stock
```{r supplier}
# Create ggplot object (Aggregated data)
supplier_oos_overview_gg<-
supplier %>%
ggplot(aes(x=Man ,
y=Scounts
)) +
geom_bar(stat='identity',aes(fill = Abcd)) +
coord_flip()
# Create plotly object
supplier_oos_overview_ply<-
ggplotly(supplier_oos_overview_gg)
supplier_oos_overview_ply
```
### Store Overview Out of Stock
```{r out of stock reactable}
daily_item_oos_rctble<-reactable(
dcross1
)
daily_item_oos_rctble
```

How do I pass real-time progress data to a chunk in Flexdashboard?

I have a large amount of r-code that reads data from Jira and other apps and then will eventually display the results using Flexdashboard/Shiny. I can get the data to display OK, but what I'm looking for is a way to show the progress of the data load on a section of the dashboard while the data is loading.
I've simplified the code showing just a single gauge and minimal dashboard. How can I get the changing variable 'amt' to update the gauge as it changes - hence, a proress bar of sorts?
---
title "Test"
output: flexdashboard::flex_dashboard
runtime: shiny
---
```{r global, include=FALSE}
library(flexdashboard)
for (i in 1:100) {
Sys.sleep(0.1)
amt <- reactive({i})
}
```
Progress
---------------------------
### Progress
```{r}
gaugeOuput("gauge1")
output$gauge1 = renderGauge({gauge(amt(), min = 0, max = 100, symbol = '%')})
```
You can use reactiveTimer() for this:
---
title: "Test"
output: flexdashboard::flex_dashboard
runtime: shiny
---
```{r global}
library(shiny)
rt <- reactiveTimer(1000)
rv <- reactiveVal(0)
observe({
rt()
tick = isolate(rv())
if(tick < 100){
rv(tick + 1)
}
else
rt <- reactiveTimer(Inf)
})
```
Progress
---------------------------
### Progress
```{r}
library(flexdashboard)
output$gauge1 = renderGauge({gauge(rv(), min = 0, max = 100, symbol = '%')})
gaugeOutput("gauge1")
```
It's possible to add a progress bar, although I don't think it's easy. Scroll down to "A more complex Progress example": https://shiny.rstudio.com/articles/progress.html. If you can figure it out and create a reprex, I'd be grateful! I'll share again if I can find an example that works.
Edit: You can do this with the shinybusy package. Copying from their example:
fluidPage(add_busy_bar(color = "#86D0F9")) #make sure to add a color or it will
#be clear and you won't see it
actionButton("go", "Submit")
Create your event reactive object
example <- eventReactive(input$go{
#some function
})
Then add this:
observeEvent(input$go, {
example()
})

R Shiny document: gap when conditional map not displayed

I am producing a Shiny interactive document. I wish to give the user the option of displaying a map conditional on checkbox status, and that map has some reactive content. I am able to achieve this, but not without the space that the map occupies remaining when it is not displayed. I believe this is also true of a plot instead of a map.
Is it possible to have the map's absence leave no gap?
---
title: "Conditional Map"
runtime: shiny
output: html_document
---
```{r setup, include=FALSE, results='hide'}
knitr::opts_chunk$set(echo = FALSE)
library(leaflet)
library(shiny)
```
The map should be present based upon the condition of the checkbox:
```{r}
# coordinates for markers:
Coords = list("London"=c(0,51), "New York" = c(-74,40))
selectInput(inputId = "Loc",label = "Select location", choices = names(Coords))
checkboxInput(inputId = "ShowMap", label="Show map?", value=TRUE)
leafletOutput("Map")
output$Map = renderLeaflet({if(input$ShowMap) leaflet() %>% addTiles %>%
setView(-45,45,zoom=2) %>%
addMarkers(lng=Coords[[input$Loc]][1],lat=Coords[[input$Loc]][2])})
```
## The Next Bit
Some additional content here which should appear directly below the previous content, whether that is the map or the checkbox.
Use conditional panel like so:
conditionalPanel(condition = "input.ShowMap == true",
leafletOutput("Map"))

Leaflet map tiles not visible in reveal.js presentation within R?

Intro:
I am trying to embed a leaflet map into a revealjs presentation within an RMarkdown file. My example below is pretty close, but it is (1) missing tiles, (2) the popups are not displaying, and (3) the legend and font are way too big!
I am not too concerned with how the code blocks look at the moment. I'm planning on using the results = "hide" slide option for my final product.
Thanks in advance!
Reproducible Example:
---
title: "My Presentation"
author: Me
date: 2017-06-23
output:
revealjs::revealjs_presentation:
theme: black
---
## Loading in necessary packages:
```{r}
library(dplyr)
library(sp)
library(rgdal)
library(rgeos)
library(RColorBrewer)
library(classInt)
library(leaflet)
library(htmlwidgets)
```
## Defining our data:
```{r}
lat <- c(45.51158000, 45.50431159, 45.496539)
lon <- c(-122.548056, -122.54775, -122.54788)
no2 <- c(17.37, 25.61, 24.69)
dta <- data.frame(lat, lon, no2)
colnames(dta) <- c("lat","lon","no2")
```
## Create layer of spatial points:
```{r}
points <- SpatialPointsDataFrame(data.frame(x=dta$lon, y=dta$lat), data = data.frame(dta$no2))
plotclr <- (brewer.pal(7, "RdYlGn"))
class <- classIntervals(dta$no2, n = 7, style = "fixed", fixedBreaks = c(0,5,10,15,20,25,30))
colcode <- findColours(class, rev(plotclr))
plot(points, col=colcode, pch=19)
pop1<-paste0("<b>NO2:</b> ", dta$no2, " ppb",
"<br /> <b>Lat:</b> ", dta$lat,
"<br /> <b>Lon:</b> ", dta$lon)
```
## Creating the leaflet map:
```{r}
no2_map <-leaflet()%>%
addTiles('http://{s}.tiles.wmflabs.org/bw-mapnik/{z}/{x}/{y}.png') %>%
addCircleMarkers(data=points, color = "black", radius = dta$no2, fillColor = colcode, fillOpacity=0.7, weight=1, popup=pop1) %>%
addLegend(position = "bottomright", colors = rev(plotclr), labels = rev(c("30","25","20","15","10","5","0")), opacity = 0.9, title = "NO2 (ppb)")
```
---
```{r}
no2_map
saveWidget(no2_map, file="map.html")
```
Unfortunately, reveal.js and Leaflet don't play very well together, and the slide with your maps might be missing layers. This is due to Leaflet not being able to discern the size of the DOM element which serves as the container of the map, because reveal.js resizes all elements dinamically.
The easiest workaround is to just refresh the page when you're in a slide with a Leaflet map. You can also try a deferred call to map.invalidateSize() (by using setTimeout() in plain Javascript)

Resources