#Thematic script for hospitals; regional and top 5 (by total cases)

# GRAPH 1: ICU, top 5
png("plot/thematic/Top5_ICU.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$terapia_intensiva,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Hospitalized, ICU (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$terapia_intensiva, type = "l", lwd = 3, col = "blue")
lines(top_3$terapia_intensiva, type = "l", lwd = 3, col = "green")
lines(top_4$terapia_intensiva, type = "l", lwd = 3, col = "orange")
lines(top_5$terapia_intensiva, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 2: non-ICU, top 5
png("plot/thematic/Top5_nonICU.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$ricoverati_con_sintomi,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Hospitalized, non-ICU (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$ricoverati_con_sintomi, type = "l", lwd = 3, col = "blue")
lines(top_3$ricoverati_con_sintomi, type = "l", lwd = 3, col = "green")
lines(top_4$ricoverati_con_sintomi, type = "l", lwd = 3, col = "orange")
lines(top_5$ricoverati_con_sintomi, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 3: total hospitalized, top 5
png("plot/thematic/Top5_hosp.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$totale_ospedalizzati,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Hospitalized, total (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$totale_ospedalizzati, type = "l", lwd = 3, col = "blue")
lines(top_3$totale_ospedalizzati, type = "l", lwd = 3, col = "green")
lines(top_4$totale_ospedalizzati, type = "l", lwd = 3, col = "orange")
lines(top_5$totale_ospedalizzati, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 4: total deceased, top 5
png("plot/thematic/Top5_deceased.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$deceduti,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Deceased, total (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$deceduti, type = "l", lwd = 3, col = "blue")
lines(top_3$deceduti, type = "l", lwd = 3, col = "green")
lines(top_4$deceduti, type = "l", lwd = 3, col = "orange")
lines(top_5$deceduti, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 5: total swabs, top 5
png("plot/thematic/Top5_swabs.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$tamponi,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Swabs (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$tamponi, type = "l", lwd = 3, col = "blue")
lines(top_3$tamponi, type = "l", lwd = 3, col = "green")
lines(top_4$tamponi, type = "l", lwd = 3, col = "orange")
lines(top_5$tamponi, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 6: recovered, top 5
png("plot/thematic/Top5_recovered.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$dimessi_guariti,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Recovered (top 5 regions)", xaxt='n', lwd = 3)
lines(top_2$dimessi_guariti, type = "l", lwd = 3, col = "blue")
lines(top_3$dimessi_guariti, type = "l", lwd = 3, col = "green")
lines(top_4$dimessi_guariti, type = "l", lwd = 3, col = "orange")
lines(top_5$dimessi_guariti, type = "l", lwd = 3, col = "purple")
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()

# GRAPH 7: variaton, top 5
png("plot/thematic/Top5_delta.png", width = 2500, height = 1250, pointsize = 50)
plot(top_1$variazione_totale_positivi,type = "l", col = "red", xlab = "", ylab = "Cases", main = "Positive case variation (delta)", xaxt='n', lwd = 3)
lines(top_2$variazione_totale_positivi, type = "l", lwd = 3, col = "blue")
lines(top_3$variazione_totale_positivi, type = "l", lwd = 3, col = "green")
lines(top_4$variazione_totale_positivi, type = "l", lwd = 3, col = "orange")
lines(top_5$variazione_totale_positivi, type = "l", lwd = 3, col = "purple")
abline(h = 0, col = "black", lwd = 2)
legend("topleft", inset = .02, legend=c(top_1$denominazione_regione[[1]], top_2$denominazione_regione[[1]], top_3$denominazione_regione[[1]], top_4$denominazione_regione[[1]], top_5$denominazione_regione[[1]]), col=c("red", "blue", "green", "orange", "purple"), lty=1, cex=0.75, lwd = 4)
axis(1, at=1:day_count, labels=top_1$data, las = 2, cex.axis = font_y)
dev.off()


#' Randomly generated data in SPSS format with 1000 rows, 2 demographic variables, respondent weight variable
#' and 10 segmentation input variables. Variables are unlabelled.
"test_seg_unlabelled"


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))

file_extensions <- c(".png", ".pdf")

plot_theme <- theme(
    title = element_text(size = 9),
    axis.title = element_text(size = 9),
    legend.text = element_text(size = 7),
    legend.title = element_text(size = 9),
    legend.key.size = unit(0.5, "cm"),
    strip.text = element_text(size = 10),
    strip.background = element_rect(colour="black", fill="#fdfff4")
)

# Load data
file <- file.path("data", "lsa_distribution_full_results.tsv.gz")

lsa_cols <- readr::cols(
    input_data_type_full = readr::col_character(),
    dist = readr::col_double(),
    input_data_type = readr::col_character(),
    shuffled = readr::col_character(),
    assay = readr::col_character(),
    data_level = readr::col_character(),
    model = readr::col_character()
)

lsa_df <- readr::read_tsv(file, col_types = lsa_cols)
lsa_df$model <- factor(lsa_df$model, levels = c("Complete", "PCA", "vanilla", "beta", "mmd"))
lsa_df$model <- dplyr::recode(lsa_df$model, "vanilla" = "Vanilla VAE", "beta" = "Beta VAE", "mmd" = "MMD VAE")

print(dim(lsa_df))
head(lsa_df, 3)

panel_a_gg <- (
    ggplot(
        lsa_df %>%
            dplyr::filter(assay == 'cell-painting', data_level == 'level5'),
        aes(y = dist, x = model, color = shuffled)
    )
    + geom_point(size = 0.2, alpha = 0.5, position = position_jitterdodge())
    + geom_boxplot(aes(middle = mean(dist)), size = 0.2, alpha = 0.8, outlier.alpha = 0)
    + theme_bw()
    + plot_theme
    + ylab("L2 distance between\nreal 'A|B' and predicted 'A|B'")
    + xlab("")
    + scale_color_manual(
        "Data",
        values = c("Shuffled" = "#E66100", "Unshuffled" = "#5D3A9B"),
        labels = c("Shuffled" = "Shuffled", "Unshuffled" = "Real")
    )
    + ggtitle("Cell Painting - Level 5")
)

panel_b_gg <- (
    ggplot(
        lsa_df %>%
            dplyr::filter(assay == 'cell-painting', data_level == 'level4'),
        aes(y = dist, x = model, color = shuffled)
    )
    + geom_point(size = 0.2, alpha = 0.5, position = position_jitterdodge())
    + geom_boxplot(aes(middle = mean(dist)), size = 0.2, alpha = 0.8, outlier.alpha = 0)
    + theme_bw()
    + plot_theme
    + ylab("L2 distance between\nreal 'A|B' and predicted 'A|B'")
    + xlab("")
    + scale_color_manual(
        "Data",
        values = c("Shuffled" = "#E66100", "Unshuffled" = "#5D3A9B"),
        labels = c("Shuffled" = "Shuffled", "Unshuffled" = "Real")
    )
    + ggtitle("Cell Painting - Level 4")
)

panel_c_gg <- (
    ggplot(
        lsa_df %>%
            dplyr::filter(assay == 'L1000', data_level == 'level5'),
        aes(y = dist, x = model, color = shuffled)
    )
    + geom_point(size = 0.2, alpha = 0.5, position = position_jitterdodge())
    + geom_boxplot(aes(middle = mean(dist)), size = 0.2, alpha = 0.8, outlier.alpha = 0)
    + theme_bw()
    + plot_theme
    + ylab("L2 distance between\nreal 'A|B' and predicted 'A|B'")
    + xlab("Models")
    + scale_color_manual(
        "Data",
        values = c("Shuffled" = "#E66100", "Unshuffled" = "#5D3A9B"),
        labels = c("Shuffled" = "Shuffled", "Unshuffled" = "Real")
    )
    + ggtitle("L1000 - Level 5")
)

# Get legend
sup_fig_legend <- cowplot::get_legend(panel_a_gg)

# Combine figure together
sup_fig_gg <- (
    cowplot::plot_grid(
        cowplot::plot_grid(
            panel_a_gg + theme(legend.position = "none"),
            panel_b_gg + theme(legend.position = "none"),
            panel_c_gg + theme(legend.position = "none"),
            labels = c("a", "b", "c"),
            nrow = 3
        ),
        sup_fig_legend,
        rel_widths = c(1, 0.2),
        ncol = 2
    )
)

sup_fig_gg

# Save figure
output_file_base <- file.path("output", "sup_fig_lsa_distributions")
for (file_extension in file_extensions) {
    output_file <- paste0(output_file_base, file_extension)
    cowplot::save_plot(output_file, sup_fig_gg, dpi = 500, base_width = 6, base_height = 8)
}


library(fmsb)
library(phyloseq)
library(extrafont)

####
# Taken from: https://stackoverflow.com/questions/54185029/change-labels-colors-in-r-radarchart
# BGJ: Adapted to avoid overlap in top and bottom of peripherical labels
radarchart2 <- function (df, axistype = 0, seg = 4, pty = 16, pcol = 1:8, plty = 1:6,
                         plwd = 1, pdensity = NULL, pangle = 45, pfcol = NA, cglty = 3,
                         cglwd = 1, cglcol = "navy", axislabcol = "blue", vlabcol = "black", title = "",
                         maxmin = TRUE, na.itp = TRUE, centerzero = FALSE, vlabels = NULL,
                         vlcex = NULL, caxislabels = NULL, calcex = NULL, paxislabels = NULL,
                         palcex = NULL, ...)
{
  if (!is.data.frame(df)) {
    cat("The data must be given as dataframe.\n")
    return()
  }
  if ((n <- length(df)) < 3) {
    cat("The number of variables must be 3 or more.\n")
    return()
  }
  if (maxmin == FALSE) {
    dfmax <- apply(df, 2, max)
    dfmin <- apply(df, 2, min)
    df <- rbind(dfmax, dfmin, df)
  }
  plot(c(-1.2, 1.2), c(-1.2, 1.2), type = "n", frame.plot = FALSE,
       axes = FALSE, xlab = "", ylab = "", main = title, asp = 1,
       ...)
  theta <- seq(90, 450, length = n + 1) * pi/180
  theta <- theta[1:n]
  xx <- cos(theta)
  yy <- sin(theta)
  CGap <- ifelse(centerzero, 0, 1)
  for (i in 0:seg) {
    polygon(xx * (i + CGap)/(seg + CGap), yy * (i + CGap)/(seg +
                                                             CGap), lty = cglty, lwd = cglwd, border = cglcol)
    if (axistype == 1 | axistype == 3)
      CAXISLABELS <- paste(i/seg * 100, "(%)")
    if (axistype == 4 | axistype == 5)
      CAXISLABELS <- sprintf("%3.2f", i/seg)
    if (!is.null(caxislabels) & (i < length(caxislabels)))
      CAXISLABELS <- caxislabels[i + 1]
    if (axistype == 1 | axistype == 3 | axistype == 4 |
        axistype == 5) {
      if (is.null(calcex))
        text(-0.05, (i + CGap)/(seg + CGap), CAXISLABELS,
             col = axislabcol)
      else text(-0.05, (i + CGap)/(seg + CGap), CAXISLABELS,
                col = axislabcol, cex = calcex)
    }
  }
  if (centerzero) {
    arrows(0, 0, xx * 1, yy * 1, lwd = cglwd, lty = cglty,
           length = 0, col = cglcol)
  }
  else {
    arrows(xx/(seg + CGap), yy/(seg + CGap), xx * 1, yy *
             1, lwd = cglwd, lty = cglty, length = 0, col = cglcol)
  }
  PAXISLABELS <- df[1, 1:n]
  if (!is.null(paxislabels))
    PAXISLABELS <- paxislabels
  if (axistype == 2 | axistype == 3 | axistype == 5) {
    if (is.null(palcex))
      text(xx[1:n], yy[1:n], PAXISLABELS, col = axislabcol)
    else text(xx[1:n], yy[1:n], PAXISLABELS, col = axislabcol,
              cex = palcex)
  }
  #
  #print("theta:")
  #print(theta)
  #print("xx:")
  #print(xx)
  #print("yy:")
  #print(yy)
  #
  VLABELS <- colnames(df)
  polars1=(abs(yy)==1)
  polars2=((abs(yy)>=9.8e-01) & (abs(yy)!=1))
  notPolars=!as.logical(polars1 + polars2)
  if (!is.null(vlabels))
    VLABELS <- vlabels
  if (is.null(vlcex)){ # BGJ: 2020.04.07 (inspired by https://stackoverflow.com/questions/43403700/controlling-srt-in-text-to-work-selectively-in-r)
    text(1.2 * xx[polars1], 1.2 * (yy[polars1]+(yy[polars1]*0.05)), VLABELS[polars1], col = vlabcol, font=4, family='Times')
    if(sum(polars2)>0)
      text(1.2 * (xx[polars2]+xx[polars2]*0.25), 1.2 * (yy[polars2]+(yy[polars2]*0.02)), VLABELS[polars2], col = vlabcol, font=4, family='Times') # if rotate: ,srt=15
    text(1.2 * xx[notPolars], 1.2 * yy[notPolars], VLABELS[notPolars], col = vlabcol, font=4, family='Times')
    # text(xx * 1.2, yy * 1.2, VLABELS, col = vlabcol) # original
  }else{ #BGJ: 2020.04.07
    text(1.2 * xx[polars1], 1.2 * (yy[polars1]+(yy[polars1]*0.05)), VLABELS[polars1], cex = vlcex, col = vlabcol, font=4, family='Times')
    if(sum(polars2)>0)
      text(1.2 * (xx[polars2]+xx[polars2]*0.25), 1.2 * (yy[polars2]+(yy[polars2]*0.02)), VLABELS[polars2], cex = vlcex, col = vlabcol, font=4, family='Times') # if rotate: ,srt=15
    text(1.2 * xx[notPolars], 1.2 * yy[notPolars], VLABELS[notPolars], cex = vlcex, col = vlabcol, font=4, family='Times')
    #text(xx * 1.2, yy * 1.2, VLABELS, cex = vlcex, col = vlabcol)  # original
  }
  series <- length(df[[1]])
  SX <- series - 2
  if (length(pty) < SX) {
    ptys <- rep(pty, SX)
  }
  else {
    ptys <- pty
  }
  if (length(pcol) < SX) {
    pcols <- rep(pcol, SX)
  }
  else {
    pcols <- pcol
  }
  if (length(plty) < SX) {
    pltys <- rep(plty, SX)
  }
  else {
    pltys <- plty
  }
  if (length(plwd) < SX) {
    plwds <- rep(plwd, SX)
  }
  else {
    plwds <- plwd
  }
  if (length(pdensity) < SX) {
    pdensities <- rep(pdensity, SX)
  }
  else {
    pdensities <- pdensity
  }
  if (length(pangle) < SX) {
    pangles <- rep(pangle, SX)
  }
  else {
    pangles <- pangle
  }
  if (length(pfcol) < SX) {
    pfcols <- rep(pfcol, SX)
  }
  else {
    pfcols <- pfcol
  }
  for (i in 3:series) {
    xxs <- xx
    yys <- yy
    scale <- CGap/(seg + CGap) + (df[i, ] - df[2, ])/(df[1,
                                                         ] - df[2, ]) * seg/(seg + CGap)
    if (sum(!is.na(df[i, ])) < 3) {
      cat(sprintf("[DATA NOT ENOUGH] at %d\n%g\n", i,
                  df[i, ]))
    }
    else {
      for (j in 1:n) {
        if (is.na(df[i, j])) {
          if (na.itp) {
            left <- ifelse(j > 1, j - 1, n)
            while (is.na(df[i, left])) {
              left <- ifelse(left > 1, left - 1, n)
            }
            right <- ifelse(j < n, j + 1, 1)
            while (is.na(df[i, right])) {
              right <- ifelse(right < n, right + 1,
                              1)
            }
            xxleft <- xx[left] * CGap/(seg + CGap) +
              xx[left] * (df[i, left] - df[2, left])/(df[1,
                                                         left] - df[2, left]) * seg/(seg + CGap)
            yyleft <- yy[left] * CGap/(seg + CGap) +
              yy[left] * (df[i, left] - df[2, left])/(df[1,
                                                         left] - df[2, left]) * seg/(seg + CGap)
            xxright <- xx[right] * CGap/(seg + CGap) +
              xx[right] * (df[i, right] - df[2, right])/(df[1,
                                                            right] - df[2, right]) * seg/(seg +
                                                                                CGap)
            yyright <- yy[right] * CGap/(seg + CGap) +
              yy[right] * (df[i, right] - df[2, right])/(df[1,
                                                            right] - df[2, right]) * seg/(seg +
                                                                                CGap)
            if (xxleft > xxright) {
              xxtmp <- xxleft
              yytmp <- yyleft
              xxleft <- xxright
              yyleft <- yyright
              xxright <- xxtmp
              yyright <- yytmp
            }
            xxs[j] <- xx[j] * (yyleft * xxright - yyright *
                                 xxleft)/(yy[j] * (xxright - xxleft) -
                                            xx[j] * (yyright - yyleft))
            yys[j] <- (yy[j]/xx[j]) * xxs[j]
          }
          else {
            xxs[j] <- 0
            yys[j] <- 0
          }
        }
        else {
          xxs[j] <- xx[j] * CGap/(seg + CGap) + xx[j] *
            (df[i, j] - df[2, j])/(df[1, j] - df[2,
                                                 j]) * seg/(seg + CGap)
          yys[j] <- yy[j] * CGap/(seg + CGap) + yy[j] *
            (df[i, j] - df[2, j])/(df[1, j] - df[2,
                                                 j]) * seg/(seg + CGap)
        }
      }
      if (is.null(pdensities)) {
        polygon(xxs, yys, lty = pltys[i - 2], lwd = plwds[i -
                                                            2], border = pcols[i - 2], col = pfcols[i -
                                                                                2])
      }
      else {
        polygon(xxs, yys, lty = pltys[i - 2], lwd = plwds[i -
                                                            2], border = pcols[i - 2], density = pdensities[i -
                                                                                2], angle = pangles[i - 2], col = pfcols[i -
                                                                                2])
      }
      points(xx * scale, yy * scale, pch = ptys[i - 2],
             col = pcols[i - 2])
    }
  }
}
####

# Author: Beatriz Garcia-Jimenez
build_physeq_object <- function(fotu,fmap,ftax){
  otumat <- read.table(fotu,sep='\t',row.names=1,header=TRUE,check.names=FALSE)
  OTU = otu_table(otumat, taxa_are_rows = TRUE)

  mapmat <- read.table(fmap,sep='\t',row.names=1,header=TRUE)
  MAP = sample_data(mapmat)

  taxmat <- read.table(ftax,sep='\t',row.names=1,header=TRUE)
  colnames(taxmat) = c("Kingdom", "Phylum", "Class", "Order", "Family", "Genus", "Species")
  taxmat=as.matrix(taxmat)
  TAX = tax_table(taxmat)

  phyObj = phyloseq(OTU, MAP, TAX)

  return(phyObj)
}
###

plot_radarchart_several_taxaLevels <- function(physeq_pred_sub,suffix0){
  for(tax_rank in c("Phylum","Class")){
    suffix=paste(suffix0,tax_rank,sep='_')
    #plot_bar(physeq_pred_sub, fill=tax_rank)
    physeq_rank <- tax_glom(physeq_pred_sub, taxrank = tax_rank)

    # Translate taxa ID to taxa understandable name
    dic_taxa_names=tax_table(physeq_rank)[,tax_rank]
    for(i in seq(1,length(taxa_names(physeq_rank)))){
      id=taxa_names(physeq_rank)[i]
      #taxa=unlist(strsplit(dic_taxa_names[id],'__'))[2]
      taxa=gsub('bacteria-','bact.',dic_taxa_names[id])
      #taxa=dic_taxa_names[id]
      taxa_names(physeq_rank)[i]=taxa
    }

    df=as.data.frame(t(otu_table(physeq_rank)))
    df=df[, order(names(df))]
    write.table(df , paste('otus_predFromDomain_novelSamples_withTaxaNames_',suffix,'.tsv',sep=''), sep="\t", row.names = TRUE, col.names = NA)

    # Plot Radar Chart
    # To use the fmsb package, I have to add 2 lines to the dataframe: the max and min of each topic to show on the plot!
    min=0
    max=round(max(df),2)
    max_perc=max*100
    max_axis=(max_perc+(5-(max_perc%%5)))/100 # To avoid rare numbers in graph
    labels_central_axis=seq(max_axis,0,-(round(max_axis/4,2)))
    labels_central_axis[5]=round(0,0)
    data <- rbind(rep(min,length(df)) , rep(max_axis,length(df)) , df)

    colors_v=c(rgb(0.8,0.2,0.5,0.9), rgb(0.2,0.5,0.5,0.9), rgb(0.7,0.5,0.1,0.9))
    pdf(paste('../Results/NovelEcosystems/radarChart_otus_predFromDomain_novelSamples_',suffix,'.pdf',sep=''))
    par(xpd=NA)         # Allow plotting outside the plot region
    #par(family='Times',font=3,font.main=2,font.axis=1)
    radarchart2(data,
               axistype=1,
               #custom polygon
               pcol=colors_v,
               plwd=3, plty=3, pty=19,
               #custom the grid
               cglcol="grey88", cglty=1, axislabcol="black",
               # Reverse axis labeling
               caxislabels=labels_central_axis,
               cglwd=0.8,
               vlcex=0.9,
               title=paste('Relative abundances in different conditions.',suffix0)
    )
    legend(x=-1, y=1.48, legend = c('actual','hot and dry','cold and wet'), bty = "n", horiz=TRUE, pch=20 , col=colors_v, cex=1.2, pt.cex=3)
    dev.off()
    embed_fonts(paste('../Results/NovelEcosystems/radarChart_otus_predFromDomain_novelSamples_',suffix,'.pdf',sep=''))
  } # end-for
} # end-function
###
# Alternative: To rotate labels: ggradar: ggplot extension for radar graph: https://rpubs.com/updragon/ggradar
###

file_tax = '../Datasets/tax_table_all_80_cleanNames.csv'
physeq_pred = build_physeq_object('../Results/otus_predFromDomain_novelSamples.tsv','../Datasets/metadata_novel_samples_only3envFeatures.csv',file_tax)

# To generate predictions for different ages
for(age in c(seq(1,15),20)){
  # To select samples to represent in radar graph by age
  print(age)
  physeq_pred_sub = prune_samples(get_variable(physeq_pred,'age') == age, physeq_pred)
  suffix0=paste('Age',age,sep='')

  plot_radarchart_several_taxaLevels(physeq_pred_sub,suffix0)
}

system('pdfjam --nup 4x4 --papersize {300mm,300mm} --pdftitle \'All ages\' --outfile radarChart_otus_predFromDomain_novelSamples_AgeAll_Class.pdf -- radarChart_otus_predFromDomain_novelSamples_Age1_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age2_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age3_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age4_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age5_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age6_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age7_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age8_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age9_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age10_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age11_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age12_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age13_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age14_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age15_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age20_Class.pdf')

system('pdfjam --nup 4x4 --papersize {300mm,300mm} --pdftitle \'All ages\' --outfile radarChart_otus_predFromDomain_novelSamples_AgeAll_Phylum.pdf -- radarChart_otus_predFromDomain_novelSamples_Age1_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age2_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age3_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age4_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age5_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age6_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age7_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age8_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age9_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age10_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age11_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age12_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age13_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age14_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age15_Phylum.pdf - radarChart_otus_predFromDomain_novelSamples_Age20_Phylum.pdf')

system('pdfjam --nup 3x1 --papersize {225mm,75mm} --pdftitle \'Age evolution\' --outfile radarChart_otus_predFromDomain_novelSamples_AgeEvol_Class.pdf -- radarChart_otus_predFromDomain_novelSamples_Age4_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age7_Class.pdf - radarChart_otus_predFromDomain_novelSamples_Age20_Class.pdf')


test_that("works with numeric", {
  x <- c(0, 100)
  expect_equal(fullseq(x, 50), c(0, 50, 100))
})

test_that("works with POSIXct", {
  x <- as.POSIXct(c("2000-01-01 08:29:58", "2000-01-01 08:30:10"), tz = "UTC")

  expect_equal(
    fullseq(x, "1 hour"),
    as.POSIXct(c("2000-01-01 8:00:00 UTC", "2000-01-01 9:00:00 UTC"), tz = "UTC")
  )
  expect_equal(
    fullseq(x, ".5 secs")[1:2],
    as.POSIXct(c("2000-01-01 08:29:58.0 UTC", "2000-01-01 08:29:58.5 UTC"), tz = "UTC")
  )
})

test_that("works with Date", {
  x <- as.Date("2012-01-01") + 1:30
  expect_equal(fullseq(x, "1 month"), as.Date(c("2012-01-01", "2012-02-01")))
})

test_that("works with hms/difftime", {
  x <- hms::hms(hours = 0:1)
  y <- as.difftime(c(0, 1800, 3600), units = "secs")
  expect_equal(fullseq(x, 1800), y)
  expect_equal(fullseq(x, "30 mins"), y)

  # Preserves units
  x <- as.difftime(c(0, 1), units = "hours")
  expect_equal(fullseq(x, 1800), as.difftime(c(0, 0.5, 1), units = "hours"))
})


library( "rmacrolite" )

# # Setup MACRO directory (if needed)
# rmacroliteSetModelVar( "C:/swash/macro" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Fetch one parameter (here percent of organic matter in
#   each soil layer
oc <- rmacroliteGet1Param(
    x    = par_file,
    pTag = "ORGC\t%s\t%s",
    type = "PROPERTIES" )

oc

    # [1] "1.39" "0.93" "0.7"  "0.3"  "0.3"  "0.27"
    # attr(,"layer")
    # [1] "1" "2" "3" "4" "5" "6"
    # attr(,"index")
    # [1] 133 134 135 136 137 138

#   The function does not know which parameters are numeric
#   and which are character, the output may need to be
#   manually converted:
as.numeric( oc )
    # [1] 1.39 0.93 0.70 0.30 0.30 0.27

#   Clean-up
rm( par_file_path, par_file, oc )


#' Crée un pavage carré en tant que géométrie d'un sf à partir de idINS.
#'
#' @param ids vecteur d'idINS.
#' @param resolution resolution, par défaut celle attachée à idINS.
#'
#'
#' @import sf
#' @export
idINS2square <- function(ids, resolution=NULL)
{
  cr_pos <- stringr::str_locate(ids[[1]], "r(?=[0-9])")[,"start"]+1
  cy_pos <- stringr::str_locate(ids[[1]], "N(?=[0-9])")[,"start"]+1
  cx_pos <- stringr::str_locate(ids[[1]], "E(?=[0-9])")[,"start"]+1
  lcoord <- cx_pos-cy_pos-1
  y <- as.numeric(stringr::str_sub(ids,cy_pos,cy_pos+lcoord))
  x <- as.numeric(stringr::str_sub(ids,cx_pos,cx_pos+lcoord))
  r <- if(is.null(resolution))
    as.numeric(stringr::str_sub(ids,cr_pos,cy_pos-cr_pos))
  else
    rep(resolution, length(x))
  purrr::pmap(list(x,y,r), ~sf::st_polygon(
    list(matrix(
      c(..1, ..1+..3,..1+..3,..1, ..1,
        ..2, ..2, ..2+..3,..2+..3,..2),
      nrow=5, ncol=2))))  |>
    st_sfc(crs=3035)
}

#' Récupère les coordonnées X et Y de idINS.
#'
#' @param ids vecteur d'idINS.
#' @param resolution resolution, par défaut celle attachée à idINS.
#'
#' @export
idINS2point <- function(ids, resolution=NULL)
{
  cr_pos <- stringr::str_locate(ids[[1]], "r(?=[0-9])")[,"start"]+1
  cy_pos <- stringr::str_locate(ids[[1]], "N(?=[0-9])")[,"start"]+1
  cx_pos <- stringr::str_locate(ids[[1]], "E(?=[0-9])")[,"start"]+1
  lcoord <- cx_pos-cy_pos-1
  y <- as.numeric(stringr::str_sub(ids,cy_pos,cy_pos+lcoord))
  x <- as.numeric(stringr::str_sub(ids,cx_pos,cx_pos+lcoord))
  r <- if(is.null(resolution))
    as.numeric(stringr::str_sub(ids,cr_pos,cy_pos-cr_pos))
  else
    rep(resolution, length(x))
  m <- matrix(c(x+r/2,y+r/2), ncol=2)
  colnames(m) <- c("X", "Y")
  m
}

#' Crée idINS à partir de coordonnées.
#'
#' @param x Ou un vecteur de la coordonnée x, ou un df avec les colonnes x et y.
#' @param y vecteur de la coordonnée y, si nécessaire. NULL par défaut.
#' @param resolution resolution, par défaut 200.
#' @param resinstr faut-il inscrire la résolution dans idINS ? Par défaut TRUE.
#'
#' @export
idINS3035 <- function(x, y=NULL, resolution=200, resinstr=TRUE)
{
  if(is.null(y))
  {
    y <- x[,2]
    x <- x[,1]
  }
  resolution <- round(resolution)
  x <- formatC(floor(x / resolution )*resolution, format="d")
  y <- formatC(floor(y / resolution )*resolution, format="d")
  resultat <- if(resinstr)
    paste0("r", resolution, "N", y, "E", x)
  else
    paste0("N", y, "E", x)

  nas <- which(is.na(y)|is.na(x))
  if (length(nas)>0) resultat[nas] <- NA

  resultat
}

#' Crée un raster de référence, vide.
#'
#' @param data sf.
#' @param resolution par défaut, 200.
#' @param crs par défaut, 3035 (European Terrestrial Reference System).
#'
#' @import sf
#' @export
raster_ref <- function(data, resolution=200, crs=3035)
{
  alignres <- max(resolution, 200)
  if(checkmate::testMultiClass(data,c("sf", "sfc")))
  {
    b <- st_bbox(data)
    crss <- st_crs(data)$proj4string
  }
  else
  {
    stopifnot("x"%in%names(data)&"y"%in%names(data))
    b <- list(xmin=min(data$x, na.rm=TRUE),
              xmax=max(data$x, na.rm=TRUE),
              ymin=min(data$y, na.rm=TRUE),
              ymax=max(data$y, na.rm=TRUE))
    crss <- sp::CRS(st_crs(crs)$proj4string)
  }
  ext <- raster::extent(floor(b$xmin / alignres )*alignres,
                        ceiling(b$xmax/alignres)*alignres,
                        floor(b$ymin/alignres)*alignres,
                        ceiling(b$ymax/alignres)*alignres)
  raster::raster(ext, crs=crss,  resolution=resolution)
}

#' Récupère la résolution dans idINS.
#'
#' @param dt data.table ou df.
#' @param idINS variable contenant idINS, par défaut, idINS.
getresINS <- function(dt, idINS="idINS") {
  purrr::map(
    purrr::keep(names(dt), ~ stringr::str_detect(.x, idINS)),
    ~{
      r <- stringr::str_extract(dt[[.x]], "(?<=r)[0-9]+") |> as.numeric()
      ur <- unique(r)
      if (length(ur)==0)
        list(idINS=.x, res=NA_integer_)
      else
        list(idINS=.x, res=ur)
    })
}

#' Crée un raster à partir d'un data.table avec idINS.
#'
#' @param dt data.table avec idINS.
#' @param resolution résolution du raster.
#' @param idINS nom de la variable idINS, par défaut "idINS".
#'
#' @import data.table
#' @import sf
#'
#' @export
dt2r <- function(dt, resolution=NULL, idINS="idINS")
{
  dt <- setDT(dt)
  rr <- getresINS(dt, idINS)
  ncol <- names(dt)
  if(length(rr)==0)
    idINSin <- FALSE
  else
  {
    if(!is.null(resolution))
      isresin <- purrr::map_lgl(rr, ~.x[["res"]]==resolution)
    else
      isresin <- c(TRUE, rep(FALSE, length(rr)-1))
    if(any(isresin))
    {
      res <- rr[which(isresin)][[1]]$res
      idINS <-rr[which(isresin)][[1]]$idINS
      idINSin <- TRUE
    }
    else
      idINSin <- FALSE
  }
  if (!idINSin)
  {
    stopifnot(!is.null(res))
    stopifnot("x" %in% ncol & "y" %in% ncol)
    dt[, idINS:=idINS3035(x,y,resolution=resolution)]
    idINS <- "idINS"
    res <- resolution
  }
  xy <- idINS2point(dt[[idINS]], resolution = res)
  dt[, `:=`(x=xy[,1], y=xy[,2])]
  rref <- raster_ref(dt, resolution = res, crs=3035)
  cells <- raster::cellFromXY(rref, xy)
  layers <- purrr::keep(ncol, ~(is.numeric(dt[[.x]]))&(!.x%in%c("x","y")))
  brickette <- raster::brick(
    purrr::map(layers,
               ~{
                 r <- raster::raster(rref)
                 r[cells] <- dt[[.x]]
                 r
               }))
  names(brickette) <- layers
  raster::crs(brickette) <- 3035
  brickette
}

#' Mise en forme des nombres (vient de f.communs)
#'
#' @param number nombre à mettre en forme
#' @param rounding logique. TRUE par défaut.
#' @param digits nombre de chiffre après la virgule.
#' @param unit méthode de choix de l'unité ("median" par défaut)
#'

f2si2 <- function(number, rounding = TRUE, digits = 1, unit = "median") {
  lut <- c(
    1e-24, 1e-21, 1e-18, 1e-15, 1e-12, 1e-09, 1e-06,
    0.001, 1, 1000, 1e+06, 1e+09, 1e+12, 1e+15, 1e+18, 1e+21,
    1e+24
  )
  pre <- c(
    "y", "z", "a", "f", "p", "n", "u", "m", "", "k",
    "M", "G", "T", "P", "E", "Z", "Y"
  )
  ix <- ifelse(number!=0, findInterval(number, lut) , 9L)
  ix <- switch(unit,
               median = median(ix, na.rm = TRUE),
               max = max(ix, na.rm = TRUE),
               multi = ix
  )
  if (rounding == TRUE)
    scaled_number <- round(number/lut[ix], digits)
  else
    scaled_number <- number/lut[ix]

  sistring <- paste0(scaled_number, pre[ix])
  sistring[scaled_number==0] <- "0"
  return(sistring)
}

#' Mise en forme du temps
#'
#' @param temps temps en secondes
second2str <- function(temps) {
  temps <- round(temps)
  jours <- temps %/% (3600 * 24)
  temps <- temps %% (3600 * 24)
  heures <- temps %/% 3600
  temps <- temps %% 3600
  minutes <- temps %/% 60
  secondes <- temps %% 60
  s <- character(0)
  if (jours > 0) {
    s <- stringr::str_c(jours, "j ")
  }
  if (heures > 0) {
    s <- stringr::str_c(s, heures, "h ")
  }
  if (minutes > 0) {
    s <- stringr::str_c(s, minutes, "m ")
  }
  if (secondes > 0) {
    s <- stringr::str_c(s, secondes, "s")
  }
  stringr::str_replace(s, " $", "")
}

#' Projette un raster RGB
#'
#' En procédant à une interpolation, la projection simple d'un raster
#' produit un raster avec des valeurs non entières même si l'input
#' est composé de composantes RGB et entière (0-255)
#' La fonction projette donc dans un système de coordonnées
#' et rebase et arrondi les différentes couches.
#'
#' @param rgb le raster en entrée
#' @param crs le système de coordonnées en sortie
#'
#' @return un raster RGB projetté dans
#' @export
#'
projectrgb <- function(rgb, crs="3035", res=200) {
  maxs <- raster::cellStats(rgb, max)
  mins <- raster::cellStats(rgb, min)
  rgbp <- raster::projectRaster(from=rgb, res=res, crs=sp::CRS(glue::glue("EPSG:{crs}"))) # la projection fait un truc bizarre sur les entiers
  maxp <- raster::cellStats(rgbp, max)
  minp <- raster::cellStats(rgbp, min)
  rgbp <- round((rgbp-minp)/(maxp-minp)*(maxs-mins) + mins)
  rgbp
}


openJulesExperimentSet <- function(name, JULES_control, JULES_experiments,
                                   ..., grab_cache = TRUE) {
    temp_file = paste0('temp/plot_jules_diff_from_control_new', name, '.Rd')
    if (file.exists(temp_file) & grab_cache) {
	load(temp_file)
    } else {
	Jules_TC_control = openJulesTree(JULES_control, JULES_dir, ...)
	Jules_PFTs       = openJulesTree(JULES_control, JULES_dir, splitPFTs = TRUE, ...)

    Jules_BA_control = openJulesTree(JULES_control, JULES_dir, 1,
                                 "burnt_area_gb", yrs = yrs) *   60 * 60 * 24 * 365
	Jules_BA_exp     = layer.apply(JULES_experiments, openJulesTree, JULES_dir, 1,
                                 "burnt_area_gb", yrs = yrs) *   60 * 60 * 24 * 365

	Jules_BA_control = raster::resample(Jules_BA_control, Jules_TC_control)
	Jules_BA_exp     = raster::resample(Jules_BA_exp    , Jules_TC_control)
	Jules_TC_exp     = layer.apply(JULES_experiments, openJulesTree, JULES_dir, ...)

	Jules_dout = (Jules_TC_control - Jules_TC_exp)/Jules_TC_control
	Jules_dout =  squeeze(Jules_dout, 500)

	save(Jules_TC_control, Jules_BA_control, Jules_BA_exp, Jules_TC_exp, Jules_dout, Jules_PFTs,
             Jules_PFTs, file = temp_file)
    }
    return(list(Jules_TC_control, Jules_TC_exp, Jules_BA_control, Jules_BA_exp, Jules_dout, Jules_PFTs))
}


\name{fastplm}
\alias{fastplm}
\title{Solve Fixed Effect Model}

\description{\code{fastplm} solves a fixed effects model or a 2SLS regression with fixed effects.}

\usage{fastplm(data = NULL, formula = NULL,
			   index = NULL, y = NULL,
			   x = NULL, z = NULL,
			   ind = NULL, sfe = NULL,
			   cfe = NULL, PCA = TRUE,
			   sp = NULL, knots = NULL,
			   degree = 3, se = 1,
			   vce = "robust", cluster = NULL,
			   wild = TRUE, refinement = FALSE,
			   test_x = NULL, parallel = TRUE,
			   nboots = 200, seed = NULL,
			   core.num = 1, drop.singletons = TRUE,
			   bootcluster = NULL, iv.test = TRUE,
			   first = FALSE, orthog = NULL,
			   endog = NULL)}

\arguments{

  \item{data}{An object of class "dataframe" or "matrix". If both \code{formula}
   and \code{y} are omitted, the first column of \code{data} will be regarded
   as the vector of outcome variable and other columns will be regarded as
   regressors. If both \code{data} and \code{y} present, \code{data} is omitted.}

  \item{formula}{An object of class "formula": a symbolic description of
   the model to be fitted. If it has the form "Y~1",
   the function merely estimates fixed effects.}

  \item{index}{A string vector specifying the indicators. Omissible if
   \code{formula} is omitted.}

  \item{y}{The Y matrix. Omissible if \code{formula} is provided.}

  \item{x}{The X matrix. Omissible if \code{formula} is provided.
   If \code{X} are not provided and \code{formula} is absent,
   the model is still valid. In such case,
   the function merely estimates fixed effects. }

  \item{z}{A string vector of the names of all exogenous variables
  (both of excluded IVs and included IVs) if \code{formula} is present.
   It can also be a matrix of all exogenous variables if
   \code{formula} is absent. }

  \item{ind}{A matrix where each row corresponds to the row (observation) in the
    X-Y dataset and each column represents an effect. The entry of row X of effect
    Y represents the group in Y that X belongs to.
    Groups can be specified by either numbers or strings,
	i.e. the input matrix can be of mode \code{numeric} or \code{character}. }

  \item{sfe}{A vector index of simple (additive) fixed effects.
    Each can be specified either by effect name or position as in \code{index} or
    by the position in the indicator matrix \code{ind}.
	If omitted, \code{sfe} will be the collection of all effects in
    \code{index} or \code{inds}. }

  \item{cfe}{A list index of complex fixed effects.

    Specifically, an complex fixed effect is a generalized fixed effect.
	It consists a pair of two effects, (I, E), interacting with each other.
	"I" stands for influence, whose level has an observed vector \code{weight}.
	"E" stands for effect, whose level has an unobserved vector \code{coefficient}
	to estimate. For each observation,
	the effect of (I, E) is the dot product of the weight of the row's
    level for "I" and the coefficient of the row's level for "E".

    Each element is a vector whose length is 2. The 1st item of each element is the
    index of effect and the 2nd item is the index of influence. For index, see
    \code{sfe}.

    If omitted, complex fixed effects will not be estimated.

  }

  \item{PCA}{A logical flag indicating whether to perform principal
	components analysis for influence in complex fixed effects (see \code{cfe}).}

  \item{sp}{A character value or a numeric vector specifying the variable for
    fitting a b-spline curve.}

  \item{knots}{A numeirc value specifying the knots point for \code{sp}. If
    left blank, a polynomial curve will be fitted by default.}

  \item{degree}{A positive integer speficying the order of the spline curve.
    Default value is \code{degree = 3} for a cubic curve.}

  \item{se}{A logical flag indicating whether uncertainty estimates of
    covariates will be produced. For 2sls regressions, all diagnostic tests will
	not be conducted if \code{se = FALSE}.}

  \item{vce}{A character value indicating type for variance estimator.
    Choose from: "standard" for standard ols standard errors, "robust" for
    the Huber White robust standard errors (default value), "clustered" (or "cl")
    for clustered standard errors, "jackknife" for jackknife standard errors,
    and "bootstrap" (or "boot") for bootstrapped standard errors.}

  \item{cluster}{A character value of the clustered variable(s) in the data frame if
    \code{formula} is provided or a matrix object of the clustered variable(s) for
    clustered standard error or clustered bootstrap.
	Two-way clustering is also supported. }

  \item{wild}{A logical flag specifies if wild bootstrap will be performed to obtain
    uncertainty estimates. Omissible if \code{se = FALSE}.
	Default to TRUE for computational efficiency.}

  \item{refinement}{A logical flag specifies if bootstrap refinement will be
    performed to obtain uncertainty estimates. Omissible if \code{se = FALSE}.
	Default to FALSE.}

  \item{test_x}{A character specifies the variable of interest for wild
    bootstrap refinement. Omissible if \code{refinement = FALSE} or
    \code{wild = FALSE}. When \code{wild = TRUE}, if \code{test_x = NULL},
	an unrestricted wild bootstrap will be conducted, otherwise,
	a restricted wild bootstrap will be performed. Default to NULL.}

  \item{parallel}{A logical flag indicating whether to perform parallel
	computing for the bootstrap procedure. Default to TRUE.}

  \item{nboots}{An integer specifying the number of bootstrap
    runs. Omissible if \code{se = FALSE}.}

  \item{seed}{An integer that sets the seed in random number generation.
    Omissible if \code{se = FALSE}.}

  \item{core.num}{The number of cores that will be used for computation.
	Default is one. Larger number of cores can improve the speed moderately.}

  \item{drop.singletons}{A logical flag indicating whether to drop
    singletons(groups with only one observation). Default to TRUE.
	The program can report the number of singletons it detects and return a vector
	\code{drop.index} noting the indices of dropped observations.}

  \item{bootcluster}{A character value specifying the level of bootstrap in
	two-way clustered bootstrap refinement.
	Must be one of the names of \code{cluster}.}

  \item{iv.test}{A logical flag indicating whether to conduct diagnostic tests
	for 2SLS regressions, including weak IV tests, exogeneity tests,
	and endogeneity tests. Default to TRUE. Omissible if \code{se=FALSE} or
	\code{vce="bootsrap" or "jackknife"}.}

  \item{first}{A logical flag indicating whether to compute partial F statistics,
	Sanderson-Windmeijer (SW) F statistics and Angrist and Pischke (AP) F statistics
	for first stage regression for 2SLS estimation. Default to FALSE.}

  \item{orthog}{A character value(s) specifying the exogenous variables whose exogeneity
   is to be tested. A C-statistic will be calculated in this case. Default to NULL.}

  \item{endog}{A character value(s) specifying the endogenous variables whose endogeneity
   is to be tested. A C-statistic will be calculated in this case. Default to NULL.}

}

\value{An object of class \code{fastplm} with at least the following properties:

  \item{demeaned}{A list represents the demeaned linear model. It has, among other
    properties, \code{x} and \code{y}, which are the demean result of the input
    \code{x} and \code{y}.}

  \item{coefficients}{The coefficients for the demeaned linear model.}

  \item{sfe.coefs}{A list of estimated simple fixed effects. Each is a column
    vector, in which row names correspond to names of levels in \code{inds}. Each, as
    a list item, has the same name as its effect name in \code{inds}. Each vector is
    centered, i.e. set to have zero mean.}

  \item{cfe.coefs}{A list of estimated complex fixed effects. Each is a matrix in
    which each row represents a level. The naming convention is the same as in
    \code{sfe.coefs}. There is no centering. Expect an arbitrary intercept.}

  \item{fitted.values}{The fitted values of the fixed effect model.}

  \item{residuals}{The residuals of the fixed effect model, which is numerically the
    same as the residual of the demeaned linear model.}

  \item{intercept}{The intercept of the fixed effect model. Arbitrary if complex fixed
    effects are present.}

  \item{est.coefficients}{The estimated coefficients, standard errors and confidence intervals.}

  \item{vcov}{The estimated variance-covariance matrix of estimated coefficients.}

  \item{R2}{Multiple R-squared(original model).}

  \item{Adj_R2}{Adjusted multiple R-squared(original model).}

  \item{projR2}{Multiple R-squared(demeaned model).}

  \item{projAdj_R2}{Adjusted multiple R-squared(demeaned model).}

  \item{RMSE}{Root Mean Square Error.}

  \item{proj_F_statistic}{F-statistic.}

  \item{variance.type}{Type of standard errors and vcov matrices.}

  \item{num.singletons}{Number of singletons(groups with only one observation) the program detected.}

  \item{drop.index}{The original index of dropped singletons.}

  \item{inds}{As in the input.}

  \item{fe}{An object of "fixed.effects" created for intermediate computing.}

  \item{df.residual}{Degree of freedom.}

  \item{dof}{A list that stores the number of categories and the number of
	redundant categories in each level of fixed effects.}

  \item{refinement}{A list that restores results from wild/pairwise bootsrap refinement.}

  \item{tests}{Only for 2SLS regressions, stores the results of diagnostic tests.}

  \item{ols.model}{Only for 2SLS regressions, stores the results of the simple
	ols regression (only regress y on x).}

  \item{reduce.model}{Only for 2SLS regressions, stores the results of the reduced-form
	ols regression (regress y on all exogenous variables z).}

  \item{names}{Only for 2SLS regressions, stores the names of excluded instruments and
	included instruments.}

}

\examples{
data(fastplm)
out <- fastplm(y~x1+x2, index = c("country", "industry", "year"),
               data = simdata1,
               se = TRUE)
}


## Change point 2D Histograms
library(tidyverse)

cdata=read_csv("changepoint.csv")

plot_fn <- function(wide,fn){
  sampler_list=c("FD_T_10","FD_T_25","FD_T_50","FD_T_100","FD_T_250","FD_T_500","FD_CensusSeries")
  year_list = unique(wide$splityear)

  pdf(paste0("",fn),width=35,height=20)
  par(mfrow=c(length(sampler_list)+1,length(year_list)+1))
  par(mar=c(2.5,1,2,2))
  plot.new()
  plot.window(c(0,1),c(0,1))
  for(j in year_list){
    plot.new()
    plot.window(c(0,1),c(0,1))
    text(0.5,0.5,700-j,cex=3)
  }
  mini_sampler_list=c("10","25","50","100","250","500","Census")
  idx=1
  for(j in sampler_list){
    plot.new()
    plot.window(c(0,1),c(0,1))
    text(0.5,0.5,mini_sampler_list[idx],cex=3,srt=90)
    idx=idx+1
    for(i in year_list){
      this_frame = filter(wide,splityear == i & sampler == j)
      cd = this_frame$changedetection-i
      co=cd[is.finite(cd)]
      ii=sum(abs(co)<25)

      if(ii>20){
        tcol="red"
      }else{
        tcol="grey50"
      }
      hist(cd,main="",xlab="",xlim=c(-200,200),ylim=c(0,35),breaks=seq(-612,612,25),col=tcol,xaxt="n",yaxt="n")
      axis(1,at=c(-200,0,200),labels=c(-200,0,200),cex.axis=2)
      axis(2,at=c(0,35),labels=c(0,35),cex.axis=2)
      abline(v=-25,lty=2)
      abline(v=25,lty=2)
    }
  }
  dev.off()
}

# Narrow
narrow <- cdata %>% filter(file=="Narrow" & !grepl("_R_",sampler)) %>% group_by(sampler,splityear)
plot_fn(narrow,"Fig4.pdf")

wide <- cdata %>% filter(file=="Wide" & !grepl("_R_",sampler)) %>% group_by(sampler,splityear)
plot_fn(wide,"Fig5.pdf")


## Usage: Rscript this.r <output_prefix> <merged.stat.txt> [pos_range] [colname_prefix]

options(stringsAsFactors=FALSE)

library(rjags)

`%.%` <- function(x,y) paste0(x,y)

join = function(sep, vec, ...) paste(collapse=sep, c(vec, ...))
cat0 = function(...) cat(sep="", ...)

echo_str <- function(x, sep=" =\t", collapse=", ") deparse(substitute(x)) %.% sep %.% join(collapse, x)
echo <- function(x, sep=" =\t", collapse=", ") cat0(deparse(substitute(x)), sep, join(collapse, x), "\n");

str_trim_left = function(str, trimLen){
	strlen = nchar(str)
	start = pmin(strlen, trimLen) + 1
	end = strlen
	substr(str, start, end)
}
str_trim_right = function(str, trimLen){
	strlen = nchar(str)
	start = 1
	end = pmax(0, strlen - trimLen)
	substr(str, start, end)
}
str_left = function(str, len){
	strlen = nchar(str)
	start = 1
	end = pmin(len, strlen)
	substr(str, start, end)
}
str_right = function(str, len){
	strlen = nchar(str)
	start = pmax(1, strlen - len + 1)
	end = strlen
	substr(str, start, end)
}

Yyx_one_group_prop = function(group_DF, n_chains=2, iter_n=100000, burnin=60000, plot_var_names="mu", should_trace=TRUE, should_density=TRUE){
	init_list = NULL
	model = jags.model(file="hierarchical_Bayesian_model_jags_SHM_test.20190819/Yyx_HierarPropBinom_JAGS_single.20190820.txt", data=list(y=group_DF$Mut, n=group_DF$Total, sampleNum=nrow(group_DF)), inits=init_list, n.chains=n_chains, quiet=TRUE, n.adapt=burnin)
	model.samples <- coda.samples(model, c("mu", "eta", "theta"), n.iter=iter_n, progress.bar="none")
	if(should_trace || should_density){
		plot(model.samples[, plot_var_names], trace=should_trace, density=should_density)
	}
	model.samples
}

args = commandArgs(TRUE)
if(length(args) < 2){
	stop("Usage: Rscript this.r <output_prefix> <merged.stat.txt> [pos_range] [colname_prefix]")
}

output_prefix = args[1]
input_filename = args[2]

pos_range = NULL
if(length(args) >= 3){
	pos_range = args[3]
	tmp = as.integer(strsplit(pos_range, "[:-]")[[1]])
	if(length(tmp)==1){
		# good, do nothing
	}else if(length(tmp)==2){
		pos_range = tmp[1]:tmp[2]
	}else{
		stop("Cannot recognize pos_range = " %.% pos_range)
	}
}

colname_prefix = ""
if(length(args) >= 4){
	colname_prefix = args[4]
}
colname_prefix_nchar = nchar(colname_prefix)

cat("Now read in input " %.% input_filename %.% " file ...\n")
all_DF = read.delim(input_filename)
echo(dim(all_DF))
NR = nrow(all_DF)
if(is.null(pos_range)){
	pos_range = 1:NR
}
pos_range = pos_range[pos_range >= 1 & pos_range <= NR]

cat("Now model each site ...\n")
in_Mut_colidx     = which(str_left(names(all_DF), colname_prefix_nchar+4) == colname_prefix %.% "Mut.")
in_Total_colidx = which(str_left(names(all_DF), colname_prefix_nchar+6) == colname_prefix %.% "Total.")

pdf(output_prefix %.% "." %.% min(pos_range) %.% "_" %.% max(pos_range) %.% ".trace_density.pdf", width=9, height=9)

all_DF$mu_mean = NA
all_DF$mu_LB = NA
all_DF$mu_UB = NA
for(i in pos_range){
	echo(i)
	group_DF = data.frame(Total=unlist(all_DF[i, in_Total_colidx]), Mut=unlist(all_DF[i, in_Mut_colidx]))

	try(silent=FALSE, {
		mcmc_rlt = Yyx_one_group_prop(group_DF, plot_var_names=c("mu", "eta"))
		write.table(as.matrix(mcmc_rlt), file=output_prefix %.% ".site_" %.% i %.% ".mcmc_rlt.tsv", row.names=FALSE, sep="\t", quote=FALSE)
	})
}

dev.off()


# Setup
source('2019-06-19-jsa-type-ch2/init/init_a.r')

# Parameters
theme <- theme_minimal()

# Script
print(paste0(Sys.time(), " --- Visualising results"))

####### Load data

# Load data

# Original data
data_raw <- read.csv(paste0(dir_model_folder, "data.csv"), na.strings=c(""))

# R data
data <- read_rdump(paste0(dir_model_folder, "count_info.data.R"))

# Load zero inflated fits
load(paste0(dir_model_folder, "fit.data"))       # as "fit"
zips <- fit; rm(fit)

# Load posterior simulation
load(paste0(dir_model_folder, "post.data"))      # as "allsim"

# Load forecast predictions
load(paste0(dir_model_folder, "forecast.data"))  # as "forecast"

# Map model indices to original variables
mapping <- unique(data.frame(
    groupname=as.character(data_raw$group),
    group=as.numeric(data_raw$group)
))

####### Check for chain convergence

# Filter for chains that did not mix
badchain <- summary(zips)$summary %>%
    data.frame(par = row.names( . ), . ) %>%
    filter(Rhat > 1.1 | Rhat < 0.9)

# write warning output
if (nrow(badchain) > 0) {

    interpret <- FALSE
    sink(paste0(dir_model_folder, "output/chain_sampling.txt"))
    cat("Chains have not converged. Increase interations in sampling in stan() function
        call in code/model.r. Do not interpret model results as parameter estimates are
        currently highly unstable.")
    sink()

} else {

    interpret <- TRUE
    sink(paste0(dir_model_folder, "output/chain_sampling.txt"))
    cat("Chains have converged. Model results are robust to posterior sampling.")
    sink()

}

####### Prepare cumulative series

# Cumulative series for observed data

cumm <- lapply(seq(data$P), function(ii) { # each group
    data.frame(index = 1:data$end[ii],                    # index (offset "year")
               value = data$counts[ii, ],                 # count
               cml_value = cumsum(data$counts[ii, ]),     # cumulative
               off = data$off[ii, ],                      # tax. effort
               group = ii)}) %>%                          # group (e.g. "family")
    rbind.fill

cumm$sim <- 0 # set sim to 0 to indicate that it is observed data

# Cumulative series for simmed data

cummsim <- lapply(seq(length(allsim)), function(jj) { # each sim
    lapply(seq(data$P), function(ii) { # each group
        data.frame(index = 1:data$end[ii],
                   value = allsim[[jj]][[ii]],
                   cml_value = cumsum(allsim[[jj]][[ii]]),
                   off = data$off[ii, ],
                   group = ii,
                   sim = jj)}) %>%
        rbind.fill
    }) %>%
    rbind.fill

# Combine the observed and simmed series
Z <- rbind(cumm, cummsim)

# Add original year back
Z$year <- Z$index + min(data_raw$year) - 1

####### Summarise model results
sum_y <- Z %>%
  filter(sim != 0 & index == max(index)) %>% # last observation
  group_by(group) %>%
  dplyr::summarize(med = median(cml_value),
                   lower = quantile(cml_value, probs=0.1),
                   upper = quantile(cml_value, probs=0.9))

obs_count <- Z %>%
  filter(sim == 0 & index == max(index)) %>% # sim==0 is observed data
  group_by(group) %>%
  dplyr::summarize(count = cml_value)

# outs$delta[, ,2] is the coefficient that estimates the long-term trend in
# description rate, it's in log units, i.e. need to exponentiate it

# where 0 means stable trend, positive means increasing description
# through time and negative is decreasing...

# `coef` is an array where
# [posterior sample [1:N samples], group number[1:N groups], coefficient[1:2]]
coef <- rstan::extract(zips, par = "delta")[[1]]

group.cf1 <- apply(coef, 1, function(i) i[, 1])
group.cf2 <- apply(coef, 1, function(i) i[, 2])

# get mean and 80 CI
mean_cf2 <- data.frame(
    provid = 1:nrow(group.cf2),
    slowdown = apply(group.cf2, 1, mean)
)

CI80_cf2 <- data.frame(
    provid = 1:nrow(group.cf2),
    slowdown = t(apply(
        group.cf2, 1, quantile, probs = c(0.1, 0.9)
    ))
)

# compile results into table
results <- data.frame(
    group = mapping[match(as.numeric(rownames(obs_count)), mapping[, 2]), 2],
    groupname = mapping[match(as.numeric(rownames(obs_count)), mapping[, 2]), 1],
    observed_species = obs_count$count,
    expected_median = round(sum_y$med, 0),
    expected_CI_lower = round(sum_y$lower, 0),
    expected_CI_higher = round(sum_y$upper, 0),
    slowdown = round(signif(mean_cf2$slowdown, 3), 4),
    slowdown_CI_lower = round(signif(CI80_cf2[, 2], 3), 4),
    slowdown_CI_higher = round(signif(CI80_cf2[, 3], 3), 4),
    row.names=NULL
) %>%
    arrange(slowdown)

# compile results of lambda (poisson parameter)
lambda <- lapply(seq(data$P), function(ii) { # for each group

    cf1 <- group.cf1[ii, ]
    cf2 <- group.cf2[ii, ]
    time <- 1:data$end[ii]
    duration <- max(time) - rev(time)

    cPair <- lapply(1:length(cf1), function(kk) { # for each coefficient pair
        b0 <- cf1[kk]
        b1 <- cf2[kk]
        lam <- exp(b0 + b1 * time)
        cbind(time=duration, lam, group=ii, sim=kk)
    })

    res <- data.frame(do.call(rbind, cPair))
    res

}) %>%
rbind.fill

# Add original year back
lambda$year <- lambda$time + min(data_raw$year)

####### Plot model fit

obs <- Z %>% filter(sim == 0)   # subset to observed series

# Set up plotting data for group panels
sims <- filter(Z, sim!=0) %>% # subset a sample of simmed series
    split( . , .$group) %>%   # group by group
    lapply( . , function(oo){ # for each group
        ids <- sample(unique(oo$sim), 200)
        oo[ oo$sim %in% ids, ]
    }) %>%
rbind.fill

# Only keep sims less that 4 times the max observed value and with the max year
goodsims <-
    filter(sims, year == max(year) & cml_value < max(obs$cml_value)*4) %>%
    dplyr::select(group, sim)

sims <- inner_join(sims, goodsims, by=c("group", "sim"))
rm(goodsims)

# Set up facet labels
labels <- as.character(mapping$groupname)
names(labels) <- mapping$group

# Plot cumulative counts
print("Plotting cumulative_fit.pdf")

P <- ggplot() +
    geom_path(data=sims, aes(x=year, y=cml_value, group=sim),
              col="skyblue2", alpha=0.1) +
    geom_path(data=obs, aes(x=year, y=cml_value)) +
    facet_wrap(~group, scales="fixed", labeller=as_labeller(labels)) +
    ylab("Number of species") +
    xlab("Year") + theme

ggsave(P, file = paste0(dir_model_folder, "output/cumulative_fit.pdf"),
       width = 10, height = 6)

# Plot per year counts
print("Plotting count_fit.pdf")

P <- ggplot() +
    geom_path(data=sims, aes(x=year, y=value, group=sim),
              col="skyblue2", alpha=0.1) +
    geom_path(data=obs, aes(x=year, y=value)) +
    facet_wrap(~group, scales="free_y", labeller=as_labeller(labels)) +
    ylab("Number of species") +
    xlab("Year") +
    theme

ggsave(P, file = paste0(dir_model_folder, "output/count_fit.pdf"),
       width = 10, height = 6)

# Set up plotting data for long-term trends
sims <- filter(lambda, sim!=0) %>%   # subset only simulated series
    split(., .$group) %>%            # by group
    lapply(., function(oo){          # for each group
        ids <- sample(unique(oo$sim), 200)
        oo[oo$sim %in% ids, ]
    }) %>%
rbind.fill

# Mean line per group
mu_sim <- sims %>%
    group_by(group, year) %>%
    dplyr::summarize(mu=mean(lam)) %>%
    data.frame()

# Plot long term trends
print("Plotting regression.pdf")
P <- ggplot() +
    geom_path(data=obs, aes(x=year, y=(value/(off+1)))) +
    geom_line(data=sims, aes(x=year, y=lam, group=sim),
              col="skyblue2", alpha=0.1) +
    geom_line(data=mu_sim, aes(x=year, y=mu), col="royalblue") +
    facet_wrap(~group, scales="free_y", labeller=as_labeller(labels)) +
    ylab("Number of species") +
    xlab("Year") +
    theme

ggsave(P, file = paste0(dir_model_folder, "output/regression.pdf"),
       width = 10, height = 6)

rm(P)

####### Summarise forecast

print("Generating output.csv table")

# Cumulative series for sampled data
nc <- ncol(data$counts)
len_fc <- length(forecast[[1]][[1]])
min_year <- min(data_raw$year)
index <- ((nc + 1):(nc + len_fc)) + (min_year - 1)

forsim <- lapply(seq(length(forecast)), function(jj) { # each sim
    lapply(seq(data$P), function(ii) { # each group
        data.frame(
            index=index,
            value=cumsum(forecast[[jj]][[ii]]),
            group=ii,
            sim=jj
        )
    }) %>%
    rbind.fill
}) %>%
rbind.fill

# for each group and each sim, find the mean and CI of cumsums
fore.table <- split(forsim, forsim$group) %>% # by group
    lapply(., function(gg) { # for each group
        group <- unique(gg$group)
        vv <- lapply(split(gg, gg$sim), function(oo) { # for each sim
            cs <- max(oo$value)
            oo[nrow(oo), ]$value <- cs
            oo[nrow(oo), ]
        }) %>% rbind.fill
        fore.mu <- round(mean(vv$value), 0) +               # summarize mean expected
            max(obs[obs$group == group, "cml_value"])       # add to currents counts
        fore.lower <- round( quantile(vv$value, 0.1), 0) +  # summarize lower expected
            max(obs[obs$group == group, "cml_value"])       # add to currents counts
        fore.upper <- round( quantile(vv$value, 0.9), 0) +  # summarize upper expected
            max(obs[obs$group == group, "cml_value"])       # add to currents counts
        data.frame(group=group, fore.mu, fore.lower, fore.upper)
    }) %>%
rbind.fill

# Merge to Results table
final_results <- merge(results, fore.table, by="group") %>%
    arrange(desc(observed_species))
write.csv(final_results, file = paste0(dir_model_folder,"output/results.csv"),
          row.names = FALSE)

# Remove variables to free up memory
rm(final_results)
rm(obs, sims, mu_sim, forsim)
rm(zips, mapping)


#devtools::test("asremlPlus")
context("prediction_presentation3")
asr3.lib <- "D:\\Analyses\\R oldpkg"

cat("#### Test for sort.alldiffs on Smarthouse with asreml3\n")
test_that("sort.alldiffs_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml, lib.loc = asr3.lib)
  library(asremlPlus)
  library(dae)
  data(Smarthouse.dat)

  #Set up without any sorting
  m1.asr <- asreml(y1 ~ Genotype*A*B,
                   random=~Replicate/Mainplot/Subplot,
                   data=Smarthouse.dat)
  testthat::expect_equal(length(m1.asr$gammas),4)
  current.asrt <- as.asrtests(m1.asr)
  current.asrt <- rmboundary(current.asrt)
  m <- current.asrt$asreml.obj
  testthat::expect_equal(length(m$gammas),3)

  diffs <- predictPlus(m, classify = "Genotype:A:B",
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none")
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_true(validAlldiffs(diffs))
  testthat::expect_equal(nrow(diffs$predictions),120)
  testthat::expect_equal(ncol(diffs$predictions),8)
  testthat::expect_equal(as.character(diffs$predictions$Genotype[1]),"Axe")
  testthat::expect_equal(length(attributes(diffs)),8)
  testthat::expect_true(is.null(attr(diffs, which = "sortOrder")))

  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))

  #Test sort in plotPredictions
  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title"),
                                          sortFactor = "Genotype"))

  #Test sort.alldiffs and save order for use with other response variables
  diffs.sort <- sort(diffs, sortFactor = "Genotype")
  sort.order <- attr(diffs.sort, which = "sortOrder")
  testthat::expect_is(diffs.sort, "alldiffs")
  testthat::expect_equal(nrow(diffs.sort$predictions),120)
  testthat::expect_equal(ncol(diffs.sort$predictions),8)
  testthat::expect_equal(as.character(diffs.sort$predictions$Genotype[1]),"Gladius")
  testthat::expect_equal(length(attributes(diffs.sort)),10)
  testthat::expect_equal(length(attr(diffs.sort, which = "sortOrder")),10)

  #Test sort.alldiffs with supplied sortOrder
  m2.asr <- asreml(y2 ~ Genotype*A*B,
                   random=~Replicate/Mainplot/Subplot,
                   data=Smarthouse.dat)
  testthat::expect_equal(length(m1.asr$gammas),4)
  current.asrt <- as.asrtests(m2.asr)
  diffs2.sort <- predictPlus(m2.asr, classify = "Genotype:A:B",
                             wald.tab = current.asrt$wald.tab,
                             error.intervals = "Stand", tables = "none",
                             sortFactor = "Genotype",
                             sortOrder = sort.order)
  testthat::expect_equal(as.character(diffs.sort$predictions$Genotype[1]),
                         as.character(diffs2.sort$predictions$Genotype[1]))
  testthat::expect_equal(attr(diffs.sort, which = "sortOrder"),
                         attr(diffs2.sort, which = "sortOrder"))

  #Test sort.alldiffs with sortParallelToCombo and increasing order
  diffs1.sort <- sort(diffs, sortFactor = "Genotype",
                      sortParallelToCombo = list(A = "N3", B = "D4"),
                      decreasing = TRUE)
  testthat::expect_is(diffs1.sort, "alldiffs")
  testthat::expect_equal(as.character(diffs1.sort$predictions$Genotype[2]),"Wyalkatchem")
  testthat::expect_equal(length(attr(diffs1.sort, which = "sortOrder")), 10)
  #Check plot
  testthat::expect_silent(plotPredictions(data = diffs1.sort$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title"),
                                          sortFactor = "Genotype"))
})

cat("#### Test for sort.alldiffs on Oats with asremls\n")
test_that("sort.alldiffs_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml, lib.loc = asr3.lib)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  testthat::expect_equal(length(m1.asr$gammas),3)
  current.asrt <- as.asrtests(m1.asr)

  #Test for as.alldiffs
  Var.pred <- asreml:::predict.asreml(m1.asr, classify="Nitrogen:Variety",
                                      sed=TRUE)$predictions
  wald.tab <-  current.asrt$wald.tab
  den.df <- wald.tab[match("Variety", rownames(wald.tab)), "denDF"]
  Var.diffs <- as.alldiffs(predictions = Var.pred$pvals,
                           sed = Var.pred$sed,
                           tdf = den.df)
  testthat::expect_equal(length(attributes(Var.diffs)),3)
  testthat::expect_null(attr(Var.diffs, which = "sortOrder"))

  #Test for allDifferences
  Var.diffs <- allDifferences(predictions = Var.pred$pvals,
                              classify = "Nitrogen:Variety",
                              sed = Var.pred$sed, tdf = den.df,
                              sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(length(attr(Var.diffs, which = "sortOrder")),3)

  #Test for predictPlus no sorting
  diffs <- predictPlus(m1.asr, classify = "Nitrogen:Variety",
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none")
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_equal(nrow(diffs$predictions),12)
  testthat::expect_equal(ncol(diffs$predictions),7)
  testthat::expect_equal(as.character(diffs$predictions$Variety[1]),"Victory")
  testthat::expect_equal(length(attributes(diffs)),8)
  testthat::expect_true(is.null(attr(diffs, which = "sortOrder")))

  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify ="Nitrogen:Variety",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))
  #TestPlot with sort
  testthat::expect_silent(plotPvalues(diffs, gridspacing = 3,
                                      sortFactor = "Variety", decreasing = TRUE))

  #Test for sort.alldiffs
  diffs.sort <- sort(diffs, sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(diffs.sort$predictions$Variety[1]),"Marvellous")
  testthat::expect_silent(plotPvalues(diffs.sort, gridspacing = 3))

  #Test for predictPresent
  mx.asr <- asreml(Yield ~ xNitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)

  testthat::expect_equal(length(mx.asr$gammas),3)
  current.asrt <- as.asrtests(mx.asr)
  print(current.asrt)

  diffs <- predictPresent(mx.asr, terms = "xNitrogen:Variety",
                          x.num = "xNitrogen", x.fac = "Nitrogen",
                          x.pred.values = sort(unique(Oats.dat$xNitrogen)),
                          wald.tab = current.asrt$wald.tab,
                          error.intervals = "Stand", tables = "none",
                          sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_is(diffs[[1]], "alldiffs")
  testthat::expect_equal(nrow(diffs[[1]]$predictions),12)
  testthat::expect_equal(ncol(diffs[[1]]$predictions),7)
  testthat::expect_equal(as.character(diffs[[1]]$predictions$Variety[[1]]),"Marvellous")
  testthat::expect_equal(length(attributes(diffs$xNitrogen.Variety)),10)
  testthat::expect_equal(length(attr(diffs[[1]], which = "sortOrder")),3)

  #Test for predictPlus with sortFactor
  diffs <- predictPlus(mx.asr, classify = "xNitrogen:Variety",
                       x.num = "xNitrogen", x.fac = "Nitrogen",
                       x.pred.values = sort(unique(Oats.dat$xNitrogen)),
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none",
                       sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_equal(nrow(diffs$predictions),12)
  testthat::expect_equal(ncol(diffs$predictions),7)
  testthat::expect_equal(as.character(diffs$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(length(attributes(diffs)),10)
  testthat::expect_true(all(attr(diffs, which = "sortOrder") ==
                              levels(diffs$predictions$Variety)))
  testthat::expect_true(all(attr(diffs, which = "sortOrder") ==
                              c("Marvellous","Golden Rain", "Victory")))
  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify ="xNitrogen:Variety",
                                          x.num = "xNitrogen", x.fac = "Nitrogen",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))
  testthat::expect_silent(plotPvalues(diffs, gridspacing = 3))

})

cat("#### Test for sort in standard order for classify on Oats with asreml3\n")
test_that("classify.sort_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml, lib.loc = asr3.lib)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  testthat::expect_equal(length(m1.asr$gammas),3)
  current.asrt <- as.asrtests(m1.asr)

  #Test for as.alldiffs
  Var.pred <- asreml:::predict.asreml(m1.asr, classify="Variety:Nitrogen",
                                      sed=TRUE)$predictions
  wald.tab <-  current.asrt$wald.tab
  den.df <- wald.tab[match("Variety", rownames(wald.tab)), "denDF"]
  Var.diffs <- as.alldiffs(predictions = Var.pred$pvals,
                           sed = Var.pred$sed,
                           tdf = den.df)
  testthat::expect_equal(length(attributes(Var.diffs)),3)
  testthat::expect_true(is.null(attr(Var.diffs, which = "sortOrder")))
  #asreml-R3 does not ensure that factors are in the same order as the classify -
  #they are in the same order as the term in asreml call
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Nitrogen","Variety")))

  #Test for allDifferences without sortFactor
  Var.diffs <- allDifferences(predictions = Var.pred$pvals,
                              classify = "Variety:Nitrogen",
                              sed = Var.pred$sed, tdf = den.df)
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Variety","Nitrogen")))
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[1]),"Victory")

  #TestPlot with sort
  testthat::expect_silent(plotPvalues(Var.diffs, gridspacing = 4))

  #Test for allDifferences with sortFactor
  Var.diffs <- allDifferences(predictions = Var.pred$pvals,
                              classify = "Variety:Nitrogen",
                              sed = Var.pred$sed, tdf = den.df,
                              sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Variety","Nitrogen")))
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(length(attr(Var.diffs, which = "sortOrder")),3)

  #TestPlot with sort
  testthat::expect_silent(plotPvalues(Var.diffs, gridspacing = 3,
                                      sortFactor = "Variety", decreasing = TRUE))

  #Test for sort.alldiffs
  diffs <- allDifferences(predictions = Var.pred$pvals,
                          classify = "Variety:Nitrogen",
                          sed = Var.pred$sed, tdf = den.df)
  diffs.sort <- sort(diffs, sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(diffs.sort$predictions$Variety[1]),"Marvellous")
  testthat::expect_silent(plotPvalues(diffs.sort, gridspacing = 3))

})


library("rjson")

#' Read in the data required to run the covid map models.
#' Loads basic data from opt$data_directory.
#' Loads cases data from opt$results_directory, ensuring that results and the case
#' counts used to create them are coupled.
#' Loads single area approximation results from opt$results_directory/singlearea in
#' order to run more complex models.
covidmap_read_data = function(env) {
  with(env,{

    readdata = function(filename,...) {
      read.csv(sprintf('%s/%s.csv',opt$data_directory,filename),...)
    }
    readresults = function(filename,...) {
      read.csv(sprintf('%s/%s.csv',opt$results_directory,filename),...)
    }
    # bootstrap merge needs to read singelarea data but folder structure is different.
    if (opt$bootstrap_merge) {
      readsinglearea = function(filename,...) {
        read.csv(sprintf('%s/bootstrap_1/singlearea/%s.csv',opt$results_directory,filename),...)
      }
    } else {
      readsinglearea = function(filename,...) {
        read.csv(sprintf('%s/singlearea/%s.csv',opt$results_directory,filename),...)
      }
    }

    #########################################################
    # Read infection profile data
    Tip <- 30
    Aip <- opt$Aip
    Bip <- opt$Bip
    print(paste("Generation interval gamma shape parameter: ", Aip))
    print(paste("Generation interval gamma rate parameter: ", Bip))
    infprofile <- pgamma(1:Tip,shape=Aip,rate=Bip)
    infprofile <- infprofile/infprofile[Tip]
    infprofile <- infprofile - c(0.0,infprofile[1:(Tip-1)])
    D <- length(infprofile)

    # Compute the testing delay profile
    Tdp <- 21
    presymptomdays <- 2
    Tdpnz <- Tdp - presymptomdays
    Adp <- opt$Adp
    Bdp <- opt$Bdp
    print(paste("Incubation period lognormal logmean parameter: ", Adp))
    print(paste("Incubation period lognormal logstd parameter: ", Bdp))
    testdelayprofile <- plnorm(1:Tdpnz,meanlog=Adp,sdlog=Bdp)
    testdelayprofile <- testdelayprofile/testdelayprofile[Tdpnz]
    testdelayprofile <- testdelayprofile - c(0.0,testdelayprofile[1:(Tdpnz-1)])
    testdelayprofile <- c(rep(0, presymptomdays), testdelayprofile)

    # Read non-temporal data about areas
    df <- readdata("areas",row.names=1)
    N <- nrow(df)
    areas <- rownames(df)
    quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))
    geoloc <- df[,1:2]
    population <- df[,3]

    # NHS region data
    sparse_region <- df[,-3:-1, drop=FALSE]
    N_region <- ncol(sparse_region)
    region_df <- readdata("nhs_regions", row.names=1)
    regions <- rownames(region_df)
    quoted_regions <- sapply(regions,function(s) paste('"',s,'"',sep=''))

    # Read on precomputed distances between region centres.
    geodist <- readdata("distances",row.names=1)
    colnames(geodist) <- areas

    # Read case data from the results folder. This ensures that the case data
    # and results are generasted from are saved together
    cases <- readresults("cases")
    ind <- sapply(cases[,2], function(s)
        !(s %in% c('Outside Wales','Unknown','...17','...18'))
    )
    cases <- cases[ind,]
    AllCount <- cases[,3:ncol(cases)]
    Tall <- ncol(AllCount)
    dates <- as.Date(colnames(AllCount), format='X%Y.%m.%d')
    colnames(AllCount) <- dates
    rownames(AllCount) <- areas

    # All methods except the singlearea approximation require the results of a
    # singlearea approximation to compute. If we are running such a method, load
    # a particular sample from the related singlearea results, run on the same cases
    # data.
    if (identical(opt$approximation, "regional") | identical(opt$approximation, "twostage")) {
      if (opt$singlearea_sample_id>0) {
        sample_id = opt$singlearea_sample_id
        Clean_latent = readsinglearea(paste('Clatent_sample',sample_id,sep=''),
          row.names=1)
        Clean_recon = readsinglearea(paste('Crecon_sample',sample_id,sep=''),
          row.names=1)
        print(paste(
         'Using samples from ',
         opt$singlearea_directory,'/Clatent_sample',sample_id,'.csv',
         sep=''
        ))
      } else {
        Clean_latent <- readsinglearea('Clatent_median', row.names=1)
        Clean_recon <- readsinglearea('Crecon_median', row.names=1)
        print(paste(
          'Using samples from ',
          opt$singlearea_directory,'/Clatent_median',
          sep=''
        ))
      }

      # Read data about how to split UK into regions to model for full model
      js = fromJSON(file=sprintf('%s/%s',opt$data_directory,"region-groupings.json")) ### TODO FIX
      inferred_region = sparse_region
      modelled_region = 0*sparse_region
      for (i in 1:opt$num_regions) {
        modelled_region[js[[i]],i]=1
      }
      stopifnot(all(inferred_region<=modelled_region))
    }

    # Load traffic flux data between regions
    traffic_flux <- array(0, dim=c(N,N,2))
    traffic_flux[,,1] <- data.matrix(readdata('traffic_flux_row-normed', row.names=1))
    traffic_flux[,,2] <- data.matrix(readdata('traffic_flux_transpose_row-normed', row.names=1))
    colnames(traffic_flux) <- areas
    rownames(traffic_flux) <- areas

    # Load alternative commuter flow data for intra region flux
    alt_traffic_flux <- array(0, dim=c(N,N,2))
    alt_traffic_flux[,,1] <- data.matrix(readdata('uk_forward_commute_flow', row.names=1))
    alt_traffic_flux[,,2] <- data.matrix(readdata('uk_reverse_commute_flow', row.names=1))
    colnames(alt_traffic_flux) <- areas
    rownames(alt_traffic_flux) <- areas

  if (opt$regions_as_areas_stage1) {
    # df <- readdata("nhs_regions", row.names=1)
    cases <- readresults("region_cases")
    N <- nrow(cases)
    areas <- cases[, 2]
    quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))
    AllCount <- cases[,3:ncol(cases)]
    Tall <- ncol(AllCount)
    dates <- as.Date(colnames(AllCount), format='X%Y.%m.%d')
    colnames(AllCount) <- dates
    rownames(AllCount) <- areas
  }

  })
  # If desired, limit the number of regions used in the computation based on a central region
  # and a radius around it.
  if (!is.null(env$opt$limit_area) && !is.null(env$opt$limit_radius)) {
    source("sandbox/limit_data.r")
    limit_data_by_distance(env, env$opt$limit_area, env$opt$limit_radius)
    print("Limited data to areas:")
    print(env$areas)
  }
  env
}


