###########################################
##-------- Read meta information --------##
##-------- Cluster library batch --------##
###########################################

## load meta information
meta<-read.table("meta.txt",sep="\t",head=T)
meta$LibraryBatch<-as.character(meta$LibraryBatch)

## LibraryBatch cluster by hclust
LibraryBatch<-matrix(as.numeric(as.Date(meta$LibraryBatch)), ncol=1)
rownames(LibraryBatch)<-meta$LibraryBatch
LibraryBatch<-unique(LibraryBatch)
LibraryBatch.dist<-dist(LibraryBatch,method="euclidean")
LibraryBatch.hclust<-hclust(LibraryBatch.dist, method="median")
LibraryBatch.id<-cutree(LibraryBatch.hclust,k=18)
pdf("hclust.LibraryBatch.pdf",width=12,height=8)
plot(LibraryBatch.hclust, main="Cluster Dendrogram", xlab="Labrary batch", ylab="Euclidean distance")
rect.hclust(LibraryBatch.hclust,k=18)
dev.off()

## RNAIsolationBatch cluster by hclust
RNAIsolationBatch<-matrix(as.numeric(as.Date(meta$RNAIsolationBatch)), ncol=1)
rownames(RNAIsolationBatch)<-meta$RNAIsolationBatch
RNAIsolationBatch<-unique(RNAIsolationBatch)
RNAIsolationBatch.dist<-dist(RNAIsolationBatch,method="euclidean")
RNAIsolationBatch.hclust<-hclust(RNAIsolationBatch.dist, method="median")
RNAIsolationBatch.id<-cutree(RNAIsolationBatch.hclust,k=14)
pdf("hclust.RNAIsolationBatch.pdf",width=12,height=8)
plot(RNAIsolationBatch.hclust, main="Cluster Dendrogram", xlab="Labrary batch", ylab="Euclidean distance")
rect.hclust(RNAIsolationBatch.hclust,k=14)
dev.off()

## output formated meta information
meta$libraryBatchClustered<-rep("",nrow(meta))
for(i in 1:nrow(meta)){
    meta$libraryBatchClustered[i]<-paste("B",LibraryBatch.id[meta$LibraryBatch[i]],sep="")
}
meta$RNAIsolationBatchClustered<-rep("",nrow(meta))
for(i in 1:nrow(meta)){
    meta$RNAIsolationBatchClustered[i]<-paste("B",RNAIsolationBatch.id[meta$RNAIsolationBatch[i]],sep="")
}
rownames(meta)<-meta$BID
write.table(meta, file="meta2.txt", sep="\t", row.names=F, col.names=T, quote=F)

meta$RIN_square <- meta$RIN^2
meta$ageDeath_square <- meta$ageDeath^2

###########################################
##--- Read RNA quantification data   ----##
##--- log2(CPM) normalization        ----##
###########################################

#read raw count data and annotation file
count<-read.table("raw.count",head=T,row.names=1)
annotation = read.csv("annotation.gene.gencodeV19.csv")

# assess for Sample Swaps by XIST and Y chromosome
mds = cmdscale(dist(t(log2(0.001 + count[annotation$chr=="chrY",]))))
xist = log2(0.001+count["ENSG00000229807",])

col.blue = rgb(t(col2rgb("blue")),alpha=50,maxColorValue = 255); col.pink=rgb(t(col2rgb("pink")),alpha=50,maxColorValue = 255)
sex_col = rep(col.blue, times=nrow(mds)); sex_col[meta$Sex=="F"] =col.pink
plot(xist, mds[,1], col=sex_col,pch=19)

tree = hclust(dist(cbind(xist,mds[,1])),"average")
sex_pred= factor(gsub(2, "F", gsub("1","M", cutree(tree,k=2))))
plot(xist, mds[,1], col=(sex_pred),pch=19)

discordant = (meta$sex=="M" & sex_pred=="F") | (meta$sex=="F" & sex_pred=="M")

#remove sex mismatch sample
count2<-count[,!discordant]

#log2(CPM) normalization
library(limma)
log2cpm<-voom(count2)$E

write.table(log2cpm,file="log2cpm",sep="\t",row.names=T,col.names=T,quote=F)

###########################################
##---  filter                        ----##
###########################################

## keep genes with at least 1 CPM in at least 25% of the individuals
library(DESeq2)
genes_to_keep = apply(log2cpm>=0,1,sum) >= round(0.25 * ncol(log2cpm))
log2cpm.fgene = log2cpm[genes_to_keep,]
annot<-annotation[annotation$gene_id %in% rownames(log2cpm.fgene),]
brainExpressedNoMT<-annot[annot$chr!="chrM"&annot$chr!="chrY"&annot$chr!="chrX",]
log2cpm.fgene = log2cpm[brainExpressedNoMT$gene_id,]
write.table(log2cpm.fgene, file="log2cpm.fgene", sep="\t", row.names=T, quote=F,col.names=T)

## pca
library(ggfortify)
library(scales)
pdf("log2cpm.fgene.pca.pdf")
pc<-prcomp(t(log2cpm.fgene))
#autoplot(pc)
eigs<-pc$sdev^2 # calculate how much variance explained by each PC.
eigsP1<-percent(eigs[1]/sum(eigs))
eigsP2<-percent(eigs[2]/sum(eigs))
plot(pc$x[,1],pc$x[,2],pch=19,col="grey",main="PCA",xlab=paste("PC1 (",eigsP1,")",sep=""),ylab=paste("PC2 (",eigsP2,")",sep=""))
dev.off()

## Remove outlier samples
## Code modified from Michael Gandal's Github: https://github.com/mgandal/TSC_MIA_RNAseq/blob/master/code/step4a_Expression_Analysis.R
## Original paper: Network methods for describing sample relationships in genomic datasets: application to Huntington’s disease
library(WGCNA)
normadj <- (0.5+0.5*bicor(log2cpm.fgene, use='pairwise.complete.obs'))^2
#normadj <- (0.5+0.5*cor(log2cpm.fgene))^2
netsummary <- fundamentalNetworkConcepts(normadj);
k <- netsummary$Connectivity; K <- k/max(k); Z.K <- (K-mean(K))/sqrt(var(K))
C <- netsummary$ClusterCoef; Z.C = (C - mean(C))/sqrt(var(C))
sdout <- 3
outliers <- (Z.K > mean(Z.K)+sdout*sd(Z.K))|(Z.K < mean(Z.K)-sdout*sd(Z.K))
print(paste("There are ",sum(outliers)," outliers samples based on a bicor distance sample network connectivity standard deviation above ",sdout,sep="")); print(colnames(log2cpm.fgene)[outliers]); print(table(outliers))
color<-rownames(pc$x) %in% colnames(log2cpm.fgene)[outliers]
color[which(color==FALSE)]<-"grey"
color[which(color==TRUE)]<-"red"
pdf("log2cpm.fgene.zscore.pdf")
#plot(Z.K, col = as.numeric(colData(dds)$Region), pch=19, main="Outlier detection", ylab="Network connectivity (z score)")
plot(Z.K, col = "black", pch=19, main="Outlier detection", ylab="Network connectivity (z score)")
abline(h=-sdout, lty=2)
dev.off()
pdf("log2cpm.fgene.pca.markOutlier.pdf")
plot(pc$x[,1],pc$x[,2],pch=19,col=color,main=paste("PCA (marked Z-score < -",sdout,")",sep=""),xlab=paste("PC1 (",eigsP1,")",sep=""),ylab=paste("PC2 (",eigsP2,")",sep=""))
dev.off()
log2cpm.fgene.fsample <- log2cpm.fgene[,!outliers]
write.table(log2cpm.fgene.fsample, file="log2cpm.fgene.fsample", sep="\t", row.names=T, quote=F,col.names=T)

###########################################
##--- Quantile Normalization       ------##
###########################################

## QN
library(preprocessCore)
log2cpm.fgene.fsample.qn<-normalize.quantiles(log2cpm.fgene.fsample,copy=T)  # Quantile normalization across columns
rownames(log2cpm.fgene.fsample.qn)<-rownames(log2cpm.fgene.fsample)
colnames(log2cpm.fgene.fsample.qn)<-colnames(log2cpm.fgene.fsample)
write.table(combat_edata, file="log2cpm.fgene.fsample.qn.combat", sep="\t", row.names=T, quote=F,col.names=NA)

