initial import of material for public archive into git
We're creating a fresh archive because the history for our old chapter includes API keys, data files, and other material we can't share.
This commit is contained in:
221
code/prediction/03-prediction_analysis.R
Normal file
221
code/prediction/03-prediction_analysis.R
Normal file
@@ -0,0 +1,221 @@
|
||||
library(data.table)
|
||||
library(Matrix)
|
||||
library(glmnet)
|
||||
library(xtable)
|
||||
library(methods)
|
||||
|
||||
predict.list <- NULL
|
||||
|
||||
if(!exists("top.ngram.matrix")){
|
||||
load("processed_data/top.ngram.matrix.RData")
|
||||
}
|
||||
|
||||
if(!exists("pred.descrip")){
|
||||
load("paper/data/prediction_descriptives.RData")
|
||||
covars <- pred.descrip$covars
|
||||
}
|
||||
|
||||
top.ngram.matrix <- data.table(top.ngram.matrix)
|
||||
setkey(top.ngram.matrix, eid)
|
||||
covars <- data.table(pred.descrip$covars)
|
||||
setkey(covars,eid)
|
||||
|
||||
# restrict to the overlap of the two datasets
|
||||
covars <- covars[covars$eid %in% top.ngram.matrix$eid,]
|
||||
|
||||
top.ngram.matrix <- top.ngram.matrix[top.ngram.matrix$eid %in%
|
||||
covars$eid,]
|
||||
|
||||
# rename the cited column in case it doesn't appear
|
||||
names(covars)[names(covars) == 'cited'] <- 'cited.x'
|
||||
|
||||
# then merge also to facilitate some manipulations below
|
||||
d <- merge(covars, top.ngram.matrix, by="eid", all=FALSE)
|
||||
|
||||
# Note that this duplicates some column names so X gets appended in a
|
||||
# few cases.
|
||||
|
||||
# construct model matrices
|
||||
x.controls <- sparse.model.matrix(cited.x ~ language.x +
|
||||
modal_country + month.x,
|
||||
data=d)[,-1]
|
||||
|
||||
x.aff <- sparse.model.matrix(cited.x ~ affiliation, data=d)[,-1]
|
||||
x.subj <- sparse.model.matrix(cited.x ~ subject.x, data=d)[,-1]
|
||||
x.venue <- sparse.model.matrix(cited.x ~ source_title, data=d)[,-1]
|
||||
|
||||
x.ngrams <- as.matrix(subset(top.ngram.matrix, select=-eid))
|
||||
x.ngrams <- as(x.ngrams, "sparseMatrix")
|
||||
|
||||
X <- cBind(x.controls, covars$year.x, covars$works.cited)
|
||||
X.aff <- cBind(X, x.aff)
|
||||
X.subj <- cBind(X.aff, x.subj)
|
||||
X.venue <- cBind(X.subj, x.venue)
|
||||
X.terms <- cBind(X.venue, x.ngrams)
|
||||
|
||||
Y <- covars$cited
|
||||
|
||||
### Hold-back sample for testing model performance later on:
|
||||
set.seed(20160719)
|
||||
holdback.index <- sample(nrow(X), round(nrow(X)*.1))
|
||||
|
||||
X.hold <- X[holdback.index,]
|
||||
X.hold.aff <- X.aff[holdback.index,]
|
||||
X.hold.subj <- X.subj[holdback.index,]
|
||||
X.hold.venue <- X.venue[holdback.index,]
|
||||
X.hold.terms <- X.terms[holdback.index,]
|
||||
Y.hold <- Y[holdback.index]
|
||||
|
||||
X.test <- X[-holdback.index,]
|
||||
X.test.aff <- X.aff[-holdback.index,]
|
||||
X.test.subj <- X.subj[-holdback.index,]
|
||||
X.test.venue <- X.venue[-holdback.index,]
|
||||
X.test.terms <- X.terms[-holdback.index,]
|
||||
Y.test <- Y[-holdback.index]
|
||||
|
||||
############### Models and prediction
|
||||
|
||||
set.seed(20160719)
|
||||
|
||||
m.con <- cv.glmnet(X.test, Y.test, alpha=1, family="binomial",
|
||||
type.measure="class")
|
||||
con.pred = predict(m.con, type="class", s="lambda.min",
|
||||
newx=X.hold)
|
||||
|
||||
m.aff <- cv.glmnet(X.test.aff, Y.test, alpha=1, family="binomial",
|
||||
type.measure="class")
|
||||
aff.pred = predict(m.aff, type="class", s="lambda.min",
|
||||
newx=X.hold.aff)
|
||||
|
||||
m.subj <- cv.glmnet(X.test.subj, Y.test, alpha=1, family="binomial",
|
||||
type.measure="class")
|
||||
subj.pred = predict(m.subj, type="class", s="lambda.min",
|
||||
newx=X.hold.subj)
|
||||
|
||||
m.venue <- cv.glmnet(X.test.venue, Y.test, alpha=1, family="binomial",
|
||||
type.measure="class")
|
||||
venue.pred = predict(m.venue, type="class", s="lambda.min",
|
||||
newx=X.hold.venue)
|
||||
|
||||
m.terms <- cv.glmnet(X.test.terms, Y.test, alpha=1, family="binomial",
|
||||
type.measure="class")
|
||||
terms.pred = predict(m.terms, type="class", s="lambda.min",
|
||||
newx=X.hold.terms)
|
||||
|
||||
##########
|
||||
# Compare test set predictions against held-back sample:
|
||||
|
||||
pred.df <- data.frame(cbind(con.pred, aff.pred, subj.pred,
|
||||
venue.pred, terms.pred))
|
||||
names(pred.df) <- c("Controls", "+ Affiliation", "+ Subject", "+ Venue",
|
||||
"+ Terms")
|
||||
|
||||
m.list <- list(m.con, m.aff, m.subj, m.venue, m.terms)
|
||||
|
||||
# collect:
|
||||
# df
|
||||
# percent.deviance
|
||||
# nonzero coefficients
|
||||
# prediction error
|
||||
|
||||
gen.m.summ.info <- function(model){
|
||||
df <- round(tail(model$glmnet.fit$df, 1),0)
|
||||
percent.dev <- round(tail(model$glmnet.fit$dev.ratio, 1),2)*100
|
||||
cv.error <- round(tail(model$cvm,1),2)*100
|
||||
# null.dev <- round(tail(model$glmnet.fit$nulldev),0)
|
||||
out <- c(df, percent.dev, cv.error)
|
||||
return(out)
|
||||
}
|
||||
|
||||
gen.class.err <- function(pred, test){
|
||||
props <- prop.table(table(pred, test))
|
||||
err.sum <- round(sum(props[1,2], props[2,1]),2)*100
|
||||
return(err.sum)
|
||||
}
|
||||
|
||||
|
||||
results.tab <- cbind(names(pred.df),data.frame(matrix(unlist(lapply(m.list,
|
||||
gen.m.summ.info)),
|
||||
byrow=T, nrow=5)))
|
||||
|
||||
results.tab$class.err <- sapply(pred.df, function(x) gen.class.err(x,
|
||||
Y.hold))
|
||||
|
||||
results.tab <- data.frame(lapply(results.tab, as.character))
|
||||
|
||||
|
||||
|
||||
names(results.tab) <- c("Model", "N features", "Deviance (%)",
|
||||
"CV error (%)", "Hold-back error (%)")
|
||||
|
||||
|
||||
print(xtable(results.tab,
|
||||
caption=
|
||||
"Summary of fitted models predicting any citations. The ``Model'' column describes which features were included. The N features column shows the number of features included in the prediction. ``Deviance'' summarizes the goodness of fit as a percentage of the total deviance accounted for by the model. ``CV error'' (cross-validation error) reports the prediction error rates of each model in the cross-validation procedure conducted as part of the parameter estimation process. ``Hold-back error'' shows the prediction error on a random 10 percent subset of the original dataset not included in any of the model estimation procedures.",
|
||||
label='tab:predict_models', align='llrrrr'),
|
||||
include.rownames=FALSE)
|
||||
|
||||
# Store the results:
|
||||
predict.list$results.tab <- results.tab
|
||||
|
||||
|
||||
|
||||
|
||||
############# Generate most salient coefficients
|
||||
nz.coefs <- data.frame( coef =
|
||||
colnames(X.test.terms)[which(
|
||||
coef(m.terms, s="lambda.min")
|
||||
!= 0)],
|
||||
type = "term",
|
||||
beta =
|
||||
coef(m.terms,
|
||||
s="lambda.min")[which(coef(m.terms,
|
||||
s="lambda.min")
|
||||
!= 0)])
|
||||
|
||||
nz.coefs$coef <- as.character(nz.coefs$coef)
|
||||
nz.coefs$type <- as.character(nz.coefs$type)
|
||||
nz.coefs <- nz.coefs[order(-abs(nz.coefs$beta)),]
|
||||
|
||||
# comparison:
|
||||
|
||||
#nz.coefs$type <- "terms"
|
||||
nz.coefs$type[grepl("(Intercept)", nz.coefs$coef)] <- NA
|
||||
nz.coefs$type[grepl("source_title", nz.coefs$coef)] <- "venue"
|
||||
nz.coefs$type[grepl("subject.x", nz.coefs$coef)] <- "subject"
|
||||
nz.coefs$type[grepl("affiliation", nz.coefs$coef)] <- "affiliation"
|
||||
nz.coefs$type[grepl("month.x", nz.coefs$coef)] <- "month"
|
||||
nz.coefs$type[grepl("modal_country", nz.coefs$coef)] <- "country"
|
||||
nz.coefs$type[grepl("language", nz.coefs$coef)] <- "language"
|
||||
nz.coefs$type[grepl("^20[0-9]{2}$", nz.coefs$coef)] <- "year"
|
||||
|
||||
|
||||
# cleanup
|
||||
nz.coefs$coef <- gsub("source_title", "", nz.coefs$coef)
|
||||
nz.coefs$coef <- gsub("subject.x", "", nz.coefs$coef)
|
||||
nz.coefs$coef <- gsub("affiliation","", nz.coefs$coef)
|
||||
nz.coefs$beta <- round(nz.coefs$beta, 3)
|
||||
names(nz.coefs) <- c("Feature", "Type", "Coefficient")
|
||||
|
||||
predict.list$nz.coefs <- nz.coefs
|
||||
|
||||
# table for all
|
||||
round(prop.table(table(nz.coefs$Type))*100, 2)
|
||||
|
||||
# for top subsets
|
||||
round(prop.table(table(nz.coefs$Type[1:700]))*100, 2)
|
||||
round(prop.table(table(nz.coefs$Type[1:200]))*100, 2)
|
||||
round(prop.table(table(nz.coefs$Type[1:100]))*100, 2)
|
||||
|
||||
print(xtable(
|
||||
as.matrix(head(nz.coefs, 10)),
|
||||
label='tab:nzcoefs',
|
||||
caption='Feature, variable type, and beta value for top 100 non-zero coefficients estimated by the best fitting model with all features included.',
|
||||
align='lllr'
|
||||
), include.rownames=FALSE)
|
||||
|
||||
|
||||
# output
|
||||
save(predict.list, file="paper/data/prediction.RData")
|
||||
|
||||
|
||||
Reference in New Issue
Block a user