# ADZES
# - Main script to perform morphometric analysis on adzes (only)

# LIBRARIES ====================================================================
library(Momocs)
library(tidyverse)
library(stringr)
library(gridExtra)
library(grid)
library(xtable)

# INPUT ========================================================================
inNProf <- list.files("Morpho/Adze/ProfileAll/", full.names = TRUE)
inNSide <- list.files("Morpho/Adze/SideView/", full.names = TRUE)
inNTop <- list.files("Morpho/Adze/TopView/", full.names = TRUE)

inProf <- import_jpg(
  jpg.path = inNProf,
  auto.notcentered = TRUE,
  threshold = 0.5,
  verbose = TRUE
)
inSide <- import_jpg(
  jpg.path = inNSide,
  auto.notcentered = TRUE,
  threshold = 0.5,
  verbose = TRUE
)
inTop <- import_jpg(
  jpg.path = inNTop,
  auto.notcentered = TRUE,
  threshold = 0.5,
  verbose = TRUE
)

# Clean mem
rm(list = "inNProf", "inNSide", "inNTop")
rm(list = "inNPA", "inNSA", "inNTA")

# Save import data
save(inProf, file = "./Archive/Adzes/Dt.inProf")
save(inSide, file = "./Archive/Adzes/Dt.inSide")
save(inTop, file = "./Archive/Adzes/Dt.inTop")

# Fac slot data
prime <- read_csv("../Db.PRIME.csv")
secon <- select(prime, -Lokalita, -Note, -Ident)
secon <- secon %>% filter(Morph == "Ad") %>% select(-Include)

# Mutate Cult + Dat
secon <- secon %>%
  mutate(CultDat = paste(Cult, Dat, sep = " "))
# String to edit CultDat
secon$CultDat <-
  str_replace(secon$CultDat, pattern = "(.*) NA", replacement = "\\1")

# secon$Lok <- as.factor(secon$Lok)
# secon$Orig <- as.factor(secon$Orig)
# secon$Cult <- as.factor(secon$Cult)
# secon$Dat <- as.factor(secon$Dat)
# secon$RM <- as.factor(secon$RM)
# secon$Morph <- as.factor(secon$Morph)
# secon$OpSeq <- as.factor(secon$OpSeq)
# secon$SalVar <- as.factor(secon$SalVar)
# secon$SalProfVys <- as.factor(secon$SalProfVys)
# secon$SalProfTvar <- as.factor(secon$SalProfTvar)
# secon$SalTylBok <- as.factor(secon$SalTylBok)
# secon$StUpev <- as.factor(secon$StUpev)
# secon$StPrac <- as.factor(secon$StPrac)
# secon$Pouzitelnost <- as.factor(secon$Pouzitelnost)
# secon$Half <- as.factor(secon$Half)
# secon$CultDat <- as.factor(secon$CultDat)

facProf <- filter(secon, Prof == TRUE) %>% select(-(Top:Prof))
facSide <- filter(secon, Side == TRUE) %>% select(-(Top:Prof))
facTop <- filter(secon, Top == TRUE) %>% select(-(Top:Prof))

facProf <- arrange(facProf, ID)
facSide <- arrange(facSide, ID)
facTop <- arrange(facTop, ID)

colsToFac <- c("Lok", "Orig", "Cult", "Dat", "CultDat", "RM", "Morph", "OpSeq",
               "SalVar", "SalProfVys", "SalProfTvar", "SalTylBok",
               "StUpev", "StPrac", "Pouzitelnost", "Half")

facProf %<>%
  mutate_at(funs(factor(.)), .vars =  colsToFac)

facSide %<>%
  mutate_at(funs(factor(.)), .vars =  colsToFac)

facTop %<>%
  mutate_at(funs(factor(.)), .vars =  colsToFac)

detach("package:tidyverse", unload = TRUE)
detach("package:stringr", unload = TRUE)

# t-test korelace stop
StPrac <- secon$StPrac
StUpev <- secon$StUpev
St <- data.frame(StPrac, StUpev)
StPracN <- as.numeric(St$StPrac)
StUpevN <- as.numeric(St$StUpev)
StN <- data.frame(StPracN, StUpevN)
t.test(StN)
rcorr(as.matrix(StN))

# korelace cultDat a profVys
# CultDat <- as.numeric(factor(secon$CultDat))
# ProfVys <- as.numeric(factor(secon$SalProfVys))
# cor.test(CultDat, ProfVys)

# MORPHOMETRICS ================================================================
# Outlines ---------------------------------------------------------------------
outProf <- Out(inProf, fac = facProf)
outSide <- Out(inSide, fac = facSide)
outTop <- Out(inTop, fac = facTop)

# Check whether outlines fit with fac!
panel(outProf, fac = "Orig", names = TRUE)
panel(outSide, fac = "Orig", names = TRUE)
panel(outTop, fac = "Orig", names = TRUE)

# Clean mem.
rm(list = "prime", "secon")
rm(list = "facProf", "facSide", "facTop")
rm(list = "inProf", "inSide", "inTop")

# Save
save(outProf, file = "./Archive/Adzes/Dt.outProf")
save(outSide, file = "./Archive/Adzes/Dt.outSide")
save(outTop, file = "./Archive/Adzes/Dt.outTop")

load(file = "./Archive/Adzes/Dt.outProf")
load(file = "./Archive/Adzes/Dt.outSide")
load(file = "./Archive/Adzes/Dt.outTop")

# Manipulate -------------------------------------------------------------------
manProf <- outProf %>%
  coo_slidedirection("N") %>%
  coo_center() %>%
  coo_smooth(50) %>%
  coo_sample(200)

manSide <- outSide %>%
  coo_alignxax() %>%
  coo_slidedirection("W") %>%
  coo_center() %>%
  coo_smooth(200) %>%
  coo_sample(400)

manTop <- outTop %>%
  coo_alignxax() %>%
  coo_slidedirection("W") %>%
  coo_center() %>%
  coo_smooth(200) %>%
  coo_sample(400)

# # Calibrating harmonics ------------------------------------------------------
# # Profile
# # devProf <- calibrate_deviations(manProf, method = "efourier")
# harmProf <- calibrate_harmonicpower(manProf, method = "efourier",
#                                     nb.h = 12, plot = TRUE)
# pdf("./Adzes/panelHarmProf.pdf")
# calibrate_reconstructions(manProf, "efourier", id = 30, range = 1:12)
# dev.off()
#
# # Side
# # devSide <- calibrate_deviations(manSide, method = "efourier")
# harmSide <- calibrate_harmonicpower(manSide, method = "efourier",
#                                     nb.h = 16, plot = TRUE)
# pdf("./Adzes/panelHarmSide.pdf", width = 7, height = 3)
# calibrate_reconstructions(manSide, "efourier", id = 23, range = 1:16)
# dev.off()
#
# # Top
# # devTop <- calibrate_deviations(manTop, method = "efourier")
# harmTop <- calibrate_harmonicpower(manTop, method = "efourier",
#                                    nb.h = 12, plot = TRUE)
# pdf("./Adzes/panelHarmTop.pdf", width = 7, height = 2.5)
# calibrate_reconstructions(manTop, "efourier", id = 17, range = 1:12)
# dev.off()
#
# # rm(list = "devProf", "devSide", "devTop")
#
# # Exporting table with harmonic power to Latex
# harmonicPower <- rbind(harmProf$minh, harmSide$minh, harmTop$minh)
# row.names(harmonicPower) <- c("Profile", "Side", "Top")
# harmonicPower <- xtable(harmonicPower,
#                  caption = "Příspěvek harmonických proměnných k popisu tvaru")
# print(harmonicPower, file = "./Adzes/Tab.HarmPow.tex",
#       booktabs = T, caption.placement = "top")
# #
# # rm(list = "harmonicPower", "harmProf", "harmSide", "harmTop")

# Elliptical Fourier Transform -------------------------------------------------
efProf <- efourier(
  manProf,
  nb.h = 10,
  norm = FALSE,
  smooth.it = 0,
  start = FALSE,
  verbose = TRUE
)
efSide <- efourier(
  manSide,
  nb.h = 12,
  norm = F,
  smooth.it = 0,
  start = FALSE,
  verbose = TRUE
)
efTop <- efourier(
  manTop,
  nb.h = 10,
  norm = F,
  smooth.it = 0,
  start = FALSE,
  verbose = TRUE
)

# Save and clean memory
save(efProf, file = "./Archive/Adzes/Dt.efProf")
save(efSide, file = "./Archive/Adzes/Dt.efSide")
save(efTop, file = "./Archive/Adzes/Dt.efTop")

load("./Archive/Adzes/Dt.efProf")
load("./Archive/Adzes/Dt.efSide")
load("./Archive/Adzes/Dt.efTop")

# ANALYSIS =====================================================================
# Symmetry ---------------------------------------------------------------------
# - rm_sym/rm_asym works only for Prof, why? or does it?
# hokuspokus <- rm_sym(efProf)
# panel(hokuspokus)
# panel(efProf)

symProf <- symmetry(efProf)
symSide <- symmetry(efSide)
symTop <- symmetry(efTop)

# hSymProf <- qplot(symProf[, "sym"],
# xlab = "(a) sym (Prof)", ylab = "frequency") +
# stat_bin(bins = 10, fill = "white", color = "black") + theme_bw()

# hSymSide <- qplot(symSide[, "sym"],
# xlab = "(b) sym (Side)", ylab = "frequency") +
# stat_bin(bins = 10, fill = "white", color = "black") + theme_bw()

# hSymTop <- qplot(symTop[, "sym"],
# xlab = "(c) sym (Top)", ylab = "frequency") +
# stat_bin(bins = 10, fill = "white", color = "black") + theme_bw()

pdf(file = "./Adzes/Symmetry.pdf",
    height = 2,
    width = 7)
layout(matrix(c(1, 2, 3), 1, 3, byrow = TRUE))
hist(
  symProf[, "sym"],
  xlab = "(a) sym (Prof)",
  ylab = "density",
  main = NA,
  freq = FALSE
)
hist(
  symSide[, "sym"],
  xlab = "(b) sym (Side)",
  ylab = "density",
  main = NA,
  freq = FALSE
)
hist(
  symTop[, "sym"],
  xlab = "(c) sym (Top)",
  ylab = "density",
  main = NA,
  freq = FALSE
)
# grid.arrange(hSymProf, hSymSide, hSymTop, nrow = 1)
dev.off()

# PCA ==========================================================================
pcProf <- PCA(efProf)
pcSide <- PCA(efSide)
pcTop <- PCA(efTop)

save(pcProf, file = "./Archive/Adzes/Dt.pcProf")
save(pcSide, file = "./Archive/Adzes/Dt.pcSide")
save(pcTop, file = "./Archive/Adzes/Dt.pcTop")

load("./Archive/Adzes/Dt.pcProf")
load("./Archive/Adzes/Dt.pcSide")
load("./Archive/Adzes/Dt.pcTop")

# # Scree plots
# scree(pcProf, 1:5)
# scree_min(pcProf, 0.98)
# sp <- scree_plot(pcProf, 1:4)
# pdf(file = "./Adzes/pcContribProf.pdf", height = 5)
# PCcontrib(pcProf,
#           nax = 1:3,
#           sd.r = c(-1.5,-1,-0.5, 0, 0.5, 1, 1.5))
# dev.off()
#
# scree(pcSide, 1:5)
# scree_min(pcSide, 0.98)
# ss <- scree_plot(pcSide, 1:5)
# pdf(file = "./Adzes/pcContribSide.pdf",
#     height = 2.5,
#     width = 10)
# PCcontrib(pcSide,
#           nax = 1:3,
#           sd.r = c(-1.5,-1,-0.5, 0, 0.5, 1, 1.5))
# dev.off()
#
# scree(pcTop, 1:5)
# scree_min(pcTop, 0.98)
# st <- scree_plot(pcTop, 1:4)
# pdf(file = "./Adzes/pcContribTop.pdf",
#     height = 2.5,
#     width = 10)
# PCcontrib(pcTop, nax = 1:3, sd.r = c(-1,-0.5, 0, 0.5, 1))
# dev.off()
#
# tp <- textGrob("(a) Prof (profil)")
# ts <- textGrob("(b) Side (bokorys)")
# tt <- textGrob("(c) Top (nárys)")
# lay <- rbind(c(1, 3, 5),
#              c(1, 3, 5),
#              c(1, 3, 5),
#              c(1, 3, 5),
#              c(1, 3, 5),
#              c(2, 4, 6))
#
# pdf(file = "./Adzes/screePlots.pdf",
#     width = 10,
#     height = 4)
# grid.arrange(sp, tp, ss, ts, st, tt, layout_matrix = lay)
# dev.off()
#
# rm(list = "sp", "ss", "st", "tp", "ts", "tt", "lay")