###
#Batch Clustering
pdf("Batch_Clustering.pdf",width=15,height=10)
PC = prcomp(na.omit(t(scale(t(log2cpm.fgene.fsample.qn),scale=F))),scale=F)
PC = PC$rotation[,1:5]
library(WGCNA)
batch = model.matrix(~0+LibraryBatch+RNAseqBatch+RNAIsolationBatch, data=meta)
idx = match(rownames(batch), rownames(meta))
tree=hclust(dist((batch)),method="ward.D2")
colors=with(meta[idx,], cbind(labels2colors(LibraryBatch),
                                 labels2colors(RNAseqBatch),
                                 labels2colors(RNAIsolationBatch)))

colors = cbind(colors, numbers2colors(PC[idx,]))
plotDendroAndColors(tree,colors, groupLabels = c("LibraryBatch", "RNAseqBatch", "RNAIsolationBatch", paste0("PC",1:5)),cex.dendroLabels = .7,main="Batch Clustering")

cutsteps = seq(min(tree$height), 0.98*max(tree$height), by = (max(tree$height) - min(tree$height))/50)
r2out = numeric()
for(h in cutsteps) {
  c=as.factor(cutree(tree,h = h))
  s=0
  for(i in 1:5) s=s+summary(lm(PC[idx,1]~c))$adj.r.squared/5
  r2out=c(r2out,s)
}
plot(cutsteps, r2out)

dev.off()

## pca for quantile data
pdf("log2cpm.fgene.fsample.qn.pca.pdf")
pc<-prcomp(t(log2cpm.fgene.fsample.qn))
#autoplot(pc)
eigs<-pc$sdev^2 # calculate how much variance explained by each PC.
percVar<-eigs/sum(eigs)
eigsP1<-percent(eigs[1]/sum(eigs))
eigsP2<-percent(eigs[2]/sum(eigs))
plot(pc$x[,1],pc$x[,2],pch=19,col="grey",main="PCA (Quantile Normalized)",xlab=paste("PC1 (",eigsP1,")",sep=""),ylab=paste("PC2 (",eigsP2,")",sep=""))
dev.off()

###########################################
##---- Estimate hidden factors        ---##
###########################################

library(peer)
expr = t(as.matrix(log2cpm.fgene.fsample.qn))  # N rows and G columns, where N is the number of samples, and G is the number of genes. No column or row names.
dim(expr)
factorList=list()
residList=list()

for(nFactor in 1:1*20){
    model = PEER()  # create the model object
    PEER_setPhenoMean(model,expr)  # set the observed data
    #PEER_setNk(model,30)  # Set the hidden confounders.
    PEER_setNk(model,nFactor) # gradient number of factors
    PEER_getNk(model)
    PEER_setAdd_mean(model, TRUE)  # include an additional factor (covariate) to account for the mean expression
    ## PEER_setCovariates(model, as.matrix(meta))  # adding covariates has no effect on the model?
    #PEER_setNmax_iterations(model, 100)  # If the model is not converged after the default 1,000 iterations, and the variance of the residuals keeps decreasing, choose a higher value of iterations, e.g., 10,000.
    PEER_update(model)  # perform the inference
    factors = PEER_getX(model)  # inferred confounders
    weights = PEER_getW(model)  # their weights
    precision = PEER_getAlpha(model)     # precision (inverse variance) of the weights
    residuals = PEER_getResiduals(model) # the residual dataset
    #plot(precision)
    #PEER_plotModel(model)
    Variance<-c(); for(i in 2:21){Variance<-c(Variance,var(factors[,i]))}; Variance<-sort(Variance, decreasing=TRUE); Variance<-100*Variance/sum(Variance)
    pdf("variance-factor.pdf",width=5,height=5)
    plot(Variance,type="o",pch=19,col="red",xlab="Factors")
    dev.off()
    factors1<-t(factors)[-1,]
    colnames(factors1)<-colnames(combat_edata)
    rownames(factors1)<-paste("Factor",1:nrow(factors1),sep="")
    factorList[[nFactor]]<-factors1
    #factors2<-rbind(t(meta),factors1)
    factors2<-cbind(meta,t(factors1))
    #write.table(t(factors2), file=paste("log2cpm.fgene.fsample.qn.realign.peerCovariates.factor",nFactor,".xls",sep=""), sep="\t", row.names=T, quote=F,col.names=NA)
    write.table(factors1, file=paste("expr",nFactor,".xls",sep=""), sep="\t", row.names=T, quote=F,col.names=NA)
}

## test correlation of hidden factors and covariates
library(gplots)
rsqList<-list()
pvalList<-list()
for(nFactor in 1:1*20){
    factors1<-factorList[[nFactor]]
    rsq<-matrix(nrow=nFactor,ncol=ncol(meta))
    pval<-matrix(nrow=nFactor,ncol=ncol(meta))
    rownames(rsq)<-rownames(factors1)
    rownames(pval)<-rownames(factors1)
    colnames(rsq)<-colnames(meta)
    colnames(pval)<-colnames(meta)
    for(m in 1:nrow(factors1)){
        for(n in 1:ncol(meta)){
            colnames(meta)[n]
            mod<-model.matrix( ~ meta[,n])
            res<-summary(lm(factors1[m,] ~ mod))
            r2<-res$adj.r.squared
            p<-pf(res$fstatistic[1],res$fstatistic[2],res$fstatistic[3],lower.tail=FALSE)
            rsq[m,n]<-r2
            pval[m,n]<-p
        }
    }

    write.table(rsq,file=paste("cor.hidden-known.rSquare.factor",nFactor,".xls",sep=""),sep="\t",quote=F,col.names=NA)
    write.table(pval,file=paste("cor.hidden-known.pValue.factor",nFactor,".xls",sep=""),sep="\t",quote=F,col.names=NA)
    Lab.palette=colorRampPalette(c('white','red'),space="Lab")
    pdf(paste("cor.hidden-known.rSquare.factor",nFactor,".pdf",sep=""))
    heatmap.2(rsq,main="R-square",col=Lab.palette,density.info="none",trace="none",dendrogram="none",Colv=FALSE,Rowv=FALSE,scale="none",margins=c(12,6))
    dev.off()
    pdf(paste("cor.hidden-known.pValue.factor",nFactor,".pdf",sep=""))
    heatmap.2(-log(pval),main="-log(Pvalue)",col=Lab.palette,density.info="none",trace="none",dendrogram="none",Colv=FALSE,Rowv=FALSE,scale="none",margins=c(12,6))
    dev.off()

    rsqList[[nFactor]]<-rsq
    pvalList[[nFactor]]<-pval
}

##################################################
##- Bayesian Information Criterion (BIC) score -##
##- Akaike   Information Criterion (AIC) score -##
##################################################

colnames(log2cpm.fgene.fsample.qn)<-rownames(factors2)
d<-cbind(t(log2cpm.fgene.fsample.qn),factors2)
nGene<-nrow(log2cpm.fgene.fsample.qn)
nSample<-nrow(factors2)

## about two days for this step
covBIC<-c()
for(i in 1:nGene){
    capture.output(resBIC<-step(lm(d[,i] ~ d$CauseDeath+d$sex + d$Group+d$ageDeath +  d$RNAIsolationBatch + d$RIN + d$LibraryBatch + d$RNAseqBatch + d$ageDeath_square + d$RIN_square + d$Factor1 + d$Factor2 + d$Factor3 + d$Factor4 + d$Factor5 + d$Factor6 + d$Factor7 + d$Factor8 + d$Factor9 + d$Factor10 + d$Factor11 + d$Factor12 + d$Factor13 + d$Factor14 + d$Factor15 + d$Factor16 + d$Factor17 + d$Factor18 + d$Factor19 + d$Factor20 + d$seqPC1 + d$seqPC2 + d$seqPC3 + d$seqPC4 + d$seqPC5 + d$seqPC6 + d$seqPC7 + d$seqPC8 + d$seqPC9 + d$seqPC10+d$seqPC11+d$seqPC12+d$seqPC13+d$seqPC14), k=log(nSample), direction="both"), file=paste("BIC/log.BIC.",i,sep=""))
    covBIC<-c(covBIC, names(attr(resBIC$terms,"dataClasses"))[-1])
}

