rm(list = ls()) # This clears everything from memory.

setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20141213.RData")

library(mgcv)

unlist(WSG100)
unlist(Moist100)
unlist(slope.100.rare[10])
unlist(convex.100.rare[10])

time <- c(1982,1985,1990,1995,2000,2005,2010)
Time=c(rep(1982,50),
                           rep(1985,50),
                           rep(1990,50),
                           rep(1995,50),
                           rep(2000,50),
                           rep(2005,50),
                           rep(2010,50))

temp.ab <- data.frame(SP = colnames(D100m[[1]]),
                      ab10_3 = D100m[[1]][3,],
                      ab10_4 = D100m[[1]][3,])
rownames(temp.ab) <- NULL

temp <- merge(temp.ab,trait, by="SP")

temp$moge1 <- (temp$ab10_3 * temp$convex_size_100)/temp$ab10_3
temp$moge2 <- (temp$ab10_4 * temp$convex_size_100)/temp$ab10_4

moge <- data.frame(temp$SP,temp$moge1)

moge3 <- as.character(na.omit(moge[moge[,2] < -0.2,][,1]))

ab.t.data[(rownames(ab.t.data) %in% moge3),"census_1982"]
ab.t.data[(rownames(ab.t.data) %in% moge3),"census_2010"]

unlist(convex.100.rare[10])[1:50]

WSG100.rm <-list()
Moist100.rm <-list()
slope100.rm <-list()
convex100.rm <-list()

# D100m[[1]][1:5,!(colnames(D100m[[1]]) %in% c("PIPECO","POULAR"))]

###use convex mean
for (i in 1:7){
  WSG100.rm[[i]] <- com.mean.ab(D100m[[i]][,!(colnames(D100m[[1]]) %in% c("PIPECO","POULAR"))],trait,"WSG")
  Moist100.rm[[i]] <- com.mean.ab(D100m[[i]][,!(colnames(D100m[[1]]) %in% c("PIPECO","POULAR","PSYCHO"))],trait,"Moist")
  slope100.rm[[i]] <- com.mean.ab(D100m[[i]][,!(colnames(D100m[[1]]) %in% c("PIPECO","POULAR","PSYCHO"))],trait,"slope_size_100")
  # convex100.rm[[i]] <- com.mean.ab(D100m[[i]][,!(colnames(D100m[[1]]) %in% c("ALSEBL","SWARS1"))],trait,"sp.convex.mean")
  convex100.rm[[i]] <- com.mean.ab(D100m[[i]][,!(colnames(D100m[[1]]) %in% c("PSYCHO"))],trait,"sp.convex.mean")
}

moge <- data.frame(WSG = unlist(WSG100),
                   Moist = unlist(Moist100),
                   slope = unlist(slope.100.rare[10]),
                   convex = unlist(convex100),
                   site = as.factor(rep(1:50,7)),
                   Time)

moge20 <- data.frame(WSG = unlist(WSG20),
                   Moist = unlist(Moist20),
                   slope = unlist(slope.20.rare[10]),
                   convex = unlist(convex20),
                   site = as.factor(rep(1:1250,7)),
                   Time)

moge100r <- data.frame(WSG = unlist(WSG100.rm),
                   Moist = unlist(Moist100.rm),
                   slope = unlist(slope100.rm),
                   convex = unlist(convex100.rm),
                   site = rep(1:50,7),
                   Time)

moge20r <- data.frame(WSG = unlist(WSG20),
                   Moist = unlist(Moist20),
                   slope = unlist(slope.20.rare[10]),
                   convex = unlist(convex20),
                   site = as.factor(rep(1:1250,7)),
                   Time)

r1.r <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r2.r <- gamm(Moist ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r3.r <- gamm(convex ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r4.r <- gamm(slope ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())

r1 <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r2 <- gamm(Moist ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r3 <- gamm(convex ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())
r4 <- gamm(slope ~  s(Time,k=4), random = list(site=~1), data=moge20, correlation = corAR1())

r1.r100<- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge100r, correlation = corAR1())
r2.r100<- gamm(Moist ~  s(Time,k=4), random = list(site=~1), data=moge100r, correlation = corAR1())
r3.r100<- gamm(convex ~  s(Time,k=4), random = list(site=~1), data=moge100r, correlation = corAR1())
r4.r100<- gamm(slope ~  s(Time,k=4), random = list(site=~1), data=moge100r, correlation = corAR1())

r1_100 <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge, correlation = corAR1())
r2_100 <- gamm(Moist ~  s(Time,k=4), random = list(site=~1), data=moge, correlation = corAR1())
r3_100 <- gamm(convex ~  s(Time,k=4), random = list(site=~1), data=moge, correlation = corAR1())
r4_100 <- gamm(slope ~  s(Time,k=4), random = list(site=~1), data=moge, correlation = corAR1())

### WSG R2
SS <- sum((moge100r[,"WSG"] - mean(moge100r[,"WSG"]))^2)
PREDS <- sum((r1.r100$gam$fitted - moge100r$WSG)^2)
1-PREDS/SS
##

moge100r$temp <- rnorm(nrow(moge100r))
moge.cross <- moge100r[order(moge100r$temp),]
rownames(moge.cross) <- NULL

k <- 10
# res.cv <- numeric(k)
  res.cv <- NULL
  i <- 1
  r2.1 <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge.cross[(35*i+1):350,], correlation = corCAR1())
  res <- data.frame(fitted = r2.1$gam$fitted.values, Time= r2.1$gam$model$Time)

  # res <- data.frame(fitted = r2.1$gam$fitted.values,
                    # res = r2.1$gam$residuals,
                    # res2 = r2.1$gam$y - r2.1$gam$fitted.values -r2.1$gam$residuals,
                    # Time= r2.1$gam$model$Time)

  res2 <- unique(res[order(res$Time),])
  res3 <- merge(moge.cross[1:35,],res2,by="Time")

  SS <- sum((moge.cross[1:35,"WSG"] - mean(moge.cross[1:35,"WSG"]))^2)
  PREDS <- sum((res3$fitted - res3$WSG)^2)
  res.cv[i] <- 1 - PREDS/SS

  # r2.1$lme$residuals$site

for (i in 2:(k-1)){
  temp.data <- rbind(moge.cross[1:(35*(i-1)),],
                     moge.cross[(35*i+1):350,])
  r2.1 <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=temp.data, correlation = corCAR1())
  res <- data.frame(fitted = r2.1$gam$fitted.values, Time= r2.1$gam$model$Time)
  res2 <- unique(res[order(res$Time),])

  K1 <- 35*(i-1) +1
  K2 <- 35*i
  res3 <- merge(moge.cross[K1:K2,],res2,by="Time")
  SS <- sum((moge.cross[K1:K2,"WSG"] - mean(moge.cross[K1:K2,"WSG"]))^2)
  PREDS <- sum((res3$fitted - res3$WSG)^2)
  res.cv[i] <- 1 - PREDS/SS
}

i <- 10
  r2.1 <- gamm(WSG ~  s(Time,k=4), random = list(site=~1), data=moge.cross[1:35*k,], correlation = corCAR1())
  res <- data.frame(fitted = r2.1$gam$fitted.values, Time= r2.1$gam$model$Time)
  res2 <- unique(res[order(res$Time),])
  res3 <- merge(moge.cross[316:350,],res2,by="Time")
  SS <- sum((moge.cross[316:350,"WSG"] - mean(moge.cross[316:350,"WSG"]))^2)
  PREDS <- sum((res3$fitted - res3$WSG)^2)
  res.cv[i] <- 1 - PREDS/SS

CV <- mean(res.cv,na.rm=T)
R2 <- 1 - mean(res.cv,na.rm=T)/mean((r2.1$gam$y - mean(r2.1$gam$y))^2)

list(res.cv=res.cv,res.data=data.frame(CV,R2))

save.image("~/Dropbox/MS/TurnoverBCI/gam_analysis.RData")

# r1 <- gam(Moist ~  s(Time,k=7), data=moge, correlation = corCAR1())
# r2 <- gamm(Moist ~  s(site,k=50), data=moge, correlation = corCAR1())
# r3 <- gamm(Moist ~  s(site,k=50)+s(Time,k=7), data=moge, correlation = corCAR1())


### Copyright (C) 2017 Rafael Laboissière
###
### This program is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by the
### Free Software Foundation, either version 3 of the License, or (at your
### option) any later version.
###
### This program is distributed in the hope that it will be useful, but
### WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
### General Public License for more details.
###
### You should have received a copy of the GNU General Public License along
### with this program.  If not, see <http://www.gnu.org/licenses/>.

### * Statistical analyses

### ** Load the necessary libraries
library (lme4)
library (lmerTest)
library (HDInterval)
library (shape)
library (car)

### ** Function for computing confidence intervals of predicted values
ci.pred <- function (fit.model, new.data = NA, pred.fun = NA, nb.sim = 1000) {
    if (! is.function (pred.fun))
        pred.fun <- function (fit.model)
                        predict (fit.model, newdata = new.data, re.form = NA)
    n <- length (pred.fun (fit.model))
    b <- bootMer (fit.model, pred.fun, nsim = nb.sim)
    ci <- c ()
    for (i in seq (1, n))
        ci <- rbind (ci, hdi (b$t [, i]))
    return (list (ci = ci, t = b$t))
}

### ** Load the results
obj.stab.psycho <- read.csv ("obj-stab-psycho.csv")

### ** Transform the discrete factors chair and object into numeric
obj.stab.psycho$object.num <- c (1, -1, 0) [as.numeric(obj.stab.psycho$object)]
obj.stab.psycho$chair.num <- c (-1, 1, 0) [as.numeric (obj.stab.psycho$chair)]
obj.stab.psycho$table.side.num <- (c (-0.5, 0, 0.5)
                                   [as.numeric (obj.stab.psycho$table.side)])

### ** Boxplot parameters
obj.col <- c ("pink", "cyan", "wheat")
exp.col <- c ("aquamarine", "coral")
side.col <- c ("firebrick1", "deepskyblue")
boxplot.pars <- list (boxwex  = 0.5, bty = "n")
boxplot.ylab <- "threshold angle (degrees)"

### ** Plot labels

### *** Labels for the conditions
chair.lab <- c ("Left Tilt", "Upright", "Right Tilt")
bg.lab <- c ("Static Surround", "Rotating Surround")
scene.lab <- c ("Scene on the Left", "Scene on the Right")
table.lab <- c ("Table to the Left", "Table to the Right")
com.lab <- c ("Low COM", "Mid COM", "High COM")

### *** Labels for the axes
dsvh.xlab <- expression (paste (Delta, "TU (degrees)"))
dca.ylab = expression (paste (Delta, "CA (degrees)"))
ca.ylab <- "Critical Angle (degrees)"
svh.ylab <- "Table Uprightness (degrees)"

### ** Experiments

### *** Room 126

### **** Select the data
room.126 <- subset (obj.stab.psycho, experiment == "room-126")

### **** Drop subject S066 (it's Corinne Cian!))
room.126 <- subset (room.126, subject != "S066")

### **** Linear mixed models

## ***** Effect of chair inclination & object shape in static background
df.r126.chair.obj <- subset (room.126,
                             stimulus == "object" & background == "static")
fm.r126.chair.obj <- lmer (threshold ~ object.num * chair.num
                           + (1 | subject), df.r126.chair.obj)

anova (fm.r126.chair.obj)
fixef (fm.r126.chair.obj)
confint (fm.r126.chair.obj)

pdf (file = "room-126-chair-object.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ object.num * chair.num, df.r126.chair.obj,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             xaxt = "n", pars = boxplot.pars,
             col = rep (obj.col, 3), add = (i == 2))
    if (i == 1)
        polygon (c (3.5, 6.5, 6.5, 3.5), c (0, 0, 100, 100),
                 col = "#eeeeee", border = NA)
}
axis (1, at = c (2, 5, 8), tick = FALSE, labels = chair.lab)
legend ("topright", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = obj.col,
        legend = com.lab)
dummy <- dev.off ()

### ***** Effect of object shape and background in upright position
df.r126.bg.obj <- subset (room.126,
                          stimulus == "object" & chair == "upright")
fm.r126.bg.obj <- lmer (threshold ~ background * object.num
                        + (1 | subject), df.r126.bg.obj)
anova (fm.r126.bg.obj)
fixef (fm.r126.bg.obj)
confint (fm.r126.bg.obj)

fe.r126.bg.obj <- fixef (fm.r126.bg.obj)
re.r126.bg.obj <- ranef (fm.r126.bg.obj)

pdf (file = "room-126-background-object.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ object.num * background, df.r126.bg.obj, frame = FALSE,
             las = 1, xlab = "", ylab = boxplot.ylab, xaxt = "n",
             pars = boxplot.pars, col = rep (obj.col, 2), add = (i == 2))
    if (i == 1)
        polygon (c (3.5, 6.5, 6.5, 3.5), c (0, 0, 100, 100),
                 col = "#eeeeee", border = NA)
}
axis (1, at = c (2, 5), tick = FALSE, labels = bg.lab)
legend ("topright", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = obj.col,
        legend = com.lab)
dummy <- dev.off ()

### ***** Power analysis

### ****** Home-made simulation
### (Taken from the web somewhere.  Look at https://goo.gl/zOUgFy)
nsim <- 1000
p.value <- rep (NA, nsim)
sim.r126.bg.obj <- simulate (fm.r126.bg.obj, nsim = nsim)

cat ("Computing power effect for Exp. 1 (surround effect)\n")
flush.console ()

for (i in seq (1, nsim)) {
    df <- df.r126.bg.obj
    df$threshold <- sim.r126.bg.obj [, i]
    fm <- lmer (threshold ~ background * object.num + (1 | subject), df)
    p.value [i] <- anova (fm) [["Pr(>F)"]] [1]
    cat (sprintf ("\r%4d", i))
    flush.console ()
}

cat (sprintf ("Power for surround effect is %f\n",
              (nsim - length (which (p.value > 0.05))) / nsim))
flush.console ()

### ****** Using SIMR package
library (simr)
powerSim (fm.r126.bg.obj, test = fixed ("background"), nsim = 100)

### ***** Effect of background in upright position on horizontal estimation
df.r126.bg.hor <- subset (room.126,
                          stimulus == "horizontal" & chair == "upright")
