Little silly fun with R

August 13, 2017
By

(This article was first published on R – nandeshwar.info, and kindly contributed to R-bloggers)

Yes, I know. I’m a hypocrite to be creating ‘interesting’ stuff using R. If you’ll excuse me just this one time, you’ll see some silly fun using R. It is an experiment to see how much we can extend R as well as learning new packages.

Add a background image to a plot

I don’t know when you would need to use this, but if you ever find a need to add a background image in a ggplot, you can use this following function called sighr.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
require(ggplot2)
require(jpeg)
require(grid)
require(gridExtra)
require(dplyr)
require(tidyr)
require(cowplot)
 
#ggthemes Excel theme colors
sigh_colors <- c("#993366", "#FFFFCC", "#CCFFFF", "#660066", "#FF8080", "#0066CC", "#CCCCFF")
 
sighr <- function(df = mpg, xvar = 'class', fillvar = 'drv', sighmore = FALSE) {
  img_url <- 'http://lorempixel.com/400/200'
  tmp_file <- tempfile()
  download.file(img_url, tmp_file, mode = "wb")
  img <- readJPEG(tmp_file)
  file.remove(tmp_file)
 
  rstr <- rasterGrob(img, width = unit(1,"npc"), height = unit(1,"npc"), interpolate = FALSE)
 
  g <- ggplot(data = df)  + annotation_custom(rstr, -Inf, Inf, -Inf, Inf)
  g <- g + geom_bar(aes_string(x = xvar, fill = fillvar))
  g <- g + theme(legend.position = "top", legend.background = element_rect(color = "blue"),
                 panel.grid = element_line(size = rel(4), color = "purple"),
                 axis.text.x = element_text(angle = 45, hjust = 1))
  g <- g + scale_fill_manual(values = sigh_colors)
 
  if (sighmore){
    totals <- group_by_(df, xvar, fillvar) %>% count() %>% spread_(xvar, 'n')
    total_grob <- tableGrob(totals)
    g <- plot_grid(g, total_grob, nrow = 2, rel_heights = c(7/8, 1/8))
  }
  return (g)
}

Executing this function we get a random background image and bonus: Excel 95 color scheme and turned axis labels.

1
sighr()

If you pass the additional argument sighmore = TRUE, you get a table attached with the plot.

1
sighr(sighmore = TRUE)

Create a gif

GIFs actually could be useful depending on your use. Here, I wanted to combine a chart with carbon emissions data and global temperature change with a “I-don’t-believe-it” gif.

Here we go.

First, let’s load all the good libraries.

1
2
library(readr)
library(lubridate)
1
2
3
library(dplyr)
library(tidyr)
library(magick)

Donwload all the data

1
2
3
4
5
##download CO2 emissions data
mo2Num <- function(x) match(tolower(x), tolower(month.abb))
co2ppm <- read_table(file = 'ftp://aftp.cmdl.noaa.gov/products/trends/co2/co2_mm_mlo.txt', 
                     comment = "#", 
                     col_names = c('year', 'month', 'dec_date', 'avg', 'interpolated', 'trend', 'days'))
1
2
3
4
5
6
co2ppm <- mutate(co2ppm, date = as.Date(date_decimal(decimal = dec_date)))
 
##download global temperature change daat
global_temp <- read_csv("https://data.giss.nasa.gov/gistemp/tabledata_v3/GLB.Ts+dSST.csv", 
                        skip = 1, na = '*****', 
                        col_types = cols(.default = 'd', Year = "i"))
1
2
3
4
5
6
7
8
9
10
global_temp_l <- select(global_temp, 1:13) %>% gather(key = month, value = temp, -Year)
global_temp_l <- mutate(global_temp_l, date = ymd(paste(Year, month, 1, sep = "-")),
                        month_number = mo2Num(month))
 