# covAIC<-c()
# for(i in 1:nGene){
#     capture.output(resAIC<-step(lm(d[,i] ~ d$BrainBank + d$Hemisphere + d$PMI + d$BrainWeight + d$YearAutopsy + d$Sex + d$Ethnicity + d$AgeDeath + d$Diagnosis + d$TissueState + d$RNAIsolationBatchClustered + d$RIN + d$ERCC_Added + d$libraryBatchClustered + d$RNAseqBatch + d$SequencingPlatform + d$PMI_square + d$BrainWeight_square + d$YearAutopsy_square + d$AgeDeath_square + d$RIN_square + d$Factor1 + d$Factor2 + d$Factor3 + d$Factor4 + d$Factor5 + d$Factor6 + d$Factor7 + d$Factor8 + d$Factor9 + d$Factor10 + d$Factor11 + d$Factor12 + d$Factor13 + d$Factor14 + d$Factor15 + d$Factor16 + d$Factor17 + d$Factor18 + d$Factor19 + d$Factor20 + d$Factor21 + d$Factor22 + d$Factor23 + d$Factor24 + d$Factor25 + d$Factor26 + d$Factor27 + d$Factor28 + d$Factor29 + d$Factor30), direction="both"), file=paste("log/log.AIC.",i,sep=""))
#     covAIC<-c(covAIC, names(attr(resAIC$terms,"dataClasses"))[-1])
# }

# Draw
phe<-colnames(factors2)
pdf("covariates.bic.pdf",width=7,height=3)
props <- table(covBIC)[paste("d$", phe, sep="")]/nGene
bp <- barplot(props,  xlab = "Covariates", ylab = "Proportion of genes decreased BIC", main="Select covariates by decreased BIC", ylim= c(0,1),col = c("blue"), las=2, cex.axis=0.5, cex.lab=0.5, cex.main=0.7, axisnames=FALSE)
#axis(1, at = bp, labels = effectsNames, xlab = "Covariates", cex.axis = 0.5, las=2)  # vertical x-axis
text(bp, par("usr")[3]-0.02, srt = 45, adj = 1,labels = phe, xpd = TRUE,cex=0.4)  # rotate 45 x-axis
text(bp, props, labels = round(props, 3), srt = 45, pos=3, cex = 0.3) # place numbers on top of bars
dev.off()

# pdf("covariates.aic.pdf",width=7,height=3)
# props <- table(covAIC)[paste("d$", phe3, sep="")]/nGene
# bp <- barplot(props,  xlab = "Covariates", ylab = "Proportion of genes decreased AIC", main="Select covariates by decreased AIC", ylim= c(0,1),col = c("blue"), las=2, cex.axis=0.5, cex.lab=0.5, cex.main=0.7, axisnames=FALSE)
# #axis(1, at = bp, labels = effectsNames, xlab = "Covariates", cex.axis = 0.5, las=2)  # vertical x-axis
# text(bp, par("usr")[3]-0.02, srt = 45, adj = 1,labels = phe3, xpd = TRUE,cex=0.4)  # rotate 45 x-axis
# text(bp, props, labels = round(props, 3), srt = 45, pos=3, cex = 0.3) # place numbers on top of bars
# dev.off()

