#
# ooc_montecarlo.r
#
rm(list=ls(all=TRUE))
#
library(MASS)
library(MCMCpack)
library(hitandrun)
library(ooc)
library(statar)
library(Matrix)
library(reshape)
library(ggplot2)
library(viridis)
library(foreach)
library(doParallel)
#
cl <- makeCluster(detectCores() - 1)
registerDoParallel(cl)
#
set.seed(1985)
#
setwd("c:/")
#
#
# Utility functions plot
#
x <- seq(0, 2.0, by=0.01)
linearutility <- 1 - abs(x-0)
normalutility <- exp(-2 * ((x-0)^2))
quadraticutility <- 1 - 2*(x-0)^2
#
#
#pdf("Dropbox/OC_publicopinion/images/montecarlo_utilityfunctions.pdf", height=6, width=6)
#
plot(c(0,2), c(-1,1), type="n", bty="n", cex.lab=1.1, xlab="Distance from Ideal Point", ylab="Utility", main="Linear, Normal, and Quadratic Utility Functions")
lines(x,linearutility, lwd=2, lty=1)
lines(x,normalutility, lwd=2, lty=2)
lines(x,quadraticutility, lwd=2, lty=3)
#
dev.off()
#
#
# DEFINE MONTE CARLO FUNCTION
#
montecarlo.oc <- function(n=1200, q=20, ndim=2, utility.probs=c(0.33,0.33,0.33),
	missing=0.1, error.respondents=c(0.1,1), error.issues=c(2,1)){
#
# %%%%%%%%%%%%%%%%%%%%%%%%%
# %%%%%    BEGIN    %%%%%%%
# %%%%% Monte Carlo %%%%%%%
# %%%%%%%%%%%%%%%%%%%%%%%%%
#
heteroskedastic.respondents <- runif(n, error.respondents[1], error.respondents[2])
heteroskedastic.issues <- rgamma(q, error.issues[1], error.issues[2])
#
correlations <- runif(n, -0.1, 0.7)
knowledge <- xtile(correlations, 3)
#
# 1.) Generate respondent ideal points
#
mu <- rep(0,ndim)
Sigma <- list()
idealpoints <- matrix(NA, nrow=n, ncol=ndim)
for (i in 1:n){
	Sigma[[i]] <- matrix(1, nrow=ndim, ncol=ndim)
	Sigma[[i]][lower.tri(Sigma[[i]])] <- runif(sum(lower.tri(Sigma[[i]])), correlations[i]-0.2, correlations[i]+0.2)
	Sigma[[i]][upper.tri(Sigma[[i]])] <- t(Sigma[[i]])[upper.tri(t(Sigma[[i]]))]
	Sigma[[i]] <- as.matrix(nearPD(Sigma[[i]])$mat)
	idealpoints[i,] <- mvrnorm(1, mu=mu, Sigma=Sigma[[i]])
}
#
idealpoints[idealpoints > 2] <- 2
idealpoints[idealpoints < -2] <- -2
#
# 2.) Generate normal vectors
#
normalvectors <- hypersphere.sample(ndim, q)
#
for (j in 1:q){
if (normalvectors[j,1] < 0) normalvectors[j,] <- -1 * normalvectors[j,]
}
#
# 3.) Project respondents on normal vectors
#
respondent.projections <- idealpoints %*% t(normalvectors)
#
# 4.) Generate outcome locations
#
outcome.locations <- apply(respondent.projections, 2, function(x){sort(runif(5,min(x),max(x)))})
#
# 5.) Define utility functions
#
linear.utility <- function(idealpoint, choices){
    tmp <- 1 - (3*abs(idealpoint - choices))
    return(tmp)}
#
normal.utility <- function(idealpoint, choices){
    tmp <- 5 * exp(-1 * ((idealpoint - choices)^2))
    return(tmp)}
#
quad.utility <- function(idealpoint, choices){
    tmp <- 1 - 2 * (idealpoint - choices)^2
    return(tmp)}
#
# 6.) Calculate utility and response probabilities
#
utility.fun <- sample(c("linear","normal","quadratic"), n, replace=TRUE, prob=utility.probs)
#
systematic.utility <- total.utility <- probmat <- list()
for (j in 1:q){
systematic.utility[[j]] <- matrix(NA, nrow=n, ncol=5)
total.utility[[j]] <- matrix(NA, nrow=n, ncol=5)
probmat[[j]] <- matrix(NA, nrow=n, ncol=5)
}
#
for (i in 1:n){
for (j in 1:q){
#
	if(utility.fun[i]=="linear"){
	systematic.utility[[j]][i,] <- linear.utility(respondent.projections[i,j], outcome.locations[,j])
	}
#
	if(utility.fun[i]=="normal"){
	systematic.utility[[j]][i,] <- normal.utility(respondent.projections[i,j], outcome.locations[,j])
	}
#
	if(utility.fun[i]=="quadratic"){
	systematic.utility[[j]][i,] <- quad.utility(respondent.projections[i,j], outcome.locations[,j])
	}
#
total.utility[[j]][i,] <- systematic.utility[[j]][i,] / exp(heteroskedastic.respondents[i] * heteroskedastic.issues[j])
probmat[[j]][i,] <- pnorm(total.utility[[j]][i,]) / sum(pnorm(total.utility[[j]][i,]))
}}
#
for (j in 1:q){
probmat[[j]][is.na(probmat[[j]])] <- 1
}
#
# 7.) Generate perfect and error (probabilistic) responses
#
simulated.responses <- perfect.responses <- matrix(NA, nrow=n, ncol=q)
#
for (i in 1:n){
for (j in 1:q){
simulated.responses[i,j] <- sample(1:5, 1, prob=probmat[[j]][i,])
# Note: perfect voting could of course also be simulated using the maximum of total.utility
perfect.responses[i,j] <- which.max(systematic.utility[[j]][i,])
}}
#
# 8.) Insert missing data at random
#
if(missing > 0){
miss <- expand.grid(n=1:n, q=1:q)
missing.selected <- as.matrix(miss)[sample(1:nrow(miss), (n*q*missing), replace=FALSE),]
for (i in 1:nrow(missing.selected)){
simulated.responses[missing.selected[i,1], missing.selected[i,2]] <- NA
perfect.responses[missing.selected[i,1], missing.selected[i,2]] <- NA
}
}
#
# 9.) Organize output
#
correctvotes <- sum(diag(table(simulated.responses,perfect.responses)))
totalvotes <- sum(table(simulated.responses,perfect.responses))
#
return(list(simulated.responses = simulated.responses,
	    perfect.responses = perfect.responses,
	    idealpoints = idealpoints,
	    normalvectors = normalvectors,
	    heteroskedastic.respondents = heteroskedastic.respondents,
	    heteroskedastic.issues = heteroskedastic.issues,
	    correlations = correlations,
	    knowledge = knowledge,
	    error = (1 - (correctvotes / totalvotes))
	))
#
}
#
# %%%%%%%%%%%%%%%%%%%%%%%%%
# %%%%%%     END    %%%%%%%
# %%%%% Monte Carlo %%%%%%%
# %%%%%%%%%%%%%%%%%%%%%%%%%
#
#
#
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# @@@@@@@@@@@@@  RUN ORDERED  @@@@@@@@@@@@@
# @@@@@@@@  OPTIMAL CLASSIFICATION  @@@@@@@
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#
#
# utility.probs = c(linear, normal, quadratic)
# error.respondents = normal(mu, sigma)
# error.issues = gamma(shape, rate)
#
# Simulations randomize:
#
#		1.) Respondent utility functions
#		2.) Missingness
#		3.) Error rate
#
#
ntrials <- 400
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# Basic setup:
#sim <- montecarlo.oc(n=1500, q=40, ndim=2, utility.probs=runif(3,0,1), missing=0.1, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
#res <- ooc(sim$perfect.responses, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
#
#
#
# I. VARY AMOUNT OF MISSING DATA
#
fit.2dim.missing10 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=2, utility.probs=runif(3,0,1), missing=0.1, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.missing10, file="Dropbox/OC_publicopinion/analysis/fit.2dim.missing10.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
fit.2dim.missing25 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=2, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.missing25, file="Dropbox/OC_publicopinion/analysis/fit.2dim.missing25.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
fit.2dim.missing40 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=2, utility.probs=runif(3,0,1), missing=0.4, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.missing40, file="Dropbox/OC_publicopinion/analysis/fit.2dim.missing40.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
fit.3dim.missing10 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=3, utility.probs=runif(3,0,1), missing=0.1, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,3), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- 1
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.missing10, file="Dropbox/OC_publicopinion/analysis/fit.3dim.missing10.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
fit.3dim.missing25 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=3, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,3), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- 1
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.missing25, file="Dropbox/OC_publicopinion/analysis/fit.3dim.missing25.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
fit.3dim.missing40 <- foreach(i=101:(100+ntrials), .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=3, utility.probs=runif(3,0,1), missing=0.4, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,3), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- 1
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.missing40, file="Dropbox/OC_publicopinion/analysis/fit.3dim.missing40.rda")
#
# !!!!!!!!!!!!!!!!!!!!!!!!!
#
#
#
#
# II. INFORMAL TEST OF CONSISTENCY:
#    VARY NUMBER OF ISSUES (25, 50, 100)
#
fit.2dim.issues25 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=25, ndim=2, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.issues25, file="Dropbox/OC_publicopinion/analysis/fit.2dim.issues25.rda")
#
#
fit.2dim.issues50 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=50, ndim=2, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.issues50, file="Dropbox/OC_publicopinion/analysis/fit.2dim.issues50.rda")
#
#
fit.2dim.issues100 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=100, ndim=2, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.2dim.issues100, file="Dropbox/OC_publicopinion/analysis/fit.2dim.issues100.rda")
#
#
fit.3dim.issues25 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=25, ndim=3, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.issues25, file="Dropbox/OC_publicopinion/analysis/fit.3dim.issues25.rda")
#
#
fit.3dim.issues50 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=50, ndim=3, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.issues50, file="Dropbox/OC_publicopinion/analysis/fit.3dim.issues50.rda")
#
#
fit.3dim.issues100 <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=100, ndim=3, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=3, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
normvecs <- res$issues.unique[,grepl("normVector", colnames(res$issues.unique)) & colnames(res$issues.unique)!="normVectorAngle2D"]
#
# Perform Procrustes rotation
rotation <- procrustes(x, sim$idealpoints)$R
rotated.idealpoints <- x %*% rotation
rotated.normalvectors <- normvecs %*% rotation
rotated.normalvectors[(rotated.normalvectors[,1] < 0),] <- -1 * rotated.normalvectors[(rotated.normalvectors[,1] < 0),]
#
truetheta <- apply(sim$normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
truetheta[sim$normalvectors[,2] < 0] <- -1 * truetheta[sim$normalvectors[,2] < 0]
#
theta <- apply(rotated.normalvectors, 1, function(x){ acos_d(sum(x * c(1,0))/(sqrt(sum(x * x)) * sqrt(sum(c(1,0) * c(1,0)))))})
theta[rotated.normalvectors[,2] < 0] <- -1 * theta[rotated.normalvectors[,2] < 0]
#
respondents.correct <- res$respondents[,"percent.correctScale"]
issues.PRE <- res$issues.unique[,"PREScale"]
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
cornormvec <- cor(as.vector(dist(rotated.normalvectors)), as.vector(dist(sim$normalvectors)))
cortheta <- cor(truetheta, theta)
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corconstraintresp <- cor(sim$correlations, respondents.correct)
corhetissues <- cor(sim$heteroskedastic.issues, issues.PRE)
#
error <- sim$error
c(corx, cornormvec, cortheta, corhetresp, corconstraintresp, corhetissues, error)
}
#
save(fit.3dim.issues100, file="Dropbox/OC_publicopinion/analysis/fit.3dim.issues100.rda")
#
#
#
#
# III. COMPARE FITS OF MODERATES AND EXTREMISTS
#
fit.2dim.moderatesextremists <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=2, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
respondents.correct <- res$respondents[,"percent.correctScale"]
#
moderate.1dim <- rotated.idealpoints[,1] > quantile(sim$idealpoints[,1])["25%"] &
rotated.idealpoints[,1] < quantile(sim$idealpoints[,1])["75%"]
moderate.2dim <- rotated.idealpoints[,2] > quantile(sim$idealpoints[,2])["25%"] &
rotated.idealpoints[,2] < quantile(rotated.idealpoints[,2])["75%"]
moderate <- moderate.1dim & moderate.2dim
#
extreme.1dim <- rotated.idealpoints[,1] < quantile(sim$idealpoints[,1])["25%"] |
rotated.idealpoints[,1] > quantile(sim$idealpoints[,1])["75%"]
extreme.2dim <- rotated.idealpoints[,2] < quantile(sim$idealpoints[,2])["25%"] |
rotated.idealpoints[,2] > quantile(sim$idealpoints[,2])["75%"]
extreme <- extreme.1dim & extreme.2dim
#
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
corx.moderate <- cor(as.vector(dist(x[moderate,])), as.vector(dist(sim$idealpoints[moderate,])))
corx.extreme <- cor(as.vector(dist(x[extreme,])), as.vector(dist(sim$idealpoints[extreme,])))
#
#
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corhetresp.moderate <- cor(sim$heteroskedastic.respondents[moderate], respondents.correct[moderate])
corhetresp.extreme <- cor(sim$heteroskedastic.respondents[extreme], respondents.correct[extreme])
#
corconstraintresp <- cor(sim$correlations, respondents.correct)
corconstraintresp.moderate <- cor(sim$correlations[moderate], respondents.correct[moderate])
corconstraintresp.extreme <- cor(sim$correlations[extreme], respondents.correct[extreme])
#
error <- sim$error
c(corx, corx.moderate, corx.extreme, corhetresp, corhetresp.moderate, corhetresp.extreme, corconstraintresp, corconstraintresp.moderate, corconstraintresp.extreme)
}
#
save(fit.2dim.moderatesextremists, file="Dropbox/OC_publicopinion/analysis/fit.2dim.moderatesextremists.rda")
#
#
fit.3dim.moderatesextremists <- foreach(i=1:ntrials, .combine='rbind', .packages=c("ooc", "statar", "Matrix")) %dopar% {
set.seed(i)
sim <- montecarlo.oc(n=1500, q=40, ndim=3, utility.probs=runif(3,0,1), missing=0.25, error.respondents=sort(runif(2,0,0.5)), error.issues=c(runif(1,0,3), 0.5))
issuescales <- sim$simulated.responses
res <- ooc(issuescales, dims=2, min=10, lop=0.0001, polarity=rep(1,2), iter=25, nv.method="svm.reg", cost=1)
x <- res$respondents[,grepl("coord", colnames(res$respondents))]
respondents.correct <- res$respondents[,"percent.correctScale"]
#
moderate.1dim <- rotated.idealpoints[,1] > quantile(sim$idealpoints[,1])["25%"] &
rotated.idealpoints[,1] < quantile(sim$idealpoints[,1])["75%"]
moderate.2dim <- rotated.idealpoints[,2] > quantile(sim$idealpoints[,2])["25%"] &
rotated.idealpoints[,2] < quantile(rotated.idealpoints[,2])["75%"]
moderate.3dim <- rotated.idealpoints[,3] > quantile(sim$idealpoints[,3])["25%"] &
rotated.idealpoints[,3] < quantile(rotated.idealpoints[,3])["75%"]
moderate <- moderate.1dim & moderate.2dim & moderate.3dim
#
extreme.1dim <- rotated.idealpoints[,1] < quantile(sim$idealpoints[,1])["25%"] |
rotated.idealpoints[,1] > quantile(sim$idealpoints[,1])["75%"]
extreme.2dim <- rotated.idealpoints[,2] < quantile(sim$idealpoints[,2])["25%"] |
rotated.idealpoints[,2] > quantile(sim$idealpoints[,2])["75%"]
extreme.3dim <- rotated.idealpoints[,3] < quantile(sim$idealpoints[,3])["25%"] |
rotated.idealpoints[,3] > quantile(sim$idealpoints[,3])["75%"]
extreme <- extreme.1dim & extreme.2dim & extreme.3dim
#
#
corx <- cor(as.vector(dist(x)), as.vector(dist(sim$idealpoints)))
corx.moderate <- cor(as.vector(dist(x[moderate,])), as.vector(dist(sim$idealpoints[moderate,])))
corx.extreme <- cor(as.vector(dist(x[extreme,])), as.vector(dist(sim$idealpoints[extreme,])))
#
#
corhetresp <- cor(sim$heteroskedastic.respondents, respondents.correct)
corhetresp.moderate <- cor(sim$heteroskedastic.respondents[moderate], respondents.correct[moderate])
corhetresp.extreme <- cor(sim$heteroskedastic.respondents[extreme], respondents.correct[extreme])
#
corconstraintresp <- cor(sim$correlations, respondents.correct)
corconstraintresp.moderate <- cor(sim$correlations[moderate], respondents.correct[moderate])
corconstraintresp.extreme <- cor(sim$correlations[extreme], respondents.correct[extreme])
#
error <- sim$error
c(corx, corx.moderate, corx.extreme, corhetresp, corhetresp.moderate, corhetresp.extreme, corconstraintresp, corconstraintresp.moderate, corconstraintresp.extreme)
}
#
save(fit.3dim.moderatesextremists, file="Dropbox/OC_publicopinion/analysis/fit.3dim.moderatesextremists.rda")
#
#
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#
stopCluster(cl)
#
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#
#
# $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
# $$$$$$$$$$  PLOTS  $$$$$$$$$$$$$$$$
# $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
#
load("Dropbox/OC_publicopinion/analysis/fit.2dim.missing10.rda")
load("Dropbox/OC_publicopinion/analysis/fit.2dim.missing25.rda")
load("Dropbox/OC_publicopinion/analysis/fit.2dim.missing40.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.missing10.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.missing25.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.missing40.rda")
#
load("Dropbox/OC_publicopinion/analysis/fit.2dim.issues25.rda")
load("Dropbox/OC_publicopinion/analysis/fit.2dim.issues50.rda")
load("Dropbox/OC_publicopinion/analysis/fit.2dim.issues100.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.issues25.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.issues50.rda")
load("Dropbox/OC_publicopinion/analysis/fit.3dim.issues100.rda")
#
load("Dropbox/OC_publicopinion/analysis/fit.2dim.moderatesextremists.rda")
load("Dropbox/OC_publicopinion/analysis/fit.2dim.moderatesextremists.rda")
#
#
#
# 10%
fit <- fit.2dim.missing10
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "10% Missing"
twodim.df10 <- twodim.df
#
# 25%
fit <- fit.2dim.missing25
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "25% Missing"
twodim.df25 <- twodim.df
#
# 40%
fit <- fit.2dim.missing40
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "40% Missing"
twodim.df40 <- twodim.df
#
#
#
twodim.df <- rbind(twodim.df10, twodim.df25, twodim.df40)
#
# Create line breaks
swr = function(string, nwrap=20) {
  paste(strwrap(string, width=nwrap), collapse="\n")
}
swr <- Vectorize(swr)
twodim.df$variable <- swr(twodim.df$variable)
#
twodim.df$variable <- factor(twodim.df$variable, levels=c("True and recovered\nideal points", "True and recovered\nissue normal\nvectors", "Reversed issue\nerror variance and\nrecovered issue PRE"))
#
pdf("Dropbox/OC_publicopinion/images/ooc_montecarlo_twodim.pdf", height=9, width=8)
#
ggplot(twodim.df, aes(errorlevel, value, fill=errorlevel)) +
	facet_wrap(~Missing+variable) +
	geom_boxplot() +
	xlab("") +
	ylab("Correlation\n") +
	scale_fill_viridis(discrete=TRUE, begin=0.8, end=0.2) +
	ylim(0,1) +
	guides(fill=FALSE) +
	ggtitle("Two Dimensions\n") +
	theme(plot.title = element_text(hjust = 0.5))