temp_co2ppm <- inner_join(select(co2ppm, year, month, interpolated), 
                          select(global_temp_l, Year, month_number, temp),
                          by = c("year" = "Year", "month" = "month_number")) %>% mutate(date = ymd(paste(year, month, 1, sep = "-")))
 
temp_co2ppm_l <- gather(temp_co2ppm, key = what, value = val, -year, -month, -date) %>% 
  mutate(ifelse(what == 'interpolated', 'CO2ppm', ifelse(what == 'temp', 'deviation temp', NA)))

Plot the data

You will see I’m not using ggplot here. I had a difficult time getting two y-axis going. base-R graphics to rescue.

1
2
3
4
5
6
7
8
9
10
11
12
13
png(filename = "co2_temp_plot.png", width = 5, height = 3.5, units = "in", res = 200)
par(mar = rep(3, 4), las = 1)
with(temp_co2ppm, plot(x = date, y = temp, type = 'l', col = "grey80", axes = FALSE, xlab = NA, ylab = NA, ylim = c(-.4, 1.4)))
axis(side = 4, at = seq(from = -.40, to = 1.40, length.out = 6), tick = FALSE, hadj = 1, line = 1, col.axis = "grey80")
par(new = TRUE)
with(temp_co2ppm, plot(x = date, y = interpolated, type = 'l', col = "red", axes = FALSE, ylim = c(300, 400)))
abline(h = seq(from = 300, to = 400, length.out = 6), col = "grey95")
axis(side = 2, at = seq(from = 300, to = 400, length.out = 6), tick = FALSE, line = 1, hadj = 0, col.axis = "red")
axis.Date(side = 1, at = seq.Date(from = min(temp_co2ppm$date), to = max(temp_co2ppm$date), length.out = 6), 
          lwd = 0, line = -1, format = "%Y", lwd.ticks = 0.5, col.ticks = "grey95")
mtext(expression(""*CO[2]*" ppm"), side = 2, col = "red", at = 410, adj = 0, line = 2)
mtext(expression("Global temp deviation from mean"~degree~C), side = 4, col = "grey80", at = 410, adj = 1, line = 2)
dev.off()

Read the plot, gif, and combine

Using the magick library, we can read the saved plot as well as the gif and write a new combined gif.

1
2
3
4
5
6
7
8
9
bkgrnd_plot <- image_read("co2_temp_plot.png")
gif_raw <- image_read("https://media.giphy.com/media/129Yiur12UfxNm/giphy.gif")
 
frames <- lapply(gif_raw, function(frame) {
  image_composite(bkgrnd_plot, frame, offset = "+650+350")
})
 
plot_gif <- image_animate(image_join(frames), fps = 20)
image_write(plot_gif, "co2plot_kanye.gif")

climate change deniers be like

Generate cat memes