save.image(file="RNA_processing.cpm.all.RData")
write.table(factors2,file="meta_with_peer.txt, sep="\t", row.names=T, quote=F,col.names=NA)


pdf_file<-"pdf/pyramids_finely_inside_1x2_line.pdf"
cairo_pdf(bg="grey98", pdf_file,width=12,height=9)

par(mai=c(0.2,0.1,0.8,0.1),omi=c(0.75,0.2,0.85,0.2),mfcol=c(1,2),cex=0.75,family="Lato Light",las=1)

# Import data and prepare chart
library(gdata)
x1991<-read.xls("myData/12411-0008_1991_reformatted.xlsx", encoding="latin1")
x1991<-x1991[1:nrow(x1991)-1,]

attach(x1991)

myF_married<-X6/1000
myF_unmarried<-(X5+X7+X8)/1000
myM_married<-X2/1000
myM_unmarried<-(X1+X3+X4)/1000

right<-data.frame(myF_married,myF_unmarried)
left<-data.frame(myM_married,myM_unmarried)

source("scripts/inc_pyramid.r")
mtext("1970",3,line=0,adj=0.5,cex=1,font=3)

x2010<-read.xls("myData/12411-0008_2010_reformatted.xlsx", encoding="latin1")
x2010<-x2010[1:nrow(x2010)-1,]

right_line<-myF_married+myF_unmarried
left_line<--(myM_married+myM_unmarried)

attach(x2010)

myF_married<-X6/1000
myF_unmarried<-(X5+X7+X8)/1000
myM_married<-X2/1000
myM_unmarried<-(X1+X3+X4)/1000

left<-data.frame(myM_married,myM_unmarried)
right<-data.frame(myF_married,myF_unmarried)

source("scripts/inc_pyramid.r")

lines(right_line,myB1,type="l",col="black")
lines(left_line,myB2,type="l", col="black")

mtext("2010",3,line=0,adj=0.5,cex=1,font=3)

# Titling

mtext("Age structure and married proportion of the population in Germany",3,line=2,adj=0,cex=2.25,family="Lato Black",outer=T)
mtext("all values in thousand per year of age",3,line=-0.5,adj=0,cex=1.25,font=3,outer=T)
mtext("destatis, GENESIS-Online, Tab. 12411-0008",1,line=2,adj=1.0,cex=0.95,font=3,outer=T)
mtext("Inner highlighted areas: married",1,line=2,adj=0,cex=0.95,font=3,outer=T)
dev.off()


# HPD - Highest Posterior Density (HPD) Interval

#-----8<-----
# Using boa package
ans <- boa.hpd(resultado.final[,i], alpha = 0.05)
write.csv2( ans , paste("HPD ",i,".csv", sep=""))
print( ans )

#-----8<-----

# [1] "Computing HPD Interval for NR.LGA"
# Lower Bound Upper Bound
# 0.08768426  0.09717933
# [1] "Computing HPD Interval for NR.PE"
# Lower Bound Upper Bound
# 0.02852109  0.06567756
# [1] "Computing HPD Interval for NR.CS"
# Lower Bound Upper Bound
# 0.09675619  0.28645520
# [1] "Computing HPD Interval for WHO.LGA"
# Lower Bound Upper Bound
# 0.08496027  0.09427048
# [1] "Computing HPD Interval for WHO.PE"
# Lower Bound Upper Bound
# 0.02790777  0.06400733
# [1] "Computing HPD Interval for WHO.CS"
# Lower Bound Upper Bound
# 0.09531015  0.28389315
# [1] "Computing HPD Interval for IADPSG.LGA"
# Lower Bound Upper Bound
# 0.08278797  0.09268037
# [1] "Computing HPD Interval for IADPSG.PE"
# Lower Bound Upper Bound
# 0.02743658  0.06309003
# [1] "Computing HPD Interval for IADPSG.CS"
# Lower Bound Upper Bound
# 0.09516766  0.28336441

Simulation Gestational Diabetes WHO/HPD_NR_WHO_IADPSG.r


require(rms)
set.seed(1)
n <- 20
x <- as.matrix(1:n)
#x <- cbind(1:n, (1:n)^2)
#colnames(x) <- 'age'
y <- sample(0:1, n, TRUE)
f <- lrm(y ~ x)

N <- 100
set.seed(1)
time <- rexp(N)
status <- sample(0:1, N, replace = TRUE)
S <- Surv(time, status)
x1 <- gl(2, 50)
x2 <- runif(N)
x3 <- sample(1:3, N, replace=TRUE)

ols(time ~ x1)
ols(time ~ scored(x3))
ols(time ~ catg(x3))

# Makes last colname x1 %ia% x2 which is really inconsistent:
model.matrix(~ x1 + rcs(x2) + x1 %ia% x2)
x3 <- c(rep('A', 33), rep('B', 33), rep('C', 34))
x4 <- runif(N) > 0.5
# Makes last 2 colnames x3 %ia% x2x3=B * x2,  x3 %ia% x2x3=C * x2
model.matrix(~ x3 + rcs(x2) + x3 %ia% x2)
cph(S ~ x3 + rcs(x2) + x3 %ia% x2)

ols(time ~ x1 + rcs(x2) + x1 %ia% x2)
lrm(status ~ x1 + rcs(x2) + x1 %ia% x2)
options(debug=TRUE,width=110)
cph(S ~ x1 + rcs(x2) + x1 %ia% rcs(x2))
cph(S ~ x1 + rcs(x2) + x1 %ia% x2)

cph(S ~ x1 * rcs(x2))

ols(time ~ x1 + x4)
cph(S ~ x1 + x4)
colnames(model.matrix(~ x1 + x4 + x1 %ia% x4))
cph(S ~ x1 + x4 + x1 %ia% x4)

## From https://github.com/harrelfe/rms/issues/29#issuecomment-303423887
## https://github.com/harrelfe/rms/issues/29#issuecomment-328581864
d <- expand.grid(
X1 = factor(c('05: X1 <= 178','01: X1 <= 6', '03: X1 <= 52', '05: X1 <= 178')),
X2 = factor(c('04: X2 <= 75','01: X2 <= 6', '05: X2 > 75', '05: X2 > 75')),
X3 = factor(c('04: X3 <= 552','01: X3 <= 1', '04: X3 <= 552', '06: X3 > 1313')),
rep = 1 : 100)
set.seed(1)
d$TARGET <- sample(0 : 1, nrow(d), replace=TRUE)

lrm(TARGET ~ ., data = d)
options(debug=TRUE)
cph(Surv(TARGET) ~ ., data=d)


#########################################################################################################################################
sceDefaults <- function()
    list(ncomplex = 5, ## number of complexes
         cce.iter = NA, ## number of iteration in inner loop (CCE algorithm)
         fnscale = 1, ## function scaling factor (set to -1 for maximisation)
         elitism = 1, ## controls amount of weighting in sampling towards the better parameter sets
         initsample = "latin", ## sampling scheme for initial values -- "latin" or "random"
         reltol = 1e-5, ## convergence threshold: relative improvement factor required in an SCE iteration
         tolsteps = 7, ## number of iterations within reltol to confirm convergence
         maxit = 10000, ## maximum number of iterations
         maxeval = Inf, ## maximum number of function evaluations
         maxtime = Inf, ## maximum duration of optimization in seconds
         returnpop = FALSE, ## whether to return populations from all iterations
         trace = 0, ## level of user feedback
         REPORT = 1) ## number of iterations between reports when trace >= 1

SCEoptim <- function(FUN, par, ...,
                lower = -Inf, upper = Inf,
                control = list())
{
    FUN <- match.fun(FUN)
    stopifnot(is.numeric(par))
    stopifnot(length(par) > 0)
    stopifnot(is.numeric(lower))
    stopifnot(is.numeric(upper))
    ## allow `lower` or `upper` to apply to all parameters
    if (length(lower) == 1)
        lower <- rep(lower, length = length(par))
    if (length(upper) == 1)
        upper <- rep(upper, length = length(par))
    stopifnot(length(lower) == length(par))
    stopifnot(length(upper) == length(par))

    ## determine number of variables to be optimized
    NDIM <- length(par)

    ## update default options with supplied options
    stopifnot(is.list(control))
    control <- modifyList(sceDefaults(), control)
    isValid <- names(control) %in% names(sceDefaults())
    if (any(!isValid))
        stop("unrecognised options: ",
             toString(names(control)[!isValid]))

    returnpop <- control$returnpop
    trace <- control$trace
    nCOMPLEXES <- control$ncomplex
    CCEITER <- control$cce.iter
    MAXIT <- control$maxit
    MAXEVAL <- control$maxeval

    ## recommended number of CCE steps in Duan et al 1994:
    if (is.na(CCEITER))
        CCEITER <- 2 * NDIM + 1

    if (is.finite(MAXEVAL)) {
        ## upper bound on number of iterations to reach MAXEVAL
        MAXIT <- min(MAXIT, ceiling(MAXEVAL / (nCOMPLEXES * CCEITER)))
    }

    ## define number of points in each complex
    nPOINTS_COMPLEX <- 2 * NDIM + 1

    ## define number of points in each simplex
    nPOINTS_SIMPLEX <- NDIM+1

    ## define total number of points
    nPOINTS <- nCOMPLEXES * nPOINTS_COMPLEX

    ## initialize counters
    funevals <- 0

    costFunction <- function(FUN, par, ...)
    {
        ## check lower and upper bounds
        i <- which(par < lower)
        if (any(i)) {
            i <- i[1]
            return( 1e12 + (lower[i] - par[i]) * 1e6 )
        }
        i <- which(par > upper)
        if (any(i)) {
            i <- i[1]
            return( 1e12 + (par[i] - upper[i]) * 1e6 )
        }
        funevals <<- funevals + 1
        result <- FUN(par, ...) * control$fnscale
        if (is.na(result))
            result <- 1e12
        result
    }

    simplexStep <- function(P, FAC)
    {
        ## Extrapolates by a factor FAC through the face of the simplex across from
        ## the highest (i.e. worst) point.
        worst <- nPOINTS_SIMPLEX
        centr <- apply(P[-worst,,drop=FALSE], 2, mean)
        newpar <- centr*(1-FAC) + P[worst,]*FAC
        newpar
    }

    ## initialize population matrix
    POPULATION <- matrix(as.numeric(NA), nrow = nPOINTS, ncol = NDIM)
    if (!is.null(names(par)))
        colnames(POPULATION) <- names(par)
    POP.FITNESS <- numeric(length = nPOINTS)
    POPULATION[1,] <- par

    ## generate initial parameter values by random uniform sampling
    finitelower <- ifelse(is.infinite(lower), -(abs(par)+2)*5, lower)
    finiteupper <- ifelse(is.infinite(upper), +(abs(par)+2)*5, upper)
    if (control$initsample == "latin") {
        for (i in 1:NDIM) {
            tmp <- seq(finitelower[i], finiteupper[i], length = nPOINTS-1)
            tmp <- jitter(tmp, factor = 2)
            tmp <- pmax(finitelower[i], pmin(finiteupper[i], tmp))
            POPULATION[-1,i] <- sample(tmp)
        }
    } else {
        for (i in 1:NDIM)
            POPULATION[-1,i] <- runif(nPOINTS-1, finitelower[i], finiteupper[i])
    }

    ## only store all iterations if requested -- could be big!
    if (!is.finite(MAXIT)) {
        MAXIT <- 10000
        warning("setting maximum iterations to 10000")
    }
    if (returnpop) {
        POP.ALL <- array(as.numeric(NA), dim = c(nPOINTS, NDIM, MAXIT))
        if (!is.null(names(par)))
            dimnames(POP.ALL)[[2]] <- names(par)
    }
    POP.FIT.ALL <- matrix(as.numeric(NA), ncol = nPOINTS, nrow = MAXIT)
    BESTMEM.ALL <- matrix(as.numeric(NA), ncol = NDIM, nrow = MAXIT)
    if (!is.null(names(par)))
        colnames(BESTMEM.ALL) <- names(par)

    ## the output object
    obj <- list()
    class(obj) <- c("SCEoptim", class(obj))
    obj$call <- match.call()
    obj$control <- control

    EXITFLAG <- NA
    EXITMSG <- NULL

    ## initialize timer
    tic <- as.numeric(Sys.time())
    toc <- 0

    ## calculate cost for each point in initial population
    for (i in 1:nPOINTS)
        POP.FITNESS[i] <- costFunction(FUN, POPULATION[i,], ...)

    ## sort the population in order of increasing function values
    idx <- order(POP.FITNESS)
    POP.FITNESS <- POP.FITNESS[idx]
    POPULATION <- POPULATION[idx,,drop=FALSE]

    ## store one previous iteration only
    POP.PREV <- POPULATION
    POP.FIT.PREV <- POP.FITNESS

    if (returnpop) {
        POP.ALL[,,1] <- POPULATION
    }
    POP.FIT.ALL[1,] <- POP.FITNESS
    BESTMEM.ALL[1,] <- POPULATION[1,]

    ## store best solution from last two iterations
    prevBestVals <- rep(Inf, control$tolsteps)
    prevBestVals[1] <- POP.FITNESS[1]

    ## for each iteration...
    i <- 0
    while (i < MAXIT) {

        i <- i + 1

        ## The population matrix POPULATION will now be rearranged into complexes.

        ## For each complex ...
        for (j in 1:nCOMPLEXES) {

            ## construct j-th complex from POPULATION

            k1 <- 1:nPOINTS_COMPLEX
            k2 <- (k1-1) * nCOMPLEXES + j

            COMPLEX <- POP.PREV[k2,,drop=FALSE]
            COMPLEX_FITNESS <- POP.FIT.PREV[k2]

            ## Each complex evolves a number of steps according to the competitive
            ## complex evolution (CCE) algorithm as described in Duan et al. (1992).
            ## Therefore, a number of 'parents' are selected from each complex which
            ## form a simplex. The selection of the parents is done so that the better
            ## points in the complex have a higher probability to be selected as a
            ## parent. The paper of Duan et al. (1992) describes how a trapezoidal
            ## probability distribution can be used for this purpose.

            for (k in 1:CCEITER) {

                ## select simplex by sampling the complex

                ## sample points with "trapezoidal" i.e. linear probability
                weights <- rev(ppoints(nPOINTS_COMPLEX))
                ## 'elitism' parameter can give more weight to the better results:
                weights <- weights ^ control$elitism
                LOCATION <- sample(seq(1,nPOINTS_COMPLEX), size = nPOINTS_SIMPLEX,
                                   prob = weights)

                LOCATION <- sort(LOCATION)

                ## construct the simplex
                SIMPLEX <- COMPLEX[LOCATION,,drop=FALSE]
                SIMPLEX_FITNESS <- COMPLEX_FITNESS[LOCATION]

                worst <- nPOINTS_SIMPLEX

                ## generate new point for simplex

                ## first extrapolate by a factor -1 through the face of the simplex
                ## across from the high point,i.e.,reflect the simplex from the high point
                parRef <- simplexStep(SIMPLEX, FAC = -1)
                fitRef <- costFunction(FUN, parRef, ...)

                ## check the result
                if (fitRef <= SIMPLEX_FITNESS[1]) {
                    ## gives a result better than the best point,so try an additional
                    ## extrapolation by a factor 2
                    parRefEx <- simplexStep(SIMPLEX, FAC = -2)
                    fitRefEx <- costFunction(FUN, parRefEx, ...)
                    if (fitRefEx < fitRef) {
                        SIMPLEX[worst,] <- parRefEx
                        SIMPLEX_FITNESS[worst] <- fitRefEx
                        ALGOSTEP <- 'reflection and expansion'
                    } else {
                        SIMPLEX[worst,] <- parRef
                        SIMPLEX_FITNESS[worst] <- fitRef
                        ALGOSTEP <- 'reflection'
                    }
                } else if (fitRef >= SIMPLEX_FITNESS[worst-1]) {
                    ## the reflected point is worse than the second-highest, so look
                    ## for an intermediate lower point, i.e., do a one-dimensional
                    ## contraction
                    parCon <- simplexStep(SIMPLEX, FAC = -0.5)
                    fitCon <- costFunction(FUN, parCon, ...)
                    if (fitCon < SIMPLEX_FITNESS[worst]) {
                        SIMPLEX[worst,] <- parCon
                        SIMPLEX_FITNESS[worst] <- fitCon
                        ALGOSTEP <- 'one dimensional contraction'
                    } else {
                        ## can't seem to get rid of that high point, so better contract
                        ## around the lowest (best) point
                        SIMPLEX <- (SIMPLEX + rep(SIMPLEX[1,], each=nPOINTS_SIMPLEX)) / 2
                        for (k in 2:NDIM)
                            SIMPLEX_FITNESS[k] <- costFunction(FUN, SIMPLEX[k,], ...)
                        ALGOSTEP <- 'multiple contraction'
                    }
                } else {
                    ## if better than second-highest point, use this point
                    SIMPLEX[worst,] <- parRef
                    SIMPLEX_FITNESS[worst] <- fitRef
                    ALGOSTEP <- 'reflection'
                }

                if (trace >= 3) {
                    message(ALGOSTEP)
                }

                ## replace the simplex into the complex
                COMPLEX[LOCATION,] <- SIMPLEX
                COMPLEX_FITNESS[LOCATION] <- SIMPLEX_FITNESS

                ## sort the complex
                idx <- order(COMPLEX_FITNESS)
                COMPLEX_FITNESS <- COMPLEX_FITNESS[idx]
                COMPLEX <- COMPLEX[idx,,drop=FALSE]
            }

            ## replace the complex back into the population
            POPULATION[k2,] <- COMPLEX
            POP.FITNESS[k2] <- COMPLEX_FITNESS
        }

        ## At this point, the population was divided in several complexes, each of which
        ## underwent a number of iteration of the simplex (Metropolis) algorithm. Now,
        ## the points in the population are sorted, the termination criteria are checked
        ## and output is given on the screen if requested.

        ## sort the population
        idx <- order(POP.FITNESS)
        POP.FITNESS <- POP.FITNESS[idx]
        POPULATION <- POPULATION[idx,,drop=FALSE]
        if (returnpop) {
            POP.ALL[,,i] <- POPULATION
        }
        POP.FIT.ALL[i,] <- POP.FITNESS
        BESTMEM.ALL[i,] <- POPULATION[1,]

        curBest <- POP.FITNESS[1]

        ## end the optimization if one of the stopping criteria is met

        prevBestVals <- c(curBest, head(prevBestVals, -1))
        reltol <- control$reltol
        if (all(abs(diff(prevBestVals)) <= reltol * (abs(curBest)+reltol))) {
            EXITMSG <- 'Change in solution over [tolsteps] less than specified tolerance (reltol).'
            EXITFLAG <- 0
        }

        ## give user feedback on screen if requested
        if (trace >= 1) {
            if (i == 1) {
                message(' Nr Iter Nr Fun Eval Current best function Current worst function')
            }
            if ((i %% control$REPORT == 0) || (!is.na(EXITFLAG)))
            {
                message(sprintf(' %5.0f %5.0f %12.6g %12.6g',
                        i, funevals, min(POP.FITNESS), max(POP.FITNESS)))
                if (trace >= 2)
                    message("parameters: ", toString(signif(POPULATION[1,], 3)))
            }
        }

        if (!is.na(EXITFLAG))
            break

        if ((i >= control$maxit) || (funevals >= control$maxeval)) {
            EXITMSG <- 'Maximum number of function evaluations or iterations reached.'
            EXITFLAG <- 1
            break
        }

        toc <- as.numeric(Sys.time()) - tic
        if (toc > control$maxtime) {
            EXITMSG <- 'Exceeded maximum time.'
            EXITFLAG <- 2
            break
        }

        ## go to next iteration
        POP.PREV <- POPULATION
        POP.FIT.PREV <- POP.FITNESS
    }
    if (trace >= 1)
        message(EXITMSG)

    ## return solution
    obj$par <- POPULATION[1,]
    obj$value <- POP.FITNESS[1]
    obj$convergence <- EXITFLAG
    obj$message <- EXITMSG

    ## store number of function evaluations
    obj$counts <- funevals
    ## store number of iterations
    obj$iterations <- i
    ## store the amount of time taken
    obj$time <- toc

    if (returnpop) {
        ## store information on the population at each iteration
        obj$POP.ALL <- POP.ALL[,,1:i]
        dimnames(obj$POP.ALL)[[3]] <- paste("iteration", 1:i)
    }
    obj$POP.FIT.ALL <- POP.FIT.ALL[1:i,]
    obj$BESTMEM.ALL <- BESTMEM.ALL[1:i,]

    obj
}


# This program computes and outputs the Bonferroni-p outliers of a time series generated by a linear model of flux
# against a 2nd degree polynomial of time. The input format is a two column .csv (time, flux) and may include
# restrictions on the indices to use to account for jumps in flux. After finding Bonferroni adjusted outliers at the
# alpha = .05 level the element is removed and the test is conducted again with a new model. When the program is complete
# a separate an ID line is printed into a separate file

# The output is placed in a .csv file with two columns (outlier_time, outlier_bonferroniP)

args = commandArgs(trailingOnly=TRUE)
file_in <- args[1]
first_index <- args[2]
last_index <- args[3]
file_out <- args[4]
file_lock <- args[5]

data = read.csv(file_in, header=FALSE)
time <- data$V1[first_index:last_index]
flux <- data$V2[first_index:last_index]
time_squared <- time * time

done <- FALSE
sink(file_out)
while(!done) {
	model = lm(flux ~ time + time_squared)

	# This is a terrible way to print out the label and know the index
	# TODO: Figure out how to get the index out of each test$bonf.p[i] value
	test_times = car::outlierTest(model, label=time)

	# TODO: Figure out in what format these elements are stored
	name <- names(test_times$bonf.p[1])
	value <- test_times$bonf.p[1]

	if(!is.na(name) & value < 1) {
		cat(name, ",", value, "\n", sep="", labels="")

		target_time <- as.integer(name)
		index_to_remove <- match(c(target_time), time)
		time <- time[-c(index_to_remove)]
		flux <- flux[-c(index_to_remove)]
		time_squared <- time_squared[-c(index_to_remove)]
	}
	else {
		done = TRUE
	}
}

sink(file_lock)
cat("locked", "\n")


####### Setup #######

library(tidyverse)
library(ggplot2)
library(grid)
library(gridExtra)
library(lme4)
library(lmerTest)
library(nlme)
library(scales)
library(readr)
library(forecast)
library(robustlmm)
library(MuMIn)
library(mvtnorm)

vColors = c("#eb0087","#554696","#d2d2d2","#08919E")

####### Data Transformation #######

dfData = read.delim("TumourSize.txt", sep = ",")

dfData = dfData[-1] # Remove X column

dfData$volume = dfData$volume %>% log() # apply log to volume

dfData$date = dfData$date %>% as.Date() # Change from factor to date

dfData["daydiff"] = NA # New column with days difference from starting date

for(i in levels(dfData$mouse)){

  dfData$daydiff[dfData$mouse == i] = difftime( dfData$date[dfData$mouse == i], min(dfData$date[dfData$mouse == i]), unit = "days")

}

### Section for Plots before combining groups ###

p0 =
ggplot(data = dfData,aes(y = volume, x = group)) +
  geom_boxplot(fill = vColors[1:3], alpha = 0.6, color= vColors[1:3]) +
  theme_minimal() +
  xlab("Group") +
  ylab("mm³ Volume (log)") # Plot for Volume distr. inside of groups

lAnova = summary(aov(volume ~ group, data = dfData))

lAnovaControl = summary(aov(volume ~ group, data = dfData[dfData$group != "Treatment",]))

###

dfData$group = as.character(dfData$group)

v3SplitGroups = dfData$group

dfData$group[which(dfData$group == "Control I" | dfData$group == "Control II")] = "Control" # Set both groups equal

dfData$group = as.factor(dfData$group)

contrasts(dfData$group) = contr.treatment(2, base = 1) # "Control" is now baseline group

summary(dfData)

####### Descriptive Analysis #######

### Linearity of the relation between the covariates and the response (Correlation) ###

p1 =
  ggplot(data = dfData,aes(y = volume, x = daydiff, color = v3SplitGroups)) +
  geom_point() +
  scale_color_manual(values=vColors[1:4])+
  geom_smooth(aes(color = v3SplitGroups), method='lm',formula=y~x, se=FALSE) +
  theme_minimal() +
  xlab("Passed Days") +
  ylab("mm³ Volume (log)")

p2 =
  ggplot(data = dfData,aes(y = volume, x = daydiff, color = group)) +
  geom_point() +
  scale_color_manual(values=vColors[1:2])+
  geom_smooth(aes(color = group), method='lm',formula=y~x, se=FALSE) +
  theme_minimal() +
  xlab("Passed Days") +
  ylab("mm³ Volume (log)")

grid.arrange(p1,p2, nrow = 1)

cor(dfData[c("volume", "daydiff")])

### Equal variance of the responses around the different factor's levels (Boxplot) (Anova) ###

lAnova # Anova for 3 groups
lAnovaControl # Anova only between Control Group 1 and 2
summary(aov(volume ~ group, data = dfData)) #Anova for 2 Groups
summary(aov(volume ~ mouse, data = dfData)) #Anova for Mice

p3 =
  ggplot(data = dfData,aes(y = volume, x = group)) +
  geom_boxplot(fill = vColors[1:2], alpha = 0.6, color= vColors[1:2]) +
  theme_minimal() +
  xlab("Group") +
  ylab("mm³ Volume (log)")

p4=
  ggplot(data = dfData,aes(y = volume, x = mouse)) +
  geom_boxplot(fill = vColors[3], alpha = 0.6, color= vColors[2]) +
  theme_minimal() +
  xlab("Mouse") +
  ylab("mm³ Volume (log)")

grid.arrange(p0, p3,p4, layout_matrix = rbind(c(1,2),c(3,3)))

### Presence or absence of interactions between the different "explanatory variables" (Interaction plot) ###

par(mfrow=c(1,2))
interaction.plot(dfData$group, dfData$daydiff, response = dfData$volume, legend = FALSE)
interaction.plot(dfData$mouse, dfData$daydiff, response = dfData$volume, legend = FALSE)

### Correlation Analysis for Random effects ###

plot(groupedData(volume~ daydiff|group,data=dfData,order.groups=F),inner = dfData$mouse, ylab = "log of Volume", key = FALSE)

### Outliers (Boxplot or Scatterplot) ###

p5 =
  ggplot(data = dfData,aes(y = volume, x = group)) +
  geom_jitter(fill = vColors[1], alpha = 0.6, color= vColors[1]) +
  theme_minimal() +
  xlab("Group") +
  ylab("mm³ Volume (log)")

p6 =
  ggplot(data = dfData,aes(y = volume, x = as.factor(daydiff))) +
  geom_boxplot(fill = vColors[2], alpha = 0.6, color= vColors[2]) +
  theme_minimal() +
  xlab("Passed Days") +
  ylab("mm³ Volume (log)")

p7 =
  ggplot(data = dfData,aes(y = volume, x = mouse)) +
  geom_boxplot(fill = vColors[3], alpha = 0.6, color= vColors[1]) +
  theme_minimal() +
  xlab("Mouse") +
  ylab("mm³ Volume (log)")

grid.arrange(p5, p6,p7, layout_matrix = rbind(c(1,2),c(3,3)))

### Normality (Given a Group or Marginal) (qqplot within groups) ###

par(mfrow=c(1,4))

qqnorm(exp(dfData$volume),pch=16,bty='n',main='Volume', col = vColors[3], ylab = "Quantiles of mm³")
qqline(exp(dfData$volume),lwd=2,col= vColors[1])

qqnorm(dfData$volume,pch=16,bty='n',main='Log Volume', col = vColors[3], ylab = "Quantiles of log mm³")
qqline(dfData$volume,lwd=2,col= vColors[1])

qqnorm(dfData$volume[dfData$group == "Control"],pch=16,bty='n',main='Log Volume within Control', col = vColors[3], ylab = "Quantiles of log mm³ for Control Group")
qqline(dfData$volume[dfData$group == "Control"],lwd=2,col= vColors[2])

qqnorm(dfData$volume[dfData$group == "Treatment"],pch=16,bty='n',main='Log Volume within Treatment', col = vColors[3], ylab = "Quantiles of log mm³ for Treatment Group")
qqline(dfData$volume[dfData$group == "Treatment"],lwd=2,col= vColors[2])


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  y = runif(10)

  x_degen = x
  x_degen[, 3] = x[, 1]

  lm = lm.fit(x, y)$coefficients
  lm_degen = lm.fit(x_degen, y)$coefficients
} else {
  x = NULL
  x_degen = NULL
  y = NULL
}

