#!/usr/bin/env Rscript

Input4=("
workload  throughput
journal-4                  7024.48
journal-4                  7144.94
journal-4                  7187.51
journal-4                  7061.21
journal-4                  6826.70
journal-4                  6683.50
journal-4                  6896.12
journal-4                  6919.83
journal-4                  7307.94
journal-4                  7102.50
sqlite-4                  9017.16
sqlite-4                  8809.81
sqlite-4                  8613.81
sqlite-4                  8467.63
sqlite-4                  8600.22
sqlite-4                  8628.48
sqlite-4                  8244.84
sqlite-4                  8075.54
sqlite-4                  8875.07
sqlite-4                  8792.31
")

df4 = read.table(textConnection(Input4),header=TRUE)
bartlett.test(df4$throughput ~ df4$workload, data=df4)

message("If p-value >= 0.05, use var.equal=TRUE below")

t.test(df4$throughput ~ df4$workload, data=df4,
       var.equal=TRUE,
       conf.level=0.95)

Input8=("
workload throughput
journal-8                  6765.83
journal-8                  6977.90
journal-8                  7089.01
journal-8                  6481.04
journal-8                  6717.82
journal-8                  6426.51
journal-8                  6837.21
journal-8                  6454.03
journal-8                  6910.78
journal-8                  6712.71
sqlite-8                 7561.52
sqlite-8                 7811.76
sqlite-8                 7904.59
sqlite-8                 7773.24
sqlite-8                 7411.04
sqlite-8                 7631.94
sqlite-8                 7771.31
sqlite-8                 7641.79
sqlite-8                 8232.62
sqlite-8                 7501.84
")

df8 = read.table(textConnection(Input8),header=TRUE)
bartlett.test(df8$throughput ~ df8$workload, data=df8)

t.test(df8$throughput ~ df8$workload, data=df8,
       var.equal=TRUE,
       conf.level=0.95)

Input16=("
workload throughput
journal-16                  6661.66
journal-16                  6759.78
journal-16                  7032.06
journal-16                  6662.63
journal-16                  6803.18
journal-16                  6579.79
journal-16                  6492.99
journal-16                  6724.89
journal-16                  6595.02
journal-16                  6643.49
sqlite-16                 6165.21
sqlite-16                 6070.99
sqlite-16                 6421.87
sqlite-16                 6536.94
sqlite-16                 6540.05
sqlite-16                 5714.42
sqlite-16                 6162.20
sqlite-16                 6454.41
sqlite-16                 6141.35
sqlite-16                 6010.05
")

df16 = read.table(textConnection(Input16),header=TRUE)
bartlett.test(df16$throughput ~ df16$workload, data=df16)

t.test(df16$throughput ~ df16$workload, data=df16,
       var.equal=TRUE,
       conf.level=0.95)

Input32=("
workload throughput
journal-32                  6745.54
journal-32                  6435.81
journal-32                  6325.01
journal-32                  6511.75
journal-32                  6379.79
journal-32                  6293.02
journal-32                  6595.44
journal-32                  6453.33
journal-32                  6371.21
journal-32                  6298.35
sqlite-32                  6060.26
sqlite-32                  5860.26
sqlite-32                  6105.28
sqlite-32                  6047.47
sqlite-32                  6067.61
sqlite-32                  5815.05
sqlite-32                  6016.67
sqlite-32                  6152.74
sqlite-32                  6077.45
sqlite-32                  5954.26
")

df32 = read.table(textConnection(Input32),header=TRUE)
bartlett.test(df32$throughput ~ df32$workload, data=df32)

message("If p-value >= 0.05, use var.equal=TRUE below")

t.test(df32$throughput ~ df32$workload, data=df32,
       var.equal=TRUE,
       conf.level=0.95)

Input64=("
workload throughput
journal-64   6193.51
journal-64   6492.17
journal-64   6093.18
journal-64   6283.59
journal-64   6253.92
journal-64   6363.34
journal-64   6131.53
journal-64   6468.23
journal-64   6147.20
journal-64   5957.34
sqlite-64    6358.80
sqlite-64    5939.43
sqlite-64    6324.36
sqlite-64    5882.36
sqlite-64    5941.00
sqlite-64    6141.81
sqlite-64    5792.27
sqlite-64    5987.80
sqlite-64    6202.03
sqlite-64    5980.05
")

df64 = read.table(textConnection(Input64),header=TRUE)
bartlett.test(df64$throughput ~ df64$workload, data=df64)

message("If p-value >= 0.05, use var.equal=TRUE below")

t.test(df64$throughput ~ df64$workload, data=df64,
       var.equal=TRUE,
       conf.level=0.95)

Input128=("
workload throughput
journal-128                6140.07
journal-128                6021.51
journal-128                6167.16
journal-128                6446.74
journal-128                6134.16
journal-128                6053.93
journal-128                6236.71
journal-128                6354.00
journal-128                6014.61
journal-128                5914.42
journal-128                  6275.96
journal-128                  6130.14
journal-128                  6069.00
journal-128                  6226.67
journal-128                  6242.63
journal-128                  5969.20
journal-128                  6094.10
journal-128                  6111.73
journal-128                  5845.98
journal-128                  6143.18
sqlite-128               7258.15
sqlite-128               6995.89
sqlite-128               6825.82
sqlite-128               7054.20
sqlite-128               6895.98
sqlite-128               6849.55
sqlite-128               6704.36
sqlite-128               6704.68
sqlite-128               6849.77
sqlite-128               6847.92
sqlite-128                  6886.70
sqlite-128                  6873.38
sqlite-128                  6567.82
sqlite-128                  6879.67
sqlite-128                  6786.69
sqlite-128                  6807.89
sqlite-128                  6940.66
sqlite-128                  6526.45
sqlite-128                  6527.77
sqlite-128                  6842.96
")

df128 = read.table(textConnection(Input128),header=TRUE)
bartlett.test(df128$throughput ~ df128$workload, data=df128)

t.test(df128$throughput ~ df128$workload, data=df128,
       var.equal=TRUE,
       conf.level=0.95)

Input256=("
workload throughput
journal-256                6174.16
journal-256                6009.00
journal-256                6133.48
journal-256                6118.66
journal-256                6251.49
journal-256                6444.50
journal-256                6289.08
journal-256                6090.86
journal-256                6107.82
journal-256                6178.65
sqlite-256               5738.44
sqlite-256               5733.58
sqlite-256               6605.20
sqlite-256               5822.83
sqlite-256               5990.19
sqlite-256               5467.91
sqlite-256               6216.10
sqlite-256               6368.61
sqlite-256               6097.44
sqlite-256               6095.78
")

df256 = read.table(textConnection(Input256),header=TRUE)
bartlett.test(df256$throughput ~ df256$workload, data=df256)

t.test(df256$throughput ~ df256$workload, data=df256,
       var.equal=FALSE,
       conf.level=0.95)

Input512=("
workload throughput
journal-512                5889.80
journal-512                5967.63
journal-512                5871.33
journal-512                6129.90
journal-512                6038.78
journal-512                6000.86
journal-512                5780.60
journal-512                5756.72
journal-512                6042.59
journal-512                5895.52
journal-512                5901.41
journal-512                5850.24
journal-512                5947.85
journal-512                5907.77
journal-512                6093.77
journal-512                5928.50
journal-512                5827.59
journal-512                5982.38
journal-512                6003.93
journal-512                5882.08
journal-512                5875.74
journal-512                5744.34
journal-512                5643.23
journal-512                6082.79
journal-512                6206.22
journal-512                5982.41
journal-512                5722.13
journal-512                5902.64
journal-512                5924.12
journal-512                5849.07
sqlite-512               4851.46
sqlite-512               4175.24
sqlite-512               5001.94
sqlite-512               6861.95
sqlite-512               4624.16
sqlite-512               6735.40
sqlite-512               6603.62
sqlite-512               6625.08
sqlite-512               6482.68
sqlite-512               6430.65
sqlite-512               4714.32
sqlite-512               4250.24
sqlite-512               6604.46
sqlite-512               4997.60
sqlite-512               4718.35
sqlite-512               6752.57
sqlite-512               4274.27
sqlite-512               6255.25
sqlite-512               5831.62
sqlite-512               4677.35
sqlite-512               6265.19
sqlite-512               4534.84
sqlite-512               4561.84
sqlite-512               4579.69
sqlite-512               6674.64
sqlite-512               4278.95
sqlite-512               6830.67
sqlite-512               6454.88
sqlite-512               5122.86
sqlite-512               4319.10
")

df512 = read.table(textConnection(Input512),header=TRUE)
bartlett.test(df512$throughput ~ df512$workload, data=df512)

t.test(df512$throughput ~ df512$workload, data=df512,
       var.equal=TRUE,
       conf.level=0.95)

Input1024=("
workload throughput
journal-1024                 6060.03
journal-1024                 5713.12
journal-1024                 5984.37
journal-1024                 5642.23
journal-1024                 5733.45
journal-1024                 5664.29
journal-1024                 5667.71
journal-1024                 6007.26
journal-1024                 5949.81
journal-1024                 5859.07
sqlite-1024                4411.89
sqlite-1024                4082.66
sqlite-1024                4422.64
sqlite-1024                3827.05
sqlite-1024                4253.10
sqlite-1024                5100.49
sqlite-1024                3986.22
sqlite-1024                4175.26
sqlite-1024                4204.46
sqlite-1024                4017.86
")

df1024 = read.table(textConnection(Input1024),header=TRUE)
bartlett.test(df1024$throughput ~ df1024$workload, data=df1024)

t.test(df1024$throughput ~ df1024$workload, data=df1024,
       var.equal=FALSE,
       conf.level=0.95)

Input2048=("
workload throughput
journal-2048                 5541.96
journal-2048                 5411.09
journal-2048                 5571.17
journal-2048                 5606.22
journal-2048                 5276.86
journal-2048                 5259.30
journal-2048                 5467.38
journal-2048                 5464.42
journal-2048                 5355.09
journal-2048                 5496.44
sqlite-2048                3504.50
sqlite-2048                3840.96
sqlite-2048                3737.51
sqlite-2048                3874.28
sqlite-2048                3541.43
sqlite-2048                4334.83
sqlite-2048                3773.90
sqlite-2048                3805.36
sqlite-2048                3843.81
sqlite-2048                3773.41
")

df2048 = read.table(textConnection(Input2048),header=TRUE)
bartlett.test(df2048$throughput ~ df2048$workload, data=df2048)

t.test(df2048$throughput ~ df2048$workload, data=df2048,
       var.equal=TRUE,
       conf.level=0.95)

Input4096=("
workload throughput
journal-4096                 4797.12
journal-4096                 5047.38
journal-4096                 4978.69
journal-4096                 4781.63
journal-4096                 5006.89
journal-4096                 4916.87
journal-4096                 4821.37
journal-4096                 4983.61
journal-4096                 5004.28
journal-4096                 4905.44
sqlite-4096                3593.53
sqlite-4096                3377.08
sqlite-4096                3545.17
sqlite-4096                3429.96
sqlite-4096                3763.35
sqlite-4096                3509.91
sqlite-4096                3499.49
sqlite-4096                3393.35
sqlite-4096                3665.23
sqlite-4096                3718.05
")

df4096 = read.table(textConnection(Input4096),header=TRUE)
bartlett.test(df4096$throughput ~ df4096$workload, data=df4096)

t.test(df4096$throughput ~ df4096$workload, data=df4096,
       var.equal=TRUE,
       conf.level=0.95)

c4    <- c(7015.473, 8612.487)
c8    <- c(6737.284, 7724.165)
c16   <- c(6695.549, 6221.749)
c32   <- c(6440.925, 6015.705)
c64   <- c(6238.401, 6054.991)
c128  <- c(6129.595, 6831.315)
c256  <- c(6179.770, 6013.608)
c512  <- c(5921.065, 5503.029)
c1024 <- c(5828.134, 4248.163)
c2048 <- c(5444.993, 3802.999)
c4096 <- c(4924.328, 3549.512)

df <- data.frame(c4, c8, c16, c32, c64, c128, c256, c512, c1024, c2048, c4096)
names(df) <- c("4", "8", "16", "32", "64", "128", "256", "512", "1024", "2048", "4096")

colours=(c("red", "blue"))

# X11()
jpeg("/tmp/journal-benchmark.jpg",
     width=640)

barplot(height=as.matrix(df),
        xlab="# of concurrent clients",
        ylab="Throughput (reqs/s)",
        beside=TRUE,
        col=colours)
legend ("topright", c("journal", "sqlite"), fill=colours)

#message("Press return to continue")
#invisible(readLines("stdin", n=1))
dev.off()


romanToArabic(c("MCMXII", "LXXXVI"))


expect_error(
    check_equal_length(c(1, 0), c(0.1, 0.2, 0.3))
)

expect_silent(
    check_equal_length(c(1, 0), c(0.1, 0.2))
)

expect_error(
    check_cutoff_range(1.1)
)

expect_error(
    check_cutoff_range(-0.1)
)

expect_silent(
    check_cutoff_range(0.5)
)

expect_error(
    check_binary(c(0, 1, 2))
)

expect_error(
    check_binary(c(-1, 0))
)

expect_error(
    check_binary(c(-1, 1))
)

expect_silent(
    check_binary(c(1, 0))
)

## https://gallery.rcpp.org/articles/sugar-function-clamp/
## https://stackoverflow.com/questions/13868963/clip-values-between-a-minimum-and-maximum-allowed-value-in-r
set.seed(42)
x <- rnorm(100)
a <- -1.0
b <- 1.0

expect_equal(
    clip(x, mi = a, ma = b),
    target = pmax(a, pmin(x, b))
)

## https://github.com/tidymodels/yardstick/blob/master/tests/testthat/test-auc.R
expect_equal(
    trapezoid(c(1, 1.2, 1.6, 2), c(4, 3.8, 4.2, 5)),
    target = 4.22
)


# Normal Boxplots

x <- read.csv("~/Desktop/nfbugs.csv", header=T,sep=",")

type <- c("Jenkins F", "Elasticsearch F", "Terasology F", "Jenkins NF", "Elasticsearch NF", "Terasology NF")

boxplot(x$jenkins.all.f,x$elasticsearch.all.f,x$terasology.all.f,x$jenins.all.nf,x$elasticsearch.all.nf,x$terasology.all.nf,names=type,ylab="Java: Days between inducing change and fixing change")

type <- c("Terasology F", "Elasticsearch-py F", "Falcon F", "Terasology NF", "Elasticsearch-py  NF", "Falcon NF")

boxplot(x$terasology.all.f,x$elasticsearch.py.all.f,x$falcon.all.f,x$terasology.all.nf,x$elasticsearch.py.all.nf,x$falcon.all.nf,names=type,ylab="Python: Days between inducing change and fixing change")

type <- c("Jenkins F", "Elasticsearch F", "Terasology F", "Jenkins NF", "Elasticsearch NF", "Terasology NF")

boxplot(x$jenkins.earliest.f,x$elasticsearch.earliest.f,x$terasology.earliest.f,x$jenkins.earliest.nf,x$elasticsearch.earliest.nf,x$terasology.earliest.nf,names=type,ylab="Java: Days between earliest inducing change and fixing change")

type <- c("Terasology F", "Elasticsearch-py F", "Falcon F", "Terasology NF", "Elasticsearch-py  NF", "Falcon NF")

boxplot(x$terasology.earliest.f,x$elasticsearch.py.earliest.f,x$falcon.earliest.f,x$terasology.earliest.nf,x$elasticsearch.py.earliest.nf,x$falcon.earliest.nf,names=type,ylab="Python: Days between earliest inducing change and fixing change")

-----------------------------------------------------------------------

# Violin Plots

library(vioplot)

vioplot(x$elasticsearch.all.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$elasticsearch.all.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between inducing change and fixing change")

-----------------------------------------------------------------------

vioplot(x$jenkins.all.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$jenins.all.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between inducing change and fixing change")

-----------------------------------------------------------------------
vioplot(x$elasticsearch.earliest.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$elasticsearch.earliest.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between earliest inducing change and fixing change")

-----------------------------------------------------------------------

vioplot(x$jenkins.earliest.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$jenkins.earliest.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between earliest inducing change and fixing change")

# -----------------------------------------------------------------------
# -----------------------------------------------------------------------
# -----------------------------------------------------------------------
# -----------------------------------------------------------------------
# -----------------------------------------------------------------------
# -----------------------------------------------------------------------
# -----------------------------------------------------------------------

vioplot(x$falcon.all.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$falcon.all.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between inducing change and fixing change")

-----------------------------------------------------------------------

vioplot(x$gae.boilerplate.all.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$gae.boilerplate.all.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between inducing change and fixing change")
-----------------------------------------------------------------------

vioplot(x$falcon.earliest.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$falcon.earliest.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between earliest inducing change and fixing change")

-----------------------------------------------------------------------

vioplot(x$gae.boilerplate.earliest.f,col="lightblue",plotCentre="line",side="left")

vioplot(x$gae.boilerplate.earliest.nf,col="palevioletred",plotCentre="line",side="right", add=T)

# title(cex.lab=1.5, cex.axis=1.5, cex.main=1.5, cex.sub=1.5, ylab="Days between earliest inducing change and fixing change")

-----------------------------------------------------------------------

# Wilcoxin test

bugs <- read.csv("~/Desktop/bugs.csv", header=T,sep=",")

jenkins.all.nf<-bugs[1]
jenkins.all.nf<-jenkins.all.nf[!is.na(jenkins.all.nf)]
sum(jenkins.all.nf < 0) # 0

jenkins.earliest.nf<-bugs[2]
jenkins.earliest.nf<-jenkins.earliest.nf[!is.na(jenkins.earliest.nf)]
sum(jenkins.earliest.nf < 0) # 0
jenkins.all.f<-bugs[3]
jenkins.all.f<-jenkins.all.f[!is.na(jenkins.all.f)]
sum(jenkins.all.f < 0) # 2
jenkins.earliest.f<-bugs[4]
jenkins.earliest.f<-jenkins.earliest.f[!is.na(jenkins.earliest.f)]
sum(jenkins.earliest.f < 0) # 1

sum(jenkins.all.nf > 365) # 2

elasticsearch.all.nf<-bugs[5]
sum(elasticsearch.all.nf < 0) # 0
elasticsearch.all.nf <- elasticsearch.all.nf[elasticsearch.all.nf > 0]
elasticsearch.all.nf<-elasticsearch.all.nf[!is.na(elasticsearch.all.nf)]
elasticsearch.earliest.nf<-bugs[6]
sum(elasticsearch.earliest.nf < 0) # 0

elasticsearch.earliest.nf <- elasticsearch.earliest.nf[elasticsearch.earliest.nf > 0]
elasticsearch.earliest.nf<-elasticsearch.earliest.nf[!is.na(elasticsearch.earliest.nf)]
elasticsearch.all.f<-bugs[7]
sum(elasticsearch.all.f < 0) # 342

elasticsearch.all.f <- elasticsearch.all.f[elasticsearch.all.f > 0]
elasticsearch.all.f<-elasticsearch.all.f[!is.na(elasticsearch.all.f)]
elasticsearch.earliest.f<-bugs[8]
sum(elasticsearch.earliest.f < 0) # 0

elasticsearch.earliest.f <- elasticsearch.earliest.f[elasticsearch.earliest.f > 0]
elasticsearch.earliest.f<-elasticsearch.earliest.f[!is.na(elasticsearch.earliest.f)]

sum(elasticsearch.all.nf > 365) # 29

falcon.all.nf<-bugs[9]
falcon.all.nf<-falcon.all.nf[!is.na(falcon.all.nf)]
falcon.earliest.nf<-bugs[10]
falcon.earliest.nf<-falcon.earliest.nf[!is.na(falcon.earliest.nf)]
falcon.all.f<-bugs[11]
falcon.all.f<-falcon.all.f[!is.na(falcon.all.f)]
falcon.earliest.f<-bugs[12]
falcon.earliest.f<-falcon.earliest.f[!is.na(falcon.earliest.f)]

sum(falcon.all.nf > 365) # 5

gaeboilerplate.all.nf<-bugs[13]
gaeboilerplate.all.nf<-gaeboilerplate.all.nf[!is.na(gaeboilerplate.all.nf)]
gaeboilerplate.earliest.nf<-bugs[14]
gaeboilerplate.earliest.nf<-gaeboilerplate.earliest.nf[!is.na(gaeboilerplate.earliest.nf)]
gaeboilerplate.all.f<-bugs[15]
gaeboilerplate.all.f<-gaeboilerplate.all.f[!is.na(gaeboilerplate.all.f)]
gaeboilerplate.earliest.f<-bugs[16]
gaeboilerplate.earliest.f<-gaeboilerplate.earliest.f[!is.na(gaeboilerplate.earliest.f)]

sum(gaeboilerplate.all.nf > 365) # 0

wilcox.test(jenkins.all.f,jenkins.all.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  jenkins.all.f and jenkins.all.nf
# W = 21358, p-value = 0.1123
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(elasticsearch.all.f,elasticsearch.all.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  elasticsearch.all.f and elasticsearch.all.nf
# W = 883587, p-value = 0.004315
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(falcon.all.f,falcon.all.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  falcon.all.f and falcon.all.nf
# W = 15056, p-value = 0.7962
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(gaeboilerplate.all.f,gaeboilerplate.all.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  gaeboilerplate.all.f and gaeboilerplate.all.nf
# W = 1559.5, p-value = 0.218
# alternative hypothesis: true location shift is not equal to 0

-----------------------------------------------------------------------

wilcox.test(jenkins.earliest.f,jenkins.earliest.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  jenkins.earliest.f and jenkins.earliest.nf
# W = 3171.5, p-value = 0.6983
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(elasticsearch.earliest.f,elasticsearch.earliest.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  elasticsearch.earliest.f and elasticsearch.earliest.nf
# W = 30778, p-value = 0.2282
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(falcon.all.f,falcon.all.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  falcon.all.f and falcon.all.nf
# W = 15056, p-value = 0.7962
# alternative hypothesis: true location shift is not equal to 0
wilcox.test(gaeboilerplate.earliest.f,gaeboilerplate.earliest.nf)
# 	Wilcoxon rank sum test with continuity correction

# data:  gaeboilerplate.earliest.f and gaeboilerplate.earliest.nf
# W = 134.5, p-value = 0.3901
# alternative hypothesis: true location shift is not equal to 0

-----------------------------------------------------------------------

# cliff's delta test

install.packages("effsize")
library(effsize)

# since wilcox.test(elasticsearch.all.f,elasticsearch.all.nf) gave us a p-value less than 0.05
# 	Wilcoxon rank sum test with continuity correction
# *********
# data:  elasticsearch.all.f and elasticsearch.all.nf
# W = 883587, p-value = 0.003591
# alternative hypothesis: true location shift is not equal to 0

# we can find the effect size using Cliff's Delta

# cliff.delta(elasticsearch.all.f,elasticsearch.all.nf)

# Cliff's Delta

# delta estimate: -0.2507339 (small)
# 95 percent confidence interval:
#       lower       upper
# -0.42387025 -0.05991925

-----------------------------------------------------------------------

vioplot(elasticsearch.earliest.f,col="lightblue",plotCentre="line",side="left")

vioplot(elasticsearch.earliest.nf,col="palevioletred",plotCentre="line",side="right", add=T)

vioplot(elasticsearch.all.f,col="lightblue",plotCentre="line",side="left")

vioplot(elasticsearch.all.nf,col="palevioletred",plotCentre="line",side="right", add=T)


getMaxAlphaFilters <- function(g, max.vertices){
  el = get.data.frame(g)
  a = unique(data.frame(node=c(el$from,el$to), alpha=c(el$alpha,el$alpha)))
  a = a[order(a$alpha),]
  a = a[!duplicated(a$node),]
  if(nrow(a) <= max.vertices) {
    max.alpha = 1
    delete.vertices = c()
  } else {
    max.alpha = a$alpha[max.vertices]
    if(max.alpha == a$alpha[max.vertices+1]) max.alpha = max.alpha - 0.000000001
    delete.vertices = na.omit(a$node[(max.vertices+1):nrow(a)])
    delete.edges = which(el$from %in% delete.vertices | el$to %in% delete.vertices)
  }
  list(max.alpha=max.alpha, delete.edges=delete.edges)
}

filterVerticesByAlpha <- function(g, max.vertices, use.original.alpha){
  filters = getMaxAlphaFilters(g, max.vertices)

  if(filters$max.alpha < max(E(g)$alpha)) {
    message(paste('Used cutoff alpha', filters$max.alpha, 'to keep number of vertices under', max.vertices))
    if(use.original.alpha){
      message(paste('(For the edges the threshold assigned in the alpha parameter is still used)'))

      g = delete.edges(g, filters$delete.edges)
    } else {
      g = delete.edges(g, which(E(g)$alpha >= filters$max.alpha))
    }
  }
  g
}

#' Extract the backbone of a network.
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @param alpha The threshold for the alpha. Can be interpreted similar to a p value (see paper for clarrification).
#' @param direction direction = 'none' can be used for both directed and undirected networks, and is (supposed to be) the disparity filter proposed in Serrano et al. (2009) is used. By setting to 'in' or 'out', the alpha is only calculated for out or in edges. This is an experimental use of the backbone extraction (so beware!) but it seems a logical application.
#' @param delete.isolates If TRUE, vertices with degree 0 (i.e. no edges) are deleted.
#' @param max.vertices Optional. Set a maximum number of vertices for the network to be produced. The alpha is then automatically lowered to the point that only the given number of vertices remains connected (degree > 0). This can be usefull if the purpose is to make an interpretation friendly network. See e.g., http://jcom.sissa.it/archive/14/01/JCOM_1401_2015_A01
#' @param use.original.alpha if max.vertices is not NULL, this determines whether the lower alpha for selecting the top vertices is also used as a threshold for the edges, or whether the original value given in the alpha parameter is used.
#' @return A graph in the Igraph format
#' @export
getBackboneNetwork <- function(g, alpha=0.05, direction='none', delete.isolates=T, max.vertices=NULL, use.original.alpha=T, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  if(direction == 'none') E(g)$alpha = backbone.alpha(g, k.is.Nvertices)
  if(direction == 'in') E(g)$alpha = backbone.indegree.alpha(g, k.is.Nvertices)
  if(direction == 'out') E(g)$alpha = backbone.outdegree.alpha(g, k.is.Nvertices)
  g = delete.edges(g, which(E(g)$alpha >= alpha))
  if(!is.null(max.vertices) & ecount(g) > 0) g = filterVerticesByAlpha(g, max.vertices, use.original.alpha)
  if(delete.isolates) g = delete.vertices(g, which(degree(g) == 0))
  if(ecount(g) == 0) {
    warning("No significant edges (backbone) remain!! Accept it (or lower the backbone_alpha)")
    return(g)
  }
  g
}

calcAlpha <- function(mat, weightsum, k){
  mat@x = mat@x / weightsum[mat@i+1]
  mat@x = (1 - mat@x)^(k[mat@i+1]-1)
  mat@x[is.na(mat@x)] = 1
  mat
}

#' Calculate the alpha values that can be used to extract the backbone of a network.
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  edgelist_ids = get.edgelist(g, names=F)

  if(!is.directed(g)) {
    mat[lower.tri(mat)] = 0 # prevents counting edges double in symmetric matrix (undirected graph)
    weightsum_ij = weightsum_ji = Matrix::rowSums(mat) + Matrix::colSums(mat)
    k_ij = k_ji = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat>0) + Matrix::colSums(mat>0)
  } else {
    weightsum_ij = Matrix::rowSums(mat)
    weightsum_ji = Matrix::colSums(mat)
    k_ij = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat>0)
    k_ji = if(k.is.Nvertices) ncol(mat) else Matrix::colSums(mat>0)
  }
  alpha_ij = calcAlpha(mat, weightsum_ij, k_ij)[edgelist_ids] # alpha from the perspective of the 'from' node.
  alpha_ji = Matrix::t(calcAlpha(Matrix::t(mat), weightsum_ji, k_ji))[edgelist_ids] # alpha from the perspective of the 'to' node.
  ifelse(alpha_ij < alpha_ji, alpha_ij, alpha_ji) # select lowest alpha, because an edge can be 'significant' from the perspective of both the 'from' and 'to' node.

}

#' Calculate the alpha values that can be used to extract the backbone of a network, for only the out.degree
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.outdegree.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support
                                     parallel edges (i.e. having multiple edges between the same nodes
                                     with the same direction). If summing multiple edges into single
                                     weighted edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  weightsum = Matrix::rowSums(mat)
  k = if(k.is.Nvertices) nrow(mat) else Matrix::rowSums(mat > 0)
  edgelist_ids = get.edgelist(g, names=F)
  calcAlpha(mat, weightsum, k)[edgelist_ids]
}

#' Calculate the alpha values that can be used to extract the backbone of a network, for only the in.degree
#'
#' Based on the following paper: Serrano, M. Á., Boguñá, M., & Vespignani, A. (2009). Extracting the multiscale backbone of complex weighted networks. Proceedings of the National Academy of Sciences, 106(16), 6483-6488.
#'
#' @param g A graph in the `Igraph` format.
#' @return A vector of alpha values, which matches the edges. Can thus easily be made an edge attribute: E(g)$alpha = backbone.alpha(g)
#' @export
backbone.indegree.alpha <- function(g, k.is.Nvertices=F){
  if (igraph::has.multiple(g)) stop('The semnet implementation of backbone extraction does not support parallel edges (i.e. having multiple edges between the same nodes with the same direction). If summing multiple edges is OK with you, you can use Igraphs simplify() function')

  mat = get.adjacency(g, attr='weight')
  weightsum = Matrix::colSums(mat)
  k = if(k.is.Nvertices) nrow(mat) else Matrix::colSums(mat > 0)
  edgelist_ids = get.edgelist(g, names=F)
  Matrix::t(calcAlpha(Matrix::t(mat), weightsum, k))[edgelist_ids]
}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

simulate <- function(data,runs)
{
	func <- log(agb) ~ log(d) + log(h) + log(rho)
	results <- matrix(nrow=runs,ncol=5)
	ddata <- matrix(nrow=nrow(data),ncol=runs)
	hdata <- matrix(nrow=nrow(data),ncol=runs)
	rhodata <- matrix(nrow=nrow(data),ncol=runs)
	for(i in 1:nrow(data))
	{
		ddata[i,] <- rnorm(runs,caldata[i,'d'],0)
		hdata[i,] <- rnorm(runs,caldata[i,'h'],2)
		rhodata[i,] <- rnorm(runs,caldata[i,'rho'],100)
	}
	for(i in 1:runs)
	{
		d <- ddata[,i]
		h <- hdata[,i]
		rho <- rhodata[,i]
		df <- data.frame(d,h,data$agb,rho)
		colnames(df) <- c("d","h","agb","rho")
		model <- fitOLS(df,func)
		results[i,1] <- coefficients(model)[1]
		results[i,2] <- coefficients(model)[2]
		results[i,3] <- coefficients(model)[3]
		results[i,4] <- coefficients(model)[4]
		results[i,5] <- summary(model)$sigma
	}
#	print(results)
	print(format(round(mean(results[,1]),3),nsmall=3))
	print(format(round(mean(results[,2]),3),nsmall=3))
	print(format(round(mean(results[,3]),3),nsmall=3))
	print(format(round(mean(results[,4]),3),nsmall=3))
	print(format(round(mean(results[,5]),3),nsmall=3))
}


# correlacion componente principal largest, y componentes cantidad

#levantar_datos
pacman::p_load("tidyverse")
base::load(here::here("data","temporal_acumulado_data.Rdata"))
base::load(here::here("data","temporal_basico_data.Rdata"))

#temporal_acumulado_estr_grafos

temporal_basico_estr_grafos %>%
    select(periodo, componentes_cantidad,componentes_largest,componentes_largest_porc)
# componentes_cantidad = cantidad de componentes en la red.
# componentes_largest = cantidad de autores en el componente mayor.
# componentes_largest_porc = porcentaje que representa el componente mayor en cantidad de autores vs del total de autores

temporal_basico_estr_grafos %>%
    select(componentes_cantidad,componentes_largest) %>% cor()

# hay una leve correlacion negativa entre la cantidad de componentes,
# y cuanto representa el componente mayor respecto del total de autores.
temporal_basico_estr_grafos %>%
    select(componentes_cantidad, componentes_largest_porc) %>% cor()

temporal_basico_estr_grafos %>%
    select(componentes_largest, componentes_largest_porc) %>% cor()


library(Rmpfr)

amcat.lda.harmonicMean <- function(logLikelihoods, precision=2000L) {
  llMed <- median(logLikelihoods)
  as.double(llMed - log(mean(exp(-mpfr(logLikelihoods,
                                       prec = precision) + llMed))))
}

amcat.lda.find.best.K <- function(dtm, package='lda', k_values=seq(2, 500, 50), iter=100, burnin=100, ll_interval=10){
  if(package == 'lda'){
    models <- lapply(k_values, function(k) amcat.lda.fit(dtm, K=k, num.iterations=iter, burnin=burnin, compute.log.likelihood=T))
    ll_list <- lapply(models, function(model) model$log.likelihoods[2,seq(1, iter, ll_interval)])

  }
  if(package == 'topicmodels') {
    models <- lapply(k_values, function(k) LDA(ap, k = k, method = "Gibbs",control = list(burnin = burnin, iter = iter, keep=ll_interval)))
    ll_list <- lapply(models, function(model)  model@logLiks[-c(1:(burnin/ll_interval))])
  }

  hm_list <- sapply(ll_list, function(ll) amcat.lda.harmonicMean(ll))

  plot(k_values, hm_list, type = "l")
  print(paste('Optimum number of topics =', k_values[which.max(hm_list)]))
  data.frame(k=k_values,hm_fit=hm_list)
}


library(testthat)
library(sparsediscrim)
library(MASS)
library(mvtnorm)

data(two_class_sim_data)

context("The HDRDA Classifier from Ramey et al. (2017)")

test_that("The HDRDA classifier works properly on the iris data set", {
  set.seed(42)
  n <- nrow(iris)
  train <- sample(seq_len(n), n / 2)
  hdrda_out <- rda_high_dim(Species ~ ., data = iris[train, ])
  predicted <- predict(hdrda_out, iris[-train, -5], type = "prob")

  hdrda_out2 <- rda_high_dim(x = iris[train, -5], y = iris[train, 5])
  predicted2 <- predict(hdrda_out2, iris[-train, -5], type = "prob")

  # Tests that the same prob results from the matrix and formula versions of
  # the HDRDA classifier
  expect_equal(predicted, predicted2)
})

test_that("HDRDA's calculations are correct for (lambda, gamma) = (1, 0)", {
  hdrda_out <- rda_high_dim(Species ~ ., data = iris, lambda=1, gamma=0)

  Sigma <- cov_pool(x=iris[, -5], y=iris$Species)
  Sigma_eigen <- eigen(Sigma, symmetric=TRUE)
  D_q <- diag(Sigma_eigen$values)

  # For each class, calculate W_k. These should equal D_q
  W_k <- sapply(hdrda_out$est, function(est) {
    solve(est$W_inv)
  }, simplify=FALSE)

  expect_equal(W_k$setosa, D_q)
  expect_equal(W_k$versicolor, D_q)
  expect_equal(W_k$virginica, D_q)
})

test_that("LDA is a special case of HDRDA on the iris data set", {
  set.seed(42)
  n <- nrow(iris)
  train <- sample(seq_len(n), n / 2)
  hdrda_out <- rda_high_dim(Species ~ ., data = iris[train, ], lambda=1, gamma=0)
  predicted_hdrda <- predict(hdrda_out, iris[-train, -5], type = "prob")

  lda_out <- lda(x = iris[train, -5], grouping = iris[train, 5])
  predicted_lda <- predict(lda_out, iris[-train, -5], type = "prob")

  # Tests that the same prob results from the matrix and formula versions of
  # the HDRDA classifier
  # TODO fails with
  # Error: `predicted_hdrda` not equivalent to as.data.frame(predicted_lda$posterior).
  # Component “versicolor”: Mean relative difference: 0.02361101
  # Component “virginica”: Mean relative difference: 0.02645662
  #  expect_equivalent(predicted_hdrda, as.data.frame(predicted_lda$posterior))
})

test_that("QDA is a special case of HDRDA on the iris data set", {
  set.seed(42)
  n <- nrow(iris)
  train <- sample(seq_len(n), n / 2)
  hdrda_out <- rda_high_dim(Species ~ ., data = iris[train, ], lambda=0, gamma=0)
  predicted_hdrda <- predict(hdrda_out, iris[-train, -5], type = "prob")

  qda_out <- qda(x = iris[train, -5], grouping = iris[train, 5])
  predicted_qda <- predict(qda_out, iris[-train, -5])$posterior

  # Tests that the same prob results from the matrix and formula versions of
  # the HDRDA classifier
  # currently fails with
  # Error: `predicted_hdrda` not equal to as.data.frame(predicted_qda).
  # Component “versicolor”: Mean relative difference: 0.02941271
  # Component “virginica”: Mean relative difference: 0.03463737
  # expect_equivalent(predicted_hdrda, as.data.frame(predicted_qda))
})

test_that("HDRDA's statistics match manual values when (lambda, gamma) = (0, 0)", {
  set.seed(42)
  p <- 250
  n1 <- 10
  n2 <- 15
  n3 <- 25

  iris_x <- as.matrix(iris[, -5])

  # The first cov matrix is the identity matrix.
  # To generate sigma2 and sigma3, we grab eigenvectors from the iris data set.
  # The eigenvalues are randomly generated.
  eigen2 <- eigen(tcrossprod(iris_x[rep(1:100, length=p), ]), symmetric=TRUE)
  eigen3 <- eigen(tcrossprod(iris_x[rep(30:130, length=p), ]), symmetric=TRUE)

  eigen2$values <- sort(rexp(p, rate=0.1), decreasing=TRUE)
  eigen3$values <- sort(rexp(p, rate=0.05), decreasing=TRUE)

  sigma2 <- with(eigen2, vectors %*% tcrossprod(diag(values), vectors))
  sigma3 <- with(eigen3, vectors %*% tcrossprod(diag(values), vectors))

  x1 <- rmvnorm(n1, mean=rep(0, p), sigma=diag(p))
  x2 <- rmvnorm(n2, mean=rep(3, p), sigma=sigma2)
  x3 <- rmvnorm(n3, mean=rep(-3, p), sigma=sigma3)

  x <- rbind(x1, x2, x3)
  colnames(x) <- paste0("x", 1:ncol(x))
  y <- c(rep(1, n1), rep(2, n2), rep(3, n3))
  y_fac <- factor(letters[y])

  # Compute estimates for HDRDA manually.
  xbar1 <- colMeans(x1)
  xbar2 <- colMeans(x2)
  xbar3 <- colMeans(x3)

  x_centered1 <- scale(x1, center=TRUE, scale=FALSE)
  x_centered2 <- scale(x2, center=TRUE, scale=FALSE)
  x_centered3 <- scale(x3, center=TRUE, scale=FALSE)

  Sigma_eigen <- cov_eigen(x=x, y=y, pool=TRUE, fast=TRUE, tol=1e-6)
  D_q <- Sigma_eigen$values
  U1 <- Sigma_eigen$vectors
  q <- length(D_q)

  XU_1 <- x_centered1 %*% U1
  XU_2 <- x_centered2 %*% U1
  XU_3 <- x_centered3 %*% U1

  xbar1_U1 <- crossprod(U1, xbar1)
  xbar2_U1 <- crossprod(U1, xbar2)
  xbar3_U1 <- crossprod(U1, xbar3)

  W_1 <- cov_mle(XU_1)
  W_2 <- cov_mle(XU_2)
  W_3 <- cov_mle(XU_3)

  W1_inv <- solve_chol(W_1 + diag(0.001, nrow=nrow(W_1), ncol=ncol(W_1)))
  W2_inv <- solve_chol(W_2 + diag(0.001, nrow=nrow(W_2), ncol=ncol(W_2)))
  W3_inv <- solve_chol(W_3 + diag(0.001, nrow=nrow(W_3), ncol=ncol(W_3)))

  hdrda_out <- rda_high_dim(x=x, y=y_fac, lambda=0, gamma=0)

  expect_equal(hdrda_out$q, q)
  expect_equal(hdrda_out$D_q, D_q)
  expect_equal(hdrda_out$U1, U1)

  expect_equal(hdrda_out$est[[1]]$n, n1)
  expect_equal(hdrda_out$est[[1]]$xbar, xbar1)
  expect_equal(hdrda_out$est[[1]]$prior, n1 / length(y))
  expect_equal(hdrda_out$est[[1]]$alpha, 1)
  expect_equal(hdrda_out$est[[1]]$XU, XU_1)
  expect_equal(hdrda_out$est[[1]]$xbar_U1, xbar1_U1)
  expect_equal(hdrda_out$est[[1]]$Gamma, matrix(0, q, q))
  expect_equal(hdrda_out$est[[1]]$Q, diag(n1))
  expect_equal(hdrda_out$est[[1]]$W_inv, W1_inv)

  expect_equal(hdrda_out$est[[2]]$n, n2)
  expect_equal(hdrda_out$est[[2]]$xbar, xbar2)
  expect_equal(hdrda_out$est[[2]]$prior, n2 / length(y))
  expect_equal(hdrda_out$est[[2]]$alpha, 1)
  expect_equal(hdrda_out$est[[2]]$XU, XU_2)
  expect_equal(hdrda_out$est[[2]]$xbar_U1, xbar2_U1)
  expect_equal(hdrda_out$est[[2]]$Gamma, matrix(0, q, q))
  expect_equal(hdrda_out$est[[2]]$Q, diag(n2))
  expect_equal(hdrda_out$est[[2]]$W_inv, W2_inv)

  expect_equal(hdrda_out$est[[3]]$n, n3)
  expect_equal(hdrda_out$est[[3]]$xbar, xbar3)
  expect_equal(hdrda_out$est[[3]]$prior, n3 / length(y))
  expect_equal(hdrda_out$est[[3]]$alpha, 1)
  expect_equal(hdrda_out$est[[3]]$XU, XU_3)
  expect_equal(hdrda_out$est[[3]]$xbar_U1, xbar3_U1)
  expect_equal(hdrda_out$est[[3]]$Gamma, matrix(0, q, q))
  expect_equal(hdrda_out$est[[3]]$Q, diag(n3))
  expect_equal(hdrda_out$est[[3]]$W_inv, W3_inv)
})

test_that("HDRDA's statistics match manual values when (lambda, gamma) = (1, 0)", {
  set.seed(42)
  p <- 250
  n1 <- 10
  n2 <- 15
  n3 <- 25

  iris_x <- as.matrix(iris[, -5])

  # The first cov matrix is the identity matrix.
  # To generate sigma2 and sigma3, we grab eigenvectors from the iris data set.
  # The eigenvalues are randomly generated.
  eigen2 <- eigen(tcrossprod(iris_x[rep(1:100, length=p), ]), symmetric=TRUE)
  eigen3 <- eigen(tcrossprod(iris_x[rep(30:130, length=p), ]), symmetric=TRUE)

  eigen2$values <- sort(rexp(p, rate=0.1), decreasing=TRUE)
  eigen3$values <- sort(rexp(p, rate=0.05), decreasing=TRUE)

  sigma2 <- with(eigen2, vectors %*% tcrossprod(diag(values), vectors))
  sigma3 <- with(eigen3, vectors %*% tcrossprod(diag(values), vectors))

  x1 <- rmvnorm(n1, mean=rep(0, p), sigma=diag(p))
  x2 <- rmvnorm(n2, mean=rep(3, p), sigma=sigma2)
  x3 <- rmvnorm(n3, mean=rep(-3, p), sigma=sigma3)

  x <- rbind(x1, x2, x3)
  colnames(x) <- paste0("x", 1:ncol(x))
  y <- c(rep(1, n1), rep(2, n2), rep(3, n3))
  y_fac <- factor(letters[y])

  # Compute estimates for HDRDA manually.
  xbar1 <- colMeans(x1)
  xbar2 <- colMeans(x2)
  xbar3 <- colMeans(x3)

  x_centered1 <- scale(x1, center=TRUE, scale=FALSE)
  x_centered2 <- scale(x2, center=TRUE, scale=FALSE)
  x_centered3 <- scale(x3, center=TRUE, scale=FALSE)

  Sigma_eigen <- cov_eigen(x=x, y=y_fac, pool=TRUE, fast=TRUE, tol=1e-6)
  D_q <- Sigma_eigen$values
  U1 <- Sigma_eigen$vectors
  q <- length(D_q)

  XU_1 <- x_centered1 %*% U1
  XU_2 <- x_centered2 %*% U1
  XU_3 <- x_centered3 %*% U1

  xbar1_U1 <- crossprod(U1, xbar1)
  xbar2_U1 <- crossprod(U1, xbar2)
  xbar3_U1 <- crossprod(U1, xbar3)

  hdrda_out <- rda_high_dim(x=x, y=y_fac, lambda=1, gamma=0)

  expect_equal(hdrda_out$q, q)
  expect_equal(hdrda_out$D_q, D_q)
  expect_equal(hdrda_out$U1, U1)

  expect_equal(hdrda_out$est[[1]]$n, n1)
  expect_equal(hdrda_out$est[[1]]$xbar, xbar1)
  expect_equal(hdrda_out$est[[1]]$prior, n1 / length(y))
  expect_equal(hdrda_out$est[[1]]$alpha, 1)
  expect_equal(hdrda_out$est[[1]]$XU, XU_1)
  expect_equal(hdrda_out$est[[1]]$xbar_U1, xbar1_U1)
  expect_equal(hdrda_out$est[[1]]$Gamma, D_q)
  expect_equal(hdrda_out$est[[1]]$Q, diag(n1))
  expect_equal(hdrda_out$est[[1]]$W_inv, diag(D_q^(-1)))

  expect_equal(hdrda_out$est[[2]]$n, n2)
  expect_equal(hdrda_out$est[[2]]$xbar, xbar2)
  expect_equal(hdrda_out$est[[2]]$prior, n2 / length(y))
  expect_equal(hdrda_out$est[[2]]$alpha, 1)
  expect_equal(hdrda_out$est[[2]]$XU, XU_2)
  expect_equal(hdrda_out$est[[2]]$xbar_U1, xbar2_U1)
  expect_equal(hdrda_out$est[[2]]$Gamma, D_q)
  expect_equal(hdrda_out$est[[2]]$Q, diag(n2))
  expect_equal(hdrda_out$est[[2]]$W_inv, diag(D_q^(-1)))

  expect_equal(hdrda_out$est[[3]]$n, n3)
  expect_equal(hdrda_out$est[[3]]$xbar, xbar3)
  expect_equal(hdrda_out$est[[3]]$prior, n3 / length(y))
  expect_equal(hdrda_out$est[[3]]$alpha, 1)
  expect_equal(hdrda_out$est[[3]]$XU, XU_3)
  expect_equal(hdrda_out$est[[3]]$xbar_U1, xbar3_U1)
  expect_equal(hdrda_out$est[[3]]$Gamma, D_q)
  expect_equal(hdrda_out$est[[3]]$Q, diag(n3))
  expect_equal(hdrda_out$est[[3]]$W_inv, diag(D_q^(-1)))
})

test_that("HDRDA's statistics match manual values when (lambda, gamma) = (0.5, 0.5)", {
  set.seed(42)
  p <- 250
  n1 <- 10
  n2 <- 15
  n3 <- 25

  iris_x <- as.matrix(iris[, -5])

  # The first cov matrix is the identity matrix.
  # To generate sigma2 and sigma3, we grab eigenvectors from the iris data set.
  # The eigenvalues are randomly generated.
  eigen2 <- eigen(tcrossprod(iris_x[rep(1:100, length=p), ]), symmetric=TRUE)
  eigen3 <- eigen(tcrossprod(iris_x[rep(30:130, length=p), ]), symmetric=TRUE)

  eigen2$values <- sort(rexp(p, rate=0.1), decreasing=TRUE)
  eigen3$values <- sort(rexp(p, rate=0.05), decreasing=TRUE)

  sigma2 <- with(eigen2, vectors %*% tcrossprod(diag(values), vectors))
  sigma3 <- with(eigen3, vectors %*% tcrossprod(diag(values), vectors))

  x1 <- rmvnorm(n1, mean=rep(0, p), sigma=diag(p))
  x2 <- rmvnorm(n2, mean=rep(3, p), sigma=sigma2)
  x3 <- rmvnorm(n3, mean=rep(-3, p), sigma=sigma3)

  x <- rbind(x1, x2, x3)
  colnames(x) <- paste0("x", 1:ncol(x))
  y <- c(rep(1, n1), rep(2, n2), rep(3, n3))
  y_fac <- factor(letters[y])

  # Compute estimates for HDRDA manually.
  xbar1 <- colMeans(x1)
  xbar2 <- colMeans(x2)
  xbar3 <- colMeans(x3)

  x_centered1 <- scale(x1, center=TRUE, scale=FALSE)
  x_centered2 <- scale(x2, center=TRUE, scale=FALSE)
  x_centered3 <- scale(x3, center=TRUE, scale=FALSE)

  Sigma_eigen <- cov_eigen(x=x, y=y_fac, pool=TRUE, fast=TRUE, tol=1e-6)
  D_q <- Sigma_eigen$values
  U1 <- Sigma_eigen$vectors
  q <- length(D_q)

  XU_1 <- x_centered1 %*% U1
  XU_2 <- x_centered2 %*% U1
  XU_3 <- x_centered3 %*% U1

  xbar1_U1 <- crossprod(U1, xbar1)
  xbar2_U1 <- crossprod(U1, xbar2)
  xbar3_U1 <- crossprod(U1, xbar3)

  Gamma <- 0.5 * diag(D_q) + 0.5 * diag(q)
  Gamma_inv <- diag(diag(Gamma)^(-1))

  W_1 <- 0.5 * cov_mle(XU_1) + Gamma
  W_2 <- 0.5 * cov_mle(XU_2) + Gamma
  W_3 <- 0.5 * cov_mle(XU_3) + Gamma

  W1_inv <- solve_chol(W_1)
  W2_inv <- solve_chol(W_2)
  W3_inv <- solve_chol(W_3)

  Q1 <- diag(n1) + 0.5 / n1 * XU_1 %*% tcrossprod(Gamma_inv, XU_1)
  Q2 <- diag(n2) + 0.5 / n2 * XU_2 %*% tcrossprod(Gamma_inv, XU_2)
  Q3 <- diag(n3) + 0.5 / n3 * XU_3 %*% tcrossprod(Gamma_inv, XU_3)

  hdrda_out <- rda_high_dim(x=x, y=y_fac, lambda=0.5, gamma=0.5)

  expect_equal(hdrda_out$q, q)
  expect_equal(hdrda_out$D_q, D_q)
  expect_equal(hdrda_out$U1, U1)

  expect_equal(hdrda_out$est[[1]]$n, n1)
  expect_equal(hdrda_out$est[[1]]$xbar, xbar1)
  expect_equal(hdrda_out$est[[1]]$prior, n1 / length(y))
  expect_equal(hdrda_out$est[[1]]$alpha, 1)
  expect_equal(hdrda_out$est[[1]]$XU, XU_1)
  expect_equal(hdrda_out$est[[1]]$xbar_U1, xbar1_U1)
  expect_equal(hdrda_out$est[[1]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[1]]$Q, Q1)
  expect_equal(hdrda_out$est[[1]]$W_inv, W1_inv)

  expect_equal(hdrda_out$est[[2]]$n, n2)
  expect_equal(hdrda_out$est[[2]]$xbar, xbar2)
  expect_equal(hdrda_out$est[[2]]$prior, n2 / length(y))
  expect_equal(hdrda_out$est[[2]]$alpha, 1)
  expect_equal(hdrda_out$est[[2]]$XU, XU_2)
  expect_equal(hdrda_out$est[[2]]$xbar_U1, xbar2_U1)
  expect_equal(hdrda_out$est[[2]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[2]]$Q, Q2)
  expect_equal(hdrda_out$est[[2]]$W_inv, W2_inv)

  expect_equal(hdrda_out$est[[3]]$n, n3)
  expect_equal(hdrda_out$est[[3]]$xbar, xbar3)
  expect_equal(hdrda_out$est[[3]]$prior, n3 / length(y))
  expect_equal(hdrda_out$est[[3]]$alpha, 1)
  expect_equal(hdrda_out$est[[3]]$XU, XU_3)
  expect_equal(hdrda_out$est[[3]]$xbar_U1, xbar3_U1)
  expect_equal(hdrda_out$est[[3]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[3]]$Q, Q3)
  expect_equal(hdrda_out$est[[3]]$W_inv, W3_inv)
})

test_that("HDRDA's statistics match manual values when (lambda, gamma) = (0.5, 0.75) and convex", {
  set.seed(42)
  p <- 250
  n1 <- 10
  n2 <- 15
  n3 <- 25

  iris_x <- as.matrix(iris[, -5])

  # The first cov matrix is the identity matrix.
  # To generate sigma2 and sigma3, we grab eigenvectors from the iris data set.
  # The eigenvalues are randomly generated.
  eigen2 <- eigen(tcrossprod(iris_x[rep(1:100, length=p), ]), symmetric=TRUE)
  eigen3 <- eigen(tcrossprod(iris_x[rep(30:130, length=p), ]), symmetric=TRUE)

  eigen2$values <- sort(rexp(p, rate=0.1), decreasing=TRUE)
  eigen3$values <- sort(rexp(p, rate=0.05), decreasing=TRUE)

  sigma2 <- with(eigen2, vectors %*% tcrossprod(diag(values), vectors))
  sigma3 <- with(eigen3, vectors %*% tcrossprod(diag(values), vectors))

  x1 <- rmvnorm(n1, mean=rep(0, p), sigma=diag(p))
  x2 <- rmvnorm(n2, mean=rep(3, p), sigma=sigma2)
  x3 <- rmvnorm(n3, mean=rep(-3, p), sigma=sigma3)

  x <- rbind(x1, x2, x3)
  colnames(x) <- paste0("x", 1:ncol(x))
  y <- c(rep(1, n1), rep(2, n2), rep(3, n3))
  y_fac <- factor(letters[y])

  # Compute estimates for HDRDA manually.
  xbar1 <- colMeans(x1)
  xbar2 <- colMeans(x2)
  xbar3 <- colMeans(x3)

  x_centered1 <- scale(x1, center=TRUE, scale=FALSE)
  x_centered2 <- scale(x2, center=TRUE, scale=FALSE)
  x_centered3 <- scale(x3, center=TRUE, scale=FALSE)

  Sigma_eigen <- cov_eigen(x=x, y=y_fac, pool=TRUE, fast=TRUE, tol=1e-6)
  D_q <- Sigma_eigen$values
  U1 <- Sigma_eigen$vectors
  q <- length(D_q)

  XU_1 <- x_centered1 %*% U1
  XU_2 <- x_centered2 %*% U1
  XU_3 <- x_centered3 %*% U1

  xbar1_U1 <- crossprod(U1, xbar1)
  xbar2_U1 <- crossprod(U1, xbar2)
  xbar3_U1 <- crossprod(U1, xbar3)

  Gamma <- 0.125 * diag(D_q) + 0.75 * diag(q)
  Gamma_inv <- diag(diag(Gamma)^(-1))

  W_1 <- 0.125 * cov_mle(XU_1) + Gamma
  W_2 <- 0.125 * cov_mle(XU_2) + Gamma
  W_3 <- 0.125 * cov_mle(XU_3) + Gamma

  W1_inv <- solve_chol(W_1)
  W2_inv <- solve_chol(W_2)
  W3_inv <- solve_chol(W_3)

  Q1 <- diag(n1) + 0.125 / n1 * XU_1 %*% tcrossprod(Gamma_inv, XU_1)
  Q2 <- diag(n2) + 0.125 / n2 * XU_2 %*% tcrossprod(Gamma_inv, XU_2)
  Q3 <- diag(n3) + 0.125 / n3 * XU_3 %*% tcrossprod(Gamma_inv, XU_3)

  hdrda_out <- rda_high_dim(x=x, y=y_fac, lambda=0.5, gamma=0.75, shrinkage_type="convex")

  expect_equal(hdrda_out$q, q)
  expect_equal(hdrda_out$D_q, D_q)
  expect_equal(hdrda_out$U1, U1)

  expect_equal(hdrda_out$est[[1]]$n, n1)
  expect_equal(hdrda_out$est[[1]]$xbar, xbar1)
  expect_equal(hdrda_out$est[[1]]$prior, n1 / length(y))
  expect_equal(hdrda_out$est[[1]]$alpha, 0.25)
  expect_equal(hdrda_out$est[[1]]$XU, XU_1)
  expect_equal(hdrda_out$est[[1]]$xbar_U1, xbar1_U1)
  expect_equal(hdrda_out$est[[1]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[1]]$Q, Q1)
  expect_equal(hdrda_out$est[[1]]$W_inv, W1_inv)

  expect_equal(hdrda_out$est[[2]]$n, n2)
  expect_equal(hdrda_out$est[[2]]$xbar, xbar2)
  expect_equal(hdrda_out$est[[2]]$prior, n2 / length(y))
  expect_equal(hdrda_out$est[[2]]$alpha, 0.25)
  expect_equal(hdrda_out$est[[2]]$XU, XU_2)
  expect_equal(hdrda_out$est[[2]]$xbar_U1, xbar2_U1)
  expect_equal(hdrda_out$est[[2]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[2]]$Q, Q2)
  expect_equal(hdrda_out$est[[2]]$W_inv, W2_inv)

  expect_equal(hdrda_out$est[[3]]$n, n3)
  expect_equal(hdrda_out$est[[3]]$xbar, xbar3)
  expect_equal(hdrda_out$est[[3]]$prior, n3 / length(y))
  expect_equal(hdrda_out$est[[3]]$alpha, 0.25)
  expect_equal(hdrda_out$est[[3]]$XU, XU_3)
  expect_equal(hdrda_out$est[[3]]$xbar_U1, xbar3_U1)
  expect_equal(hdrda_out$est[[3]]$Gamma, diag(Gamma))
  expect_equal(hdrda_out$est[[3]]$Q, Q3)
  expect_equal(hdrda_out$est[[3]]$W_inv, W3_inv)
})

test_that("HDRDA posterior probabilities sum to one. (Issue #34)", {
  trn <- two_class_sim_data[1:100,]
  tst <- two_class_sim_data[101:105,]

  mod <- rda_high_dim(x = as.matrix(trn[, -ncol(trn)]), y = trn$Class)

  posterior_probs <- predict(mod, newdata=tst[, -ncol(tst)], type = "prob")
  scores <- predict(mod, newdata=tst[, -ncol(tst)], type = "score")

  ones <- rep(1, nrow(tst))
  expect_equal(as.vector(rowSums(posterior_probs)), ones)
  expect_equal(colnames(posterior_probs), levels(two_class_sim_data$Class))
  expect_equal(colnames(scores), levels(two_class_sim_data$Class))
})

test_that("HDRDA correctly predicts one observation. (Issue #34)", {
  trn <- two_class_sim_data[1:100,]
  tst <- two_class_sim_data[101,]

  mod <- rda_high_dim(x = as.matrix(trn[, -ncol(trn)]), y = trn$Class)

  posterior_probs <- predict(mod, newdata=tst[, -ncol(tst)], type = "prob")
  scores <- predict(mod, newdata=tst[, -ncol(tst)], type = "score")

  expect_equal(sum(posterior_probs), 1)
  expect_equal(names(posterior_probs), levels(two_class_sim_data$Class))
  expect_equal(names(scores), levels(two_class_sim_data$Class))
})

# Related to issue #41
test_that("The HDRDA classifier works properly when 1 feature used", {
  require('MASS')

  train <- seq(1, 150, by = 3)

  hdrda_out <- rda_high_dim(x = iris[train, 1, drop = FALSE], y = iris[train, 5], lambda=0.5, gamma=0.5)
  predicted_cls   <- predict(hdrda_out, iris[-train, 1, drop = FALSE])
  predicted_prob  <- predict(hdrda_out, iris[-train, 1, drop = FALSE], type = "prob")
  predicted_score <- predict(hdrda_out, iris[-train, 1, drop = FALSE], type = "score")

  expect_equal(length(predicted_cls), 150 - length(train))
  expect_is(predicted_prob,  "data.frame")
  expect_is(predicted_score, "data.frame")
  expect_equal(dim(predicted_prob),  c(150 - length(train), nlevels(iris$Species)))
  expect_equal(dim(predicted_score), c(150 - length(train), nlevels(iris$Species)))
})


################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Waleed Almutiry <wkmtierie@qu.edu.sa>,
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>, and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
# Algorithm based on:
#                Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
#                M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
#                Inference for individual level models of infectious diseases in large
#                populations. Statistica Sinica, 20, 239-261.
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

pred.epi <- function (object, xx, criterion , n.samples, burnin = NULL, tmin = NULL, Sformula = NULL, Tformula = NULL, showProgressBar = interactive()) {

	if (!is(object, "epidata")) {
		stop("The object of the epidemic data must be in a class of \"epidata\"", call. = FALSE)
	}

	if (!is(xx, "epimcmc")) {
		stop("The object of the MCMC samples must be in a class of \"epimcmc\"", call. = FALSE)
	}

	n <- length(object$inftime)

	if (is.null(burnin)) {
		burnin <- 1
	}

	if (is.null(tmin)){
		tmin = 1
	}

	t_end <- max(object$inftime)

	ns <- xx$n.sus.par
	nt <- xx$n.trans.par
	ni <- xx$n.ker.par

    if (object$type == "SIR") {
        infperiod = object$remtime - object$inftime
    } else {
        infperiod = NULL
    }

	mcmcout_posterior <- matrix(xx$Fullsample[sample(seq(burnin,length(xx$Fullsample[,1])), n.samples, replace = FALSE), ],
                            nrow = n.samples,
                            ncol = ncol(xx$Fullsample))

	newinftime <- replace(object$inftime, object$inftime > tmin, 0)
	out1 <- vector(mode = "list", length = n.samples)

	if (is.null(object$contact)) {

		x <- object$XYcoordinates[,1]
		y <- object$XYcoordinates[,2]

		if (all((nt == 0) & (ns + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("generate", n.samples, "epidemics \n")
			if (showProgressBar) {
	    pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {
				if (showProgressBar && i %% update.step == 0) {
		      setTxtProgressBar(pb, i)
		    }

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1: ns]),
				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}
		} else if (all((nt > 0) & (ns + nt + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt == 0) & (ns + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1: ns]), trans.par = 1,
				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
				spark = mcmcout_posterior[i, (ns + ni + 1)],
				x = x, y = y, inftime = newinftime, infperiod = infperiod)
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
				spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
				x = x, y = y, inftime = newinftime, infperiod = infperiod)

			}
			if (showProgressBar) {
				close(pb)
			}
		}

	} else {

		contact <- object$contact

		if (all((nt == 0) & (ns + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) == ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
    				beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt == 0) & (ns + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
  				out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
    				sus.par = c(mcmcout_posterior[i, 1: ns]),
    				beta = c(mcmcout_posterior[i, (ns + 1): (ns + ni)]),
    				spark = mcmcout_posterior[i, (ns + ni + 1)],
    				contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1: ns]),
            spark = mcmcout_posterior[i, (ns + ni + 1)],
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}

			if (showProgressBar) {
				close(pb)
			}

		} else if (all((nt > 0) & (ns + nt + ni) < ncol(xx$Fullsample)) == TRUE) {

			cat("  generate", n.samples, "epidemics \n")
			if (showProgressBar) {
			pb <- txtProgressBar(min = 0, max = n.samples, style = 3)
			}
			update.step <- max(5, floor(n.samples/100))

			for (i in 1:n.samples) {

				if (showProgressBar && i %% update.step == 0) {
					setTxtProgressBar(pb, i)
				}

        if (ni != 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            beta = c(mcmcout_posterior[i, (ns+nt+1): (ns+nt+ni)]),
            spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        } else if (ni == 0) {
          out1[[i]] <- epidata(type = object$type, n = n, tmax = t_end, Sformula = Sformula, Tformula = Tformula, tmin = tmin,
            sus.par = c(mcmcout_posterior[i, 1:ns]), trans.par = c(mcmcout_posterior[i, (ns+1): (ns+nt)]),
            spark = c(mcmcout_posterior[i, (ns+nt+ni+1)]),
            contact = contact, inftime = newinftime, infperiod = infperiod)
        }
			}
			if (showProgressBar) {
				close(pb)
			}
		}

	}

	if (criterion == "newly infectious") {

		crit <- matrix(0, ncol = t_end, nrow = n.samples)

		for (j in 1:n.samples) {
			newinf <- rep(0)
			for (i in 1: t_end) {
				newinf[i] <- sum(out1[[j]]$inftime == i)
			}
			crit[j,] <- newinf
		}

		crit_true <- rep(0)
		for (i in 1: t_end) {
			crit_true[i] <- length(object$inftime[object$inftime == i])
		}

		result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

	} else if (criterion == "epidemic length") {

		if (object$type == "SI") {

			crit <- NULL

			for (j in 1:n.samples) {
				crit[j] <- max(out1[[j]]$inftime) - min(out1[[j]]$inftime)
			}

			crit_true <- max(object$inftime) - min(object$inftime)

		} else if (object$type == "SIR") {

			crit <- NULL

			for (j in 1:n.samples) {
				crit[j] <- max(out1[[j]]$remtime) - min(out1[[j]]$inftime)
			}

			crit_true <- max(object$remtime) - min(object$inftime)

		}
			result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

			} else if (criterion == "peak time") {

		    if (object$type == "SI") {

		      crit <- NULL

		      for (j in 1:n.samples) {

		        oot <- out1[[j]]$inftime[which(out1[[j]]$inftime!=0)]

		        dff <- as.data.frame(table(oot))

		        res <- dff[which(dff[, 2] == max(dff[, 2])), 1]

		        if (length(res) > 1) {

		          crit[j] <- max(as.numeric(as.character(res)))

		        } else {

		          crit[j] <- as.numeric(as.character(res))

		        }

		      }

		      oot <- object$inftime[which(object$inftime!=0)]

		      dff <- as.data.frame(table(oot))

		      crit_true <- max(as.numeric(as.character(dff[which(dff[, 2] == max(dff[, 2])), 1])))

		      result <- list(type = object$type, criterion = criterion, crit.sim = crit, crit.obs = crit_true, tmin = tmin, tmax = t_end, n.samples = n.samples)

		    } else if (object$type == "SIR") {

		      crit_inf <- NULL

		      crit_rem <- NULL

		      for (j in 1:n.samples) {

		        oot <- out1[[j]]$inftime[which(out1[[j]]$inftime!=0)]

		        oot1 <- out1[[j]]$remtime[which(out1[[j]]$remtime!=0)]

		        dff <- as.data.frame(table(oot))

		        dff1 <- as.data.frame(table(oot1))

		        res <- dff[which(dff[, 2] == max(dff[, 2])), 1]

		        res1<- dff1[which(dff1[, 2] == max(dff1[, 2])), 1]

		        if (length(res) > 1) {

		          crit_inf[j] <- max(as.numeric(as.character(res)))

		        } else {

		          crit_inf[j] <- as.numeric(as.character(res))

		        }

		        if (length(res1) > 1) {

		          crit_rem[j] <- max(as.numeric(as.character(res1)))

		        } else {

		          crit_rem[j] <- as.numeric(as.character(res1))

		        }

		      }

		      oot <- object$inftime[which(object$inftime!=0)]

		      oot1 <- object$remtime[which(object$remtime!=0)]

		      dff <- as.data.frame(table(oot))

		      dff1 <- as.data.frame(table(oot1))

		      crit_true_inf <- max(as.numeric(as.character(dff[which(dff[, 2] == max(dff[, 2])), 1])))

		      crit_true_rem <- max(as.numeric(as.character(dff1[which(dff1[, 2] == max(dff1[, 2])), 1])))

		      result <- list(type = object$type, criterion = criterion, crit.sim = list(crit_inf, crit_rem),
		                     crit.obs = list(crit_true_inf, crit_true_rem), tmin = tmin, tmax = t_end, n.samples = n.samples)

		    }

		  }

		  class(result) <- "pred.epi"

		  result

}

plot.pred.epi <- function (x, ...) {

	if (!is(x, "pred.epi")) {
		stop("The object must be in a class of \"pred.epi\"", call. = FALSE)
	}

	if (x$criterion == "newly infectious") {

		lowerq <- NULL
		upperq <- NULL

		for (i in 1: x$tmax) {
			lowerq[i] <- quantile(x$crit.sim[,i], 0.025)
			upperq[i] <- quantile(x$crit.sim[,i], 0.975)
		}

		time <- rep(1: x$tmax)
		mx <- max(upperq)
		mn <- min(lowerq)

		plot (time, x$crit.obs, xlim = c(min(time), max(time)), ylim = c(mn, mx),
			ylab = "Newly infections", xlab =" Time", xaxt = "n", col = "black", type = "o", pch = 20)

		axis(1, at = 1:max(time))

		for (i in 1: x$n.samples) {
            lines(time[x$tmin:x$tmax], x$crit.sim[i,x$tmin:x$tmax], col = "grey", lwd = 0.2)
		}

    lines(time[x$tmin:x$tmax], apply(x$crit.sim[,x$tmin:x$tmax], 2, mean), lty = 1, ...)
    lines(time, x$crit.obs, col = "black", type = "o", pch = 20, lwd = 2)

		axis(1, at = 1:max(time))
		lines(time[x$tmin:x$tmax], lowerq[x$tmin:x$tmax], lty = 2, ...)
		lines(time[x$tmin:x$tmax], upperq[x$tmin:x$tmax], lty = 2, ...)

	} else if (x$criterion == "epidemic length") {

		hist(x$crit.sim, main = "", xlab = "The length of epidemic", ylab = "Time", ...)
		abline(v = quantile(x$crit.sim, c(0.025, 0.975)), col = "red", lty = 2)
		abline(v = mean(x$crit.sim), col = "red")
		abline(v = x$crit.obs, col = "blue")

	} else if (x$criterion == "peak time") {

		if(x$type == "SI") {

			hist(x$crit.sim, main = "", xlab = "The time of the peak of infection times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim, c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim), col = "red")
			abline(v = x$crit.obs, col = "blue")

		} else if (x$type == "SIR") {

      par(mfrow = c(1, 2))

			hist(x$crit.sim[[1]], main = "", xlab = "The time of the peak of infection times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim[[1]], c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim[[1]]), col = "red")
			abline(v = x$crit.obs[[1]], col = "blue")

			hist(x$crit.sim[[2]], main = "", xlab = "The time of the peak of removal times", ylab = "Time", ...)
			abline(v = quantile(x$crit.sim[[2]], c(0.025, 0.975)), col = "red", lty = 2)
			abline(v = mean(x$crit.sim[[2]]), col = "red")
			abline(v = x$crit.obs[[2]], col = "blue")

		}
	}
}


#VIOLIN PLOTS
library(vioplot)
x1 <- mtcars$mpg[mtcars$cyl==4]
x2 <- mtcars$mpg[mtcars$cyl==6]
x3 <- mtcars$mpg[mtcars$cyl==8]
vioplot(x1,x2,x3, names=c("4 cyl","6 cyl", "8 cyl"), col='gold')
title("Violin Plots of Miles per Gallon")


graticules<-function(disx=10,disy=10,proj="NA"){
	x<-seq(-180,180,disx)
	y<-seq(-90,90,disy)

	EW<-list()
	for(i in 1:length(x)){
		l<-cbind(rep(x[i],1000),seq(-90,90,length.out=1000))
		EW[[i]]<-Line(l)
	}
	EW<-Lines(EW,ID=c("EW"))
	NS<-list()
	for(i in 1:length(y)){
		l<-cbind(seq(-180,180,length.out=1000),rep(y[i],1000))
		NS[[i]]<-Line(l)
	}
	NS<-Lines(NS,ID=c("NS"))
	out<-SpatialLines(list(EW,NS),proj4string=CRS(proj_latlon))
	if(proj!="NA"){
		out<-spTransform(out,CRS(proj))
	}
	return(out)
}

LabelsDegreeEW<-function (x) {
    x <- ifelse(x > 180, x - 360, x)
    pos = sign(x) + 2
    if (any(x == -180))
        pos[x == -180] = 2
    if (any(x == 180))
        pos[x == 180] = 2
    dir = c("°W", "°", "°E")
    paste(abs(x), dir[pos])
}

LabelsDegreeNS<-function (x)
{
    pos = sign(x) + 2
    dir = c("°S", "°", "°N")
    paste(abs(x), dir[pos])
}

gratText<-function(graticule,lim){
	if(graticule@lines[[1]]@ID!="EW") stop("graticule class id is not correct.\n")
	if(graticule@lines[[2]]@ID!="NS") stop("graticule class id is not correct.\n")
	wbound_lon<-lim[1]
	sbound_lat<-lim[3]
	ebound_lon<-lim[2]
	nbound_lat<-lim[4]

	grat_ew<-graticule@lines[[1]]@Lines
	grat_ns<-graticule@lines[[2]]@Lines

	txt_pos_ew<-data.frame()
	txt_pos_ns<-data.frame()
	for(i in 1:length(grat_ew)){
		ew_lon<-grat_ew[[i]]@coords[,1]
		ew_lat<-grat_ew[[i]]@coords[,2]

		diff<-abs(sbound_lat-ew_lat)
		diff<-cbind(diff,seq(1,length(diff)))
		diff<-diff[order(diff[,1]),]
		# check three closest values and exclude the values that are outbound
		for(j in 1:3){
			ind_<-diff[j,2]
			if(ew_lon[ind_]>=wbound_lon&ew_lon[ind_]<=ebound_lon){
				ind<-ind_
				break
			}else{
				ind<-NA
			}
		}
		if(!is.na(ind) ){
			west_bound<-c(ew_lon[ind],ew_lat[ind])
			txt_pos_ew<-rbind(txt_pos_ew,west_bound)
		}
	}

	for(i in 1:length(grat_ns)){
		sn_lat<-grat_ns[[i]]@coords[,2]
		sn_lon<-grat_ns[[i]]@coords[,1]

		diff<-abs(wbound_lon-sn_lon)
		diff<-cbind(diff,seq(1,length(diff)))
		diff<-diff[order(diff[,1]),]
		for(j in 1:3){ # check three closest values and exclude the values that are outbound
			ind_<-diff[j,2]
			if(sn_lat[ind_]>=sbound_lat&sn_lat[ind_]<=nbound_lat){
				ind<-ind_
				break
			}else{
				ind<-NA
			}
		}
		if(!is.na(ind) ){
		south_bound<-c(sn_lon[ind],sn_lat[ind])
		txt_pos_ns<-rbind(txt_pos_ns,south_bound)
		}

	}
	spoints_ew<-SpatialPoints(txt_pos_ew, CRS(projection(graticule)))
	spoints_ns<-SpatialPoints(txt_pos_ns, CRS(projection(graticule)))

 	if(projection(graticule)!=proj_latlon){
		latlon_ew<-as.data.frame(spTransform(spoints_ew,CRS(proj_latlon)))
		latlon_ns<-as.data.frame(spTransform(spoints_ns,CRS(proj_latlon)))
	}else{
		latlon_ew<-as.data.frame(spoints_ew)
		latlon_ns<-as.data.frame(spoints_ns)
	}

	text<-list()
	text[["x"]]<-data.frame(lon=txt_pos_ew[,1],txt=LabelsDegreeEW(round(latlon_ew[,1],digits=1)))
	text[["y"]]<-data.frame(lon=txt_pos_ns[,2],txt=LabelsDegreeNS(round(latlon_ns[,2],digits=1)))

	return(text)
}


d <- data.frame(a=c(2,4,6), b = c(5,7,9))
also <- c(1, 0, 2)
with(d, mean(b - a + also)) #returns 4

## with() is built in, but you might have implemented it like this:

with.impl <- function(env, expr) {
  env <- as.environment(env)
  parent.env(env) <- parent.frame()
  eval(substitute(expr), envir=env)
}
with.impl(d, mean(b - a + also))


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R

 library(jpeg)
 library(ggplot2)

 img <- readJPEG("d:/Image.jpg")

 img_Dim <- dim(img)

 img_Dim
[1] 526 800   3

 img_RGB_channels  <- data.frame(
     x = rep(1:img_Dim[2], each = img_Dim[1]),
     y = rep(img_Dim[1]:1, img_Dim[2]),
     R = as.vector(img[,,1]),
     G = as.vector(img[,,2]),
     B = as.vector(img[,,3])
 )

plotTheme <- function() {
  theme(
    panel.background = element_rect(
      size = 3,
      colour = "black",
      fill = "white"),
    axis.ticks = element_line(
      size = 2),
    panel.grid.major = element_line(
      colour = "gray80",
      linetype = "dotted"),
    panel.grid.minor = element_line(
      colour = "gray90",
      linetype = "dashed"),
    axis.title.x = element_text(
      size = rel(1.2),
      face = "bold"),
    axis.title.y = element_text(
      size = rel(1.2),
      face = "bold"),
    plot.title = element_text(
      size = 20,
      face = "bold",
      vjust = 1.5)
  )
}

 ggplot(data = img_RGB_channels, aes(x = x, y = y)) +
     geom_point(colour = rgb(img_RGB_channels[c("R", "G", "B")])) +
     labs(title = "Original Image: Colorful Bird") +
     xlab("x") +
     ylab("y") +
     plotTheme()

 kClusters <- 3

 kMeans_clst <- kmeans(img_RGB_channels[, c("R", "G", "B")], centers = kClusters)

 kColours <- rgb(kMeans_clst$centers[kMeans_clst$cluster,])

 ggplot(data = img_RGB_channels, aes(x = x, y = y)) +
     geom_point(colour = kColours) +
     labs(title = paste("k-Means Clustering of", kClusters, "Colours")) +
     xlab("x") +
     ylab("y") +
     plotTheme()

 kClusters <- 5

 kMeans_clst <- kmeans(img_RGB_channels[, c("R", "G", "B")], centers = kClusters)

 kColours <- rgb(kMeans_clst$centers[kMeans_clst$cluster,])

 ggplot(data = img_RGB_channels, aes(x = x, y = y)) +
     geom_point(colour = kColours) +
     labs(title = paste("k-Means Clustering of", kClusters, "Colours")) +
     xlab("x") +
     ylab("y") +
     plotTheme()

 ggplot(data = img_RGB_channels, aes(x = x, y = y)) +
     geom_point(colour = rgb(img_RGB_channels[c("R", "G", "B")])) +
     labs(title = "Original Image: Colorful Bird") +
     xlab("x") +
     ylab("y") +
     plotTheme()

 kClusters <- 3

 kMeans_clst <- kmeans(imgRGB[, c("R", "G", "B")], centers = kClusters)

 kColours <- rgb(kMeans_clst$centers[kMeans_clst$cluster,])

 ggplot(data = imgRGB, aes(x = x, y = y)) +
     geom_point(colour = kColours) +
     labs(title = paste("k-Means Clustering of", kClusters, "Colours")) +
     xlab("x") +
     ylab("y") +
     plotTheme()

 kClusters <- 5

 kMeans_clst <- kmeans(imgRGB[, c("R", "G", "B")], centers = kClusters)

 kColours <- rgb(kMeans_clst$centers[kMeans_clst$cluster,])

 ggplot(data = imgRGB, aes(x = x, y = y)) +
     geom_point(colour = kColours) +
     labs(title = paste("k-Means Clustering of", kClusters, "Colours")) +
     xlab("x") +
     ylab("y") +
     plotTheme()

Chapter 07/2Vector Quantization - Image Clustering.r


#'@title calcPropPwr
#'
#'@description Calculates ship power (kW) using the propeller law.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of
#' numericals, kW) (maximum
#' continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param refSpeed Reference speed of the ship (service speed or maximum speed)
#' (vector of numericals, m/s)
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10}
#' Can supply either a vector of numericals, a single number, or rely on the default
#' @param n Exponential relationship applied to the ship speed ratio (dimensionless).
#' Default = 3. This argument is not vectorized, so supply a single number or rely
#' on the default
#' @param refSpeedType Indicates if the reference speed is service speed or
#' maximum speed: \itemize{
#' \item "serviceSpeed (Default)"
#' \item "maxSpeed"}
#' Can supply either a vector of strings, a single value, or rely on the default.
#'
#'@return power (vector of numericals, kW)
#'
#'@details
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' serviceMargin = 10 or 15, based on IMO (Prpic Orsic and Faltinsen, 2012).
#' 15 indicates 15\% increased resistance in at-sea water conditions, and 10
#' indicates 10\% increased resistance in coastal water conditions.
#'
#' Note that service margin is treated as an added resistance here
#' (instead of as a reduced efficiency) to maintain consistency with the other
#' power models used in this library. (See MAN, 2011).
#'
#'@references
#'\href{https://nepis.epa.gov/Exe/ZyPURL.cgi?Dockey=P1005ZGH.TXT}{EPA. 2009.
#'"Regulatory impact analysis: Control of emissions air pollution from category
#'3 marine diesel engines." Ann Arbor, MI: Office of Transportation and Air
#'Quality. US Environmental Protection Agency.}
#'
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcAdmPwr}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("Propeller.Law.Example", package="ShipPowerModel")}
#'}
#'
#'@examples
#'calcPropPwr(totalInstalledPwr = 9363,
#'            shipSpeed = seq(10,14,1),
#'            refSpeed = 15,
#'            serviceMargin = 15,
#'            n = 3)
#'
#'@export

calcPropPwr <- function(totalInstalledPwr, shipSpeed, refSpeed, serviceMargin=15, n=3,refSpeedType = "serviceSpeed"){

  #The propeller law method requires the the reference speed to be maximum speed, to be consistent with the other terms
  #Convert service speed to maximum speed by assuming service speed is 94% of maximum speed
  refSpeed<-ifelse(tolower(refSpeedType) == "servicespeed",
                   refSpeed/0.94,
                   refSpeed
                   )#end ifelse

  power <- ifelse(shipSpeed==0,
                  0,
                  (totalInstalledPwr*
                    pmin(1,#set maximum power to 100%
                         pmax(.02,#limit minimum power to 2%
                              (shipSpeed/refSpeed)^(n)*
                              ((100+serviceMargin)/100)
                             )
                        )
                  )
                 )#end ifelse
  return(power)
}


##
## does position in gift network predict herd size and/or no. kids?
##
library(tidyverse)
library(rstanarm)
library(loo)
library(bayesplot)
library(futile.logger)

options(mc.cores = parallel::detectCores())

source("init if necessary.r")
source("model comparison functions.r")

# data for analyses
d.cattle = people %>%
  select(HerderID, Pop, cattle.z, Age.z, Sexb, gift.deg.in, gift.betweenness, gift.eigen) %>%
  na.omit(.)

# uncomment this if you want to fit the models to only the Saami sites
# d.cattle = d.cattle %>%
#   filter(Pop %in% c("karasjok", "kautokeino")) %>%
#   mutate(Pop = forcats::fct_drop(Pop))

################################################################
## Plot descriptives
##
# plot association between age and herd size (with LOESS smoothers)
people %>%
  select(Pop, Age, HerdSize) %>%
  na.omit(.) %>%
  mutate(PopName = convert_pop(Pop)) %>%

  ggplot(aes(x=Age, y=HerdSize)) +
    geom_point(aes(colour=PopName), alpha=0.3) +
    geom_smooth(aes(colour=PopName, fill=PopName), se=T) +
    facet_wrap(~PopName, scales="free_y") +
    ylab("Herd size") +
    common_theme

ggsave(filename=file.path(plots.dir, "Age and herd size.png"), width=250, height=150, units="mm")
ggsave(filename=file.path(plots.dir, "Age and herd size.pdf"), width=200, height=120, units="mm")

# does age predict herd size? No.
# library(broom)
#
# d.cattle %>%
#   group_by(Pop) %>%
#   #do(tidy(lm(HerdSize ~ Age, data=.))) %>%
#   do(tidy(cor.test(~ HerdSize + Age, data=.))) %>%
#   mutate(p.value = round(p.value, 4))

################################################################
## Predicting herd size
##
flog.info("Fitting herd size models")

m.herd.null = stan_lmer(cattle.z ~ 1 + (1 | Pop),
                        data=d.cattle,
                        prior_intercept=normal(0, 5),
                        adapt_delta=0.99, chains=4, cores=2)

m.herd.control = stan_lmer(cattle.z ~ Age.z + Sexb + (1 | Pop),
                           data=d.cattle,
                           prior_intercept=normal(0, 5), prior=normal(0, 5),
                           adapt_delta=0.99, chains=4, cores=2)

m.herd.deg = stan_lmer(cattle.z ~ gift.deg.in + Age.z + Sexb + (1 | Pop),
                       data=d.cattle,
                       prior_intercept=normal(0, 5), prior=normal(0, 5),
                       adapt_delta=0.99, chains=4, cores=2)

m.herd.deg_int = stan_lmer(cattle.z ~ gift.deg.in * Age.z + Sexb + (1 | Pop),
                           data=d.cattle,
                           prior_intercept=normal(0, 5), prior=normal(0, 5),
                           adapt_delta=0.99, chains=4, cores=2)

m.herd.btwn = stan_lmer(cattle.z ~ gift.betweenness + Age.z + Sexb + (1 | Pop),
                        data=d.cattle,
                        prior_intercept=normal(0, 5), prior=normal(0, 5),
                        adapt_delta=0.99, chains=4, cores=2)

m.herd.eigen = stan_lmer(cattle.z ~ gift.eigen + Age.z + Sexb + (1 | Pop),
                         data=d.cattle,
                         prior_intercept=normal(0, 5), prior=normal(0, 5),
                         adapt_delta=0.99, chains=4, cores=2)

################################################################
## Model selection
##
flog.info("Comparing herd size models")

loo.herd.null    = loo(m.herd.null)
loo.herd.control = loo(m.herd.control)
loo.herd.deg     = loo(m.herd.deg)
loo.herd.btwn    = loo(m.herd.btwn)
loo.herd.eigen   = loo(m.herd.eigen)

loo.herd.deg_int = loo(m.herd.deg_int)
ll.herd.deg_int = log_lik(m.herd.deg_int)

ll.herd.null    = log_lik(m.herd.null)
ll.herd.control = log_lik(m.herd.control)
ll.herd.deg     = log_lik(m.herd.deg)
ll.herd.btwn    = log_lik(m.herd.btwn)
ll.herd.eigen   = log_lik(m.herd.eigen)

m.herd.loos         = compare_models_delta(loo.herd.null, loo.herd.control, loo.herd.deg, loo.herd.deg_int, loo.herd.btwn, loo.herd.eigen)
m.herd.loos.weights = model_weights(list(ll.herd.null, ll.herd.control, ll.herd.deg, ll.herd.deg_int, ll.herd.btwn, ll.herd.eigen))
m.herd.loos.sel     = model_select(list(ll.herd.null, ll.herd.control, ll.herd.deg, ll.herd.deg_int, ll.herd.btwn, ll.herd.eigen))

##
## save model comparison table
##
m_names = c(m.herd.null    ="(Varying intercepts only)",
            m.herd.control = "Controls only: Age + Sex",
            m.herd.deg     = "In-degree",
            m.herd.deg_int = "In-degree × Age",
            m.herd.btwn    = "Betweenness",
            m.herd.eigen   = "Eigenvector centrality")

names(m.herd.loos.weights) = c("m.herd.null", "m.herd.control", "m.herd.deg", "m.herd.deg_int", "m.herd.btwn", "m.herd.eigen")

# add stacking weights to table (in correct order)
m.herd.loos$stacking = round(m.herd.loos.weights[row.names(m.herd.loos)], 4)  # m.herd.loos.weights[ m_order ]

# add model names to table
#m_order = as.integer( gsub("model([0-9])", "\\1", row.names(m.herd.loos)) )  # get order of models from lowest to highest delta
row.names(m.herd.loos) = m_names[row.names(m.herd.loos)]  #m_names[ m_order ]

# calculate and save variance partition coefficients
vpc.herd.deg = VarCorr(m.herd.deg) %>%
  dplyr::as_data_frame() %>%
  mutate(vpc = vcov / sum(vcov))

##
## save everything
##
write.csv( subset(m.herd.loos, select=c(delta, d_se, stacking)),
           file.path(results.dir, "social network analysis of herd size.csv"), row.names=T)

write.csv(vpc.herd.deg, file.path(results.dir, "herd size model VPCs.csv"), row.names=F)

save(d.cattle,
     m.herd.null, m.herd.control, m.herd.deg, m.herd.btwn, m.herd.eigen,
     loo.herd.null, loo.herd.control, loo.herd.deg, loo.herd.deg_int, loo.herd.btwn, loo.herd.eigen,
     ll.herd.null, ll.herd.control, ll.herd.deg, ll.herd.deg_int, ll.herd.btwn, ll.herd.eigen,
     m.herd.loos, m.herd.loos.weights, m.herd.loos.sel, vpc.herd.deg,
     file=file.path(models.dir, "herd size models.RData"))

########################################
## plot parameter estimates
##
flog.info("Plotting parameter estimates")

draws = as.data.frame(m.herd.deg)
names(draws) = c("(Intercept)", "No. gifts received", "Age (z-score)", "Sex (0 = male)",
                 "Tibet: Cairima intercept", "Tibet: Doulong intercept", "Tibet: Jilehe intercept",
                 "Finnmark: Karasjok intercept", "Finnmark: Kautokeino intercept", "Tibet: Tawa intercept",
                 "Between-herder variance", "Between-site variance")

# put param names in a better order (mainly study sites)
draws = draws %>%
  select("(Intercept)", "No. gifts received", "Age (z-score)", "Sex (0 = male)",
         starts_with("Finnmark"), starts_with("Tibet"), everything())

mcmc_intervals(draws, prob = 0.8, prob_outer = 0.95) +
  xlab("Coefficient") +
  theme_bw() +
  theme(panel.spacing = unit(0, "lines")
        ,strip.background = element_blank()
        ,strip.placement = "outside"
        ,plot.background = element_blank()
        ,panel.grid.major = element_blank()
        ,panel.grid.minor = element_blank()
        ,panel.background = element_blank()
  )

ggsave(file.path(plots.dir, "Prediction intervals - herd sizes from gifts received.png"), height=100, width=200, units="mm")
ggsave(file.path(plots.dir, "Prediction intervals - herd sizes from gifts received.pdf"), height=100, width=200, units="mm")

########################################
## predicted deviation in herd size given no. gifts received
##
flog.info("Plotting predictions")

new.data = expand.grid(
  gift.deg.in = seq(from=min(d.cattle$gift.deg.in), to=max(d.cattle$gift.deg.in)),
  Age.z = 0,
  Sexb = 0:1,
  Pop = "",
  cattle.z = 0
)

post = posterior_predict(m.herd.deg, new.data, re.form = NA)
pred = posterior_linpred(m.herd.deg, new.data, transform=T, re.form = NA)

quants = apply(post, 2, quantile, probs = c(0.025, 0.5, 0.975))  # quantiles over mcmc samples
quants2 = apply(pred, 2, quantile, probs = c(0.025, 0.5, 0.975))  # quantiles over mcmc samples
row.names(quants) = c("sim.lwr", "sim.med", "sim.upr")
row.names(quants2) = c("lwr", "herd.pred", "upr")

new.data = cbind(new.data, t(quants), t(quants2))

ggplot(new.data, aes(x=gift.deg.in, y=herd.pred)) +
  geom_line(aes(colour=factor(Sexb))) +
  geom_ribbon(aes(ymin=lwr, ymax=upr, fill=factor(Sexb)), alpha=0.2) +

  scale_colour_manual(values = cols) +
  scale_fill_manual(values = cols) +

  xlab("No. gifts received") +
  ylab("Herd size (z-score)") +

  # plot relatedness on log scale with breaks at familiar points
  scale_x_continuous(breaks=c(0,2,4,6,8,10)) +

  common_theme

ggsave(filename=file.path(plots.dir, "Predicted herd size from gifts received.png"), width=100, height=80, units="mm")
ggsave(filename=file.path(plots.dir, "Predicted herd size from gifts received.pdf"), width=100, height=80, units="mm")


NOF_POINTS <- 10000
NOF_CLUSTERS <- 3

X <- runif(NOF_POINTS)
Y <- runif(NOF_POINTS)
DF <- data.frame(X, Y)

CLUSTERS <- kmeans(DF, NOF_CLUSTERS)
plot(X, Y, col = CLUSTERS$cluster + 1)


library(RTextTools)
library(tm)

cosinesim<-function(query,document){
  corpus<-create_matrix(documents,removeStopwords = T,stemWords = T)
  corpus<- as.matrix(corpus)
  q1matrix<-create_matrix(q1,originalMatrix = corpus,removeStopwords = T,stemWords = T)
  q1matrix<-as.matrix(q1matrix)
  cosine = c()
  for (i in 1:3){
  cosine_sim = crossprod(corpus[i,],q1matrix[1,])/sqrt(crossprod(corpus[i,])*crossprod(q1matrix[1,]))
  cosine = append(cosine,cosine_sim)
  }
  return(cosine)
}


leafNumber1 =leafNumber
ntip=0
if (phase == 1 and cumulTTPhenoMaizeAtEmergence == 0):
    cumulTTPhenoMaizeAtEmergence = cumulTT
if (phase >= 1 and phase< 4):
    if (hasFlagLeafLiguleAppeared==0):
        if (switchMaize==0):
            if (phyllochron == 0.0):
                phyllochron = 0.0000001
            leafNumber = leafNumber1 + min(deltaTT / phyllochron, 0.999)
            ntip=0
        else:
            if (leafNumber1 < leaf_tip_emerg):
                leafNumber = leaf_tip_emerg
            else:
                nextstartExpTT = 0
                nexttipTT = ((leafNumber1 + 1) - leaf_tip_emerg) / atip + cumulTTPhenoMaizeAtEmergence
                abl = k_bl * atip
                tt_lim_lip = ((nlim - leaf_tip_emerg) / atip) + cumulTTPhenoMaizeAtEmergence
                bbl = nlim - (abl * tt_lim_lip)
                tt_bl = ((leafNumber1 + 1) - bbl) / abl
                if (tt_bl > nexttipTT):
                    nextstartExpTT = nexttipTT
                else:
                    nextstartExpTT = tt_bl
                if (cumulTT >= nextstartExpTT):
                    leafNumber = leafNumber1 + 1
                else:
                    leafNumber = leafNumber1
            ntip = atip * (cumulTT - cumulTTPhenoMaizeAtEmergence) + leaf_tip_emerg


# create data
#set.seed(20130226)
n <- 200
x1 <- rnorm(n, mean = 2)
y1 <- 2.5 + 0.4 * x1 + rnorm(n)
x2 <- rnorm(n, mean = 0)
y2 <- 3.5 - 1.2 * x2 + rnorm(n)
class <- rep(c("A", "B"), each = n)
df <- data.frame(x = c(x1, x2), y = c(y1, y2), colour = class)

# get code for "stat_ellipse"
library(devtools)
library(ggplot2)
library(mmadsenr)
# scatterplot with confidence ellipses (but inner ellipse areas are not filled)
qplot(data = df, x = x, y = y, colour = class) + stat_ellipse(geom="polygon", alpha = 0.5, aes(fill = class))


#### 반복측정 분산분석(Repeated Measures ANOVA) #####

# 01.데이터 불러오기
rma.df <- read.csv("Ch0902.RMA.csv",
                    header=TRUE,
                    na.strings = ".")
str(rma.df)
View(rma.df)
rma.df$time <- factor(rma.df$time,
                        levels=c(1:3),
                        labels=c("사전","3개월","6개월")                       )

# 02.기본통계치 확인
library(psych)
describeBy(rma.df$score, rma.df$time, mat=T)

# 03.그래프 그리기(박스그래프,히스토그램)
boxplot(score ~ time,
        data=rma.df,
        ylab="score",
        xlab="time")

# 04.통계분석
# 다변량 분석을 이용한 구형성(sphericity)검정: Mauchly’s test. 분산의 동질성 검정 방법 레빈 기법 활용한 것과 같은 논리
  # 매트릭스를 만들어서 해야 한다. 어려우니 잘 따라서 하자. (두번하면 대응표본이지만, 세번하면 분산분석임)
  # 현재 데이터 구조를 바꾸어야 하기 때문에

library(car)
rma.matrix <- cbind(rma.df$score[rma.df$time=="사전"], # 따로따로 뽑아서 옆으로 합쳐라
                    rma.df$score[rma.df$time=="3개월"],
                    rma.df$score[rma.df$time=="6개월"])
head(rma.matrix)

rma.model.lm <- lm(rma.matrix ~ 1) # ~1 : 데이터를 하나로 묶기
time.f <- factor(c("사전","3개월","6개월")) # 시간을 적자 (실제 사용할 때에는  여기만 변경해 주면 된다)
options(contrasts=c("contr.sum", "contr.poly"))
rma.result.mt <- Anova(rma.model.lm, #Anova 대문자
                       idata=data.frame(time.f),
                       idesign=~time.f,
                       type="III")

summary(rma.result.mt, multivariate=F)

# 일변량 ANOVA 검정
rma.result <- aov(score ~ time+Error(id/time),
                  data=rma.df)
summary(rma.result)

options("scipen" = 20)

# 다중비교 (Multicamparison test) - t-value 포함
# install.packages("multcomp")
library(multcomp)
result.lm <- lm(score ~ time, data=rma.df)
tukey.result <- glht(result.lm, linfct=mcp(time='Tukey'))
summary(tukey.result)
plot(tukey.result)

# 부록: 사후검정(기본함수사용): Tukey HSD
tukey.result <- aov(rma.df$score ~ rma.df$time, data=rma.df)
TukeyHSD(tukey.result)
plot(TukeyHSD(tukey.result))

ch09 - 분산분석 1/02.반복측정 분산분석(Repeated Measures ANOVA).r


devtools::load_all()
library(parallel)
RNGkind("L'Ecuyer-CMRG")
set.seed(999983)

ncores <- 4
n <- 512; m <- 20; lengthtau <- 1024; lengthtest <- 1e4;
v_taus <- seq(0.001, 0.999, length.out = lengthtau)

k1 <- 11; ktau <- 2; m1 <- 4; mtau <- 3
v_k <- c(ktau, k1); v_m <- c(mtau, m1); v_dim <- v_k + v_m

tune_code <- function(m = 20, taus = v_taus, ...) {
    # L2 loss
    L2loss <- matrix(rep(0, length(taus) * 2), nrow = 2)
    colnames(L2loss) <- taus
    rownames(L2loss) <- c("quantile sheets(gam)", "quantile sheets(scam)")
    # time
    m_time <- matrix(rep(0, 3 * 2), nrow = 2)
    rownames(m_time) <- rownames(L2loss)
    for (j in seq(m)) {
        #data set
        x <- sort(runif(n))
        y <- obs_f(x, ...)
        # test
        test_x <- seq(min(x), max(x), length.out = lengthtest)
        #quantile sheets
        m_time[1, ] <- m_time[1, ] + system.time(gam_fit <- qs_gam(x, y,
                maxit = 50, ntaus = 10,
                dims = v_dim, ords = NA,
                sp = NULL, tol = 1e-3))[1:3]
        m_time[2, ] <- m_time[2, ] + system.time(scam_fit <- qs_scam(x, y,
                    maxit = 20, ntaus = 10,
                    arg_bs = c("tesmi1", "cr"),
                    opt = "nlm.fd", dims = v_dim))[1:3]

        for (i in seq_along(taus)) {
            tau <- taus[i]
            truth <- truth_f(test_x, tau, ...)
            L2loss[1, i] <- L2loss[1, i] + mean((c(predict(gam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
            L2loss[2, i] <- L2loss[2, i] + mean((c(predict(scam_fit, data.frame(tau = tau, x1 = test_x))) - truth)^2)
        }
    }
    list(L2loss = L2loss / m,
        time = m_time / m,
        model = list(gam_fit, scam_fit))
}

# tune <- tune_code(m, gmean = "sqrtsin", xsig = "linear", derr = "norm")

v_gmean <- c("linear", "log", "sin", "lsin", "sqrtsin")
v_xsig <- c("const", "linear", "quad")
v_derr <- c("norm", "chisq3", "t3", "t1")

tune <- mclapply(v_gmean, gmean_loop <- function(gmean) {
    mclapply(v_xsig, xsig_loop <- function(xsig) {
        mclapply(v_derr, derr_loop <- function(derr) {
            tune_code(m, gmean = gmean, xsig = xsig, derr = derr)
        }, mc.cores = ncores)
    }, mc.cores = ncores)
}, mc.cores = ncores)

save(tune, file = "sim_tunedefault.RData")


#' State-Dependent Memory-Less Adaptive Transition Kernel
#'
#' @param x Current state
#' @param f Objective function
#' @param gr (optional) Gradient of the objective function.
#' @param rz Random number function.
#' @param dz Fensity function of `z`.
#' @param rz.args List of parameters passed to `rz`.
#' @param ... Further arguments passed to `f` and, if specified, `gr`
#' @param alpha Number in `[0, 1)`.
#' @param eps If no `gr` is specified, epsilon used to approximate the gradient.
#' @noRd
# sdml_adaptive_kernel <- function(
#   x,
#   f,
#   gr,
#   rz      = stats::rnorm,
#   dz      = stats::dnorm,
#   rz.args = list(mean=0, sd=1),
#   ...,
#   alpha = .9,
#   eps = rep(1e-5, length(x))
# ) {
#
#   # Number of parameters
#   k <- length(x)
#
#   # Evaluating functions
#   fx  <- f(x, ...)
#
#   # Gradient function
#   gx <- if (missing(gr))
#     (f(x + eps, ...) - fx)/
#         (2 * eps)
#   else
#     gr(x, ...)
#
#
#   # Proposal
#   beta_x <- 1 - stats::plogis(gx)*alpha
#   x_new  <- x + do.call(rz, c(list(k), rz.args))*beta_x
#   fx_new <- f(x_new, ...)
#
#   # New gradient
#   gx_new <- if (missing(gr))
#     (f(x_new + eps, ...) - fx_new)/
#     (2 * eps)
#   else
#     gr(x_new, ...)
#
#   # Hastings ratio
#   beta_x_new <- 1 - stats::plogis(gx_new)*alpha
#   fz_x_x_new <- do.call(dz, c(list((x_new - x)/beta_x), rz.args))/beta_x
#   fz_x_new_x <- do.call(dz, c(list((x - x_new)/beta_x_new), rz.args))/beta_x_new
#
#   list(
#     x = x_new,
#     h = min(1, fx_new * fz_x_x_new/(fx * fz_x_new_x + 1e-15))
#   )
#
# }