fm.r126.bg.hor <- lmer (threshold ~ background + (1 | subject), df.r126.bg.hor)

anova (fm.r126.bg.hor)
fixef (fm.r126.bg.hor)
confint (fm.r126.bg.hor)

fe.r126.bg.hor <- fixef (fm.r126.bg.hor)
re.r126.bg.hor <- ranef (fm.r126.bg.hor)

pdf (file = "room-126-background-horizontal.pdf")
par (mar = c (4, 5, 0.5, 0))
boxplot (threshold ~ background, df.r126.bg.hor, frame = FALSE,
         las = 1, xlab = "", ylab = boxplot.ylab,
         xaxt = "n", pars = list (boxwex  = 0.2, bty = "n"))
axis (1, at = c (1, 2), tick = FALSE, labels = bg.lab)
dummy <- dev.off ()

### ***** Efect of inclination in static background on horizontal estimation
df.r126.chair.hor <- subset (room.126,
              stimulus == "horizontal" & background == "static")
df.r126.chair.hor$object <- factor (as.character (df.r126.chair.hor$object))
fm.r126.chair.hor <- lmer (threshold ~ chair.num + (0 + chair.num | subject),
                           df.r126.chair.hor)

anova (fm.r126.chair.hor)
fixef (fm.r126.chair.hor)
confint (fm.r126.chair.hor)

pdf (file = "room-126-chair-horizontal.pdf")
par (mar = c (4, 5, 0.5, 0))
boxplot (threshold ~ chair.num, df.r126.chair.hor, frame = FALSE,
         las = 1, xlab = "", ylab = boxplot.ylab,
         xaxt = "n", pars = list (boxwex  = 0.4, bty = "n"))
axis (1, at = seq (1, 3), tick = FALSE, labels = chair.lab)
dummy <- dev.off ()

### **** Plot random effects for horizontality vs. object stability models

pdf (file = "room-126-ranef-cor.pdf")
par (mar = c (4, 5, 0.5, 0))
plot (fe.r126.bg.hor [2] + re.r126.bg.hor$subject [, 1],
      fe.r126.bg.obj [2] + re.r126.bg.obj$subject [, 1],
      pch = 19, bty = "n", las = 1, xlim = c (0,7),
      xlab = dsvh.xlab, ylab = dca.ylab)
dummy <- dev.off ()

pdf (file = "room-126-ranef-cor-diag.pdf")
par (mar = c (4, 5, 0.5, 0))
plot (fe.r126.bg.hor [2] + re.r126.bg.hor$subject [, 1],
      fe.r126.bg.obj [2] + re.r126.bg.obj$subject [, 1],
      pch = 19, bty = "n", las = 1, xlim = c (0,7),
      xlab = dsvh.xlab, ylab = dca.ylab)
abline (0, 1, lty = 2, col = "gray", lwd = 2)
dummy <- dev.off ()

### **** Select representative subjects

### ***** Object stability experiment

### Get the data frame for the room-126 (background/object) experiment
### in condition "static"
df <- subset (df.r126.bg.obj, background == "static")
### Compute the differences in threshold high-mid and mid-low
ag <- aggregate (threshold ~ subject, df,
                 function (x) c(x[2] - x[3], x [3] - x [1]))
diff.t <- ag$threshold
### Get the size of the effect
diff.ca <- -fixef (fm.r126.bg.obj) [3]
### Find the subject
idx <- which.min ((diff.t [, 1] - diff.ca) ^ 2 + (diff.t [, 2] - diff.ca) ^ 2)
cat (sprintf ("Representative subject is %s\n", ag$subject [idx]))

### ***** Horizontality experiment

### Get the data frame for the room-126 (background/horizontal) experiment
### in condition "vection"
df <- subset (df.r126.bg.hor, background == "vection")
### Get the indivual thresholds
thres <- df$threshold
### Get the size of the effect
fe <- fixef (fm.r126.bg.hor) [2]
### Find the subject
idx <- which.min ((thres - fe) ^ 2)
cat (sprintf ("Representative subject is %s\n", df$subject [idx]))

### *** New screen

### **** Select the data
new.screen <- subset (obj.stab.psycho, experiment == "new-screen")
new.screen$subject <- factor (as.character (new.screen$subject))

### **** Select the same subjects from room 126 experiment
for (s in levels (new.screen$subject)) {
    new.screen <- rbind (new.screen,
                         subset (obj.stab.psycho, subject == s
                                                  & experiment == "room-126"
                                                  & stimulus == "horizontal"
                                                  & chair == "upright"))
}
new.screen$subject <- factor (as.character (new.screen$subject))
new.screen$experiment <- factor (as.character (new.screen$experiment),
                                 levels = c ("room-126", "new-screen"))

pdf (file = "room-126-new-screen.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ experiment * background, new.screen, frame = FALSE,
             las = 1, xlab = "", ylab = boxplot.ylab, col = rep (exp.col, 2),
             xaxt = "n", pars = list (boxwex  = 0.4, bty = "n"), add = (i == 2))
    if (i == 1)
        polygon (c (2.5, 4.5, 4.5, 2.5), c (-50, -50, 50, 50),
                 col = "#eeeeee", border = NA)
}
axis (1, at = c (1.5, 3.5), tick = FALSE, labels = bg.lab)
legend ("topleft", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = exp.col,
        legend = c ("computer screen", "wall screen"))
dummy <- dev.off ()

### **** Fit model
fm <- lmer (threshold ~ experiment * background + (1 | subject), new.screen)
show (anova (fm))
show (fixef (fm))
show (ranef (fm))

### **** Results Exp. 1 (Fig. 2)

### ***** General plot paramaters
obj.pch <- c (18, 16, 15) # diamond, circle, square
obj.cex <- c (2.5, 2, 2) # diamond, circle, square
gray.box <- "#eeeeee"
pdf.wd <- 4.5
pdf.ht <- 4.5

### ***** Panel A
nd <- expand.grid (object.num  = c (-1, 0, 1),
                   background = c ("static", "vection"))
pred <- predict (fm.r126.bg.obj, nd, re.form = NA)
ci <- ci.pred (fm.r126.bg.obj, nd)$ci
y.min <- 26
y.max <- 39
pdf (file = "Fig-2-a.pdf", width = pdf.wd, height = pdf.ht)
par (mar = c (2, 4, 1, 1))
plot (0, 0, xlim = c (0.5, 6.5), bty = "n", xaxt = "n", las = 1,
      ylim = c (y.min, y.max), xlab = "", ylab = ca.ylab, type = "n")
axis (1, at = c (2, 5), tick = FALSE, labels = bg.lab)
polygon (c (3.5, 6.5, 6.5, 3.5), c (-50, -50, y.max, y.max), col = gray.box,
         border = NA)
points (pred, pch = obj.pch, cex = obj.cex)
for (i in seq (1, 6))
    lines (rep (i, 2), ci [i, ], lwd = 3)
legend ("bottomleft", inset = c (0.05, 0.05), pch = obj.pch, bty = "n",
        pt.cex = 0.75 * obj.cex, legend = com.lab)
par (xpd = NA)
text (-0.2, y.max, adj = c (0, 0), labels = "a", cex = 2)
dummy <- dev.off ()

### ***** Panel C
nd <- expand.grid (object.num  = c (-1, 0, 1), chair.num = c (-1, 0, 1))
pred <- predict (fm.r126.chair.obj, nd, re.form = NA)
ci <- ci.pred (fm.r126.chair.obj, nd)$ci
pdf (file = "Fig-2-c.pdf", width = pdf.wd, height = pdf.ht)
par (mar = c (2, 4, 1, 1))
plot (0, 0, xlim = c (0.5, 9.5), bty = "n", xaxt = "n", las = 1, type = "n",
      ylim = c (y.min, y.max), xlab = "", ylab = ca.ylab)
axis (1, at = c (2, 5, 8), tick = FALSE, labels = chair.lab)
polygon (c (3.5, 6.5, 6.5, 3.5), c (-50, -50, y.max, y.max), col = gray.box,
         border = NA)
points (pred, pch = obj.pch, cex = obj.cex)
for (i in seq (1, 9))
    lines (rep (i, 2), ci [i, ], lwd = 3)
par (xpd = NA)
text (-0.2, y.max, adj = c (0, 0), labels = "c", cex = 2)
dummy <- dev.off ()

### ***** Panel B
nd <- expand.grid (background = c ("static", "vection"))
pred <- predict (fm.r126.bg.hor, nd, re.form = NA)
ci <- ci.pred (fm.r126.bg.hor, nd)$ci
y.min <- -5
y.max <- 8
pdf (file = "Fig-2-b.pdf", width = pdf.wd, height = 0.8 * pdf.ht)
par (mar = c (4.5, 4, 2.0, 1))
plot (0, 0, xlim = c (0.5, 6.5), bty = "n", xaxt = "n", las = 1,
      ylim = c (y.min, y.max), xlab = "", ylab = svh.ylab, type = "n")
axis (1, at = c (2, 5), tick = FALSE, labels = bg.lab)
polygon (c (3.5, 6.5, 6.5, 3.5), c (-50, -50, 38, 38), col = gray.box,
         border = NA)
for (i in seq (1, 2))
    lines (rep ((i - 1) * 3 + 2, 2), ci [i, ], lwd = 3)
points (c (2, 5), pred, pch = 21, cex = 1.8, bg = "white")
par (xpd = NA)
text (-0.2, y.max + 1.2, adj = c (0, -0.2), labels = "b", cex = 2)
dummy <- dev.off ()

### ***** Panel D
nd <- expand.grid (chair.num = c (-1, 0, 1))
pred <- predict (fm.r126.chair.hor, nd, re.form = NA)
ci <- ci.pred (fm.r126.chair.hor, nd)$ci
pdf (file = "Fig-2-d.pdf", width = pdf.wd, height = 0.8 * pdf.ht)
par (mar = c (4.5, 5, 2.0, 1))
plot (0, 0, xlim = c (0.5, 9.5), bty = "n", xaxt = "n", las = 1,
      ylim = c (y.min, y.max), xlab = "", ylab = svh.ylab, type = "n")
axis (1, at = c (2, 5, 8), tick = FALSE, labels = chair.lab)
polygon (c (3.5, 6.5, 6.5, 3.5), c (-50, -50, 38, 38), col = gray.box,
         border = NA)
for (i in seq (1, 3))
    lines (rep ((i - 1) * 3 + 2, 2), ci [i, ], lwd = 3)
points (c (2, 5, 8), pred, pch = 21, cex = 1.8, bg = "white")
par (xpd = NA)
text (-0.2, y.max + 1.2, adj = c (0, -0.2), labels = "d", cex = 2)
dummy <- dev.off ()

### ***** Compose Figure
system (paste ("pdfjam Fig-2-a.pdf Fig-2-c.pdf Fig-2-b.pdf Fig-2-d.pdf",
               "--no-landscape --frame true --nup 2x2 --frame false",
               "--outfile tmp.pdf"))
system ("pdfcrop --margins 10 tmp.pdf Fig-2.pdf")

### **** Correlation figure (Fig. 3)
df.hor <- subset(room.126, stimulus == "horizontal" & chair == "upright")
delta.hor <- aggregate (threshold ~ subject, df.hor, diff)
df.ca <- subset(room.126, stimulus == "object" & chair == "upright")
delta.ca <- aggregate (threshold ~ subject,
                       aggregate (threshold ~ subject * background, df.ca, mean),
                       diff)
pdf (file = "Fig-3.pdf", width = pdf.wd, height = pdf.ht)
par (mar = c (5, 4, 0, 0))
plot (delta.hor$threshold, delta.ca$threshold, bty = "n", las = 1, pch = 19,
      xlab = dsvh.xlab, ylab = dca.ylab, type = "n")
abline (0, 1, col = "gray", lwd = 2)
points (delta.hor$threshold, delta.ca$threshold, pch = 19)
points (mean (delta.hor$threshold), mean (delta.ca$threshold), pch = 18,
        col = "#ff000080", cex = 3)
dummy <- dev.off ()

### *** Scene mirror

### **** Select the data
df.scene.mirror <- subset (obj.stab.psycho, experiment == "scene-mirror")
df.scene.mirror$subject <- factor (as.character (df.scene.mirror$subject))

### **** Effect of object CG height and secene side

### ***** Extract the data
df.scene.mirror.obj <- subset (df.scene.mirror, stimulus == "object")

### ***** Plot the raw results
pdf (file = "scene-mirror-object.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ object.num * object.side, df.scene.mirror.obj,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             xaxt = "n", pars = boxplot.pars,
             col = rep (obj.col, 2), add = (i == 2))
    if (i == 1)
        polygon (c (3.5, 6.5, 6.5, 3.5), c (0, 0, 100, 100),
                 col = gray.box, border = NA)
}
axis (1, at = c (2, 5), tick = FALSE, labels = scene.lab)
legend ("topright", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = obj.col,
        legend = com.lab)
dummy <- dev.off ()

### ***** Fit the model
fm.scene.mirror.obj <- lmer (threshold ~ object.num * table.side.num
                                         + (1 | subject)
                                         + (0 + table.side.num | subject),
                             df.scene.mirror.obj)
show (anova (fm.scene.mirror.obj))
show (fixef (fm.scene.mirror.obj))
show (ranef (fm.scene.mirror.obj))

fm.no.Intercept <- lmer (threshold ~ object.num * table.side.num
                                     + (0 + table.side.num | subject),
                         df.scene.mirror.obj)
fm.no.table.side.num <- lmer (threshold ~ object.num * table.side.num
                                          + (1 | subject),
                              df.scene.mirror.obj)
show (anova (fm.no.Intercept, fm.scene.mirror.obj))
show (anova (fm.no.table.side.num, fm.scene.mirror.obj))

### ***** Plot the results
nd <- expand.grid (object.num = c (-1, 0, 1), table.side.num = c (-0.5, 0.5))
pred <- predict (fm.scene.mirror.obj, nd, re.form = NA)
ci <- ci.pred (fm.scene.mirror.obj, nd)$ci
y.min <- min (ci [, 1])
y.max <- max (ci [, 2])
pdf (file = "Fig-5-a.pdf", width = pdf.wd, height = pdf.ht)
par (mar = c (4.5, 5, 2.0, 0))
plot (0, 0, type = "n", xlim = c (0.5, 6.5), bty = "n", xaxt = "n", las = 1,
      ylim = c (y.min, y.max), xlab = "", ylab = ca.ylab)