dx = expand(x)
dx_degen = expand(x_degen)
dy = expand(y)

lm_test = lm_coefs(dx, dy)
### TODO
# lm_degen_test = lm_coefs(dx_degen, dy)

comm.print(all.equal(lm, lm_test))
# comm.print(all.equal(lm_degen, lm_degen_test))

finalize()


-- HASKELL

-- $ ghci 		#invoca intèrpret Prelude de Haskell
> 2 + 2
4
> 2 * 2
4

* 4 2

>2 == 2
True
>2 /= 2
True
-- @
-- OPERATORS: + - * / div **  ^
-- |  / -> divisió entera
-- | div -> divisió fraccionaria
--@

COMPS:  && || not (AND/OR/NOT)

Decimals POINT: 2.333333333
CHAR: 'a'
STRING (list chars): "SEND NUDES"

:t 'A' 			-- "Quin és el tipus de 'A' ? "
'A' :: Char 	--A és de tipus Char

:t "A" 			--"Quin és el tipus de 'A' ? "
'A' :: [Char] 	--A és de tipus List<Char>

:t 2==4 			--"Quin és el tipus de 2==4  ? "
2==4 :: Bool 		--A és de tipus Bool

:t 5				--"Quin és el tipus de 5 ? "
5 :: Num t => t 	--A és de tipus Numeric (com una interface de Java)

