Trying to use one of the javascript addons for leaflet - specifically the heatmap functionality - https://github.com/Leaflet/Leaflet.heat
Thing is - I want to incorporate this into Shiny, but leaflet for R doesn't seem to have this addon included by default, so I would have to somehow include this JS manually. The closest I got to figuring out how to do this is through a post on rCharts that showed this:
server.R.
HeatMap$addAssets(jshead = c("http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js"))
HeatMap$setTemplate(afterScript = sprintf("<script>
var addressPoints = %s
var heat = L.heatLayer(addressPoints).addTo(map)
</script>",
rjson::toJSON(dt)))
(taken from: https://github.com/ramnathv/rCharts/issues/498 )
But being not too familiar with JS, and new to leaflet it's still not quite clear how it can be incorporated from beginning to end - i.e. taking this JS from github and ending up with a heatmap created using leaflet on the dataset 'quakes'.
My server side code is something like the following:
library(leaflet)
output$mymap <- renderLeaflet({
leaflet() %>%
addProviderTiles("OpenMapSurfer.Roads",
options = providerTileOptions(noWrap = TRUE))
%>% addMarkers(clusterOptions = markerClusterOptions(), data = quakes))
Where instead of clusterOptions I would like to add a heatmap of the magnitude of the earthquakes (the dataset 'quakes' is included in R so you can see it for yourself).
Any help on figuring this out would be very much appreciated! :)
The setTemplate(afterscript...) bit doesn't work in shiny. Instead you need to use tags$() and render the heatmap output separately to the map.
Here is a basic app that uses heatmaps (inspired by this SO answer )
server.R
library(shiny)
library(rCharts)
dat <- data.frame(Offence = c("Assault","Assault","Assault","Weapon","Assault","Burglary"),
Date = c("2015-10-02","2015-10-03","2015-10-04","2015-04-12","2015-06-30","2015-09-04"),
Longitude = c(-122.3809, -122.3269, -122.3342, -122.2984, -122.3044, -122.2754),
Latitude = c(47.66796,47.63436,47.57665,47.71930,47.60616,47.55392),
intensity = c(10,20,30,40,50,30000))
shinyServer(function(input, output, session) {
output$baseMap <- renderMap({
baseMap <- Leaflet$new()
baseMap$setView(c(47.5982623,-122.3415519) ,12)
baseMap$tileLayer(provider="Esri.WorldStreetMap")
baseMap
})
output$heatMap <- renderUI({
## here I'm creating the JSON through 'paste0()'.
## you can also use jsonlite::toJSON or RJSONIO::toJSON
j <- paste0("[",dat[,"Latitude"], ",", dat[,"Longitude"], ",", dat[,"intensity"], "]", collapse=",")
j <- paste0("[",j,"]")
j
tags$body(tags$script(HTML(sprintf("
var addressPoints = %s
var heat = L.heatLayer(addressPoints).addTo(map)"
, j
))))
})
})
ui.R
library(shiny)
library(rCharts)
shinyUI(fluidPage(
mainPanel(
headerPanel("title"),
chartOutput("baseMap", "leaflet"),
tags$style('.leaflet {height: 500px;}'),
tags$head(tags$script(src="http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js")),
uiOutput('heatMap')
)
))
Edit - Using Google Maps
There is also a way to do this in the development version of googleway. For this you'll need a valid Google API key, and currently it only works in a browser
## devtools::install_github("googleway")
library(googleway)
library(magrittr)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
actionButton(inputId = "traffic", label = "traffic"),
box(width = 10,
height = 600,
google_mapOutput("myMap")
)
)
)
server <- function(input, output){
map_key <- "your_valid_api_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key
## set up some data-------
pl <- "~s|dF}{~rZnNoExBq#|#SfAIjA#~Et#fBBp#Iv#QxCoArNqGfA_#dB]`KgAfVkC|Gu#rAYf#Q|#i#p#m#n#{#^u#`#kAR_ALiADuACiAIeAOy#_#qA{#uB{#sB]gAUmAOaB?oCTkKr#kZZiN?s#Cq#EQDOLILFn#A\\CpI_A|AQjB[BGPOX#LHz#CpAKT?v#KpHu#vD]LGt#Ix#I\\QBGLOVCPJd#Dj#GnFq#`PaBp#KfBQzA[zAq#nAaAx#aA~ByDp#yAXe#VSVO#EVWPCRDJLBF#Hd#TrDj#rK`ADEJGJ#JFBFrSxBJOPCNHHPdBLnCb#bBb#lAf#zA~#lAbApAzAt#nAxA|C~BhHrAxD~AtEb#|#xAtBpBlBzCbB`AZhIhBrFpA|AZl#HRDLENGXORe#DKJSf#wD`#cDt#}INq#ZuEt#mHfBsN~BkS`CmR\\eDnAiKzAcM`CePNmAhAsGXmArAgFtDsM|DaOh#sC^kCf#kDb#uDl#kI\\sHn#yM?gDEoAOsA[}BUiBUsC#qCNuBViBrCcPp#oGHW|#oPBuDI_DKqAy#wD{Ja^}#oFY_CWoDIqBGqEBsENqE`C{^JuA\\aDj#oDn#cDxAcFz#yBtC{Fp#eAn#_An#s#t#}#j#g#bCaBtCsA`GiAzBm#`C}#jBmA~CiC~DcDjCwAfAa#bBe#nBa#pCYlCArDBlCHhCGnC_#~A]vBk#hAa#lF_CnMaGbDeArD}#vB[zEe#jFS`GFfBFxBJzO\\zZfAfCJdEPbDNvDRnEHvD?tEE~BQhC[zAYnCu#bA]dBm#bIkDtBy#bAYhB[rDYxJ[nB#vAHfBLbCf#|C~#vAp#nCdB|A`A`CzApAr#|Al#rBl#bBZbUbCZBzBDvBEtAMnF_AvB[vBOlCAlBFnBXbDr#~Bv#z#`#bBfAdD~BtB`Bv#f#nAn#x#ZZJ~A\\dBTdADtBEbAGnEg#dFi#`DYdDQdF?|DNfCV`BTlCl#dNvD`HnBdLvClAZn#DzB^hCRd#?fA?|#Ih#O`#Ud#a#h#w#\\u#Pm#Lw#HoBq#qK]eLUcIE{DC{AD}Fn#eSLeCJs#RwFRkDf#sCj#aE`AsFhAuGh#gDt#wEp#}En#_FPeBRkDByBCgBEgAS}B{#oEsA}Dy#eCi#yBGq#?s#Ds#V}#Rg#r#u#ZOj#Ml#Az#PrA^fBb#j#HV#f#e#`B}AbB_B]Ie#KeASiO}CmH_B{L}Bk#QTqBTgCAm#g#kCSaAs#V{CdAmDrAuAh#{#Ra#H{#D{Af#wBt#gAb#]ReBl#"
df_line <- decode_pl(pl)
set.seed(123)
df_line$weight <- runif(nrow(df_line), min = 1, max = 100)
## ------------
## plot the map
output$myMap <- renderGoogle_map({
google_map(key = map_key, data = df_line, search_box = F) %>%
add_heatmap(weight = "weight") %>%
add_traffic()
})
}
shinyApp(ui, server)
Related
I am building a small app to summarize some data. my results table has the value of a number of categories that sum to a given total. Now I would like users to be able to input different categories and get the sum of the statistics of those categories OR show them the total of all categories (so selecting all the categories gives the same as just selecting the total). To make the app look a bit cleaner I would like to simply use a single selectizeInput. However, that would mean that if the user selects the category total they should not be able to select any of the other 3 categories and if any of the 3 categories is selected total should be deselected. Otherwise, if the user selects all inputs including the total the sum sum to 2*Total (in my example 20 instead of 10).
Small example (based on https://shiny.rstudio.com/articles/selectize.html)
df <- data.frame(x = c("Total", "A", "B", "C"),
sum_res = c(10, 5, 3, 2))
library(shiny)
ui <- fluidPage(title = 'Selectize examples',
sidebarLayout(
sidebarPanel(
selectizeInput(
'e2',
'2. Multi-select',
multiple = TRUE,
selected = "Total",
choices = df$x
)
),
mainPanel(
helpText('Output of the examples in the left:'),
verbatimTextOutput('ex_out'),
verbatimTextOutput('sum')
)
))
server <- function(input, output) {
output$ex_out <- renderPrint({
str(list(input$e2))
})
output$sum <- renderPrint({
df %>%
filter(x %in% input$e2) %>%
summarise(sum = sum(sum_res))
})
}
shinyApp(ui, server)
This is somewhat related, but not exactly the same as Selectizeinput inputs be mutually exclusive R Shiny.
Ideally this solution would be in the custom javascript within the selectizeInput(), but could also be serverside.
One way to do it is to ignore other selections when Total is selected. Try this
df <- data.frame(x = c("A", "B", "C"),
sum_res = c(5, 3, 2))
library(shiny)
ui <- fluidPage(title = 'Selectize examples',
sidebarLayout(
sidebarPanel(
selectizeInput(
'e2',
'2. Multi-select',
multiple = TRUE,
selected = "Total",
choices = c("Total",unique(df$x))
)
),
mainPanel(
helpText('Output of the examples in the left:'),
verbatimTextOutput('ex_out'),
verbatimTextOutput('sum')
)
))
server <- function(input, output) {
output$ex_out <- renderPrint({
str(list(input$e2))
})
output$sum <- renderPrint({
if ("Total" %in% input$e2 | length(input$e2)==3) df1 <- df
else df1 <- df %>% filter(x %in% input$e2)
df1 %>% summarise(sum = sum(sum_res))
})
}
shinyApp(ui, server)
I have this app:
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(includeScript("www/script.js"),
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(session, input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
observe({
if(input$bins > 25) {
Message1 = input$bins
session$sendCustomMessage("bla", Message1)
}
})
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
My Oberserver checks if the value is larger than 25. I send the value to Javascript.
$( document ).ready(function() {
Shiny.addCustomMessageHandler("bla", dosomething);
function dosomething(Message1) {
alert(Message1)
}
});
The code works perfectly, BUT every time i change the slider, the code seems to get executed one more time than before. After changing it 2 times, I get 3 alerts for example. Why is that happening and what can I do against it?
The reason this is so broken is that your observe() is inside the renderPlot() function. Generally speaking, observers should not be inside render functions, it's almost always a recipe for very strange undefined behaviours to happen!
Simply moving the observer outside of the render function fixes your problem. This also fixes another problem you didn't mention, that the alert box was actually showing the previous number rather than the current one.
For completeness, this is the correct server code:
server <- function(session, input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
observe({
if(input$bins > 25) {
Message1 = input$bins
session$sendCustomMessage("bla", Message1)
}
})
}
For a certain online course, I made a quick interactive map using leaflet in Rmarkdown and published it to Rpubs. The data is about world cities and their population.
I was trying to make colour gradient based on the population size of a city. For example red for Tokyo and green for a city with lesser population (~=1-2). Below is the code I used to generate the published map here:
---
title: "Global population concentration"
author: "Piyush Verma"
date: "December 28, 2017"
output: html_document
---
```{r setup, echo=FALSE}
knitr::opts_chunk$set(fig.width=12, fig.height=8)
```
```{r, message=FALSE,warning=FALSE,results='hide', echo=FALSE}
set.seed(2017-12-27)
library("data.table")
cities<-fread("./worldcities.csv")
cities<-cities[cities$pop>0,]
```
```{r, message=FALSE,warning=FALSE, echo=FALSE, width = 40, height = 30}
library("leaflet")
pal <- colorNumeric(palette = "Red",domain = cities$pop)
cities2<-cbind(cities,col=pal(cities$pop))
my_map <- cities2 %>% leaflet() %>% addTiles() %>% addCircles(weight = 1, radius = sqrt(cities$pop) * 110) %>% setView(lat = 51.4826, lng = 0.0077, zoom = 2)
my_map
```
I downloaded the data from here:
I tried using help from here but ended up producing error Error in polygonData/default(data): Dont know how to get path data from object of class numeric
Any help would be a great help for the future.
Thank you.
Change your code to
pal <- colorNumeric(palette = c("green", "red"), domain = cities$pop)
my_map <- cities2 %>% leaflet() %>% addTiles() %>%
addCircles(weight = 1, radius = sqrt(cities$pop) * 110, color = ~pal(cities$pop)) %>%
setView(lat = 51.4826, lng = 0.0077, zoom = 2)
and it works. Needs some fine-tuning though. colorQuantile might be better suited.
I am in the circuit board manufacturing industry, and we measure the temperature at a variety of locations on our circuit boards in an effort to identify if certain components are exceeding their required temperatures.
I have some exposure to .js visualization libraries, RStudio and Shiny. I would like to implement this application into an existing R or ShinyDashboard that I am developing.
What I would like to accomplish is to have a 2d or 3d image of my circuit board, and a heatmap that takes the maximum temperature and shows it on that image. My data sets have columns of temperatures over time for up to 20 different locations.
I know this is a crude description, but I was wondering if anyone has any initial suggestions to accomplish this?
Update1
This is the result of running the first code:
Update2
Here is the sample dataset that I would like to base this heatmap off of.
https://docs.google.com/spreadsheets/d/11I19uQyND7YehKrYd-NPiib4bQSHmHmWENFvausigvU/edit?usp=sharing
You could use ggplot for something like this, for example:
library(grid)
library(ggplot2)
# Download image
library(jpeg)
download.file("http://www.expresspcb.com/wp-content/uploads/2015/06/PhotoProductionPCB_TL_800.jpg","pcb.jpg")
img <- readJPEG("/home/oskar/pcb.jpg")
## Load image, use this if you can't download image
#library(png)
#img <- readPNG(system.file("img", "Rlogo.png", package="png"))
g <- rasterGrob(img, interpolate=TRUE,width=1,height=1)
coords <- data.frame("x"=c(0,1),"y"=c(0,1))
# Simulate data
df <- data.frame("x.pos" = c(runif(200),runif(20,min=0.5,max=0.8)),
"y.pos" = c(runif(200),runif(20,min=0.5,max=0.8)),
"heat" = c(runif(200),runif(20,min=0.7,max=1)))
# Show overlay of image and heatmap
ggplot(data=df,aes(x=x.pos,y=y.pos,fill=heat)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
stat_density2d( alpha=0.2,aes(fill = ..level..), geom="polygon" ) +
scale_fill_gradientn(colours = rev( rainbow(3) )) +
scale_x_continuous(expand=c(0,0)) +
scale_y_continuous(expand=c(0,0))
# Show where max temperature is
dat.max = df[which.max(df$heat),]
ggplot(data=coords,aes(x=x,y=y)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
geom_point(data=dat.max,aes(x=x.pos,y=y.pos), shape=21,size=5,color="black",fill="red") +
geom_text(data=dat.max,aes(x=x.pos,y=y.pos,label=round(heat,3)),vjust=-1,color="red",size=10)
The ggplot image part is from here
You can also bin the data manually and overlay it on the image like this (run this part after the script above):
# bin data manually
# Manually set number of rows and columns in the matrix containing sums of heat for each square in grid
nrows <- 30
ncols <- 30
# Define image coordinate ranges
x.range <- c(0,1) # x-coord range
y.range <- c(0,1) # x-coord range
# Create matrix and set all entries to 0
heat.density.dat <- matrix(nrow=nrows,ncol=ncols)
heat.density.dat[is.na(heat.density.dat)] <- 0
# Subdivide the coordinate ranges to n+1 values so that i-1,i gives a segments start and stop coordinates
x.seg <- seq(from=min(x.range),to=max(x.range),length.out=ncols+1)
y.seg <- seq(from=min(y.range),to=max(y.range),length.out=nrows+1)
# List to hold found values
a <- list()
cnt <- 1
for( ri in 2:(nrows+1)){
for ( ci in 2:(ncols+1)){
# Get current segments, for example x.vals = [0.2, 0.3]
x.vals <- x.seg [c(ri-1,ri)]
y.vals <- y.seg [c(ci-1,ci)]
# Find which of the entries in the data.frame that has x or y coordinates in the current grid
x.inds <- which( ((df$x.pos >= min(x.vals)) & (df$x.pos <= max(x.vals)))==T )
y.inds <- which( ((df$y.pos >= min(y.vals)) & (df$y.pos <= max(y.vals)))==T )
# Find which entries has both x and y in current grid
inds <- which( x.inds %in% y.inds )
# If there's any such coordinates
if (length(inds) > 0){
# Append to list
a[[cnt]] <- data.frame("x.start"=min(x.vals), "x.stop"=max(x.vals),
"y.start"=min(y.vals), "y.stop"=max(y.vals),
"acc.heat"=sum(df$heat[inds],na.rm = T) )
# Increment counter variable
cnt <- cnt + 1
}
}
}
# Construct data.frame from list
heat.dens.df <- do.call(rbind,a)
# Plot again
ggplot(data=heat.dens.df,aes(x=x.start,y=y.start)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
geom_rect(data=heat.dens.df, aes(xmin=x.start, xmax=x.stop, ymin=y.start, ymax=y.stop, fill=acc.heat), alpha=0.5) +
scale_fill_gradientn(colours = rev( rainbow(3) )) +
scale_x_continuous(expand=c(0,0)) +
scale_y_continuous(expand=c(0,0))
Coordinate conversion from your data to my format can be done like:
sensor.data <- read.csv("~/Sample_Dataset.csv - Sample_Dataset.csv.csv")
# Create position -> coord conversion
pos.names <- names(sensor.data)[ grep("*Pos",names(sensor.data)) ] # Get column names with "Pos" in them
mock.coords <<- list()
lapply(pos.names, function(name){
# Create mocup coords between 0-1
mock.coords[[name]] <<- data.frame("x"=runif(1),"y"=runif(1))
})
# Change format of your data matrix
df.l <- list()
cnt <- 1
for (i in 1:nrow(sensor.data)){
for (j in 1:length(pos.names)){
name <- pos.names[j]
curr.coords <- mock.coords[[name]]
df.l[[cnt]] <- data.frame("x.pos"=curr.coords$x,
"y.pos"=curr.coords$x,
"heat" =sensor.data[i,j])
cnt <- cnt + 1
}
}
# Create matrix
df <- do.call(rbind, df.l)
I have come across this kind of a plot that performs hierarchical clustering over a given set of timeseries data. Can someone tell me how to draw such plots?
I am open to implementations in R or Javascript, especially using d3.js.
You can always create the plot by hand:
with base graphics, you the fig parameter
allows you to add plots inside another plot.
# Sample data
n <- 100
k <- 6
d <- matrix(rnorm(k*n),nc=k)
d[,2] <- d[,1] # To help check the results
colnames(d) <- LETTERS[1:k]
x <- apply(d,2,cumsum)
r <- hclust(dist(t(d)))
# Plot
op <- par(mar=c(0,0,0,0),oma=c(0,2,0,0))
plot(NA,ylim=c(.5,k+.5), xlim=c(0,4),axes=FALSE)
# Dendrogram. See ?hclust for details.
xc <- yc <- rep(NA,k)
o <- 1:k
o[r$order] <- 1:k
for(i in 1:(k-1)) {
a <- r$merge[i,1]
x1 <- if( a<0 ) o[-a] else xc[a]
y1 <- if( a<0 ) 0 else yc[a]
b <- r$merge[i,2]
x2 <- if( b<0 ) o[-b] else xc[b]
y2 <- if( b<0 ) 0 else yc[b]
lines(
3+c(y1,i,i,y2)/k,
c(x1,x1,x2,x2),
lwd=k-i
)
xc[i] <- (x1+x2)/2
yc[i] <- i
}
# Time series
axis(2,1:k,colnames(d)[r$order],las=1)
u <- par()$usr
for(i in 1:k) {
f <- c(0,3,i-.5,i+.5)
f <- c(
(f[1]-u[1])/(u[2]-u[1]),
(f[2]-u[1])/(u[2]-u[1]),
(f[3]-u[3])/(u[4]-u[3]),
(f[4]-u[3])/(u[4]-u[3])
)
par(new=TRUE,fig=f)
plot(x[,r$order[i]],axes=FALSE,xlab="",ylab="",main="",type="l",col="navy",lwd=2)
box()
}
par(op)
(After writing this, I realize that it is probably easier to do with layout...)