#
dev.off()
#
# 3-dimensional graph
#
# 10%
fit <- fit.3dim.missing10
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "10% Missing"
threedim.df10 <- threedim.df
#
# 25%
fit <- fit.3dim.missing25
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "25% Missing"
threedim.df25 <- threedim.df
#
# 40%
fit <- fit.3dim.missing40
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "40% Missing"
threedim.df40 <- threedim.df
#
#
#
threedim.df <- rbind(threedim.df10, threedim.df25, threedim.df40)
#
# Create line breaks
swr = function(string, nwrap=20) {
  paste(strwrap(string, width=nwrap), collapse="\n")
}
swr <- Vectorize(swr)
threedim.df$variable <- swr(threedim.df$variable)
#
threedim.df$variable <- factor(threedim.df$variable, levels=c("True and recovered\nideal points", "True and recovered\nissue normal\nvectors", "Reversed issue\nerror variance and\nrecovered issue PRE"))
#
pdf("Dropbox/OC_publicopinion/images/ooc_montecarlo_threedim.pdf", height=9, width=8)
#
ggplot(threedim.df, aes(errorlevel, value, fill=errorlevel)) +
	facet_wrap(~Missing+variable) +
	geom_boxplot() +
	xlab("") +
	ylab("Correlation\n") +
	scale_fill_viridis(discrete=TRUE, begin=0.8, end=0.2) +
	ylim(0,1) +
	theme(plot.title = element_text(hjust = 0.5)) +
	guides(fill=FALSE) +
	ggtitle("Three Dimensions\n") +
	theme(plot.title = element_text(hjust = 0.5))
