R-SquareD

Pipe Dream

Wed, 07 Dec 2016 00:00:00 -0600

Plusses and Arrows and Percents, oh my!. -

Do you continually substitute “%>%” for “+” when switching between data wrangling and data visualization? I’ve got just the solution for you!

Count myself as one of those people that continually use a pipe instead of a plus and vice-verca when I’m writing a lot of code. Sir Hadley has basically shut the door on ever switching ggplot to using magrittr pipes and I don’t blame him. But he can’t stop me from doing whatever the heck I want.

In the following code, I took the sample ggplot code from the help and modified it to use magrittr.

library(magrittr)
library(ggplot2)
library(dplyr)
geom_point_p = function(p, ...) {
  return(
    p + geom_point(...)
  )
}

geom_errorbar_p = function(p, ...) {
  return(
    p + geom_errorbar(...)
  )
}

df = data.frame(
  gp = factor(rep(letters[1:3], each = 10)),
  y = rnorm(30)
)
ds = plyr::ddply(df, "gp", plyr::summarise, mean = mean(y), sd = sd(y))

# The summary data frame ds is used to plot larger red points on top
# of the raw data. Note that we don't need to supply `data` or `mapping`
# in each layer because the defaults from ggplot() are used.
ggplot(df, aes(gp, y)) %>%
  geom_point_p() %>%
  geom_point_p(data = ds, aes(y = mean), colour = 'red', size = 3)

# Same plot as above, declaring only the data frame in ggplot().
# Note how the x and y aesthetics must now be declared in
# each geom_point() layer.
ggplot(df) %>%
  geom_point_p(aes(gp, y)) %>%
  geom_point_p(data = ds, aes(gp, mean), colour = 'red', size = 3)

# Alternatively we can fully specify the plot in each layer. This
# is not useful here, but can be more clear when working with complex
# mult-dataset graphics
ggplot() %>%
  geom_point_p(data = df, aes(gp, y)) %>%
  geom_point_p(data = ds, aes(gp, mean), colour = 'red', size = 3) %>%
  geom_errorbar_p(
    data = ds,
    aes(gp, mean, ymin = mean - sd, ymax = mean + sd),
    colour = 'red',
    width = 0.4
  )

I may have to roll this into a package at some point.

The End of the Line

Thu, 06 Oct 2016 00:00:00 -0500

Adding labels to the end of lines indicating the last value -

Often, the value of the last data point in price series data is important to the viewer. Adding these yourself is always clumsy.

I considered creating my own geom to handle these but decided to see if someone else did the work for me. The answer, kind of. The directlabels is intended to replace the legend and add labeling directly in the plot area.

library(dplyr)
library(ggplot2)
library(directlabels)
tx <- time(mdeaths)
Time <- ISOdate(floor(tx),round(tx%%1 * 12)+1,1,0,0,0)
uk.lung <- rbind(data.frame(Time,sex="male",deaths=as.integer(mdeaths)),
                 data.frame(Time,sex="female",deaths=as.integer(fdeaths)))

ggplot(uk.lung, aes(x=Time, y=deaths)) +
  geom_line(aes(color=sex)) +
  geom_dl(aes(label=sex, color=sex)
                    , method = list("last.points"))

The geom_dl is a custom geom in the directlabels package and is easy to use. This is a nice feature and has lots of options, but I am looking for a way to show that the last data point for male is 1341 and female is 574. The package is not designed to do this, but with a small data hack, we can still use it.

tx <- time(mdeaths)
Time <- ISOdate(floor(tx),round(tx%%1 * 12)+1,1,0,0,0)
uk.lung <- rbind(data.frame(Time,sex="male",deaths=as.integer(mdeaths)),
                 data.frame(Time,sex="female",deaths=as.integer(fdeaths))) %>%
  group_by(sex) %>%
  mutate(last_value = last(deaths)) 

ggplot(uk.lung, aes(x=Time, y=deaths)) +
  geom_line(aes(color=sex)) +
  geom_dl(aes(label=last_value, color=sex)
                        , method = list("last.qp"))

Lightweight Timer Using a Closure

Fri, 30 Sep 2016 00:00:00 -0500

Your very own swiss chronograph -

I am always looking for a way to speed up processing in R before giving up and porting to C++.

To find bottlenecks, I used to put timing variables all over code with print statements. When I discovered R6, I immediately created my own timing class to handle this.

