#
# 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)
#
#


library(coop)
library(rbenchmark)
cols <- cols <- c("test", "replications", "elapsed", "relative")
reps <- 25

m <- 10000
n <- 250
x <- matrix(rnorm(m*n), m, n)

cat("### regular\n")
benchmark(cov(x), covar(x), replications=reps, columns=cols)

cat("### pairwise\n")
benchmark(cov(x, use='pair'), covar(x, use='pair'), replications=reps, columns=cols)


# Note that if you want ranks from highest to lowest you can take the negative and then compute the ranks
x <- c(88, 100, 83, 92, 94)
rank(-x)

# Defining rate
rate <-  murders$total/ murders$population * 100000

# Redefine murders to include a column named rank
# with the ranks of rate from highest to lowest

murders <- mutate(murders, rank = rank(-rate))


# graphics

library(quantmod)
# initialization
symbols = c("AMZN", "FB", "NFLX", "MSFT")
start <- as.Date("2017-01-01")
end <- as.Date("2020-01-01")
getSymbols(Symbols = symbols, src = "yahoo", from = start, to = end)
# get only Close values of AMZN and MSFT symbols
stocks <- as.xts(data.frame(AMZN = AMZN[,"AMZN.Close"], MSFT = MSFT[,"MSFT.Close"]))

# plotting
library(plotly)
plot(AMZN[,"AMZN.Close"], main = "AMZN") # prints linear graph

# create a custom theme
my_theme <- chart_theme()
my_theme$col$up.col <- "darkgreen"
my_theme$col$up.border <- "black"
my_theme$col$dn.col <- "darkred"
my_theme$col$dn.border <- "black"
my_theme$rylab <- FALSE
my_theme$col$grid <- "lightgrey"

# using the custom theme with a range
chart_Series(AMZN, subset = "2017-10::2018-09", theme = my_theme)

# using the custom theme with a range of one month
chart_Series(AMZN, subset = "2018-09", theme = my_theme)

# using the candle theme of quantmod
candleChart(AMZN, up.col = "green", dn.col = "red", theme = "white")

# zoom of graph on one month
zoomChart("2018-09")

# zoom of graph on one year
zoomChart("2018")

# add indicators
addSMA(n = c(20, 50, 200)) # adds simple moving averages
addBBands(n = 20, sd = 2, ma = "SMA", draw = "bands", on = -1) # sd = standard deviation, ma = average
AMZN_ema_21 <- EMA(Cl(AMZN), n=21) # exponencial moving average
addTA(AMZN_ema_21, on = 1, col = "red")
AMZN_ema_50 <- EMA(Cl(AMZN), n=50) # exponencial moving average
addTA(AMZN_ema_50, on = 1, col = "blue")
AMZN_ema_200 <- EMA(Cl(AMZN), n=200) # exponencial moving average
addTA(AMZN_ema_200, on = 1, col = "orange")


context("Convergence checkers work")

test_that("Multiple chains mcmc behaves", {

  set.seed(71)
  n <- 1000
  x <- rnorm(n)
  s <- 2
  y <- 1 + .2*x + rnorm(n, sd = s)

  ll <- function(p) {
    ans <- sum(log(dnorm(y - p[1] - x*p[2], sd = p[3])))
    if (!is.finite(ans))
      return(-.Machine$double.xmax*1e-10)
    ans
  }

  # Gwedeke autostop convergence
  ans0 <- suppressWarnings(MCMC(
    ll, initial = rep(5, 3), nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
      ), conv_checker = convergence_auto(500L),
    thin = 10
    ))

  ans0 <- MCMC(
    ll, initial = tail(ans0, 0L), nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
    ), conv_checker = NULL,
    thin = 10, burnin = 0L
  )

  # Gelman autostop convergence
  ans1 <- suppressWarnings(MCMC(
    ll, initial = rep(5, 3), nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
    ),
    thin         = 10,
    conv_checker = convergence_gelman(500L),
    nchains      = 2
  ))

  ans1 <- MCMC(
    ll,
    initial = colMeans(do.call(rbind, tail(ans1, 0))),
    nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
    ), conv_checker = NULL,
    thin = 10, burnin = 0L
  )

  # Heidel autostop convergence
  ans2 <- suppressWarnings(MCMC(
    ll, initial = rep(5, 3), nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
    ),
    thin = 10, conv_checker = convergence_heildel(500L)
  ))

  ans2 <- MCMC(
    ll, initial = tail(ans2, 0), nsteps = 2000,
    kernel = kernel_reflective(
      lb = 0, ub = 10, mu = 0, scale = .1
    ), conv_checker = NULL,
    thin = 10, burnin = 0L
  )

  # Should reach an estimates close to the model parameters
  sol <- c(1, .2, 2)
  expect_equivalent(colMeans(ans0), sol, tol = 0.2)
  expect_equivalent(colMeans(ans1), sol, tol = 0.2)
  expect_equivalent(colMeans(ans2), sol, tol = 0.2)

})


