Related
I am trying to create a time line plot using leaflet and leaftime packages. I want to set custom color in addTimeline to specify each point to his groups, as follows:
library(leaflet)
library(leaftime)
library(geojsonio)
power_d <- data.frame(
"Latitude" = c(
33.515556, 38.060556, 47.903056, 49.71, 49.041667, 31.934167,
54.140586, 54.140586, 48.494444, 48.494444
),
"Longitude" = c(
129.837222, -77.789444, 7.563056, 8.415278, 9.175, -82.343889,
13.664422, 13.664422, 17.681944, 17.681944
),
"start" = seq.Date(as.Date("2015-01-01"), by = "day", length.out = 10),
"end" = seq.Date(as.Date("2015-01-01"), by = "day", length.out = 10) + 1,
color_temp=rep(c("red","blue","green"),len=10)
)
power_geo <- geojsonio::geojson_json(power_d ,lat="Latitude",lon="Longitude")
leaflet() %>%
addTiles() %>%
setView(44.0665,23.74667,2) %>%
addTimeline(data = power_geo,
timelineOpts = timelineOptions(
styleOptions = styleOptions(
radius = 5,
color=color_temp,
fillColor = color_temp,
fillOpacity = 1
)
)
)
Unfortunately I got following error:
Error in lapply(x, f) : object 'color_temp' not found
I also try replacing color_temp with power_d$color_temp, the code run without error, but the color of points do not change. The color arguments not work in above code, why? and how to fix it?
It doesn't seem as if you can pass a vector of colours with the standard styleOptions, however, an example from the help page for ?addTimeline show how you can add colours based on the data using a little JavaScript (which thankfully is provided in the example).
Using the example that starts "# to style each point differently based on the data" you need to change it slightly to point to your colour vector e.g. change data.properties.color to data.properties.color_temp. Running the code below leads to
# code
leaflet(power_geo) %>%
addTiles() %>%
setView(44.0665,23.74667,2) %>%
addTimeline(
timelineOpts = timelineOptions(
styleOptions = NULL,
pointToLayer = htmlwidgets::JS(
"
function(data, latlng) {
return L.circleMarker(
latlng,
{
radius: 25,
color: data.properties.color_temp,
fillColor: data.properties.color_temp,
fillOpacity: 1
}
);
}
"
)
)
)
I'm seeking assistance with my shiny dashboard issue.
Essentially, I have a single selectInput menu, however want to be able to select multiple variables and have them all plotted on the same graph.
At the moment I can get it to plot a single selected variable on the plot.ly graph, however even when I select multiple variables, it will still only plot the first variable selected:
current single variable output
Additionally, when the app is first run, I get this error until I manually select a variable:
error received when first displayed
This is a simplified version of the code I'm working with so far:
global_indices <- read_excel("Market_Data.xlsx",
sheet = 4,
col_names = FALSE,
skip = 5)
global_indices_clean <- global_indicies[,c(1,3,7,9,13,21,23)]
colnames(global_indices_clean) <- c("Date", "Australia", "US", "UK", "Germany", "Japan", "Hong_Kong")
global_indices_2y2 <- global_indices_clean %>% filter(between(Date, now() - years(2), now()))
header <- dashboardHeader(
title = "Dashboard"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Global Indices",
tabName = "global_indices")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "global_indices",
fluidRow(
box(plotlyOutput("plot_3"), title = "Developed indices", status = "primary", width = 4, ""),
box(plotlyOutput(""), title = "", status = "primary", width = 4, ""),
box(plotlyOutput(""), title = "", status = "primary", width = 4, "")
),
fluidRow(
box(selectInput("global_indices_input", "Indices",
choices =
list("Australia" = "Australia",
"US" = "US",
"UK" = "UK",
"Germany" = "Germany",
"Japan" = "Japan",
"Hong Kong" = "Hong_Kong"),
multiple = TRUE),
width = 4)
)
)
)
)
ui <- dashboardPage(
header,
sidebar,
body
)
server <- function(input, output) {
output$plot_3 <- renderPlotly({
plot_3 <- plot_ly(
global_indices_2y2, x = global_indices_2y2$Date, y = ~get(input$global_indices_input), type="scatter", mode="lines"
)
})
}
shinyApp(ui, server)
I can't provide the dataset itself, however below is a small section of it:
> str(global_indices_2y2)
'data.frame': 478 obs. of 7 variables:
$ Date : POSIXct, format: "2018-01-29" "2018-01-30" "2018-01-31" "2018-02-01" ...
$ Australia: num 107 106 106 107 108 ...
$ US : num 113 112 112 112 110 ...
$ UK : num 104 103 102 102 101 ...
$ Germany : num 103.9 102.9 102.8 101.4 99.7 ...
$ Japan : num 116 114 113 115 114 ...
$ Hong_Kong: num 120 118 119 118 118 ...
I've read through dozens of threads on here over the last few days, however they all seem to focus on issues around multiple selectInput parameters, instead of a single selectInput requiring the ability to select and display multiple outputs.
Any help that you are able to provide would be greatly appreciated!
One approach would be to create a separate reactive to filter your data, and use the filtered data in your plot. First, I would consider converting your data to long format (e.g., using tidyverse pivot_longer). For example:
global_indices_2y2 <- data.frame(
Date = as.POSIXct(c("2018-01-29", "2018-01-30", "2018-01-31", "2018-02-01")),
Australia = c(107, 106, 106, 107),
US = c(113,112,112,112),
UK = c(104,103,102,102)
) %>%
pivot_longer(cols = -Date, names_to = "country", values_to = "index")
Then add reactive to filter based on multiple selections in your server:
mydata <- reactive({
global_indices_2y2 %>%
filter(country %in% input$global_indices_input)
})
Then plot filtered data:
output$plot_3 <- renderPlotly({
plot_3 <- plot_ly(
mydata(),
x = ~Date,
y = ~index,
name = ~country,
type="scatter",
mode="lines"
)
})
I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
I have two data sets df_state and df_city.
df_state has a summed up of a numeric value(net_value_x).
df_city has a break down of the numeric value(value_x) at city level
This is just a sample for the sate Texas:
df_state:
state_abb, net_value_x
.
.
TX 18.94
.
.
df_city:
state_abb, city, value_x
.
.
TX Dallas 14
TX Houston 2
TX Austin 2.94
.
.
This is the code i used to plot at state level using hcmap function from highcharter.
hcmap("countries/us/us-all", data = df_state, value = "net_value_x",
joinBy = c("hc-a2", "code"), name = "net_value_x",
dataLabels = list(enabled = TRUE, format = "{point.name}"),
borderColor = "#FAFAFA", borderWidth = 0.1,
tooltip = list(valueDecimals = 2))
This is the map that i get. Hovering sample data for Texas.
What I need is to drill down this further into city level. Also i may get county level data in the future.
I am visualizing something like this in the link:
highchart drilldown
While the drilldown feature of highcharter is useful, when you have data in every state, it would require loading the map for each underlying state at render. An approach I have taken is to essentially switch between plotting the state map and a county map as follows.
## Library
library(shiny)
library(shinyjs)
library(dplyr)
library(highcharter)
library(stringr)
## Load maps at start for speed
maps <- sapply(
X = c("us-all", "us-tx-all"),
simplify = FALSE,
FUN = function(x) { highcharter::download_map_data(paste0("countries/us/", x)) }
)
ui <- shiny::fluidPage(
shinyjs::useShinyjs(),
highcharter::highchartOutput(outputId = "map"),
shiny::uiOutput(outputId = "ui")
)
server <- function(input, output, session) {
## USA map with just TX as example
state_map <- shiny::reactive({
highcharter::highchart() %>%
highcharter::hc_add_series_map(
map = maps[["us-all"]],
df = data.frame(state_abbr = c("TX"), y = c(10)),
joinBy = c("postal-code", "state_abbr"),
value = "y"
) %>%
highcharter::hc_plotOptions(
series = list(
allowPointSelect = TRUE,
events = list(
click = htmlwidgets::JS(
"function(event) {
Shiny.setInputValue(
'geo_click',
event.point.state_abbr,
{priority: 'event'}
);
}"
)
)
)
)
})
## County map
county_map <- shiny::reactive({
highcharter::highchart() %>%
highcharter::hc_add_series_map(
map = maps[[paste0("us-", stringr::str_to_lower(input$geo_click), "-all")]],
df = data.frame(city = c("Gray", "Leon", "Lamb", "Duval"), y = c(1, 4, 2, 3)),
joinBy = c("name", "city"),
value = "y"
)
})
## Set to state map at outset
output$map <- highcharter::renderHighchart({ state_map() })
## If state clicked, add button to go back to state map
output$ui <- shiny::renderUI({
if (!is.null(input$geo_click)) {
shiny::actionButton(
inputId = "geo_button",
label = "Return to USA Map"
)
}
})
## If button clicked, reset input, hide button, and go back to state map
shiny::observeEvent(
eventExpr = input$geo_button,
handlerExpr = {
output$map <- highcharter::renderHighchart({ state_map() })
shinyjs::hide(id = "geo_button")
}
)
## If state clicked, go to county map and show button
shiny::observeEvent(
eventExpr = input$geo_click,
handlerExpr = {
output$map <- highcharter::renderHighchart({ county_map() })
shinyjs::show(id = "geo_button")
}
)
}
shiny::shinyApp(ui = ui, server = server)
This question already has answers here:
Plotting routes that cross the international dateline using leaflet library in R
(3 answers)
Closed 4 years ago.
I'm creating a map of Australian airports and their international destinations using R-Leaflet.
Here is my sample data:
df<-data.frame("Australian_Airport" = "Brisbane",
"International" = c("Auckland", "Bandar Seri Begawan","Bangkok","Christchurch","Denpasar","Dunedin","Hamilton","Hong Kong","Honiara","Kuala Lumpur"),
"Australian_lon" = c(153.117, 153.117,153.117,153.117,153.117,153.117, 153.117, 153.117, 153.117, 153.117),
"Australian_lat" = c(-27.3842,-27.3842,-27.3842,-27.3842,-27.3842,-27.3842, -27.3842, -27.3842, -27.3842, -27.3842),
"International_lon" = c(174.7633, 114.9398, 100.5018, 172.6362, 115.2126,-82.77177, -84.56134, 114.10950, 159.97290, 101.68685),
"International_lat" = c(-36.848460, 4.903052, 13.756331, -43.532054,-8.670458,28.019740, 39.399501, 22.396428, -9.445638, 3.139003)
)
I thought it would be cool to use curved flight paths using gcIntermediate, so I created a SpatialLines object:
library(rgeos)
library(geosphere)
p1<-as.matrix(df[,c(3,4)])
p2<-as.matrix(df[,c(5,6)])
df2 <-gcIntermediate(p1, p2, breakAtDateLine=F,
n=100,
addStartEnd=TRUE,
sp=T)
And then I plotted it using leaflet and Shiny:
server <-function(input, output) {
airportmap<- leaflet() %>% addTiles() %>%
addCircleMarkers(df, lng = df$Australian_lon, lat = df$Australian_lat,
radius = 2, label = paste(df$Australian_Airport, "Airport"))%>%
addPolylines(data = df2, weight = 1)
output$mymap <- renderLeaflet({airportmap}) # render the base map
}
ui<- navbarPage("International flight path statistics - top routes",
tabPanel("Interactive map",
leafletOutput('mymap', width="100%", height=900)
)
)
# Run the application
shinyApp(ui = ui, server = server)
It looks like this:
So the paths are incorrect if they cross the date line. Changing breakAtDateLine to FALSE doesn't fix it (the line disappears but the path is still broken). At this stage, I suspect I may need to use a different mapping system or something but I'd be very grateful if anyone has some advice.
Thanks in advance.
Overview
I set the max bounds and minimum zoom level to only display the world map once. It looks okay in the RStudio viewer but fails when I display it in browser. I'm hoping this helps spark other answers.
Code
# load necessary packages
library( leaflet )
library( geosphere )
# create data
df <-
data.frame("Australian_Airport" = "Brisbane",
"International" = c("Auckland", "Bandar Seri Begawan","Bangkok","Christchurch","Denpasar","Dunedin","Hamilton","Hong Kong","Honiara","Kuala Lumpur"),
"Australian_lon" = c(153.117, 153.117,153.117,153.117,153.117,153.117, 153.117, 153.117, 153.117, 153.117),
"Australian_lat" = c(-27.3842,-27.3842,-27.3842,-27.3842,-27.3842,-27.3842, -27.3842, -27.3842, -27.3842, -27.3842),
"International_lon" = c(174.7633, 114.9398, 100.5018, 172.6362, 115.2126,-82.77177, -84.56134, 114.10950, 159.97290, 101.68685),
"International_lat" = c(-36.848460, 4.903052, 13.756331, -43.532054,-8.670458,28.019740, 39.399501, 22.396428, -9.445638, 3.139003)
, stringsAsFactors = FALSE
)
# create curved lines
curved.lines <-
gcIntermediate(
p1 = as.matrix( x = df[ , 3:4 ] )
, p2 = as.matrix( x = df[ , 5:6 ] )
, breakAtDateLine = TRUE
, n = 1000
, addStartEnd = TRUE
, sp = TRUE
)
# create leaflet
airport <-
leaflet( options = leafletOptions( minZoom = 1) ) %>%
setMaxBounds( lng1 = -180
, lat1 = -89.98155760646617
, lng2 = 180
, lat2 = 89.99346179538875 ) %>%
addTiles() %>%
addCircleMarkers( data = df
, lng = ~Australian_lon
, lat = ~Australian_lat
, radius = 2
, color = "red"
, label = paste( ~Australian_Airport
, "Airport" )
) %>%
addCircleMarkers( data = df
, lng = ~International_lon
, lat = ~International_lat
, radius = 2
, color = "blue"
, label = paste( ~International
, "Airport" )
) %>%
addPolylines( data = curved.lines
, weight = 1
)
# display map
airport
# end of script #
If you are interested in another mapping library, then googleway uses Google Maps, which in my experience is better at handling lines that cross the date line.
Notes
To use Google Maps you need an API key
Currently only sf objects are supported, not sp
This will also work in shiny; I'm just showing you the basic map here
I authored googleway
library(sf)
library(googleway)
## convert the sp object to sf
sf <- sf::st_as_sf(df2)
set_key("your_api_key")
google_map() %>%
add_polylines(data = sf)