# Basic PCA plots --------------------------------------------------------------
pdf(
  file = "./Adzes/pcProf.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcProf,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 0.5,
  amp.shp = 0.9,
  pch = 4,
  center.origin = FALSE,
  zoom = 1.2,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

pdf(
  file = "./Adzes/pc2Prof.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcProf,
  xax = 2,
  yax = 3,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 0.5,
  amp.shp = 0.9,
  pch = 4,
  center.origin = FALSE,
  zoom = 1.2,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

pdf(
  file = "./Adzes/pcSide.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcSide,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 1,
  amp.shp = 0.9,
  flipx.shp = F,
  flipy.shp = T,
  pch = 4,
  center.origin = F,
  zoom = 1.6,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

pdf(
  file = "./Adzes/pc2Side.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcSide,
  xax = 2,
  yax = 3,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 1,
  amp.shp = 0.9,
  flipx.shp = F,
  flipy.shp = T,
  pch = 4,
  center.origin = T,
  zoom = 1.4,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

pdf(
  file = "./Adzes/pcTop.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcTop,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 0.8,
  amp.shp = 0.6,
  pch = 4,
  center.origin = F,
  zoom = 1.4,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

pdf(
  file = "./Adzes/pc2Top.pdf",
  paper = "a4r",
  width = 12,
  height = 8
)
plot(
  pcTop,
  xax = 2,
  yax = 3,
  points = TRUE,
  morphospace = TRUE,
  pos.shp = "xy",
  size.shp = 1,
  amp.shp = 0.8,
  pch = 4,
  center.origin = TRUE,
  zoom = 1,
  density = T,
  contour = F,
  axisvar = T,
  box = TRUE,
  cex.labelsgroups = 2
)
dev.off()

# PCA 3 plots ------------------------------------------------------------------
# color palettes (see color brewer)
pal2 <- c("#e41a1c", "#33a02c")
pal3 <- c("#377eb8", "#33a02c", "#e41a1c")
palN <- c("#e41a1c", "gray50", "#33a02c")
palN3 <- c("gray50", "#33a02c", "#e41a1c") ##377eb8
palN2 <- c("#33a02c", "#e41a1c", "gray50")
pal4 <- c("#377eb8", "#33a02c", "#e41a1c", "gray50")

# pca3Plot <- function(pcaSlot, facSlot) {
#   plot3(pcaSlot, fac = facSlot,
#         size.shp = 0.5, amp.shp = 0.8, pch = c(15, 4, 19),
#         morphospace = T, pos.shp = "range_axes",
#         chull = T, chull.filled = T, chull.lty = 0,
#         ellipses = F,
#         labelsgroups = TRUE, abbreviate.labelsgroups = TRUE)
# }

# Stopy
pdf(file = "./Obr/pc3-Top_StUpev.pdf")
plot3(
  pcTop,
  fac = "StUpev",
  size.shp = 1,
  amp.shp = 1,
  col = palN3,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  zoom = 1.2,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Adzes/pc3-Top_StPrac.pdf")
plot3(
  pcTop,
  fac = "StPrac",
  size.shp = 1,
  amp.shp = 1,
  col = palN,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  zoom = 1.2,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Obr/pc3-Side_StUpev.pdf")
plot3(
  pcSide,
  fac = "StUpev",
  size.shp = 1,
  amp.shp = 1,
  col = palN3,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE,
  flipx.shp = T,
  zoom = 1.2
)
dev.off()

pdf(file = "./Adzes/pc3-Side_StPrac.pdf")
plot3(
  pcSide,
  fac = "StPrac",
  size.shp = 1,
  amp.shp = 1,
  col = palN,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE,
  flipx.shp = T,
  zoom = 1.2
)
dev.off()

# plot3(pcProf, fac = "Half",
#      size.shp = 0.5, amp.shp = 0.8, col = pal2, pch = c(4, 19),
#      morphospace = T, pos.shp = "range_axes",
#      chull = T, chull.filled = T, chull.lty = 0,
#      ellipses = F,
#      labelsgroups = TRUE, abbreviate.labelsgroups = TRUE)

# SalVar
pdf(file = "./Adzes/pc3-Prof_SalProfVys.pdf")
plot3(
  pcProf,
  fac = "SalProfVys",
  size.shp = 1,
  amp.shp = 1,
  col = pal3,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  zoom = 1,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Obr/pc3-Prof_SalProfTvar.pdf")
plot3(
  pcProf,
  fac = "SalProfTvar",
  size.shp = 1,
  amp.shp = 1,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  zoom = 1,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Obr/pc3-Side_SalTylBok.pdf")
plot3(
  pcSide,
  fac = "SalTylBok",
  size.shp = 1,
  amp.shp = 1,
  pch = c(15, 4, 19),
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  zoom = 1.3,
  flipx.shp = T,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

# Orig
pdf(file = "./Adzes/pc3-Prof_Orig.pdf")
plot3(
  pcProf,
  fac = "Orig",
  size.shp = 0.5,
  amp.shp = 0.8,
  col = pal3,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Adzes/pc3-Side_Orig.pdf")
plot3(
  pcSide,
  fac = "Orig",
  size.shp = 0.5,
  amp.shp = 0.8,
  col = pal3,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

pdf(file = "./Adzes/pc3-Top_Orig.pdf")
plot3(
  pcTop,
  fac = "Orig",
  size.shp = 0.5,
  amp.shp = 0.8,
  col = pal3,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = TRUE
)
dev.off()

plot(
  pcProf,
  fac = "CultDat",
  size.shp = 0.5,
  amp.shp = 0.8,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
  abbreviate.labelsgroups = F
)

plot(
  pcSide,
  fac = "CultDat",
  size.shp = 0.5,
  amp.shp = 0.8,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
)

plot(
  pcTop,
  fac = "CultDat",
  size.shp = 0.5,
  amp.shp = 0.8,
  pch = 4,
  morphospace = T,
  pos.shp = "range_axes",
  chull = T,
  chull.filled = T,
  chull.lty = 0,
  ellipses = F,
  labelsgroups = TRUE,
)

# Clustering ===================================================================
# Count number of clusters K and perform kmeans clustering
# - elbow method (wss - within-clusters sum of squares)
# - stolen and modified from rbloggers (DataScience+, by Sunny Anand)
k.max <- 8

# Prof
wssProf <- sapply(1:k.max,
                  function(k) {
                    kmeans(pcProf$x, k, nstart = 50,
                           iter.max = 15)$tot.withinss
                  })

plot(
  1:k.max,
  wssProf,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Prof)",
  ylab = "Total within-clusters sum of squares"
)

# Side
wssSide <- sapply(1:k.max,
                  function(k) {
                    kmeans(pcSide$x, k, nstart = 50,
                           iter.max = 15)$tot.withinss
                  })

plot(
  1:k.max,
  wssSide,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Side)",
  ylab = "Total within-clusters sum of squares"
)

# Top
wssTop <- sapply(1:k.max,
                 function(k) {
                   kmeans(pcTop$x, k, nstart = 50,
                          iter.max = 15)$tot.withinss
                 })

plot(
  1:k.max,
  wssTop,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Top)",
  ylab = "Total within-clusters sum of squares"
)

# grid arrange
pdf(file = "./Adzes/elbow.pdf",
    width = 10,
    height = 4)
layout(matrix(c(1, 2, 3), 1, 3, byrow = TRUE))
plot(
  1:k.max,
  wssProf,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Prof)",
  ylab = "Total within-clusters sum of squares"
)
plot(
  1:k.max,
  wssSide,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Side)",
  ylab = NA
)
plot(
  1:k.max,
  wssTop,
  type = "b",
  pch = 19,
  frame = FALSE,
  xlab = "Number of clusters K (Top)",
  ylab = NA
)
dev.off()

# K means clustering -----------------------------------------------------------
pdf(file = "./Adzes/kmeansProf.pdf")
KMEANS(pcProf, 3)
dev.off()

pdf(file = "./Obr/kmeansSide.pdf")
KMEANS(pcSide, 2)
dev.off()

pdf(file = "./Obr/kmeansTop.pdf")
KMEANS(pcTop, 2)
dev.off()

# VedTop <- filter(pcTop, pcTop$fac$Lok == "Ved")
# KMEANS(VedTop, 2)

# Hierarchical clustering ------------------------------------------------------
# CLUST(
#   pcTop,
#   fac = "StPrac",
#   type = "phylogram",
#   hclust_method = "ward.D2",
#   tip_labels = "StPrac"
# )
# CLUST(
#   pcSide,
#   fac = "SalTylBok",
#   type = "phylogram",
#   hclust_method = "ward.D2",
#   tip_labels = "SalTylBok"
# )
# CLUST(
#   pcTop,
#   fac = "RM",
#   type = "phylogram",
#   hclust_method = "ward.D2",
#   tip_labels = "RM"
# )

# Linear dicriminant analysis ==================================================
load("./Archive/Adzes/Dt.efProf")
load("./Archive/Adzes/Dt.efSide")
load("./Archive/Adzes/Dt.efTop")

funLDA <- function(efSLot, facSlot, view) {
  plot(LDA(efSLot, fac = facSlot),
       chull.filled = TRUE,
       ellipsesax = FALSE,
       title = sprintf("Linear discriminant analysis (%s: %s)", view, facSlot))
}

pdf(file = "./Adzes/ldaProf_Vys.pdf")
funLDA(efProf, "SalProfVys", "Prof")
dev.off()

pdf(file = "./Adzes/ldaProf_Tvar.pdf")
#funLDA(efProf, "SalProfTvar", "Prof")
plot(LDA(efProf, fac = "SalProfTvar"), zoom = 2.4,
     chull.filled = TRUE,
     ellipsesax = FALSE,
     title = ("Linear discriminant analysis (Prof: Tvar)"))
dev.off()

pdf(file = "./Adzes/ldaSide_Bok.pdf")
#funLDA(efSide, "SalTylBok", "Side")
plot(LDA(efSide, fac = "SalTylBok"), zoom = 4.5,
     chull.filled = TRUE,
     ellipsesax = FALSE,
     title = ("Linear discriminant analysis (Side: Tyl)"))
dev.off()

pdf(file = "./Adzes/ldaTop_StUpev.pdf")
funLDA(efTop, "StUpev", "Top")
dev.off()
pdf(file = "./Adzes/ldaTop_StPrac.pdf")
funLDA(efTop, "StPrac", "Top")
dev.off()
pdf(file = "./Adzes/ldaSide_StUpev.pdf")
funLDA(efSide, "StUpev", "Side")
dev.off()
pdf(file = "./Adzes/ldaSide_StPrac.pdf")
funLDA(efSide, "StPrac", "Side")
dev.off()

pdf(file = "./Adzes/ldaProf_Orig.pdf")
funLDA(efProf, "Orig", "Prof")
dev.off()
pdf(file = "./Adzes/ldaSide_Orig.pdf")
funLDA(efSide, "Orig", "Side")
dev.off()
pdf(file = "./Adzes/ldaTop_Orig.pdf")
funLDA(efTop, "Orig", "Top")
dev.off()

# Other
# - it is possible to distinguish Lbk I vs II in Top view thanks to LDA
plot3(PCA(efTop), fac = "CultDat")
funLDA(efTop, "CultDat", "Top")

# - same for OpSeq in Side and Top views
funLDA(efProf, "OpSeq", "Prof")

pdf(file = "./Adzes/ldaSide_OpSeq.pdf")
funLDA(efSide, "OpSeq", "Side")
dev.off()

pdf(file = "./Adzes/ldaTop_OpSeq.pdf")
funLDA(efTop, "OpSeq", "Top")
dev.off()

# MANOVA =======================================================================
load("./Archive/Adzes/Dt.pcProf")
load("./Archive/Adzes/Dt.pcSide")
load("./Archive/Adzes/Dt.pcTop")

# Normality tests --------------------------------------------------------------
topStUpevT <- filter(pcTop, StUpev == "T")
topStUpevF <- filter(pcTop, StUpev == "F")

topStPracT <- filter(pcTop, StPrac == "T")
topStPracF <- filter(pcTop, StPrac == "F")

sideStUpevT <- filter(pcSide, StUpev == "T")
sideStUpevF <- filter(pcSide, StUpev == "F")

sideStPracT <- filter(pcSide, StPrac == "T")
sideStPracF <- filter(pcSide, StPrac == "F")

# Q-Q plot
# qqnorm(topStUpevT$x[, 1])
library(ggpubr)
library(mvnormtest)
# ggqqplot(pcTop$x[, 1])
# ggqqplot(pcSide$x[, 1])
# ggqqplot(pcTop$x[, 1])
#
# ggqqplot(pcTop$x[, 2])
# ggqqplot(pcSide$x[, 2])
# ggqqplot(pcTop$x[, 2])

ggqqplot(topStUpevT$x[, 1])
ggqqplot(topStUpevF$x[, 1])

ggqqplot(topStPracT$x[, 1])
ggqqplot(topStPracF$x[, 1])

ggqqplot(sideStUpevT$x[, 1])
ggqqplot(sideStUpevF$x[, 1])

ggqqplot(sideStPracT$x[, 1])
ggqqplot(sideStPracF$x[, 1])

# Shapiro--Wilk normality test
# shapiro.test(pcTop$x[, 1])
# shapiro.test(pcSide$x[, 1])
#
# shapiro.test(pcTop$x[, 2])
# shapiro.test(pcSide$x[, 2])

shapiro.test(topStUpevT$x)
shapiro.test(topStUpevF$x)

shapiro.test(topStPracT$x)
shapiro.test(topStPracF$x)

shapiro.test(sideStUpevT$x)
shapiro.test(sideStUpevF$x)

shapiro.test(topStPracT$x)
shapiro.test(topStPracF$x)

# Tests of homogeneity of variances
# - Bartlett for Top ~StUpev, ~StPrac; pc1:pc2
bartlett.test(pcTop$x[, 1], pcTop$fac$StUpev) # rejected
bartlett.test(pcTop$x[, 2], pcTop$fac$StUpev) # not

bartlett.test(pcTop$x[, 1], pcTop$fac$StPrac) # not
bartlett.test(pcTop$x[, 2], pcTop$fac$StPrac) # not

# - Fligner-Killeen for Top ~StUpev, ~StPrac; pc1:pc2
fligner.test(pcTop$x[, 1], pcTop$fac$StUpev) # not
fligner.test(pcTop$x[, 2], pcTop$fac$StUpev) # not

fligner.test(pcTop$x[, 1], pcTop$fac$StPrac) # not
fligner.test(pcTop$x[, 2], pcTop$fac$StPrac) # not

# - Bartlett for Side ~StUpev, ~StPrac; pc1:pc2
bartlett.test(pcSide$x[, 1], pcSide$fac$StPrac) # not
bartlett.test(pcSide$x[, 2], pcSide$fac$StPrac) # not

bartlett.test(pcSide$x[, 1], pcSide$fac$StUpev) # rejected
bartlett.test(pcSide$x[, 2], pcSide$fac$StUpev) # not

# - Fligner-Killeen for Side ~StUpev, ~StPrac; pc1:pc2
fligner.test(pcSide$x[, 1], pcSide$fac$StUpev) # not
fligner.test(pcSide$x[, 2], pcSide$fac$StUpev) # not

fligner.test(pcSide$x[, 1], pcSide$fac$StPrac) # not
fligner.test(pcSide$x[, 2], pcSide$fac$StPrac) # not

bartlett.test(efTop$coe[, 1], efTop$fac$StUpev) # rejected

# vlastní MANOVA
MANOVA(pcProf, fac = "SalProfVys", retain = 0.99)
MANOVA(pcProf, fac = "SalProfTvar", retain = 0.99)
MANOVA(pcSide, fac = "SalTylBok", retain = 0.99)

MANOVA(pcSide, fac = "StPrac", retain = 0.99)
MANOVA(pcSide, fac = "StUpev", retain = 0.99)

MANOVA(pcTop, fac = "StPrac", retain = 0.99)
MANOVA(pcTop, fac = "StUpev", retain = 0.99)

MANOVA(pcTop, fac = "Orig", retain = 0.99)
MANOVA(pcTop, fac = "CultDat", retain = 0.99)
MANOVA(pcSide, fac = "Orig", retain = 0.99)
MANOVA(pcSide, fac = "CultDat", retain = 0.99)
MANOVA(pcProf, fac = "Orig", retain = 0.99)
MANOVA(pcProf, fac = "CultDat", retain = 0.99)

MANOVA(pcTop, fac = "OpSeq")
MANOVA(pcSide, fac = "OpSeq")
MANOVA(pcProf, fac = "OpSeq")

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$StPrac) # * pcTop$fac$StUpev
summary(m)
summary.aov(m)

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$StUpev)
summary(m)
summary.aov(m)

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$CultDat)
summary(m)
summary.aov(m)

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$Orig)
summary(m)
summary.aov(m)

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$Orig)
summary(m)
summary.aov(m)

m <- manova(cbind(pcTop$x[, 1], pcSide$x[, 1]) ~ pcTop$fac$OpSeq)
summary(m)
summary.aov(m)

# m <- manova(cbind(pcProf$x[, 1:2], pcProf$x[, 1:2]) ~ pcProf$fac$SalProfVys) # * pcTop$fac$StUpev
# summary(m)
# summary.aov(m)
#
# m <- manova(pcSide$x[, 1:2] ~ pcSide$fac$SalTylBok) # * pcTop$fac$StUpev
# summary(m)
# summary.aov(m)

# Kruskal--Wallis test
# boxplot(sideStPracT$x[, 1], sideStPracF$x[, 1])
kruskal.test(pcTop$x[, 1], pcTop$fac$StPrac)
kruskal.test(pcSide$x[, 1], pcSide$fac$StPrac)
# kruskal.test(pcTop$x[, 2], pcTop$fac$StPrac)
# kruskal.test(pcSide$x[, 2], pcSide$fac$StPrac)

kruskal.test(pcTop$x[, 1], pcTop$fac$StUpev)
kruskal.test(pcSide$x[, 1], pcSide$fac$StUpev)
# kruskal.test(pcTop$x[, 2], pcTop$fac$StUpev)
# kruskal.test(pcSide$x[, 2], pcSide$fac$StUpev)

kruskal.test(pcSide$x[, 1], pcSide$fac$SalTylBok)
kruskal.test(pcProf$x[, 1], pcProf$fac$SalProfTvar)
kruskal.test(pcProf$x[, 1], pcProf$fac$SalProfVys)
kruskal.test(pcProf$x[, 2], pcProf$fac$SalProfTvar)
kruskal.test(pcProf$x[, 2], pcProf$fac$SalProfVys)

kruskal.test(pcSide$x[,1], pcSide$fac$CultDat)
kruskal.test(pcTop$x[,1], pcTop$fac$CultDat)
kruskal.test(pcProf$x[,1], pcProf$fac$CultDat)
kruskal.test(pcProf$x[,2], pcProf$fac$CultDat)

kruskal.test(pcSide$x[,1], pcSide$fac$Orig)
kruskal.test(pcTop$x[,1], pcTop$fac$Orig)
kruskal.test(pcProf$x[,1], pcProf$fac$Orig)
kruskal.test(pcProf$x[,2], pcProf$fac$Orig)

# END ==========================================================================
graphics.off()
rm(list = ls())
gc()
.rs.restartR()
q("no")


library(symphony)
library(anndata)

# .X should have unnormalized counts.
project_symphony <- function(adata_file, batch_col, query_names, dim=20)
{

  print("Reading data.")

  ad <- read_h5ad(adata_file)

  q_mask <- ad$obs[[batch_col]] %in% query_names

  ref_X <- t(ad$X[!q_mask,])
  query_X <- t(ad$X[q_mask,])

  ref_meta <- ad$obs[!q_mask,][batch_col]
  query_meta <- ad$obs[q_mask,][batch_col]

  print("Integrating reference:")
  print(unique(ref_meta[[1]]))

  reference <- buildReference(
      ref_X,
      ref_meta,
      vars = batch_col,
      K = 100,
      verbose = TRUE,
      do_umap = FALSE,
      do_normalize = TRUE,
      vargenes_method = 'vst',
      topn = ad$n_vars, # use all variables
      d = dim
  )

  print("Projecting query:")
  print(unique(query_meta[[1]]))

  query <- mapQuery(
      query_X,
      query_meta,
      reference,
      do_normalize = TRUE,
      do_umap = FALSE
  )

  latent <- t(cbind(reference[["Z_corr"]], query[["Z"]]))
  ad$obsm[["X_symphony"]] <- latent[ad$obs_names,]

  ad$write_h5ad(adata_file)

}


##test for R github

# use transformation database with each transformation assigned to be biotic or abiotic or unknown
# transformations will be parsed into biotic and abiotic groups
# then the relative contributions of those two groups will be calculated for each sample and ratio will, in turn, be calculated
# each sample should have 3 metrics: number of biotic transformations, number of abiotic transformations, and the ratio of those two
# those outcomes will then be combined with metadata, including spatial position and the basic climate variables previously extracted

#### start function to turn factors to character

fac.to.char.fun = function(matrix.in) {

  i = sapply(matrix.in,is.factor)
  matrix.in[i] = lapply(matrix.in[i],as.character)

  return(matrix.in)

}

# set the working directory
setwd("//PNL/Projects/ECA_Project/Biotic_Abiotic")

# read in the transformation database, take a look at the first few rows, and check the variable types
trans = fac.to.char.fun(read.csv("Biotic-abiotic-transfromation-classification.csv")); head(trans); str(trans)

unique(trans$Biotic.abiotic)

trans = trans [-which(is.na(trans$Biotic.abiotic)),]; head(trans)
trans$Biotic.abiotic = gsub(pattern = "Bitoic/abiotic",replacement = "Both",x = trans$Biotic.abiotic)

trans$Biotic.abiotic = gsub(pattern = "\\*", "", trans$Biotic.abiotic)
trans$Biotic.abiotic = gsub(pattern = "Biotic based on Kegg but we didn't use for the biotic/abiotic paper",replacement = "Biotic",x = trans$Biotic.abiotic)
unique(trans$Biotic.abiotic)

#read in transformation profiles
prof.tran = fac.to.char.fun(read.csv("S19S_Sed-Water_08.12_Trans_Profiles.csv")); prof.tran[1:5,1:5]; str(prof.tran)

#new matrix, sample name, abundance of transformation type, ratio
trans.comp = numeric()
for (samp.name in colnames(prof.tran)[grep(pattern = 'Sample',x = colnames(prof.tran))]) { # compute the abundances

  abiotic.abund = sum(prof.tran[which(prof.tran$Name %in% trans$Name[grep(pattern = 'Abiotic',x = trans$Biotic.abiotic)]  ),which(colnames(prof.tran) == samp.name)])

  biotic.abund = sum(prof.tran[which(prof.tran$Name %in% trans$Name[grep(pattern = 'Biotic',x = trans$Biotic.abiotic)]  ),which(colnames(prof.tran) == samp.name)])

  both.abund = sum(prof.tran[which(prof.tran$Name %in% trans$Name[grep(pattern = 'Both',x = trans$Biotic.abiotic)]  ),which(colnames(prof.tran) == samp.name)])

  trans.comp = rbind(trans.comp,c(samp.name,abiotic.abund,biotic.abund,both.abund))

}

# do some formatting
colnames(trans.comp) = c("Sample_ID","Abiotic.abund","Biotic.abund","Both.abund")
trans.comp = fac.to.char.fun(as.data.frame(trans.comp));
trans.comp$Abiotic.abund = as.numeric(trans.comp$Abiotic.abund)
trans.comp$Biotic.abund = as.numeric(trans.comp$Biotic.abund)
trans.comp$Both.abund = as.numeric(trans.comp$Both.abund)
str(trans.comp)

#cal ratios

trans.comp$Abiotic.to.Biotic = trans.comp$Abiotic.abund/trans.comp$Biotic.abund
trans.comp$Abiotic.to.Both = trans.comp$Abiotic.abund/trans.comp$Both.abund
trans.comp$Biotic.to.Both = trans.comp$Biotic.abund/trans.comp$Both.abund

head(trans.comp)

# write out the file
write.csv(x = trans.comp,file = "trans_variables.csv", quote = F, row.names = F)

#analysis
pdf("abiotic_to_biotic_hist.pdf")
hist(trans.comp$Abiotic.to.Biotic, breaks = 50)
dev.off()
#hist(log10(trans.comp$Abiotic.to.Biotic))
#hist(trans.comp$Abiotic.to.Both, breaks = 50)
#hist(trans.comp$Biotic.to.Both, breaks = 50)


source("colorRamps.R")

col.map <- blue2red(1024)
col.pop <- c("#E41A1C","#377EB8","#4DAF4A","#984EA3","#FF7F00","#FFFF33","#A65628","#F781BF","#999999")

# phenotype data

pheno <- read.table("pheno.txt", header=TRUE)

y <- aggregate(y ~ ind, pheno, mean, na.rm=TRUE)
y <- y[order(y[,2]),]
rownames(y) <- y[,1]
y <- y[,2,drop=FALSE]

y.ticks <- sprintf("%.0f", quantile(y[,1], na.rm=TRUE))

# population

pop <- read.table("pop.txt", header=TRUE)

ord <- match(rownames(y), pop[,1])
pop <- pop[ord,2]

# QTL-allele matrix

qam <- read.table("qam.txt", header=TRUE, check.names=FALSE)
qam <- na.omit(qam)

# extream value
ex <- head(sort(qam[,5]),2)
if (ex[1]/ex[2] > 2) {
    cat("detected extream value", ex, "\n")
    qam[qam[,5]==ex[1],5] <- ex[2]
}
ex <- tail(sort(qam[,5]),2)
if (ex[2]/ex[1] > 2) {
    cat("detected extream value", ex, "\n")
    qam[qam[,5]==ex[2],5] <- ex[1]
}

G <- as.matrix(qam[,6:ncol(qam)])
E <- matrix(qam[,5], nrow(G), ncol(G))
A <- G * E
B <- NULL
loc <- qam[!duplicated(qam[,1]),1]
for (e in loc) {
    w <- which(qam[,1] == e)
    B <- rbind(B, colSums(A[w,]))
}
rownames(B) <- loc
write.csv(B, "qam.gv.csv", quote=FALSE)

# sort row
ord <- order(rowSums(B))
B <- B[ord,]

# sort column
ord <- match(rownames(y), colnames(B))
B <- B[,ord]
write.csv(B, "qam.gv.sort.csv", quote=FALSE)

# adjust color

a <- abs(min(B))
b <- abs(max(B))
if (a != b) {
    if (a > b) {
        k <- round(quantile(1:length(col.map), (a+b)/(2*a)))
        col.map <- col.map[1:k]
    } else {
        k <- round(quantile(1:length(col.map), 1-(a+b)/(2*b)))
        col.map <- col.map[k:length(col.map)]
    }
}

# plot

tiff("qam-pop.tif", width=14, height=10, units="cm", pointsize=10, res=300, compression="lzw")

layout(matrix(c(1,2,3,0),2,2), widths=c(9,1.1), height=c(5,1))

# heatmap

par(mar=c(0.5,2,0.5,0.5), lend=2, cex=1)
image(t(B), col=col.map, axes=FALSE)
title(ylab="QTL", line=0.6)

# accession colorbar

par(mar=c(3,2,0,0.5), lend=2, cex=1)
image(cbind(1:nrow(y)), col=col.pop[c(pop)], axes=FALSE, xlab=NA, ylab=NA)
axis(1, at=seq(0,1,0.25), labels=y.ticks, lwd=0, lwd.ticks=1, tcl=-0.3, mgp=c(0,0.5,0))
title(xlab="Accession", line=1.5)

# effect colorbar

par(mar=c(3,0,3.5,2.5), lend=2, cex=1)
x <- seq(min(B), max(B), length=length(col.map))
image(x=1, y=x, z=t(x), col=col.map, axes=FALSE, xlab=NA, ylab=NA)
axis(4, las=2, lwd=0, lwd.ticks=1, tcl=0.3, mgp=c(0,0.5,0))

dev.off()

tiff("pop-color.tif", width=4, height=4, units="cm", pointsize=10, res=300, compression="lzw")
par(mar=c(1,1,1,1))
pie(rep(1,length(levels(pop))), labels=levels(pop), col=col.pop, border=NA)
dev.off()


# library(tidyverse)
library(dplyr)
# library(ggrepel)
# require(rgdal)
library(ggpubr)
detach(package:plyr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

results <- read.csv(file.path(folder, '..', '..', 'results', 'national_results_technology_options.csv'))
names(results)[names(results) == 'GID_0'] <- 'iso3'

clusters <- read.csv(file.path(folder, '..', 'clustering', 'results', 'data_clustering_results.csv'))
names(clusters)[names(clusters) == 'ISO_3digit'] <- 'iso3'
clusters <- select(clusters, iso3, cluster, country)

results <- merge(results, clusters, x.by='iso3', y.by='iso3', all=FALSE)

results <- select(results, scenario, strategy, confidence, cost_per_network_user, cluster)

results <- results %>%
        group_by(scenario, strategy, confidence, cluster) %>%
         summarise(
           mean_cost_per_user = round(mean(cost_per_network_user))
           )

all_data <- merge(clusters, results, by='cluster', all=FALSE)

pop <- read.csv(file.path(folder, 'data_inputs', 'population_2018.csv'))
pop <- select(pop, iso3, population)
pop$iso3 <- as.character(pop$iso3)

all_data <- merge(all_data, pop, by='iso3', all=FALSE)

#Not sure if this is right
#Current costs are for a user on a network with 25% market share
#We then multiply the user cost across the whole population?
#check and revise this
all_data$total_cost <- all_data$mean_cost_per_user * all_data$population

all_data$confidence = factor(all_data$confidence, levels=c('5','50', '95'),
                            labels=c("lower", 'mean', "upper"))

all_data$scenario = factor(all_data$scenario, levels=c("S1_25_10_2",
                                                     "S2_200_50_5",
                                                     "S3_400_100_10"),
                          labels=c("S1 (25 Mbps)",
                                   "S2 (200 Mbps)",
                                   "S3 (400 Mbps)"))

scenario_200_mbps <- all_data[(all_data$scenario == 'S2 (200 Mbps)'),]

scenario_200_mbps$strategy = factor(scenario_200_mbps$strategy, levels=c(
                                               "4G_epc_microwave_baseline_baseline_baseline_baseline",
                                               "4G_epc_fiber_baseline_baseline_baseline_baseline",
                                               "5G_nsa_microwave_baseline_baseline_baseline_baseline",
                                               "5G_sa_fiber_baseline_baseline_baseline_baseline"),
                       labels=c(
                                "4G (Microwave)",
                                "4G (Fiber)",
                                "5G NSA (Microwave)",
                                "5G SA (Fiber)"))

wide <- select(scenario_200_mbps, country, cluster, scenario, strategy, confidence, total_cost)
wide <- spread(wide, confidence, total_cost)

cost_by_strategy <- ggplot(wide, aes(x=wide$cluster, y=wide$mean/1e9, colour=wide$cluster)) +
  geom_boxplot(aes(group=factor(wide$cluster))) + geom_jitter(width = 0.4, height=0.5, size=1.7) +
  scale_colour_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73")) +
  theme(legend.position = NULL) +
  labs(colour=NULL,
       title = "Total Investment Cost",
       subtitle = "Results reported by scenario, strategy and country for 95% confidence",
       x = NULL, y = "Total Investment ($USD Billions)") +
  theme(panel.spacing = unit(0.6, "lines")) + expand_limits(x = 0, y = 0) +
  scale_y_continuous(limits=c(0,40), expand=c(0,0)) +
  guides(fill=FALSE, colour=FALSE) +
  facet_grid(scenario~strategy)

#export to folder
path = file.path(folder, 'figures', 'cost_by_strategy.png')
ggsave(path, units="in", width=7, height=5)
print(cost_by_strategy)
dev.off()

if (!require(rgeos)) {
  install.packages("rgeos", repos = "http://cran.us.r-project.org")
  require(rgeos)
}
if (!require(rgdal)) {
  install.packages("rgdal", repos = "http://cran.us.r-project.org")
  require(rgdal)
}
# if (!require(raster)) {
#   install.packages("raster", repos = "http://cran.us.r-project.org")
#   require(raster)
# }
if(!require(ggplot2)) {
  install.packages("ggplot2", repos="http://cloud.r-project.org")
  require(ggplot2)
}
if(!require(viridis)) {
  install.packages("viridis", repos="http://cloud.r-project.org")
  require(viridis)
}
if(!require(dplyr)) {
  install.packages("dplyr", repos = "https://cloud.r-project.org/")
  require(dplyr)
}
if(!require(gtable)) {
  install.packages("gtable", repos = "https://cloud.r-project.org/")
  require(gtable)
}
if(!require(grid)) {
  install.packages("grid", repos = "https://cloud.r-project.org/")
  require(grid)
}
if(!require(readxl)) {
  install.packages("readxl", repos = "https://cloud.r-project.org/")
  require(readxl)
}
if(!require(magrittr)) {
  install.packages("magrittr", repos = "https://cloud.r-project.org/")
  require(magrittr)
}

#set ggplot2 theme for map
theme_map <- function(...) {
  theme_minimal() +
    theme(
      text = element_text(family = "Ubuntu Regular", color = "#22211d"),
      axis.line = element_blank(),
      axis.text.x = element_blank(),
      axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      # panel.grid.minor = element_line(color = "#ebebe5", size = 0.2),
      panel.grid.major = element_line(color = "#ebebe5", size = 0.2),
      panel.grid.minor = element_blank(),
      plot.background = element_rect(fill = "#f5f5f2", color = NA),
      panel.background = element_rect(fill = "#f5f5f2", color = NA),
      legend.background = element_rect(fill = "#f5f5f2", color = NA),
      panel.border = element_blank(),
      ...
    )
}

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#get data
data <- read.csv(file.path(folder,'..','clustering','results','data_clustering_results.csv'), stringsAsFactors = F)

shapes <- file.path(folder, '..','clustering','data_inputs', "global_countries.shp")

#fortify the data AND keep trace of the commune code! (Takes ~2 minutes)
gde_15 <- readOGR(shapes, layer = "global_countries")

#fortify the data
map_data_fortified <- fortify(gde_15, region = "ISO_3digit") %>% mutate(id = id)

#now join the thematic data
map_data <- map_data_fortified %>% left_join(data, by = c("id" = "ISO_3digit"))

#swap na label for 'no data'
map_data$cluster[is.na(map_data$cluster)] <- "No Data"

#create map
cluster_map <- ggplot() +
  geom_polygon(data = map_data, aes(fill = factor(cluster),
                                    x = long, y = lat, group = group), colour='grey', size = 0.2) +
  coord_equal() +  theme_map() +
  labs(x = NULL, y = NULL,  fill = 'Cluster', title = "Global Countries by Cluster",
       subtitle = "Clustering based on GDP Per Capita, Population Density and 4G Coverage") +
  theme(legend.position = "bottom") +
  guides(fill=guide_legend(ncol=8)) +
  scale_fill_manual(values = c("#F0E442","#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73", "#999999", "#000000"))

# #export to folder
# path = file.path(folder, 'figures', 'map.tiff')
# tiff(path, units="in", width=12, height=12, res=300)
# print(cluster_map)
# dev.off()

rm(data, gde_15, map_data, map_data_fortified)

cost_by_strategy_vis <- ggarrange(cost_by_strategy, cluster_map, ncol = 1, nrow = 2, align = c("hv"))

#export to folder
path = file.path(folder, 'figures', 'cost_by_strategy_panel.png')
ggsave(path, units="in", width=10, height=10)
print(cost_by_strategy_vis)
dev.off()


LineGraph.loader <- function(
	input.filename,
  scaling.filename = NULL,
	output.file="LineGraph",
	graphType="MERR",
    aggregate.probes = FALSE,
  plot.individuals=FALSE,
  HDD.data.type = NULL
) {
	library(stringr)
	library(plyr)
	library(ggplot2)
	library(Cairo)

	line.data<-read.delim(input.filename,header=T)

  #Read the scaling data (location of each group (concept path) on X-axis)
  if (!is.null(scaling.filename)) {
    scaling.data <- read.delim(scaling.filename,header=T)
  } else { # if scaling file is not available, each level of group (concept path) will be plotted at the number of that level
    scaling.data <- data.frame(GROUP = unique(line.data$GROUP), VALUE = 1:length(unique(line.data$GROUP)))
  }
  # assign the X-axis position to each row
  line.data$TIME_VALUE <- sapply(line.data$GROUP,FUN = function(groupValue) { scaling.data$VALUE[which(groupValue==scaling.data$GROUP)] })

  # Either plot a single LineGraph (if there are no plot_group values)
  # or, for each group-value, retrieve rows for that value and plot LineGraph
  plotGroupValues <- unique(line.data$PLOT_GROUP)
  if (is.null(plotGroupValues) || is.na(plotGroupValues)) {
    p <- LineGraph.plotter(line.data, graphType, plot.individuals, HDD.data.type)
    imageFileName <- paste(output.file,".png",sep="")
    CairoPNG(file=imageFileName, width=1200, height=600,units = "px")
    print(p)
    dev.off()
  } else {
    fileIter <- 1
    for (plotGroup in plotGroupValues) {
      groupData <- line.data[which(line.data$PLOT_GROUP==plotGroup),]
      p <- LineGraph.plotter(groupData, graphType, plot.individuals, HDD.data.type)
      p <- p + labs(title = as.character(plotGroup))
      imageFileName <- paste(output.file,fileIter,".png",sep="")
      fileIter <- fileIter + 1
      CairoPNG(file=imageFileName, width=1200, height=600,units = "px")
      print(p)
      dev.off()
    }
  }
}

LineGraph.plotter <- function(
  data.to.plot,
  graphType,
  plot.individuals,
  HDD.data.type
)
{

	if (plot.individuals) {
	  #Change column order to match internal standard and adjust the column names.
    dataOutput <- data.to.plot[,c("PATIENT_NUM","GROUP","TIME_VALUE","GROUP_VAR","VALUE")]
    colnames(dataOutput) <- c('PATIENT_NUM','TIMEPOINT','TIME_VALUE','GROUP','VALUE')
	} else {
	  #Aggregate the data to get rid of patient numbers. We add a standard error column so we can use it in the error bars.
    dataOutput <- ddply(data.to.plot, .(GROUP,TIME_VALUE,GROUP_VAR),
	                      summarise,
	                      MEAN   	= mean(VALUE),
	                      SD 		= sd(VALUE),
	                      SE 		= sd(VALUE)/sqrt(length(VALUE)),
	                      MEDIAN 	= median(VALUE)
	  )
	  #Adjust the column names.
    colnames(dataOutput) <- c('TIMEPOINT','TIME_VALUE','GROUP','MEAN','SD','SE','MEDIAN')
	}

	#Use a regular expression trim out the timepoint from the concept.
	#dataOutput$TIMEPOINT <- str_extract(dataOutput$TIMEPOINT,"Week [0-9]+")
  dataOutput$TIMEPOINT <- as.character(dataOutput$TIMEPOINT)
  TIMEPOINT_reducedConceptPath <- str_extract(dataOutput$TIMEPOINT,"(\\\\.+\\\\.+\\\\)+?$")
  validReplacements <- which(!is.na(TIMEPOINT_reducedConceptPath))
  dataOutput$TIMEPOINT[validReplacements] <- TIMEPOINT_reducedConceptPath[validReplacements]
  dataOutput$TIMEPOINT <- as.factor(dataOutput$TIMEPOINT)

	#Convert the timepoint field to a factor.
	dataOutput$TIMEPOINT <- factor(dataOutput$TIMEPOINT)

	#Convert the group field to a factor.
	dataOutput$GROUP <- factor(dataOutput$GROUP)
	######################################################

	######################################################
	#Plotting the line.

  #Determine Y-axis label.
  if (is.null(HDD.data.type)) yLabel <- dataOutput$TIMEPOINT[1] else yLabel <- HDD.data.type

	#Depending on whether we wish to plot individual data, and otherwise the specific graph type, we create different graphs.
	if (plot.individuals) {
	  limits <- aes(ymax = VALUE, ymin = VALUE);
    layerData <- aes(x=TIME_VALUE, y=VALUE, group=PATIENT_NUM, colour=GROUP)
	} else if (graphType=="MERR") {
	  limits <- aes(ymax = MEAN + SE, ymin = MEAN - SE)
    layerData <- aes(x=TIME_VALUE, y=MEAN, group=GROUP, colour=GROUP)
    yLabel <- paste(yLabel,"(mean + se)")
	} else if (graphType=="MSTD") {
	  limits <- aes(ymax = MEAN + SD, ymin = MEAN - SD)
    layerData <- aes(x=TIME_VALUE, y=MEAN, group=GROUP, colour=GROUP)
    yLabel <- paste(yLabel,"(mean + sd)")
	} else if (graphType=="MEDER") {
	  limits <- aes(ymax = MEDIAN + SE, ymin = MEDIAN - SE)
    layerData <- aes(x=TIME_VALUE, y=MEDIAN, group=GROUP, colour=GROUP)
    yLabel <- paste(yLabel,"(median + se)")
	}
  p <- ggplot(data=dataOutput,layerData) + ylab(yLabel)

	p <- p + geom_line(size=1.5) + scale_colour_brewer()
	if (!plot.individuals) p <- p + geom_errorbar(limits,width=0.2)

	#Defines a continuous x-axis with proper break-locations, labels, and axis-name
  p <- p + scale_x_continuous(name = "TIMEPOINT", breaks = dataOutput$TIME_VALUE, labels = dataOutput$TIMEPOINT)

	#This sets the color theme of the background/grid.
	p <- p + theme_bw();

	#Set the text options for the axis.
	p <- p + theme(axis.text.x = element_text(size = 17,face="bold",angle=5));
	p <- p + theme(axis.text.y = element_text(size = 17,face="bold"));

	#Set the text options for the title.
	p <- p + theme(axis.title.x = element_text(vjust = -.5,size = 20,face="bold"));
	p <- p + theme(axis.title.y = element_text(vjust = .35,size = 20,face="bold",angle=90));

	#Set the legend attributes.
	p <- p + theme(legend.title = element_text(size = 20,face="bold"));
	p <- p + theme(legend.text = element_text(size = 15,face="bold"));
	p <- p + theme(legend.title=element_blank())

	p <- p + geom_point(size=4);

  p
}


#library(reprtree)
#library(caret)
library(randomForest)

args <- commandArgs(TRUE)
parseArgs <- function(x) {
  res = strsplit(sub("^--", "", x), "=")
  if(length(unlist(res))==1) res[[1]][2]=""
  return(res)
}
argsL <- as.list(as.character(as.data.frame(do.call("rbind", parseArgs(args)))$V2))
names(argsL) <- as.data.frame(do.call("rbind", parseArgs(args)))$V1
args <- argsL;rm(argsL)

if(is.null(args$help)) {help=FALSE} else {help=TRUE}

if(is.null(args$model_snv) | is.null(args$model_snv) | is.null(args$target_table) | help) {
  cat("

      Method: add features to each variant of a table to be used in the classifier

      Mandatory arguments:
      --model_snv=Robject         - trained random forest from snv (output of compute_model.r)
      --model_indel=Robject       - trained random forest from indel (output of compute_model.r)
      --target_table=file_name    - table to apply the model on (output of add_calling_features.r)

      Optional arguments:
      --output_folder             - folder to save the models (default: .)
      --output_table              - file name for the table annotated with random forest predictions (default: RF_table_result.txt)
      --help                      - print this text

      example: add_calling_features.r --train_table=table_for_training.txt \n\n")
  q(save="no")
}

if(is.null(args$output_folder)) {output_folder="."} else {output_folder=args$output_folder}
if(is.null(args$output_table)) {output_table="RF_table_result.txt"} else {output_table=args$output_table}

model_snv = args$model_snv
model_indel = args$model_indel

set.seed(123) # here I fix the seed of the random generator to have the same random numbers if re-run

target_table = read.table(args$target_table, quote="\"", stringsAsFactors=F, sep="\t", header=T)
target_table[which(is.infinite(target_table$MIN_DIST)),"MIN_DIST"] = 1000000000
target_table[which(is.infinite(target_table$MaxRatioWin)),"MaxRatioWin"] = 1000000000
target_table$IoD = 1 + target_table$SIG * 10^(target_table$ERR)
target_table$IoD = 1 + target_table$SIG * 10^(target_table$ERR)

for(type in c("snv","indel")){
  load(get(paste("model_",type,sep="")))
  if(type == "snv") { ids=which(target_table$TYPE_INFO=="snv") ; rf = rf_snv }
  if(type == "indel") { ids=which(target_table$TYPE_INFO!="snv") ; rf = rf_indel }
  target_table[ids,"FP_prob"] = predict(rf, target_table[ids,], type="prob")[,"FP"]
}

write.table(target_table, file=paste(output_folder,"/",output_table,sep=""), quote=F, sep="\t", row.names = F)


make.evenness.spatial = function( distance=50 ) {

    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    # maturity codes
    immature = 0
    mature = 1
    mat.unknown = 2

  require(MASS)
  require(doBy)

  #  distance = seq(10,60,10)
  #  distance = 50

  #  subsample size-at-maturity estimates in a spatio-temporal context and then map it
  # mapping is continued in functions,figures.r and "map.maturity" in 2.figures.r

  det = snowcrab.db("det.georeferenced")
  to.keep = c("trip", "set", "sex", "cw", "mass", "abdomen", "chela", "mat","lon", "lat", "yr", "sa","plon","plat")
  det = det[,to.keep]
  gc()

  det$X 	<- det$lon
  det$Y 	<- det$lat
  det$lon 	<- det$plon
  det$lat 	<- det$plat
  loc = c("lon", "lat")

  years = sort( unique( det$yr ) )
  years = years[years>=1999]
  nyears = length( years )
  output = NULL

  for (y in 1:nyears) {
    	j = which( det$yr == years[y] )
    	dj = det[j,]
    	dj$uid <- paste(dj$trip,dj$set,sep="")
    	sets = sort( unique(dj$uid ) )
    	nset = length(sets)
	    print (years[y])
    for (s in 1:nset) {
      	i = which( dj$uid == sets[s] )
      dji = dj[i,]
      coord0 = dji[1,loc]  # focal pt
      browser()
      d.ss = which( geodist(
        point=coord0, locations=dj[,loc], method="vincenty") <= distance
      )
      dji = dj[d.ss,]
   for (sex in c(male, female)) {
        sexi = which(dji$sex == sex )
        out = inf = NULL

        ##to here December 11, 2013
        out = est.size.at.maturity (dji[sexi,], sex)

        if (!is.null(out) ) {
          out = data.frame( t(out ))
          inf = cbind( sex=sex, distance=distance, uniqueid=I(sets[s]),
                       yr=years[y], lon=coord0[1], lat=coord0[2], out
                )
          output = rbind( output , inf )
  }}}}

  good = which(
    output$converged==1 &
    output$cw50 >  20 &
    output$cw50 < 150 &
    output$deviance < 400 &
    output$aic < 400
  )

  maturity = output[good,]
  return (maturity )
}


rm(list=ls())
library(DEploid)

true.prop = list()
# 3d7, dd2, 7g8, hb3
true.prop[["PG0389-C"]] = c(0.9, 0.1, 0, 0)
true.prop[["PG0390-C"]] = c(0.8, 0.2, 0, 0)
true.prop[["PG0391-C"]] = c(0.67, 0.33, 0, 0)
true.prop[["PG0392-C"]] = c(0.33, 0.67, 0, 0)
true.prop[["PG0393-C"]] = c(0.2, 0.8,0,0)
true.prop[["PG0394-C"]] = c(0.1, 0.9,0,0)
true.prop[["PG0395-C"]] = c(0, 0.33, 0.34, 0.33)
true.prop[["PG0396-C"]] = c(0, 0.25, 0.5, 0.25)
true.prop[["PG0397-C"]] = c(0, 0.143, 0.714, 0.143)
true.prop[["PG0398-C"]] = c(0, 0, 0, 1)
true.prop[["PG0399-C"]] = c(0, 0, 0.01, 0.99)
true.prop[["PG0400-C"]] = c(0, 0, 0.05, 0.95)
true.prop[["PG0401-C"]] = c(0, 0, 0.1, 0.9)
true.prop[["PG0402-C"]] = c(0, 0, 0.15, 0.85)
true.prop[["PG0403-C"]] = c(0, 0, 0.2, 0.8)
true.prop[["PG0404-C"]] = c(0, 0, 0.25, 0.75)
true.prop[["PG0405-C"]] = c(0, 0, 0.3, 0.7)
true.prop[["PG0406-C"]] = c(0, 0, 0.4, 0.6)
true.prop[["PG0407-C"]] = c(0, 0, 0.5, 0.5)
true.prop[["PG0408-C"]] = c(0, 0, 0.6, 0.4)
true.prop[["PG0409-C"]] = c(0, 0, 0.7, 0.3)
true.prop[["PG0410-C"]] = c(0, 0, 0.75, 0.25)
true.prop[["PG0411-C"]] = c(0, 0, 0.80, 0.2)
true.prop[["PG0412-C"]] = c(0, 0, 0.85, 0.15)
true.prop[["PG0413-C"]] = c(0, 0, 0.95, 0.05)
true.prop[["PG0414-C"]] = c(0, 0, 0.99, 0.01)
true.prop[["PG0415-C"]] = c(0, 0, 1,0)

PLAF = read.table("labStrains.eg.PLAF.txt", header=T, stringsAsFactors=F)

chroms = unique(PLAF$CHROM)
CHROM = PLAF$CHROM
POS = PLAF$POS

i_arr = c(389:415)
panel = ""
#panel = ".asiaAfrica"
for ( idx_i in 24:27 ){
    i = i_arr[idx_i]
    sample_i = paste("PG0", i, "-C", sep="")
    prop.tmp = paste(true.prop[[sample_i]][true.prop[[sample_i]]>0], collapse = " ")
    haps = c()
    for ( chrom in chroms ){
        cmd = paste("-ref", paste("coverage/", sample_i, "_", chrom, ".ref", sep =""),
                    "-alt", paste("coverage/", sample_i, "_", chrom, ".alt", sep =""),
                    "-plaf", paste("plafs/", chrom, ".plaf", sep = ""),
                    "-panel", paste("panels/", sample_i, "_", chrom, panel, ".panel.txt", sep =""),
                    "-initialP", prop.tmp)
        print(cmd)
        dEploidout = dEploid(cmd)
        haps = rbind(haps, t(dEploidout$Haps))
    }
    colnames(haps) = paste("h", 1:length(true.prop[[sample_i]][true.prop[[sample_i]]>0]), sep="")
    write.table(cbind(CHROM, POS, haps), file = paste("haps/", sample_i, panel, ".hap", sep=""), row.names=F, quote=F, sep="\t")
}


#############################################################################
## 2nov2020                                                                ##
## Script manipulates governor votes in order to aggregate coalitions etc. ##
## It generates object dat in memory that other scripts rely upon          ##
## (eg. incumbent-reelection.r).                                           ##
## At the end, the possibility of saving this object is commented out.     ##
#############################################################################

# get state-level gob elections
dat <- read.csv("/home/eric/Desktop/MXelsCalendGovt/elecReturns/data/goed1961-on.csv", stringsAsFactors = FALSE)
dat <- within(dat, fuente <- nota <- vtot <- nr <- nulos <- fake <- NULL)

# re-compute efec
sel <- grep("v[0-9]+", colnames(dat))
v <- dat[,sel]
v[is.na(v)] <- 0 # NAs with 0s
dat$efec <- rowSums(v)
rm(v)

######################################################
######################################################
# identify coalitions by searching for "-" in labels #
######################################################
######################################################
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
#
# dummy had at least one coalition
dat$dcoal <- 0
for (i in 1:ncol(l)){
    dat$dcoal[grep("-", l[,i])] <- 1
}

# create objects with vote for coalition(s) added and redudant columns dropped
cv <- v; cv[] <- NA # will receive votes with coalitions aggregated
cl <- l; cl[] <- NA # will keep coalition labels but drop coalition member labels
ci <- data.frame(dcoal=dat$dcoal, ncoal=NA, coal1="none", coal2="none", coal3="none", coal4="none", stringsAsFactors = FALSE) # coalition summary info
ci$ncoal[ci$dcoal==0] <- 0 # 0=no coalition
# ci$coal1 coal2 coal3 coal4 pre-filled
  # n is object reporting how many parties reported in a v/l cell?
  ln1 <- v # duplicate votes
  ln1[] <- 0 # will receive info
  ln2 <- ln1 # duplicate
  # replace each label with its character length
  for (i in 1:ncol(ln1)){
      #i <- 16 # debug
      tmp <- l[,i] # pick ith column as vector
      ln1[,i] <- nchar(tmp) # replace items with num characters
  }
  # drop hyphens to count character difference
  l.tmp <- l # duplicate
  for (i in 1:ncol(l.tmp)){
      #i <- 1 # debug
      l.tmp[,i] <- gsub("-", "", l.tmp[,i]) # remove hyphens to count char dif
      ln2[,i] <- nchar(l.tmp[,i]) # replace items with num characters
  }
  n <- ln1 - ln2 + 1 # 1 means no coalition, single party
  n[l=="0"] <- 0     # empty votes
  rm(i, ln1, ln2, l.tmp, sel, tmp)
#
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
I <- nrow(v)
c1 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # will receive vector of 1st coalition's members
c2 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 2nd coalition's members
c3 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 3rd coalition's members
c4 <- as.data.frame(matrix("0", I, 7), col.names = paste("p", 1:7, sep = ""), stringsAsFactors = FALSE) # 3rd coalition's members
#
# will receive columns corresponding to coalition members in v/l for use when weighting votes contributed by each member
w1 <- as.list(rep("noCoal",I))
w2 <- as.list(rep("noCoal",I))
w3 <- as.list(rep("noCoal",I))
w4 <- as.list(rep("noCoal",I))
#
# fill in easy cases with no coalition
sel <- which(dat$dcoal==0)
cv[sel,] <- v[sel,]
cl[sel,] <- l[sel,]
# c1 c2 c3 c4 are pre-filled
# w1 w2 w3 w4 are pre-filled

# fill in info selecting cases of coalitions with most members
sel7 <- which(max.tmp>1)
tmp.v <- v[sel7,] # subset for manipulation
tmp.l <- l[sel7,]
tmp.n <- n[sel7,]
max.tmp <- max.tmp[sel7]
tmp.c1 <- c1[sel7,]
tmp.w1 <- w1[sel7]
tmp.ci <- ci[sel7,]

# debug
#i <- which(dat$ord[sel7]==847)

for (i in 1:length(sel7)){
    #i <- length(sel7) # debug
    tmp.ci$ncoal[i] <- 1               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal1[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c1[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 1 # debug
        if (tmp.c1[i,j]=="0") next
        pat <- paste("^", tmp.c1[i,j], "$|", tmp.c1[i,j], "-|-", tmp.c1[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c1[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w1[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c1[sel7,] <- tmp.c1
w1[sel7] <- tmp.w1
ci[sel7,] <- tmp.ci
#tail(w1[sel7])

####################################
# process cases with 2nd coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c2 <- c2[sel7,]
tmp.w2 <- w2[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

# debug
#i <- which(dat$ord[sel7]==847)

for (i in 1:length(sel7)){
    #i <- 3079 # debug
    tmp.l[i,] # debug
    #tmp.n[i,] # debug
    #message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 2               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal2[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c2[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c2[i,j]=="0") next
        pat <- paste("^", tmp.c2[i,j], "$|", tmp.c2[i,j], "-|-", tmp.c2[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c2[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w2[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c2[sel7,] <- tmp.c2
w2[sel7] <- tmp.w2
ci[sel7,] <- tmp.ci
# tail(w2[sel7])

####################################
# process cases with 3rd coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c3 <- c3[sel7,]
tmp.w3 <- w3[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

for (i in 1:length(sel7)){
    #i <- 1 # debug
    #tmp.l[i,] # debug
    #tmp.n[i,] # debug
    #message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 3               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal3[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c3[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c3[i,j]=="0") next
        pat <- paste("^", tmp.c3[i,j], "$|", tmp.c3[i,j], "-|-", tmp.c3[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c3[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w3[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c3[sel7,] <- tmp.c3
w3[sel7] <- tmp.w3
ci[sel7,] <- tmp.ci
# tail(w3[sel7])

####################################
# process cases with 4th coalition #
####################################
max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # coal w most members has 7
sel7 <- which(max.tmp>1)
tmp.v <- cv[sel7,] # subset for manipulation
tmp.l <- cl[sel7,]
tmp.n <- n[sel7,]
tmp.c4 <- c4[sel7,]
tmp.w4 <- w4[sel7]
max.tmp <- max.tmp[sel7]
tmp.ci <- ci[sel7,]

for (i in 1:length(sel7)){
    #i <- 1 # debug
    #tmp.l[i,] # debug
    #tmp.n[i,] # debug
    #message(sprintf("loop %s of %s", i, length(sel7)))
    tmp.ci$ncoal[i] <- 4               # running tally co ncoal
    save.col <- which(tmp.n[i,]==max.tmp[i])[1] # spare this column from erasure in process below (1st if multiple hits)
    save.label <- tmp.l[i, save.col]            # keep coalition full label
    tmp.ci$coal4[i] <- save.label      # plug coal label into summary
    tmp <- strsplit(save.label, split = "-") # break into component character vector
    tmp.c4[i,1:length(tmp[[1]])] <- tmp[[1]] # fill in coalition members
    #
    target.cols <- numeric() # initialize empty vector
    for (j in 1:7){
        #j <- 2 # debug
        if (tmp.c4[i,j]=="0") next
        pat <- paste("^", tmp.c4[i,j], "$|", tmp.c4[i,j], "-|-", tmp.c4[i,j], sep="") # searches ^pty$, pty- or -pty (avoids panal hit when searching for pan) --- unnecessary given label changes
        tmp.target <- grep(pattern = pat, x = tmp.l[i,])
        #tmp.target <- grep(pattern = tmp.c4[i,j], x = tmp.l[i,]) # version hits panal when searching pan
        if (length(tmp.target)>0) {
            target.cols <- c(target.cols, tmp.target)
        }
    }
    target.cols <- unique(target.cols); target.cols <- target.cols[order(target.cols)]
    tmp.w4[[i]] <- target.cols # for use when computing coalition members' contribution
    save.vote <- sum(tmp.v[i,target.cols])
    tmp.v[i, target.cols] <- 0   # erase votes to keep only aggregate
    tmp.l[i, target.cols] <- "0" # erase labels to keep only full coalition label
    tmp.n[i, target.cols] <- 0   # erase ns
    tmp.v[i, save.col] <- save.vote  # place aggregate vote back in
    tmp.l[i, save.col] <- save.label # place coalition label back in
}
# return to data
cv[sel7,] <- tmp.v
cl[sel7,] <- tmp.l
n[sel7,] <- tmp.n
c4[sel7,] <- tmp.c4
w4[sel7] <- tmp.w4
ci[sel7,] <- tmp.ci

max.tmp <- apply(n, 1, max) # max parties reported in a row's cell
table(max.tmp) # must have 0s and 1s only (number of parties being reported by remaining columns)

# plug ncoal into data
dat$ncoal  <- ci$ncoal

# prepare object with coalition party weights
w <- as.list(rep("noCoal",I))
sel <- which(ci$ncoal>=1)
for (i in sel){
    w[[i]] <- list(coal1="no", coal2="no", coal3="no", coal4="no")
    #i <- sel[1] # debug
    w[[i]]$coal1 <- v[i,w1[[i]]]
    names(w[[i]]$coal1) <- l[i,w1[[i]]]
}
#
sel <- which(ci$ncoal>=2)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal2 <- v[i,w2[[i]]]
    names(w[[i]]$coal2) <- l[i,w2[[i]]]
}
#
sel <- which(ci$ncoal>=3)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal3 <- v[i,w3[[i]]]
    names(w[[i]]$coal3) <- l[i,w3[[i]]]
}
#
sel <- which(ci$ncoal>=4)
for (i in sel){
    #i <- sel[1] # debug
    w[[i]]$coal4 <- v[i,w4[[i]]]
    names(w[[i]]$coal4) <- l[i,w4[[i]]]
}
coal.weights <- w # rename
coal.info <- ci
rm(w, ci)

rm(c1, c2, c3, c4, I, i, j, max.tmp, n, pat, save.col, save.label, save.vote, sel, sel7, target.cols, tmp, tmp.c1, tmp.c2, tmp.c3, tmp.c4, tmp.ci, tmp.l, tmp.n, tmp.target, tmp.v, tmp.w1, tmp.w2, tmp.w3, tmp.w4, w1, w2, w3, w4) # housecleaning

## winner (sorts data to have largest vote-winning party in column 1)
# handy function to sort one data frame's rows by order of another, matching data frame
sortBy <- function(target, By){
    t <- target; b <- By;
    do.call(rbind, lapply(seq_len(nrow(b)),
            function(i) as.character(unlist(t[i,])[order(unlist(-b[i,]))]))) # change to -b for decreasing order
}
# example
## v1 <- data.frame(c1=c(30,15,3), c2=c(10,25,2), c3=c(20,35,4))
## l1 <- data.frame(c1=c("thirty","fifteen","three"), c2=c("ten","twenty-five","two"), c3=c("twenty","thirty-five","four"))
## v1.sorted <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE))) # sort each row of df -- http://stackoverflow.com/questions/6063881/sorting-rows-alphabetically
## l1.sorted <- sortBy(target = l1, By = v1)
## sortBy(target = v1, By = v1)
##
## this sorts matrix rows faster than function above
## dat <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE)))

# sort coalition-aggregated data
tail(cv)
tail(cl)
###########################################
cv.sorted <- sortBy(target = cv, By = cv) # slow! wait for process
#                                         # end before continuing
###########################################
cl.sorted <- sortBy(target = cl, By = cv) # slow! wait for process
#                                         # end before continuing
###########################################
cv.sorted <- as.data.frame(cv.sorted, stringsAsFactors = FALSE) # return matrix to dataframe
cl.sorted <- as.data.frame(cl.sorted, stringsAsFactors = FALSE) # return matrix to dataframe
colnames(cv.sorted) <- colnames(v); colnames(cl.sorted) <- colnames(l)
cv.sorted <- transform(cv.sorted, v01 = as.numeric(v01), v02 = as.numeric(v02), v03 = as.numeric(v03), v04 = as.numeric(v04), v05 = as.numeric(v05), v06 = as.numeric(v06), v07 = as.numeric(v07), v08 = as.numeric(v08), v09 = as.numeric(v09), v10 = as.numeric(v10), v11 = as.numeric(v11), v12 = as.numeric(v12), v13 = as.numeric(v13), v14 = as.numeric(v14), v15 = as.numeric(v15), v16 = as.numeric(v16)) # return to numeric format
tail(cv.sorted)
tail(cl.sorted)

# rename objects so that dat now has coalition aggregates
dat.orig <- dat # original data
dat[,sel.l] <- cl.sorted # return manipulated labels to data
dat[,sel.v] <- cv.sorted # return manipulated votes to data
#
# NAs w 0s in votes
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
v[is.na(v)] <- 0
dat[,sel.v] <- v # return
#
# move dcoal and ncoal columns before v01
tmp <- dat # duplicate if I mess up
tmp1 <- grep("v01", colnames(dat))
tmp2 <- grep("dcoal", colnames(dat))
tmp3 <- grep("ncoal", colnames(dat))
dat <- dat[, c(1:(tmp1-1), tmp2, tmp3, tmp1:(tmp2-1))]
colnames(dat)
rm(cv, cl, cv.sorted, cl.sorted, sel.l, sel.v, v, l, tmp, tmp1, tmp2, tmp3)

table(dat$v12) # check that only has zeroes
dat$v12 <- dat$v13 <- dat$v14 <- dat$v15 <- dat$v16 <- dat$v17 <- dat$v18 <- NULL # redundant columns
dat$l12 <- dat$l13 <- dat$l14 <- dat$l15 <- dat$l16 <- dat$l17 <- dat$l18 <- NULL # redundant columns
#
#dat$win <- dat$l01

# recompute ncand
sel.l <- grep("^l[0-9]{2}", colnames(dat))
l <- dat[,sel.l] # subset label columns
sel.v <- grep("^v[0-9]{2}", colnames(dat))
v <- dat[,sel.v] # subset vote columns
#
sel <- which(dat$yr>1994 & dat$ncand!=apply(v, 1, function(x) length(x[x>0])))
sel
#
dat$ncand <- apply(v, 1, function(x) length(x[x>0]))

# clean, levaes only object `dat'
rm(coal.info,coal.weights)
rm(dat.orig)
rm(l,sel,sel.l,sel.v,sortBy,v)

#################################################################
## I could save a coal-agg version of go.ed here, not done yet ##
#################################################################


# 3. faza: Vizualizacija podatkov

# GLEDE AVRAGE TOP in BOTTOM
a_mean_08_T <- nat.ha %>% drop_na(h) %>% arrange(h) %>% filter(sredina=="mean") %>% filter(leto=="2008") %>%  tail(n = 10)
a_mean_08_B <- nat.ha %>% drop_na(h) %>% arrange(h) %>% filter(sredina == "mean") %>% filter(leto=="2008") %>% head(n = 15)

# GRAF, KI ANALIZIRA ZAPOSLITEV

graf1 <- t_e %>% filter(occ_code == "00-0000") %>%
  ggplot(aes(x=leto, y=emp)) +
  geom_line(size=1.5, colour="green") +
  geom_point(size=2, colour="blue") +
  ylab("Število zaposlednih") +
  scale_y_continuous(labels = comma_format(big.mark = ".", decimal.mark = ",")) +
  scale_x_continuous(name = "Leto", breaks = seq(2006,2018,1)) +
  labs(title="Zaposlenost po letih") +
  stat_smooth(method = "lm") +
  theme(axis.line = element_line(colour = "darkblue",
                                 size = 1, linetype = "solid"),
        axis.text.x = element_text(face="plain", color="red",
                                   size=10, angle=7),
        axis.text.y = element_text(face="bold", color="red",
                                   size=10, angle=7))

# PORAZDELITEV TOP3 PLAC PO LETIH
kode[591, 2] <- "Kirurgi"
kode[585,2] <- "Anesteziologi"
kode[575, 2] <- "Ortodonti"
kode[850,2] <- "Frizerji"
kode[784,2] <- "Pomivalci posod"
kode[884,2] <- "Blagajniki"
kode[777,2] <- "Natakarji in natakarice"

joined <- inner_join(nat.ha, kode, by="occ_code")
pr <- joined %>% filter(sredina=="mean")
top <- pr[pr$occ_code %in% c("29-1067","29-1061","29-1023"), ]  %>%
  rename(Poklic=occ_title)
top$Poklic = paste0('Vrh:', top$Poklic)

graf2 <- top %>%
  ggplot(aes(x=Poklic, y=h)) +
  xlab("Poklic") +
  ylab("Povprečna urna postavka plač") +
  geom_boxplot(fill="red", colour="red" , alpha=I(0.2)) +
  geom_jitter(alpha=I(0.2)) +
  geom_point() +
  labs(title="Porazdelitev plač boljše plačanih poklicev")

# TOP 3 GRAFICNO PO DREVESIH

# graf4* <- top %>%
#  ggplot(aes(x=leto,y=HM)) +
#  geom_line(color="blue") +
#  geom_point() +
#  facet_grid(~poklic)

# graf4* <- top %>%
#   ggplot(aes(x=leto,y=HM)) +
#   geom_line(color="blue") +
#   geom_point() +
#   facet_grid(occ_title~.)

# TOP 3 GLEDE NA URNE POSTAVEK

graf3 <- top %>%
  filter(leto!="2019") %>%
  ggplot(aes(x=leto, y=h, col=Poklic)) +
  xlab("Leto") +
  ylab("Povprečna plača na uro") +
  labs(title="Povprečna urna plača treh najboljše plačanih poklicev.") +
  geom_line(size=1) +
  geom_point(size=2) +
  scale_colour_manual(values = c("Red4", "Violetred", "Limegreen"))

# BOTTOM 3 GLEDE NA AVRAGE WAGE
bottom <- pr[pr$occ_code %in%  c("39-5093","35-9021","41-2011","35-3031"), ] %>%
  rename(Poklic=occ_title)
bottom$Poklic = paste0('Spodaj:', bottom$Poklic)

graf4 <- bottom %>%
  ggplot(aes(x=leto, y=a)) +
  geom_line(color="blue") +
  geom_point() +
  xlab("Leto") +
  ylab("Povprečna plača na leto") +
  labs(title="Povprečna letna plača štirih slabše plačanih poklicev.") +
  facet_wrap(~Poklic, ncol=2)

# Zaposlenost top 3 poklicev in bot. 2 poklicev
joined_emp <- inner_join(t_e, kode, by="occ_code")
emoloyment <- joined_emp
bottomemp <- emoloyment[emoloyment$occ_code %in%  c("39-5093","35-9021","41-2011","35-3031"), ] %>%
  rename(Poklic=occ_title)
bottomemp$Poklic = paste0('Spodaj:', bottomemp$Poklic)

topemp <- emoloyment[emoloyment$occ_code %in% c("29-1067","29-1061","29-1023"), ]  %>%
  rename(Poklic=occ_title)
topemp$Poklic = paste0('Vrh:', topemp$Poklic)
together <- rbind(bottomemp, topemp)

graf5 <- together %>% filter(leto=="2018") %>%
  ggplot() +
  aes(x="", y=emp, fill=Poklic) +
  scale_y_continuous(labels = comma_format(big.mark = ".", decimal.mark = ",")) +
  geom_col(width=1) +
  coord_polar(theta="y") + xlab("") + ylab("") +
  labs(title="Deleži poklicev (najboljše plačanih v primeravi z najmanj) v letu 2018")+
  guides(fill=guide_legend("Poklic"))

graf6 <- together %>%
   filter(leto!="2019") %>%
   ggplot(aes(x=leto)) +
   geom_col(aes(y=emp, fill=Poklic)) +
   scale_y_continuous(labels = comma_format(big.mark = ".", decimal.mark = ",")) +
   xlab("Leto") +
   ylab("Zaposlenost") +
   labs(title="Deleži poklicev (najboljše plačanih v primeravi z najmanj)")

# POVPREČNE PLAČE (URNE) V ZDA

zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/states_21basic.zip", "states",
                             encoding="UTF-8")
map1_db <- st.ha  %>%
  filter(sredina=="median") %>%
  drop_na(h) %>%
  group_by(state) %>%
  summarise(povprecje= mean(h))

zem1 <-  tm_shape(merge(zemljevid, map1_db, by.x="STATE_NAME", by.y="state"), simplify = 0.2) +
  tm_polygons("povprecje",title="Povprečne plače v ZDA (urna postavka)",legend.hist=TRUE,
              palette = c("springgreen","lightblue","navy")) +
  tm_layout(legend.outside=TRUE) +
  tm_text("STATE_ABBR", size=0.3)

# GDP PP v Aljaski

graf8 <- GDP_by_state %>% filter(State=="Alaska") %>%
  ggplot(aes(x=leto, y=GDP)) +
  geom_point() +
  geom_line()

podatki <- GDP_by_state %>% filter(State=="Alaska")

graf9 <-  ggplot(podatki, aes(x=leto, y=GDP, size =GDP)) +
  geom_point(color="Violetred") +
  scale_y_continuous(labels = comma_format(big.mark = ".", decimal.mark = ",")) +
  theme_light() +
  labs(title = 'Leto: {floor(frame_time)}',
       x = 'Leto',
       y = 'BDP per capita') +
  scale_size(name="BDP PC v Aljaski",range = c(1,15)) +
  transition_time(leto) +
  shadow_wake(0.2)

animacija <- animate(graf9, renderer = gifski_renderer(), rewind=TRUE)


# Petit script R pour étudier les plateformes de blogging
# du planete-sf.org.

# Realiser par Thom a partir des données de la pages d'accueill.

# Licence GPLv3

# Pour une execution simple sur Linux :
# R -q --vanilla < plateforme.r

# importation des donnees

p.sf = read.csv("planete-sf.csv", header=TRUE, sep=";")

# Pour afficher les donnees :
# plateforme.planete.sf
# Pour afficher la première colonne
# plateforme.planete.sf[,1]

# Nombre de blog concerne par l'étude

nombreblog = length(p.sf[,1])

blogging=c("canalblog", "hautfort", "over-blog", "blogspot", "wordpress")

# compteur compte le nombre de blog sur des plateformes de blogging
# tandis que anticompteur est là pour vérifier que je ne me gourre pas dans les comptes

compteur = 0
anticompteur = 0

for (i in 1 : nombreblog)
{
	for (j in 1 : 5)
	{
		if (p.sf[i,2] == blogging[j])
		{
			compteur=compteur + 1
		}
	}
	if (p.sf[i,2] == "perso")
	{
		anticompteur = anticompteur + 1
	}

}

nombreblog
compteur

# On verifie qu'on n'a pas necessairement faux
verif = (compteur + anticompteur == nombreblog)
verif

pourcentage = compteur / nombreblog
pourcentage

antipourcentage = 1 -  pourcentage
antipourcentage


integrityFileSize {
#Input parameter is:
#  Name of collection that will be checked
#  Minimum file size allowed in collection
#  Maximum file size allowed in collection
#Output is:
#  List of all files in the collection that have a size outside the allowed range

  #Verify that input path is a collection
  *Isizemax = int(*Sizemax);
  *Isizemin = int(*Sizemin);
  msiIsColl(*Coll,*Result, *Status);
  if(*Result == 0) {
    writeLine("stdout","Input path *Coll is not a collection");
    fail;
  }
  *ContInxOld = 1;
  *Count = 0;

  #Loop over files in the collection
  msiMakeGenQuery("DATA_ID,DATA_NAME,DATA_SIZE","COLL_NAME = '*Coll'", *GenQInp);
  msiExecGenQuery(*GenQInp, *GenQOut);
  msiGetContInxFromGenQueryOut(*GenQOut,*ContInxNew);
  while(*ContInxOld > 0) {
    foreach(*GenQOut) {
      msiGetValByKey(*GenQOut,"DATA_SIZE",*Dsize);
      *Idsize = int(*Dsize);
      if(*Idsize > *Isizemax) {
        msiGetValByKey(*GenQOut,"DATA_NAME",*File);
        writeLine("stdout","File *File with size *Dsize is larger than allowed size");
        *Count = *Count + 1;
      }
      if(*Idsize < *Isizemin) {
        msiGetValByKey(*GenQOut,"DATA_NAME",*File);
        writeLine("stdout","File *File with size *Dsize is smaller than allowed size");
        *Count = *Count + 1;
      }
    }
    *ContInxOld = *ContInxNew;
    if(*ContInxOld > 0) {msiGetMoreRows(*GenQInp,*GenQOut,*ContInxNew);}
  }
  writeLine("stdout","Number of files in *Coll outside size range *Sizemin to *Sizemax is *Count");
}
INPUT *Coll = "/tempZone/home/rods/sub1", *Sizemin = "1000000", *Sizemax = "1000000000"
OUTPUT ruleExecOut


# Function to identify private, shared, and fixed polymorphisms
# for all populations defined in a popmap and snp data in a structure
# formatted file.
# The structure file is a tab delimited matrix with all SNP data in columns
# and two rows for each diploid individual, and including a column
# for both the individual names and their a priori locality (not used in function).
# Missing data in the structure file should be 0 or a negative integer. Each base
# pair should be a unique positive integer.
# The popmap is a tab delimited file with the first column
# indicating the sample names, and the second column a unique
# number for each population.
#
# With this script in current working directory: source("polymorphisms.r")
polymorphisms <- function(file, popmap) {
	x <- read.table(file,sep="\t")
	inds <- read.table(popmap, sep="\t")
	pops <- unique(as.numeric(inds[,2]))

	# loop to calculate for each population
	for(a in pops) {

		# define population 1 and all others
		inds1 <- as.character(inds[inds[,2]==pops[a],1])
		inds2 <- as.character(inds[inds[,2]!=pops[a],1])

		# extract all the lines from the structure file
		# pertaining to each group
		names <- as.character(x[2:nrow(x),1])
		inds1 <- match(inds1,names)
		inds1 <- sort(c(inds1, (inds1 + 1)))
		inds2 <- match(inds2,names)
		inds2 <- sort(c(inds2, (inds2 + 1)))
		x.new <- x[2:nrow(x), 3:ncol(x)]
		inds1 <- x.new[inds1,]
		inds2 <- x.new[inds2,]

		# reset all counters
		shared <- 0
		fixed <- 0
		private <- 0
		mono <- 0
		nbi <- 0

		# loop for each snp to identify if fixed, shared, etc.
		for(b in 1:ncol(inds1)) {
			i1.rep <- inds1[,b]
			i2.rep <- inds2[,b]
			i1.rep <- i1.rep[i1.rep>0]
			i2.rep <- i2.rep[i2.rep>0]
			if(length(unique(c(i1.rep,i2.rep)))==2) {
				if(length(unique(i1.rep))==1 & length(unique(i2.rep))==1) {
					fixed <- fixed + 1
				}
				if(length(unique(i1.rep))>1 & length(unique(i2.rep))==1) {
					private <- private + 1
				}
				if(length(unique(i1.rep))>1 & length(unique(i2.rep))>1) {
					shared <- shared + 1
				}
			}
			if(length(unique(c(i1.rep,i2.rep)))==1) {
				mono <- mono + 1
			}
			if(length(unique(c(i1.rep,i2.rep)))>2) {
				nbi <- nbi + 1
			}
		}

		# print output to screen for each population
		writeLines(" ")
		writeLines(paste("Population", pops[a],sep=" "))
		writeLines(paste("Fixed Differences:", fixed))
		writeLines(paste("Shared Polymorphisms:", shared))
		writeLines(paste("Private Polymorphisms:", private))
		writeLines(paste("Monomorphic:", mono))
		writeLines(paste("More than two alleles:", nbi))

	}
}


library(rstan)
library(data.table)
library(gdata)
library(EnvStats)

setwd("~/git/covid19model")

## command line parsing if any
args <- list(
  stanModelFile= 'base_age_google_mobility_200427',
  seed= 42,
  chain= 1,
  job_tag= 'myfirstrun',
  cntct_by = 5,
  seedAge = 7L
)

## set other args
args$file_stanModel <- file.path('stan-models',paste0(args$stanModelFile,'.stan'))
args$file_serial_interval <- file.path('data','serial_interval.csv')
args$file_covariates <- file.path('data','interventions.csv')
args$file_contact <- file.path('data','contact_UK.rda') # with weekday weekend
args$file_pop_age <- file.path('data','popByAge.csv')
args$file_age_ifr <- file.path('data','ifr_age.csv')
args$file_google_mobility <- file.path('data','google-mobility.csv')
tmp <- Sys.getenv("PBS_JOBID")
args$job_id <- ifelse(tmp!='', tmp, as.character(abs(round(rnorm(1) * 1e6))) )
args$job_dir <- file.path("results",paste0(args$stanModelFile,'-',args$job_tag,'-',args$job_id))
args$DEBUG <- TRUE
args$path_to_cmdstan <- filepath("~/git/cmdstan")

## start script
cat(sprintf("Running\n"))
str(args)
set.seed(args$seed)

source(file.path("utils", "read-data.r"))
source(file.path("utils", "process-covariates.r"))

## make job dir
dir.create( args$job_dir )

## save input args
saveRDS( args, file=file.path(args$job_dir, paste0(basename(args$job_dir), '_args.RDS')))

# countries to investigate
countries <- read.csv('data/regions.csv', stringsAsFactors = FALSE)

## Reading all data
d <- read_obs_data(countries)

# Read ifr
ifr.by.country <- read_ifr_data()

#	read age-specific ifr
ifr.by.age = read.csv(args$file_age_ifr)

#	read contact rates
load(args$file_contact)

#	read age-specific pop counts
pop_by_age = read.csv(args$file_pop_age)

# Read interventions
covariates <- read_interventions(args$file_covariates)

# Read serial interval
serial.interval <- read.csv(args$file_serial_interval)

# read google mobility
google_mobility <- read.csv(args$file_google_mobility)

# Process covariates
forecast <- 0
N2 <- 90 # increase if you need more forecast

processed_data <- process_covariates_age( countries$Regions,
                                         google_mobility,
                                         d,
                                         ifr.by.country,
                                         ifr.by.age,
                                         serial.interval,
                                         pop_by_age,
                                         contact_tab,
                                         args$seedAge,
                                         N2,
                                         forecast)
stan_data = processed_data$stan_data
dates = processed_data$dates
deaths_by_country = processed_data$deaths_by_country
reported_cases = processed_data$reported_cases

## save image before running Stan
save.image( file=file.path(args$job_dir, paste0(basename(args$job_dir), '_stanin.RData')) )

# adapt format for cmdstan
stan_data$covariates_res = array(as.numeric(unlist(stan_data$covariates_res)), dim=c(stan_data$M, stan_data$N2, stan_data$P_RES))
stan_data$covariates_nonres = array(as.numeric(unlist(stan_data$covariates_nonres)), dim=c(stan_data$M, stan_data$N2, stan_data$P_NONRES))
stan_data$cntct_weekdays_mean = array(as.numeric(unlist(stan_data$cntct_weekdays_mean)), dim=c(stan_data$M, stan_data$A, stan_data$A))
stan_data$cntct_weekends_mean = array(as.numeric(unlist(stan_data$cntct_weekdays_mean)), dim=c(stan_data$M, stan_data$A, stan_data$A))

## run Stan
cat('\nRunning Stan... \n')
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
model <- stan_model(args$file_stanModel)

if(rstan){
  if(args$DEBUG) {
    fit <- sampling(model,data=stan_data,iter=10,warmup=5,chains=1,seed=args$seed,verbose=TRUE)
  } else {
    # uncomment the line below for a full run to replicate results and comment the second line below
    fit <- sampling(model,data=stan_data,iter=3000, warmup=2000, chains=1,seed=args$seed, thin=1, control = list(adapt_delta = 0.95, max_treedepth = 15))
    #fit = sampling(model,data=stan_data,iter=10,warmup=5,chains=1,seed=args$seed,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 10))
  }
}
if(cmdstan){
  set_cmdstan_path(args$path_to_cmdstan)

  if(args$DEBUG) {
    fit <- sampling(model,data=stan_data,iter=10,warmup=5,chains=1,seed=args$seed,verbose=TRUE)
  } else {
    # uncomment the line below for a full run to replicate results and comment the second line below
    fit <- sampling(model,data=stan_data,iter=3000, warmup=2000, chains=1,seed=args$seed, thin=1, control = list(adapt_delta = 0.95, max_treedepth = 15))
    #fit = sampling(model,data=stan_data,iter=10,warmup=5,chains=1,seed=args$seed,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 10))
  }
}

save(fit, file=file.path(args$job_dir, paste0(basename(args$job_dir), '_stanout.RData')) )


#' ta_comfort
#'
#' Calculate the temperature of thermal comfort requireed given other parameters and timing in hours.
#'
#' @param rh numeric    Relative humidity in percentage.
#' @param wind numeric  Wind speed in meter per second.
#' @param M numeric     Metabolic rate of the subject in Watt/mq.
#' @param iclo numeric Clothing level of subject in clo unit.
#' @param H numeric    Timimg in hours.
#' @return comfort temperature in degC
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  ta_comfort
#' @export
#'
#'
#'
#'

ta_comfort=function(rh,wind,M,iclo,H) {
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$assign("M", as.array(M))
                         ct$assign("iclo", as.array(iclo))
                         ct$assign("H", as.array(H))
                         ct$eval("var res=[]; for(var i=0, len=rh.length; i < len; i++){ res[i]=ta_comfort(rh[i],wind[i],M[i],iclo[i],H[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# wahpenayo at gmail dot com
# 2017-12-10
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taigabench')) {
  setwd('e:/porta/projects/taigabench')
} else {
  setwd('c:/porta/projects/taigabench')
}
source('src/scripts/r/functions.r')
readr.show_progress <- FALSE
#-----------------------------------------------------------------
dataset <- 'ontime'
problem <- 'classify'
response <- 'arr_delayed_15min'
dataf <- ontime.classify.data
dtest <- dataf(test.file(dataset=dataset))
suffixes <- c('32768','131072','524288','2097152','8388608','33554432')
#-----------------------------------------------------------------
bench(
  dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
  response=response,
  suffixes=suffixes,
  trainf=classify.h2o.randomForest,
  prefix='h2o')

bench(
  dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
  response=response,
  suffixes=suffixes,
  trainf=classify.xgboost.randomForest,
  prefix='xgboost')

bench(
  dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
  response=response,
  suffixes=suffixes,
  trainf=classify.xgboost.exact.randomForest,
  prefix='xgboost.exact')

bench(
  dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
  response=response,
  # crashes in 64gb at 1m
  suffixes=suffixes[1:min(3,length(suffixes))],
  trainf=classify.randomForest,
  prefix='randomForest')

bench(
  dataset=dataset,problem=problem,dataf=dataf,dtest=dtest,
  response=response,
  suffixes=suffixes,
  trainf=classify.randomForestSRC,
  prefix='randomForestSRC')

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