fn.cd38 = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_cd38_ge_sig_score_subjects.txt")
fn.pb = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_PB.DC_SLEDAI_corr_score.txt")

df.cd38 = fread(fn.cd38)
df.pb = fread(fn.pb)

PG.group.names = c("SLE patients with plasmablast\nsignature during flare", "Other SLE patients")

df = full_join(df.cd38, df.pb, by="SUBJECT") %>%
  dplyr::filter(!is.na(PG)) %>%
  mutate(PG = ifelse(PG %in% 2:3, PG, "Other")) %>%
  mutate(PG = factor(PG)) %>%
  mutate(PG.group = ifelse(PG %in% 2:3, PG.group.names[1], PG.group.names[2])) %>%
  mutate(PG.group = factor(PG.group, levels=PG.group.names))

cc = df %>% dplyr::filter(PG %in% 2:3) %>%
  cor.test(~ CD38_score_mean + PB_SLEDAI_corr_score, data=., method="spearman")

p = ggplot(df %>% dplyr::filter(PG %in% 2:3), aes(CD38_score_mean, PB_SLEDAI_corr_score)) +
  geom_point(aes(fill=PB_SLEDAI_corr_score), size=3, shape=21, col="white") +
  scale_fill_gradient2(low = "blue", mid="grey", high="red", name = "DaCP", midpoint = 0) +
  geom_hline(yintercept=0) + geom_vline(xintercept=0) + theme_bw() + theme(legend.key = element_blank()) +
  xlab("Mean Baseline score at low DA") +
  ylab("DaCP") +
  theme_bw()