library(magrittr)
library(R6)
Timer = R6Class("Timer",
  ## Public Scope
  public=list(
    initialize = function() {
      # Initialized the timer
      #  and start the clock
      private$ptm = proc.time()
    },
    Lap = function() {
      dif = proc.time() - private$ptm
      private$ptm <<- proc.time()
      print(dif)
    }
  ),
  ## Private Scope
  private=list(
    ptm = NULL
  )
)

t = Timer$new()
for(i in 1:100000) x = i
t$Lap()

##    user  system elapsed 
##   0.013   0.006   0.027

for(i in 1:200000) x = i
t$Lap()

##    user  system elapsed 
##   0.030   0.004   0.031

This works great and I love working with R6, but I want something a little more lightweight for when I’m bouncing between multiple R environments. After racking my brain a little, I found that closures provide great solution to such a simple problem. The closure gives us the data persistance we need and doesn’t require outside packages.

Timer = function() {
  # Initialized the timer
  #  and start the clock
  ptm = proc.time()
  
  function(lab = NULL) {
    dif = proc.time() - ptm
    ptm <<- proc.time()
    print(dif)
  }
}

t = Timer()

rst = c()
for(i in 1:10000) {
  test = c()
  for(j in 1:100) {
    test = c(test, sample(1:0, 1))
  }
  rst = c(rst, sum(test))
}
t()

##    user  system elapsed 
##   5.116   0.000   5.123

rst = c()
for(i in 1:10000) {
  rst = c(rst, sum(sample(1:0, 100, replace=T)))
}
t()

##    user  system elapsed 
##   0.230   0.000   0.231

rst = matrix(nrow = 10000) %>%
  apply(1, FUN = function(x) sum(sample(1:0, 100, replace=T)))
t()

##    user  system elapsed 
##   0.104   0.000   0.102

You could extend this timer to make fancy output and also put conditional development environment checking. If you really wanted to get sophisticated, you could inject the timer into functions automatically. I may write a post in the future on how to do this. Sounds like fun.

Scatterplot Me

Thu, 29 Sep 2016 00:00:00 -0500

Plot the data within a png for fun -

Just for fun, I took my avatar image and plotted the png data into a scatterplot.

It was relatively easy to do using the png package.

library(dplyr)
library(tidyr)
library(ggplot2)
library(ggthemes)
library(png)

# Read the png into a matrix. The png has three layers (see third dimension)
#  but I only care about one.
av = readPNG("../img/avatar-icon2.png")[,,1]
num_rows = NROW(av)
num_cols = NCOL(av)

# Add a column of row numbers
av = cbind(1:num_rows, av)

# Gather the matrix into three columns for easy plotting
df.av = av %>% as.data.frame() %>% gather("rows", "cols", 2:(num_cols+1))

# Clean up the data to make sure X and Y are integers
df.av$rows = as.integer(gsub("V", "", df.av$rows))
colnames(df.av) = c("Y", "X", "COL")
df.av$COL = round(df.av$COL, 3)

# For fun, calculate R^2 on the dark points of the data
lm_sum = df.av %>% filter(COL < .1) %$% lm(Y ~ X) %>% summary()
  
eq = substitute(~italic(r)^2~"="~r2, list(r2 = format(lm_sum$r.squared, digits = 3)))
eq_lab = as.character(as.expression(eq))

# Plot the data.frame
#  I reversed the y scale to get the image upright.
ggplot(df.av) +
  geom_point(aes(x=X, y=Y, color=COL)) +
  annotate("text", label=eq_lab, x = num_cols*.9, y = 10, color="white", parse=T, size=5.5)+
  scale_y_reverse() + 
  labs(title="", x="x", y="y", color="Col") +
  theme_classic()

Wasn’t that fun!

I Hate You paste!

Mon, 26 Sep 2016 00:00:00 -0500

Don't call me anymore. -

I really don’t hate the paste function, it is actually quite useful when working with vectors. I just hate using it for simple string concatenation.

var = 4.345
paste0("The value is: ", var)

## [1] "The value is: 4.345"

Luckily, R has the functionality to create binary operators so I rolled my own string concatenation operator.

"%+%" = function(...) {paste0(...)}

"The value is: " %+% var

## [1] "The value is: 4.345"

Date Wrangling with dplyr and lubridate

Sat, 24 Sep 2016 00:00:00 -0500

Converting data.frames to different periods -

