I recently encountered a situation where I wanted to run several linear models, but where the response variables would depend on previous steps in the data analysis pipeline. Let me illustrate using the mtcars dataset:

data(mtcars)
head(mtcars)
#>                    mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
#> Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
#> Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
#> Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
#> Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
#> Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

Let’s say I wanted to fit a linear model of mpg vs. hp and get the coefficients. This is easy:

lm(mpg ~ hp, data = mtcars)$coefficients
#> (Intercept)          hp 
#> 30.09886054 -0.06822828 

But what if I wanted to fit a linear model of y vs. hp, where y is a response variable that I won’t know until runtime? Or what if I want to fit 3 linear models: each of mpg, disp, drat vs. hp? Or what if I want to fit 300 such models? There has to be a way to do this programmatically.

It turns out that there are at least 4 different ways to achieve this in R. For all these methods, let’s assume that the responses we want to fit models for are in a character vector:

response_list <- c("mpg", "disp", "drat")

Here are the 4 ways I know (in decreasing order of preference):

1. as.formula()

as.formula() converts a string to a formula object. Hence, we can programmatically create the formula we want as a string, then pass that string to as.formula():

for (y in response_list) {
    lmfit <- lm(as.formula(paste(y, "~ hp")), data = mtcars)
    print(lmfit$coefficients)
}
#> (Intercept)          hp 
#> 30.09886054 -0.06822828 
#> (Intercept)          hp 
#>    20.99248     1.42977 
#> (Intercept)          hp 
#>  4.10990867 -0.00349959 

2. Don’t specify the data option

Passing the data = mtcars option to lm() gives us more succinct and readable code. However, lm() also accepts the response vector and data matrix themselves:

for (y in response_list) {
    lmfit <- lm(mtcars[[y]] ~ mtcars$hp) 
    print(lmfit$coefficients)
} 
#> (Intercept)          hp 
#> 30.09886054 -0.06822828 
#> (Intercept)          hp 
#>    20.99248     1.42977 
#> (Intercept)          hp 
#>  4.10990867 -0.00349959 

3. get()

get() searches for an R object by name and returns that object if it exists.

for (y in response_list) {
    lmfit <- lm(get(y) ~ hp, data = mtcars)
    print(lmfit$coefficients)
}
#> (Intercept)          hp 
#> 30.09886054 -0.06822828 
#> (Intercept)          hp 
#>    20.99248     1.42977 
#> (Intercept)          hp 
#>  4.10990867 -0.00349959 

4. eval(parse())

This one is a little complicated. parse() returns the parsed but unevaluated expressions, while eval() evaluates those expressions (in a specified environment).

for (y in response_list) {
    lmfit <- lm(eval(parse(text = y)) ~ hp, data = mtcars)
    print(lmfit$coefficients)
}
#> (Intercept)          hp 
#> 30.09886054 -0.06822828 
#> (Intercept)          hp 
#>    20.99248     1.42977 
#> (Intercept)          hp 
#>  4.10990867 -0.00349959 

Of course, for any of these methods, we could replace the outer loop with apply() or purrr::map().

References:

1. johnramey. Converting a String to a Variable Name On-The-Fly and Vice-versa in R.

Today’s post comes from an idea and some starting code by my colleague David Diviny from Nous Group.

A common real-world problem is trying to estimate an unknown continuous variable from data that has been published in lumped-together bins. Often this will have been done for confidentialisation reasons; or it might just be that it has been aggregated that way for reporting and the original data is unavailable; or the binning might have happened at the time of measurement (common in surveys, when respondents might be asked to pick from several categories for ‘how often do you…’ or a similar question).

This is a related problem to the question of data being suppressed in low-count cells I discussed in some previous posts. It exemplifies a more general problem with censoring of all of our data into rough left and right bounds, at the mercy of the analyst who produced the original set of bins for publication.

Simulated data

I’m going to start with a made up but realistic example where respondents were asked “how long do you think it will take for X to happen”. Our simulated data from 10,000 responses (ok, perhaps that sample size isn’t very realistic for this sort of question :)) looks like this:

Under the hood, I generated 10,000 actual continuous values from an exponential distribution, so I know the true un-binned values, the population mean and even the true data generating process. The true mean is 200.

A tempting but overly simplistic way of estimating the average time would be to allocate to each value the mid point of its bin; so we would have 474 values of 5, 1,710 values of 30, 1,731 of 75, and so on. This would give us an estimated population average of 358, far too high. The fact that I chose a very right-skewed distribution (exponential) to generate the data is the main reason this method doesn’t work, but this is not an unlikely scenario.

A vastly better method of estimating the mean is to model the underlying distribution, choosing parameters for it that are most likely to have generated the binned results we see. I could cheat and fit an exponential distribution, but let’s be more realistic and allow our model the flexibility of a Gamma distribution (of which exponential is a special case), reflecting the uncertainty we would have in encountering this data in the wild. Fitting this method to my binned data gives me a Gamma distribution with an estimated shape parameter of 1.02 (very close to the true data generating process value of 1, meaning a pure exponential distribution), estimated rate of 0.0051 and inferred mean of 198.5 – very close to the true total and much better than 358.

Here’s the results:

> # overall fit:> summary(fitted_distribution_gamma)Fitting of the distribution ' gamma ' By maximum likelihood on censored data Parameters        estimate   Std. Errorshape 1.01844011 0.0144237671rate  0.00512979 0.0001093316Loglikelihood:  -10860.99   AIC:  21725.99   BIC:  21740.41 Correlation matrix:          shape      rateshape 1.0000000 0.7996524rate  0.7996524 1.0000000> > # estimated mean> fitted_distribution_gamma$estimate["shape"] / fitted_distribution_gamma$estimate["rate"]   shape 198.5345

And here’s the code that generated it. Most of this is just simulating the data; as is often the case, the actual statistical modelling here is a one liner, using the fitdistcens function from Marie Laure Delignette-Muller, Christophe Dutang (2015). fitdistrplus: An R Package for Fitting Distributions. Journal of Statistical Software, 64(4), 1-34. URL http://www.jstatsoft.org/v64/i04/

Post continues after R code

library(tidyverse)library(multidplyr)library(frs)library(fitdistrplus)library(knitr)library(readxl)library(kableExtra)library(clipr)#-----------------simulated data-------------set.seed(123)simulated_rate<-0.005volumes<-tibble(volume=rexp(n=10000,rate=simulated_rate))volumes<-volumes%>%mutate(bin=case_when(volume<10~"<10",volume<50~"10-50",volume<100~"50-100",volume<1000~"100 - 1000",TRUE~">= 1000"),left=case_when(volume<10~0,volume<50~10,volume<100~50,volume<1000~100,TRUE~1000),right=case_when(volume<10~10,volume<50~50,volume<100~100,volume<1000~1000,TRUE~NA_real_),bin=factor(bin,levels=c("<10","10-50","50-100","100 - 1000",">= 1000"),ordered=T))# This is how it would look to the original uservolumes%>%group_by(bin)%>%summarise(freq=n())# Create data frame with just "left" and "right" columns, one row per respondent, ready for fitdistcensvolumes_bin<-dplyr::select(volumes,left,right)%>%as.data.frame()# Fit model  fitted_distribution_gamma<-fitdistcens(volumes_bin,"gamma")# overall fit:summary(fitted_distribution_gamma)# estimated meanfitted_distribution_gamma$estimate["shape"]/fitted_distribution_gamma$estimate["rate"]ggplot(volumes)+geom_density(aes(x=volume))+stat_function(fun=dgamma,args=fitted_distribution_gamma$estimate,colour="blue")+annotate("text",x=700,y=0.0027,label="Blue line shows modelled distribution; black is density of the actual data.")# bin_based_mean (358 - very wrong)volumes%>%mutate(mid=(left+replace_na(right,2000))/2)%>%summarise(crude_mean=mean(mid))%>%pull(crude_mean)

Here’s the comparison of our fitted distribution compared to the actual density of the data:

Binned data in the wild

Motivation – estimating average firm size from binned data

That’s all very well for simulated data, with an impressive reduction in error (from > 75% down to <1%), but did I cook the example by using a right-skewed distribution? Let’s use an even more realistic example, this time with real data.

The Australian Bureau of Statistics series 8165.0 is the Count of Australian Businesses, including Entries and Exits. It includes a detailed breakdown of number of firms by primary state of the firm’s operation, number of employees (who may not all be in that state of course) and detailed industry classification. To preserve confidentiality the number of employees is reported in bins of 0, 1-19, 20-199 and 200+. The data looks like this:

For today’s purpose I am using the number of businesses operating at the start of the 2018 financial year, ie in July 2017.

If we want to use this data to estimate the mean number of employees per firm by industry and state we have a challenge that is almost identical to that with my simulated data, albeit we now have 4,473 instances of that challenge (one for each combination of industry and state or territory). So this is a good chance to see whether we can scale up this method to a larger and more complex dataset. Luckily, dplyr makes quick work of this sort of calculation, as we will see in a minute.

Data wrangling

The first job is tidy the data into a structure we want. The four digit industry classification is too detailed to be interesting for me just now and I will want to roll it up to three digit, and also be able to easily summarise it at even coarser levels for graphics. For some reason, the ANZSIC classification is surprisingly hard to get hold of in tidy format, so I’ve included it as the object d_anzsic_4_abs in my package of R miscellanea, frs (available via GitHub).

For fitting my distributions to censored data down the track, I need columns for the left and right bounds of each bin and the frequency of occurances in each. After tidying, the data looks like this:

Along the way we’ll do some exploratory analysis. Here’s some summary data showing the top five states and ten industry divisions:

We can see that small businesses with less than 20 employees form the overwhelming number of business, and that perhaps half or more have no employees at all. Construction is the biggest industry (at the coarse one digit level of classification), followed by professional services and real estate. The pattern is similar across states, although Queensland and South Australia have relatively fewer professional and financial services firms than the other states. All of this is useful context.

I first chose 250,000 as the upper bound for the top bin (firms with 200 to 250,000 employees) because Wikipedia informs us that the largest firm in Australia by employee size is retailing giant Wesfarmers with 220,000. (Wesfarmers began as a farmer’s cooperative in my home state of Western Australia in 1914, but has grown and diversified – it now owns Bunnings, Kmart, Target and Officeworks among other things). But after some reflection I realised that Wesfarmers is almost certainly one of the 40,000 Australian Business Numbers “associated with complex structures” in this helpful diagram from the ABS on how the Business Counts is scoped. They would be a profiled unit for which the ABS maintains a record of its unit structure by direct contact with the business, and its various units likely are recorded as separate units in the data.

So, unable to use that 220,000 maximum employee size, I struggled to get a better figure for a maximum individual business unit, so decided on 30,000 more or less arbitrarily. It turns out this choice matters a lot if we are going to try to calculate average firm size directly from the counting binned data, but it doesn’t matter at all when fitting an explicit model the way I am here. Which is another argument in favour of doing it this way.

Here’s the entire data sourcing wrangling needed for this operation (asssuming frs is loaded with the ANZSIC lookup table):

Post continues after code excerpt