#
dev.off()
#
#table(fit[,"errorlevel"], fit.twodim$errorlevel)
#
#
#
#
# 25 issues
fit <- fit.2dim.issues25
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "25 Issues"
twodim.df25 <- twodim.df
#
# 50 issues
fit <- fit.2dim.issues50
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "50 Issues"
twodim.df50 <- twodim.df
#
# 100 issues
fit <- fit.2dim.issues100
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.twodim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.twodim$errorlevel <- factor(xtile(fit.twodim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.twodim$cor.errorissues <- abs(fit.twodim$cor.errorissues)
#
names(fit.twodim)[names(fit.twodim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.twodim)[names(fit.twodim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.twodim)[names(fit.twodim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
twodim.df <- melt(fit.twodim, id=c("errorlevel"))
#
#ggplot(twodim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
twodim.df$Missing <- "100 Issues"
twodim.df100 <- twodim.df
#
#
#
twodim.df <- rbind(twodim.df25, twodim.df50, twodim.df100)
#
# Create line breaks
swr = function(string, nwrap=20) {
  paste(strwrap(string, width=nwrap), collapse="\n")
}
swr <- Vectorize(swr)
twodim.df$variable <- swr(twodim.df$variable)
#
twodim.df$variable <- factor(twodim.df$variable, levels=c("True and recovered\nideal points", "True and recovered\nissue normal\nvectors", "Reversed issue\nerror variance and\nrecovered issue PRE"))
#
pdf("Dropbox/OC_publicopinion/images/ooc_montecarlo_twodim_numberissues.pdf", height=9, width=8)
#
ggplot(twodim.df, aes(errorlevel, value, fill=errorlevel)) +
	facet_wrap(~Missing+variable) +
	geom_boxplot() +
	xlab("") +
	ylab("Correlation\n") +
	scale_fill_viridis(discrete=TRUE, begin=0.8, end=0.2) +
	ylim(0,1) +
	guides(fill=FALSE) +
	ggtitle("Two Dimensions\n") +
	theme(plot.title = element_text(hjust = 0.5))
#
dev.off()
#
# 3-dimensional graph
#
# 25 issues
fit <- fit.3dim.issues25
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "25 Issues"
threedim.df25 <- threedim.df
#
# 50 issues
fit <- fit.3dim.issues50
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "50 Issues"
threedim.df50 <- threedim.df
#
# 100 issues
fit <- fit.3dim.issues100
colnames(fit) <- c("cor.idealpoints", "cor.normvecs", "cor.theta", "cor.errorrespondents", "cor.constraintrespondents", "cor.errorissues", "errorlevel")
fit.threedim <- data.frame(fit[,c("cor.idealpoints","cor.normvecs","cor.errorissues","errorlevel")])
#
fit.threedim$errorlevel <- factor(xtile(fit.threedim$errorlevel, 3), labels=c("Low error", "Medium error", "High error"))
fit.threedim$cor.errorissues <- abs(fit.threedim$cor.errorissues)
#
names(fit.threedim)[names(fit.threedim)=="cor.idealpoints"] <- "True and recovered ideal points"
names(fit.threedim)[names(fit.threedim)=="cor.normvecs"] <- "True and recovered issue normal vectors"
names(fit.threedim)[names(fit.threedim)=="cor.errorissues"] <- "Reversed issue error variance and recovered issue PRE"
#
threedim.df <- melt(fit.threedim, id=c("errorlevel"))
#
#ggplot(threedim.df, aes(errorlevel, value)) + facet_wrap(~variable) + geom_boxplot()
#
threedim.df$Missing <- "100 Issues"
threedim.df100 <- threedim.df
#
#
#
threedim.df <- rbind(threedim.df25, threedim.df50, threedim.df100)
#
# Create line breaks
swr = function(string, nwrap=20) {
  paste(strwrap(string, width=nwrap), collapse="\n")
}
swr <- Vectorize(swr)
threedim.df$variable <- swr(threedim.df$variable)
#
threedim.df$variable <- factor(threedim.df$variable, levels=c("True and recovered\nideal points", "True and recovered\nissue normal\nvectors", "Reversed issue\nerror variance and\nrecovered issue PRE"))
#
pdf("Dropbox/OC_publicopinion/images/ooc_montecarlo_threedim_numberissues.pdf", height=9, width=8)
#
ggplot(threedim.df, aes(errorlevel, value, fill=errorlevel)) +
	facet_wrap(~Missing+variable) +
	geom_boxplot() +
	xlab("") +
	ylab("Correlation\n") +
	scale_fill_viridis(discrete=TRUE, begin=0.8, end=0.2) +
	ylim(0,1) +
	theme(plot.title = element_text(hjust = 0.5)) +
	guides(fill=FALSE) +
	ggtitle("Three Dimensions\n") +
	theme(plot.title = element_text(hjust = 0.5))
#
dev.off()
#
#table(fit[,"errorlevel"], fit.twodim$errorlevel)
#
#


### Draws a figure illustrating change detection in the distribution of synthetic data.
### Each dot represents a single time period with 1000 samples. Before the change,
### the data is sampled from a unit normal distribution. After the change, 20 samples
### in each time period are taken from N(3,1). Comparing counts with a chi^2 test that
### is robust to small expected counts robustly detects this shift.

### log-likelihood ratio test for multinomial data
llr = function(k) {
    2 * sum(k) * (H(k) - H(rowSums(k)) - H(colSums(k)))
}
H = function(k) {
    N = sum(k) ;
    return (sum(k/N * log(k/N + (k==0))))
}

### compare recent samples to historical by comparing counts in a range of interest
analyze = function(historical, recent, cuts) {
    counts = data.frame(
        a=hist(recent, breaks=cuts, plot=F)$counts,
        b=hist(historical, breaks=cuts, plot=F)$counts)
    llr(counts)
}

### use fixed seed for stability of the pictures
set.seed(3)
### lots of reference data
historical = rnorm(100000)

### set cuts based on historical data
### in practical systems, this step would be implemented with a t-digest
cuts = c(-10, quantile(historical, probs=c(0.99, 0.999)), 20)

### 1000 samples per time period, 2% perturbation after change
n = 1000
epsilon = 0.02

### sample 60 scores without perturbation
scores = rep(0,100)
for (i in 1:60) {
    scores[i] = analyze(historical, c(rnorm(n)), cuts)
}

### sample 40 scores with perturbation
for (i in 1:40) {
    scores[i + 60] = analyze(historical, c(rnorm(n * (1-epsilon)), rnorm(n * epsilon, 3)), cuts)
}

### plot the data
pdf("change-point.pdf", width=5, height=4, pointsize=10)
old = par('mgp')
par(mgp=c(3,0.6,0))
colors = c(rep(rgb(0,0,0,alpha=0.8),60), rep(rgb(1,0,0,alpha=0.8),40))
plot(scores, xaxt='n', xlab=NA, ylab=NA, ylim=c(0,60), cex=1.3, pch=21, bg=colors, col=NA)
abline(v=60.5, lwd=3, col=rgb(0,0,0, alpha=0.1))

polygon(c(-1,55,55,-1,-1), c(60, 60,36,36,60), col='white')
points(c(1.5, 1.5), c(55, 45), pch=21, bg=c('black', 'red'), col=NA)
text(5, c(55,45), adj=0, labels=c(
    expression(x %~% symbol(N)(mu == 0)),
    expression(x %~% bgroup("[", atop(symbol(N)(mu==0) , symbol(N)(mu==3)),""))))
text(30, c(55,48,41.5), c("1000 samples", "980 samples", "20 samples"), adj=0)

mtext(expression(llr(counts)), side=2, padj=-1.3, cex=1.4)
mtext("Before change", at=25, side=1, padj=1, cex=1.5)
mtext("After change", at=75, side=1, padj=1, cex=1.5)
par(mgp=old)
dev.off()


#Exercise for Lecture 1 FISH554: exploring data from the FAO database
#the trophic level, species, maximum length, habitat, mean catch
#for each of the species, based on data used in
#Branch TA et al. (2010) The trophic fingerprint of marine fisheries.
#Nature 468:431-435

#reading in data
library(tidyverse)
FAOdata1 <- read_csv(file="FAO catch.csv")
FAOdata1

#using ggplot to make explorations of the data
#relation between Lmax and Trophic level
ggplot(data=FAOdata1) +
  aes(x=Lmax, y=TrophicLevel) +
  geom_point()

ggplot(data=FAOdata1) +
  aes(x=Lmax, y=TrophicLevel) +
  geom_point() +
  scale_x_log10()

ggplot(data=FAOdata1) +
  aes(x=Lmax, y=TrophicLevel) +
  geom_point() +
  scale_x_log10() +
  aes(size=MeanCatch) +
  scale_size_area()

roundedFAO <- FAOdata1
roundedFAO$TrophicLevel <- round(roundedFAO$TrophicLevel,1)
ggplot(data=roundedFAO) +
  aes(x=Lmax, y=TrophicLevel) +
  geom_point() +
  scale_x_log10() +
  aes(size=MeanCatch) +
  scale_size_area()

#boxplots
ggplot(data=roundedFAO) +
  aes(x=TrophicLevel, y=Lmax) +
  geom_boxplot() + aes(group=TrophicLevel)

#trophic level vs maximum length
ggplot(data=roundedFAO) +
  aes(x=TrophicLevel, y=Lmax) +
  geom_boxplot() + aes(group=TrophicLevel) +
  scale_y_log10()

#trophic level vs average catch
ggplot(data=roundedFAO) +
  aes(x=TrophicLevel, y=MeanCatch) +
  geom_boxplot() + aes(group=TrophicLevel) +
  scale_y_log10()


# R script to calculate P values using binomial test

##########################################################
## Functions

#This function calculates the p value for each window.
#The probability is the % of RE sites in the chromosome covered with reads and for each window a p value is assigned using the binom.test function.
pValCal<-function (windows_data,windows_data_full)
{
	pVal<-c()
	chromosomes <- unique(windows_data[,1])
	for (i in 1:length(chromosomes))
	{
		tmp.data<-windows_data[windows_data[,1]==i,]
		tmp.data_full<-windows_data_full[windows_data_full[,1]==i,]
		prob<-sum(tmp.data[,4])/sum(tmp.data_full[,4])
		tmp<-mapply(binom.test, x=as.vector(tmp.data[,4]), n=as.vector(tmp.data_full[,4]), p=prob, alternative="greater")
		pVal<-c(pVal,as.numeric(tmp[3,]))
	}
	#We save both the p-values and the p-scores which are -log10 of the p-values.
	pVal2<- -log10(pVal);pVal2[pVal2 == Inf]<-max(pVal2[pVal2!=Inf])
	list(pVal,pVal2)
}

#################################################################

## Constants
WIND<- N/2 # Half of the size of the window (N) used for the analysis.
data_full<-read.delim("RE_sites_genome_N_windows_with_RE", header=FALSE) #RE windows with the number of total RE per window.

## Calcualte per sample
data_bait<-read.delim("RE_sites_genome_N_windows_with_Sample_RE", header=FALSE) #RE windows with the number of valid RE from the sample per window.

#Calcualte p-values
pValues<-pValCal(data_bait,data_full)
#Save the windows with their p scores for genome browser and other analyses.
Sample_N_pScore<-cbind(data_bait[,1:3],pValues[[2]])
#Each window is represented by the RE site it is spanning
Sample_N_pScore[,3]<-Sample_N_pScore[,3]-WIND
Sample_N_pScore[,2]<-Sample_N_pScore[,3]-4
#save the file
write.table(Sample_N_pScore,"Sample_N_pScore.bedgraph",quote=F,row.names=F,col.names=F,append=F, sep="\t")


twenty.four <- function(operators=c("+", "-", "*", "/", "("),
                        selector=function() sample(1:9, 4, replace=TRUE),
                        arguments=selector(),
                        goal=24) {
  newdigits <- function() {
    arguments <<- selector()
    cat("New digits:", paste(arguments, collapse=", "), "\n")
  }
  help <- function() cat("Make", goal,
      "out of the numbers",paste(arguments, collapse=", "),
      "and the operators",paste(operators, collapse=", "), ".",
      "\nEnter 'q' to quit, '!' to select new digits,",
      "or '?' to repeat this message.\n")
  help()
  repeat {
    switch(input <- readline(prompt="> "),
           q={ cat("Goodbye!\n"); break },
           `?`=help(),
           `!`=newdigits(),
           tryCatch({
             expr <- parse(text=input, n=1)[[1]]
             check.call(expr, operators, arguments)
             result <- eval(expr)
             if (isTRUE(all.equal(result, goal))) {
               cat("Correct!\n")
               newdigits()
             } else {
               cat("Evaluated to", result, "( goal", goal, ")\n")
             }
           },error=function(e) cat(e$message, "\n")))
  }
}

check.call <- function(expr, operators, arguments) {
  unexpr <- function(x) {
    if (is.call(x))
      unexpr(as.list(x))
    else if (is.list(x))
      lapply(x,unexpr)
    else x
  }
  leaves <- unlist(unexpr(expr))
  if (any(disallowed <-
          !leaves %in% c(lapply(operators, as.name),
                         as.list(arguments)))) {
    stop("'", paste(sapply(leaves[disallowed], as.character),
                    collapse=", "),
         "' not allowed. ")
  }
  numbers.used <- unlist(leaves[sapply(leaves, mode) == 'numeric'])

  if (! isTRUE(all.equal(sort(numbers.used), sort(arguments))))
   stop("Must use each number once.")
}


#本文需要用到的 R 包
library(vegan)	#用于计算 Shannon 熵指数、Simpson 指数、Chao1 指数、ACE 指数等，同时用于抽样
library(picante)	#用于计算 PD_whole_tree，若不计算它就无需加载。事实上，picante 包加载时默认同时加载 vegan
library(ggplot2)	#用于 ggplot2 作图
library(doBy)	#用于分组统计（第 97 行使用到）
library(ggalt)	#用于绘制拟合曲线（第 138 行使用到）
library(BiodiversityR)	#用于绘制 Rank-abundance 曲线（第 160 行使用到）

##定义函数
#计算多种 Alpha 多样性指数，结果返回至向量
#各子函数的用法详见 http://blog.sciencenet.cn/blog-3406804-1179983.html
alpha_index <- function(x, method = 'richness', tree = NULL, base = exp(1)) {
    if (method == 'richness') result <- rowSums(x > 0)	#丰富度指数
    else if (method == 'chao1') result <- estimateR(x)[3, ]	#Chao1 指数
    else if (method == 'ace') result <- estimateR(x)[5, ]	#ACE 指数
    else if (method == 'shannon') result <- diversity(x, index = 'shannon', base = base)	#Shannon 指数
    else if (method == 'simpson') result <- diversity(x, index = 'simpson')	#Gini-Simpson 指数
    else if (method == 'pielou') result <- diversity(x, index = 'shannon', base = base) / log(estimateR(x)[1, ], base)	#Pielou 均匀度
    else if (method == 'gc') result <- 1 - rowSums(x == 1) / rowSums(x)	#goods_coverage
    else if (method == 'pd' & !is.null(tree)) {	#PD_whole_tree
        pd <- pd(x, tree, include.root = FALSE)
        result <- pd[ ,1]
        names(result) <- rownames(pd)
    }
    result
}

#根据抽样步长（step），统计每个稀释梯度下的 Alpha 多样性指数，结果返回至列表
alpha_curves <- function(x, step, method = 'richness', rare = NULL, tree = NULL, base = exp(1)) {
    x_nrow <- nrow(x)
    if (is.null(rare)) rare <- rowSums(x) else rare <- rep(rare, x_nrow)
    alpha_rare <- list()

    for (i in 1:x_nrow) {
        step_num <- seq(0, rare[i], step)
        if (max(step_num) < rare[i]) step_num <- c(step_num, rare[i])

        alpha_rare_i <- NULL
        for (step_num_n in step_num) alpha_rare_i <- c(alpha_rare_i, alpha_index(x = rrarefy(x[i, ], step_num_n), method = method, tree = tree, base = base))
        names(alpha_rare_i) <- step_num
        alpha_rare <- c(alpha_rare, list(alpha_rare_i))
    }

    names(alpha_rare) <- rownames(x)
    alpha_rare
}

##测试
#统计 OTU 丰度表中各样本的 Shannon 指数，对数底数使用 e
# shannon_index <- alpha_index(otu, method = 'shannon', base = exp(1))
#以 1000 条序列为抽样步长，依次对 OTU 表稀释抽样，直到最大序列深度；并统计各抽样梯度下的 OTU 丰度表中各样本的 Shannon 指数，对数底数使用 e
# shannon_curves <- alpha_curves(otu, step = 1000, method = 'shannon', base = exp(1))

##以下以物种丰富度指数为例绘制 Alpha 多样性曲线（当为丰富度指数时，另一个名称即为常说的稀释曲线，或物种累计曲线）
#读取 OTU 丰度表
if(1) {
    setwd('~/Documents/R/Numerical_Ecology/Hong/')
    otu <- read.delim('Tomato.txt', row.names = 1, sep = '\t', stringsAsFactors = FALSE, check.names = FALSE)
    otu <- t(otu)
}

#以 2000 步长（step=2000）为例统计
richness_curves <- alpha_curves(otu, step = 2000, method = 'richness')

#获得 ggplot2 作图文件
plot_richness <- data.frame()
for (i in names(richness_curves)) {
    richness_curves_i <- (richness_curves[[i]])
    richness_curves_i <- data.frame(rare = names(richness_curves_i), alpha = richness_curves_i, sample = i, stringsAsFactors = FALSE)
    plot_richness <- rbind(plot_richness, richness_curves_i)
}

rownames(plot_richness) <- NULL
plot_richness$rare <- as.numeric(plot_richness$rare)
plot_richness$alpha <- as.numeric(plot_richness$alpha)

#ggplot2 作图
ggplot(plot_richness, aes(rare, alpha, color = sample)) +
    geom_line() +
    labs(x = 'Number of sequences', y = 'Richness', color = NULL) +
    theme(panel.grid = element_blank(), panel.background = element_rect(fill = 'transparent', color = 'black'), legend.key = element_rect(fill = 'transparent')) +
    geom_vline(xintercept = min(rowSums(otu)), linetype = 2) +
    scale_x_continuous(breaks = seq(0, 30000, 5000), labels = as.character(seq(0, 30000, 5000)))

##多计算几次以获取均值 ± 标准差，然后再展示出也是一个不错的选择
#重复抽样 5 次
plot_richness <- data.frame()

for (n in 1:5) {
    richness_curves <- alpha_curves(otu, step = 2000, method = 'richness')

    for (i in names(richness_curves)) {
        richness_curves_i <- (richness_curves[[i]])
        richness_curves_i <- data.frame(rare = names(richness_curves_i), alpha = richness_curves_i, sample = i, stringsAsFactors = FALSE)
        plot_richness <- rbind(plot_richness, richness_curves_i)
    }
}

#计算均值 ± 标准差（doBy 包中的 summaryBy() 函数）
plot_richness_stat <- summaryBy(alpha~sample+rare, plot_richness, FUN = c(mean, sd))
plot_richness_stat$rare <- as.numeric(plot_richness_stat$rare)
plot_richness_stat[which(plot_richness_stat$rare == 0),'alpha.sd'] <- NA

#ggplot2 作图
ggplot(plot_richness_stat, aes(rare, alpha.mean, color = sample)) +
    geom_line() +
    geom_point() +
    geom_errorbar(aes(ymin = alpha.mean - alpha.sd, ymax = alpha.mean + alpha.sd), width = 500) +
    labs(x = 'Number of sequences', y = 'Richness', color = NULL) +
    theme(panel.grid = element_blank(), panel.background = element_rect(fill = 'transparent', color = 'black'), legend.key = element_rect(fill = 'transparent')) +
    geom_vline(xintercept = min(rowSums(otu)), linetype = 2) +
    scale_x_continuous(breaks = seq(0, 30000, 5000), labels = as.character(seq(0, 30000, 5000)))

##对于 Shannon 指数等，方法类似
#以 2000 步长（step=2000）为例统计每个稀释梯度下的 Shannon 指数，Shannon 公式的对数底数默认为 e，若有需要可更改（例如 2）
shannon_curves <- alpha_curves(otu, step = 2000, method = 'shannon', base = 2)

#获得 ggplot2 作图文件（略，参见上述）
#ggplot2 作图（略，参见上述）

##若简单的“geom_line()”样式波动幅度过大，不平滑等，可以尝试拟合曲线的样式
#获得作图数据。前面多生成一个点，使得 Shannon 拟合曲线更加平滑（你把 shannon_curves1 注释掉就知道我说的啥了）
shannon_curves1 <- alpha_curves(otu, step = 200, rare = 200, method = 'shannon')
shannon_curves2 <- alpha_curves(otu, step = 2000, method = 'shannon')
shannon_curves <- c(shannon_curves1, shannon_curves2)

plot_shannon <- data.frame()
for (i in 1:length(shannon_curves)) {
    shannon_curves_i <- shannon_curves[[i]]
    shannon_curves_i <- data.frame(rare = names(shannon_curves_i), alpha = shannon_curves_i, sample = names(shannon_curves)[i], stringsAsFactors = FALSE)
    plot_shannon <- rbind(plot_shannon, shannon_curves_i)
}

rownames(plot_shannon) <- NULL
plot_shannon$rare <- as.numeric(plot_shannon$rare)
plot_shannon$alpha <- as.numeric(plot_shannon$alpha)
plot_shannon <- plot_shannon[order(plot_shannon$sample, plot_shannon$rare), ]

#ggplot2 作图（使用到 ggalt 包的 geom_xspline() 绘制平滑拟合线）
ggplot(plot_shannon, aes(rare, alpha, color = sample)) +
    geom_xspline() +
    labs(x = 'Number of sequences', y = 'Shannon', color = NULL) +
    theme(panel.grid = element_blank(), panel.background = element_rect(fill = 'transparent', color = 'black'), legend.key = element_rect(fill = 'transparent')) +
    geom_vline(xintercept = min(rowSums(otu)), linetype = 2) +
    scale_x_continuous(breaks = seq(0, 30000, 5000), labels = as.character(seq(0, 30000, 5000)))

# Above -------------------------------------------------------------------
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#
# ##对于 PD_whole_tree，除了 OTU 丰度表，还使用到进化树文件
# #加载 OTU 丰度表和进化树文件
# otu <- read.delim('otu_table.txt', row.names = 1, sep = '\t', stringsAsFactors = FALSE, check.names = FALSE)
# otu <- t(otu)
# # tree <- read.tree('otu_tree.tre')
#
# #以 2000 步长（step=2000）为例统计
# pd_curves <- alpha_curves(otu, tree = tree, step = 2000, method = 'pd')
#
# #统计及做图方法同上述
#
# ##Rank-abundance 曲线
# #统计（BiodiversityR 包 rankabundance() 实现 OTU 排序）
# otu_relative <- otu / rowSums(otu)
# rank_dat <- data.frame()
# for (i in rownames(otu_relative)) {
#     rank_dat_i <- data.frame(rankabundance(subset(otu_relative, rownames(otu_relative) == i), digits = 6))[1:2]
#     rank_dat_i$sample <- i
#     rank_dat <- rbind(rank_dat, rank_dat_i)
# }
# rank_dat <- subset(rank_dat, rank_dat$abundance != 0)
#
# #ggplot2 作图
# ggplot(rank_dat, aes(rank, log(abundance, 10), color = sample)) +
#     geom_line() +
#     labs(x = 'OTUs rank', y = 'Relative adundance (%)', color = NULL) +
#     theme(panel.grid = element_blank(), panel.background = element_rect(fill = 'transparent', color = 'black'), legend.key = element_rect(fill = 'transparent')) +
#     scale_y_continuous(breaks = 0:-5, labels = c('100', '10', '1', '0.1', '0.01', '0.001'), limits = c(-5, 0))


#' cq.reg
#'
#' Estimate conditional quantile in two steps:
#' 1. estimate the conditional probability for each observation: tau=p(y|x)
#'          Default to use local method over knn method,
#'          if both arguement supply or unspecify,
#'          only the local method will use.
#' 2. apply scam package to fix x to y with one more predictor tau,
#'    constrain tau to be monotonely nondecreasing.
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param span  fraction of total distance to be the bandwidth, between 0 and 1,
#'             default to be 0.5 if bandwidth not supply.
#' @param bandwidth the bandwidth of x to evaluate the cdf,
#'                 overwrite the span input.
#' @param rnn   fraction of total number of observations to be knn,
#'              between 0 and 1. Set span to be NULL to use knn,
#'              default to be 0.5, if not supply
#' @param knn   the number of nearest neighbor to estimate the cdf,
#'              should be less than the number of observation and greater than 0
#'              (\code{knn < length(y)}.
#'              setting this value overwrite the rnn
#' @param ...   additional arguement pass into scam (eg. sp, gamma, weights)
#'
#' @import scam
#'
#' @return a scam object
#'
#' @examples
#' devtools::load_all()
#' x <- soy$V5
#' y <- soy$V6
#' fit <- cq.reg(x, y)
#' cq_plot(fit)

cq.reg <- function(x, y, arg_bs = c("tesmi1", "ps"),
                opt = "efs", dims = c(5, 15), ords = NA,
                span = 0.05, bandwidth=NULL, rnn=NULL, knn=NULL,
                analysis=F, sp = NULL, ...) {
    #1. Estimate the conditional probability
    tau <- cond_pr(x, y, span, bandwidth, rnn, knn)

    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }

    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(tau, x)

    dat <- data.frame(y, newx)
    colnames(dat) <- c("y", xnam)

    #2. apply scam package
    fit <- scam(y ~ s(tau, x1, k = dims, m = ords, bs = arg_bs),
            data = dat, optimizer = opt, sp = sp, ...)

    if (analysis) {
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(y, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3)

        plot(x, y)
        sort_x <- sort(x)
        for (i in 1:10) {
            newx <- data.frame(i / 10, sort_x)
            colnames(newx) <- xnam
            lines(sort_x, predict(fit, newx), col = i + 1)
        }
    }

    fit$x <- x
    fit$xnam <- xnam
    return(fit)
}

#' @rdname cq.reg
#' @export
cq_regplot <- function(fit, v_taus = seq(0.05, 0.95, 0.15), ...) {
    x <- fit$x
    y <- fit$y
    xnam <- fit$xnam
    sort_x <- sort(x)

    xlim <- grDevices::extendrange(x, f = .01)
    ylim <- grDevices::extendrange(y, f = .01)
    xlab <- "x"
    ylab <- "y"

    plot(x, y, ...,
        type = "p", pch = 16, cex = 0.8, col = "grey",
        xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab)

    for (i in seq_along(v_taus)) {
        newx <- data.frame(v_taus[i], sort_x)
        colnames(newx) <- xnam
        lines(sort_x, predict(fit, newx), col = i + 1)
}

#    lgd <- c(
 #           expression(paste(mu, "=0.1")),
#            expression(paste(mu, "=0.2")),
#            expression(paste(mu, "=0.3")),
#            expression(paste(mu, "=0.4")),
#            expression(paste(mu, "=0.5")),
#            expression(paste(mu, "=0.6")),
#            expression(paste(mu, "=0.7")),
#            expression(paste(mu, "=0.8")),
#            expression(paste(mu, "=0.9")),
#            expression(paste(mu, "=1")))

#    legend("topleft",
#            lty = 1, legend = rev(lgd), col = 11:2,
#            lwd = 1, cex = 1, bty = "n"
#        )
}


# demo: lsystem.r
# author: Daniel Adler

#
# geometry
#

deg2rad <- function( degree ) {
  return( degree*pi/180 )
}

rotZ.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
        kc, -ks,   0,
        ks,  kc,   0,
         0,   0,   1
      ),ncol=3,byrow=TRUE
    )
  )
}

rotX.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
         1,   0,   0,
         0,  kc, -ks,
         0,  ks,  kc
      ),ncol=3,byrow=TRUE
    )
  )
}