p
fn.fig = file.path(PROJECT_DIR, "figure_generation", "SLE_DaCP_vs_TGSig_col.DaCP_PG23")
ggsave(paste0(fn.fig,".png"), w=4.5, h=3.2)
ggsave(paste0(fn.fig,".pdf"), w=4.5, h=3.2, useDingbats=F)

par.cur = par()

ths = df$PB_SLEDAI_corr_score[!is.na(df$PB_SLEDAI_corr_score) & !is.na(df$CD38_score_mean) & df$PG %in% 2:3] %>% unique() %>% sort()
ths = ths[1:(length(ths)-2)]
cc = rep(NA, length(ths))
pv = cc
nn = cc
meth = "pearson"
for(i in seq_along(ths)){
  ith = !is.na(df$PB_SLEDAI_corr_score) & !is.na(df$CD38_score_mean) & df$PB_SLEDAI_corr_score >= ths[i] & (df$PG %in% 2:3)

  nn[i] = sum(ith)
  if(sum(!is.na(df$PB_SLEDAI_corr_score[ith]))<3 | sum(!is.na(df$CD38_score_mean[ith]))<3) next()

  cc[i] = cor.test(df$PB_SLEDAI_corr_score[ith], df$CD38_score_mean[ith], method = meth,
              use = "pairwise.complete.obs")$estimate
  pv[i] = cor.test(df$PB_SLEDAI_corr_score[ith], df$CD38_score_mean[ith], method = meth,
              use = "pairwise.complete.obs")$p.value
}