#------real data - business counts------------download.file("https://www.abs.gov.au/AUSSTATS/subscriber.nsf/log?openagent&816502.xls&8165.0&Data%20Cubes&B164DBE8275CCE58CA2583A700121372&0&June%202014%20to%20June%202018&21.02.2019&Latest",destfile="bus_counts.xls",mode="wb")bus_counts_orig<-readxl::read_excel("bus_counts.xls",sheet="June 2018",range="A7:G4976",col_types=c("text","text","text",rep("numeric",4)))names(bus_counts_orig)<-c("state","code","industry","0-0","1-19","20-199","200-30000")bus_counts<-bus_counts_orig%>%mutate(code=str_pad(code,4,"left","0"))%>%filter(!grepl("^Total",industry)&code!="9999")%>%filter((`0-0`+`1-19`+`20-199`+`200-30000`)>0)%>%gather(employees,freq,-state,-code,-industry)%>%separate(employees,by="-",into=c("left","right"),remove=FALSE)%>%mutate(left=as.numeric(left),right=as.numeric(right),employees=fct_reorder(employees,-left))%>%left_join(dplyr::select(anzsic_4_abs,anzsic_class_code,anzsic_group_code,anzsic_group,division),by=c("code"="anzsic_class_code"))%>%group_by(anzsic_group_code,anzsic_group,state,employees,left,right,division)%>%summarise(freq=sum(freq))%>%arrange(anzsic_group_code)%>%ungroup()# how data will look:kable(head(bus_counts))%>%kable_styling(bootstrap_options="striped")%>%write_clip()# demo plot:bus_counts%>%mutate(division2=fct_lump(division,10,w=freq),division2=fct_reorder(division2,freq,.fun=sum),state2=fct_lump(state,5,w=freq),division2=fct_relevel(division2,"Other",after=0))%>%ggplot(aes(x=division2,fill=employees,weight=freq))+geom_bar()+facet_wrap(~state2)+coord_flip()+scale_y_continuous(label=comma,expand=c(0,0))+labs(y="Number of firms",x="",fill="Number of employees",caption="Source: ABS Count of Australian Businesses, analysis by freerangestats.info",title="Number of firms by industry division and number of employees")+theme(panel.grid.minor=element_blank(),panel.spacing=unit(5,"mm"),panel.border=element_blank(),axis.text.x=element_text(angle=45,hjust=1))+scale_fill_brewer(palette="Spectral",guide=guide_legend(reverse=TRUE))

Modelling strategy and application

Whereas the simulated data in the first part of this post was estimates of time taken to perform a task, the underlying data here is a count of employees. So the Gamma distribution won’t be appropriate. The Poisson distribution is the usual starting point for modelling counts, but it doesn’t work in this case, so we relax it to a negative binomial distribution. One possible derivation of the negative binomial in this case would be to assume that the number of counts in any individual business has a Poisson distribution, but that even within state-industry combinations the mean of that distribution is itself a random variable. This feels pretty intuitive and plausible, and more importantly it seems to work.

To apply this with a minimum of code, I define a function to do the data reshaping needed for fitdistcens, estimate the parameters, and return the mean of the fitted distribution as a single number. This is suitable for use in dplyr’s summarise function after a group_by operation which means we can fit our models with only a few lines of code. I encountered uninteresting problems doing this with the whole dataset, so I decided to fit these models only to the manufacturing industries in three of the larger states. Even this was a computationally intensive task, so I make use of Hadley Wickham’s experimental multidplyr package which provides yet another way of performing parallel processing tasks in R. I think multidplyr looks promising because it integrates the familiar group_by approach from dplyr into partitioning of data into separate clusters for embarassingly parallel tasks (like fitting this distribution to many combinations of industry and state). This fits nicely into my workflow. The example usage I found on the net seemed to be from an old version of multidplyr (it looks like you used to be able to wrap your group_by command into partition but now they are sensibly separate) but it wasn’t hard to get things working.

Here’s the code for fitting all these models to every detailed manufacturing industry group in those three states. It takes less than a minute to run.

Post continues after code excerpt

bus_counts_small<-bus_counts%>%filter(division=="Manufacturing"&state%in%c("New South Wales","Victoria","Queensland"))#' @param d a data frame or tibble with columns including left, right and freq#' @param keepdata passed through to fitdistcens#' @param ... extra variables to pass to fitdistcens eg starting values for the estimation processavg_finder<-function(d,keepdata=FALSE,...){d_bin<-as.data.frame(d[rep(1:nrow(d),d$freq),c("left","right")])fit<-fitdistrplus::fitdistcens(d_bin,"nbinom",keepdata=keepdata,...)return(fit$estimate[["mu"]])}# Meat manufacturing in NSW:avg_finder(bus_counts_small[1:4,])# Meat manufacturing in Queensland:avg_finder(bus_counts_small[5:8,])cluster<-new_cluster(7)cluster_library(cluster,"fitdistrplus")cluster_assign(cluster,avg_finder=avg_finder)# calculate the simple ones using single processing dplyr for ease during dev:bus_summary_simp<-bus_counts_small%>%mutate(middle=(left+right)/2,just_above_left=(right-left)/10+left,tiny_above_left=left*1.1)%>%group_by(anzsic_group,state)%>%summarise(number_businesses=sum(freq),crude_avg=sum(freq*middle)/sum(freq),less_crude_avg=sum(freq*just_above_left)/sum(freq),another_avg=sum(freq*tiny_above_left)/sum(freq))# parallel processing for the negative binomial verionsbus_summary_nb<-bus_counts_small%>%group_by(anzsic_group,state)%>%partition(cluster=cluster)%>%do(nb_avg=avg_finder(.))%>%collect()%>%mutate(nb_avg=unlist(nb_avg))bus_summary<-bus_summary_simp%>%left_join(bus_summary_nb,by=c("anzsic_group","state"))

Results

So what do we see?

In the three plots below I compare three crude ways of estimating average firm size (in number of employees), on the horizontal axis, with the superior statistical modelling method taking into account the nature of binned data on the vertical axis. We can see that the choice of a crude way to assign an average employee number within each bin makes a huge difference. For the first two plots, I did this by taking either the mid point of each bin, or the point 10% of the way between the left and right bounds of the bin. Both of these methods give appallingly high overestimates of average firm size. But for the third plot, where I said the average number of employees in each bin was just 10% more than the lowest bound of the bin, we get bad under-estimates.

The shape of these plots depends not only on the method used for crude averaging within bins, but on the critical choice of the right-most bound of the highest bin (30,000 in my case). Differing choices for this value lead to more sensible estimates of average firm size, but this just shows how hopeless any naive method of using these bins is for assigning averages.

These are interesting results which illustrate how difficult it is estimate means of real world, highly skewed data – particularly so when the data has been clouded by binning for confidentialisation or convenience reasons. The mean has a breakdown point of zero, meaning that a single arbitrarily large value is enough to make the whole estimate meaningless (unlike eg the median, where 50% of the data needs to be problematic for this to happen). Having an unknown upper bound to a bin makes this problem almost certain when you are trying to recover a mean from the underlying data.

Here’s the code for those comparative plots.

Post continues after code excerpt

p1<-bus_summary%>%ggplot(aes(x=crude_avg,y=nb_avg,colour=anzsic_group))+facet_wrap(~state)+geom_abline(intercept=0,slope=1)+geom_point()+theme(legend.position="none")+labs(x="Average firm size calculated based on mid point of each bin\nDiagonal line shows where points would be if both methods agreed.",y="Average firm size calculated with negative binomial model",title="Mean number of employees in manufacturing firms estimated from binned data",subtitle="Inference based on mid point of bin delivers massive over-estimates")p2<-bus_summary%>%ggplot(aes(x=less_crude_avg,y=nb_avg,colour=anzsic_group))+facet_wrap(~state)+geom_abline(intercept=0,slope=1)+geom_point()+theme(legend.position="none")+labs(x="Average firm size calculated based on 10% of way from left side of bin to right side\nDiagonal line shows where points would be if both methods agreed.",y="Average firm size calculated with negative binomial model",title="Mean number of employees in manufacturing firms estimated from binned data",subtitle="Using a point 10% of the distance from the left to the right still over-estimates very materially")p3<-bus_summary%>%ggplot(aes(x=another_avg,y=nb_avg,colour=anzsic_group))+facet_wrap(~state)+geom_abline(intercept=0,slope=1)+geom_point()+theme(legend.position="none")+labs(x="Average firm size calculated based on left side of bin x 1.1\nDiagonal line shows where points would be if both methods agreed.",y="Average firm size calculated with negative binomial model",title="Mean number of employees in manufacturing firms estimated from binned data",subtitle="Using the (left-most point of the bin times 1.1) results in under-estimates")

Conclusion

Don’t be naive in translating binned counts into estimates of the average of an underlying continuous distribution, whether that underlying distribution is a discrete count (like our real life example) or truly continuous (as in the simulated data). It’s much more accurate, and not much harder, to fit a statistical model of the underlying distribution and calculate the estimates of interest directly from that. This applies whether you are interested in the average, the sum, percentiles, variance or other more complex statistics.

Visualizing the relationship between multiple variables can get messy very quickly. This post is about how the ggpairs() function in the GGally package does this task, as well as my own method for visualizing pairwise relationships when all the variables are categorical.

For all the code in this post in one file, click here.

The GGally::ggpairs() function does a really good job of visualizing the pairwise relationship for a group of variables. Let’s demonstrate this on a small segment of the vehicles dataset from the fueleconomy package:

library(fueleconomy)data(vehicles)df <- vehicles[1:100, ]str(df)# Classes ‘tbl_df’, ‘tbl’ and 'data.frame':100 obs. of  12 variables:#     $ id   : int  27550 28426 27549 28425 1032 1033 3347 13309 13310 13311 ...# $ make : chr  "AM General" "AM General" "AM General" "AM General" ...# $ model: chr  "DJ Po Vehicle 2WD" "DJ Po Vehicle 2WD" "FJ8c Post Office" "FJ8c Post Office" ...# $ year : int  1984 1984 1984 1984 1985 1985 1987 1997 1997 1997 ...# $ class: chr  "Special Purpose Vehicle 2WD" "Special Purpose Vehicle 2WD" "Special Purpose Vehicle 2WD" "Special Purpose Vehicle 2WD" ...# $ trans: chr  "Automatic 3-spd" "Automatic 3-spd" "Automatic 3-spd" "Automatic 3-spd" ...# $ drive: chr  "2-Wheel Drive" "2-Wheel Drive" "2-Wheel Drive" "2-Wheel Drive" ...# $ cyl  : int  4 4 6 6 4 6 6 4 4 6 ...# $ displ: num  2.5 2.5 4.2 4.2 2.5 4.2 3.8 2.2 2.2 3 ...# $ fuel : chr  "Regular" "Regular" "Regular" "Regular" ...# $ hwy  : int  17 17 13 13 17 13 21 26 28 26 ...# $ cty  : int  18 18 13 13 16 13 14 20 22 18 ...

Let’s see how GGally::ggpairs() visualizes relationships between quantitative variables:

library(GGally)quant_df <- df[, c("cyl", "hwy", "cty")]ggpairs(quant_df)

• Along the diagonal, we see a density plot for each of the variables.
• Below the diagonal, we see scatterplots for each pair of variables.
• Above the diagonal, we see the (Pearson) correlation between each pair of variables.

The visualization changes a little when we have a mix of quantitative and categorical variables. Below, fuel is a categorical variable while hwy is a quantitative variable.

mixed_df <- df[, c("fuel", "hwy")]ggpairs(mixed_df)

• For a categorical variable on the diagonal, we see a barplot depicting the number of times each category appears.
• In one of the corners (top-right), for each categorical value we have a boxplot for the quantitative variable.
• In one of the corners (bottom-left), for each categorical value we have a histogram for the quantitative variable.

The only behavior for GGally::ggpairs() we haven’t observed yet is for a pair of categorical variables. In the code fragment below, all 3 variables are categorical:

cat_df <- df[, c("fuel", "make", "drive")]ggpairs(cat_df)

For each pair of categorical variables, we have a barplot depicting the number of times each pair of categorical values appears.

You may have noticed that the plots above the diagonal are essentially transposes of the plot below the diagonal, and so they don’t really convey any more information. What follows below is my attempt to make the plots above the diagonal more useful. Instead of plotting the transpose barplot, I will plot a heatmap showing the relative proportion of observations having each pair of categorical values.

First, the scaffold for the plot. I will use the gridExtra package to put several ggplot2 objects together. The code below puts the same barplots below the diagonal, variable names along the diagonal, and empty canvases above the diagonal. (Notice that I need some tricks to make the barplots with the variables as strings, namely the use of aes_string() and as.formula() within facet_grid().)