rotY.m3x3 <- function( degree ) {
  kc <- cos(deg2rad(degree))
  ks <- sin(deg2rad(degree))
  return(
    matrix(
      c(
        kc,   0,   ks,
         0,   1,    0,
       -ks,   0,   kc
      ),ncol=3,byrow=TRUE
    )
  )
}

rotZ <- function( v, degree ) {
  return( rotZ.m3x3(degree) %*% v)
}

rotX <- function( v, degree ) {
  return( rotX.m3x3(degree) %*% v)
}

rotY <- function( v, degree ) {
  return( rotY.m3x3(degree) %*% v)
}

#
# turtle graphics, rgl implementation:
#

turtle.init <- function(pos=c(0,0,0),head=0,pitch=90,roll=0,level=0) {
  rgl.clear("all")
  rgl.bg(color="black")
  rgl.light()
  return( list(pos=pos,head=head,pitch=pitch,roll=roll,level=level) )
}

turtle.move <- function(turtle, steps, color) {

  rm <- rotX.m3x3(turtle$pitch) %*% rotY.m3x3(turtle$head) %*% rotZ.m3x3(turtle$roll)

  from <- as.vector( turtle$pos )
  dir  <- rm %*% c(0,0,-1)
  to   <- from + dir * steps

  x <- c( from[1], to[1] )
  y <- c( from[2], to[2] )
  z <- c( from[3], to[3] )
  rgl.lines(x,y,z,col=color,size=1.5,alpha=0.5)
  turtle$pos <- to
  return(turtle)
}