df.cc = tibble(th = ths, `N subjects` = nn, `Pearson's r` = cc, `-log10(p)` = -log10(pv))
df.cc = df.cc %>%
  gather("metric","value", -th) %>%
  mutate(metric = factor(metric, levels=names(df.cc)[-1]))
df.vl = data.frame(metric = "-log10(p)", x = -log10(c(0.05, 0.1)))
ggplot(df.cc, aes(value, th)) +
  geom_point(size=3) +
  facet_wrap(~metric, nrow=1, scales = "free_x") +
  xlab("") + ylab("DaCP threshold (lower bound)") +
  geom_vline(data=df.vl, aes(xintercept=x), col="red", lty=2) +
  theme_bw() +
  theme(strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(10,"mm") )

fn.fig = file.path(PROJECT_DIR, "figure_generation", "SLE_DaCP_threshold2_correlations_PG23.png")
ggsave(paste0(fn.fig,".png"), w=5, h=3.5)
ggsave(paste0(fn.fig,".pdf"), w=5, h=3.5, useDingbats=F)


##' @param eliminate logical, `TRUE` by default.
force_cos_ramp_constraint <- function(H_matrix, bounds_tuple_of_numeric, vector_out, max_allowable_increasing_tension_speed,
    max_allowable_decreasing_tension_speed, n_task_values=1000, cycles_per_second=60, cyclical_function=force_cos_ramp, eliminate=TRUE){
        if (n_task_values <2) stop("must be at least 3 task values for spatiotemporal constraints")
        near_maximal_task <- vector_out*(1-1e-05)

        tasks_and_constraints <- generate_tasks_and_corresponding_constraints(H_matrix=H_matrix, vector_out = near_maximal_task, n_task_values = n_task_values, cycles_per_second = cycles_per_second, cyclical_function = cyclical_function,
        bounds_tuple_of_numeric=bounds_tuple_of_numeric)
        num_muscles <- ncol(H_matrix)
        inequality_constraints <- diagonal_merge_constraint_list(tasks_and_constraints$constraint)
        st_constr <- generate_and_add_velocity_constraint(inequality_constraints, max_allowable_increasing_tension_speed, max_allowable_decreasing_tension_speed, num_muscles)
        if(eliminate){
            print('eliminate_redundant')
            #overwrite original constraint with nonredundant constraint
            st_constr <- st_constr %>% eliminate_redundant
        }
        res <- list(nonredundant_constr=st_constr, tasks_and_constraints=tasks_and_constraints)
        return(res)
        }