:t (5::Int)				--"Quin és el tipus de (5::Int) ? "
(5::Int) :: Int 		--A és de tipus Int

:t (5::Integer)				--"Quin és el tipus de (5::Integer) ? "
(5::Integer) :: Integer 	--A és de tipus Integer

	-- PROTIP: Definir els tipus prèviament a la programació

FUNCIONS: <NAME> <arg1> <arg2> .. <argN>  --SEPARATS ENTRE ESPAIS

--A haskell totes les funcions tenen un parametre

Int :: Int -> Int -> Int 		======>		Int :: Int -> (Int -> Int)

> (*) 2 3 --Operadors com a multiplicadors
6

dobla = (*) 2 --No és una assignació, però una definició

>dobla 6
12

--FITXERS *.hs
> :r --reload

-- Llistes, TOTES homogenies
>[1, 2, 4]
[1,2,4]

>:t [1, 2, 4]
[1, 2, 4] :: Num t -> [t]

>[4, 3, 9]
[4,3,9]

>[]
[]

> 9:[] --Push front (op recursiva)
[9]
> 5:9:[]
[5,9]

>head [1..10]
1

>tail [1..10]
[2,3,4,5,6,7,8,9,10]

>init [1..10]
[1,2,3,4,5,6,7,8,9]

> [1..10]++[5..10] --concat