turtle.pitch <- function(turtle, degree) {
  turtle$pitch <- turtle$pitch + degree
  return(turtle)
}

turtle.head <- function(turtle, degree) {
  turtle$head <- turtle$head + degree
  return(turtle)
}

turtle.roll <- function(turtle, degree) {
  turtle$roll <- turtle$roll + degree
  return(turtle)
}

#
# l-system general
#

lsystem.code <- function( x )
  substitute( x )

lsystem.gen <- function( x, grammar, levels=0 ) {
  code <- eval( substitute( substitute( REPLACE , grammar ), list(REPLACE=x) ) )
  if (levels)
    return( lsystem.gen( code , grammar , levels-1 ) )
  else
    return( code )
}

#
# l-system plot
#

lsystem.plot <- function( expr, level ) {
  turtle <- turtle.init(level=level)
  lsystem.eval( expr, turtle )
}

lsystem.eval <- function( expr, turtle ) {
  if ( length(expr) == 3 ) {
    turtle <- lsystem.eval( expr[[2]], turtle )
    turtle <- lsystem.eval( expr[[3]], turtle )
    turtle <- lsystem.eval( expr[[1]], turtle )
  } else if ( length(expr) == 2 ) {
    saved <- turtle
    turtle <- lsystem.eval( expr[[1]], turtle )
    turtle <- lsystem.eval( expr[[2]], turtle )
    turtle <- saved
  } else if ( length(expr) == 1 ) {
    if ( as.name(expr) == "stem" )      turtle <- turtle.move(turtle, 5, "brown")
    else if ( as.name(expr) == "short") turtle <- turtle.move(turtle, 5, "brown")
    else if ( as.name(expr) == "leaf" ) {
      rgl.spheres(turtle$pos[1],turtle$pos[2],turtle$pos[3],radius=0.1+turtle$level*0.3,color="green")
      rgl.sprites(turtle$pos[1],turtle$pos[2],turtle$pos[3],radius=0.5+turtle$level*0.3 ,color="green",texture=system.file("textures/particle.png",package="rgl"),textype="alpha",alpha=0.5)
    }
    else if ( as.name(expr) == "roll" ) turtle <- turtle.head(turtle, 60)
    else if ( as.name(expr) == "down" ) turtle <- turtle.pitch(turtle,10)
    else if ( as.name(expr) == "up" )   turtle <- turtle.pitch(turtle,-10)
    else if ( as.name(expr) == "left" ) turtle <- turtle.head(turtle, 1)
    else if ( as.name(expr) == "right") turtle <- turtle.head(turtle,-1.5)
    else if ( as.name(expr) == "turnleft") turtle <- turtle.head(turtle,20)
    else if ( as.name(expr) == "turnright") turtle <- turtle.head(turtle,-20)
    else if ( as.name(expr) == "turn") turtle <- turtle.roll(turtle,180)
  }
  return(turtle)
}