When I’m working with financial time series data, I usually use xts objects. I convert the data to a data.frame when I’m ready to plot. Sometimes, I find that I want to adjust the periodicity after I’ve converted the data to a data.frame and dplyr doesn’t have a built in ToPeriod function to handle this.

There are many ways to do this, but here is a simple method I created using lubridate.

library(dplyr)
library(lubridate)
library(knitr)

## Create a simple data.frame object
df = data.frame(
   dt = today() + days(1:300),
   x = runif(300),
   y = runif(300),
   z = runif(300)
)

## Select only the last "Monthly" row for each month
df %>%
  mutate(Monthly = ceiling_date(dt, "months")) %>%  
  group_by(Monthly) %>%
  top_n(n=1, dt) %>%
  ungroup() %>%
  select(-Monthly) %>%
  kable()

dt	x	y	z
2016-09-30	0.5929255	0.9471731	0.3849695
2016-10-31	0.4608359	0.4818123	0.3505995
2016-11-30	0.0489204	0.1026600	0.5048000
2016-12-31	0.4354312	0.7474725	0.1319946
2017-01-31	0.1969235	0.9362995	0.0475031
2017-02-28	0.2869447	0.3290996	0.9325527
2017-03-31	0.7202285	0.1793812	0.4118351
2017-04-30	0.8789776	0.4084741	0.2664088
2017-05-31	0.7721041	0.0749422	0.2096817
2017-06-30	0.4888230	0.8979686	0.0206246
2017-07-26	0.9185885	0.4004092	0.5670242

This is a very simple method to create periodicity transformation using dplyr and lubridate. The first function creates a new column that distinctly identifies each month/year that each record belongs to using ceiling_date. This could be any interval of time from second to hours to quarters, to years. I can also prefix the unit with an integer to create custom intervals (“5 days”).

Next, I group_by the new column so that it can perform a subset function upon each month. The top_n function will return the largest value within a grouping for the field passed (date). If I wanted to return the first observation within each month, simply change the n parameter to -1 (top_n(n=-1, date)).

The final two functions are just to clean up the data by ungrouping it and removing the Monthly column.

That is all nice, but if I’m going to be doing this more than once, I would rather have a function to handle it more generically.

ToPeriod = function(.data, field, period, at="endOf") {
  ## Use substitute to convert field to a named object
  field = substitute(field)
  
  ## Get date column into its own vector
  #   the deparse function takes a named field
  #   and turns it into a string. This allows us to
  #   reference a column name literally (without quotes)
  #   when calling the function but within the function
  #   we don't have to rely on lazy evaluation which is 
  #   cumbersome to use and hard to debug
  date_values = .data[,deparse(field)]
  index.at.options = c(endOf=1, firstOf=-1)
  index.at = as.integer(index.at.options[at])
  
  ## Set up some new fields so that we can group and 
  ##  pick the top or bottom.
  .data$UNIT = ceiling_date(date_values, period)
  .data$NEWDATEFIELD = date_values
  
  .data = .data %>% 
    group_by(UNIT) %>%
    top_n(index.at, wt = NEWDATEFIELD) %>%
    ungroup() %>%
    select(c(-UNIT, -NEWDATEFIELD))
  return(.data)
}

df %>%
  ToPeriod(dt, "3 months", at="firstOf") %>%
  kable()

dt	x	y	z
2016-09-30	0.5929255	0.9471731	0.3849695
2016-10-01	0.5546463	0.5019259	0.2752113
2017-01-01	0.8042691	0.8392850	0.9429900
2017-04-01	0.8989569	0.0962568	0.2398289
2017-07-01	0.1345319	0.9558426	0.6833553