### 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")


a = "this is python!"; print(a)

a <- "this is R!"; cat(a)

import matplotlib.pyplot as p
import scipy as sc

x = sc.arange(0, 5, 0.1); y = sc.sin(x)
p.plot(x, y); p.show()

require(ggplot2)
library(repr)# to resize plot within jupyter - this package is part of IRKernel
options(repr.plot.width=3.3,repr.plot.height=2.5)

x <- seq(0, 5, 0.1); y <- sin(x)
qplot(x, y, geom = "line") # large figure


#' @export
summary.strata <- function (object, alpha.t = 0.05, effic = FALSE, nopt = FALSE, ...) {
    if (!inherits(object, "strata"))
        stop("Not a legitimate strata object")
    yh <- as.vector(sapply(object$yhi, mean))
    yst <- sum(object$Wh * yh, na.rm = TRUE)
    sh <- as.vector(sapply(object$yhi, var))
    se.yst <- sqrt(sum((((object$Nh * (object$Nh - object$nh))/sum(object$Nh)^2) *
        sh)/object$nh, na.rm = TRUE))
    ah <- (object$Nh * (object$Nh - object$nh))/object$nh
    df.yst <- (sum(ah * sh, na.rm = TRUE)^2)/(sum(((ah * sh)^2)/(object$nh -
        1), na.rm = TRUE))
    ci.yst <- yst + (c(qt(alpha.t/2, df.yst), -qt(alpha.t/2,
        df.yst)) * se.yst)
    if(any(length(object$Wh) != length(object$nhws) | length(object$nhws)!= length(object$nh))) browser()
    dwao <- sum(object$Wh*(object$nhws / object$nh)) * sum(object$Nh) * 0.011801
    gi=NA
    if(length(yh)>1) gi <- gini(x=yh,y=object$Nh)

    res <- list(yst = yst, se.yst = se.yst, Yst = yst * sum(object$Nh),
        df.yst = df.yst, alpha = alpha.t, ci.yst = ci.yst, dwao = dwao,gini = gi)
    if (effic == TRUE) {
        N <- sum(object$Nh)
        n <- sum(object$nh)
        vran <- ((N - n)/(n * N)) * sum(object$Wh * sh, na.rm = TRUE)
        effic.str <- ((N - n)/(n * (N - 1))) * (sum(object$Wh *
            (yh - yst)^2) - sum((object$Wh * (1 - object$Wh) *
            sh)/object$nh, na.rm = TRUE))
        vran <- vran + effic.str
        effic.alloc <- sum(((1/n) - (object$Wh/object$nh)) *
            object$Wh * sh, na.rm = TRUE)
        effic.str <- (100 * effic.str)/vran
        effic.alloc <- (100 * effic.alloc)/vran
        min.var <- ((1/n) * sum(object$Wh * sqrt(sh), na.rm = TRUE)^2) -
            sum(object$Wh * sh, na.rm = TRUE)/N
        res <- c(res, list(effic.alloc = effic.alloc, effic.str = effic.str,
            var.ran = vran, max.eff = (100 * (vran - min.var))/vran,
            min.var = min.var))
    }
    if (nopt) {
        n.opt.out <- as.data.frame(matrix(NA, length(yh) + 1,
            6))
        names(n.opt.out) <- c("Strata", "Observed", "Optimal",
            "Perc.Increase.Var.opt", "Compromise", "Perc.Increase.Var.comp")
        n.opt.out$Strata <- c(object$Strata, "Total")
        n.opt.out$Observed <- c(object$nh, n.tot <- sum(object$nh))
        if (all(object$nh != 1)) {
            n.opt <- (((sqrt(sapply(object$yhi, var)) * object$Wh)/sum(sqrt(sapply(object$yhi,
                var)) * object$Wh, na.rm = TRUE)) * sum(object$nh))
            n.opt <- round(n.opt)
            if (n.tot > sum(n.opt)) {
                n.opt[n.opt == max(n.opt)] <- n.opt[n.opt ==
                  max(n.opt)] + (n.tot - sum(n.opt))
            }
            if (n.tot < sum(n.opt)) {
                n.opt[n.opt == max(n.opt)] <- n.opt[n.opt ==
                  max(n.opt)] - (n.tot - sum(n.opt))
            }
            n.opt.out$Optimal <- c(n.opt, sum(n.opt))
            perc.increase <- (100 * (((object$nh - n.opt)^2)/object$nh))/sum(object$nh)
            n.opt.out$Perc.Increase.Var.opt <- c(perc.increase,
                sum(perc.increase))
            n.comp.ind <- (n.opt <= 1)
            n.comp.opt <- sum(n.comp.ind)
            n.opt2 <- n.opt
            n.opt2[n.comp.ind] <- 2
            n.opt2[n.opt2 == max(n.opt2)] <- n.opt2[n.opt2 ==
                max(n.opt2)] - (sum(n.opt2) - sum(n.opt))
            n.opt.out$Compromise <- c(n.opt2, sum(n.opt2))
            Perc.Increase.Var.comp <- (100 * (((n.opt2 - n.opt)^2)/n.opt2))/sum(object$nh)
            n.opt.out$Perc.Increase.Var.comp <- c(Perc.Increase.Var.comp,
                sum(Perc.Increase.Var.comp))
        }
        res <- c(res, list(n.opt = n.opt.out))
    }
    options(digits = max(options()$digits - 5, 5))
    c(res, list(descrip = "Stratified Analysis"))
}