mbm_median <- function(mbm_object) summary(mbm)$median
generate_and_add_velocity_constraint <- function(constraint_object, max_allowable_increasing_tension_speed,
    max_allowable_decreasing_tension_speed, num_muscles) {
    indices_for_muscles <- muscle_and_lambda_indices(constraint_object, num_muscles)$indices_for_muscles
    velocity_constraint <- generate_full_velocity_constraint(constraint_object, max_allowable_increasing_tension_speed,
        max_allowable_decreasing_tension_speed, num_muscles)
    constraint_with_velocity_requirements <- merge_constraints(constraint_object,
        velocity_constraint)
    expect_equal(sum(nrow(constraint_object$constr), nrow(velocity_constraint$constr)),
        nrow(constraint_with_velocity_requirements$constr))
    return(constraint_with_velocity_requirements)
}

transition_inequalities_for_velocity <- function(muscle_names) {
    num_muscles <- length(muscle_names)/2
    time_point_1 <- rbind(-diag(num_muscles), diag(num_muscles))
    dimnames(time_point_1) <- NULL
    df <- cbind(time_point_1, -time_point_1) %>% set_colnames(muscle_names)
    colnames(df) <- muscle_names
    rownames_pos <- transition_names(muscle_names) %>% paste0("_positive_velocitylimit")
    rownames_neg <- transition_names(muscle_names) %>% paste0("_negative_velocitylimit")
    rownames(df) <- c(rownames_pos, rownames_neg)
    return(df)
}