axis (1, at = c (2, 5), tick = FALSE, labels = scene.lab)
polygon (c (3.5, 6.5, 6.5, 3.5), c (-50, -50, 42, 42), col = gray.box,
         border = NA)
for (i in seq (1, 6))
    lines (rep (i, 2), ci [i, ], lwd = 3)
points (pred, pch = obj.pch, cex = obj.cex)
legend ("bottomleft", inset = 0.05, pch = obj.pch, pt.cex = 0.75 * obj.cex,
        bty = "n", legend = com.lab)
par (xpd = NA)
text (-0.2, y.max + 0.8, adj = c (0, -0.2), labels = "a", cex = 2)
dummy <- dev.off ()

### ***** Plot the BLUP
re <- ranef (fm.scene.mirror.obj)$subject
n <- nrow (re)
fe <- fixef (fm.scene.mirror.obj)

pdf (file = "Fig-5-b.pdf", width = pdf.wd, height = pdf.ht)
par (mar = c (5, 5.5, 2, 0.1))
x <- re [,1] + fe [1]
y <- - (re [,2]  + fe [3])
show (max (y))
y.min <- min (y)
y.max <- 18
plot (x, y, pch = 19, cex = 1.5, las = 1,  xlim = c (20, 40), col = "#00000080",
      bty = "n", xlab = "Mean Critical Angle (degrees)",
      ylab = "Left/Right Side Effect (degrees)")
abline (h = -fe [3], col = "#00000080", lwd = 2, lty = "21")
abline (v = fe [1], col = "#00000080", lwd = 2, lty = "21")
par (xpd = NA)
text (20, 14.5, adj = c (1, 0), labels = "b", cex = 2)
dummy <- dev.off ()

### ***** Compose the Fig. 5
system (paste ("pdfjam Fig-5-a.pdf Fig-5-b.pdf",
               "--no-landscape --frame true --nup 2x1 --frame false",
               "--outfile tmp.pdf"))
system ("pdfcrop --margins 10 tmp.pdf Fig-5.pdf")

### **** Check age effect on the random factors

### ****** Plot the ranef with age as size of points
subjects <- read.csv ("cohort-info.csv")
age <- sapply (row.names (re),
               function (x)
                   subjects$age [which (x == as.character (subjects$subject))])
pdf (file = "scene-mirror-ranef-age.pdf")
par (xpd = NA)
plot (fe [1] + re [, 1], -(fe [3] + re [, 2]), bty = "n",
      las = 1, col = "#00000080", pch = 19,
      cex = 1 + 5 * (age - min (age)) / (max (age) - min (age)),
      xlab = "individual intercept effect (degrees)",
      ylab = "individual table-sode effect (degrees)")
legend.years <- c (20, 30)
legend.cex <- 1 + 5 * (legend.years - min (age)) / (max (age) - min (age))
legend ("topleft", inset = 0.2, pt.cex = legend.cex, pch = 1, cex = 1.8,
        legend = sapply (legend.years, function (x) sprintf ("%.0f years", x)),
        text.col = "#bbbbbb")
Arrows (19, 0, 19, -5, lwd = 2, col = "red")
text (19.5, -2.5, label = "- gravity", adj = c (0.5, 1), srt = 90, col = "red",
      cex = 1.2)
Arrows (19, 8, 19, 13, lwd = 2, col = "red")
text (19.5, 10.5, label = "+ gravity", adj = c (0.5, 1), srt = 90, col = "red",
      cex = 1.2)
Arrows (24, 15, 20, 15, lwd = 2, col = "red")
text (22, 15.5, label = "cautious", adj = c (0.5, 0), col = "red", cex = 1.2)
Arrows (32, 15, 36, 15, lwd = 2, col = "red")
text (34, 15.5, label = "risky", adj = c (0.5, 0), col = "red", cex = 1.2)
dummy <- dev.off ()

### ****** Pilai statistical test
fm.scene.mirror.age <- lm (cbind (fe [1] + re [, 1], -(fe [3] + re [, 2])) ~ age)
Manova (fm.scene.mirror.age)

### **** Effect of background on horizontal detection
df.scene.mirror.hor <- subset (df.scene.mirror, stimulus == "horizontal")
idx <- which (df.scene.mirror.hor$table.side == "right")
df.scene.mirror.hor$threshold [idx] <- -df.scene.mirror.hor$threshold [idx]

pdf (file = "scene-mirror-horizontal.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ table.side * background, df.scene.mirror.hor,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             col = rep (side.col, 2), xaxt = "n",
             pars = list (boxwex  = 0.4, bty = "n"), add = (i == 2))
    if (i == 1)
        polygon (c (2.5, 4.5, 4.5, 2.5), c (-50, -50, 50, 50),
                 col = gray.box, border = NA)
}
axis (1, at = c (1.5, 3.5), tick = FALSE, labels = bg.lab)
legend ("topleft", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = side.col,
        legend = table.lab)
dummy <- dev.off ()

fm.scene.mirror.hor <- lmer (threshold ~ table.side.num * background
                                         + (1 | subject),
                             df.scene.mirror.hor)
show (anova (fm.scene.mirror.hor))
show (fixef (fm.scene.mirror.hor))
show (ranef (fm.scene.mirror.hor))

### *** Flip table

### **** Select the data
flip.table <- subset (obj.stab.psycho, experiment == "flip-table")
flip.table$subject <- factor (as.character (flip.table$subject))

### **** Effect of scene side and background on object stability
flip.table.obj <- subset (flip.table, stimulus == "object")

pdf (file = "flip-table-object.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ table.side * background, flip.table.obj,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             col = rep (side.col, 2), xaxt = "n",
             pars = list (boxwex  = 0.4, bty = "n"), add = (i == 2))
    if (i == 1)
        polygon (c (2.5, 4.5, 4.5, 2.5), c (-50, -50, 50, 50),
                 col = gray.box, border = NA)
}
axis (1, at = c (1.5, 3.5), tick = FALSE, labels = bg.lab)
legend ("bottomleft", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = side.col,
        legend = c ("table to the left", "table to the right"))
dummy <- dev.off ()

fm <- lmer (threshold ~ background * table.side + (1 | subject),
            flip.table.obj)
show (anova (fm))
show (fixef (fm))
show (ranef (fm))

### **** Effect of scene side and background on horizontal detection
flip.table.hor <- subset (flip.table, stimulus == "horizontal")
idx <- which (flip.table.hor$table.side == "right")
flip.table.hor$threshold [idx] <- -flip.table.hor$threshold [idx]

pdf (file = "flip-table-horizontal.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ background * table.side, flip.table.hor,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             col = rep (side.col, 2), xaxt = "n",
             pars = list (boxwex  = 0.4, bty = "n"), add = (i == 2))
    if (i == 1)
        polygon (c (2.5, 4.5, 4.5, 2.5), c (-50, -50, 50, 50),
                 col = gray.box, border = NA)
}
axis (1, at = c (1.5, 3.5), tick = FALSE,
      labels = c ("table to the left", "table to the right"))
legend ("topleft", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = side.col,
        legend = bg.lab)
dummy <- dev.off ()

fm <- t.test (threshold ~ background, paired = TRUE,
              data = subset (flip.table.hor, table.side == "left"))
show (fm)

fm <- t.test (threshold ~ background, paired = TRUE,
              data = subset (flip.table.hor, table.side == "right"))
show (fm)

### *** No table

### **** Select the data
df.no.table <- subset (obj.stab.psycho, experiment == "no-table")

### **** Plot the raw results
pdf (file = "no-table-object.pdf")
par (mar = c (4, 5, 0.5, 0))
for (i in c (1, 2)) {
    boxplot (threshold ~ object.num * background * table.side, df.no.table,
             frame = FALSE, las = 1, xlab = "", ylab = boxplot.ylab,
             xaxt = "n", pars = boxplot.pars,
             col = rep (obj.col, 2), add = (i == 2))
    if (i == 1)
        polygon (c (3.5, 6.5, 6.5, 3.5), c (0, 0, 100, 100),
                 col = gray.box, border = NA)
}
axis (1, at = c (2, 5), tick = FALSE, labels = bg.lab)
legend ("topright", inset = 0.05, pch = 22, pt.cex = 2, pt.bg = obj.col,
        legend = com.lab)
dummy <- dev.off ()

fm.no.table <- lmer (threshold ~ background * object.num * table.side
                                 + (1 | subject),
                     df.no.table)
show (anova (fm.no.table))
show (fixef (fm.no.table))
show (ranef (fm.no.table))
show (confint (fm.no.table))

fe <- fixef (fm.no.table)

### **** Rudimentary plot of results
pdf (file = "no-table-object.pdf", width = 4, height = 5)
par (mar = c (4, 5, 0.5, 0))
plot (c (1, 1, 2, 2),
      c (fe[1], fe [1] + fe [2], fe [1] + fe [4],
         fe [1] + fe [2] + fe [4] + fe [6]),
      pch = 19, col = rep (c ("blue", "red"), 2), bty = "n",
      xlim = c (0.7, 2.3), cex = 1.3,
      las = 1, xaxt = "n", xlab = "", ylab = ca.ylab)
lines (c (1, 2), c (fe[1], fe [1] + fe [4]), col = "blue")
lines (c (1, 2), c (fe [1] + fe [2], fe [1] + fe [2] + fe [4] + fe [6]),
       col = "red")
axis (1, at = c (1, 2), labels = c ("table", "no table"))
legend ("right", col = c ("red", "blue"), legend = c ("rotating", "static"),
        pch = 19)
dummy <- dev.off ()

### ***** Plot the results
nd <- expand.grid (object.num = c (-1, 0, 1),
                   background = c ("static", "vection"),
                   table.side = c ("left", "none"))
pred <- predict (fm.no.table, nd, re.form = NA)
ci <- ci.pred (fm.no.table, nd)$ci
y.min <- min (ci [, 1])
y.max <- max (ci [, 2])
pdf (file = "Fig-6.pdf", width = 7, height = 5)
par (mar = c (4.5, 5, 4.5, 0), xpd = FALSE)
plot (0, 0, type = "n", xlim = c (0.5, 12.5), bty = "n", xaxt = "n", las = 1,
      ylim = c (y.min, y.max), xlab = "", ylab = ca.ylab)
group.axis <- function (pos, at, lab) {
    axis (pos, at = at, labels = rep ("", 2), line = 1)
    axis (pos, at = mean (at), tick = FALSE, line = 0.5, labels = lab)
}
for (i in c (1, 2)) {
    polygon (6 * (i - 1) + c (3.5, 6.5, 6.5, 3.5),
             c (0, 0, 100, 100), col = gray.box, border = NA)
    group.axis (3, at = 6 * (i - 1) + c (1, 3), "Static")
    group.axis (3, at = 6 * (i - 1) + c (4, 6), "Rotating")
}
group.axis (1, c (1, 6), "With Table")
group.axis (1, c (7, 12), "Without Table")
for (i in seq (1, 12))
    lines (rep (i, 2), ci [i, ], lwd = 3)
points (pred, pch = obj.pch, cex = obj.cex)
legend ("topleft", inset = c (0.05, 0), pch = obj.pch, pt.cex = 0.75 * obj.cex,
        bty = "n", legend = com.lab)
dummy <- dev.off ()

### ** Verify age effects for background effect in Exp. 1 and Exp. 3

df.age <- subset (obj.stab.psycho,
                  experiment %in% c ("room-126", "no-table")
                  & table.side == "left" & chair == "upright"
                  & subject != "S066" & stimulus == "object")
fm.age <- lmer (threshold ~ background * object + (background | subject),
                df.age)
re <- ranef (fm.age)$subject
age <- sapply (row.names (re),
               function (x)
                   subjects$age [which (x == as.character (subjects$subject))])
cor.test (re [, 1], age)
cor.test (re [, 2], age)


library(ggplot2)
head(diamonds)

ggplot(diamonds, aes(x=carat , y=price)) + geom_point()
dim(diamonds)

library(fmsb)
data <-diamonds[c(1:1),-(1:4)]
data
data <-rbind(rep(400,5), rep(0,5), data)
data
radarchart(data)


library(caret)
library(randomForest)

args <- commandArgs(TRUE)

trainingDataDir <- "sensor-data"
trainingFile <- paste(trainingDataDir, "training.csv", sep = "/")
testingFile <- paste(trainingDataDir, "testing.csv", sep = "/")
trainingFileUrl <- args[1]
testingFileUrl <- args[2]

# Number of columns expected in the CSV file
numColumns <- 160

# Cross validation ratio for training data
trainTestRatio <- 0.75

# Column to start training/testing. By default this skips columns 1..7
startColumn <- 8

if(length(args) < 2) {
	stop("Please supply training CSV URL as first command argument & testing CSV as second command argument.")
}

if (!file.exists(trainingDataDir)) {
	# Create sensor-data directory
	dir.create(trainingDataDir)
}

if (!file.exists(trainingFile) || !file.exists(testingFile)) {
	# Download training & testing data
	print(paste("Downloading training file:", trainingFileUrl))
	print(paste("Downloading testing file:", testingFileUrl))

	download.file(trainingFileUrl, destfile = trainingFile)
	download.file(testingFileUrl, destfile = testingFile)
}

if (dim(read.csv(trainingFile))[2] != numColumns || dim(read.csv(testingFile))[2] != numColumns) {
	stop(paste(numColumns, " columns must be present in training and testing CSV"))
}

# Load the files
trainingRaw <- read.csv(trainingFile, na.strings = c("NA", ""))
testingRaw <- read.csv(testingFile, na.strings = c("NA", ""))

# Remove empty columns
trainingEmpty <- apply(trainingRaw, 2, function(x) { sum(is.na(x)) })
trainingProcessed <- trainingRaw[,which(trainingEmpty == 0)]
trainingProcessed <- trainingProcessed[startColumn:length(trainingProcessed)]

testingEmpty <- apply(testingRaw, 2, function(x) { sum(is.na(x)) })
testingProcessed <- testingRaw[,which(testingEmpty == 0)]
testingProcessed <- testingProcessed[startColumn:length(testingProcessed)]

# Partition training set
trainingPartition <- createDataPartition(y = trainingProcessed$classe, p = trainTestRatio, list = FALSE)
training <- trainingProcessed[trainingPartition,]
testing <- trainingProcessed[-trainingPartition,]