#' zero_truncated_density.r
#' For when you want to make a density plot, but your values are bounded to [0,]
#'
#' @param x vector of values to make a density object out ouf
#'
#' @return  returns a zero truncated density object.
#' @export
#'
#' @examples
zero_truncated_density <- function(x){
  h <- density(x)$bw                                                #get dansity bandwith
  w <- 1 / pnorm(0, mean=x, sd=h, lower.tail=FALSE)                 #Compute edge weights.
  suppressWarnings(
    h <- density(x, bw=h, kernel="gaussian", weights=w / length(x)) #Generate truncated distribution.
  )
  h$y[h$x < 0] <- 0                                                 #set negative values to zero.
  #Check: the integral ought to be close to 1:
  if(sum(h$y * diff(h$x)[1]) > 1.1 | sum(h$y * diff(h$x)[1]) < 0.9){
    warning('Zero-truncated density sum is not close to 1. Consider doing something else...')
  }
  return(h)
}


#  James Rekow

identifyNumSubgroupsTest = function(abdList, infoMat){

  #  ARGS: infoMat - matrix of info weights corresponding to pairs of samples from an abundance list
  #
  #  RETURNS: numClust - predicted number of clusters in infoMat

  normalizeVec = function(x) x / sqrt(sum(x ^ 2))

  abdMat = Reduce(rbind, abdList)

  abdMat = t(apply(abdMat, 1, normalizeVec))
  infoMat = t(apply(infoMat, 1, normalizeVec))

  mixMat = cbind(abdMat, infoMat)

  mixMat = t(apply(mixMat, 1, normalizeVec))

  cmr = clusGap(x = mixMat, FUNcluster = kmeans, K.max = 9, d.power = 2, B = 100)

  numClust = maxSE(f = cmr$Tab[ , "gap"], SE.f = cmr$Tab[ , "SE.sim"], SE.factor = 1,
                   method = "Tibs2001SEmax")

  return(numClust)

} #  end identifyNumSubgroupsTest function