zeros <- function(rows, cols) matrix(0, nrow = rows, ncol = cols)

##' Transition Names for velocity/acceleration constraints
##' x_to_xprime. note that the first and second half of the input colnames should represent the same muscle, but after deltaT.
##' @param colnames_for_transition list of strings, each a muscle.
##' @return transition_names vector of strings like "LUM_0_to_LUM1" "EIP_0_to_EIP1", where the input was c("LUM_0", "EIP_0", "LUM_1", "EIP_1")
transition_names <- function(colnames_for_transition){
    num_muscles <- length(colnames_for_transition)/2
    rowname_part1 <- colnames_for_transition[1:num_muscles]
    rowname_part2 <- colnames_for_transition[(1+num_muscles):(num_muscles*2)]
    apply(cbind(rowname_part1, rowname_part2), 1, paste, collapse = "_to_")
}

compose_velocity_constraint_per_transition <- function(transition_blocks,
    num_muscles) {
    velocity_constraint <- lapply(1:length(transition_blocks), function(transition_index) {
        left_pad_blocks <- transition_index - 1
        right_pad_blocks <- -transition_index + length(transition_blocks)
        L <- zeros(num_muscles * 2, num_muscles * left_pad_blocks) %>% as.data.frame
        R <- zeros(num_muscles * 2, num_muscles * right_pad_blocks) %>% as.data.frame
        constraint_row <- cbind(L, transition_blocks[[transition_index]], R)
        return(constraint_row)
    })
    return(velocity_constraint)
}