# Train the model with randomForest, y = classe
model <- randomForest(classe ~ ., data = training)

# Time for cross validation...
crossValidationPrediction <- predict(model, testing)
confMatrix <- confusionMatrix(testing$classe, crossValidationPrediction)
print(paste("======== START CROSS VALIDATION ACCURACY ========"))
print(confMatrix)
print(paste("========  END CROSS VALIDATION ACCURACY  ========"))

# Time to test
prediction <- predict(model, testingProcessed)

# Output results
print(paste("========        START PREDICTIONS        ========"))
prediction
print(paste("========         END PREDICTIONS         ========"))


# Plot the distance to Earth for Mercury, Venus, and Mars.
#
# Uses data taken from the Jet Propulsion Laboratory's DE432 ephemeris. See
# accompanying Python script to see how the magic happens.
library(dplyr)   # v0.7.8
library(ggplot2) # v3.1.0
library(readr)   # v1.3.0
library(scales)  # v1.0.0
library(stringr) # v1.3.1
library(tidyr)   # v0.8.2

# Import data containing past and future distances of Mercury, Venus, and Mars
# to the Earth. Run `python3 planets.py > planets.csv` to build the CSV file.
planets <- read_csv("planets.csv") %>%
  mutate(planet = str_to_title(str_extract(planet, "[A-Z]+$"))) %>%
  filter(date >= as.Date("2018-01-01")) %>%
  filter(date <= as.Date("2026-12-31"))

# Plot the distance from Mercury, Venus, and Mars to Earth.
planets %>%
  ggplot(aes(date, distance, group = planet, colour = planet)) +
  geom_line(size = .8) +
  scale_x_date(date_breaks = "1 year",
               date_labels = "%Y") +
  scale_y_continuous(breaks = c(0, 1, 2),
                     limits = c(0, 2.75),
                     expand = c(0, 0),
                     labels = unit_format(unit = " au")) +
  scale_colour_manual(values = c("Mercury" = "#4daf4a",
                                 "Venus" = "#377eb8",
                                 "Mars" = "#e41a1c")) +
  labs(title = "Hello neighbour",
       subtitle = "What’s the distance between Earth and its nearest planetary neighbours?",
       x = NULL,
       y = NULL,
       caption = "Source: Jet Propulsion Laboratory") +
  guides(colour = guide_legend(title = NULL))

# Calculate which planet is nearest to Earth on a given day.
nearest_planet <- planets %>%
  spread(planet, distance) %>%
  rowwise() %>%
  mutate(planet = if_else(Mercury == min(Mercury, Venus, Mars), "Mercury", ""),
         planet = if_else(Venus == min(Mercury, Venus, Mars), "Venus", planet),
         planet = if_else(Mars == min(Mercury, Venus, Mars), "Mars", planet),
         distance = if_else(Mercury == min(Mercury, Venus, Mars), Mercury, .0),
         distance = if_else(Venus == min(Mercury, Venus, Mars), Venus, distance),
         distance = if_else(Mars == min(Mercury, Venus, Mars), Mars, distance)) %>%
  select(date, planet, distance)

# Plot the distance between Earth and whichever planet is its nearest
# neighbour.
ggplot() +
  geom_line(data = planets,
            map = aes(date, distance, group = planet, colour = planet),
            alpha = 0.3) +
  geom_line(data = nearest_planet,
            map = aes(date, distance),
            colour = "#000000",
            size = .8) +
  scale_x_date(date_breaks = "1 year",
               date_labels = "%Y") +
  scale_y_continuous(breaks = c(0, 1, 2),
                     limits = c(0, 2.75),
                     expand = c(0, 0),
                     labels = unit_format(unit = " au")) +
  scale_colour_manual(values = c("Mercury" = "#4daf4a",
                                 "Venus" = "#377eb8",
                                 "Mars" = "#e41a1c")) +
  labs(title = "The wanderers of the solar system",
       subtitle = "What’s the distance between Earth and its nearest planetary neighbour?",
       x = NULL,
       y = NULL,
       caption = "Source: Jet Propulsion Laboratory") +
  annotate("text",
           label = "Nearest planet",
           x = as.Date("2021-08-01"),
           y = 1.9,
           size = 4) +
  annotate("segment",
           colour = "black",
           x = as.Date("2021-08-01"),
           xend = as.Date("2021-08-01"),
           y = 1.4,
           yend = 1.75) +
  guides(colour = guide_legend(title = NULL))


library(ggplot2)                     # plots
library(ggthemes)                    # fivethirtyeight theme
library(scales)                      # $ in plot axis
library(dplyr, warn.conflicts=FALSE) # left join
library(zoo, warn.conflicts=FALSE)   # rollapply

# Base directory for all generated graphs
gdir = "graphs"
rdir = "reports-generated"
gwidth = 7
gheight = 5

theme <- theme_fivethirtyeight(base_size=8, base_family="sans")

# Create graph directory if it does not exist
dir.create(file.path(gdir), showWarnings = FALSE)

# Parse ledger report file into dataframe with date & amount.
# Assumes no units, and dates in YYYY-MM-DD format.
std.parse <- function(filename) {
  r <- read.csv(file=filename, header=FALSE, sep=" ",
                col.names=c("date","amount"),stringsAsFactors=FALSE)
  r$dt <- as.Date(as.POSIXct(strptime(r$date, format="%Y-%m-%d")))
  r[c("dt","amount")]
}

# Net Worth Plot
cat("* Plotting Net Worth\n")
nw.raw <- std.parse(file.path(rdir, "networth.monthly.csv"))
nw.plot <- ggplot(nw.raw, aes(x=dt, y=amount)) +
  ggtitle("Net Worth") + geom_line() + theme +
  scale_y_continuous(labels = scales::dollar_format(), limits = c(0, NA))
ggsave(nw.plot, file=file.path(gdir, "networth.monthly.png"),
       width=gwidth, height=gheight)

# Monthly Expenses
# Expense data, monthly
exp.m <- std.parse(file.path(rdir, "expenses.monthly.csv")) %>%
  rename(expenses = amount)
cat("* Plotting Monthly Expenses\n")
expenses.monthly.plot <- ggplot(exp.m, aes(x=dt,y=expenses)) +
  ggtitle("Monthly Expenses") + geom_line() + theme +
  scale_y_continuous(labels = scales::dollar_format(), limits = c(0, NA))
ggsave(expenses.monthly.plot, file=file.path(gdir, "expenses.monthly.png"),
       width=gwidth, height=gheight)

# Years expenses saved (withdrawal rate calculation)
# Smooth the graph by averaging over several months of data
smooth.months = 4
# Invested assets, monthly totals
inv.m <- std.parse(file.path(rdir, "invested.monthly.csv")) %>%
  rename(assets = amount)
# Join datasets by their common 'dt' attribute
wr <- inv.m %>% left_join(exp.m, by=c("dt"))
# Calculate the rate (annualized expenses / invested asssets)
wr$rate <- ((wr$expenses*12)/wr$assets)
# Rolling mean to smooth data
wr <- wr %>% mutate(rate.mean = rollapply(data=rate, width=smooth.months,
                                          align="right", FUN=mean, fill = NA))
# Generate plot
cat("* Plotting Years of Saved Expenses\n")
years.exp.smooth.plot <- ggplot(wr, aes(x=dt,y=1/rate.mean)) +
  ggtitle("Years of Expenses Saved") + geom_line(na.rm=TRUE) + theme +
  geom_hline(aes(yintercept=25), linetype=2) +
  scale_y_continuous(limits = c(0, NA))
ggsave(years.exp.smooth.plot, file=file.path(gdir, "years.expenses.png"),
  width=gwidth, height=gheight)


zemljevid.sveta.k<- function(n){
  k <- kmeans(velemojstri_drzave_norm, n, nstart = 1000)
  skupine <- data.frame(Drzava = velemojstri_drzave$Drzava, skupina=factor(k$cluster))
  print(skupine)
  data <- merge(World, skupine,by.x="sovereignt", by.y="Drzava")
  graf <- tm_shape(data) + tm_polygons("skupina")
  return(graf)
}


#!/usr/bin/env r
#
# Comparison benchmark
#
# This shows how Armadillo improves on the previous version using GNU GSL,
# and how both are doing better than lm.fit()
#
# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
# Rcpp is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# Rcpp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.

suppressMessages(library(RcppGSL))
suppressMessages(library(RcppArmadillo))

source("lmArmadillo.R")
source("lmGSL.R")

set.seed(42)
n <- 5000
k <- 9
X <- cbind( rep(1,n), matrix(rnorm(n*k), ncol=k) )
truecoef <- 1:(k+1)
y <- as.numeric(X %*% truecoef + rnorm(n))

N <- 100

lmgsl <- lmGSL()
lmarma <- lmArmadillo()

tlm <- mean(replicate(N, system.time( lmfit <- lm(y ~ X - 1) )["elapsed"]), trim=0.05)
tlmfit <- mean(replicate(N, system.time(lmfitfit <- lm.fit(X, y))["elapsed"]), trim=0.05)
tlmgsl <- mean(replicate(N, system.time(lmgsl(y, X))["elapsed"]), trim=0.05)
tlmarma <- mean(replicate(N, system.time(lmarma(y, X))["elapsed"]), trim=0.05)

res <- c(tlm, tlmfit, tlmgsl, tlmarma)
data <- data.frame(results=res, ratios=tlm/res)
rownames(data) <- c("lm", "lm.fit", "lmGSL", "lmArma")
cat("For n=", n, " and k=", k, "\n", sep="")
print(t(data))
print(t(1/data[,1,drop=FALSE])) # regressions per second


df = read_csv('./data/final_csv/predictions_resolution.csv') %>%
  filter(resolution == 0.01) %>%
  select(method, location_error, orientation_error, x_source, y_source, orientation_source)
  mutate('source_id' = group_indices(., x_source, y_source, orientation_source))

# Summary stats
df %>%
  group_by(method) %>%
  get_summary_stats(location_error, orientation_error, type = "mean_sd")

# Create boxplots
bxp_loc <- ggboxplot(df, x = "method", y = "location_error", add = "point")
bxp_or <- ggboxplot(df, x = "method", y = "orientation_error", add = "point")

# There are extreme outliers
df %>%
  group_by(method) %>%
  identify_outliers(location_error) %>%
  filter(is.extreme)
df %>%
  group_by(method) %>%
  identify_outliers(orientation_error) %>%
  filter(is.extreme)

# Check normality (fails because to large sample size)
df %>%
  group_by(method) %>%
  shapiro_test(location_error)
df %>%
  group_by(method) %>%
  shapiro_test(orientation_error)

# Data is not normally distributed...
ggqqplot(df, "location_error", facet.by = "method")

# Still try it
res.aov <- anova_test(data = df, dv = location_error, wid = source_id, within = method)
get_anova_table(res.aov)

# Pairwise tests
pwc <- df %>%
  pairwise_t_test(
    location_error ~ method, paired = TRUE,
    p.adjust.method = "bonferroni"
  )
pwc


modelPlotStyle2 = function( calobs_, rhessys_, dailytimeSeries_, output){

	calobsDayFlow = calobs_
	calobsWeekFlow = tapply(calobsDayFlow, dailytimeSeries_ $yy_woy, sum )
	calobsMonthFlow = tapply(calobsDayFlow, dailytimeSeries_ $yy_month, sum )
	calobsYearFlow = tapply(calobsDayFlow, dailytimeSeries_ $wy, sum )
	weeklyCDF=ecdf(calobsWeekFlow)

	rhessysDayFlow = rhessys_[,19]#flow
	rhessysWeekFlow = tapply(rhessysDayFlow, dailytimeSeries_ $yy_woy, sum )
	rhessysMonthFlow = tapply(rhessysDayFlow, dailytimeSeries_ $yy_month, sum )
	rhessysYearFlow = tapply(rhessysDayFlow, dailytimeSeries_ $wy, sum )
	rhessysDayResidue = rhessysDayFlow - calobsDayFlow

	day_plottime = as.Date(paste(dailytimeSeries_ $day, dailytimeSeries_ $month, dailytimeSeries_ $year,sep="-"),format="%d-%m-%Y")
	week_plottime = day_plottime[tapply(seq_along(day_plottime), dailytimeSeries_ $yy_woy, function(dd){dd[1]})]
	month_plottime = day_plottime[tapply(seq_along(day_plottime), dailytimeSeries_ $yy_month, function(dd){dd[1]})]
	year_plottime = day_plottime[tapply(seq_along(day_plottime), dailytimeSeries_ $wy, function(dd){dd[1]})]

	pdf(output,height=9,width=8)
	layout(matrix(1:10,nrow=5,ncol=2,byrow=T))
	par(mar=c(4,4,1,1) )

	ymin = min(rhessysYearFlow, calobsYearFlow)
	ymax = max(rhessysYearFlow, calobsYearFlow)
	plot(year_plottime ,calobsYearFlow,type='l',ylim=c(ymin,ymax), xlab="");
	lines(year_plottime ,rhessysYearFlow,col='red');

	ymin = min(rhessysYearFlow, calobsYearFlow)
	ymax = max(rhessysYearFlow, calobsYearFlow)
	plot(rhessysYearFlow ,calobsYearFlow, ylim=c(ymin,ymax));abline(a=0,b=1,lty=2)

	ymin = min(rhessysMonthFlow, calobsMonthFlow)
	ymax = max(rhessysMonthFlow, calobsMonthFlow)
	plot(month_plottime ,calobsMonthFlow,type='l',ylim=c(ymin,ymax), xlab="");
	lines(month_plottime ,rhessysMonthFlow,col='red');
	ymin = min(rhessysMonthFlow, calobsMonthFlow)
	ymax = max(rhessysMonthFlow, calobsMonthFlow)
	plot(rhessysMonthFlow ,calobsMonthFlow, ylim=c(ymin,ymax));abline(a=0,b=1,lty=2)

	ymin = min(rhessysWeekFlow, calobsWeekFlow)
	ymax = max(rhessysWeekFlow, calobsWeekFlow)
	plot(week_plottime ,calobsWeekFlow,type='l',ylim=c(ymin,ymax), xlab="");
	lines(week_plottime ,rhessysWeekFlow,col='red');
	###------------------------- log
	ymin = min(rhessysWeekFlow, calobsWeekFlow)
	ymax = max(rhessysWeekFlow, calobsWeekFlow)
	plot(rhessysWeekFlow ,calobsWeekFlow, ylim=c(ymin,ymax),xlim=c(ymin,ymax),log='xy');abline(a=0,b=1,lty=2)

	ymin = min(rhessysDayFlow, calobsDayFlow)
	ymax = max(rhessysDayFlow, calobsDayFlow)
	plot(day_plottime ,calobsDayFlow,type='l',ylim=c(ymin,ymax), xlab="");
	lines(day_plottime ,rhessysDayFlow,col='red');
	###------------------------- log
	ymin = min(rhessysDayFlow, calobsDayFlow)
	ymax = max(rhessysDayFlow, calobsDayFlow)
	plot(rhessysDayFlow ,calobsDayFlow, ylim=c(ymin,ymax),xlim=c(ymin,ymax),log='xy' );abline(a=0,b=1,lty=2)

	yy1 = log(rhessysWeekFlow,10)
	yy2 = log(calobsWeekFlow,10)
	ymin = min(yy1,yy2)
	ymax = max(yy1,yy2)
	plot(week_plottime ,yy2,type='l',ylim=c(ymin,ymax) , xlab="",ylab="log weeklyflow",yaxt='n');
	lines(week_plottime ,yy1,col='red');
	axis(2,at=round(ymin):round(ymax), labels=10^(round(ymin):round(ymax)) )

	yy1 = log(rhessysDayFlow,10)
	yy2 = log(calobsDayFlow,10)
	ymin = min(yy1,yy2)
	ymax = max(yy1,yy2)
	plot(day_plottime ,yy2,type='l',ylim=c(ymin,ymax),xlab="",ylab="log dailyflow" ,yaxt='n');
	lines(day_plottime ,yy1,col='red');
	axis(2,at=round(ymin):round(ymax), labels=10^(round(ymin):round(ymax)) )

	dev.off()
}#