#
# example
#

simple <- function(level=0) {
  grammar <- list(
    stem=lsystem.code(
      stem-(up-stem-leaf)-stem-(down-stem-leaf)-stem-leaf
    )
  )
  plant <- lsystem.gen(lsystem.code(stem), grammar, level )
  lsystem.plot(plant,level)
}

rgl.demo.lsystem <- function(level=0) {
  gen   <- list(
    stem=lsystem.code(
      stem-left-stem-branch( turnleft-down-short-turnleft-down-stem-leaf)-right-right-stem--branch( turnright-up-short-turnright-up-short-turnright-short-stem-leaf)-left-left-left-stem-branch( turnleft-down-short-turnright-down-stem-leaf )-branch( up-turnright-short-up-turnleft-up-stem-leaf )
    )
  )
  plant <- lsystem.gen(lsystem.code(stem), gen, level )
  lsystem.plot(plant,level)
}

rgl.open()
rgl.demo.lsystem(level=1)


[[[[[
   KRAFT INEQUALITY CRITERION FOR CONSTRUCTING COMPUTERS
   Take as input requirement pairs (output, size of program)
   and produce as output assignment pairs (program, output).

   We assume that the requirements are consistent.
   I.e. the sum of 1/2 raised to each size is <= unity.
   Then we can produce a set of assignments that meets
   the requirements and is prefex free, i.e. no extension
   of a valid program is a valid program.

   The basic data structure in this program is the free space pool.
   That's a list of prefixes all of whose extensions (by zero
   or more bits) are unassigned programs.  Initially this is the
   list consisting of the empty string because everything is free.

   The algorithm consists of assigning that program that meets
   each requirement that is available and that comes first in
   lexicographic order (0 before 1).

   The free space pool is kept in lexicographic order, to facilitate
   searching.  So the algorithm is to look for the first prefix in
   the pool that is <= the requested size in each requirement.

   If it has exactly the requested size, then that prefix is the
   program assigned to the output in the requirement.  If not,
   the prefix must be smaller than the requirement, and represents
   a piece of free storage that is a power of two larger than needed.
   So as program we assign the prefix extended by sufficiently many
   0's to reach the requested size, and then the prefix is replaced
   in the free space pool by prefix00001, prefix0001, prefix001,
   prefix01, prefix1, for all sizes up to the assigned size.
   This will always work if the Kraft inequality is satisfied.

   If this algorithm is given the requirements
      (0 1) (1 2)  (2 3)   (3 4)...
   (i.e., a 1-bit p for 0, a 2-bit p for 1, a 3-bit p for 2, etc.)
   it will produce the assignments
      (0 0) (10 1) (110 2) (1110 3)...
   (i.e., p = 0 yields 0, p = 10 yields 1, p = 110 yields 2, etc.)
   In this case the free storage pool will always consist of a
   single piece.

   Key fact: if you follow this first-fit algorithm, the free space
   will appear in blocks in the unit interval whose sizes are all
   distinct powers of two, and in order of increasing size.  So
   if an allocation cannot be made, the piece requested must be
   larger (at least twice as large) as the last & largest piece.
   But the total free storage is less than twice the size of the
   last & largest free piece, so allocating this would have violated
   the Kraft inequality.

   To actually run these programs, we have to feed the output of
   this program kraft.l into the previous one, exec.l.
   So there will in fact be an additional prefix in front of the
   assigned programs to tell U how to do kraft.l and how to do exec.l.

   Kraft is written as a function that is applied to a finite list
   of requirements and produces the corresponding finite list of
   assignments.  Exec.l will use try to run the requirement generator
   for more and more time to produce longer and longer lists of
   assignments.   It will then use the Kraft function to transform
   these into longer and longer lists of assignments, which it will
   use to actually run individual programs by reading them bit by
   bit as required. The Kraft function has the property that applying
   it to a longer list of requirements just produces a longer list
   of assignments.  I.e., it's monotone, it never changes its mind.
]]]]]