combine_velocity_constraints <- function(velocity_constraint_list) {
    velocity_constraint_constr <- dcrb(lapply(velocity_constraint_list, function(x) {
        colnames(x) <- NULL
        return(x %>% as.matrix)
    }))
    return(velocity_constraint_constr)
}

set_dimnames <- function(input_df_or_mat, colnames_to_use, rownames_to_use) {
    # Make a copy
    df_or_mat <- input_df_or_mat
    colnames(df_or_mat) <- colnames_to_use
    rownames(df_or_mat) <- rownames_to_use
    return(df_or_mat)
}

generate_full_velocity_constraint <- function(constraint_object, max_allowable_increasing_tension_speed,
    max_allowable_decreasing_tension_speed, num_muscles) {
    num_tasks <- ncol(constraint_object$constr)/num_muscles
    num_pairs <- num_tasks - 1
    velocity_constraint <- generate_velocity_constraint_matrix(constraint_object, num_muscles)
    expect_equal(ncol(velocity_constraint), num_tasks * (num_muscles))
    expect_equal(nrow(velocity_constraint), num_pairs * num_muscles * 2)
    max_inc_speed <- rep(max_allowable_increasing_tension_speed, num_muscles)
    max_dec_speed <- rep(max_allowable_decreasing_tension_speed, num_muscles)
    rhs_velocity <- rep(c(max_inc_speed, max_dec_speed), num_pairs)
    dir_velocity <- all_less_than(velocity_constraint)
    constraint_result <- list(constr = velocity_constraint, dir = dir_velocity, rhs = rhs_velocity)
    plot_constraint_matrix(constraint_result) + ggtitle("Velocity constraint")
    return(constraint_result)
}