dist_hist <- function(original_matrix_file, groups_list = "AMETHST_groups", perm_dists_path = "./DISTs", write_tables=TRUE, debug = FALSE){

# dist_hist <- function(distance_matrix_file, file_path = "./", groups_list = "groups", perm_dists_path = "./DISTs", debug = 0){

# Sub to process counts for an individual dist file
# return two matrices - one for within and one for between group counts
# This sub is the hear of the script
  process_dist <- function(dist_matrix, groups) {

   # create some file names for output
   # real_table = paste(original_matrix_file, ".real_counts", sep="")
   # perm_table = paste(original_matrix_file, ".perm_counts_acg", sep="")

  # read in the groups
    groups_in <- readLines(groups_list)
    num_groups <- dim(data.frame(groups_in))[1]

  # read in the dists
    distance_matrix <- data.matrix(read.table(dist_matrix, row.names=1, header=TRUE, check.names=FALSE, sep="\t", comment.char="", quote=""))

  # initialize arrays to hold the distances for each unique pair of samples -- within and between group in separate arrays
    within_group_distances <- matrix()
    between_group_distances <- matrix()

    for (i in 1:num_groups){

      group_samples <- strsplit(groups_in[i], ",")
      if(debug==TRUE){print(paste("group_samples: ", group_samples))}
      num_samples <- dim(data.frame(group_samples))[1]
      num_pairs <- dim(combn(num_samples,2))[2]
      if(debug==TRUE){print(paste("num_pairs: ",num_pairs))}
      if(debug==TRUE){print(paste("num_samples: ",num_samples))}
    #group_distances <<- matrix (NA, size(combn(num_samples,2))[2], 1) #####
      #group_distances <<- matrix (NA, dim(combn(num_samples,2))[2], 1) #####
      group_distances <- matrix (NA, num_pairs, 1)

      #dimnames(group_distances)[[1]] <- c(rep("", dim(group_distances)[[1]]))

      if(debug==TRUE){print(paste("dim(group_distances)[[1]] : ",dim(group_distances)[[1]]))}
      dimnames(group_distances)[[1]] <- c(rep("",num_pairs))

      #dimnames(group_distances)[[1]] <- c(rep("", dim(group_distances)[[1]]))####<---

      gd_index <- 1

      for (m in 2:num_samples){ # get all of the unique non-redundant pairs

        for (n in 1:(m-1)){

          if (
              identical( toString(charmatch( group_samples[[1]][m], dimnames(distance_matrix)[[1]])), "NA" ) ||
              identical( toString(charmatch(   group_samples[[1]][n], dimnames(distance_matrix)[[1]])), "NA" )
              )
            {

              stop (paste("sample names in the groups file:\n", groups_list,"\n (", noquote(group_samples[[1]][m]), " or ", noquote(group_samples[[1]][n]), ")\n are not in the distance_matrix:\n",dist_matrix, "\n",
                          "check the names in the groups and distance_matrix files to make sure that they match\n\n"))
            }

          #if (debug==TRUE){ print(paste("gd_index =", gd_index, "distance:", distance_matrix[ noquote(group_samples[[1]][m]), noquote(group_samples[[1]][n]) ] )) } #####
          group_distances[gd_index,1] <- distance_matrix[ noquote(group_samples[[1]][m]), noquote(group_samples[[1]][n]) ] #####
          #if(debug==TRUE){print(paste("group_samples[[1]][n] :", group_samples[[1]][n]))}
          #if(debug==TRUE){print(paste("group_samples[[1]][m] :", group_samples[[1]][m]))}
          #if(debug==TRUE){print(paste("gd_index: ",gd_index))}
          dimnames(group_distances)[[1]][gd_index] <- paste(group_samples[[1]][n], "::", group_samples[[1]][m])
          gd_index <- gd_index + 1

        }

      }

      if ( i == 1 ){
        within_group_distances <- group_distances
      }else{
        within_group_distances <- rbind(within_group_distances, group_distances)
      }

      #return(group_distances)

    }

  #
    for (p in 2:num_groups){ # get all of the unique non-redundant pairs

      for (q in 1:(p-1)){

        alpha_samples <- strsplit(groups_in[p], ",")
        num_alpha_samples <- dim(data.frame(alpha_samples))[1]
                                        #alpha_distances <- matrix(NA, size(combn(num_alpha_samples,2))[2], 1) ### ###

        beta_samples <- strsplit(groups_in[q], ",")
        num_beta_samples <- dim(data.frame(beta_samples))[1]
                                        #beta_distances <- matrix(NA, size(combn(num_beta_samples,2))[2], 1) ### ###

        alpha_beta_distances <- matrix(NA, (num_alpha_samples*num_beta_samples), 1) # alpha and beta should be the same size
        dimnames(alpha_beta_distances)[[1]] <- c(rep("",num_alpha_samples*num_beta_samples)) #<--

        dist_index <- 1 ### ###

                                        #write(gsub(" ", "", (paste(">>Group(", p, ")::Group(", q, ")"))), file=output_file, append=TRUE)

        for (na in 1:num_alpha_samples){
          for (nb in 1:num_beta_samples){

            alpha_beta_distances[dist_index,1] <- distance_matrix[ noquote(alpha_samples[[1]][na]), noquote(beta_samples[[1]][nb]) ] ### ###
            dimnames(alpha_beta_distances)[[1]][dist_index] <- paste(alpha_samples[[1]][na], "::", beta_samples[[1]][nb]) #<--
            dist_index <- dist_index + 1 ### ###

          }
        }

      }

      if( (p-1) == 1 ){
        between_group_distances <- alpha_beta_distances
      }else{
        between_group_distances <- rbind(between_group_distances, alpha_beta_distances)
      }

    }

    distances_list <- list("within"= within_group_distances, "between" = between_group_distances)

    return(distances_list)

  }

# Import groups from file

#groups_characterlist <<- readLines(groups_list)

# First, deal with the original file
  distances_list_real <<- process_dist(dist_matrix=original_matrix_file, groups=groups_list )

# now deal with the permutations

  perm_dists <- dir(perm_dists_path)
  num_perm <- length(perm_dists)

  within_group_distances_perm_sum <- matrix()
  between_group_distances_perm_sum <- matrix()

  for (j in 1:num_perm){

    perm_file <- paste( perm_dists_path,"/",perm_dists[j], sep="")

    if(debug==TRUE){print(paste( "perm_file: ", perm_file))}

    distances_list_perm <- process_dist(dist_matrix=perm_file, groups=groups_list)

    within_perm <- distances_list_perm$within
    between_perm <- distances_list_perm$between

    if(j == 1){
      #within_group_distances_perm_sum <- distances_list_perm$within
      #between_group_distances_perm_sum <- distances_list_perm$between

      within_group_distances_perm_sum <- within_perm
      between_group_distances_perm_sum <- between_perm

      if(debug==TRUE){print(paste("j: ",j,"     within_perm: ",within_perm[1,1]))}
      if(debug==TRUE){print(paste("j: ",j,"     within_sum   : ",within_group_distances_perm_sum[1,1]))}
    }else{
      #within_group_distances_perm_sum <- within_group_distances_perm_sum + distances_list_perm$within
      #between_group_distances_perm_sum <- between_group_distances_perm_sum + distances_list_perm$between
      within_group_distances_perm_sum <- within_group_distances_perm_sum + within_perm
      between_group_distances_perm_sum <- between_group_distances_perm_sum + between_perm
      if(debug==TRUE){print(paste("j: ",j,"     within_perm: ",within_perm[1,1]))}
      if(debug==TRUE){print(paste("j: ",j,"     within_sum   : ",within_group_distances_perm_sum[1,1]))}
    }

  }

  within_group_distances_perm_avg = ( within_group_distances_perm_sum / num_perm )
  between_group_distances_perm_avg = ( between_group_distances_perm_sum / num_perm )
  if(debug==TRUE){print(paste("j: ",j,"     within_1_1_avg: ",within_group_distances_perm_avg[1,1]))}

                                        # now plots

  within_group_real.hist <-  hist(distances_list_real$within, plot=FALSE, breaks=20)
  between_group_real.hist <-  hist(distances_list_real$between, plot=FALSE, breaks=20)

  within_group_perm.hist <-  hist(within_group_distances_perm_avg, plot=FALSE, breaks=20)
  between_group_perm.hist <-  hist(between_group_distances_perm_avg, plot=FALSE, breaks=20)

  x_max = max(within_group_real.hist$breaks, between_group_real.hist$breaks, within_group_perm.hist$breaks, between_group_perm.hist$breaks, na.rm=TRUE)
  y_max = max(within_group_real.hist$counts, between_group_real.hist$counts, within_group_perm.hist$counts, between_group_perm.hist$counts, na.rm=TRUE)

                                        #print(paste("my ylim =", my_ylim))

  legend_colors <- c("blue", "blue", "red", "red")
  legend_text <- c(paste("within_group.real  :: avg=", round(mean(within_group_real.hist$counts),digits=3),  ", sd=", round(sd(within_group_real.hist$counts),digits=3), sep=""),
                   paste("between_group.real :: avg=", round(mean(between_group_real.hist$counts),digits=3), ", sd=", round(sd(between_group_real.hist$counts),digits=3), sep=""),
                   paste("within_group.perm  :: avg=", round(mean(within_group_perm.hist$counts),digits=3),  ", sd=", round(sd(within_group_perm.hist$counts),digits=3), sep=""),
                   paste("between_group.perm :: avg=", round(mean(between_group_perm.hist$counts),digits=3), ", sd=", round(sd(between_group_perm.hist$counts),digits=3), sep="")
                         )

  plot(x = within_group_real.hist$breaks, y = c(within_group_real.hist$counts, 0), ylab="frequency", xlab="dist", type="l", lty=3, col=legend_colors[1], xlim=c(0,x_max), ylim=c(0,y_max), main="Distance comparison (real vs averaged perm)")
  lines(x = between_group_real.hist$breaks, y = c(between_group_real.hist$counts, 0), ylab="frequency", xlab="dist", type="l", col=legend_colors[2])
  lines(x = within_group_perm.hist$breaks, y = c(within_group_perm.hist$counts, 0), ylab="frequency", xlab="dist", type="l", lty=3, col=legend_colors[3])
  lines(x = between_group_perm.hist$breaks, y = c(between_group_perm.hist$counts, 0), ylab="frequency", xlab="dist", type="l", col=legend_colors[4])

  legend("topleft", legend = legend_text, pch=19, lty=c(3,1), col = legend_colors)

  if(write_tables == TRUE ){
    real_table = paste(original_matrix_file, ".real_counts", sep="")
    perm_table = paste(original_matrix_file, ".perm_counts_acg", sep="")
    write.table(rbind(distances_list_real$within, distances_list_real$between), file = real_table, col.names=NA, row.names = TRUE, sep="\t", quote=FALSE)
    #write.table(rbind(within_group_perm.hist$counts, between_group_perm.hist$counts), file = perm_table, col.names=NA, row.names = TRUE, sep="\t", quote=FALSE)
    if(debug==TRUE){print(paste("within:  ",within_group_real.hist$counts))}
    if(debug==TRUE){print(paste("class(within_group_real.hist$counts):  ",class(within_group_real.hist$counts)))}
    if(debug==TRUE){print(paste("between: ",between_group_real.hist$counts))}

  }

  #legend("topleft", legend = legend_text, pch=19, lty=c(3,1), col = c("blue", "blue", "red", "red"))

}

## dist_hist <- function(distance_matrix_file, groups_list = "AMETHST_groups", debug = 0){

## # dist_hist <- function(distance_matrix_file, file_path = "./", groups_list = "groups", perm_dists_path = "./DISTs", debug = 0){

##   legend_text <- c("within_group","between_group")
##   legend_colors <- c("red", "green")

## # First, deal with the original file

##   distance_matrix <<- data.matrix(read.table(distance_matrix_file, row.names=1, header=TRUE, check.names=FALSE, sep="\t", comment.char="", quote=""))

##   groups_dataframe <<- read.table(groups_list, header=FALSE, check.names=FALSE, sep = ",", comment.char="", quote="", fill=TRUE, blank.lines.skip=TRUE)
##   #groups_characterlist <<- readLines(groups_list)

##   groups_in <<- readLines(groups_list)
##   num_groups <<- dim(data.frame(groups_in))[1]

##   within_group_distances <- matrix()
##   between_group_distances <- matrix()

##   for (i in 1:num_groups){

##     if ( debug>0 ) { print(paste("Group:", i)) }

