Friday, 30 June 2017

Trick a Shiny Event Listener

Shiny allows you to build a graphical user interface for your R script. The so-called Shiny Apps are specific R scripts that run on special servers. The script is split into two parts: a part that does all the heavy duty calculations on the server; and a part that generates a graphical user interface to interact with the user. I don't intend to explain Shiny in detail in this post. You can consult the Shiny page, which offers excellent information and tutorials.

In this post I will focus on a specific issue with Shiny. Information thrown from the user interface can be caught by ‘event observers’. For instance, when a user clicks a button on the interface this can be detected on the server, which then executes a specific part of the script. Shiny offers many standard user interface elements, but custom elements can also be created.

You can for instance create a link that can be clicked, which then sends information to the server. The problem is that such ‘events’ (clicks) will only be detected by the Shiny server when the information that is being send changes. So, when you create a custom interface element that should send the same information each time it is clicked, it will not be detected.

In the example below I show how you can work around this issue. I solved it by negating (i.e., multiplying the information with minus one) each time the custom interface element is clicked. This way, it will get detected each time by the server. On the server side you only need to take the absolute value of the data sent by the interface.

Below you will find a fully commented source code showing the work around described in this post. It also shows you the App actually running on the shinyapps.io server.

Note: the app runs under my free account at shinyapps.io. So, when it is not working, I probably ran out of my monthly server-time. In that case please come back later and try again. Or get the source code from my Gist:

# This part of the code generates the user interface show at the client's side.
# For details and tutorials go to http://shiny.rstudio.com
ui <- shinyUI(fluidPage(
# This adds a tiny bit of javascript to the client side's web page.
# It defines a global variable 'negator', which is negated when
# the javascript function negate() is called.
# This can be used to trick Shiny's event observers.
tags$head(tags$script("var negator=1;
function negate() {
negator = -negator
return(negator)
}")),
# A custom user interface element:
# If you click me twice in a row, the second time, nothing will happen:
p(a("I'm a custom interface", href = "#",
onclick = "Shiny.onInputChange(\"customInterface\", 1);"),
"clicking me twice won't work as intended..."),
# Another custom user interface element:
# If you click me twice in a row, the siny server will respond (because
# the value that is being passed is negated):
p(a("I'm another custom interface", href = "#",
onclick = "Shiny.onInputChange(\"customInterface\", 2*negate());"),
"clicking me twice will work as intended..."),
# Output text will be shown here:
verbatimTextOutput("outputText"),
p("Source code is shown below")
))

# This part of the code runs on a Shiny server and interacts with the
# user interface shown at the client's side.
# For details and tutorials go to http://shiny.rstudio.com
server <- shinyServer(function(input, output, server) {
# Make these character strings 'reactive'. That way
# the output text is automatically update when these
# values are changed.
values <- reactiveValues(state = c("Interface1: Waiting for clicks",
"Interface2: Waiting for clicks"))
# Try to count the number of clicks on each interface. Initialize the counter
interface <- c(-1, -1)
# observer for clicks on any of the custom interface elements:
observeEvent(input$customInterface, {
# This event observer will always respond to clicks on the second
# interface, as it's value is negated with each click.
# We just need to make sure that we take the absolute value of
# any negated values:
i <- abs(input$customInterface)
# count the number of clicks and reset once they have been clicked twice:
interface[i] <<- (interface[i] + 1)%%2
if (interface[i] == 0) values$state[i] <- sprintf("Interface%i: click me once, shame on you!", i)
if (interface[i] == 1) values$state[i] <- sprintf("Interface%i: click me twice, shame on me!", i)
})
# render the output text:
output$outputText <- renderText(paste0(c(values$state[1],
values$state[2]), collapse = "\n"))
})

Saturday, 7 January 2017

Filling SpatialPolygons with an image

Plotting country outlines is really easy in R, but making those plots a bit more fancy can be frustrating. I thought it would be nice to fill the country outlines with an image rather than with a solid colour. How hard could it be? After some googling it appears that there is very little documentation on this topic. The only document that I found was by Paul Murrel (2011). He plots a black filled country shape first and then captures the rasterized shape using the grid.cap function from the grid package. This captured raster is then used as a mask on the image that needs to be plotted in the shape of a country.

I'm having difficulties with this approach for two reasons: one, I can't seem to get grid.cap working as it should; two, I don't like having to plot the shape of a country first in order to create a mask. The first matter is probably my own wrongdoing, but all the grid.cap function returns me is a matrix of white pixels. I grew tired of figuring out what I was doing wrong. For the second aspect, I think a more direct approach should be possible by using the ‘over’ function from the sp package.

So these are the steps that I took to tackle the problem:

  1. Download the country shape
  2. Download a suitable png image
  3. Georeference the image, such that it matches the location of the country
  4. Use the ‘over’ function to determine which pixels are inside the country shape
  5. Plot the pixels of the image that are inside the country and plot the outline

In this post I will show you how to create the image shown below, where each country is filled with an image of their respective flag. Below I will explain in a bit more detail how this image was created, following the steps listed above. I've also provided the script used to create the image below, where each of the steps are also clearly marked.

The country shapes for step 1 are downloaded from GADM using the getData function from the raster package. Of course you can use any SpatialPolygons object from any other source.

The country flag png images are downloaded from wikipedia (step 2). So this example shows how to download png image and turn it into a usable format. If you like, you can use any image format like jpg or tif, but that will require some modification of the code presented here.

To understand the next step (3), I'm using georeferencing and I may need to explain what that means. Basically, this is telling where and how the image should be positioned in the coordinate reference system (CRS) of the SpatialPolygons objects (the country outlines). In this step I'm instructing the system to stretch the image to the bounding box of the respective country. This also means that the aspect ratio of the original image is probably messed up. If you would like to keep the original aspect ratio, you need to modify this step. The image was downloaded as an array with the red, green and blue component in separate dimensions. With the brick function from the raster package this array is turned into a correctly georeferenced brick object.

Now that we have properly positioned the image, we need to determine which pixels are located inside the country outlines (step 4). For this purpose, we use the ‘over’ function from the sp package. This function will not accept a raster brick object as input. The raster brick object is therefore cast into a SpatialGrid format. The function will return a dataframe with the country shape element that matches with a specific grid cell. From this information it can be derived whether the pixel is situated inside or outside the country outline. The pixel values for those situated outside the country outlines are set to NA. Note that this can be a time-consuming step. Especially when the resolution of your image is high, and/or the country outline is complex (i.e., contains details, a lot of islands and/or holes), so either be patient. Alternatively, you can speed up the process by either lowering the resolution of your image (hint: focal) or simplifying the country outline (hint: gSimplify).

All there is left to do is to plot the image and the outline (step 5). I use the plotRGB function from the raster package to plot the image. Don't forget to set the ‘bgalpha’ argument to 0, to ensure that NA values are plotted as transparent pixels. Otherwise, it will plot white pixels over anything that has previously been plotted.

I've wrapped four of the five steps in a function, such that I could easily repeat these steps for different countries. Hopefully this post will help you to create your own cool graphics in R. Good luck, and please let me know in the comments if any of the steps are not clear...

## Required libraries for this example
library(png)
library(sp)
library(maptools)
library(raster)
## A function as a wrapper around 4 of the 5 steps
## described in the main text of the blog....
## As input it requires a SpatialPolygons object
## and the URL to the png image that will be used
## to fill the SpatialPolygons object. Additional
## arguments are passed onto the plotRGB function
## from the raster package.
plot.masked.image <- function(sp, png.url, ...) {
###############################################
## STEP 2 ##
###############################################
## First step is to read the png file, in this
## case from an url...
## Note that step 1 is shown below and is executed
## before calling this function...
## open an url connection to the png file
u <- url(png.url, "rb")
## I'm assuming here that the png file is less
## then 10 MiB (just increase the number if it is larger).
img.dat <- readBin(u, "raw", 10*1024*1024)
## close the url connection...
close(u)
## convert the raw data read from the file into a
## raster object:
img.dat <- readPNG(img.dat)
###############################################
## STEP 3 ##
## Georeference the image, such that it ##
## matches the location of the country ##
###############################################
## convert the raster object into
## a raster brick object and georeference
## it using the extent and CRS of the
## SpatialPolygons object 'sp'.
img <- brick(img.dat,
xmn = extent(sp)@xmin,
xmx = extent(sp)@xmax,
ymn = extent(sp)@ymin,
ymx = extent(sp)@ymax,
crs = CRS(proj4string(sp)))
###############################################
## STEP 4 ##
## Use the 'over' function to determine ##
## which pixels are inside the country shape ##
###############################################
indices <- over(as(img, "SpatialGrid"), sp)
## set the RGB values that do not overlap with
## SpatialPolygons object sp to NA
img[is.na(indices)] <- NA
###############################################
## STEP 5 ##
## Plot the pixels of the image that are ##
## inside the country and plot the outline ##
###############################################
## This is done by plotting the resulting
## rasterbrick as RGB.
## 'bgalpha = 0' is important as otherwise
## you may interfere with previously plotted
## shapes...
plotRGB(img, 1, 2, 3, 1, bgalpha = 0, ...)
}
###############################################
## STEP 1 ##
## Download the country shape(s) ##
###############################################
## Download several country's outlines from gadm.org:
nld <- raster::getData("GADM", country = "NLD", level = 1)
nld <- unionSpatialPolygons(nld, nld@data$ENGTYPE_1 != "Water body")[2]
uk <- raster::getData("GADM", country = "GBR", level = 0)
bel <- raster::getData("GADM", country = "BEL", level = 0)
fr <- raster::getData("GADM", country = "FRA", level = 0)
de <- raster::getData("GADM", country = "DEU", level = 0)
lux <- raster::getData("GADM", country = "LUX", level = 0)
## specify a bounding box, to initialise the base plot
box <- as(extent(-5.5, 8, 48, 58.5), "SpatialPolygons")
proj4string(box) <- proj4string(nld)
## open a graphics device for the resulting plot and save as png:
png("flagmap.png", 400, 500, type = "cairo")
## Get rid of the margins
par(mar = c(0, 0, 0, 0))
## Initialise the base plot
plot(box, border = NA, xaxs = "i", yaxs = "i")
## Call the magical function defined above.
## For each country use the flag image as
## available from wikipedia.
## The resolution of the flag-image can be
## increased, simply by increasing the 800px
## bit in the url into for instance 1200px...
plot.masked.image(nld, "https://upload.wikimedia.org/wikipedia/commons/thumb/2/20/Flag_of_the_Netherlands.svg/800px-Flag_of_the_Netherlands.svg.png", add = T)
plot(nld, add = T, lwd = 2)
plot.masked.image(bel, "https://upload.wikimedia.org/wikipedia/commons/thumb/6/65/Flag_of_Belgium.svg/800px-Flag_of_Belgium.svg.png", add = T)
plot(bel, add = T, lwd = 2)
plot.masked.image(lux, "https://upload.wikimedia.org/wikipedia/commons/thumb/d/da/Flag_of_Luxembourg.svg/800px-Flag_of_Luxembourg.svg.png", add = T)
plot(lux, add = T, lwd = 2)
plot.masked.image(uk, "https://upload.wikimedia.org/wikipedia/en/thumb/a/ae/Flag_of_the_United_Kingdom.svg/800px-Flag_of_the_United_Kingdom.svg.png", add = T)
plot(uk, add = T, lwd = 2)
plot.masked.image(fr, "https://upload.wikimedia.org/wikipedia/en/thumb/c/c3/Flag_of_France.svg/800px-Flag_of_France.svg.png", add = T)
plot(fr, add = T, lwd = 2)
plot.masked.image(de, "https://upload.wikimedia.org/wikipedia/en/thumb/b/ba/Flag_of_Germany.svg/800px-Flag_of_Germany.svg.png", add = T)
plot(de, add = T, lwd = 2)
## make sure to turn off the graphical device:
dev.off()