## Write a function to return a proposal function for that parameter
generic.normal.proposal <- function( param.name ) {
        return(
                function( state ) {
                        ## Extract parameters from the state
                        param.old <- state[[param.name]]
                        ## th.old <- state$th

                        MH.param  <- state$MH[[param.name]]
                        ## MH.th  <- state$MH$th

                        ## Draw the proposal to update the state
                        state[[param.name]] <- rnorm(
                                length( param.old ),
                                mean=param.old,
                                sd=MH.param )
                        ## state$th <- rnorm( length( th.old ),
                        ##                    mean=th.old,
                        ##                    sd=MH.th )

                        ## Build a function to return the density of the proposal
                        log.density <- function( state.to, state.from ) {
                                dnorm( x    = state.to[[param.name]],
                                       ##     state.to$th,
                                       mean = state.from[[param.name]],
                                       ##     state.from$th,
                                       sd   = MH.param,
                                       ##     MH.th,
                                       log  = TRUE )
                        }

                        ## Return the proposal object
                        return( list( param.name=param.name, state=state,
                                      ##      list( param.name='th', state=state,
                                      ##
                                      log.density=log.density ))
                }
        )
}


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.")
}


# "Performance for all severity"

# Setting
```{r}

# reset
rm(list=ls(all=TRUE))

# library
library(data.table)
library(dplyr)
library(psych)
library(caret)
library(gam)
library(RSNNS)
library(e1071)
library(ranger)
library(randomForest)
library(xgboost)

# Directory
setwd(".")

# Get data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

Data_obs_pred_city_specific <- fread("Out_obs_pred_cityspeficit_model.csv")
Data_obs_pred_city_specific$Pred <- ifelse(Data_obs_pred_city_specific$Pred < 0, 0, Data_obs_pred_city_specific$Pred)
Data_obs_pred_city_specific$Pred <- ifelse(Data_obs_pred_city_specific$Pred > 104, 104, Data_obs_pred_city_specific$Pred)

# Train Test
Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible
Data_test <- data.frame(Data_test)

Data_obs_pred_city_specific_train <- Data_obs_pred_city_specific[TrainTest == "Train", , ]
Data_obs_pred_city_specific_test <- Data_obs_pred_city_specific[TrainTest == "Test", , ]

```

# define functions
```{r}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

# Performance All SeverityAll in Train and Test
```{r}

Models <- c(
	"gamSpline_temp.rds"
)

# get model list
Model_list <- Models

# get city list
City_list <- c(
"Kobe"
, "Ashiya"
, "Nishinomiya"
, "Amagasaki"
, "Akashi"
, "Himeji"

, "Kyoto"
, "Uji"
, "Muko"
, "Nagaokakyo"

, "Osaka"
, "Toyonaka"
, "Mino"
, "Ikeda"
, "Suita"
, "Sakai"
)
# Save performance
Hoge <- c()