##     group_samples <- strsplit(groups_in[i], ",")
##     num_samples <- dim(data.frame(group_samples))[1]
##     group_distances <<- matrix (NA, size(combn(num_samples,2))[2], 1) #####
##     gd_index <- 1

##     for (m in 2:num_samples){ # get all of the unique non-redundant pairs

##       for (n in 1:(m-1)){

##         if (
##             identical( toString(charmatch( group_samples[[1]][m], dimnames(distance_matrix)[[1]])), "NA" ) ||
##             identical( toString(charmatch(   group_samples[[1]][n], dimnames(distance_matrix)[[1]])), "NA" )
##             )
##           {

##             stop (paste("sample names in the groups file:\n", groups_list,"\n (", noquote(group_samples[[1]][m]), " or ", noquote(group_samples[[1]][n]), ")\n are not in the distance_matrix:\n",distance_matrix_file, "\n",
##                         "check the names in the groups and distance_matrix files to make sure that they match\n\n"))
##           }

##         if (debug>0){ print(paste("gd_index =", gd_index, "distance:", distance_matrix[ noquote(group_samples[[1]][m]), noquote(group_samples[[1]][n]) ] )) } #####
##         group_distances[gd_index,1] <<- distance_matrix[ noquote(group_samples[[1]][m]), noquote(group_samples[[1]][n]) ] #####
##         gd_index <- gd_index + 1

##       }

##     }

##     if ( i == 1 ){
##       within_group_distances <- group_distances
##     }else{
##       within_group_distances <- rbind(within_group_distances, group_distances)
##     }

##   }

##   #
##   for (p in 2:num_groups){ # get all of the unique non-redundant pairs

##     for (q in 1:(p-1)){

##       alpha_samples <- strsplit(groups_in[p], ",")
##       num_alpha_samples <- dim(data.frame(alpha_samples))[1]
##                                         #alpha_distances <- matrix(NA, size(combn(num_alpha_samples,2))[2], 1) ### ###

##       beta_samples <- strsplit(groups_in[q], ",")
##       num_beta_samples <- dim(data.frame(beta_samples))[1]
##                                         #beta_distances <- matrix(NA, size(combn(num_beta_samples,2))[2], 1) ### ###

##       alpha_beta_distances <<- matrix(NA, (num_alpha_samples*num_beta_samples), 1) # alpha and beta should be the same size
##       dist_index <- 1 ### ###

##       #write(gsub(" ", "", (paste(">>Group(", p, ")::Group(", q, ")"))), file=output_file, append=TRUE)

##       for (na in 1:num_alpha_samples){
##         for (nb in 1:num_beta_samples){

##           alpha_beta_distances[dist_index,1] <<- distance_matrix[ noquote(alpha_samples[[1]][na]), noquote(beta_samples[[1]][nb]) ] ### ###
##           dist_index <- dist_index + 1 ### ###

##         }
##       }

##     }

##     if( p == 1 ){
##       between_group_distances <- alpha_beta_distances
##     }else{
##       between_group_distances <- rbind(between_group_distances, alpha_beta_distances)
##     }

##   }

## within_group.hist <-  hist(within_group_distances, plot=FALSE, breaks=20)
## between_group.hist <-  hist(between_group_distances, plot=FALSE, breaks=20)

## y_max = max(within_group.hist$counts, between_group.hist$counts, na.rm=TRUE)
## #print(paste("my ylim =", my_ylim))

## plot(x = within_group.hist$breaks, y = c(within_group.hist$counts, 0), ylab="frequency", xlab="breaks", type="l", col=legend_colors[1], ylim=c(0,y_max))
## lines(x = between_group.hist$breaks, y = c(between_group.hist$counts, 0), ylab="frequency", xlab="breaks", type="l", col=legend_colors[2])
## legend("topright", legend = legend_text, pch=19, col = legend_colors)

## }

## dist_hist <- function(original_dist,
##                           #input_type = "file",
##                           #original_dist,
##                           perm_dists_path = "./DISTs",
##                           file_out_prefix = "my_dist_hist",
##                           create_figure=FALSE){

## # Print usage if
##    #if (nargs() == 0){print_usage()}

## # mport the original dist file
## original.dist <- data.matrix(read.table(original_dist, row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))

## original_hist <- hist(as.dist(original.dist), plot=FALSE, breaks=20)

## sum.dist <- matrix()

## perm_dists <- dir(perm_dists_path)

## for (i in 1:length(perm_dists)){

##   perm.dist <- data.matrix(read.table(  paste( perm_dists_path,"/",perm_dists[i], sep="") , row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))

##   # perm_hist <- hist(perm.dist, plot=FALSE, breaks=20)

##   if ( i==1 ){
##     sum.dist = perm.dist
##   }else{
##     sum.dist = sum.dist + perm.dist
##   }

## }

## avg.perm.dist = ( sum.dist / length(perm_dists) )

## #perm_hist <- hist(avg.perm.dist, plot=FALSE, breaks=20)
## perm_hist <- hist(as.dist(avg.perm.dist), plot=FALSE, breaks=20)

## print(attributes(as.dist(original.dist)))
## print(attributes(as.dist(avg.perm.dist)))

##   #num_breaks <- length(my_hist$breaks)

##   #print(paste(my_hist$counts, 0))

##   #print(my_hist$breaks)
##   #my_hist <- hist(temp.matrix)

## }

## dist_hist <- function(original_dist,
##                           #input_type = "file",
##                           #original_dist,
##                           perm_dists_path = "./DISTs",
##                           file_out_prefix = "my_dist_hist",
##                           create_figure=FALSE){

## # Print usage if
##    #if (nargs() == 0){print_usage()}

## # mport the original dist file
## original.dist <- data.matrix(read.table(original_dist, row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))

## original_hist <- hist(as.dist(original.dist), plot=FALSE, breaks=20)

## sum.dist <- matrix()

## perm_dists <- dir(perm_dists_path)

## for (i in 1:length(perm_dists)){

##   perm.dist <- data.matrix(read.table(  paste( perm_dists_path,"/",perm_dists[i], sep="") , row.names=1, check.names=FALSE, header=TRUE, sep="\t", comment.char="", quote=""))

##   # perm_hist <- hist(perm.dist, plot=FALSE, breaks=20)

##   if ( i==1 ){
##     sum.dist = perm.dist
##   }else{
##     sum.dist = sum.dist + perm.dist
##   }

## }

## avg.perm.dist = ( sum.dist / length(perm_dists) )

## #perm_hist <- hist(avg.perm.dist, plot=FALSE, breaks=20)
## perm_hist <- hist(as.dist(avg.perm.dist), plot=FALSE, breaks=20)

## print(attributes(as.dist(original.dist)))
## print(attributes(as.dist(avg.perm.dist)))

##   #num_breaks <- length(my_hist$breaks)

##   #print(paste(my_hist$counts, 0))

## plot(x = original_hist$breaks, y = c(original_hist$counts, 0), ylab="frequency", xlab="breaks", type="l", col="blue")
## lines(x = perm_hist$breaks, y = c(perm_hist$counts, 0), ylab="frequency", xlab="breaks", type="l", col="red")

##   #print(my_hist$breaks)
##   #my_hist <- hist(temp.matrix)

## }


context("Testing  Links")

#create 4 Nodes

#  Link

n1<- new("Node",x=10, y=20)
n2<- new("Node",x=13, y=24)
n3<- new("Node", x=7, y=16)
n4<- new("Node", x=7, y=20)

#create links
#
	l1 <- new("Link",n1,n2)
	l2 <- new("Link",n1,n3)
	l3 <- new("Link",n1,n4)
	l4 <- new("Link",n3,n4)
context("\tTest 01: Are the Node-Methods for Links working?")
test_that("Node-Methods work for Links", {

	expect_true(l1$distance == 5)
	expect_true(l2$distance == 5)
	expect_true(l3$distance == 3)
	expect_true(l4$distance == 4)

})

context("done.")
context("--------------------------------------------------")


##
## Fig 2: Fertility of Mosuo household heads
##
library(AICcmodavg)
library(lme4)
library(MuMIn)
library(tidyverse)

# source("data functions/reproductive success - load data.r")
source("init.r")

####################################################################################
## Data prep
##
mosuo.people.sub = mosuo.people %>%
  # keep only adult Mosuo household heads
  filter(Age>=15 & EthnicGroup=="Mosuo" & ID %in% mosuo.heads) %>%

  # get predictors into correct formats
  mutate(income_bin = factor(income01_12),
         WealthRank = factor(WealthRank),
         zhubo1 = factor(zhubo1),
         #TotalHelp_bin = factor(ifelse(TotalHelp==0, 0, 1)),
         VillageID = factor(VillageID)) %>%

  # keep only relevant variables
  dplyr::select(ChildNum, Age, year.of.education, income_bin, livestockno_12, WealthRank, zhubo1, VillageID, Sex)

##
## females
##
mosuo.females = mosuo.people.sub %>%
  filter(Sex=="f") %>%
  dplyr::select(-Sex) %>%
  na.omit()

# head(mosuo.females)
nrow(mosuo.females)

##
## males
##
mosuo.males = mosuo.people.sub %>%
  filter(Sex=="m") %>%
  dplyr::select(-Sex) %>%
  na.omit()

nrow(mosuo.males)

##
## pre-processing
##
# mean-centre ages
mosuo.females$Age.c = as.numeric(scale(mosuo.females$Age))
mosuo.males$Age.c = as.numeric(scale(mosuo.males$Age))

# age^2
mosuo.females$Age2 = mosuo.females$Age.c^2
mosuo.males$Age2 = mosuo.males$Age.c^2

rm(mosuo.people.sub)

#########################################################################################################
## Plot fertility distributions
##
# this function is the same as rethinking::simplehist() but without requiring the user to install the rethinking package...
plot_kids = function(d, title="") plot(table(d$ChildNum), xlab="Number of children", ylab="Count", main=title)

png(file.path(plots.dir, "fertility distributions.png"), height=10, width=20, units="cm", res=300)
  par(mfrow=c(1,2))
  plot_kids(mosuo.females, "a")
  plot_kids(mosuo.males, "b")
dev.off()

pdf(file.path(plots.dir, "fertility distributions.pdf"), height=5, width=10)
  par(mfrow=c(1,2))
  plot_kids(mosuo.females, "a")
  plot_kids(mosuo.males, "b")
dev.off()

par(mfrow=c(1,1))  # reset

####################################################################################
## Should we use a linear or quadratic term for age?
##
m.age.1 = glm(ChildNum ~ Age.c, data=mosuo.females, family="poisson")
m.age.2 = glm(ChildNum ~ Age.c + Age2, data=mosuo.females, family="poisson")

aictab(list(m.age.1, m.age.2), modnames=c("age", "age^2"))  # quadratic model fits best (though only has 66% of the weight)

rm(m.age.1, m.age.2)

####################################################################################
## Prepare for model fitting
##
# lists to store all the female (.f) and male (.m) models
m.rs.f = list()
m.rs.m = list()

# names of models
rs_names = c("Null model", "Control", "Control + Zhu")
# rs_names = c("Null model", "Control", "Control + Zhu", "Control + Help", "Control + Help + Zhu")

####################################################################################
## Poisson models for reproductive success - female household heads
##
# null
m.rs.f[[1]] = glmer(ChildNum ~ 1 + (1 | VillageID), family="poisson", data=mosuo.females)

# control (age, age^2, no. sibs, agexsibs, education, wealth)
m.rs.f[[2]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + (1 | VillageID), family="poisson", data=mosuo.females)

# control + Zhubo
m.rs.f[[3]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + zhubo1 + (1 | VillageID), family="poisson", data=mosuo.females)

# with farm help
# m.rs.f[[4]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + TotalHelp_bin + (1 | VillageID), family="poisson", data=mosuo.females)
# m.rs.f[[5]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + TotalHelp_bin + zhubo1 + (1 | VillageID), family="poisson", data=mosuo.females)

##
## model selection/averaging
##
best.models = model.sel(m.rs.f)
best.models$Model = rs_names[ as.integer(rownames(best.models))]  # add model names in correct order

best.models %>%
  dplyr::select(Model, K=df, delta, weight, LL=logLik) %>%
  write_csv(file.path(results.dir, "Reproductive success - confidence set - females - household heads.csv"))

# averaging
avg.model = model.avg(best.models, subset = delta < 2, revised.var=T)

avg.model.sum.f = summary(avg.model)$coefficients[2,] %>%
  as_data_frame() %>%
  rownames_to_column(var="Parameter") %>%
  bind_cols(confint(avg.model) %>% as_data_frame())

avg.model.sum.f$Parameter <- c("(Intercept)"
                              ,"Age", "Age^2"
                              ,"Education (years)", "Tourist income", "No. livestock"
                              ,"Wealth rank: 2", "Wealth rank: 3", "Wealth rank: 4", "Wealth rank: 5", "Wealth rank: 6"
                              ,"Zhubo?"
)

####################################################################################
## Poisson models for reproductive success - male household heads
##
# null
m.rs.m[[1]] = glmer(ChildNum ~ 1 + (1 | VillageID), family="poisson", data=mosuo.males,
                             control=glmerControl(optimizer="bobyqa", optCtrl=list(maxfun=2e5)))

# control (age, age^2, no. sibs, agexsibs, education, wealth)
m.rs.m[[2]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + (1 | VillageID), family="poisson", data=mosuo.males,
                             control=glmerControl(optCtrl=list(maxfun=2e5)))

# control + Zhubo
m.rs.m[[3]] = glmer(ChildNum ~ Age.c + Age2 + year.of.education + income_bin + livestockno_12 + WealthRank + zhubo1 + (1 | VillageID), family="poisson", data=mosuo.males,
                             control=glmerControl(optimizer="bobyqa", optCtrl=list(maxfun=2e5)))

##
## model selection/averaging
##
best.models = model.sel(m.rs.m)
best.models$Model = rs_names[ as.integer(rownames(best.models))]  # add model names in correct order

best.models %>%
  dplyr::select(Model, K=df, delta, weight, LL=logLik) %>%
  write_csv(file.path(results.dir, "Reproductive success - confidence set - males - household heads.csv"))

# averaging
avg.model = model.avg(best.models, subset = delta < 2, revised.var=T)