This function is obviously more complicated than the script above, but the field parameter adds some challenges. I want my data wrangling functions to follow the dplyr convention of passing expressions as field names. This keeps everything consistent. I use the deparse function to convert the expression to a string so that I can access the data. I could use lazyeval for this (which is how dplyr works) but it creates many more complications and unatractive code. There are limitations to deparse but they do not impact this function (see https://cran.r-project.org/web/packages/lazyeval/vignettes/lazyeval.html).

It would be useful to pass a aggregation function to this function to aggregate by the period (mean, median, max, etc.). I will create this function in the future, for now I use xts to handle this.

It's Time!

Thu, 15 Sep 2016 00:00:00 -0500

...to ggplot some xts objects. -

The xts package is fantastic for time-series data manipulation. You can easily convert to and apply functions to different frequencies, merge with other time series vertically and horizontally, and lag data. These are very helpful features that are cumbersome when working with a data.frame. Unfortunately, if you want to leverage ggplot to produce great looking plots, you cannot use xts objects natively.

It is fairly easy to convert from xts to to a data frame but the key is to get the date into its own column.

library(xts)
library(ggplot2)
library(ggthemes)
library(reshape2)
 
## Read in a csv file of prices 
ibm_url = "http://real-chart.finance.yahoo.com/table.csv?s=IBM&g=d&a=0&b=1&c=2005&ignore=.csv"
ibm_price_hist = read.csv(ibm_url, header = T, quote = "")

## Convert the data into an xts object for ease of date manipulation.
x.ibm_price_hist = as.xts(ibm_price_hist[,-1], order.by = as.Date(ibm_price_hist[,1]))
     
x.ibm_price_hist_monthly = to.monthly(x.ibm_price_hist$Close, OHLC=F)

I don’t like those four steps to get the price data into an xts object, so just create a personal library function to handle it. You can use the quantmod package which includes a function (getSymbols) to download prices and other data from various sources directly into xts objects. You can also just roll your own.

GetPrices = function(url) {
  price_hist = read.csv(url, header = T, quote = "")
  ## Convert the data into an xts object for ease of date manipulation.
  x.price_hist = as.xts(price_hist[,-1], order.by = as.Date(price_hist[,1]))
  
  return(x.price_hist)
}

x.ibm_price_hist = GetPrices(ibm_url)

x.ibm_price_hist_monthly = to.monthly(x.ibm_price_hist$Close, indexAt = "endof", OHLC=F)
tail(x.ibm_price_hist_monthly)

##             Close
## 2016-07-29 160.62
## 2016-08-31 158.88
## 2016-09-30 158.85
## 2016-10-31 153.69
## 2016-11-30 162.22
## 2016-12-06 160.35

To use ggplot with this data, we need to convert it back to a data.frame. This is a fairly simple process, but again, we don’t want to continually do it so create a function.

xts2data.frame = function(x) {
  df = data.frame(x=index(x), coredata(x))
  # Preserve the column names from the xts object 
  #  and use "Date" as the new column for new date column
  colnames(df) = c("Date", colnames(x))
  return(df)
}
 
df.ibm_price_history_monthly = xts2data.frame(x.ibm_price_hist_monthly)
tail(df.ibm_price_history_monthly)

##           Date  Close
## 139 2016-07-29 160.62
## 140 2016-08-31 158.88
## 141 2016-09-30 158.85
## 142 2016-10-31 153.69
## 143 2016-11-30 162.22
## 144 2016-12-06 160.35

ggplot(df.ibm_price_history_monthly) +
  geom_line(aes(x=Date, y=Close), size=1.5) +
  ggtitle("IBM Stock Price") + 
  ylab("Price Close (log 10 scale)") +
  scale_y_log10(breaks=pretty(df.ibm_price_history_monthly$Close)) +
  theme_economist_white()

If you want to use the group or facet features of ggplot for each time series in your object, you will need to “stack” the data. There are many ways to do this, but melt from the reshape2 package does a good job.

df.ibm_price_history = xts2data.frame(x.ibm_price_hist["2016-05-01::"])
df.ibm_price_history_stack = melt(df.ibm_price_history[,1:5], id=c("Date"), variable.name="Type", value.name="Price")

ggplot(df.ibm_price_history_stack) +
  geom_line(aes(x=Date, y=Price, group=Type, color=Type), size=1) +
  ggtitle("IBM") + 
  ylab("Price (log 10 scale)") +
  scale_y_log10(breaks=pretty(df.ibm_price_history_stack$Price)) +
  theme_economist_white()

ggplot(df.ibm_price_history_stack) +
  geom_line(aes(x=Date, y=Price), size=1) +
  ggtitle("IBM") + 
  ylab("Price (log 10 scale)") +
  scale_y_log10(breaks=pretty(df.ibm_price_history_stack$Price)) +
  facet_grid(Type ~ .) +
  theme_economist_white()

Those are not very helpful charts, but you should get the idea.

Here is a nice candlestick chart that looks much better and uses the data. It takes a little more data manipulation, but it is worth it.

x.ibm_ohlc_hist_monthly = to.monthly(x.ibm_price_hist$Close, indexAt = "endof", OHLC=T, name = c("Data"))
tail(x.ibm_ohlc_hist_monthly)

##            Data.Open Data.High Data.Low Data.Close
## 2016-07-29    152.35    162.65   151.68     160.62
## 2016-08-31    161.45    163.53   158.32     158.88
## 2016-09-30    159.54    161.64   153.84     158.85
## 2016-10-31    157.61    157.61   149.63     153.69
## 2016-11-30    152.79    164.52   151.95     162.22
## 2016-12-06    159.82    160.35   159.82     160.35

df.ibm_ohlc_hist_monthly = xts2data.frame(x.ibm_ohlc_hist_monthly)

# Need the direction
df.ibm_ohlc_hist_monthly$Direction = ifelse(df.ibm_ohlc_hist_monthly$Data.Close >= df.ibm_ohlc_hist_monthly$Data.Open, "UP", "DOWN")

ggplot(df.ibm_ohlc_hist_monthly) +
  geom_linerange(aes(x=Date, ymin=Data.Low, ymax=Data.High), size=.5) +
  geom_rect(aes(xmin = Date - 10, xmax = Date + 10, ymin = Data.Open, ymax = Data.Close, fill=Direction)) + 
  ggtitle("IBM Price Chart") + 
  ylab("Price (log 10 scale)") +
  scale_y_log10(breaks=pretty(df.ibm_ohlc_hist_monthly$Data.Close)) +
  theme_economist() +
  theme(legend.position = "none")

Breaking the Ellipsis

Wed, 07 Sep 2016 00:00:00 -0500

Dot Dot Dot -

I have often found instances where I want to pass a list to a function that accepts multiple items though an ellipsis. If you pass the list, the function considers that one item.

Lists are handy structures to use because they are not as judgmental as other structures. The ellipsis is also handy because it doesn’t ask you to figure out how many items you want to pass to a function. If I am writing a function with an ellipsis, I will check the class of the first item and determine if it is a list before processing the data.

fun = function(...) {
  params = list(...)
  if(length(params) == 1 & class(params) == "list") {
    params = params[[1]]
  }
  #...
}

This doesn’t obviously work if the function expects multiple list objects to be passed in. It also doesn’t work on functions you don’t write.

Here is an example problem I have run into many times:

mylist = list()
mylist[[1]] = sample(1:10, 10)
mylist[[2]] = sample(1:10, 10)
mylist[[3]] = sample(1:10, 10)
mylist[[4]] = sample(1:10, 10)
mylist[[5]] = sample(1:10, 10)
 
## How do I take this list and turn it into a matrix?!
mymatrix = matrix(nrow = length(mylist[[1]]))
for(i in 1:length(mylist)) {
  mymatrix = cbind(mymatrix, mylist[[i]])
}
mymatrix = mymatrix[,-1]
 
# That solution sucks!
# I just want to call cbind(mylist) and get a matrix

As you can see, for loops and a blank starter column are not ideal. I could create a proxy for [cbind] to handle lists or separate parameters, but that is cumbersome and could cause problems if the underlying function changes.

The easy solution is to use the [do.call] function. [do.call] takes a function and a list (named if you want direct assignment to the function) and calls the passed function with each element of the list.

mylist = list()
mylist[[1]] = sample(1:10, 10)
mylist[[2]] = sample(1:10, 10)
mylist[[3]] = sample(1:10, 10)
mylist[[4]] = sample(1:10, 10)
mylist[[5]] = sample(1:10, 10)
 
mymatrix = do.call(cbind, mylist)
 
# This is the equivalent of mymatrix = cbind(mylist[[1]]
#  , mylist[[2]]
#  , mylist[[3]]
#  , mylist[[4]]
#  , mylist[[5]])

Here is another example I created to demonstrate how it works:

## Simple function to print each parameter
fun = function(...) {
 params = list(...)
 print(paste("List length:", length(params)))
 for(i in 1:length(params)) {
   print(params[[i]])
 }
}
# Call fun passing three values
fun(1,2,3)

## [1] "List length: 3"
## [1] 1
## [1] 2
## [1] 3

# The function can handle a variable number of inputs
 
# Call fun passing a list
fun(list(1,2,3))

## [1] "List length: 1"
## [[1]]
## [1] 1
## 
## [[2]]
## [1] 2
## 
## [[3]]
## [1] 3

# Passing a list to the ellipsis will not
# separate each parameter
 
# If you have your data in a list and want each value
# to be passed individually, use the do.call
 
do.call(fun, args = list(1,2,3))

## [1] "List length: 3"
## [1] 1
## [1] 2
## [1] 3