Multiple choice questions, or “multi-code” questions, are very common in survey analysis and in itself adds a level of complication in analysis. A simple example of a multi-code question is this:
Q11. Which of the following best describes your experience with these brands?
SHOW BRANDS ONE BY ONE: [Brand A, Brand B…]
- I have never heard of… [BRAND]
- I have heard of [BRAND] but have never bought from them
- I have bought from [BRAND]
Typically, the output of the data would look something like this:
This is a simulated data set where each column represents the scores for each brand, and each row is a respondent’s answer for that brand.
One of the key things that we want to quickly find out from this data is whether some brands perform better on penetration (Q11x = 2) and brand awareness (Q11x = 1+2). To do this we would want to look at the column percentages for each column (brand) and yet have the percentages organised in a way that will allow us to easily compare differences across brands.
In my own attempts to find a solution for this, I’ve found the table() function in base R and CrossTable() in the gmodels package are on their own insufficient for analysing multi-code questions, since they seem to only work for single-code questions. I’ve thus proceeded to try and produce my own functions.
First, I would format the data so that each variable would be a factor rather than numeric:
Q11 %<>% lapply(as.factor) %<>%
data.frame()
glimpse(Q11)
Observations: 500
Variables: 5
$ Q11a <fctr> 1, 2, 1, 2, 1, 2, 0, 2, 0, 0, 2, 1, 2, 0, 0, 0, 0, 1, 0, 2, 1, 0, 1, 0, 0, 0, 1, 1, ...
$ Q11b <fctr> 0, 1, 2, 2, 0, 0, 1, 2, 0, 1, 2, 0, 2, 2, 2, 2, 0, 0, 0, 2, 0, 0, 0, 2, 1, 1, 1, 0, ...
$ Q11c <fctr> 0, 1, 2, 1, 1, 2, 2, 2, 2, 2, 1, 1, 2, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 0, 0, 2, 2, 0, ...
$ Q11d <fctr> 2, 2, 1, 0, 2, 0, 0, 0, 2, 1, 1, 1, 0, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 0, 0, 2, 2, 1, ...
$ Q11e <fctr> 2, 0, 2, 2, 2, 2, 2, 0, 0, 0, 0, 2, 2, 1, 2, 0, 0, 1, 2, 1, 0, 0, 1, 2, 0, 2, 2, 1, ...
My next step would be to write two functions: one for producing a contingency table with column percentages for each brand (similar to what prop.table(table()) does), and another for creating a “multi-code” version of the table which allows you to compare the column percentages across all the brands. Here are the two functions:
ctab <- function(vec){
var<-list(0)
prop<-list(0)
tab<-data.frame(Q=0,Prop=0)
for(i in 1:nlevels(vec)){
var[i]<-levels(vec)[i]
prop[i]<-mean(vec==levels(vec)[i])
}
var <- unlist(var)
prop <- unlist(prop)
tab <- cbind(var,prop) %>% as.data.frame()
names(tab)<-c("Q","Prop")
tab
}
ctab.mc <- function(x){
ind.tabs <-list()
x.codes <- ncol(x)
x.names <- names(x)
for(i in 1:x.codes){
ind.tabs[[i]]<-ctab(x[,i])
}
all.merged <-merge(x=ind.tabs[[1]],y=ind.tabs[[2]],by="Q")
for(i in 3:x.codes){
all.merged<-merge(x=all.merged,y=ind.tabs[[i]],by="Q")
}
for(i in 1:x.codes){
names(all.merged)[i+1]<-x.names[i]
}
all.merged
}
Let’s now have a look at what these functions output respectively. When the responses for Brand A is passed through to the ctab function, we get a contingency table showing the percentage of respondents answering responses 0, 1, or 2 for Brand A:
ctab(Q11$Q11a)
And similarly for Brand B:
ctab(Q11$Q11b)
The second function ctab.mc() saves time by merging all of these individual contingency tables into a single combined contingency table. Instead of passing a column/vector in the argument, this time instead we will pass the whole data frame (where all columns are multi-code data, no ID columns etc.). This is what it looks like in action:
ctab.mc(Q11)
This way, we can easily see that penetration is the highest for Brand C, since it has the highest % for code 2. It is also the brand scoring the highest on brand awareness, since its combined % for codes 1 and 2 is also the highest.
It’s likely that there are other solutions out there that can do this job more elegantly and efficiently, but hopefully this example would still be useful in showing how custom functions can help solve problems when a ready-made solution isn’t known.
LS0tDQp0aXRsZTogIkNyZWF0aW5nIENvbnRpbmdlbmN5IFRhYmxlcyBmb3IgTXVsdGlwbGUgQ2hvaWNlIFN1cnZleSBEYXRhIg0KYXV0aG9yOiAiTWFydGluIENoYW4iDQpkYXRlOiAiSnVuZSAxMSwgMjAxNyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCmBgYHtyLCBpbmNsdWRlPUZBTFNFfQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpsaWJyYXJ5KG1hZ3JpdHRyKQ0Kc2V0LnNlZWQoNjkpDQpgYGANCg0KDQoqKk11bHRpcGxlIGNob2ljZSBxdWVzdGlvbnMqKiwgb3IgIm11bHRpLWNvZGUiIHF1ZXN0aW9ucywgYXJlIHZlcnkgY29tbW9uIGluIHN1cnZleSBhbmFseXNpcyBhbmQgaW4gaXRzZWxmIGFkZHMgYSBsZXZlbCBvZiBjb21wbGljYXRpb24gaW4gYW5hbHlzaXMuIEEgc2ltcGxlIGV4YW1wbGUgb2YgYSBtdWx0aS1jb2RlIHF1ZXN0aW9uIGlzIHRoaXM6IA0KDQpRMTEuIFdoaWNoIG9mIHRoZSBmb2xsb3dpbmcgYmVzdCBkZXNjcmliZXMgeW91ciBleHBlcmllbmNlIHdpdGggdGhlc2UgYnJhbmRzPw0KDQogIFNIT1cgQlJBTkRTIE9ORSBCWSBPTkU6IFtCcmFuZCBBLCBCcmFuZCBCLi4uXQ0KDQowLiBJIGhhdmUgbmV2ZXIgaGVhcmQgb2YuLi4gW0JSQU5EXQ0KMS4gSSBoYXZlIGhlYXJkIG9mIFtCUkFORF0gYnV0IGhhdmUgbmV2ZXIgYm91Z2h0IGZyb20gdGhlbQ0KMi4gSSBoYXZlIGJvdWdodCBmcm9tIFtCUkFORF0NCg0KVHlwaWNhbGx5LCB0aGUgb3V0cHV0IG9mIHRoZSBkYXRhIHdvdWxkIGxvb2sgc29tZXRoaW5nIGxpa2UgdGhpczogDQpgYGB7ciwgZWNobz1GQUxTRX0NClExMWNvbG5hbWVzIDwtIHBhc3RlMCgiUTExIixsZXR0ZXJzWzE6NV0pDQpRMTEgPC0gZGF0YS5mcmFtZShtYXRyaXgoc2FtcGxlKGMoMCwxLDIpLHNpemU9MjUwMCwgcmVwbGFjZT1UUlVFKSwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgbnJvdz01MDAsIG5jb2w9NSwgZGltbmFtZXMgPSBsaXN0KDE6NTAwLFExMWNvbG5hbWVzKSkpDQpoZWFkKFExMSkNCmBgYA0KDQpUaGlzIGlzIGEgc2ltdWxhdGVkIGRhdGEgc2V0IHdoZXJlIGVhY2ggY29sdW1uIHJlcHJlc2VudHMgdGhlIHNjb3JlcyBmb3IgZWFjaCBicmFuZCwgYW5kIGVhY2ggcm93IGlzIGEgcmVzcG9uZGVudCdzIGFuc3dlciBmb3IgdGhhdCBicmFuZC4gDQoNCk9uZSBvZiB0aGUga2V5IHRoaW5ncyB0aGF0IHdlIHdhbnQgdG8gcXVpY2tseSBmaW5kIG91dCBmcm9tIHRoaXMgZGF0YSBpcyB3aGV0aGVyIHNvbWUgYnJhbmRzIHBlcmZvcm0gIGJldHRlciBvbiBwZW5ldHJhdGlvbiAoUTExeCA9IDIpIGFuZCBicmFuZCBhd2FyZW5lc3MgKFExMXggPSAxKzIpLiBUbyBkbyB0aGlzIHdlIHdvdWxkIHdhbnQgdG8gbG9vayBhdCB0aGUgY29sdW1uIHBlcmNlbnRhZ2VzIGZvciBlYWNoIGNvbHVtbiAoYnJhbmQpIGFuZCB5ZXQgaGF2ZSB0aGUgcGVyY2VudGFnZXMgb3JnYW5pc2VkIGluIGEgd2F5IHRoYXQgd2lsbCBhbGxvdyB1cyB0byBlYXNpbHkgY29tcGFyZSBkaWZmZXJlbmNlcyBhY3Jvc3MgYnJhbmRzLg0KDQpJbiBteSBvd24gYXR0ZW1wdHMgdG8gZmluZCBhIHNvbHV0aW9uIGZvciB0aGlzLCBJJ3ZlIGZvdW5kIHRoZSAqKnRhYmxlKCkqKiBmdW5jdGlvbiBpbiBiYXNlIFIgYW5kICoqQ3Jvc3NUYWJsZSgpKiogaW4gdGhlICoqZ21vZGVscyoqIHBhY2thZ2UgYXJlIG9uIHRoZWlyIG93biBpbnN1ZmZpY2llbnQgZm9yIGFuYWx5c2luZyBtdWx0aS1jb2RlIHF1ZXN0aW9ucywgc2luY2UgdGhleSBzZWVtIHRvIG9ubHkgd29yayBmb3Igc2luZ2xlLWNvZGUgcXVlc3Rpb25zLiBJJ3ZlIHRodXMgcHJvY2VlZGVkIHRvIHRyeSBhbmQgcHJvZHVjZSBteSBvd24gZnVuY3Rpb25zLiANCg0KRmlyc3QsIEkgd291bGQgZm9ybWF0IHRoZSBkYXRhIHNvIHRoYXQgZWFjaCB2YXJpYWJsZSB3b3VsZCBiZSBhIGZhY3RvciByYXRoZXIgdGhhbiBudW1lcmljOg0KDQpgYGB7cn0NClExMSAlPD4lIGxhcHBseShhcy5mYWN0b3IpICU8PiUNCiAgZGF0YS5mcmFtZSgpDQpnbGltcHNlKFExMSkNCmBgYA0KDQpNeSBuZXh0IHN0ZXAgd291bGQgYmUgdG8gd3JpdGUgdHdvIGZ1bmN0aW9uczogb25lIGZvciBwcm9kdWNpbmcgYSBjb250aW5nZW5jeSB0YWJsZSB3aXRoIGNvbHVtbiBwZXJjZW50YWdlcyBmb3IgZWFjaCBicmFuZCAoc2ltaWxhciB0byB3aGF0ICoqcHJvcC50YWJsZSh0YWJsZSgpKSoqIGRvZXMpLCBhbmQgYW5vdGhlciBmb3IgY3JlYXRpbmcgYSAibXVsdGktY29kZSIgdmVyc2lvbiBvZiB0aGUgdGFibGUgd2hpY2ggYWxsb3dzIHlvdSB0byBjb21wYXJlIHRoZSBjb2x1bW4gcGVyY2VudGFnZXMgYWNyb3NzIGFsbCB0aGUgYnJhbmRzLiBIZXJlIGFyZSB0aGUgdHdvIGZ1bmN0aW9uczoNCg0KYGBge3IsIGVjaG89VFJVRX0NCmN0YWIgPC0gZnVuY3Rpb24odmVjKXsNCiAgdmFyPC1saXN0KDApDQogIHByb3A8LWxpc3QoMCkNCiAgdGFiPC1kYXRhLmZyYW1lKFE9MCxQcm9wPTApDQogIGZvcihpIGluIDE6bmxldmVscyh2ZWMpKXsNCiAgICB2YXJbaV08LWxldmVscyh2ZWMpW2ldDQogICAgcHJvcFtpXTwtbWVhbih2ZWM9PWxldmVscyh2ZWMpW2ldKQ0KICB9DQogIHZhciA8LSB1bmxpc3QodmFyKQ0KICBwcm9wIDwtIHVubGlzdChwcm9wKQ0KICB0YWIgPC0gY2JpbmQodmFyLHByb3ApICU+JSBhcy5kYXRhLmZyYW1lKCkNCiAgbmFtZXModGFiKTwtYygiUSIsIlByb3AiKQ0KICB0YWINCn0NCmBgYA0KDQpgYGB7ciwgZWNobz1UUlVFfQ0KY3RhYi5tYyA8LSBmdW5jdGlvbih4KXsNCiAgaW5kLnRhYnMgPC1saXN0KCkNCiAgeC5jb2RlcyA8LSBuY29sKHgpDQogIHgubmFtZXMgPC0gbmFtZXMoeCkNCiAgZm9yKGkgaW4gMTp4LmNvZGVzKXsNCiAgICBpbmQudGFic1tbaV1dPC1jdGFiKHhbLGldKQ0KICB9DQogIGFsbC5tZXJnZWQgPC1tZXJnZSh4PWluZC50YWJzW1sxXV0seT1pbmQudGFic1tbMl1dLGJ5PSJRIikNCiAgZm9yKGkgaW4gMzp4LmNvZGVzKXsNCiAgICBhbGwubWVyZ2VkPC1tZXJnZSh4PWFsbC5tZXJnZWQseT1pbmQudGFic1tbaV1dLGJ5PSJRIikNCiAgfQ0KICBmb3IoaSBpbiAxOnguY29kZXMpew0KICAgIG5hbWVzKGFsbC5tZXJnZWQpW2krMV08LXgubmFtZXNbaV0NCiAgfQ0KICANCiAgYWxsLm1lcmdlZA0KfQ0KYGBgDQoNCkxldCdzIG5vdyBoYXZlIGEgbG9vayBhdCB3aGF0IHRoZXNlIGZ1bmN0aW9ucyBvdXRwdXQgcmVzcGVjdGl2ZWx5LiBXaGVuIHRoZSByZXNwb25zZXMgZm9yIEJyYW5kIEEgaXMgcGFzc2VkIHRocm91Z2ggdG8gdGhlIGN0YWIgZnVuY3Rpb24sIHdlIGdldCBhIGNvbnRpbmdlbmN5IHRhYmxlIHNob3dpbmcgdGhlIHBlcmNlbnRhZ2Ugb2YgcmVzcG9uZGVudHMgYW5zd2VyaW5nIHJlc3BvbnNlcyAwLCAxLCBvciAyIGZvciBCcmFuZCBBOg0KDQpgYGB7ciwgZWNobz1UUlVFfQ0KY3RhYihRMTEkUTExYSkNCmBgYA0KDQpBbmQgc2ltaWxhcmx5IGZvciBCcmFuZCBCOg0KDQpgYGB7ciwgZWNobz1UUlVFfQ0KY3RhYihRMTEkUTExYikNCmBgYA0KVGhlIHNlY29uZCBmdW5jdGlvbiAqKmN0YWIubWMoKSoqIHNhdmVzIHRpbWUgYnkgbWVyZ2luZyBhbGwgb2YgdGhlc2UgaW5kaXZpZHVhbCBjb250aW5nZW5jeSB0YWJsZXMgaW50byBhIHNpbmdsZSBjb21iaW5lZCBjb250aW5nZW5jeSB0YWJsZS4gSW5zdGVhZCBvZiBwYXNzaW5nIGEgY29sdW1uL3ZlY3RvciBpbiB0aGUgYXJndW1lbnQsIHRoaXMgdGltZSBpbnN0ZWFkIHdlIHdpbGwgcGFzcyB0aGUgd2hvbGUgZGF0YSBmcmFtZSAod2hlcmUgYWxsIGNvbHVtbnMgYXJlIG11bHRpLWNvZGUgZGF0YSwgbm8gSUQgY29sdW1ucyBldGMuKS4gVGhpcyBpcyB3aGF0IGl0IGxvb2tzIGxpa2UgaW4gYWN0aW9uOg0KDQpgYGB7ciwgZWNobz1UUlVFLCB3YXJuaW5nPUZBTFNFfQ0KY3RhYi5tYyhRMTEpDQpgYGANCg0KVGhpcyB3YXksIHdlIGNhbiBlYXNpbHkgc2VlIHRoYXQgcGVuZXRyYXRpb24gaXMgdGhlIGhpZ2hlc3QgZm9yIEJyYW5kIEMsIHNpbmNlIGl0IGhhcyB0aGUgaGlnaGVzdCAlIGZvciBjb2RlIDIuIEl0IGlzIGFsc28gdGhlIGJyYW5kIHNjb3JpbmcgdGhlIGhpZ2hlc3Qgb24gYnJhbmQgYXdhcmVuZXNzLCBzaW5jZSBpdHMgY29tYmluZWQgJSBmb3IgY29kZXMgMSBhbmQgMiBpcyBhbHNvIHRoZSBoaWdoZXN0Lg0KDQpJdCdzIGxpa2VseSB0aGF0IHRoZXJlIGFyZSBvdGhlciBzb2x1dGlvbnMgb3V0IHRoZXJlIHRoYXQgY2FuIGRvIHRoaXMgam9iIG1vcmUgZWxlZ2FudGx5IGFuZCBlZmZpY2llbnRseSwgYnV0IGhvcGVmdWxseSB0aGlzIGV4YW1wbGUgd291bGQgc3RpbGwgYmUgdXNlZnVsIGluIHNob3dpbmcgaG93IGN1c3RvbSBmdW5jdGlvbnMgY2FuIGhlbHAgc29sdmUgcHJvYmxlbXMgd2hlbiBhIHJlYWR5LW1hZGUgc29sdXRpb24gaXNuJ3Qga25vd24uICA=