generate_velocity_constraint_matrix <- function(constraint_object, num_muscles) {
    num_tasks <- ncol(constraint_object$constr)/num_muscles
    all_colnames <- colnames(constraint_object$constr)
    num_pairs <- num_tasks-1
    muscle_names_per_transition <- lapply(1:num_pairs, function(pair_i){
        pair_start <- (pair_i-1)*num_muscles + 1
        pair_end <- pair_start + num_muscles*2 - 1

        tryCatch({
            names_of_interest <- all_colnames[pair_start:pair_end]
    }, warning = function(w) {
        browser()
    }, error = function(e) {
        browser()
    })

        return(names_of_interest)
    })
    transition_blocks <- lapply(muscle_names_per_transition, transition_inequalities_for_velocity)
    velocity_constraint <- compose_velocity_constraint_per_transition(transition_blocks,num_muscles) %>% combine_velocity_constraints
    # browser()
    expect_equal(num_pairs * num_muscles * 2, nrow(velocity_constraint))
    velocity_constraint <- velocity_constraint %>% set_colnames(colnames(constraint_object$constr))
    return(velocity_constraint)
}


#!/usr/bin/env Rscript

source("/tmp/class-libs.R")

class_name = "IB161"
class_libs = c(
  "pegas", "0.14"
)
class_libs_install_version(class_name, class_libs)


library(tidyverse)
library(forcats)
library(themes360info)
library(ggtext)
library(ragg)
library(here)
source(here("util.r"))

dose_labeller <- scales::label_number_si("", accuracy = 0.1)
dose_axis_labeller <- scales::label_number_si("", accuracy = 1)

unicef <- get_unicef_totals()

totals <-
  unicef %>%
  # doing a sheeky and ordering the bar levels here rather than explicitly with
  # factor (because i want to add %s to the labels)
  # factor order is the reverse of our bar stacking order (last level ends up left/bottom of ggplot2 bars)
  summarise(
    Unknown    = sum(unknown, na.rm = TRUE),
    AVAT       = sum(avat, na.rm = TRUE),
    Donations  = sum(donations, na.rm = TRUE),
    COVAX      = sum(covax, na.rm = TRUE),
    Commercial = sum(commercial, na.rm = TRUE),
    ) %>%
  pivot_longer(everything(), names_to = "source", values_to = "count") %>%
  mutate(
    # add counts to the labels
    source = paste0(source, ": ", dose_labeller(count)),
    source = factor(source, levels = source),
    frac = count / sum(count))

# specify the palette using the (reverse of the) order above
bar_colours <-
  c(pal_360[["darkblue"]],
    pal_360[["green"]],
    pal_360[["teal"]],
    pal_360[["grey"]],
    pal_360[["lightgrey"]]) %>%
  set_names(rev(totals$source))

# okay, here's an easy graphic: breakdown of global vaccines by program
totals %>%
  mutate(x = 1) %>%
  {
    ggplot(.) +
      aes(x = x, y = count, fill = source) +
      geom_col() +
      # geom_col(position = "fill") +
      coord_flip() +
      # scale_y_continuous(labels = scales::percent) +
      scale_y_continuous(
        breaks = c(0, 2, 4, 6, 8, 10) * 1e9,
        labels = dose_axis_labeller) +
      scale_fill_manual(
        # specify these in the reverse of the factor levels above
        values = bar_colours) +
      theme_360info() +
      theme(
        legend.direction = "horizontal",
        legend.position = "top",
        legend.text = element_text(size = rel(1)),
        legend.title = element_text(size = rel(1)),
        plot.caption = element_markdown(size = rel(0.9)),
        axis.text.y = element_blank(),
        axis.text.x = element_text(size = rel(1.5)),
        panel.grid = element_blank()
      ) +
      labs(
        x = NULL, y = NULL,
        fill = NULL,
        title = toupper("Vaccine doses by source"),
        subtitle =
          toupper("Donations make up a small fraction of global vaccine doses"),
        caption = paste(
          "**SOURCE: UNICEF** COVID-19 Vaccine Market Dashboard",
          "<unicef.org/supply/covid-19-vaccine-market-dashboard>"))
  } %>%
  ggsave(here("out", "total-vaccines.png"), .,
    width = 1, height = 1 / 3, device = agg_png, dpi = 100, scale = 12)