This was truly fun and I was surprised by the results. Some were really on point. To make this code work, you will need to get an API key from [. This function downloads a random quote based on your select: Chuck Norris, Ron Swanson, or a motivational quote.

Load all goodies

1
2
3
library(magick)
library(dplyr)
library(magrittr)
1
2
3
library(httr)
library(jsonlite)
library(stringr)

Setup your mashape key

1
hd_key <- c('X-Mashape-Key' = 'get-your-own-key')

Create a function to wrap the API call

1
2
3
4
api_text <- function(url, extra = ""){
  cntt <- GET(url = url, add_headers(.headers = extra))
  return (fromJSON(rawToChar(cntt$content)))
}

Create the meme

This function will change the font type to Impact and adds the quote to a random cat photo from the site thecatapi.com. By default, the function will use Ron Swanson quote.

1
2
3
4
5
6
7
8
9
10
11
12
cat_meme <- function(which_quote = 5){
  if (which_quote == 2 ){
    cat_text <- api_text('https://andruxnet-random-famous-quotes.p.mashape.com/?cat=famous&amp;count=1', extra = hd_key)$quote
  }else if (which_quote == 3 ){
    cat_text <- api_text('https://matchilling-chuck-norris-jokes-v1.p.mashape.com/jokes/random?category=animal', extra = hd_key)$value
  }else {
    cat_text <- api_text('http://ron-swanson-quotes.herokuapp.com/v2/quotes')
  }
  cat_text <- str_to_upper(str_wrap(cat_text, width = 30))
  cat_img <- image_read('http://thecatapi.com/api/images/get?size=med')
  image_annotate(cat_img, cat_text, gravity = "north", size = 30, location = "+0+10", color = "white", font = 'impact', strokecolor = "black")
}

Let’s try it:

1
cat_meme()

With Chuck Norris this time:

1
cat_meme(which_quote = 3)

How about a motivational quote:

1
cat_meme(which_quote = 2)

Create a motivational quote Twitter bot

The cat meme function gave me the idea to create a Twitter bot that:

  • pulls a motivational quote from www.mashape.com
  • gets a random image from unsplash.com
  • blurs the image
  • combines the image and the quote
  • posts the combined image to Twitter

Of course, for this to succeed, you need a Twitter account and a Twitter API key and token.

Load the twitteR library

1
2
library(twitteR)
library(stringr)

Setup Twitter authentication

1
2
3
4
setup_twitter_oauth(consumer_key = "your-consumer_key", 
                    consumer_secret = "your-consumer_secret",
                    access_token = "your-access_token",
                    access_secret = "your-access_secret")

Read the logo (optional)

1
nand_logo <- image_read('yourlogo.png')

Create the quote function

1
2
3
4
5
6
7
8
9
10
11
12
motivational_qt <- function(){
  bkgrnd_img <-  image_read('https://unsplash.it/800/500/?random') #get a random image from unsplash
  bkgrnd_img <- image_blur(bkgrnd_img, radius = 6, 5) #blur the image
  bkgrnd_img <- image_colorize(image = bkgrnd_img, color = "grey90", opacity = 40) #add a grey layer for better reading of the text
  quote <- api_text('https://andruxnet-random-famous-quotes.p.mashape.com/?cat=famous&amp;count=1', extra = hd_key) # get a quote
  quote_a <- paste0(str_wrap(quote$quote, width = 40), "\n - ", quote$author) #wrap the text to make it fit on the image
  qt_img <- image_annotate(bkgrnd_img, quote_a, gravity = "center", size = 30, location = "+0+0", color = "#A13700", font = '/System/Library/Fonts/Noteworthy.ttc', strokecolor = "#A13700") #add the text to the image
  qt_logo <- image_composite(qt_img, image_scale(nand_logo, "30%"), operator = "atop", offset = "+730+450") #add the logo
  qt_logo_site <- image_annotate(qt_logo, "www.nandeshwar.info", gravity = 'southwest', location = "+10+10", color = "white", size = 15, font = 'arial') #add the url
  t <- image_write(image = qt_logo_site, path = "quote_text.png") #save the image
  return(quote_a) #return text
}

Let’s try the function

1
motivational_qt()
## [1] ""The artist is nothing without the gift,\nbut the gift is nothing without work.\n - Emile Zola""

If everything worked, this function should return a quote and the image should be saved locally.

Update your Twitter status

This is the easiest part. Just get the text from the motivational_qt() function and the image and send it to Twitter. Please use caution and don’t spam.

1
2
3
4
updateStatus(text = str_sub(paste0("QuoteBot courtesy @n_ashutosh @opencpu @unsplash @geoffjentry ",
                                   str_replace(motivational_qt(), pattern = "\n", replacement = " ")),
                            end = 140),
             mediaPath = "quote_text.png")
That’s it. I hope you enjoy having some fun with R – but please, please use all of this very responsibly.

The post Little silly fun with R appeared first on nandeshwar.info.

To leave a comment for the author, please follow the link and comment on their blog: R – nandeshwar.info.

R-bloggers.com offers daily e-mail updates about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...



If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Comments are closed.

Search R-bloggers

Sponsors

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)