[1,2,3,4,5,6,7,8,9,10,5,6,7,8,9,10]


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(1:30, 10)
  c_tf = scale(x, TRUE, FALSE)
  s_tf = scale(x, FALSE, TRUE)
  cs_tf = scale(x, TRUE, TRUE)
} else {
  x = NULL
}

dx = expand(x)

c_tf_test = collapse(scale(dx, TRUE, FALSE))
s_tf_test = collapse(scale(dx, FALSE, TRUE))
cs_tf_test = collapse(scale(dx, TRUE, TRUE))

comm.print(all.equal(c_tf, c_tf_test))
comm.print(all.equal(s_tf, s_tf_test))
comm.print(all.equal(cs_tf, cs_tf_test))

finalize()


 DGTCON Example Program Results

 Estimate of condition number =   9.27E+01


# Load in the tidyverse package
library(tidyverse)

# Read datasets/yearly_deaths_by_clinic.csv into yearly
yearly <- read_csv('datasets/yearly_deaths_by_clinic.csv', col_names=TRUE)

# Print out yearly
yearly

library(testthat)
library(IRkernel.testthat)
run_tests({
    test_that("Read in data correctly.", {
        expect_is(yearly, "tbl_df",
            info = 'You should use read_csv (with an underscore) to read "datasets/yearly_deaths_by_clinic.csv" into yearly.')
    })

    test_that("Read in data correctly.", {
        yearly_temp <- read_csv('datasets/yearly_deaths_by_clinic.csv')
        expect_equivalent(yearly, yearly_temp,
            info = 'yearly should contain the data in "datasets/yearly_deaths_by_clinic.csv"')
    })
})

# Adding a new column to yearly with proportion of deaths per no. births
yearly <- yearly %>% mutate(proportion_deaths = deaths / births)

# Print out yearly
yearly

run_tests({
    test_that("A proportion_deaths column exists", {
        expect_true("proportion_deaths" %in% names(yearly),
            info = 'yearly should have the new column proportion_deaths')
    })

    test_that("Read in data correctly.", {
        yearly_temp <- read_csv('datasets/yearly_deaths_by_clinic.csv') %>%
          mutate(proportion_deaths = deaths / births)
        expect_equivalent(yearly, yearly_temp,
            info = 'proportion_deaths should be calculated as deaths / births')
    })
})

# Setting the size of plots in this notebook
options(repr.plot.width=7, repr.plot.height=4)

# Plot yearly proportion of deaths at the two clinics
ggplot(yearly, aes(x = year, y = proportion_deaths, col = clinic)) +
geom_line()

run_tests({
    test_that("The right columns are plotted", {
        mappings <- str_replace(as.character(last_plot()$mapping), "~", "")
        expect_true(all(c("year", "proportion_deaths", "clinic") %in% mappings),
                    info = "year should be on the x-axis, proportion_deaths should be on the y-axis, and clinic should be mapped to color.")
    })
})

# Read datasets/monthly_deaths.csv into monthly
monthly <- read_csv("datasets/monthly_deaths.csv")

# Adding a new column with proportion of deaths per no. births
monthly <- monthly %>% mutate(proportion_deaths = deaths / births)

# Print out the first rows in monthly
head(monthly)

run_tests({

   test_that("Read in data correctly.", {
        expect_is(monthly, "tbl_df",
            info = 'You should use read_csv (with an underscore) to read "datasets/monthly_deaths.csv" into monthly.')
    })

    test_that("Read in monthly correctly.", {
        monthly_temp <- read_csv("datasets/monthly_deaths.csv")
        expect_true(all(names(monthly_temp) %in% names(monthly)),
            info = 'monthly should contain the data in "datasets/monthly_deaths.csv"')
    })

    test_that("proportion_death is calculated correctly.", {
        monthly_temp <- read_csv("datasets/monthly_deaths.csv")
        monthly_temp <- monthly_temp %>%
          mutate(proportion_deaths = deaths / births)
        expect_equivalent(monthly, monthly_temp,
            info = 'proportion_deaths should be calculated as deaths / births')
    })
})

# Plot monthly proportion of deaths
ggplot(monthly, aes(x = date, y = proportion_deaths)) +
geom_line() +
labs(x = "Date", y = "proportion of deaths")

run_tests({
    test_that("The right columns are plotted", {
        mappings <- str_replace(as.character(last_plot()$mapping), "~", "")
        expect_true(all(c("date", "proportion_deaths") %in% mappings),
            info = "date should be on the x-axis, proportion_deaths on the y-axis")
    })
})

# From this date handwashing was made mandatory
handwashing_start = as.Date('1847-06-01')

# Add a TRUE/FALSE column to monthly called handwashing_started
monthly <- monthly %>%
mutate(handwashing_started = ifelse(date >= handwashing_start, TRUE, FALSE))

# Plot monthly proportion of deaths before and after handwashing
ggplot(monthly, aes(x = date, y = proportion_deaths, col = handwashing_started)) +
geom_line()

run_tests({
    test_that("handwashing_started has been defined", {
        expect_true("handwashing_started" %in% names(monthly),
            info = 'monthly should contain the column handwashing_started.')
    })

    test_that("there are 22 rows where handwashing_started is TRUE", {
        expect_equal(22, sum(monthly$handwashing_started),
            info = 'handwashing_started should be a TRUE/FALSE column where the rows where handwashing was enforced are set to TRUE.')
    })

    test_that("The right columns are plotted", {
        mappings <- str_replace(as.character(last_plot()$mapping), "~", "")
        expect_true(all(c("date", "proportion_deaths", "handwashing_started") %in% mappings),
            info = 'date should be on the x-axis, proportion_deaths on the y-axis, and handwashing_started should be mapped to color.')
    })
})

# Calculating the mean proportion of deaths
# before and after handwashing.

monthly_summary <- monthly %>%
group_by(handwashing_started) %>%
summarise(mean_proportion_deaths = mean(proportion_deaths))

# Printing out the summary.
monthly_summary

run_tests({
    test_that("mean_proportion_deaths was calculated correctly", {
        flat_summary <- as.numeric(unlist(monthly_summary))
        handwashing_start = as.Date('1847-06-01')
        monthly_temp <- read_csv("datasets/monthly_deaths.csv") %>%
          mutate(proportion_deaths = deaths / births) %>%
          mutate(handwashing_started = date >= handwashing_start) %>%
          group_by(handwashing_started) %>%
          summarise(mean_proportion_deaths = mean(proportion_deaths))
        expect_true(all(monthly_temp$mean_proportion_deaths %in% flat_summary),
            info = 'monthly_summary should contain the mean monthly proportion of deaths before and after handwashing was enforced.')
    })
})

# Calculating a 95% Confidence intrerval using t.test
test_result <- t.test( proportion_deaths ~ handwashing_started, data = monthly)
test_result

run_tests({
    test_that("the confidence intervals match", {
        temp_test_result <- t.test( proportion_deaths ~ handwashing_started, data = monthly)
        expect_equivalent(test_result$conf.int, temp_test_result$conf.int,
            info = 'The t-test should be calculated with proportion_deaths as a function of handwashing_started.')
    })
})

# The data Semmelweis collected points to that:
doctors_should_wash_their_hands <- TRUE

run_tests({
    test_that("The project is finished.", {
        expect_true(doctors_should_wash_their_hands,
            info = "Semmelweis would argue that doctors_should_wash_their_hands should be TRUE .")
    })
})

R/Projects/Dr. Semmelweis and the discovery of handwashing/Dr. Semmelweis and the discovery of handwashing.r


########################################################################
#                                                                      #
#   finite-map.rb                                                      #
#                                                                      #
########################################################################
=begin
[((<index-ja|URL:index-ja.html>))]
[((<finite-set-ja|URL:finite-set-ja.html>))]
((<Algebra::Map>))

= Algebra::Map
((*写像クラス*))

写像を表現するクラスです。

== ファイル名:
* ((|finite-map.rb|))

== スーパークラス:
* ((|Set|))

== インクルードしているモジュール:

* ((|Powers|))

== クラスメソッド:

--- ::[]([x0 => y0, [x1 => y1, [x2 => y2, ...]]])
    ((|x0|)) の時 ((|y0|)), ((|x1|)) の時 ((|y1|)), ((|x2|)) の時 ((|y2|)),..
    という値を持つ写像を返します。

    例:
      require "finite-map"
      include Algebra
      p Map[0 => 10, 1 => 11, 2 => 12]         #=> {0 => 10, 1 => 11, 2 => 12}
      p Map[{0 => 10, 1 => 11, 2 => 12}]       #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new(0 => 10, 1 => 11, 2 => 12)     #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new({0 => 10, 1 => 11, 2 => 12})   #=> {0 => 10, 1 => 11, 2 => 12}
      p Map.new_a([0, 10, 1, 11, 2, 12])       #=> {0 => 10, 1 => 11, 2 => 12}

--- ::new([x0 => y0, [x1 => y1, [x2 => y2, ...]]])
    ((|x0|)) の時 ((|y0|)), ((|x1|)) の時 ((|y1|)), ((|x2|)) の時 ((|y|)),..
    という値を持つ写像を返します。((<::[]>)) と同じです。

--- ::new_a(a)
    配列 a の偶数番目を定義域の元、奇数番目を値域の元として定義される
    写像を生成します。

--- ::phi([t])
    空写像（定義域が空集合である写像）を返します。集合 ((|t|)) を
    引数にすると、それを定義域 ((<target>)) にします。

    例:
      p Map.phi #=> {}
      p Map.phi(Set[0, 1]) #=> {}
      p Map.phi(Set[0, 1]).target #=> {0, 1}

--- ::empty_set
    ((<::phi>)) のエイリアスです。

--- ::singleton(x, y)
    ただ一つの元で構成される集合 (({{x}})) 上で定義された ((|y|)) という
    値を取る関数を返します。

== メソッド:

--- target=(s)
    写像の値域を ((|s|)) に設定します。((<surjective?>)) などに
    利用されます。

--- codomain=(s)
    ((<target=>)) のエイリアスです。

--- target
    写像の値域を返します。

--- codomain
    ((<target>)) のエイリアスです。

--- source
    写像の定義域を返します。

    例:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11, 2 => 12]
      p m.source #=> {0, 1, 2}
      p m.target #=> nil
      m.target = Set[10, 11, 12, 13]
      p m.target #=> {10, 11, 12, 13}

--- domain
    ((<source>)) のエイリアスです。

--- phi([t])
    値域を ((|t|)) とする空の写像を返します。

--- empty_set
--- null
    ((<phi>)) のエイリアスです。

--- call(x)
    写像の ((|x|)) における値を返します。

--- act
--- []
    ((<call>)) のエイリアスです。

--- each
    すべての (({[原像, 像]})) について繰り返すイテレータです。

    例:
      require "finite-map"
      include Algebra
      Map[0 => 10, 1 => 11, 2 => 12].each do |x, y|
        p [x, y] #=> [1, 11], [0, 10], [2, 12]
      end

--- compose(other)
    ((|self|)) と ((|other|)) の合成写像を返します。

    例:
      require "finite-map"
      include Algebra
      f = Map.new(0 => 10, 1 => 11, 2 => 12)
      g = Map.new(10 => 20, 11 => 21, 12 => 22)
      p g * f #=> {0 => 20, 1 => 21, 2 => 22}

--- *
    ((<compose>)) のエイリアスです。

--- dup
    自身の複製を返します。値域の値も返します。

--- append!(x, y)
    ((|x|)) で ((|y|)) という値を取るように設定します。

    例:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11]
      m.append!(2, 12)
      p m #=> {0 => 10, 1 => 11, 2 => 12}

--- []=(x, y)
    ((<append!>)) のエイリアスです。

--- append(x, y)
    ((<dup>)) の後、((<append!>))(x, y) したものを返します。

--- include?(x)
    ((|x|)) が定義域に含まれるとき真を返します。

--- contains?(x)
    ((<include?>)) のエイリアスです。

--- member?(a)
    ((|a|)) を配列 (({[x, y]})) としたとき、((|x|)) における値が
    ((|y|)) となるとき、真を返します。

    例:
      require "finite-map"
      include Algebra
      m = Map[0 => 10, 1 => 11]
      p m.include?(1)  #=> true
      p m.member?([1, 11]) #=> true

--- has?
    member? のエイリアスです。

--- image([s])
    写像の像を返します。定義域の部分集合 ((|s|)) が与えられれば、
    ((|s|)) の像を返します。

--- inv_image(s)
    集合 ((|s|)) の原像を返します。

--- map_s
    写像の各 [原像, 像] のペアについて繰り返し、ブロックで得た
    値の集合を返します。

    例:
      require "finite-map"
      include Algebra
      p Map.new(0 => 10, 1 => 11, 2 => 12).map_s{|x, y| y - 2*x}
      #=> Set[10, 9, 8]

--- map_m
    写像の各 [原像, 像] のペアについて繰り返し、ブロックで得た
    値の配列で構成される写像を返します。

    例:
      require "finite-map"
      include Algebra
      p Map.new(0 => 10, 1 => 11, 2 => 12).map_m{|x, y| [y, x]}
      #=> {10 => 0, 11 => 1, 12 => 2}

--- inverse
    逆写像を返します。

--- inv_coset
    各像に逆像の集合を対応させる写像を返します。

    例:
      require "finite-map"
      include Algebra
      m = Map[0=>0, 1=>0, 2=>2, 3=>2, 4=>0]
      p m.inv_coset #=> {0=>{0, 1, 4}, 2=>{2, 3}}
      m.codomain = Set[0, 1, 2, 3]
      p m.inv_coset #=> {0=>{0, 1, 4}, 1=>{}, 2=>{2, 3}, 3=>{}}

--- indentity?
    恒等写像であるとき、真を返します。

--- surjective?
    全射である時、真を返します。あらかじめ ((<target>)) が指定されて
    いる必要があります。

--- injective?
    単射である時、真を返します。

--- bijective?
    全単射である時、真を返します。あらかじめ ((<target>)) が指定されて
    いる必要があります。

=end


 DSPCON Example Program Results

 Estimate of condition number =  7.57E+01


=begin
((<Algebra>))

= Algebra
((*(代数モジュール)*))

代数ライブラリ

* ((<Algebra::Polynomial|URL:polynomial-ja.html>)) (1変数多項式環クラス)
* ((<Algebra::MPolynomial|URL:m-polynomial-ja.html>)) (多変数多項式環クラス)
* ((<Algebra::ResidueClassRing|URL:residue-class-ring-ja.html>)) (剰余環クラス)
* ((<Algebra::LocalizedRing|URL:localized-ring-ja.html>)) (局所化環クラス)
* ((<Algebra::MatrixAlgebra|URL:matrix-algebra-ja.html>)) (行列代数クラス)
* etc.

などをまとめているモジュールです。

== 関連するファイル:
* (({require "algebra.rb"})) をしておくと、

    include Algebra

  がなされ、これらのモジュールが記述されたファイルを適宜 (({require})) します。

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

なし

== クラスメソッド:

--- Algebra.Polynomial(ring [, obj0 , obj1 [, ...]])
    ((<Algebra.Polynomial|URL:polynomial-ja.html#Algebra_S_Polynomial>))() 参照。

--- Algebra.MPolynomial(ring [, obj0 [, obj1 [, ...]]])
    ((<Algebra.MPolynomial|URL:m-polynomial-ja.html#Algebra_S_MPolynomial>))() 参照。

--- Algebra.ResidueClassRing(ring, mod)
    ((<Algebra.ResidueClassRing|URL:residue-class-ring-ja.html#Algebra_S_ResidueClassRing>))() 参照。

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    ((<Algebra.AlgebraicExtensionField|URL:residue-class-ring-ja.html#Algebra_S_AlgebraicExtensionField>))() 参照。

--- Algebra.MatrixAlgebra(ring, m, n)
    ((<Algebra.MatrixAlgebra|URL:matrix-algebra-ja.html#Algebra_S_MatrixAlgebra>))(ring, m, n) 参照。

--- Algebra.Vector(ring, n)
    ((<Algebra.Vector|URL:matrix-algebra-ja.html#Algebra_S_Vector>))(ring, n) 参照。

--- Algebra.Covector(ring, n)
    ((<Algebra.Covector|URL:matrix-algebra-ja.html#Algebra_S_Covector>))(ring, n) 参照。

--- Algebra.SquareMatrix(ring, size)
    ((<Algebra.SquareMatrix|URL:matrix-algebra-ja.html#Algebra_S_SquareMatrix>))(ring, n) 参照。

=end


matrix.multiply <- function(A, s, option = 1) {
  if (option == 2) {
    return(A * (s %*% t(rep(1, dim(A)[2]))))
  }
  if (option == 1) {
    return(A * (rep(1, dim(A)[1]) %*% t(s)))
  }
}