Modeling Player-character Engagement Poster

The figures from the poster Modeling Player-character Engagement in Single-player Character-Driven Games in ACE Netherlands (2013):

(The paper: /2013/11/15/modeling-player-character-engagement-in-single-player-character-driven-games/)

Code for producing these figures:

library("ordinal")
library("reshape")
library("ggplot2")
# FUNCTIONS
# from clmm2 tutorial
pred <- function(eta, theta, cat = 1:(length(theta) + 1), inv.link = plogis) {
   Theta <- c(-1000, theta, 1000)
   sapply(cat, function(j) inv.link(Theta[j + 1] - eta) - inv.link(Theta[j] - eta))
}

plot.probabilities2<-function(grid, model, leg, plot=NULL, title="", ylim=NULL) {
   plot <- if(is.null(plot)) ggplot()
   co <- model$coefficients[1:length(model$y.levels)-1]
   pre.mat <- pred(eta=rowSums(grid), theta=co)
   df.pred<-data.frame(pre.mat)
   names(df.pred) <- as.numeric(model$y.levels)
   df<-melt(cbind(df.pred,leg))
   plot1 <- plot + geom_line(data=df, aes(x=variable, y=value, group=leg, shape=leg, color=leg)) +
   ggtitle(title) + ylab("probability") + xlab("")
   if(!is.null(ylim)) {
       plot1 <- plot1 + ylim(0, ylim)
   }
   return(plot1)
}

plot.probabilities3<-function(grid, model, comp.data=NULL, title="", ylim=NULL) {
   co <- model$coefficients[1:length(model$y.levels)-1]
   pre.mat <- pred(eta=rowSums(grid), theta=co)
   df<-data.frame(levels=as.numeric(model$y.levels))
   df["avg"] <- pre.mat[1,]
   df["low"] <- pre.mat[2,]
   df["high"] <- pre.mat[3,]
   if(!is.null(comp.data)) {
      df["freq"] <- summary(comp.data)/sum(summary(comp.data))
   }
   plot1 <- ggplot(data=df)
   if(!is.null(comp.data)) {
      plot1 <- plot1 +
      geom_area(aes(x=levels,y=freq), alpha=0.7, fill="lightblue") +
          geom_point(aes(x=levels, y=freq), colour="lightblue")
   }
   plot1 <- plot1 + geom_line(aes(x=levels, y=avg)) + geom_point(aes(x=levels, y=avg)) +
   ggtitle(title) + ylab("probability") + xlab("") +
   geom_line(aes(x=levels, y=low), lty="dotted") +
   geom_line(aes(x=levels, y=high), lty="dotted")

   if(!is.null(ylim)) {
      plot1 <- plot1 + ylim(0, ylim)
   }
   return(plot1)
}

df <- read.csv(url("http://www.mediafire.com/download/t9d5d97d78qcbpp/story.csv"), sep = ";")
df$game <-  factor(df$game)
df$game <-  factor(df$game)
df$sex <- factor(df$sex, levels=c("Male", "Female"))
df$rpg <- factor(df$rpg, levels=c("not at all", "less frequently", "other", "monthly", "weekly", "daily"))
df$education <- factor(df$education, levels=c("High school", "Other", "Vocational", "College", "Bachelors", "Masters", "Doctoral"))
df$board_games <- factor(df$board_games, levels=c("not at all", "less frequently", "other", "monthly", "weekly", "daily"))
df$videogames <- factor(df$videogames, levels=c("not at all", "less frequently", "other", "monthly", "weekly", "daily"))
df$q4 <- factor(df$q4, ordered = FALSE)
df$q7 <- factor(df$q7, ordered = FALSE)
df$q8 <- factor(df$q8, ordered = FALSE)
df$char_dev <- factor(df$char_dev)
df$play_styles<-factor(df$play_styles)
df$romance <- factor(df$romance)
df$voice <- factor(df$voice)
df$friendship <- factor(df$friendship)
df$appearance <- factor(df$appearance)
# appearance with the best model produces "design is column rank deficient so dropping 1 coef" so I just combine the levels as the model will do
levels(df$appearance)<-c("no","yes","yes")
df$quest <- factor(df$quest)
df$moral <- factor(df$moral)
df$dialog <- factor(df$dialog)
df$subject <- factor(df$subject)

q8 <- clmm(q8 ~ dialog + romance + romance_cut + friendship + (1|subject), data = df, link = "logit", Hess=TRUE,nAGQ=10L)

q8.mat <- expand.grid(
   c(0,q8$beta[1], q8$beta[2], q8$beta[3], q8$beta[4], q8$beta[5])
)

plot1<-plot.probabilities2(q8.mat, q8, c("none",
   "interactive dialogue",
   "romance modeling: some",
   "romance modeling: yes",
   "romance in cut-scenes",
   "friendship modeling"))
plot1

# U2, RDR & ACB: romance_cut: yes, romance: no, dialog: no, friendship: no
q8.mat.u2 <- expand.grid(subject = qnorm(0.95) * c(0, -1, 1) * q8$stDev,
    romance_cut=c(q8$beta[4])
)
q8.mat.me2 <- expand.grid(subject = qnorm(0.95) * c(0, -1, 1) * q8$stDev,
   romance_cut=c(q8$beta[4]),
   romance=c(q8$beta[3]),
   dialog=c(q8$beta[1]),
   friendship=c(q8$beta[5])
)

q8.mat.dehr <- expand.grid(subject = qnorm(0.95) * c(0, -1, 1) * q8$stDev,
   romance_cut=c(q8$beta[4]),
   dialog=c(q8$beta[1]),
   friendship=c(q8$beta[5])
)

q8.mat.esv<- expand.grid(subject = qnorm(0.95) * c(0, -1, 1) * q8$stDev,
   romance_cut=c(q8$beta[4]),
   romance=c(q8$beta[2]),
   dialog=c(q8$beta[1]),
   friendship=c(q8$beta[5])
)

q8.u2.sub<-subset(df, game=="U2" |game == "RDR" | game=="ACB")
q8.me2.sub<-subset(df, game=="ME2" | game=="DA2" | game=="DAO")
q8.dehr.sub<-subset(df, game=="DEHR")
q8.esv.sub<-subset(df, game=="ESV")

# add more game data comparisons for the poster
plot1<- plot.probabilities3(q8.mat.u2, q8, q8.u2.sub$q8, title="U2, RDR, ACB", ylim=.75)
plot2 <- plot.probabilities3(q8.mat.me2, q8, q8.me2.sub$q8, title="ME2, DAO, DA2", ylim=.75)
plot3 <- plot.probabilities3(q8.mat.dehr, q8, q8.dehr.sub$q8, title="DEHR", ylim=.75)
plot4 <- plot.probabilities3(q8.mat.esv, q8, q8.esv.sub$q8, title="ESV", ylim=.75)
grid.arrange(plot1, plot2, plot3, plot4, ncol=2)