# loop
for(iii_city in City_list){

Data_train_city <- subset(Data_train, ID == iii_city)
Data_test_city <- subset(Data_test, ID == iii_city)

# load models
Model <- readRDS(Model_list)

# get predicted values
Data_train_city$Pred <- predict(Model, Data_train_city)
Data_train_city$Pred <- ifelse(Data_train_city$Pred < 0, 0, Data_train_city$Pred)

# get performance
RMSE_train <- RMSE(Obs = Data_train_city$SeverityAll, Pred = Data_train_city$Pred)

MAE_train <- MAE(Obs = Data_train_city$SeverityAll, Pred = Data_train_city$Pred)

Cor_train <- paste(
	cor.test(Data_train_city$SeverityAll, Data_train_city$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_train_city$SeverityAll, Data_train_city$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_train_city$SeverityAll, Data_train_city$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# get predicted values
Data_test_city$Pred <- predict(Model, Data_test_city)
Data_test_city$Pred <- ifelse(Data_test_city$Pred < 0, 0, Data_test_city$Pred)

# get performance
RMSE_test <- RMSE(Obs = Data_test_city$SeverityAll, Pred = Data_test_city$Pred)

MAE_test <- MAE(Obs = Data_test_city$SeverityAll, Pred = Data_test_city$Pred)

Cor_test <- paste(
	cor.test(Data_test_city$SeverityAll, Data_test_city$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_test_city$SeverityAll, Data_test_city$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_test_city$SeverityAll, Data_test_city$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# city specific model
Data_obs_pred_city_specific_train_sel <- Data_obs_pred_city_specific_train[ID == iii_city, , ]
Data_obs_pred_city_specific_test_sel <- Data_obs_pred_city_specific_test[ID == iii_city, , ]

RMSE_train_city <- RMSE(Obs = Data_obs_pred_city_specific_train_sel$SeverityAll, Pred = Data_obs_pred_city_specific_train_sel$Pred)
RMSE_test_city <- RMSE(Obs = Data_obs_pred_city_specific_test_sel$SeverityAll, Pred = Data_obs_pred_city_specific_test_sel$Pred)

Cor_train_city <- paste(
	cor.test(Data_obs_pred_city_specific_train_sel$SeverityAll, Data_obs_pred_city_specific_train_sel$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_obs_pred_city_specific_train_sel$SeverityAll, Data_obs_pred_city_specific_train_sel$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_obs_pred_city_specific_train_sel$SeverityAll, Data_obs_pred_city_specific_train_sel$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

Cor_test_city <- paste(
	cor.test(Data_obs_pred_city_specific_test_sel$SeverityAll, Data_obs_pred_city_specific_test_sel$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_obs_pred_city_specific_test_sel$SeverityAll, Data_obs_pred_city_specific_test_sel$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_obs_pred_city_specific_test_sel$SeverityAll, Data_obs_pred_city_specific_test_sel$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	)

# Summarize
Performance <- c(
	iii_city,
	RMSE_train
	, RMSE_train_city
	, RMSE_test
	, RMSE_test_city

	, Cor_train
	, Cor_train_city
	, Cor_test
	, Cor_test_city
	)

Hoge <- cbind(Hoge, Performance)

}

Hoge <- data.table(Hoge)
Hoge$Name <- c(
	  "City"
	, "RMSE_train"
	, "RMSE_train_city"
	, "RMSE_test"
	, "RMSE_test_city"

	, "Cor_train"
	, "Cor_train_city"
	, "Cor_test"
	, "Cor_test_city"
)

fwrite(Hoge, "Out_RMSE_city_commonmodel.csv") #

Hoge

```

# define functions
```{r}

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 2)
	return(RMSE)
}

MAE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAE <- Dif %>% abs() %>% mean()	%>% round(., 2)
	return(MAE)
}

MAPE <- function(Obs, Pred){
	Dif <- Pred - Obs
	MAPE <- mean(abs(Dif/Obs)*100) %>% round(., 2)
	return(MAPE)
}

```

# Performance
```{r}

Data <- fread("Out_obs_pred_cityspeficit_model.csv")
Data$Pred <- ifelse(Data$Pred < 0, 0, Data$Pred)
Data$Pred <- ifelse(Data$Pred > 104, 104, Data$Pred)

Data_train <- Data[TrainTest == "Train", , ]
Data_test <- Data[TrainTest == "Test", , ]

# get performance
RMSE_train <- RMSE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred) %>% print()

MAE_train <- MAE(Obs = Data_train$SeverityAll, Pred = Data_train$Pred) %>% print()

Cor_train <- paste(
	cor.test(Data_train$SeverityAll, Data_train$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_train$SeverityAll, Data_train$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	) %>% print()

# get performance
RMSE_test <- RMSE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred) %>% print()

MAE_test <- MAE(Obs = Data_test$SeverityAll, Pred = Data_test$Pred) %>% print()

Cor_test <- paste(
	cor.test(Data_test$SeverityAll, Data_test$Pred)$estimate %>% round(., 2),
	" (",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[1] %>% round(., 2),
	" to ",
	cor.test(Data_test$SeverityAll, Data_test$Pred)$conf.int[2] %>% round(., 2),
	")",
	sep = ""
	) %>% print()

# Summarize
Performance <- c(
	RMSE_train
	, RMSE_test

	, Cor_train
	, Cor_test
	)
Performance

write.csv(Performance, "Out_RMSE_city_specific_model.csv")

```

# MAPE by 24
```{r}

# Organized dataset
Data_train_MAPE <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_train_MAPE[, Year := year(Date), ]

Data_train_MAPE[, Spike :=
	ifelse(Year == 2015 & Obs >= Data_train_MAPE[Year == 2015, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2016 & Obs >= Data_train_MAPE[Year == 2016, quantile(Obs, 0.8), ], 1,
	ifelse(Year == 2017 & Obs >= Data_train_MAPE[Year == 2017, quantile(Obs, 0.8), ], 1, 0)))
	, ]
Data_train_MAPE[, table(Spike), ]
Data_train_MAPE[, table(Spike), ] / nrow(Data_train_MAPE)

# get performance
MAPE_train <- MAPE(
	Obs = Data_train_MAPE[Spike == 1, Obs, ],
	Pred = Data_train_MAPE[Spike == 1, Pred, ]
	) %>% print()

PE_train <- Data_train_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ] %>% print()

# Organized dataset
Data_test_MAPE <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obs = sum(SeverityAll),
		Pred = sum(Pred)
		) %>% data.table()

Data_test_MAPE[, Year := year(Date), ]

Data_test_MAPE[, Spike :=
	ifelse(Year == 2018 & Obs >= Data_test_MAPE[Year == 2018, quantile(Obs, 0.8), ], 1, 0)
	, ]
Data_test_MAPE[, table(Spike), ]
Data_test_MAPE[, table(Spike), ] / nrow(Data_test_MAPE)

# get performance
MAPE_test <- MAPE(
	Obs = Data_test_MAPE[Spike == 1, Obs, ],
	Pred = Data_test_MAPE[Spike == 1, Pred, ]
	) %>% print()

PE_test <- Data_test_MAPE[Spike == 1, round( (abs(sum(Pred) - sum(Obs)) / sum(Obs) ) * 100, 2), ] %>% print()

# Summarize
Performance <- c(
	MAPE_train
	, MAPE_test
	, PE_train
	, PE_test
	) %>% print()

write.csv(Performance, "Out_MAPE_24_city_specific_model.csv")

```

# Figure time series by 24h
```{r}

# get predicted values
Data_train$Predicted <- Data_train$Pred
Data_train$Obserbved <- Data_train$SeverityAll
Data_train$Dif <- Data_train$Predicted - Data_train$Obserbved

# get predicted values
Data_test$Predicted <- Data_test$Pred
Data_test$Obserbved <- Data_test$SeverityAll
Data_test$Dif <- Data_test$Predicted - Data_test$Obserbved

### Make figures
ggplot(data = Data_train, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_city_specific_train.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make figures test
ggplot(data = Data_test, aes(x = Predicted, y = Obserbved)) +
	geom_point() +
	geom_smooth(method = lm) +
	scale_x_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10)) +
	xlab("") +
	ylab("") +
	theme_classic()