avg.model.sum.m = summary(avg.model)$coefficients[2,] %>%
  as_data_frame() %>%
  rownames_to_column(var="Parameter") %>%
  bind_cols(confint(avg.model) %>% as_data_frame())

avg.model.sum.m$Parameter <- c("(Intercept)"
                               ,"Age", "Age^2"
                               ,"Education (years)", "Tourist income", "No. livestock"
                               ,"Wealth rank: 2", "Wealth rank: 3", "Wealth rank: 4", "Wealth rank: 5", "Wealth rank: 6"
                               ,"Zhubo?"
)

####################################################################################
## Plot model averaged estimates with CIs
## code modified from: https://github.com/seananderson/lobsters-predators/blob/7f90997b309e52a5f4f7470e20091bdf3b26cba5/r/mod.averaging.lmer.R
##
# pick one or the other of these
#png(filename=file.path(plots.dir, "fig 3.png"), width=200, height=100, units="mm", res=300)
pdf(file=file.path(plots.dir, "fig 3.pdf"), width=7.8, height=3.9)

##
## females
##
par(fig=c(0,0.6,0,1), new=TRUE)
num.params = nrow(avg.model.sum.f)
pch <- c(rep(19, 11), rep(21, 11), cex = 0.8)
par(mar = c(4, 9, 1, 1))
plot(1, 1, type = "n", xlim = c(min(avg.model.sum.f$`2.5 %`, na.rm=T), max(avg.model.sum.f$`97.5 %`, na.rm=T)), ylim = c(1, num.params), axes = FALSE, xlab = "", ylab = "")
with(avg.model.sum.f, points(value, 1:num.params, pch = pch))
with(avg.model.sum.f, segments(`2.5 %`, 1:num.params, `97.5 %`, 1:num.params))
abline(v = 0, lty = 2)
axis(1)
axis(2, at = 1:num.params, labels = avg.model.sum.f$Parameter, las = 1)
mtext("a")

##
## males
##
par(fig=c(0.6,1,0,1), new=TRUE)
num.params = nrow(avg.model.sum.m)
pch <- c(rep(19, 11), rep(21, 11), cex = 0.8)
par(mar = c(4, 1, 1, 1))
plot(1, 1, type = "n", xlim = c(min(avg.model.sum.m$`2.5 %`, na.rm=T), max(avg.model.sum.m$`97.5 %`, na.rm=T)), ylim = c(1, num.params), axes = FALSE, xlab = "", ylab = "")
with(avg.model.sum.m, points(value, 1:num.params, pch = pch))
with(avg.model.sum.m, segments(`2.5 %`, 1:num.params, `97.5 %`, 1:num.params))
abline(v = 0, lty = 2)
axis(1)
mtext("b")

dev.off()

####################################################################################
## Table of varying intercepts' variances for each model
##
bind_cols(
  data_frame(Model = rs_names),
  data_frame(Females = round(unlist(lapply(m.rs.f, VarCorr)), 3)),
  data_frame(Males   = round(unlist(lapply(m.rs.m, VarCorr)), 3))
) %>%
  write_csv(file.path(results.dir, "Reproductive success - variances of varying intercepts.csv"))

# save models
# save.image("fertility models.rdata")


# 3. faza: Vizualizacija podatkov
library(ggplot2)
library(gganimate)
library(tidyverse)
library(tmap)
library(plotly)
library(sf)
######Število potovanj glede na spol EU#####

g1 <- ggplot(EU_Spol) + geom_line(aes(x = leto, y = stevilo/10^6, color = spol, group = spol))+ labs(
  x = "Leto",
  y = "Število ljudi v mio",
  title = sprintf("Število potovanj glede na spol"))

#####Število potovanj glede na starost EU###### ok

g2 <- sumStarost %>% ggplot() + geom_col(data = sumStarost, aes(x = leto, y = x/10^6, fill = starost)) + labs(
  x = "Leto",
  y = "Število potovanj v mio",
  title = sprintf("Število potovanj glede na starost"))

#######indeks v primerjavi z državami####osnovni graf nekako
g3 <- average_indeks %>%
  ggplot(
    mapping = aes(x = reorder(Država,-x), y = x)
  ) +
  geom_bar(stat = "identity") + labs(
    x = "Država",
    y = "Št. potovanj na osebo",
    title = sprintf("Število potovanj na osebo v EU")
  ) + theme(axis.text.x = element_text(angle = 60, hjust = 1))

g3 <- g3 + average_indeks%>%filter(Država == "EU") %>% geom_bar(
  mapping = aes(x = Država, y = x) ,
  stat = "identity",
  fill = "red"
)
g3 <- g3 + average_indeks%>%filter(Država == "Slovenija") %>% geom_bar(
  mapping = aes(x = Država, y = x) ,
  stat = "identity",
  fill = "green"
)

#########min.plača, bdppc, št.preb. in velikost indeksa
gosp.zn. <- Gospodarske_značilnosti
colnames(gosp.zn.)[8] <- "št.prebivalcev"
g4 <- gosp.zn.[1:27,] %>%
  ggplot(
    mapping = aes(x = vsota, y = bdppc)
  ) +
  geom_count(
    aes(color = indeks,size = št.prebivalcev)
  ) + theme(axis.text.x = element_text(angle = 60, hjust = 1)) + labs(title=sprintf("Povezava z gospodarskimi značilnostmi"))
g4 <- ggplotly(g4,tooltip = "št.prebivalcev")
g4

####bdpcc, brezposelnost indeks in vse države
g5 <- Gospodarske_značilnosti[1:27,] %>%
  ggplot(
    mapping = aes(x =bdppc ,y =indeks.bp,  size = indeks , color = Država)
  ) + labs(
    x = "BDP per capita",
    y = "indeks brezposelnosti",
    title = sprintf("Št.potovanj v odvisnosti od brezposelnosti in BDPpc")
  )+
  geom_point() + theme(legend.position = "none")
g5 <- ggplotly(g5,tooltip = "Država")
g5

######zemljevid#########
###tukaj bo še tabelica indeksa, kjer bodo popravljena imena nazaj v angl. da lahko mergamo##
data("World")
ang_indeks <-  average_indeks
match(ang_indeks$Država, poimenovanje_drzav$drzave)
ang_indeks$Država = unlist(poimenovanje_drzav[match(ang_indeks$Država, poimenovanje_drzav$drzave), "drzava_anglesko"])
ang_indeks$Država[ang_indeks$Država == "Czech Republic" ] <- "Czech Rep."
colnames(ang_indeks)[1] <- "name"
podatki <- ang_indeks %>% left_join(World, by = "name")
podatki <- podatki[!(podatki$name == "Cyprus"| podatki$name == "Malta"| podatki$name == "Slovak Republic"|
  podatki$name == "European Union - 27 countries (from 2020)"),]

st_potovanj_graf <- function() {
  podatki <- st_sf(ang_indeks %>% left_join(World, by = "name"))
  podatki <- podatki[!(podatki$name == "Cyprus"| podatki$name == "Malta"| podatki$name == "Slovak Republic"|
                         podatki$name == "European Union - 27 countries (from 2020)"),]
  evropa <- tm_shape(podatki) + tm_polygons('x')
  tmap_mode('view')
  return(evropa)
}

mapa1 <- st_potovanj_graf()
tmap_mode("view")


library(magrittr)

df1 <- read.table("R:/Datasets/anes_timeseries_cdf_rawda-1948-2016.txt", header = T, sep = "|", stringsAsFactors = F)

dim(df1)

df2 <- cbind(as.numeric(df1$VCF0201), as.numeric(df1$VCF0202), as.numeric(df1$VCF0101))

dim(df2)

#dem therm, rep therm, age

for(i in 1:ncol(df2)){
    df2 <- df2[ !is.na(df2[,i]),]
}

toKeep1 <- !(df2[,1] == 98 | df2[,1] == 99)
toKeep2 <- !(df2[,2] == 98 | df2[,2] == 99)
toKeep3 <- !(df2[,3] == 0)
toKeep <- toKeep1 & toKeep2 & toKeep3

df3 <- df2[toKeep,]

fm1 <- lm(df3[,1] ~ df3[,2] + df3[,3])
#dv dem therm
#indv rep therm, age

fm1 %>% plot

fm2 <- lm(df3[,1] ~ df3[,2] * df3[,3])
#dv dem therm
#indv rep therm, age, interaction

# so age moderates the relationship
# https://psych.wisc.edu/henriques/mediator.html
# https://stats.stackexchange.com/questions/218401/testing-mediation-and-moderation-can-one-variable-function-as-both-mediator-and

fm2 %>% plot

fm3 <- lm(df3[,1] ~ df3[,3])
#dv dem therm
# indv age

plot(df3[,1] ~ df3[,3])
abline(reg = lm(df3[,1] ~ df3[,3]))
plot(fm3)#check fit
#I dont like the fit of these models

fm4 <- lm(df3[,1] ~ df3[,2])
# dv dem therm
# indv rep therm
summary(fm4)
fm4 %>% plot
#not normally distributed
fm4$resid %>% hist
#strong skew


coingame <- function(gamenum, flips) {
    results <- round(runif(flips))

    heads <- sum(results == 0)
    tails <- sum(results == 1)

    return(toString(paste('Game ', gamenum, ' | Heads: ', format(heads, big.mark=","),
    ' | Tails: ', format(tails, big.mark=","), ' | Total: ', format(heads + tails, big.mark=","))))
}

games <- 5
flips <- 1000000

for (x in 1:games) {
    print(coingame(x, flips))
}


source("ac_powerflow_lib.r")

animation_steps = 120

steps = seq(-0.2, 0.2, length.out=animation_steps/2)

for (i in 1:length(steps)) {
    ac_powerflow(sprintf("voltage_magnitude_flow/%03d.pdf",i), v_fr = 1.0 + steps[i])
    ac_powerloss(sprintf("voltage_magnitude_loss/%03d.pdf",i), v_fr = 1.0 + steps[i])
}

rev_steps = rev(steps)
for (i in 1:length(steps)) {
    ac_powerflow(sprintf("voltage_magnitude_flow/%03d.pdf",i+length(steps)), v_fr = 1.0 + rev_steps[i])
    ac_powerloss(sprintf("voltage_magnitude_loss/%03d.pdf",i+length(steps)), v_fr = 1.0 + rev_steps[i])
}


pips <- c("2", "3", "4", "5", "6", "7", "8", "9", "10", "Jack", "Queen", "King", "Ace")
suit <- c("Clubs", "Diamonds", "Hearts", "Spades")
# Create a deck
deck <- data.frame(pips=rep(pips, 4), suit=rep(suit, each=13))

shuffle <- function(deck)
{
   n <- nrow(deck)
   ord <- sample(seq_len(n), size=n)
   deck[ord,]
}

deal <- function(deck, fromtop=TRUE)
{
   index <- ifelse(fromtop, 1, nrow(deck))
   print(paste("Dealt the", deck[index, "pips"], "of", deck[index, "suit"]))
   deck[-index,]
}

# Usage
deck <- shuffle(deck)
deck
deck <- deal(deck)
# While no-one is looking, sneakily deal a card from the bottom of the pack
deck <- deal(deck, FALSE)


REBOL [
    Title: "Tests of simple stack vitrual mashine"
    File: %vm-spec.r
    Author: "Kirill Temnov"
    Date: 03/11/2015
    ]

do %spec.r
do %../vm.r
do %../utils.r

utils: make utils-instance []

test: make test-suite [name: "utils tests"]