[used to assign a program to an output]

define (extend-with-0s bit-string [to] given-length)
   if = length bit-string given-length  [then]
      bit-string  [else]
   append (extend-with-0s bit-string [to] - given-length 1)
          cons 0 nil

define      extend-with-0s
value       (lambda (bit-string given-length) (if (= (length b
            it-string) given-length) bit-string (append (exten
            d-with-0s bit-string (- given-length 1)) (cons 0 n
            il))))

[test it]

(extend-with-0s '(1 1 1) [to] 6)

expression  (extend-with-0s (' (1 1 1)) 6)
value       (1 1 1 0 0 0)

(extend-with-0s '(1 1 1) [to] 5)

expression  (extend-with-0s (' (1 1 1)) 5)
value       (1 1 1 0 0)

(extend-with-0s '(1 1 1) [to] 4)

expression  (extend-with-0s (' (1 1 1)) 4)
value       (1 1 1 0)

(extend-with-0s '(1 1 1) [to] 3)

expression  (extend-with-0s (' (1 1 1)) 3)
value       (1 1 1)

[used to subtract storage from a piece of free storage]

define (remove-piece free-prefix size-of-program)
   if = size-of-program length free-prefix
       nil  [then no storage left, else]
   cons append (extend-with-0s free-prefix [to] - size-of-program 1)
               cons 1 nil
        (remove-piece free-prefix - size-of-program 1)

define      remove-piece
value       (lambda (free-prefix size-of-program) (if (= size-
            of-program (length free-prefix)) nil (cons (append
             (extend-with-0s free-prefix (- size-of-program 1)
            ) (cons 1 nil)) (remove-piece free-prefix (- size-
            of-program 1)))))

[test it]

(remove-piece '(1 1 1) 6)

expression  (remove-piece (' (1 1 1)) 6)
value       ((1 1 1 0 0 1) (1 1 1 0 1) (1 1 1 1))

(remove-piece '(1 1 1) 5)

expression  (remove-piece (' (1 1 1)) 5)
value       ((1 1 1 0 1) (1 1 1 1))

(remove-piece '(1 1 1) 4)

expression  (remove-piece (' (1 1 1)) 4)
value       ((1 1 1 1))

(remove-piece '(1 1 1) 3)

expression  (remove-piece (' (1 1 1)) 3)
value       ()

[
   Make-assignments uses debug to show us the
   free-space-pool after making each assignment.
   If an assignment cannot be made because
   there is not enough storage, we just skip it.
]
define (make-assignments free-space-pool requirements)

   let free-space-pool   debug free-space-pool
                         [Done just to show pool!]

   if  atom requirements nil  [no requirements => no assignments]
                              [If so, we're finished!]

   let requirement       car  requirements
   let requirements      cdr  requirements
   let output-of-program car  requirement
   let size-of-program   cadr requirement
   let already-scanned   nil
   let not-yet-scanned   free-space-pool

   let (loop-thru-free-space-pool) [DEFINE IT!]

       if atom not-yet-scanned [cannot make this assignment!]
          [indicate problem and go to next requirement]
          cons not-enough-storage!
               (make-assignments free-space-pool requirements)

       let free-prefix      car not-yet-scanned
       let not-yet-scanned  cdr not-yet-scanned
       if < size-of-program length free-prefix

          [doesn't fit --- continue scanning]
          let already-scanned
              append already-scanned
                     cons free-prefix nil
          (loop-thru-free-space-pool)

       [fits! --- make assignment]
       [add to list of rest of assignments]
       let free-space-pool
           append already-scanned
           append (remove-piece free-prefix size-of-program)
                  not-yet-scanned

       let assignment
           [make assignment - add to list of rest of assignments]
           [found free piece where it fits!]
           [extend with zeros to correct size]
           cons (extend-with-0s free-prefix [to] size-of-program)
           cons output-of-program
                nil

       [return full list of assignments]
       cons assignment
            (make-assignments free-space-pool requirements)

   [NOW DO IT!]
   (loop-thru-free-space-pool)

define      make-assignments
value       (lambda (free-space-pool requirements) ((' (lambda
             (free-space-pool) (if (atom requirements) nil (('
             (lambda (requirement) ((' (lambda (requirements)
            ((' (lambda (output-of-program) ((' (lambda (size-
            of-program) ((' (lambda (already-scanned) ((' (lam
            bda (not-yet-scanned) ((' (lambda (loop-thru-free-
            space-pool) (loop-thru-free-space-pool))) (' (lamb
            da () (if (atom not-yet-scanned) (cons not-enough-
            storage! (make-assignments free-space-pool require
            ments)) ((' (lambda (free-prefix) ((' (lambda (not
            -yet-scanned) (if (< size-of-program (length free-
            prefix)) ((' (lambda (already-scanned) (loop-thru-
            free-space-pool))) (append already-scanned (cons f
            ree-prefix nil))) ((' (lambda (free-space-pool) ((
            ' (lambda (assignment) (cons assignment (make-assi
            gnments free-space-pool requirements)))) (cons (ex
            tend-with-0s free-prefix size-of-program) (cons ou
            tput-of-program nil))))) (append already-scanned (
            append (remove-piece free-prefix size-of-program)
            not-yet-scanned)))))) (cdr not-yet-scanned)))) (ca
            r not-yet-scanned)))))))) free-space-pool))) nil))
            ) (car (cdr requirement))))) (car requirement))))
            (cdr requirements)))) (car requirements))))) (debu
            g free-space-pool)))

[put it all together]

define (kraft requirements)

   let free-space-pool '(()) [everything free]

   (make-assignments free-space-pool requirements)

define      kraft
value       (lambda (requirements) ((' (lambda (free-space-poo
            l) (make-assignments free-space-pool requirements)
            )) (' (()))))

[TEST KRAFT!]

(kraft '((x 0) (y 1)))

expression  (kraft (' ((x 0) (y 1))))
debug       (())
debug       ()
debug       ()
value       ((() x) not-enough-storage!)

(kraft '((a 1) (b 0) (c 1)))

expression  (kraft (' ((a 1) (b 0) (c 1))))
debug       (())
debug       ((1))
debug       ((1))
debug       ()
value       (((0) a) not-enough-storage! ((1) c))

(kraft '((x 1) (y 2)))

expression  (kraft (' ((x 1) (y 2))))
debug       (())
debug       ((1))
debug       ((1 1))
value       (((0) x) ((1 0) y))

(kraft '((a 1) (b 2) (c 3) (d 4) (e 5)))

expression  (kraft (' ((a 1) (b 2) (c 3) (d 4) (e 5))))
debug       (())
debug       ((1))
debug       ((1 1))
debug       ((1 1 1))
debug       ((1 1 1 1))
debug       ((1 1 1 1 1))
value       (((0) a) ((1 0) b) ((1 1 0) c) ((1 1 1 0) d) ((1 1
             1 1 0) e))

(kraft '((e 5) (d 4) (c 3) (b 2) (a 1)))

expression  (kraft (' ((e 5) (d 4) (c 3) (b 2) (a 1))))
debug       (())
debug       ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (1))
debug       ((0 0 0 0 1))
value       (((0 0 0 0 0) e) ((0 0 0 1) d) ((0 0 1) c) ((0 1)
            b) ((1) a))

(kraft '((e 5) (c 3) (d 4) (a 1) (b 2)))

expression  (kraft (' ((e 5) (c 3) (d 4) (a 1) (b 2))))
debug       (())
debug       ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1) (1))
debug       ((0 0 0 0 1) (0 1))
debug       ((0 0 0 0 1))
value       (((0 0 0 0 0) e) ((0 0 1) c) ((0 0 0 1) d) ((1) a)
             ((0 1) b))