ggsave(paste("Out_plot_city_specific_test.png", sep = ""), width = 4.2, height = 3.2) #*action

### Make Fig train
DataSum_train <- Data_train %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table() %>%
	print()

DataSum_test <- Data_test %>%
	group_by(Date) %>%
	summarise(
		Obserbved = sum(Obserbved),
		Predicted = sum(Predicted)
		) %>%
	data.table() %>%
	print()

DataSum <- rbind(DataSum_train, DataSum_test)

DataSum[, Date:=as.Date(Date), ]
DataSum[, YearUse:=year(Date), ]
DataSum <- DataSum[order(Date), , ]
DataSum[, Day:=1:length(Obserbved), by = YearUse]
DataSum

DataSum[Date == as.Date("2015-06-01"), , ]
DataSum[Date == as.Date("2015-07-01"), , ]
DataSum[Date == as.Date("2015-08-01"), , ]
DataSum[Date == as.Date("2015-09-01"), , ]

ggplot(data = DataSum, aes(x = Day), group=factor(YearUse)) +
	geom_line(aes(y = Obserbved, x=Day), colour = "Black", size = 0.4) +
	geom_line(aes(y = Predicted, x=Day), colour = "Red", size = 0.4) +
	xlab("") +
	ylab("") +

	scale_y_continuous(
		limits = c(0, 450),
		breaks = seq(0, 450, 50)
		) +

	scale_x_continuous(
		label = c("Jun.", "Jul.", "Aug.", "Sep."),
		breaks = c(1, 31, 62, 93)
		) +
	theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
	facet_grid(~YearUse) +
	theme_classic()