test/assert [equal? #{0000} utils/int-to-word 0]
test/assert [equal? #{0001} utils/int-to-word 1]
test/assert [equal? #{0080} utils/int-to-word 128]
test/assert [equal? #{8000} utils/int-to-word 32768]
test/assert [equal? #{FFFF} utils/int-to-word 65535]
test/assert [equal? #{FFFF} utils/int-to-word -1]
test/assert [equal? #{FF80} utils/int-to-word -128]
test/assert [equal? #{8000} utils/int-to-word -32768]

test/assert [equal? 240 utils/word-to-int #{00F0}]
test/assert [equal? 292 utils/word-to-int #{0124}]
test/assert [equal? 31420 utils/word-to-int #{7ABC}]
test/assert [equal? 65440 utils/word-to-int #{FFA0}]

test/assert [equal? #{1122} utils/get-word #{00112233} 2]
test/assert [equal? #{2233} utils/get-word #{00112233} 3]

; TODO
; this part not work, strange ...
; test/assert [equal? [f d] utils/swap-stack-values [d f]]
; test/assert [equal? [b a] utils/swap-stack-values [a b]]
; test/assert [equal? [1 0] utils/swap-stack-values [0 1]]
; test/assert [equal? [bar foo buzz] utils/swap-stack-values [foo bar buzz]]
; test/assert [equal? [none none] utils/swap-stack-values []]
; test/assert [equal? [none fuzz] utils/swap-stack-values [fuzz]]

; use [vm] [
;     vm: make vitrual-mashine []
;     test/assert [equal? [2] utils/with-one-arg-do [#{0001}] :vm/dec]
;     test/assert [equal? [1] utils/with-one-arg-do [1] :vm/inc]
; ]
; test/assert [equal? [15] utils/with-two-args-do [7 8] func [a b] [a + b]]
; test/assert [equal? [455] utils/with-two-args-do [35 13] func [a ] [a * b]]

test/stat


polyroot(c(2i, 0, 1))
[1] -1+1i  1-1i

polyroot(c(1, -1e9, 1))
[1] 1e-09+0i 1e+09+0i


wpct <- function(x, weight=NULL, na.rm=TRUE){
  require(Hmisc)
  if(is.null(weight)){
    weight <- rep(1, length(x))
  }
  y <- wtd.table(x, weight, na.rm=na.rm)$sum.of.weights/sum(wtd.table(x, weight, na.rm=na.rm)$sum.of.weights)
  z <- as.vector(y)
  names(z) <- names(y)
  if(is.logical(x))
    z <- rev(z)
  z
}


# types
10.5 55    # numeric
1L 55L     # integer
4i 9+3i    # complex
'foo'      # character (string)
TRUE FALSE # logical (boolean)

class(TRUE) # check type

# operator
+ - * /          # arithmetic
	^              #   exponent
	%%             #   remainder
	%/%            #   integer division
<- -> <<- ->>    # assignment
== != >	 < >= <= # comparison
! && || & |      # logical
:    # sequence generator
%in% # does elem belong to vector
%*%  # matrix multiplication

# structs
c(1,2,3,4)             # vector
c('a','b','c')         # ...
list('a','b','c')      # list
matrix(c(1,2,3,4),2,2) # matrix
array(1:10)            # array
array(c('a','b'))      # ...
array(1:10,c(5,5))     # ... 2d

# some arr ops
array(c('green','yellow'),c(2,4))

foo <- list(1,2,3)
foo <- append(foo,4)

foo <- list(1,2,3)
foo <- foo[-1]

seq(1,4)
seq(-4,4,length=100)

# var
a <- 'foo'
a <- 2
a <- 3
3 -> a
g <<- 3 # global assignment
3 ->> g

# cond
if () {}
if () {} else if () {}
if () {} else if () {} else {}

# loop
for (i in 1:20) {
	if (i %% 2 == 0) { next }
	if (i == 17) { break }
  print(i)
}

i <- 0
while (i < 20) {
	i <- i + 1
	print(i)
	if (i %% 2 == 0) { next }
	if (i == 17) { break }
}

# fn
myfn <- function(a, b=25, name='john') {
	num <- a * b
	res <- paste(c(name, 'is', num, 'years old'), collapse=' ')
	return(res)
}


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  Reduce("+", lapply(strsplit(s, "")[[1]], as.integer))
}), sep="\n")


impute.matrix <- function(x, FUN=function(x) rowMeans(x, na.rm=T)) {
    ##idx <- which(is.na(x), arr.ind=T)
    ## the line above causes a 'long vectors not supported yet' error
    ## when x contains more elements the .Machine$integer.max
    ## the following 5 lines allows x to be much larger without generating this error
    idx <- lapply(1:ncol(x), function(i) {
        idx <- which(is.na(x[,i]))
        cbind(row=idx, col=rep(i,length(idx)))
    })
    idx <- do.call(rbind, idx)

    if (length(idx) > 0) {
        v <- FUN(x)
        v[which(is.na(v))] <- FUN(matrix(v, nrow=1))
        x[idx] <- v[idx[,"row"]]
    }
    x
}


subroutine rqfnb(n,p,a,y,rhs,d,u,beta,eps,wn,wp,nit,info)
integer n,p,info,nit(3)
double precision a(p,n),y(n),rhs(p),d(n),u(n),wn(n,9),wp(p,p+3)
double precision one,beta,eps
parameter( one = 1.0d0)
call lpfnb(n,p,a,y,rhs,d,u,beta,eps,wn(1,1),wn(1,2),
        wp(1,1),wn(1,3),wn(1,4),wn(1,5),wn(1,6),
        wp(1,2),wn(1,7),wn(1,8),wn(1,9),wp(1,3),wp(1,4),nit,info)
return
end
# This is a revised form of my primal-dual log barrier form of the
# interior point LP solver based on Lustig, Marsten and Shanno ORSA J Opt 1992.
# It is a projected Newton primal-dual logarithmic barrier method which uses
# the predictor-corrector approach of Mehrotra for the mu steps.
# For the sake of brevity we will call it a Frisch-Newton algorithm.
# Problem:
# 	min c'x s.t. Ax=b, 0<=x<=u
#
# Denote dx,dy,dw,ds,dz as the steps for the respective variables x,y,w,s,z
#
subroutine lpfnb(n,p,a,c,b,d,u,beta,eps,x,s,y,z,w,
	dx,ds,dy,dz,dw,dr,rhs,ada,nit,info)

integer n,p,pp,i,info,nit(3),maxit
double precision a(p,n),c(n),b(p)
double precision zero,one,mone,big,ddot,dmax1,dmin1,dxdz,dsdw
double precision deltap,deltad,beta,eps,mu,gap,g
double precision x(n),u(n),s(n),y(p),z(n),w(n),d(n),rhs(p),ada(p,p)
double precision dx(n),ds(n),dy(p),dz(n),dw(n),dr(n)

parameter( zero  = 0.0d0)
parameter( one   = 1.0d0)
parameter( mone  = -1.0d0)
parameter( big  = 1.0d+20)
parameter( maxit  = 500)

# Initialization:  We follow the notation of LMS
# On input we require:
#
# 	c = n-vector of marginal costs (-y in the rq problem)
# 	a = p by n matrix of linear constraints (x' in rq)
# 	b = p-vector of rhs ((1-tau)x'e in rq)
#       u = upper bound vector ( e in rq)
# 	beta = barrier parameter, LMS recommend .99995
# 	eps = convergence tolerance, LMS recommend 10d-8
#
# 	the integer vector nit returns iteration counts
# 	the integer info contains an error code from the Cholesky in stepy
# 		info = 0 is fine
# 		info < 0 invalid argument to dposv
# 		info > 0 singular matrix
nit(1)=0
nit(2)=0
nit(3)=n
pp=p*p
# Start at the OLS estimate for the dual vector y
call dgemv('N',p,n,one,a,p,c,1,zero,y,1)
do i=1,n
	d(i)=one
call stepy(n,p,a,d,y,ada,info)
if(info != 0) return
# put current residual vector in s (temporarily)
call dcopy(n,c,1,s,1)
call dgemv('T',p,n,mone,a,p,y,1,one,s,1)
# Initialize remaining variables
do i=1,n{
	if(dabs(s(i))<eps){
		z(i)=dmax1(s(i), zero) + eps
		w(i)=dmax1(-s(i),zero) + eps
		}
	else {
		z(i)=dmax1(s(i), zero)
		w(i)=dmax1(-s(i),zero)
		}
	s(i)=u(i)-x(i)
	}
gap = ddot(n,z,1,x,1)+ddot(n,w,1,s,1)
while(gap > eps && nit(1)<maxit) {
	nit(1)=nit(1)+1
	do i = 1,n{
		d(i) = one/(z(i)/x(i) + w(i)/s(i))
		ds(i)=z(i)-w(i)
		dz(i)=d(i)*ds(i)
		}
	call dcopy(p,b,1,dy,1)#save rhs
	call dgemv('N',p,n,mone,a,p,x,1,one,dy,1)
	call dgemv('N',p,n,one,a,p,dz,1,one,dy,1)
	call dcopy(p,dy,1,rhs,1)#save rhs
	call stepy(n,p,a,d,dy,ada,info)
	if(info != 0) return
	call dgemv('T',p,n,one,a,p,dy,1,mone,ds,1) #ds -> A'dy - ds
	deltap=big
	deltad=big
	do i=1,n{
		dx(i)=d(i)*ds(i)
		ds(i)=-dx(i)
		dz(i)=-z(i)*(dx(i)/x(i) + one)
		dw(i)=-w(i)*(ds(i)/s(i) + one)
		if(dx(i)<0)deltap=dmin1(deltap,-x(i)/dx(i))
		if(ds(i)<0)deltap=dmin1(deltap,-s(i)/ds(i))
		if(dz(i)<0)deltad=dmin1(deltad,-z(i)/dz(i))
		if(dw(i)<0)deltad=dmin1(deltad,-w(i)/dw(i))
		}
	deltap=dmin1(beta*deltap,one)
	deltad=dmin1(beta*deltad,one)
	if(min(deltap,deltad) < one){
		nit(2)=nit(2)+1
		# Update mu
		mu = ddot(n,x,1,z,1)+ddot(n,s,1,w,1)
		g = mu + deltap*ddot(n,dx,1,z,1)+
			deltad*ddot(n,dz,1,x,1) +
			deltap*deltad*ddot(n,dz,1,dx,1)+
			deltap*ddot(n,ds,1,w,1)+
			deltad*ddot(n,dw,1,s,1) +
			deltap*deltad*ddot(n,ds,1,dw,1)
		mu = mu * ((g/mu)**3) /dfloat(2*n)
		# Compute modified step
		do i=1,n{
			dr(i)=d(i)*(mu*(1/s(i)-1/x(i))+
				dx(i)*dz(i)/x(i)-ds(i)*dw(i)/s(i))
			}
		call dswap(p,rhs,1,dy,1)
		call dgemv('N',p,n,one,a,p,dr,1,one,dy,1)# new rhs
		call dpotrs('U',p,1,ada,p,dy,p,info)# backsolve for dy
		call dgemv('T',p,n,one,a,p,dy,1,zero,u,1)#ds=A'ddy
		deltap=big
		deltad=big
		do i=1,n{
			dxdz =  dx(i)*dz(i)
			dsdw =  ds(i)*dw(i)
			dx(i)=  d(i)*(u(i)-z(i)+w(i))-dr(i)
			ds(i)= -dx(i)
			dz(i)= -z(i)+(mu - z(i)*dx(i) - dxdz)/x(i)
			dw(i)= -w(i)+(mu - w(i)*ds(i) - dsdw)/s(i)
			if(dx(i)<0)deltap=dmin1(deltap,-x(i)/dx(i))
			if(ds(i)<0)deltap=dmin1(deltap,-s(i)/ds(i))
			if(dz(i)<0)deltad=dmin1(deltad,-z(i)/dz(i))
			if(dw(i)<0)deltad=dmin1(deltad,-w(i)/dw(i))
			}
		deltap=dmin1(beta*deltap,one)
		deltad=dmin1(beta*deltad,one)
		}
	call daxpy(n,deltap,dx,1,x,1)
	call daxpy(n,deltap,ds,1,s,1)
	call daxpy(p,deltad,dy,1,y,1)
	call daxpy(n,deltad,dz,1,z,1)
	call daxpy(n,deltad,dw,1,w,1)
	gap = ddot(n,z,1,x,1)+ddot(n,w,1,s,1)
	}
# return residuals in the vector x
call daxpy(n,mone,w,1,z,1)
call dswap(n,z,1,x,1)
return
end
subroutine stepy(n,p,a,d,b,ada,info)
integer n,p,pp,i,info
double precision a(p,n),b(p),d(n),ada(p,p),zero
parameter( zero = 0.0d0)
# Solve the linear system ada'x=b by Choleski -- d is diagonal
# Note that a isn't altered, and on output ada returns the upper
# triangle Choleski factor, which can be reused, eg with blas dtrtrs
pp=p*p
do j=1,p
	do k=1,p
		ada(j,k)=zero
do i=1,n
	call dsyr('U',p,d(i),a(1,i),1,ada,p)
call dposv('U',p,1,ada,p,b,p,info)
return
end


#!/usr/bin/env Rscript
# Example: gene_level_burden_test.r /nfs/research/birney/projects/association/gene_burden/genotypes/mask1_pLoF_canonical_rare_v1/ukb23156.mask1.c22.gene_burden.tsv /nfs/research/birney/users/tomas/gene_modules/cleaned_and_linked_phenotypes/cancer_ukb_f_id_40009_EFO_0000311-8.txt quant ukb23156.mask1.c22.cancer_ukb_f_id_40009_EFO_0000311-8.tsv
args = commandArgs(trailingOnly=TRUE)

library(data.table)
library(foreach)
library(parallel)

## Helper function
# RankNorm() from package RNOmni
RankNorm <- function (u, k = 0.375)
{
  if (!is.vector(u)) {
    stop("A numeric vector is expected for u.")
  }
  if ((k < 0) || (k > 0.5)) {
    stop("Select the offset within the interval (0,0.5).")
  }
  if (sum(is.na(u)) > 0) {
    stop("Please exclude observations with missing measurements.")
  }
  n <- length(u)
  r <- rank(u)
  out <- qnorm((r - k)/(n - 2 * k + 1))
  return(out)
}

## Input
# covar <- fread('/nfs/research/birney/projects/association/gene_burden/covariates//ukbb_200k_covar_v1.csv')
covar <- fread(args[1], header=T)

# geno <- fread('/nfs/research/birney/projects/association/gene_burden/genotypes/mask1_pLoF_canonical_rare_v1/ukb23156.mask1.c22.gene_burden.tsv', header=T)
geno <-  fread(args[2], header=T)
setnames(geno, 1, 'Gene') # The first one must be 'Gene'

# pheno <- fread('/nfs/research/birney/users/tomas/gene_modules/cleaned_and_linked_phenotypes/cancer_ukb_f_id_40009_EFO_0000311-8.txt', header=T, col.names = c('eid', 'y'))
pheno <- fread(args[3], header=T, col.names = c('eid', 'y'))

# dtype <- 'quant' or 'binary'
dtype <- args[4]

out <- args[5]

pheno <- merge(pheno, covar, by='eid')
pheno[, eid:=as.character(eid)]
setkey(pheno, eid)

keep <- intersect(pheno$eid, colnames(geno))
pheno <- pheno[keep, ]

## Subsampling for binary to 1:99 case:control
if (dtype == 'binary') {
    n_case <- pheno[y==1, .N]
    n_ctrl <- pheno[y==0, .N]
    if (n_ctrl/n_case > 99) {
        set.seed(1993)
        max_ctrl <- n_case * 99
        keep <- c(pheno[y==1, eid], pheno[y==0, sample(eid, max_ctrl)])
        pheno <- pheno[keep, ]
    }
}

print(length(keep)) # No. of samples used

## Normalize y for quant
if (dtype == 'quant') pheno[, y:=RankNorm(y)]

geno_keep = as.matrix(geno[, -1])[,keep]
rownames(geno_keep) <- geno$Gene

# Run test in parallel
cl <- parallel::makeForkCluster(8)
doParallel::registerDoParallel(cl)

# loop over genes
res <- foreach(g=geno$Gene, .combine='rbind') %dopar% {
    pheno[, x:=geno_keep[g, ]]
    hom_ref_count = pheno[x==0, .N]
    het_alt_count = pheno[x==1, .N]
    hom_alt_count = pheno[x==2, .N]
    if (dtype == 'quant') fit <- lm(data = pheno[, -1], formula = y ~ .)
    if (dtype == 'binary') fit <- glm(data = pheno[, -1], formula = y ~ ., family = 'binomial')
    coef_tb <- coef(summary(fit))
    if ('x' %in% rownames(coef_tb)) {
        c(g, coef_tb['x', ], hom_ref_count, het_alt_count, hom_alt_count)
    } else {
        c(g, rep(NA, 4), hom_ref_count, het_alt_count, hom_alt_count)
    }
}

res = setDT(as.data.frame(res))
colnames(res) = c('Gene', 'EST', 'SE', 'T', 'P', 'HOM_REF', 'HET_ALT', 'HOM_ALT')

fwrite(res, out, sep='\t')

parallel::stopCluster(cl)