library(gridExtra)library(tidyverse)grobs <- list()idx <- 0for (i in 1:ncol(cat_df)) {    for (j in 1:ncol(cat_df)) {        idx <- idx + 1                # get feature names (note that i & j are reversed)        x_feat <- names(cat_df)[j]        y_feat <- names(cat_df)[i]                if (i < j) {            # empty canvas            grobs[[idx]] <- ggplot() + theme_void()        } else if (i == j) {            # just the name of the variable            label_df <- data.frame(x = -0, y = 0, label = x_feat)            grobs[[idx]] <- ggplot(label_df, aes(x = x, y = y, label = label),                                    fontface = "bold", hjust = 0.5) +                geom_text() +                coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) +                theme_void()        }        else {            # 2-dimensional barplot            grobs[[idx]] <- ggplot(cat_df, aes_string(x = x_feat)) +                 geom_bar() +                facet_grid(as.formula(paste(y_feat, "~ ."))) +                theme(legend.position = "none", axis.title = element_blank())        }    }}grid.arrange(grobs = grobs, ncol = ncol(cat_df))

This is essentially showing the same information as GGally::ggpairs(). To add the frequency proportion heatmaps, replace the code in the (i < j) branch with the following:

# frequency proportion heatmap# get frequency proportionsfreq_df <- cat_df %>%     group_by_at(c(x_feat, y_feat)) %>%    summarize(proportion = n() / nrow(cat_df)) %>%     ungroup()            # get all pairwise combinations of valuestemp_df <- expand.grid(unique(cat_df[[x_feat]]),                        unique(cat_df[[y_feat]]))names(temp_df) <- c(x_feat, y_feat)            # join to get frequency proportiontemp_df <- temp_df %>%    left_join(freq_df, by = c(setNames(x_feat, x_feat),                              setNames(y_feat, y_feat))) %>%    replace_na(list(proportion = 0))            grobs[[idx]] <- ggplot(temp_df, aes_string(x = x_feat, y = y_feat)) +     geom_tile(aes(fill = proportion)) +    geom_text(aes(label = sprintf("%0.2f", round(proportion, 2)))) +    scale_fill_gradient(low = "white", high = "#007acc") +    theme(legend.position = "none", axis.title = element_blank())

Notice that each heatmap has its own limits for the color scale. If you want to have the same color scale for all the plots, you can add limits = c(0, 1) to the scale_fill_gradient() layer of the plot.

The one thing we lose here over the GGally::ggpairs() version is the marginal barplot for each variable. This is easy to add but then we don’t really have a place to put the variable names. Replacing the code in the (i == j) branch with the following is one possible option.

# df for positioning the variable namelabel_df <- data.frame(x = 0.5 + length(unique(cat_df[[x_feat]])) / 2,                        y = max(table(cat_df[[x_feat]])) / 2, label = x_feat)# marginal barplot with variable name on topgrobs[[idx]] <- ggplot(cat_df, aes_string(x = x_feat)) +    geom_bar() +    geom_label(data = label_df, aes(x = x, y = y, label = label),               size = 5)

In this final version, we clean up some of the axes so that more of the plot space can be devoted to the plot itself, not the axis labels:

theme_update(legend.position = "none", axis.title = element_blank())grobs <- list()idx <- 0for (i in 1:ncol(cat_df)) {    for (j in 1:ncol(cat_df)) {        idx <- idx + 1                # get feature names (note that i & j are reversed)        x_feat <- names(cat_df)[j]        y_feat <- names(cat_df)[i]                if (i < j) {            # frequency proportion heatmap            # get frequency proportions            freq_df <- cat_df %>%                 group_by_at(c(x_feat, y_feat)) %>%                summarize(proportion = n() / nrow(cat_df)) %>%                 ungroup()                        # get all pairwise combinations of values            temp_df <- expand.grid(unique(cat_df[[x_feat]]),                                    unique(cat_df[[y_feat]]))            names(temp_df) <- c(x_feat, y_feat)                        # join to get frequency proportion            temp_df <- temp_df %>%                left_join(freq_df, by = c(setNames(x_feat, x_feat),                                          setNames(y_feat, y_feat))) %>%                replace_na(list(proportion = 0))                        grobs[[idx]] <- ggplot(temp_df, aes_string(x = x_feat, y = y_feat)) +                 geom_tile(aes(fill = proportion)) +                geom_text(aes(label = sprintf("%0.2f", round(proportion, 2)))) +                scale_fill_gradient(low = "white", high = "#007acc") +                theme(axis.ticks = element_blank(), axis.text = element_blank())        } else if (i == j) {            # df for positioning the variable name            label_df <- data.frame(x = 0.5 + length(unique(cat_df[[x_feat]])) / 2,                                    y = max(table(cat_df[[x_feat]])) / 2, label = x_feat)            # marginal barplot with variable name on top            grobs[[idx]] <- ggplot(cat_df, aes_string(x = x_feat)) +                geom_bar() +                geom_label(data = label_df, aes(x = x, y = y, label = label),                           size = 5)        }        else {            # 2-dimensional barplot            grobs[[idx]] <- ggplot(cat_df, aes_string(x = x_feat)) +                 geom_bar() +                facet_grid(as.formula(paste(y_feat, "~ ."))) +                theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())        }    }}grid.arrange(grobs = grobs, ncol = ncol(cat_df))

A new version of the RcppExamples package is now on CRAN.

The RcppExamples package provides a handful of short examples detailing by concrete working examples how to set up basic R data structures in C++. It also provides a simple example for packaging with Rcpp.

This releases brings a number of small fixes, including two from contributed pull requests (extra thanks for those!), and updates the package in a few spots. The NEWS extract follows:

Changes in RcppExamples version 0.1.9 (2019-08-24)

• Extended DateExample to use more new Rcpp features

• Do not print DataFrame result twice (Xikun Han in #3)

• Missing parenthesis added in man page (Chris Muir in #5)

• Rewrote StringVectorExample slightly to not run afould the -Wnoexcept-type warning for C++17-related name mangling changes

• Updated NAMESPACE and RcppExports.cpp to add registration

• Removed the no-longer-needed #define for new Datetime vectors

Courtesy of CRANberries, there is also a diffstat report for the most recent release.

This post by Dirk Eddelbuettel originated on his Thinking inside the box blog. Please report excessive re-aggregation in third-party for-profit settings.

var vglnk = { key: '949efb41171ac6ec1bf7f206d57e90b8' }; (function(d, t) { var s = d.createElement(t); s.type = 'text/javascript'; s.async = true; s.src = '//cdn.viglink.com/api/vglnk.js'; var r = d.getElementsByTagName(t)[0]; r.parentNode.insertBefore(s, r); }(document, 'script'));

In the 1975 edition of “Applied multiple regression/correlation analysis for the behavioral sciences” by Jacob Cohen, an interesting approach of handling missing values in numeric variables was proposed with the purpose to improve the traditional single-value imputation, as described below:

– First of all, impute missing values by the value of mean or median – And then create a dummy variable to flag out imputed values

In the setting of a regression model, both imputed and dummy variables would be included and therefore the number of independent variables are doubled.

Although the aforementioned approach has long been criticized and eventually abandoned by Cohen himself in the recent edition of the book, I was told that this obsolete technique is still being actively used.

Out of my own curiosity, I applied this dummy imputation approach to the data used in https://statcompute.wordpress.com/2019/05/04/why-use-weight-of-evidence and then compared it with the WoE imputation in the context of Logistic Regression.

Below are my observations:

– Since the dummy approach converts each numeric variable with missing values, the final model tends to have more independent variables, which is not desirable in terms of the model parsimony. For instance, there are 7 independent variables in the model with dummy imputation and only 5 in the model with WoE approach.

– The model performance doesn’t seem to justify the use of more independent variables in the regression with the dummy imputation. As shown in the output below, ROC statistic from the model with WoE approach is significantly better than the one with the dummy imputation based on the DeLong’s test, which is also consistent with the result of Vuong test.

A new version of graphlayouts is now available on CRAN. This major update introduces several new layout algorithms and adds additional support for weighted networks. Here is a breakdown of all changes:

• BREAKING CHANGE: removed qgraph(). Now part of ggraph.
• POSSIBLE BREAKING CHANGE: layout_with_focus() now also returns the distance to the focus node
• changed filenames (doesn’t have any effect on functionality)
• added layout_as_dynamic() for longitudinal network data
• removed gbp and scales dependency and moved oaqc to suggest
• edge weights are now supported in layout_with_stress() and layout_with_focus()
• added layout_with_pmds() (Pivot MDS for large graphs)
• added layout_with_sparse_stress() (“stress for large graphs”)

All layout algorithms will be fully supported by the new version of ggrap. An updated tutorial for ggraph and graphlayouts can be found here.

library(igraph)library(ggraph)library(graphlayouts)library(patchwork)

# US PowerGrid network obtained from https://sparse.tamu.edu/ggraph(power,layout = "pmds", pivots = 50)+  geom_edge_link0(edge_colour = "grey66")+  geom_node_point(size = 3)+  theme_graph()

# collaboration network (preprints in condensed matter archive) # obtained from https://sparse.tamu.edu/ggraph(power,layout = "sparse_stress", pivots = 50)+  geom_edge_link0(edge_colour = "grey66")+  geom_node_point(size = 3)+  theme_graph()

# 3 Waves of 50 girls from 'Teenage Friends and Lifestyle Study' data # https://www.stats.ox.ac.uk/~snijders/siena/gList

## [[1]]## IGRAPH c2863cd UN-- 50 74 -- ## + attr: name (v/c), smoking (v/c)## + edges from c2863cd (vertex names):##  [1] V1 --V11 V1 --V14 V2 --V7  V2 --V11 V3 --V4  V3 --V9  V4 --V9 ##  [8] V5 --V32 V6 --V8  V7 --V12 V7 --V26 V7 --V42 V7 --V44 V10--V11## [15] V10--V14 V10--V15 V10--V33 V11--V14 V11--V15 V11--V16 V11--V19## [22] V11--V30 V12--V42 V12--V44 V15--V16 V17--V18 V17--V19 V17--V21## [29] V17--V22 V17--V24 V18--V19 V18--V35 V19--V24 V19--V26 V19--V30## [36] V21--V22 V21--V24 V21--V31 V21--V32 V22--V24 V22--V25 V22--V31## [43] V22--V34 V22--V43 V23--V24 V25--V31 V25--V32 V26--V29 V26--V30## [50] V26--V44 V27--V28 V27--V29 V27--V30 V29--V30 V29--V33 V30--V33## + ... omitted several edges## ## [[2]]## IGRAPH af42ccd UN-- 50 81 -- ## + attr: name (v/c), smoking (v/c)## + edges from af42ccd (vertex names):##  [1] V1 --V10 V1 --V11 V1 --V14 V1 --V33 V2 --V26 V3 --V4  V3 --V9 ##  [8] V4 --V5  V4 --V17 V4 --V34 V5 --V17 V6 --V8  V6 --V35 V7 --V26## [15] V7 --V44 V10--V11 V10--V14 V10--V33 V11--V14 V11--V19 V11--V26## [22] V11--V30 V12--V15 V12--V26 V12--V42 V12--V44 V15--V16 V15--V36## [29] V15--V42 V16--V26 V16--V42 V16--V44 V17--V22 V17--V24 V17--V27## [36] V17--V32 V18--V35 V19--V21 V19--V23 V19--V30 V19--V36 V19--V41## [43] V21--V31 V21--V37 V21--V40 V22--V24 V23--V50 V24--V25 V24--V28## [50] V25--V27 V25--V28 V25--V32 V26--V42 V27--V28 V28--V35 V29--V30## + ... omitted several edges## ## [[3]]## IGRAPH f5b65f3 UN-- 50 77 -- ## + attr: name (v/c), smoking (v/c)## + edges from f5b65f3 (vertex names):##  [1] V1 --V10 V1 --V11 V1 --V14 V1 --V41 V2 --V7  V2 --V23 V2 --V26##  [8] V3 --V4  V3 --V9  V3 --V34 V4 --V32 V4 --V34 V5 --V17 V5 --V32## [15] V6 --V24 V6 --V27 V6 --V28 V7 --V16 V7 --V26 V7 --V42 V7 --V44## [22] V8 --V25 V10--V11 V10--V12 V10--V14 V10--V33 V11--V14 V11--V15## [29] V11--V33 V12--V15 V12--V33 V14--V33 V15--V29 V15--V33 V15--V36## [36] V16--V26 V16--V42 V16--V44 V17--V22 V17--V27 V19--V29 V19--V30## [43] V19--V36 V21--V31 V21--V37 V21--V40 V21--V45 V24--V27 V24--V28## [50] V25--V50 V26--V44 V27--V28 V29--V30 V29--V33 V30--V33 V30--V36## + ... omitted several edges

xy <- layout_as_dynamic(gList,alpha = 0.2)pList <- vector("list",length(gList))for(i in 1:length(gList)){  pList[[i]] <- ggraph(gList[[i]],layout="manual",x = xy[[i]][,1],y = xy[[i]][,2])+    geom_edge_link0(edge_width = 0.2,edge_colour = "grey25")+    geom_node_point(shape=21,aes(fill=smoking),size = 3)+    geom_node_text(aes(label = 1:50),repel = T)+    scale_fill_manual(values=c("forestgreen","grey25","firebrick"),                      guide = ifelse(i!=2,FALSE,"legend"))+    theme_graph()+    theme(legend.position = "bottom")+    labs(title = paste0("Wave ",i))}Reduce("+",pList)+  plot_annotation(title="Friendship network",                  theme = theme(title = element_text(family="Arial Narrow",                                                     face = "bold",size = 16)))

Two years ago I have written a post “Naughty APEs and the quest for the holy grail“, where I have discussed why percentage-based error measures (such as MPE, MAPE, sMAPE) are not good for the task of forecasting performance evaluation. However, it seems to me that I did not explain the topic to the full extent – the time has shown that there are some other issues that need to be discussed in detail, so I have decided to write another post on the topic, possibly repeating myself a little bit. This time we won’t have imaginary forecasters, we will be more serious.

Introduction

We start from a fact, well-known in statistics. MSE is minimised by mean value, while MAE is minimised by the median. There is a lot of nice examples, papers and post, explaining, why this happens and how, so we don’t need to waste time on that. But there are two elements related to this that need to be discussed.

First, some people think that this property is applicable only to the estimation of models. For some reason, it is implied that forecasts evaluation is a completely different activity, unrelated to the estimation. Something like: as soon as you estimate a model, you are done with “MSE is minimised by mean” thingy, the evaluation is not related to this. However, when we select the best performing model based on some error measure, we inevitably impose properties of that error on the forecasts. So, if a method performs better than the other in terms of MAE, it means that it produces forecasts closer to the median of the data than the others do.

For example, zero forecast will always be one of the most accurate forecasts for intermittent demand in terms of MAE, especially when number of zeroes in the data is greater than 50%. The reason for this is obvious: if you have so many zeroes, then saying that we won’t sell anything in the next foreseeable future is a safe strategy. And this strategy works, because MAE is minimised by median. The usefulness of such forecast is a completely different topic, but a thing to carry out from this, is that in general, MAE-based error measures should not be used on intermittent demand.

Are you not convinced? Click here…

Just to make this point clearer, let’s consider the following example in R. We generate data from a mixture of normal and Bernoulli distributions (with probability \(p=0.4\), which means that we should have around 60% of zeroes in the data):

x <- rnorm(150,30,10) * rbinom(150, 1, 0.4)

The series should look something like this:

plot.ts(x)

An example of artificial intermittent data

We use the first 100 observations for methods estimation and the last 50 for the evaluation of the forecasts. We use two forecasting methods: simple average of the in-sample part of the series and zero forecast (which accidentally corresponds to the median of the data). They look the following way:

plot.ts(x)abline(h=mean(x[1:100]),col="blue", lwd=2)abline(h=0,col="purple", lwd=2)abline(v=100, col="red", lwd=2)

An example of artificial intermittent data and the forecasts. The blue line is the simple average, the purple line is the zero forecast. The red line splits the data into in-sample and the holdout

It is obvious that the average forecast is more reasonable than the zero forecast in this case – at least we can make some decisions based on that. In addition, it seems that it goes “through the data” in the holdout sample, which is what we usually want from the point forecasts. But what about the error measures?

errorMeasures <- matrix(c(mean(abs(x[101:150] - mean(x[1:100]))),                          mean(abs(x[101:150] - 0)),                          mean((x[101:150] - mean(x[1:100]))^2),                          mean((x[101:150] - 0)^2)),                        2,2,dimnames=list(c("Average","Zero"),c("MAE","MSE")))errorMeasures

MAE     MSEAverage 15.4360 264.9922Zero    12.3995 418.4934

We can see that MAE recommends zero forecast as the more appropriate here (it has the lower error of 12.3995 in contrast with 15.4360), while MSE prefers the Average (264.9922 vs 418.4934). This is a simple illustration of the point about the mean and median.

Second, some researchers think that if a model is optimised, for example, using MSE, then it should always be evaluated using the MSE-based error measure. This is not completely correct. Yes, the model will probably perform better if the loss function is aligned with the error measure used for the evaluation. However, this does not mean that we cannot use MAE-based error measures, if the loss is not MAE-based. These are still slightly different tasks, and the selection of the error measures should be motivated by a specific problem (for which the forecast is needed) not by a loss function used. For example, in case of inventory management neither MAE nor MSE might be useful for the evaluation. One would probably need to see how models perform in terms of safety stock allocation, and this is a completely different problem, which does not necessarily align well with either MAE or MSE. As a final note, in some cases we are interested in estimating models via the likelihood maximisation, and selecting an aligned error measure in those cases might be quite challenging.

So, as a minor conclusion, MSE-based measures should be used, when we are interested in identifying the method that outperforms the others in terms of mean values, while the MAE-based should be preferred for the medians, irrespective to how we estimate our models.

As one can already see, there might be some other losses, focusing, for example, on specific quantiles (such as pinball loss). But the other question is, what statistics minimise MAPE and sMAPE. The short answer is: “we don’t know”. However, Stephan Kolassa and Martin Roland (2011) showed on a simple example that in case of strictly positive distribution the MAPE prefers the biased forecasts, and Stephan Kolassa (2016) noted that in case of log normal distribution, the MAPE is minimised by the mode. So at least we have an idea of what to expect from MAPE. However, the sMAPE is a complete mystery in this sense. We don’t know what it does, and this is yet another reason not to use it in forecasts evaluation at all (see the other reasons in the previous post).

We are already familiar with some error measures from the previous post, so I will not rewrite all the formulae here. And we already know that the error measures can be in the original units (MAE, MSE, ME), percentage (MAPE, MPE), scaled or relative. Skipping the first two, we can discuss the latter two in more detail.

Scaled measures

Scaled measures can be quite informative and useful, when comparing different forecasting methods. For example, sMAE and sMSE (from Petropoulos & Kourentzes, 2015): \begin{equation} \label{eq:sMAE} \text{sMAE} = \frac{\text{MAE}}{\bar{y}}, \end{equation} \begin{equation} \label{eq:sMSE} \text{sMSE} = \frac{\text{MSE}}{\bar{y}^2}, \end{equation} where \(\bar{y}\) is the in-sample mean of the data. These measures have a simple interpretation, close to the one of MAPE: they show the mean percentage errors, relative to the mean of the series (not to each specific observation in the holdout). They don’t have problems that APEs have, but they might not be applicable in cases of non-stationary data, when mean changes over time. To make a point, they might be okay for the series on the graph on the left below, where the level of series does not change substantially, but their value might change dramatically, when the new data is added on the graph on the right, with trend time series.

Two time series examples

MASE by Rob Hyndman and Anne Koehler (2006) does not have this issue, because it is scaled using the mean absolute in-sample first differences of the data: \begin{equation} \label{eq:MASE} \text{MASE} = \frac{\text{MAE}}{\frac{1}{T-1}\sum_{t=2}^{T}|y_t -y_{t-1}|} . \end{equation} The motivation here is statistically solid: while the mean can change over time, the first difference of the data are usually much more stable. So the denominator of the formula becomes more or less fixed, which solves the problem, mentioned above.

Unfortunately, MASE has a different issue – it is uninterpretable. If MASE is equal to 1.3, this does not really mean anything. Yes, the denominator can be interpreted as a mean absolute error of in-sample one-step-ahead forecasts of Naive, but this does not help with the overall interpretation. This measure can be used for research purposes, but I would not expect practitioners to understand and use it.

And let’s not forget about the dictum “MAE is minimised by median”, which implies that, in general, neither MASE nor sMAE should be used on intermittent demand.

Relative measures

Finally, we have relative measures. For example, we can have relative MAE or RMSE. Note that Davydenko & Fildes, 2013 called them “RelMAE” and “RelRMSE”, while the aggregated versions were “AvgRelMAE” and “AvgRelRMSE”. I personally find these names tedious, so I prefer to call them “rMAE”, “rRMSE” and “ArMAE” and “ArRMSE” respectively. They are calculated the following way: \begin{equation} \label{eq:rMAE} \text{rMAE} = \frac{\text{MAE}_a}{\text{MAE}_b}, \end{equation} \begin{equation} \label{eq:rRMSE} \text{rRMSE} = \frac{\text{RMSE}_a}{\text{RMSE}_b}, \end{equation} where the numerator contains the error measure of the method of interest, and the denominator contains the error measure of a benchmark method (for example, Naive method in case of continuous demand or forecast from an average for the intermittent one). Given that both are aligned and are evaluated over the same part of the sample, we don’t need to bother about the changing mean in time series, which makes both of them easily interpretable. If the measure is greater than one, then our method performed worse than the benchmark; if it is less than one, the method is doing better. Furthermore, as I have mentioned in the previous post, both rMAE and rRMSE align very well with the idea of forecast value, developed by Mike Gilliland from SAS, which can be calculated as: \begin{equation} \label{eq:FV} \text{FV} = 1-\text{relative measure} \cdot 100\%. \end{equation} So, for example, rMAE = 0.96 means that our method is doing 4% better than the benchmark in terms of MAE, so that we are adding the value to the forecast that we produce.

As mentioned in the previous post, if you want to aggregate the relative error measures, it makes sense to use geometric means instead of arithmetic ones. This is because the distribution of relative measures is typically asymmetric, and the arithmetic mean would be too much influenced by the outliers (cases, when the models performed very poorly). Geometric one, on the other hand, is much more robust, in some cases aligning with the median value of a distribution.

The main limitation of relative measures is that they cannot be properly aggregated, when the error (either MAE or MSE) is equal to zero either in the numerator or in the denominator, because the geometric mean becomes either equal to zero or infinity. This does not stop us from analysing the distribution of the errors, but might cause some inconveniences. To be honest, we don’t face these situations very often in real world, because this implies that we have produced perfect forecast for the whole holdout sample, several steps ahead, which can only happen, if there is no forecasting problem at all. An example would be, when we know for sure that we will sell 500 bottles of beer per day for the next week, because someone pre-ordered them from us. The other example would be an intermittent demand series with zeroes in the holdout, where the Naive would produce zero forecast as well. But I would argue that Naive is not a good benchmark in this case, it makes sense to switch to something like simple mean of the series. I struggle to come up with other meaningful examples from the real world, where the mean error (either MAE or MSE) would be equal to zero for the whole holdout. Having said that, if you notice that either rMAE or rRMSE becomes equal to zero or infinite for some time series, it makes sense to investigate, why that happened, and probably remove those series from the analysis.

It might sound as I am advertising relative measures. To some extent I do, because I don’t think that there are better options for the comparison of the point forecasts than these at the moment. I would be glad to recommend something else as soon as we have a better option. They are not ideal, but they do a pretty good job for the forecasts evaluation.

So, summarising, I would recommend using relative error measures, keeping in mind that MSE is minimised by mean and MAE is minimised by median. And in order to decide, what to use between the two, you should probably ask yourself: what do we really need to measure? In some cases it might appear that none of the above is needed. Maybe you should look at the prediction intervals instead of point forecasts… This is something that we will discuss next time.

Examples in R

To make this post a bit closer to the application, we will consider a simple example with

smooth

package v2.5.3 and several series from the M3 dataset.

Load the packages:

library(smooth)library(Mcomp)

Take a subset of monthly demographic time series (it’s just 111 time series, which should suffice for our experiment):

M3Subset <- subset(M3, 12, "demographic")

Prepare the array for the two error measures: rMAE and rRMSE (these are calculated based on the

measures()

function from

greybox

package). We will be using three options for this example: CES, ETS with automatic model selection between the 30 models and ETS with the automatic selection, skipping multiplicative trends:

errorMeasures <- array(NA, c(length(M3Subset),2,3),                       dimnames=list(NULL, c("rMAE","rRMSE"),                                     c("CES","ETS(Z,Z,Z)","ETS(Z,X,Z)")))

Do the loop, applying the models to the data and extracting the error measures from the accuracy variable. By default, the benchmark in rMAE and rRMSE is the Naive method.

for(i in 1:length(M3Subset)){    errorMeasures[i,,1] <- auto.ces(M3Subset[[i]])$accuracy[c("rMAE","rRMSE")]    errorMeasures[i,,2] <- es(M3Subset[[i]])$accuracy[c("rMAE","rRMSE")]    errorMeasures[i,,3] <- es(M3Subset[[i]],"ZXZ")$accuracy[c("rMAE","rRMSE")]    cat(i); cat(", ")}

Now we can analyse the results. We start with the ArMAE and ArRMSE:

exp(apply(log(errorMeasures),c(2,3),mean))

CES        ETS(Z,Z,Z) ETS(Z,X,Z)rMAE  0.6339194  0.8798265  0.8540869rRMSE 0.6430326  0.8843838  0.8584140

As we see, all models did better than Naive: ETS is approximately 12 – 16% better, while CES is more than 35% better. Also, CES outperformed both ETS options in terms of rMAE and rRMSE. The difference is quite substantial, but in order to see this clearer, we can reformulate our error measures, dividing rMAE of each option by (for example) rMAE of ETS(Z,Z,Z):

errorMeasuresZZZ <- errorMeasuresfor(i in 1:3){    errorMeasuresZZZ[,,i] <- errorMeasuresZZZ[,,i] / errorMeasures[,,"ETS(Z,Z,Z)"]}exp(apply(log(errorMeasuresZZZ),c(2,3),mean))

CES        ETS(Z,Z,Z) ETS(Z,X,Z)rMAE  0.7205050          1  0.9707448rRMSE 0.7270968          1  0.9706352

With these measures, we can say that CES is approximately 28% more accurate than ETS(Z,Z,Z) both in terms of MAE and RMSE. Also, the exclusion of the multiplicative trend in ETS leads to the improvements in the accuracy of around 3% for both MAE and RMSE.

We can also analyse the distributions of the error measures, which sometimes can give an additional information about the performance of the models. The simplest thing to do is to produce boxplots:

boxplot(errorMeasures[,1,])abline(h=1, col="grey", lwd=2)points(exp(apply(log(errorMeasures[,1,]),2,mean)),col="red",pch=16)

Boxplot of rMAE for a subset of time series from the M3

Given that the error measures have asymmetric distribution, it is difficult to analyse the results. But what we can spot is that the boxplot of CES is located lower than the boxplots of the other two models. This indicates that the model is performing consistently better than the others. The grey horizontal line on the plot is the value for the benchmark, which is Naive in our case. Notice that in some cases all the models that we have applied to the data do not outperform Naive (there are values above the line), but on average (in terms of geometric means, red dots) they do better.

Producing boxplot in log scale might sometimes simplify the analysis:

boxplot(log(errorMeasures[,1,]))abline(h=0, col="grey", lwd=2)points(apply(log(errorMeasures[,1,]),2,mean),col="red",pch=16)

Boxplot of rMAE in logarithms for a subset of time series from the M3

The grey horizontal line on this plot still correspond to Naive, which in log-scale is equal to zero (log(1)=0). In our case this plot does not give any additional information, but in some cases it might be easier to work in logarithms rather than in the original scale due to the potential magnitude of positive errors. The only thing that we can note is that CES was more accurate than ETS for the first, second and third quartiles, but it seems that there were some cases, where it was less accurate than both ETS and Naive (the upper whisker and the outliers).

There are other things that we could do in order to analyse the distribution of error measures more thoroughly. For example, we could do statistical tests (such as Nemenyi) in order to see whether the difference between the models is statistically significant or if it is due to randomness. But this is something that we should leave for the future posts.

My updated version of my regtools package, tools for parametric and nonparametric regression, is now on CRAN,

https://cran.r-project.org/package=regtools

It has a number of new functions and datasets. Type vignette(‘regtools’) for an overview.

When using R markdown in RStudio, I like to insert a new chunk using the shortcut Cmd+Option+I. Unfortunately I often press a key instead of “I” and end up folding all the chunks, getting something like this:

It often takes me a while (on Google) to figure out what I did and how to undo it. With this note to remind me, no longer!! The shortcut I accidentally used was Cmd+Option+O, which folds up all chunks. To unfold all chunks, use Cmd+Shift+Option+O.

The full list of RStudio keyboard shortcuts can be found here.

Swift 5 has been so much fun to hack on that there’s a new update to macOS R-focused mebubar utility RSwitch available. Along with the app comes a new dedicated RSwitch landing page and a new user’s guide since it has enough features to warrant such documentation. Here’s the new menu

The core changes/additions include:

• a reorganized menu (see above)
• the use of notifications instead of alerts
• disabling of download menu entries while download is in progress
• the ability to start new R GUI or RStudio instances
• the ability to switch to and make running R GUI or RStudio instances active
• additional “bookmarks” in the reorganized web resources submenu
• Built-in check for updates

To make RSwitch launch at startup, just add it as a login item to your user in the “Users & Groups” pane of “System Preferences”.

The guide has information on how all the existing and new features work plus provides documentation on the how to install the alternate R versions available at the R for macOS Developer’s Page. There’s also a slightly expanded set of information on how to contribute to RSwitch development.

FIN

As usual, kick the tyres, file feature requests or bug reports where you’re comfortable, & — if you’re macOS-dev-curious — join in the Swift 5 fun (it really is a pretty fun language).

Today’s puzzle is a single part of a mystery that comprises several smaller puzzles, styled on the cult classic TV show The Crystal Maze. To get the coordinates there is a “mental” test for the northings, two easy puzzles that I won’t go into here. The westings are the more interesting part, with a “skill” test.

The skill test is a whack-a-mole game, with 60 radio buttons. One radio button is highlighted at random and you need to click it. If you hit, you get a point, and if you miss, you lose a point. After 30 seconds, if your score is 30 or more, you are presented with the coordinates. Now, there’s more than one way to skin this particular cat, and one of them doesn’t require any fast fingers or making an R programme. But I’ll stay silent on that method and instead use the opportunity to demonstrate how sometimes R can be enhanced by invoking scripts in other languages.

R seems to lack a way to read information about pixels on the screen. It’s easy to do if you’re interested in pixels within an image, but in this case we’re not. I’d like to read the pixels on the screen to detect which radio button is lit, then direct the mouse to click there. So I cribbed a small python script from somewhere or other to plug the gap of detecting the colour:

def get_pixel_colour(i_x, i_y):    import win32gui    i_desktop_window_id = win32gui.GetDesktopWindow()    i_desktop_window_dc = win32gui.GetWindowDC(i_desktop_window_id)    long_colour = win32gui.GetPixel(i_desktop_window_dc, i_x, i_y)    i_colour = int(long_colour)    return (i_colour & 0xff), ((i_colour >> 8) & 0xff), ((i_colour >> 16) & 0xff)

The reticulate package allows us to take a python function and “source” it, loading it as though it is an R function. It’s really painless. KeyboardSimulator can send key presses and mouse clicks to the OS. And those two packages do most of the hard work. Here’s the code:

library(KeyboardSimulator)library(reticulate)library(magrittr)## the source_python takes a few seconds to run, and we're against the clock in this game## so the first run will stop after it's in memory, and the second run will ignore this blockif (exists("runBefore")==0) {  runBefore <- 1  source_python("C:/Users/alunh/OneDrive/Documents/Repos/geo2/getPixelColour.py")  stop("python script loaded!")}## the position of the radio buttons on my screenw <- 26h <- 21l <- 1324t <- 290## the target radio button is dark grey and the non-targets are pale.## Choose r+g+b < 500 to identify the targetstart <- Sys.time()repeat {  for (x in sample(10)) {    for (y in sample(6)) {      ## here's the python function!      p <- get_pixel_colour(as.integer(l+w*(x-1)), as.integer(t+h*(y-1))) %>%         unlist()      if (sum(p) < 500) {        mouse.move(l + w * (x-1), t+h * (y-1))        mouse.click()      }    }  }  ## quit after 32 seconds  if ((Sys.time() - start) > 32) break}

So how did our R/python hybrid do? Remember, the target was 30 correct clicks within 30 seconds, without errors. Using a mouse, I managed 23, and using a touchscreen device I made it to 34.

(Final coordinates redacted)

51! Not too shabby! Doubtless something bigger and better could be done to improve this score, but I’m very satisfied with my first foray into sourcing python from R.

It’s not often that R has a gap in its functionality, and there might well be a way of doing this without resorting to a python script. Please let me know if you have a better way by using the comment section below.

The online encyclopedia Wikipedia, together with its sibling, the collaboratively edited knowledge base Wikidata, provides incredibly rich yet largely untapped sources for political research. In this Methods Bites Tutorial, Denis Cohen and Nick Baumann offer a hands-on recap of Simon Munzert’s (Hertie School of Governance) workshop materials to show how these platforms can inform research on public attention dynamics, policies, political and other events, political elites, and parties, among other things.

After reading this blog post and engaging with the applied exercises, readers should:

• be able to collect Wikipedia data and Wikidata items using R
• be able to conduct explorative analyses of Wikipedia data using R
• have a basic intuition of the potentials and limitations of using Wikipedia data in research projects

Note: This blog post provides a summary of Simon’s workshop in the MZES Social Science Data Lab with some adaptations. Simon’s original workshop materials, including slides and scripts, are available from our GitHub.

## Packagespkgs <- c(  "devtools",  "ggnetwork",  "igraph",  "intergraph",  "tidyverse",  "rvest",  "devtools",  "magrittr",  "plotly",  "RColorBrewer",  "colorspace",  "lubridate",  "networkD3",  "pageviews",  "readr",  "wikipediatrend",  "WikipediR",  "WikidataR")## Install uninstalled packageslapply(pkgs[!(pkgs %in% installed.packages())], install.packages)## Load all packages to librarylapply(pkgs, library, character.only = TRUE)## legislatoRdevtools::install_github("saschagobel/legislatoR")library(legislatoR)

# get pageviewstrump_views <-  article_pageviews(    project = "en.wikipedia",    article = "Donald Trump",    user_type = "user",    start = "2015070100",    end = "2017050100"  )head(trump_views)clinton_views <-  article_pageviews(    project = "en.wikipedia",    article = "Hillary Clinton",    user_type = "user",    start = "2015070100",    end = "2017050100"  )

# Plot pageviewsplot(ymd(trump_views$date), trump_views$views, col = "red", type = "l", xlab="Time", ylab="Pageviews")lines(ymd(clinton_views$date), clinton_views$views, col = "blue")legend("topleft", legend=c("Trump","Clinton"), cex=.8,col=c("red","blue"), lty=1) 

## step 1: get info about legislatorsdat <- semi_join(  x = get_core(legislature = "deu"),  y = filter(get_political(legislature = "deu"), session == 19),  by = "pageid")## step 2: get page links (max 500 links)if (!file.exists("studying-politics-wikipedia/data/wikipediR/mdb_links_list.RData")) {  links_list <- list()  for (i in 1:nrow(dat)) {    links <-      page_links(        "de",        "wikipedia",        page = dat$wikititle[i],        clean_response = TRUE,        limit = 500,        namespaces = 0      )    links_list[[i]] <- lapply(links[[1]]$links, "[", 2) %>% unlist  }  save(links_list, file = "studying-politics-wikipedia/data/wikipediR/mdb_links_list.RData")} else{  load("studying-politics-wikipedia/data/wikipediR/mdb_links_list.RData")}## step 3: identify links between MPs# loop preparationconnections <- data.frame(from = NULL, to = NULL)# loopfor (i in seq_along(dat$wikititle)) {  links_in_pslinks <-    seq_along(dat$wikititle)[str_replace_all(dat$wikititle, "_", " ") %in%                               links_list[[i]]]  links_in_pslinks <- links_in_pslinks[links_in_pslinks != i]  connections <-    rbind(connections,          data.frame(            from = rep(i - 1, length(links_in_pslinks)), # -1 for zero-indexing            to = links_in_pslinks - 1 # here too            )          )}# resultsnames(connections) <- c("from", "to")# make symmetricalconnections <- rbind(connections,                     data.frame(from = connections$to,                                to = connections$from))connections <- connections[!duplicated(connections), ]## step 4: visualize connectionsconnections$value <- 1nodesDF <- data.frame(name = dat$name, group = 1)network_out <-  forceNetwork(    Links = connections,    Nodes = nodesDF,    Source = "from",    Target = "to",    Value = "value",    NodeID = "name",    Group = "group",    zoom = TRUE,    opacityNoHover = 3,    height = 360,    width = 636  )

nodesDF$id <- as.numeric(rownames(nodesDF)) - 1connections_df <-  merge(connections,        nodesDF,        by.x = "to",        by.y = "id",        all = TRUE)to_count_df <- count(connections_df, name)arrange(to_count_df, desc(n))

## # A tibble: 712 x 2##    name                     n##                    ##  1 Angela Merkel           59##  2 Andrea Nahles           40##  3 Heiko Maas              38##  4 Katarina Barley         38##  5 Peter Altmaier          38##  6 Wolfgang Schäuble       38##  7 Wolfgang Kubicki        37##  8 Hans-Peter Friedrich    34##  9 Hermann Gröhe           34## 10 Ursula von der Leyen    33## # ... with 702 more rows

# retrieve article titles of interestenf <- "Europe_of_Nations_and_Freedom"efdd <- "Europe_of_Freedom_and_Direct_Democracy"enf_parties <- c(  "Freedom_Party_of_Austria",  "Vlaams_Belang",  "National_Rally_(France)",  "The_Blue_Party_(Germany)",  "Lega_Nord",  "Party_for_Freedom",  "Congress_of_the_New_Right")efdd_parties <- c(  "Svobodní",  "The_Patriots_(France)",  "Debout_la_France",  "Alternative_for_Germany",  "Five_Star_Movement",  "Order_and_Justice",  "Liberty_(Poland)",  "Brexit_Party",  "Social_Democratic_Party_(UK,_1990–present)",  "Libertarian_Party_(UK)")articles <- c(enf, efdd, enf_parties, efdd_parties)# import raw clickstream datacs <-  read.table(    "clickstream-enwiki-2019-05.tsv",    header = FALSE,    col.names = c("prev", "curr", "type", "n"),    fill = TRUE,    stringsAsFactors = FALSE  )cs$n <- as.integer(cs$n)# subsetcs <- subset(cs, prev %in% articles & curr %in% articles)

# assign categoriescs <- cs %>%  mutate(    curr_cat = ifelse(      curr == enf,      "ENF Group",      ifelse(        curr == efdd,        "EFDD Group",        ifelse(curr %in% enf_parties, "ENF Parties",               "EFDD Parties")      )    ),    prev_cat = ifelse(      prev == enf,      "ENF Group",      ifelse(        prev == efdd,        "EFDD Group",        ifelse(prev %in% enf_parties, "ENF Parties",               "EFDD Parties")      )    )  )# summarize datacs_sum <-  cs %>%  group_by(curr_cat, prev_cat) %>%  summarize(n = sum(n)) %>%  arrange(prev_cat)# Sankey diagram using plotlylabels <- c(unique(cs_sum$prev_cat), unique(cs_sum$curr_cat))colors <- ifelse(grepl("EFDD", labels), "#24B9B9", "#2B3856")sankey_plot <- plot_ly(  type = "sankey",  orientation = "h",    node = list(    label = labels,    color = colors,    pad = 15,    thickness = 15,    line = list(color = "black",                width = 0.5)  ),    link = list(    source = as.numeric(as.factor(cs_sum$prev_cat)) - 1L,    target = as.numeric(as.factor(cs_sum$curr_cat)) + 3L,    value =  cs_sum$n  ),    height = 340,  width = 600) %>%  layout(font = list(size = 10))

# construct edgescs_edge <-  cs %>%  group_by(prev, curr, prev_cat, curr_cat) %>%  dplyr::summarise(weight = sum(n)) %>%  arrange(curr)# get list of unique articles to construct as nodescs_node <-   gather(cs_edge,         `prev`,         `curr`,         key = "where",         value = "article") %>%  ungroup() %>%  select(article) %>%  distinct(article)names(cs_node) <- c("node")cs_node$category <-  ifelse(cs_node$node == enf,         "ENF Group",         ifelse(           cs_node$node == efdd,           "EFDD Group",           ifelse(cs_node$node %in% enf_parties, "ENF Parties",                  "EFDD Parties")         )  )# generate graphset.seed(3)cs_net <-  graph.data.frame(cs_edge,                   vertices = cs_node,                   directed = F)cs_net <-  igraph::simplify(cs_net, remove.multiple = T, remove.loops = T)# generate colors based on categoryV(cs_net)$color <-   ifelse(grepl("EFDD", V(cs_net)$category), "#24B9B9", "#2B3856")# compute node degrees (#links) and use that to set node sizedeg <- igraph::degree(cs_net, mode = "all")V(cs_net)$size <- deg / 10# set labelsV(cs_net)$label <- NAV(cs_net)$label.cex = 0.5V(cs_net)$label = ifelse(igraph::degree(cs_net) > 5, V(cs_net)$label, NA)cs_hc_labels <- as.vector(cs_node$node)# set edge width based on weightE(cs_net)$width <- log(E(cs_net)$weight) / 5E(cs_net)$edge.color <- "gray80"# transform the network to a ggplot friendly format# (required to generate interactive graph embedded in blog post)gg_cs_net <-  ggnetwork(    cs_net,    layout = "fruchtermanreingold",    weights = "weight",    niter = 50000,    arrow.gap = 0  )cs_plot <- ggplot(gg_cs_net, aes(x = x, y = y, xend = xend, yend = yend)) +  geom_edges(aes(color = edge.color), size = 0.4, alpha = 0.25) +  geom_nodes(aes(color = color, size = size)) +  geom_nodetext(aes(color = color, label = vertex.names, cex = 0.6)) +  guides(size=FALSE) +  theme_blank() +  theme(legend.position = "none")

# get item based on item iduk_item <- get_item("Q30325756", language = "en")# extract candidatescandidates <- extract_claims(uk_item, claims = "P726")candidates <- candidates[[1]][[1]]$mainsnak$datavalue$value$id# collect the following attributes ("claims") for each candidateclaims <- c("P1559", "P21", "P569", "P39", "P69", "P856", "P2002", "P2013")names(claims) <- c("nam", "sex", "dob", "exp", "edu", "web", "twi", "fbk")claims

##     nam     sex     dob     exp     edu     web     twi     fbk ## "P1559"   "P21"  "P569"   "P39"   "P69"  "P856" "P2002" "P2013"

# retrieve datauk_data <-  sapply(candidates,         function (item) {           tmp_item <- get_item(item, language = "en")           sapply(claims,                  function(claim) {                    tmp_claim <- extract_claims(tmp_item, claim)[[1]][[1]]                    if (any(is.na(tmp_claim))) {                      return(NA)                    } else {                      tmp_claim <- tmp_claim$mainsnak$datavalue$value                      if (is.atomic(tmp_claim)) {                        return(tmp_claim)                      } else if ("text" %in% names(tmp_claim)) {                        return(tmp_claim$text)                      } else if ("time" %in% names(tmp_claim)) {                        tmp_claim <- as.Date(substr(tmp_claim$time, 2, 11))                        return(tmp_claim)                      } else if ("id" %in% names(tmp_claim)) {                        tmp_claim <- tmp_claim$id                        tmp_claim <-                           sapply(tmp_claim,                                  get_item,                                  language = "en",                                 simplify = FALSE,                                 USE.NAMES = TRUE)                        tmp_claim <-                          sapply(tmp_claim,                                 function (x) {                                   x[[1]]$labels$en$value                                 })                        return(tmp_claim)                      }                    }                  },                  simplify = FALSE,                  USE.NAMES = TRUE)         },         simplify = FALSE,         USE.NAMES = TRUE  )

## $nam## [1] "Boris Johnson"## ## $sex## Q6581097 ##   "male" ## ## $dob## [1] "1964-06-19"## ## $exp##                                                    Q38931 ##                                         "Mayor of London" ##                                                  Q1371091 ## "Secretary of State for Foreign and Commonwealth Affairs" ##                                                 Q28841847 ##       "Member of the Privy Council of the United Kingdom" ##                                                 Q30524710 ##     "Member of the 57th Parliament of the United Kingdom" ##                                                 Q30524718 ##     "Member of the 56th Parliament of the United Kingdom" ##                                                 Q35647955 ##     "Member of the 54th Parliament of the United Kingdom" ##                                                 Q35921591 ##     "Member of the 53rd Parliament of the United Kingdom" ##                                                    Q14211 ##                    "Prime Minister of the United Kingdom" ##                                                  Q3303456 ##                        "Leader of the Conservative Party" ## ## $edu##                         Q192088                         Q805285 ##                  "Eton College"               "Balliol College" ##                        Q4804780                          Q34433 ##          "Ashdown House School"          "University of Oxford" ##                        Q5413121 ## "European School of Brussels I" ## ## $web## [1] "http://www.boris-johnson.com"## ## $twi## [1] "BorisJohnson"## ## $fbk## [1] "borisjohnson"

## Install from GitHubdevtools::install_github("saschagobel/legislatoR")library(legislatoR)## View functionalityls("package:legislatoR")

## [1] "get_core"       "get_history"    "get_ids"        "get_office"    ## [5] "get_political"  "get_portrait"   "get_profession" "get_social"    ## [9] "get_traffic"

## Get social media adoption rates# get data: Germanydat_ger <- right_join(  x = get_core(legislature = "deu"),  y = filter(    get_political(legislature = "deu"),    as.numeric(session) == max(as.numeric(session))  ),  by = "pageid")dat_ger <- left_join(x = dat_ger,                     y = get_social(legislature = "deu"),                     by = "wikidataid")dat_ger$legislature <- "Germany"dat_ger_sum <- dat_ger %>%  dplyr::summarize(    twitter = mean(not(is.na(twitter)), na.rm = TRUE),    facebook = mean(not(is.na(facebook)), na.rm = TRUE),    website = mean(not(is.na(website)), na.rm = TRUE),    session_start = ymd(first(session_start)),    session_end = ymd(first(session_end)),    legislature = first(legislature)  )

##     twitter  facebook  website session_start session_end legislature## 1 0.7591036 0.6918768 0.640056    2017-10-24  2021-10-24     Germany

## Visualize average pageviews data of German MPs# get datager_traffic <- right_join(  x = get_traffic(legislature = "deu"),  y = filter(    get_political(legislature = "deu"),    session_end >= as.Date("2015-07-01")  ),  by = "pageid")ger_traffic <- left_join(x = ger_traffic,                         y = get_core(legislature = "deu"),                         by = "pageid")ger_traffic <-  dplyr::select(ger_traffic, pageid, date, traffic, session, party, name)# aggregate datager_traffic$date <- ymd(ger_traffic$date)ger_traffic_date <- group_by(ger_traffic, date)ger_traffic_legislators <- group_by(ger_traffic, pageid)ger_traffic_sum <-  summarize(ger_traffic_date, mean = mean(traffic, na.rm = TRUE))ger_traffic_sum <- mutate(  ger_traffic_sum,  mean_l1 = lag(mean, 1),  mean_f1 = lead(mean, 1),  peak = (mean >= 1.8 * mean_l1 &            mean > 180))# identify peaksger_traffic_peaks <- filter(ger_traffic_sum, peak == TRUE)ger_traffic_peaks_df <-  filter(ger_traffic, date %in% ger_traffic_peaks$date)ger_traffic_peaks_group <-  group_by(ger_traffic_peaks_df, date) %>%   dplyr::arrange(desc(traffic)) %>%   filter(row_number() == 1)ger_traffic_peaks_group <- arrange(ger_traffic_peaks_group, date)events_vec <-  c(    "deceased",    "drug affair",    "bullying affair",    "candidacy for presidency",    "deceased",    "???",    "chancellorchip announcement",    "elected president",    "???",    "policy success",    "TV debate",    "general election",    "threat to resign",    "elected speaker of parliament"  )# plotpar(oma = c(0, 0, 0, 0))par(mar = c(0, 4, 0, .5))par(yaxs = "i", xaxs = "i", bty = "n")layout(matrix(c(1, 1, 3, 2, 2, 3), 2, 3, byrow = TRUE),       heights = c(1, 2, 3),       widths = c(5, 5, 1.8))# names labelsplot(  ymd(ger_traffic_sum$date),  rep(0, length(ger_traffic_sum$date)),  xlim = c(ymd("2015-07-01"), ymd("2018-01-01")),  xaxt = "n",  ylim = c(0, 8),  yaxt = "n",  xlab = "",  ylab = "",  cex = 0)text(  ger_traffic_peaks_group$date,  0,  ger_traffic_peaks_group$name,  cex = .75,  srt = 90,  adj = c(0, 0))# pageviews time seriespar(mar = c(2, 4, 0, .5))plot(  ymd(ger_traffic_sum$date),  ger_traffic_sum$mean,  type = "l",  ylim = c(0, 1.25 * max(ger_traffic_sum$mean)),  xlim = c(ymd("2015-07-01"), ymd("2018-01-01")),  xaxt = "n",  yaxt = "n",  xlab = "",  ylab = "mean(pageviews)",  col = "white")abline(h = seq(0, 1.5 * max(ger_traffic_sum$mean), 250), col = "lightgrey")lines(ymd(ger_traffic_sum$date), ger_traffic_sum$mean, lwd = .5)dates <- seq(ymd("2015-07-01"), ymd("2018-01-01"), by = 1)axis(1, dates[day(dates) == 1 &                month(dates) %in% c(1, 4, 7, 10)], labels = FALSE)axis(1,     dates[day(dates) == 1 &             month(dates) %in% c(1)],     lwd = 0,     lwd.ticks = 3,     labels = FALSE)axis(1,     dates[day(dates) == 1 &             month(dates) %in% c(7)],     labels = as.character(year(dates[day(dates) == 15 &                                        month(dates) %in% c(7)])),     tick = F,     lwd = 0)axis(2, seq(0, 1.5 * max(ger_traffic_sum$mean), 250), las = 2)# events labels in time seriesfor (i in seq_along(events_vec)) {  text(ger_traffic_peaks_group$date[i],       ger_traffic_sum$mean[ger_traffic_sum$peak == TRUE][i] + 80,       i,       cex = .8)  points(    ger_traffic_peaks_group$date[i],    ger_traffic_sum$mean[ger_traffic_sum$peak == TRUE][i] + 80,    pch = 1,    cex = 2.2  )}# election date# events labels explainedpar(mar = c(0, 0, 0, 0))plot(  0,  0,  xlim = c(0, 5),  ylim = c(0, 10),  xaxt = "n",  yaxt = "n",  xlab = "",  ylab = "",  cex = 0)positions <-  data.frame(    events_xpos = 0.45,    events_ypos = seq(6.5, (6.5 - .5 * length(events_vec)),-.5),    text_xpos = .5  )text(0, 7, "Events", pos = 4, cex = .75)for (i in seq_along(events_vec)) {  text(positions$events_xpos[i], positions$events_ypos[i], i, cex = .8)  points(positions$events_xpos[i],         positions$events_ypos[i],         pch = 1,         cex = 2.2)  text(    positions$text_xpos[i],    positions$events_ypos[i],    events_vec[i],    pos = 4,    cex = .75  )}

I am so pleased to now be an RStudio-certified tidyverse trainer! I have been teaching technical content for decades, whether in a university classroom, developing online courses, or leading workshops, but I still found this program valuable for my own professonal development. I learned a lot that is going to make my teaching better, and I am happy to have been a participant. If you are looking for someone to lead trainings or workshops in your organization, you can check out this list of trainers to see who might be conveniently located to you!

Part of the certification process is delivering a demonstration lesson. I quite like the content of the demonstration lesson I built and I might not use it in an actual workshop anytime soon, so I decided to expand upon it and share it here as a blog post. My demonstration focused on handling dates using lubridate; dates and times are important in data analysis, but they can often be challenging. In this post, we will explore some wild caught date data from the London Stage Database and explore how to handle these dates using the lubridate package.

library(tidyverse)json_path <- "https://londonstagedatabase.usu.edu/downloads/LondonStageJSON.zip"download.file(json_path, "LondonStageJSON.zip")unzip("LondonStageJSON.zip")london_stage_raw <- jsonlite::fromJSON("LondonStageFull.json") %>%    as_tibble()

london_stage_raw

## # A tibble: 52,617 x 13##    EventId EventDate TheatreCode Season Volume Hathi CommentC TheatreId##                                ##  1 0       16591029  city        1659-… 1      ""    The … 63       ##  2 1       16591100  mt          1659-… 1      ""    On 23 N… 206      ##  3 2       16591218  none        1659-… 1      ""    Represe… 1        ##  4 3       16600200  mt          1659-… 1      ""    6 Feb. … 206      ##  5 4       16600204  cockpit     1659-… 1      ""    $Thomas… 73       ##  6 5       16600328  dh          1659-… 1      ""    At D… 90       ##  7 6       16600406  none        1659-… 1      ""    ""       1        ##  8 7       16600412  vh          1659-… 1      ""    Edition… 319      ##  9 8       16600413  fh          1659-… 1      ""    The … 116      ## 10 9       16600416  none        1659-… 1      ""    ""       1        ## # … with 52,607 more rows, and 5 more variables: Phase2 ,## #   Phase1 , CommentCClean , BookPDF , Performances 

class(london_stage_raw$EventDate)

## [1] "character"

library(lubridate)london_stage <- london_stage_raw %>%    mutate(EventDate = ymd(EventDate)) %>%    filter(!is.na(EventDate))

## Warning: 378 failed to parse.

class(london_stage$EventDate)

## [1] "Date"

year(today())

## [1] 2019

london_stage %>%    mutate(EventYear = year(EventDate)) %>%    count(EventYear)

## # A tibble: 142 x 2##    EventYear     n##         ##  1      1659     2##  2      1660    58##  3      1661   138##  4      1662    91##  5      1663    68##  6      1664    53##  7      1665    20##  8      1666    30##  9      1667   149## 10      1668   147## # … with 132 more rows

london_stage %>%    count(EventYear = year(EventDate)) %>%    ggplot(aes(EventYear, n)) +    geom_area(fill = "midnightblue", alpha = 0.8) +    labs(y = "Number of events",         x = NULL)

london_stage %>%    ggplot(aes(month(EventDate))) +    geom_bar(fill = "midnightblue", alpha = 0.8) +    labs(y = "Number of events")

london_stage %>%    ggplot(aes(month(EventDate, label = TRUE))) +    geom_bar(fill = "midnightblue", alpha = 0.8) +    labs(x = NULL,         y = "Number of events")

london_stage %>%    ggplot(aes(wday(EventDate, label = TRUE))) +    geom_bar(fill = "midnightblue", alpha = 0.8) +    labs(x = NULL,         y = "Number of events")

london_by_theater <- london_stage %>%    filter(TheatreCode != "none") %>%     group_by(TheatreCode) %>%    summarise(TotalEvents = n(),              MinDate = min(EventDate),              MaxDate = max(EventDate),              TimeSpan = as.duration(MaxDate - MinDate)) %>%    arrange(-TotalEvents)london_by_theater

## # A tibble: 233 x 5##    TheatreCode TotalEvents MinDate    MaxDate   ##                           ##  1 dl                18451 1674-03-26 1800-06-18##  2 cg                12826 1662-05-09 1800-06-16##  3 hay                5178 1720-12-29 1800-09-16##  4 king's             4299 1714-10-23 1800-08-02##  5 lif                4117 1661-06-28 1745-10-07##  6 gf                 1832 1729-10-31 1772-10-23##  7 queen's             884 1705-04-09 1714-06-23##  8 marly               403 1750-08-16 1776-08-10##  9 bf                  257 1661-08-22 1767-09-07## 10 dg                  235 1671-06-26 1706-11-28## # … with 223 more rows, and 1 more variable: TimeSpan 

london_by_theater %>%     filter(TotalEvents > 100) %>%    ggplot(aes(TimeSpan)) +    geom_histogram(bins = 20)

## Error: Incompatible duration classes (Duration, numeric). Please coerce with `as.duration`.

london_by_theater %>%    mutate(TimeSpan = as.numeric(TimeSpan, "year"))

## # A tibble: 233 x 5##    TheatreCode TotalEvents MinDate    MaxDate    TimeSpan##                               ##  1 dl                18451 1674-03-26 1800-06-18   126.  ##  2 cg                12826 1662-05-09 1800-06-16   138.  ##  3 hay                5178 1720-12-29 1800-09-16    79.7 ##  4 king's             4299 1714-10-23 1800-08-02    85.8 ##  5 lif                4117 1661-06-28 1745-10-07    84.3 ##  6 gf                 1832 1729-10-31 1772-10-23    43.0 ##  7 queen's             884 1705-04-09 1714-06-23     9.20##  8 marly               403 1750-08-16 1776-08-10    26.0 ##  9 bf                  257 1661-08-22 1767-09-07   106.  ## 10 dg                  235 1671-06-26 1706-11-28    35.4 ## # … with 223 more rows

london_by_theater %>%    mutate(TimeSpan = as.numeric(TimeSpan, "month"))

## # A tibble: 233 x 5##    TheatreCode TotalEvents MinDate    MaxDate    TimeSpan##                               ##  1 dl                18451 1674-03-26 1800-06-18    1515.##  2 cg                12826 1662-05-09 1800-06-16    1657.##  3 hay                5178 1720-12-29 1800-09-16     957.##  4 king's             4299 1714-10-23 1800-08-02    1029.##  5 lif                4117 1661-06-28 1745-10-07    1011.##  6 gf                 1832 1729-10-31 1772-10-23     516.##  7 queen's             884 1705-04-09 1714-06-23     110.##  8 marly               403 1750-08-16 1776-08-10     312.##  9 bf                  257 1661-08-22 1767-09-07    1272.## 10 dg                  235 1671-06-26 1706-11-28     425.## # … with 223 more rows

library(ggrepel)london_by_theater %>%    mutate(TimeSpan = as.numeric(TimeSpan, "month")) %>%    filter(TotalEvents > 10) %>%    ggplot(aes(TimeSpan, TotalEvents, label = TheatreCode)) +    geom_smooth(method = "lm") +    geom_label_repel(family = "IBMPlexSans") +    geom_point() +    scale_x_log10() +    scale_y_log10() +    labs(x = "Months that theater was in operation",         y = "Total events staged by theater")

Background

I like writing my academic papers in RMarkdown because it allows reproducible research. The cleanest way to submit a manuscript made in RMarkdown is using the LaTeX code that it generates using the YAML switch keep_tex = true. A minimalist YAML header would look like so:

---title: The document titleauthor:   - Duke A Caboom, MD  - Justin d'Ottawa, PhD:output:   pdf_document:    keep_tex: true---

Introduction

However, when you want mutliple authors affiliations you discover that you can’t do as you would in LaTeX because Pandoc does not know what to do with the affiliations and you end out a dishearting PDF that looks like the output shown in figure 1 below:

Figure 1: This is so sad.

The situation worsens if you want MS-Word output. As those of us in medical fields know, most journals (with some notable exceptions like the Clinical Mass Spectrometry Journal and other Elsevier journals like Clinical Biochemistry and Clinica Chimica Acta) require submission of a document in MS-Word format which goes against all that Data Science and Reprodicible Research stands for–he says, with hyperbole. Parenthetically, it is my hope that since AACC has indicated that they intend to make Data Science a strategic priority for Lab Medicine, they will soon accept submissons to Clinical Chemistry and Journal of Applied Laboratory Medicine written reproducibly in RMardown or LaTeX.

In the mean time, here are the workarounds for getting the affiliations to display correctly along with all the other stuff we want, namely, cross referencing of figures and tables and correct reference formatting and abbreviation of journal names. This allows you to avoid the horror of manually fixing your Word document after it generated from RMarkdown. In any case, let’s start with MS-Word.

Dependencies for MS-Word and the Associated YAML

You will also need to install Pandoc which is the Swiss Army Knife of document conversion. It’s going to turn your code into a .docx file for you. Mac users can do this with Homebrew on the terminal command line:

brew install pandocbrew install pandoc-citeprocbrew install pandoc-crossref

There are some extra installs required to help Pandoc do its job. Install the prebuilt binaries if you can.

• pandoc-citeproc
• pandoc-crossref

Finally, you need to use some scripts written in the Lua scripting language which means you will need the language itself:

• lua language

And you will need two Lua scripts:

These are in Pandoc github repository:

• scholarly-metadata.lua
• author-info-blocks.lua

You want the files named scholarly-metadata.lua and author-info-blocks.lua.

You will need to choose a .csl file for your journal. This will tell Pandoc how to format the references. You can download the correct .csl file here. You will also need a journal abbreviations database. I have made one for you from the Web of Science list and you can download it here.

You will need to creat a .bibtex database which is just your list of references. This can be exported from various reference managers or built by hand. Name the file mybibfile.bib.

Now follow the bouncing ball:

1. Go to the directory containing your .Rmd file.
2. Create a directory in it called “Extras”
3. Put the two Lua scripts, the Bibtex database, the abbreviations database and the .csl file into the “Extras” folder.
4. If you want to avoid Pandoc’s goofy default .docx formatting, then put this word document in the same folder.

OR

Download the contents of this folder from my github repo that has everything set up as I describe above.

For two authors, your YAML will need to look like this:

title: |  RMarkdown Template for Managing    Academic Affiliations subtitle: |  Also Deals with Cross References and    Reference Abbreviations for MS-Word Outputauthor:  - Duke A Caboom, MD:      email: duke.a.caboom@utuktoyaktuk.edu      institute: [UofT]      correspondence: true  - Justin d'Ottawa, PhD:      email: justin@neverready.ca      institute: [UofO]      correspondence: falseinstitute:  - UofT: University of Tuktoyaktuk, CXVG+62 Tuktoyaktuk, Inuvik, Unorganized, NT Canada  - UofO: University of Ottawa, 75 Laurier Ave E, Ottawa, ON K1N 6N5, Canadaabstract: |  **Introduction**: There's a big scientific problem out there. I know how to fix it.  **Methods**: My experiments are pure genius.  **Results**: Now you have your proof.  **Conclusion**: Give me more grant money.journal: "An awesome journal"date: ""toc: falseoutput: bookdown::word_document2:    pandoc_args:      - --csl=Extras/clinical-biochemistry.csl      - --citation-abbreviations=Extras/abbreviations.json      - --filter=pandoc-crossref      - --lua-filter=Extras/scholarly-metadata.lua      - --lua-filter=Extras/author-info-blocks.lua      - --reference-doc=Extras/Reference_Document.docx bibliography: "Extras/mybibfile.bib"keywords: "CRAN, R, RMarkdown, RStudio, YAML"

Et voila! Figure 2 shows that we have something reasonable.

Figure 2: This is so great

Dependencies for LaTeX and the Associated YAML

It goes without saying that you need to install LaTeX. LaTeX markup language is available here: Mac, Windows. For Linux, just install from the command line with your package manager. Do a full install with all the glorious bloat of all LaTeX packages. This saves many headaches in the future.

You don’t need the lua scripts for LaTeX although you can use them. The issue with LaTeX is that the .tex template that Pandoc uses for generating LaTeX files does not support author affiliations as descibed in the Pandoc documentation. So what you need to do is modify the Pandoc LaTeX template. To get your current working copy of the Pandoc LaTeX template open up a terminal (Mac/Linux) and type:

pandoc -D latex > mytemplate.tex

This will push the contents to a file. Move the file to the “Extras” folder discussed above. If that seems difficult, you can also download it here. Now you have to edit it. Open it up in a text editor and find the section that reads:

$if(author)$\author{$for(author)$author$sep$ \and $endfor$}$endif$

Replace this with this code that will invoke the LaTeX authblk package.

$if(author)$    \usepackage{authblk}    $for(author)$        $if(author.name)$            $if(author.number)$                \author[$author.number$]{$author.name$}            $else$                \author[]{$author.name$}            $endif$            $if(author.affiliation)$                $if(author.email)$                    \affil{$author.affiliation$ \thanks{$author.email$}}                $else$                    \affil{$author.affiliation$}                $endif$            $endif$            $else$              \author{$author$}        $endif$    $endfor$$endif$

Then make your YAML header look like this:

---title: |  RMarkdown Template for Managing    Academic Affiliations subtitle: |  Also Deals with Cross References and    Reference Abbreviations for PDF Outputauthor:- name: Duke A Caboom, MD  affiliation: University of Tuktoyaktuk, CXVG+62 Tuktoyaktuk, Inuvik, Unorganized, NT Canada  email: dtholmes@mail.ubc.ca  number: 1- name: Justin d'Ottawa, PhD  affiliation: University of Ottawa, 75 Laurier Ave E, Ottawa, ON K1N 6N5, Canada  email: justin@neverready.ca  number: 2abstract: |  **Introduction**: There's a big scientific problem out there. I know how to fix it.  **Methods**: My experiments are pure genius.  **Results**: Now you have your proof.  **Conclusion**: Give me more grant money.toc: falseoutput:   bookdown::pdf_document2:    pandoc_args:      - --filter=pandoc-crossref      - --csl=Extras/clinical-biochemistry.csl      - --citation-abbreviations=Extras/abbreviations.json      - --template=Extras/mytemplate.texbibliography: "Extras/mybibfile.bib"keep-latex: true

And as you can see in figure 3 you get a correctly list of authors.

Figure 3: This is also great.

Cross Reference of a Table

Of course, tables can be cross referenced in the same manner as figures. Here is a cross reference to table 1 using the code \@ref(tab:mytable) .

This Template also Takes Care of Reference Abbreviation.

As usual, you can make a citation with the code [@bibtexname], where bibtexname is the articles’s abbreviated handle in your bibtex database. Here is a great resource on the bookdown package [1] and reproducible research [2] and here are references where the journal title is longer [3,4]. The references in your documnent (and shown below) will have appropriate abbreviations based on the .json abbreviations database I have provided. In this case, I have chosen the .csl file for Clinical Mass Spectrometry–’cause MSACL.

Other Ways to Skin the YAML Cat

I came across some other ways to deal with this that I did not like as much but they are simpler. Here is one using a footnote.

title: The document titleauthor:- [Duke A Caboom, MD]^(University of Tuktoyaktuk, CXVG+62 Tuktoyaktuk, Inuvik, Unorganized, NT Canada)- [Justin d'Ottawa, PhD]^(University of Ottawa, 75 Laurier Ave E, Ottawa, ON K1N 6N5, Canada)output: pdf_document

And you can also misuse the date variable:

title: The document titleauthor:- Duke A Caboom, MD [1]- Justin d'Ottawa, PhD [2]date: 1. University of Tuktoyaktuk, CXVG+62 Tuktoyaktuk, Inuvik, Unorganized, NT Canada \newline 2. University of Ottawa, 75 Laurier Ave E, Ottawa, ON K1N 6N5, Canadaoutput: pdf_document

Conclusion

This concludes my long personal struggle to get a completely reproducible .docx manusript genereated by RMarkdown and Pandoc. Here is the output for PDF and Word.

Parting Thought

Let us not become weary in doing good, for at the proper time we will reap a harvest if we do not give up.

Galations 6:9

References

Next Tuesday (September 3) I will be giving a talk at the Bay Area R User Group titled Behind the Scenes of an R Consortium Project. This will be my first time speaking about my work with the R Consortium, and I encourage you to attend!

Over the last few years the R Consortium has emerged as a major source of funding for R projects. However, many R users are not aware of the R Consortium. And many of those who are aware of it view applying for funding as something that “other people do”.

This talk will use a case study – my own R Consortium Project – to argue that even “average” members of the R community can and should apply to the R Consortium for funding for projects that personally interest them.

In 2018 I began working with the Census Bureau to create an online course on using R to analyze US Census Data. Shortly after I announced that project, Joseph Rickert from the R Consortium contacted me about applying for funding to further this work. In this talk I will describe what problem I wanted to solve, how it related to work that I was already doing and what the application process was like. I will argue that my project can serve as a template for other, similar projects, and will also provide a post-mortem on the project.

You can register for the Meetup for free here.

The post Behind the Scenes of an R Consortium Project appeared first on AriLamstein.com.

Zomato is a popular restaurants listing website in India (Similar to Yelp) and People are always interested in seeing how to download or scrape Zomato Restaurants data for Data Science and Visualizations.

In this post, We’ll learn how to scrape / download Zomato Restaurants (Buffets) data using R. Also, hope this post would serve as a basic web scraping framework / guide for any such task of building a new dataset from internet using web scraping.

Loading the libraries

library(rvest)library(tidyverse)

zomato web scraping

zom <- read_html("https://www.zomato.com/bangalore/restaurants?buffet=1")

Barbeque Nation

zom %>% html_nodes("a.result-title") %>%   html_attr("title") %>%   stringr::str_split(pattern = ',') -> listing

zom_df <- do.call(rbind.data.frame, listing)names(zom_df) <- c("Name","Place")

zom_df$Price <- zom %>% html_nodes("div.res-cost > span.pl0") %>%   html_text() %>%   parse_number()

head(zom_df)

##                                Name             Place Price## 1 abs absolute barbecues Restaurant      Marathahalli  1600## 2            big pitcher Restaurant  Old Airport Road  1800## 3                 pallet Restaurant        Whitefield  1600## 4        barbeque nation Restaurant       Indiranagar  1600## 5            black pearl Restaurant      Marathahalli  1500## 6      empire restaurant Restaurant       Indiranagar   500

zom_df %>%   ggplot() + geom_line(aes(Name,Price,group = 1)) +  theme_minimal() +  coord_flip() +  labs(title = "Top Zomato Buffet Restaurants",       caption = "Data: Zomato.com")

As the current Editor-in-Chief of the R Journal, I must apologize for the delay in getting the July issue online, due to technical and other matters. In the meantime, though, please take a look at the many interesting articles slated for publication in this and upcoming issues.

Various improvements in technical documentation, as well as the pending hire of the journal’s first-ever editorial assistant, should shorten the review and publication processes in the future.

By the way, I’ve made a couple of tweaks to the Instructions for Authors. First, I note that the journal’s production software really does require following the instructions carefully. For instance, the \author field in your .tex file must start with “by” in order to work properly; it’s not merely a matter of, say, aesthetics. And your submission package must not have more than one .bib file or more than one .tex file other than RJwrapper.tex.

Finally, a reminder to those whom we ask to review article submissions: Your service would be greatly appreciated, a valuable contribution to R. If you must decline, though, please respond to our e-mail query, stating so, so that we may quickly search for other possible reviewers.