ggsave(paste("Out_time_24_city_specific.png", sep = ""), width = 6.7 * 1.5, height = 3.5 * 0.66) #*action

```


# source: https://www.ceremade.dauphine.fr/~xian/basudo.R
# Le Monde 241008
s=matrix(0,ncol=9,nrow=9)
s[1,c(1,5,6,8)]=c(4,9,7,8)
s[2,2]=2
s[3,c(3,8)]=c(6,4)
s[4,9]=9
s[5,c(2,4,7)]=c(1,4,6)
s[6,c(8,3,6,8,9)]=c(8,3,2,5,7)
s[7,1:3]=c(5,9,7)
s[8,5]=1
s[9,5:7]=c(2,6,7)


measure <- function(x) { mean(x) / sd(c(x, 0, 1)) }
A <- c(rep(1, 97), rep(0, 3))
B <- c(1, 1, 1)
c(measure(A), measure(B))


#本文需要用到的 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))


context("compare twomeans results to Stata")

test_that("sampsi 12 16, sd(5) power(0.8)", {
	calc <- twomeans(m1 = 12, m2 = 16, sd = 5)
	expect_equal(calc$n1, 25)
	expect_equal(calc$n2, 25)
})

test_that("sampsi 12 15, sd1(5) sd2(7) r(0.5) power(0.8)", {
    calc <- twomeans(m1 = 12, m2 = 15, nratio = 0.5, sd1 = 5, sd2 = 7)
    expect_equal(calc$n1, 108)
    expect_equal(calc$n2, 54)
})


 C02AKJ Example Program Results

  Roots of cubic equation             Error estimates
                                    (machine-dependent)

  z =   1.0000E+00 +0.0000E+00*i          1.0E-15
  z =  -2.0000E+00 +3.0000E+00*i          1.0E-15
  z =  -2.0000E+00 -3.0000E+00*i          1.0E-15


#' 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"
#        )
}


##this script tested packages: curvclust, funHDDC, and FunCluster on clustering time series curves
require(fda)
require(curvclust)
require(funHDDC)
require(FunCluster)
require(ggplot2)
require(R.matlab)
#example 1
## test on the data set Berkeley Growth Data
K=2
###curvclust {Wavelet}, not good design, not good performance
fdat=list()
data=growth[["hgtf"]]
size=dim(data)
dataarr=as.data.frame(matrix(NA,nrow=size[1]*size[2],ncol=4))
colnames(dataarr)=c("person","age","height","cluster")
for(j in 1:ncol(data)){
  vec=data[,j]
  names(vec)=NULL
  fdat[[j]]=vec
}
dataarr[,"height"]=unlist(fdat)
dataarr[,"person"]=rep(seq(size[2]),each=size[1])
dataarr[,"age"]=rep(growth[["age"]],times=size[2])
#data
CCD=new("CClustData",Y=fdat,filter.number=1)#smoothness
CCDred=getUnionCoef(CCD)
#options
CCO=new("CClustO")
CCO["nbclust"]=K
CCO["Gamma2.structure"]="none"
CCR=getFCMM(CCDred,CCO)#Functional Clustering Mixed Models {FCMM,FCM,FMM}
summary(CCR)
cluster=apply(CCR["Tau"],1,which.max)
dataarr[,"cluster"]=rep(cluster,each=size[1])
p<-ggplot(data=dataarr,aes(age,height,colour=cluster,group=person))+
      geom_line(alpha=0.5)+
      xlab("age")+
      ylab("height")+
      theme_bw()

###funHDDC
age=growth[["age"]]
heightmat=growth[["hgtf"]]
norder=6
nbasis=length(age)+norder-2
heightbasis=create.bspline.basis(c(1,18),nbasis,norder,age)
heightfdPar=fdPar(heightbasis,4,0.01)
heightfd=smooth.basis(age,heightmat,heightfdPar)$fd
res.uni<-funHDDC(heightfd,K=2,model="AkBkQkDk",init="random",threshold=0.2)
plot(heightfd,col=res.uni$class)
# slopeHeuristic(res.uni)
res.pca<-mfpca(heightfd)
plot.mfpca(res.pca)
#FunCluster: really domain specific(hard to code with)

#example 2
## test on ridge tracking data set
load("/Users/mikeaalv/Dropbox (Edison_Lab@UGA)/Projects/Bioinformatics_modeling/spectral.related/result/compound.quan.record.absmore.upd.RData")
experi=1
lenlist=sapply(list.quan,function(x){
  dim(x)[1]
})
dataarr=as.data.frame(cbind(Reduce(rbind,list.quan),rep(names(list.quan),times=lenlist)))
colnames(dataarr)=c("time","intensity","exp","compd")
dataarr=dataarr[dataarr[,"exp"]==experi,]
# timecount=table(dataarr[,"time"])
# allexitime=names(timecount)[timecount==max(timecount)]
dataarr=dataarr[dataarr[,"time"]<7.2 & dataarr[,"time"]>0.8,]
dataarr=dataarr[order(dataarr[,"compd"]),]
compds=unique(dataarr[,"compd"])
for(compd in compds){
  ind=dataarr[,"compd"]==compd
  dataarr[ind,"intensity"]=scale(dataarr[ind,"intensity"])
}
time=sort(unique(dataarr[,"time"]))
###curvclust
fdat=list()
for(compd_i in seq(length(compds))){
  compd=compds[compd_i]
  vec=dataarr[dataarr[,"compd"]==compd,"intensity"]
  names(vec)=NULL
  fdat[[compd_i]]=vec
}
#data
CCD=new("CClustData",Y=fdat,filter.number=1)#smoothness
CCDred=getUnionCoef(CCD)
#options
CCO=new("CClustO")
CCO["nbclust"]=3
CCO["Gamma2.structure"]="none"
CCR=getFCM(CCDred,CCO)#Functional Clustering Mixed Models {FCMM,FCM,FMM}
summary(CCR)
cluster=apply(CCR["Tau"],1,which.max)
dataarrtemp=dataarr
dataarrtemp[,"cluster"]=as.factor(rep(cluster,each=length(time)))
p<-ggplot(data=dataarrtemp,aes(time,intensity,colour=cluster,group=compd))+
      geom_line(alpha=0.5)+
      xlab("time")+
      ylab("intensity")+
      theme_bw()

###funHDDC
list_intensity=sapply(compds,simplify=FALSE,function(x){
  tempmat=dataarr[dataarr[,"compd"]==x,]
  tempmat[order(tempmat[,"time"]),"intensity"]
})
intenmat=Reduce(cbind,list_intensity)
norder=6
nbasis=length(time)+norder-2
intbasis=create.bspline.basis(c(min(time),max(time)),nbasis,norder,time)
intfdPar=fdPar(intbasis,4,0.01)
intfd=smooth.basis(time,intenmat,intfdPar)$fd
res.uni<-funHDDC(intfd,K=3,model="AkBkQkDk",init="random",threshold=0.2,nb.rep=50)
plot(intfd,col=res.uni$class)
# slopeHeuristic(res.uni)
res.pca<-mfpca(intfd)
plot.mfpca(res.pca)