#setwd("C:/Users/fcdossantos/Desktop/UFMG 201801/Reconhecimento de Padrões/Template Matching")
rm(list=ls())
graphics.off()
rm(list=ls())
graphics.off()
require('latticeExtra')
# install.packages("jpeg")
#  install.packages("bmp")
#  install.packages("pixmap")
#  install.packages("lattice")

#require(grDevices)
library('jpeg')
library('bmp')
library('pixmap')
# #ibrary('rgl')
library('lattice')

rotate <- function(x) t(apply(x, 2, rev))

extrairFeatures <- function(img_vec)
{
  #img_mat <- makematrix(img_vec)
  f = matrix(0,3,1)
  f[1,1] = sum(img_vec)
  f[2,1] = var(img_vec)
  f[3,1] = sd(img_vec)
  f
}

similaridade <- function(feature_train,feature_test)
{
  sim_mat <- matrix(seq(1,5,1), ncol=25, nrow=25);
  colum <-matrix(seq(1,5,1), ncol=1, nrow=25);
  for( i in 1: 25){
    for(j in 1:25){
      sim_mat[i,j] = dist(rbind(feature_train[i,],feature_test[j,]))
      if( sim_mat[i,j]<3000)
      {
        sim_mat[i,j] = 100000000;
      }
    }
  }
  for(i in 1:25)
  {
    colum[i,] <- which(sim_mat[i,] == min(sim_mat[i,]))
  }

  colum

}

makematrix <- function(vet)
{
  m <-matrix(vet,nrow=56, ncol=46)
  m
}

#Leitura de dados ###################################################################################
xt <- c();
xe <- c();

for(i in 1:5){

  for(j in 1:5){

    path_xt <- paste(getwd(), paste(paste("/f", i, sep=""), paste(paste("teste",j, sep=""),".bmp", sep=""), sep="") ,sep="");
    path_xe <- paste(getwd(), paste(paste("/F", i, sep=""), paste(paste("TESTE",j,sep=""),"R.BMP",sep=""),sep=""),sep="");

    img_train <- read.bmp(path_xt);
    img_test <- read.bmp(path_xe);

    xt <- rbind(xt, t(as.matrix(as.vector(img_train))))
    xe <- rbind(xe, t(as.matrix(as.vector(img_test))))
  }
}

yt <- matrix(seq(1,5,1), ncol=1, nrow=25);#yt = [1,2,3,4,5,1,2,3,4...];
ye <- matrix(seq(1,5,1), ncol=1, nrow=25);

image(matrix(xe[1,],nrow = 56,ncol=46))
image(matrix(xe[10,],nrow = 56,ncol=46))

#extrai features

n_features = 4;
feature_train = matrix(seq(1,5,1), ncol=3, nrow=25)
feature_test = matrix(seq(1,5,1), ncol=3, nrow=25)

for( i in 1:25){

  feature_train[i,] = extrairFeatures(xe[i,])
  feature_test[i,] = extrairFeatures(xt[i,])

}

# FacesID <- c(seq(1:5), seq(1:5), seq(1:5), seq(1:5), seq(1:5))
#
# dat <- data.frame(FacesID, Media=feature_train[,1], Variancia=feature_train[,2])
#
# xyplot(Variancia ~ Media, groups=dat$FacesID, data = dat, cex=2)

# dat_teste <- data.frame(TipoConjunto="Teste", FacesID,
#                         Feature1=features_teste[,1], Feature2=features_teste[,2])
#
# data_total = smartbind(dat_train, dat_teste) # Merge data frames
#
# TemaTrain <- standard.theme(col = FALSE)
# TemaTrain$superpose.symbol$pch <- 1
#
# TemaTeste <- standard.theme(col = FALSE)
# TemaTeste$superpose.symbol$pch <- 3
#
#
# xlim = c(min(data_total$Feature1)*0.95 , 1.05*max(data_total$Feature1))
# ylim = c(min(data_total$Feature2)*0.95 , 1.05*max(data_total$Feature2))
#
# p1 <- xyplot(Feature2 ~ Feature1,
#              groups= dat_train$FacesID,
#              data = dat_train, cex=1,
#              col = list("green","red","blue","yellow","black"),
#              par.settings = TemaTrain,
#              xlim = xlim,
#              ylim = ylim)
#
# p2 <- xyplot(Feature2 ~ Feature1,
#              groups= dat_teste$FacesID,
#              data = dat_teste, cex=1,
#              col = list("green","red","blue","yellow","black"),
#              par.settings = TemaTeste,
#              xlim = xlim,
#              ylim = ylim)
#
# print(p1 + as.layer(p2))

 x <- similaridade(feature_train,feature_test)
 count <- matrix(0,ncol=1, nrow=5)
for( i in 1:25)
{
  if(ye[i,]== ye[x[i,],])
    {
      count[ye[i,],]= count[ye[i,],]+1;
    }

}
 count = count-1
 plot(count,type="l")


library(ggplot2)
test=read.table('stacked_frequency.csv', sep=',',header=F)
names(test) <- c('index','genotype', 'ratio')
ggplot(test, aes(x=ratio, fill=genotype)) + geom_density(alpha=.9)


#==========================================================================================================================
#==========================================================================================================================

# 2. faza: Uvoz podatkov

#==========================================================================================================================
#==========================================================================================================================

library(readxl)
library(readr)

sl <- locale("sl", decimal_mark=",", grouping_mark=".")

#==========================================================================================================================

# a) delovno aktivno prebivalstvo po starostnih skupinah, letno

STAROST <- read_excel("podatki/Delovno aktivno prebivalstvo po starostnih skupinah.xlsx",
                      col_names = c("starost", "sektor", as.numeric(2005:2020)),
                      na="N",
                      skip = 1) %>% select(-"sektor")

starostne_skupine <- STAROST %>% pivot_longer(`2005`:`2020`,
                                              names_to = "leto",
                                              names_transform =list(leto = as.integer),
                                              values_to = "stevilo")

starostne_skupine_2018 <- starostne_skupine %>% filter(leto == "2018") %>% select(-leto)

starost_spol <- read_excel("podatki/starost_spol.xlsx") %>% select(-"STATUS ZAPOSLITVE")

starost_spol1 <- starost_spol %>%
  pivot_longer(`2005`:`2020`,
               names_to ="leto",
               names_transform =list(leto = as.integer),
               values_to = "stevilo") %>%
  filter(STAROST == "25-29 let" | STAROST == "65 let in več") %>%
  filter(SPOL == "Spol - SKUPAJ")

#==========================================================================================================================

# b) delovno aktivno prebivalstvo glede na stopnjo dosežene izobrazbe, letno

IZOBRAZBA <- read_html("podatki/Delovno aktivno prebivalstvo po stopnji dosežene izobrazbe.htm",
                       encoding = "Windows-1250")

izobrazba <- IZOBRAZBA %>% html_nodes(xpath="//table") %>%
  .[[1]] %>% html_table(dec=".")

colnames(izobrazba)<- c("izobrazba", as.numeric(2008:2020))
tabela12 <- izobrazba[-c(1:2),]

zenske_izobrazba <- tabela12[c(14:18),]
colnames(zenske_izobrazba) <- c("stopnja_dosežene_izobrazbe_pri_ženskah", 2008:2020)
zenske_izobrazba1 <- zenske_izobrazba %>% pivot_longer(`2008`:`2020`,
                                                       names_to ="leto",
                                                       names_transform = list(leto = as.integer),
                                                       values_to = "stevilo")

#da vzame stevilo za double in ne chr
zenske_izobrazba1$stevilo <- as.numeric(gsub(",", ".", gsub("\\.", "", zenske_izobrazba1$stevilo)))

moski_izobrazba <- tabela12[c(8:12),]
colnames(moski_izobrazba) <- c("stopnja_dosežene_izobrazbe_pri_moških", 2008:2020)
moski_izobrazba1 <- moski_izobrazba %>% pivot_longer(`2008`:`2020`,
                                                     names_to ="leto",
                                                     names_transform =list(leto = as.integer),
                                                     values_to = "stevilo")
moski_izobrazba1$stevilo <- as.numeric(gsub(",", ".", gsub("\\.", "", moski_izobrazba1$stevilo)))

skupaj_izobrazba <- tabela12[c(2:6),]
colnames(skupaj_izobrazba) <- c("stopnja_dosežene_izobrazbe_pri_obeh_spolih", 2008:2020)
skupaj_izobrazba1 <- skupaj_izobrazba %>% pivot_longer(`2008`:`2020`,
                                                       names_to ="leto",
                                                       values_to = "stevilo")
skupaj_izobrazba1$leto <- parse_integer(skupaj_izobrazba1$leto)
skupaj_izobrazba1$stevilo <- as.numeric(gsub(",", ".", gsub("\\.", "", skupaj_izobrazba1$stevilo)))

#==========================================================================================================================

#c) delovno aktivno prebivalstvo glede po dejavnostih, letno (oblika csv)

DEJAVNOSTI <- read_delim("podatki/Delovno aktivno prebivalstvo po dejavnostih1.csv",
                         col_names = c("DEJAVNOST",
                                       "DELAVNO",
                                       2005:2020),
                         delim = ";",
                         escape_double = TRUE,
                         locale=locale(encoding = "Windows-1250"),
                         trim_ws = TRUE,
                         na="z",
                         skip = 1,) %>%
  select(-"DELAVNO") %>% drop_na()

dejavnosti1_1 <- DEJAVNOSTI %>% pivot_longer(`2005`:`2020`,
                                              names_to ="leto",
                                              names_transform =list(leto = as.integer),
                                              values_to = "stevilo",
                                              values_transform = list(stevilo=as.double))

DEJAVNOSTI_osnovne <- DEJAVNOSTI %>% filter(DEJAVNOST =="A KMETIJSTVO IN LOV, GOZDARSTVO, RIBIŠTVO" |
                                               DEJAVNOST == "C PREDELOVALNE DEJAVNOSTI" |
                                               DEJAVNOST == "E OSKRBA Z VODO, RAVNANJE Z ODPLAKAMI IN ODPADKI, SANIRANJE OKOLJA"|
                                               DEJAVNOST == "F GRADBENIŠTVO"|
                                               DEJAVNOST == "G TRGOVINA, VZDRŽEVANJE IN POPRAVILA MOTORNIH VOZIL"|
                                               DEJAVNOST == "H PROMET IN SKLADIŠČENJE"|
                                               DEJAVNOST == "I GOSTINSTVO"|
                                               DEJAVNOST == "J INFORMACIJSKE IN KOMUNIKACIJSKE DEJAVNOSTI"|
                                               DEJAVNOST == "K FINANČNE IN ZAVAROVALNIŠKE DEJAVNOSTI"|
                                               DEJAVNOST == "N DRUGE RAZNOVRSTNE POSLOVNE DEJAVNOSTI"|
                                               DEJAVNOST == "P IZOBRAŽEVANJE"|
                                               DEJAVNOST == "Q ZDRAVSTVO IN SOCIALNO VARSTVO"|
                                               DEJAVNOST == "R KULTURNE, RAZVEDRILNE IN REKREACIJSKE DEJAVNOSTI")

DEJAVNOSTI_osnovne_2020 <- DEJAVNOSTI_osnovne %>% pivot_longer(`2005`:`2020`,
                                                               names_to ="leto",
                                                               values_to = "stevilo",
                                                               values_transform = list(stevilo=as.double)) %>%
  filter(leto == "2020") %>% select(-leto)

DEJAVNOSTI1_PREDELOVALNE <- dejavnosti1_1[c(97:385, 401:416),]
predelovalne_2020 <- DEJAVNOSTI1_PREDELOVALNE %>% filter(leto == "2020") %>% select(-leto)
predelovalne <- c("Proizvodnja živil",
                  "Proizvodnja pijač",
                  "Proizvodnja tekstilij",
                  "Proizvodnja oblačil",
                  "Proizvodnja usnja",
                  "Proizvodnja in obdelava lesa",
                  "Proizvodnja papirja",
                  "Tiskarstvo",
                  "Proizvodnja kemikalij",
                  "Proizvodnja farmacevtskih surovin",
                  "Proizvodnja izdelkov iz gume",
                  "Proizvodnja nekovinskih mineralnih izdelkov",
                  "Proizvodnja kovin",
                  "Proizvodnja računalnikov",
                  "Proizvodnja električnih naprav",
                  "Proizvodnja drugih strojev in naprav",
                  "Proizvodnja motornih vozil, prikolic in polprikolic",
                  "Proizvodnja pohištva",
                  "Popravila in montaža strojev in naprav")

#==========================================================================================================================

# d) delovno aktivno prebivalstvo po starostnih skupinah in statističnih regijah, letno (oblika xlsx)

#ZEMLJEVID

regije <- read_excel("podatki/Delovno aktivno prebivalstvo po starostnih skupinah in regijah.xlsx",
                     col_names = c("MERITVE", "REGIJA", "STAROSTNI_RAZRED", as.integer(2010:2020)),
                     skip = 1) %>% select(-"MERITVE")

regija_1 <- regije %>% pivot_longer(`2010`:`2020`,
                                    names_to ="leto",
                                    names_transform =list(leto = as.integer),
                                    values_to = "stevilo")

regija_2 <- regija_1 %>% filter(STAROSTNI_RAZRED == "40-44", leto == "2018" ) %>% select(-leto, -STAROSTNI_RAZRED)

# da bo res obarvalo vse regije, drugače mi tistih s šumniki ne želi obarvati (+ Posavska regija)
regija_2$REGIJA[regija_2$REGIJA=="Posavska"] <- "Spodnjeposavska"
regija_2$REGIJA[regija_2$REGIJA=="Primorsko-notranjska"] <- "Notranjsko-kraška"


#a function to determine "substitution type"
#return a vector, where each item is one of c("ts", "tv", "indel")
#similar to strataG::subType(), but better than it. and the "strataG" package is obsolete and archieved

#get dependency
if(FALSE){
  require(magrittr)
  require(gtools)
  source(file=R.home(component="RBioinfoZm/AnyEmpty().r"))
}

warning("currently subType2() contains a bug for more than 2 residues. the algorithm ",
        "only permute the linear processes, which should be network processes. for ",
        "example, for residues (a c g t -), the algorithm only enumerate the processes ",
        "in a line: \"a\" --> \"c\" --> \"g\" --> \"t\" --> \"-\", etc. ",
        "in fact, the real processes may be:\n", "\"a\" --> \"c\" --> \"g\"\n",
        "  \\       \\\n", "   \\       --> \"-\"\n", "    --> \"t\"\n",
        "learn the permutation of nodes in networks and revise the codes")

subType2 <- function(x){
  #control the input of x-------------------------------------------------------
  if(!is.character(x)){stop("invalid x");}
  if(AnyEmpty(x)){stop("invalid x");}
  x %<>% base::tolower() %>% base::unique() %>% base::sort()
  if(!all(x %in% c("a", "c", "g", "t", "-"))){stop("invalid x");}
  #give a waninging if length(x) > 2--------------------------------------------
  if(length(x) > 2){
    warning("when length(unique(x)) > 2, it's usually impossible to determine ",
            "what processes have happened. for example, if (a, c, -) occur at ",
            "one site, the process may be: \"a\" --indel--> \"-\" --indel--> ",
            "\"c\", or it may be: \"a\" --transvertion--> \"c\" --indel--> ",
            "\"-\". subType2() will only return un-avoidable processes, e.g. ",
            "\"indel\" in the former example.")
  }
  #main manipulation------------------------------------------------------------
  f_ans <- function(datum){
    if(length(datum) != 2){stop("invalid input");}
    datum <- c(a="purine", c="pyrimidine", g="purine", t="pyrimidine", `-`="hyphen") %>%
      .[datum] %>% unname() %>% base::unique()
    if("hyphen" %in% datum){result <- "indel";}else{
      #see K80 model description in ?ape::dist.dna()
      if(length(datum) == 1){result <- "ts";}
      if(length(datum) == 2){result <- "tv";}
    }
    return(result)
  }
  if(length(x) > 1){
    x <- gtools::permutations(n=length(x), r=length(x), v=x, repeats.allowed=FALSE)
    result <- base::vector(mode="list", length=nrow(x))
    for(i in 1:length(result)){
      result[[i]] <- x[i,] %>% {base::rbind(utils::head(., n=-1), .[-1])} %>%
        base::apply(MARGIN=2, FUN=f_ans)
    }; remove(i);
    result %<>% lapply(FUN=base::unique)
    if(length(result) > 1) for(i in 2:length(result)){
      result[[1]] %<>% base::intersect(x=., y=result[[i]])
    }; i <- 0; remove(i);
    result %<>% .[[1]]
  }else{
    result <- character()
  }
  remove(f_ans, x)
  #anchor-----------------------------------------------------------------------
  return(result)
}

#here are the test codes
if(FALSE){
  x <- c("A", "C", "g", "t", "-") %>% sample(x=., size=5, replace=TRUE); x;
  x %>% subType2()
}


library(tidyverse)
library(dplyr)
# this didn't work
# type_comparisons <- read_csv("https://github.com/robinsones/pokemon-chart/blob/master/chart.csv")
library(datapasta)
# use tribble_paste()
type_comparisons <- tibble::tribble(
     ~Attacking, ~Normal, ~Fire, ~Water, ~Electric, ~Grass, ~Ice, ~Fighting, ~Poison, ~Ground, ~Flying, ~Psychic, ~Bug, ~Rock, ~Ghost, ~Dragon, ~Dark, ~Steel,
       "Normal",       1,     1,      1,         1,      1,    1,         1,       1,       1,       1,        1,    1,   0.5,      0,       1,     1,    0.5,
         "Fire",       1,   0.5,    0.5,         1,      2,    2,         1,       1,       1,       1,        1,    2,   0.5,      1,     0.5,     1,      2,
        "Water",       1,     2,    0.5,         1,    0.5,    1,         1,       1,       2,       1,        1,    1,     2,      1,     0.5,     1,      1,
     "Electric",       1,     1,      2,       0.5,    0.5,    1,         1,       1,       0,       2,        1,    1,     1,      1,     0.5,     1,      1,
        "Grass",       1,   0.5,      2,         1,    0.5,    1,         1,     0.5,       2,     0.5,        1,  0.5,     2,      1,     0.5,     1,    0.5,
          "Ice",       1,   0.5,    0.5,         1,      2,  0.5,         1,       1,       2,       2,        1,    1,     1,      1,       2,     1,    0.5,
     "Fighting",       2,     1,      1,         1,      1,    2,         1,     0.5,       1,     0.5,      0.5,  0.5,     2,      0,       1,     2,      2,
       "Poison",       1,     1,      1,         1,      2,    1,         1,     0.5,     0.5,       1,        1,    1,   0.5,    0.5,       1,     1,      0,
       "Ground",       1,     2,      1,         2,    0.5,    1,         1,       2,       1,       0,        1,  0.5,     2,      1,       1,     1,      2,
       "Flying",       1,     1,      1,       0.5,      2,    1,         2,       1,       1,       1,        1,    2,   0.5,      1,       1,     1,    0.5,
      "Psychic",       1,     1,      1,         1,      1,    1,         2,       2,       1,       1,      0.5,    1,     1,      1,       1,     0,    0.5,
          "Bug",       1,   0.5,      1,         1,      2,    1,       0.5,     0.5,       1,     0.5,        2,    1,     1,    0.5,       1,     2,    0.5,
         "Rock",       1,     2,      1,         1,      1,    2,       0.5,       1,     0.5,       2,        1,    2,     1,      1,       1,     1,    0.5,
        "Ghost",       0,     1,      1,         1,      1,    1,         1,       1,       1,       1,        2,    1,     1,      2,       1,   0.5,    0.5,
       "Dragon",       1,     1,      1,         1,      1,    1,         1,       1,       1,       1,        1,    1,     1,      1,       2,     1,    0.5,
         "Dark",       1,     1,      1,         1,      1,    1,       0.5,       1,       1,       1,        2,    1,     1,      2,       1,   0.5,    0.5,
        "Steel",       1,   0.5,    0.5,       0.5,      1,    2,         1,       1,       1,       1,        1,    1,     2,      1,       1,     1,    0.5
)

tidied_comparison <- type_comparisons %>%
  gather(Defending, outcome, -Attacking)

Super_effective <-tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(Super_effective = sum(ifelse(outcome == 2, 1, 0))) %>%
  arrange(desc(Super_effective)) %>%
  knitr::kable()

Neutral<- tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(Neutral = sum(ifelse(outcome == 1, 1, 0))) %>%
  arrange(desc(Neutral)) %>%
  knitr::kable()

Super_Effective_and_Neutral <-tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(Super_Effective_and_Neutral = sum(ifelse(outcome >= 1, 1, 0))) %>%
  arrange(desc(Super_Effective_and_Neutral)) %>%
  knitr::kable()

Not_Very_Effective <-tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(Not_Very_Effective = sum(ifelse(outcome == 0.5, 1, 0))) %>%
  arrange(desc(Not_Very_Effective)) %>%
  knitr::kable()

No_Effect  <-tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(No_Effect  = sum(ifelse(outcome == 0, 1, 0))) %>%
  arrange(desc(No_Effect )) %>%
  knitr::kable()

Not_Very_Effective_and_No_Effect  <-tidied_comparison %>%
  group_by(Attacking) %>%
  summarize(Not_Very_Effective_and_No_Effect  = sum(ifelse(outcome <= 0.5, 1, 0))) %>%
  arrange(desc(Not_Very_Effective_and_No_Effect )) %>%
  knitr::kable()

m <- as.matrix(type_comparisons[, -1])
rownames(m) <- type_comparisons$Attacking

super_effective_m <- (m == 2) * 1L

super_effective_nb <- function(indices) {
  sum(colSums(super_effective_m[indices, ]) > 0)
}
all_combinations <- combn(17, 4)

super_effective_results <- apply(all_combinations, 2, super_effective_nb)

all_combinations3 <- combn(17, 3)

super_effective_results3 <- apply(all_combinations3, 2, super_effective_nb)

dim(all_combinations)

dim(all_combinations3)

head(sort(super_effective_results,decreasing = TRUE), n=30)

head(sort(super_effective_results3,decreasing = TRUE), n=14)

#head(order(super_effective_results,decreasing = TRUE), n=30)

best_combos <- all_combinations[, head(order(super_effective_results,decreasing = TRUE), n=30)]

best_combos2 <- all_combinations3[, head(order(super_effective_results3,decreasing = TRUE), n=14)]

Super_effective
Neutral
Super_Effective_and_Neutral
Not_Very_Effective
No_Effect
Not_Very_Effective_and_No_Effect

#strongest_team <- t(matrix(rownames(super_effective_m)[best_combos]))
#t<-t(matrix(str_replace_all(strongest_team,"Ice","a"), nrow = 4))
#t

strongest_teams <- t(matrix(rownames(super_effective_m)[best_combos], nrow = 4))
strongest_teams2 <- t(matrix(rownames(super_effective_m)[best_combos2], nrow = 3))
strongest_teams

strongest_teams2

types <- strongest_teams %>%
  as_tibble() %>%
  gather(team, type) %>%
  count(type, sort = TRUE) %>%
  knitr::kable()

types2 <- strongest_teams2 %>%
  as_tibble() %>%
  gather(team, type) %>%
  count(type, sort = TRUE) %>%
  knitr::kable()
types
types2


library(combinat)
library(gtools)
library(pbivnorm)

sys_randper = 1;

#' The probability density function of the mvna
#'
#' @param a
#' @param r
#' @param s
#'
#' @export
#'
#' @import pbivnorm
#' @import combinat
pdfmvna <- function(a,r,s) {
	m <- length(a)
	filler_matrix <- lower.tri(diag(m), diag=F)
	rRowCol <- which(filler_matrix == TRUE, arr.in = TRUE)
	rRow <- rRowCol[,1]
	rCol <- rRowCol[,2]

	w <- 0
	s1 <- 0

	if(sys_randper == 0){
		w <-  getComb(m,2)
		s1 <- s
	}
	else{
		w <- matrix(nrow = 0,ncol = m)
		set.seed(s)
		for(z in 1:sys_randper) {
			aa <- cbind(seq(1:m), runif(m))
			aa <- aa[order(aa[,2])]
			w <- rbind(w, aa)
		}
		s1 = ceiling(runif(1) * 1000000000 )
	}

	#w <- matrix(1:m, nrow = 1) ## TEMP OVERRIDE FOR SAME MACML PERMUTATION
	w <- t(w)
	n1 <- ncol(w)
	p <- 0
	j <- 1

	# What is this 5.7? where does it come from? should it be parameterized?
	a <- 	a * (a < 5.7) + 5.7 * (a >= 5.7)
	ab <- t(a)
	condpass <- matrix(nrow = 1,ncol = 0)
  for(j in 1:n1) {
		x <- ab[w[,j]]
		xvec <- rep(x,m)
		rho <- as.vector(r[w[,j], w[,j]])
		y <- x[sapply(1:m, rep, m)]
		z <- pbivnorm(xvec, y, rho)

		z <- matrix(z, nrow = m,ncol = m)
		z3 <- pnorm(x)

		z = z - diag(diag(z)) + diag(z3)

		z1 = matrix(pnorm(xvec) * pnorm(y),nrow=m,ncol=m)
		z2 = 1-z3
		cond = 1

		for(k in 3:m) {
			omega21 = z[k,1:k-1]-z1[k,1:k-1]
			omega11 = z[1:k-1,1:k-1]-z1[1:k-1,1:k-1]
			cm = chol2inv(chol(omega11))#chol2inv(chol/solve
			condk = z3[k] + omega21%*%(cm)%*%z2[1:k-1]
			cond=cond*condk
		}
		pcomb = z[1,2]*cond
		condpass = cbind(condpass,cond)
		p = p+pcomb
	}

	gwfinal = matrix(0,nrow=1,ncol=m)
	grfinal = matrix(0,nrow=1,ncol=((m-1)*(m)/2))
	for(j in 1:n1) {
		x = ab[w[,j]]
		xvec = rep(x,m)
		rho = as.vector(r[w[,j],w[,j]])
		y = x[sapply(1:m,rep,m)]
		z = pbivnorm(xvec,y,rho)

		z = matrix(z,nrow=m,ncol=m)
		z3 = pnorm(x)

		z = z - diag(diag(z)) + diag(z3)

		z1 = matrix(pnorm(xvec) * pnorm(y),nrow=m,ncol=m)
		z2 = 1-z3

		y = matrix(y,nrow=m,ncol=m)
		rho = matrix(rho,nrow=m,ncol=m)

    rho1 <- rho
    diag(rho1) <- rep(0,m)
    rho2 = sqrt(1-rho1^2)

    # what do these do?
    g3 = dnorm(x)
    g5 = (y-rho1*x)/rho2
    g10 = g3*pnorm(g5)
    g11 = g3*pnorm(y)
    g12 = g10-g11
    g13 = g12
    g14 = g3*(1-2*z3)
    g15 = g13
    diag(g15) = g14
    g20 = -g3

    g25 = (1/rho2)*g3*dnorm(g5)
    diag(g25) <- rep(0,m)
    g25Vec =  g25[filler_matrix]

    rhovec = matrix(nrow=1,ncol=0)
    for(idim in (1:(ncol(rho)-1))) {
      rhovec = cbind(rhovec,matrix(rho[idim,((idim+1):ncol(rho))],nrow=1))
    }

    g30 = cbind(g10[1,2],g10[2,1],matrix(0,nrow=1,ncol=m-2))
    g53 = cbind(g25[1,2],matrix(0,nrow=1,ncol=(ncol(rhovec)-1)))

    gw1 = matrix(0,nrow=1,ncol=m)
    gr1 = matrix(0,nrow=1,ncol=ncol(rhovec))
    for(k in (3:m)){
      omega21 = z[k,1:k-1]-z1[k,1:k-1]
      omega11 = z[1:k-1,1:k-1]-z1[1:k-1,1:k-1]
      invomg11 = chol2inv(chol(omega11))
			condk = z3[k] + omega21%*%(invomg11)%*%z2[1:k-1]
			g31 = matrix(0,nrow=1,ncol=m)
			g31[k] = g3[k]
      g40=matrix(nrow=1,ncol=0)
      g46=matrix(nrow=1,ncol=0)
      g51=matrix(nrow=1,ncol=0)
      g81 = z2[1:k-1]
      for(l in (1:(k-1))){
        g35 = matrix(0,nrow=k-1,ncol=k-1)
        g35[l,(1:(k-1))] = g15[l,(1:(k-1))]
        g35=g35+t(g35)
        diag(g35) = (diag(g35)/2)
        g36 = -invomg11 %*% g35 %*% invomg11
        g36 = omega21 %*% g36 %*% g81
        g40 = cbind(g40,g36)

        g45 = matrix(0,nrow=1,ncol=k-1)
        g45[l] = g15[l,k]
        g46 = cbind(g46,(g45 %*% invomg11 %*% g81))

        g50 = matrix(0,nrow=k-1,ncol=1)
        g50[l]=g20[l]
        g51 = cbind(g51,(omega21 %*% invomg11 %*% g50))
      }
      g40 = cbind(g40,matrix(0,nrow=1,ncol=m-(k-1)))

      g49 = g15[k,1:k-1]
      g46 = cbind(g46,(g49 %*% invomg11 %*% g81))

      g47 = matrix(0,nrow=1,ncol=m)
      g47[(1:ncol(g46))] = g46

      g51 = cbind(g51,matrix(0,nrow=1,ncol=m-(k-1)))

      gw = (g31+g40+g47+g51) * as.vector((condpass[1,j]/condk)*z[1,2])

      #####   Start here for gradients with respect to rho parameters   ###
      kk = ncol(rhovec)
      g60 = matrix(0,nrow=1,ncol=0)
      g65 = matrix(0,nrow=1,ncol=0)

      for(l in (1:kk))
      {
        g57 = matrix(0,nrow=m,ncol=m)

        g57[rRow[l],rCol[l]]=1
        g57[rCol[l],rRow[l]]=1

        g59 = g57*g25

        g59 = g59[1:(k-1),1:(k-1)]
        g58 = -invomg11 %*% g59 %*% invomg11
        g58 = omega21 %*% g58 %*% z2[1:(k-1)]
        g60 = cbind(g60,g58)

        g61 = g57[k,1:(k-1)]*g25[k,1:(k-1)]
        g62 = g61 %*% invomg11 %*% z2[1:(k-1)]
        g65 = cbind(g65,g62)
      }
      gr = (g60+g65) * as.vector(((condpass[j])/condk)*z[1,2])
      gw1 = gw+gw1
      gr1 = gr+gr1
    }

    gw2 = (g30*condpass[1,j])+gw1
    gr2 = (g53*condpass[1,j])+gr1

    sk=0
    gr3 = matrix(0,nrow=m,ncol=m)
    for(mm in (1:(m-1))) {
      gr3[mm,(mm+1):m] = (gr2[(sk+1):(sk+m-mm)])
      sk=sk+m-mm
    }
    ####    commands below to resequence gradients based on permutation   #####

    aaa = cbind(w[,j],(1:m))
    aaa = aaa[sort.list(aaa[,1]),2]
    gwf = gw2[aaa]
    grf = gr3[aaa,aaa]

    res = matrix(nrow=0,ncol=2)
    for(ir in (1:(m-1))) {
      jr = ir+1
      temp = matrix((rep(w[ir,j],m-ir)),ncol=1)
      temp = cbind(temp,matrix(w[jr:m,j],nrow=m-jr+1,ncol=1))
      res = rbind(res,temp)
    }
    res2 = cbind(apply(res,1,min),apply(res,1,max))

    res2 = matrix(res2[,1] *(10^(floor (log(res2[,2])/log(10))+1)) + res2[,2],ncol=1)

    aaa1 = cbind(res2,(1:nrow(res2)))
    aaa1 = matrix(aaa1[sort.list(aaa1[,1]),2],ncol=1)

    grf = gr2[aaa1]
    gwfinal = gwfinal+gwf
    grfinal = grfinal+grf

	}
	if( (p/n1) > 0) {
		 cbind(p/n1,cbind(gwfinal,grfinal)/n1,s1)
	} else {
		newval <- pdfmvna(a,r,s1)
		newval
	}
}

#' The cumulative density function of the mvna
#'
#' @param a
#' @param r
#' @param s
#' @export
cdfmvna <- function(a,r,s){
	m = length(a);
	w = 0; s1 = 0;
	if(sys_randper ==0){
		w <-  getComb(m,2) ;
		s1 = s;
	}
	else{
		w = matrix(nrow=0,ncol=m);
		set.seed(s);
		for(z in 1:sys_randper)
		{
			aa = cbind(seq(1:m),runif(m));
			aa = aa[order(aa[,2])];
			w <- rbind(w,aa);
		}
		s1 = ceiling(runif(1)*1000000000 );
	}
  #w = matrix(1:m,nrow=1); ## TEMP OVERRIDE FOR SAME MACML PERMUTATION
	w = t(w);
	n1 = ncol(w);
	p = 0;
	j = 1;

	a <- 	a * (a < 5.7) + 5.7*(a >= 5.7);
	ab = t(a);

	for(j in 1:n1)
	{
		x = ab[w[,j]];
		xvec = rep(x,m);
		rho = as.vector(r[w[,j],w[,j]]);
		y = x[sapply(1:m,rep,m)];
		z = pbivnorm(xvec,y,rho);

		z = matrix(z,nrow=m,ncol=m);
		z3 = pnorm(x);

		z = z - diag(diag(z)) + diag(z3);

		z1 = matrix(pnorm(xvec) * pnorm(y),nrow=m,ncol=m);
		z2 = 1-z3;
		cond = 1;

		for(k in 3:m)
		{
			omega21 = z[k,1:k-1]-z1[k,1:k-1];
			omega11 = z[1:k-1,1:k-1]-z1[1:k-1,1:k-1];
			cm = chol2inv(chol(omega11));#chol2inv(chol/solve
			condk = z3[k] + omega21%*%(cm)%*%z2[1:k-1] ;
			cond=cond*condk;
		}
		pcomb = z[1,2]*cond;
		p = p+pcomb;
	}
	if( (p/n1) > 0)
	{
		 return(cbind(p/n1,s1));
	}
	else
	{
		newval <- cdfmvna(a,r,s1);
		return(newval);
	}
}

#' Get combination

#' @param n
#' @param dim
#'
#' @export
getComb  <- function(n,dim){
	combs_all <- t(combn(n,dim))
	perms_all <- matrix(nrow = 0, ncol = n)
	num_combs <- nrow(combs_all)

	# TODO: this might be the kind of thing that would be better in c++
	for(irow in 1:num_combs){
		oth_dims <- matrix(nrow = 1, ncol = 0)
		for(idim in 1:n){
			check <- which(combs_all[irow,] == idim)
			if(length(check) == 0 ){
				oth_dims <- cbind(oth_dims, idim)
			}
		}

		# FIXME: function `permutations` does not exist.
		oth_dims <- permutations(ncol(oth_dims), ncol(oth_dims), oth_dims)
		ini_dims <- kronecker(combs_all[irow,],
		                      matrix(1, ncol = nrow(oth_dims), nrow = 1))
		ini_dims <- t(ini_dims)
		perms_all <- rbind(perms_all, cbind(ini_dims, oth_dims))
	}

	permsall
}


#
# W E E D S
#

library(caTools)
library(logistf)

setwd("c:/University of Arizona/weeds")

# Read in the LR Data
myData = read.csv("training-doubled.csv", header = TRUE)

#
# C L E A N  U P  D A T A
#
# Drop bits we don't care about
#df = subset(myData, select= -c(name, number))
# Replace values so we have some that correspond to true/false
#df["type"][df["type"] == "1"] <- "0"
#df["type"][df["type"] == "2"] <- "1"

#final = as.vector(df)
#
# S P L I T
#
# Unless you give the split one column name, it will split 50/50
split = sample.split(myData$type, SplitRatio = 0.6)
train <- subset(myData, split == "TRUE")
test <- subset(myData, split == "FALSE")
myData$type <- as.factor(myData$type)

weedModel <- glm(type ~ ratio + shape + distance, data = train, family='binomial', maxit=100 )
weedModel2 <- logistf::logistf(formula = type ~ ratio + shape + distance, data = train)
#weedModel <- glm(type ~ ., data = train, family='binomial' )
summary(weedModel)
summary(weedModel2)

res <- predict(weedModel, test, type="response")
res

res <- predict(weedModel, train, type="response")
res

#
# Confusion Matrix
#
confusion <- table(Actual_value=train$type, Predicted_value= res > 0.5)
confusion


context("mask")

test_that("mask", {
    F = list(a=c('e1','e2'),b='e1',c='e2')

    Z = mask(F)
    #      e1    e2
    # a  TRUE  TRUE
    # b  TRUE FALSE
    # c FALSE  TRUE

    Zref = structure(c(TRUE, TRUE, FALSE, TRUE, FALSE, TRUE), .Dim = c(3L,
    2L), .Dimnames = list(c("a", "b", "c"), c("e1", "e2")))

    expect_equal(Zref, Z)
    expect_equal(Zref, mask(F, along=2))
    expect_equal(Zref, t(mask(F, along=1)))
})


ivfastplm.core <- function(y = NULL, ## outcome vector
                         x = NULL, ## regressor matrix
                         z = NULL, ## exogenous variables matrix
                         ind = NULL, ## indicator matrix
                         se = 0,
                         robust = FALSE,
                         cl = NULL,
                         sfe.index = NULL, ## index for simple fe , a vector of integer
                         cfe.index = NULL, ## index for complex fe, a list of double, e.g. c(effect, influence)
                         core.num = 1,
                         df.use = NULL,
                         df.cl.use = NULL,
                         need.fe = FALSE,
                         iv.test = FALSE,
                         first = TRUE,
                         orthog = NULL,
                         endog = NULL) {

    if(is.null(z)){
        stop("No exogenous variables.\n")
    }

    if(is.null(x)){
        stop("No regressors.\n")
    }

    data.reduce <- cbind(y, z)
    data <- cbind(y, x)

    ## create indicators
    inds <- create.indicators(ind) ## an indicator class object

    ## ------ fe ------- ##
    fe <- cfes <- sub.cfe.index <- num.cfe.index <- NULL

    ## create complex fe
    gcfe <- function(i) {
        sub.cfe.index <- cfe.index[[i]]
        inf.weight <- as.numeric(inds$levels[[sub.cfe.index[2]]])
        cfe.sub <- create.complex.effect(inds, sub.cfe.index[1],
                                         sub.cfe.index[2], t(as.matrix(inf.weight)))
        return(cfe.sub)
    }

    ## complex fe
    if (!is.null(cfe.index)) {
        ## length
        cfe.length <- length(cfe.index)
        cfes <- lapply(1:cfe.length, gcfe)
    }

    ## create an fe class object
    fe <- create.fixed.effects(inds, sfes = sfe.index, cfes = cfes)

    ## demean all variables and then recover the fixed effects in ivregression using the coefficients
    model <- SolveFixedEffects(data, fe$ptr, core.num)
    model <- name.fe.model(model, inds, fe)
    model$inds <- inds
    model$fe <- fe

    model.reduce <- SolveFixedEffects(data.reduce, fe$ptr, core.num)
    model.reduce <- name.fe.model(model.reduce, inds, fe)
    model.reduce$inds <- inds
    model.reduce$fe <- fe

    dy <- model$demeaned$y
    dz <- model.reduce$demeaned$x
    dx <- model$demeaned$x
    colnames(dy) <- colnames(y)
    colnames(dz) <- colnames(z)
    colnames(dx) <- colnames(x)

    #inv.x <- solve(t(dx)%*%dx)
    #inv.z <- solve(t(dz)%*%dz)
    #Pz <- dz%*%inv.z%*%t(dz)
    #inv.xPzx <- solve(t(dx)%*%Pz%*%dx)
    #inv.z.zx <- inv.z%*%t(dz)%*%dx
    #iv.coef <- matrix(inv.xPzx%*%t(dx)%*%Pz%*%dy,ncol=1)
    #u.hat <- matrix(dy-dx%*%iv.coef,ncol=1)

    iv.solve <- try(solveiv(Y=dy,X=dx,Z=dz),silent = T)
    if ('try-error' %in% class(iv.solve)) {
        stop("Exact collinearity in the regression.\n")
    }
    inv.x <- iv.solve[["invxx"]]
    inv.z <- iv.solve[["invzz"]]
    inv.xPzx <- iv.solve[["invXPzX"]]
    iv.coef <- iv.solve[["coef"]]
    inv.z.zx <- iv.solve[["invzzx"]]
    rownames(iv.coef) <- colnames(x)
    u.hat <- iv.solve[["residual"]]
    ZY <- iv.solve[["ZY"]]; #t(Z)*y
    XZ <- iv.solve[["XZ"]]; #t(X)*Z

    if(sum(is.na(inv.x))>0){
        stop("Exact collinearity in the regression.")
    }
    if(sum(is.na(inv.z))>0){
        stop("Exact collinearity in the regression.")
    }

    colnames(inv.xPzx) <- rownames(inv.xPzx) <- colnames(inv.x) <- rownames(inv.x) <- colnames(dx)
    colnames(inv.z) <- rownames(inv.z) <- colnames(dz)
    rownames(XZ) <- colnames(dx)
    colnames(XZ) <- colnames(dz)

    colnames(ZY) <- colnames(dy)
    rownames(ZY) <- colnames(dz)

    model.iv <- list(coefficients=iv.coef,res=u.hat)
    model.iv$fe <- fe
    if(se == 1){
        if(is.null(df.use)){
            dof.output <- get.dof(model=model,
                                  x=x,
                                  cl=NULL,
                                  ind=ind,
                                  sfe.index=sfe.index,
                                  cfe.index=cfe.index)
            gtot <- dof.output$gtot
            model.iv$dof <- dof.output$dof
            ## degree of freedom
            df <- dim(dy)[1] - gtot
        }else{
            df <- df.use
        }
        model.iv$df.original <- df
        model$df.original <- df

        if(is.null(cl)){

            sigma2 <- t(u.hat)%*%u.hat/(df)
            RMSE <- sqrt(sigma2)
            R2 <- 1 - sum(t(u.hat)%*%u.hat)/sum((data[, 1] - mean(data[, 1]))^2)
            Adj_R2 <- 1 - (1 - R2) * (dim(x)[1] - 1) / df
            projR2 <- 1 - sum(t(u.hat)%*%u.hat)/sum((c(model$demeaned$y) - mean(model$demeaned$y))^2)
            projAdj_R2 <- 1 - (1 - projR2) * (dim(x)[1] - 1) / df

            if (robust == FALSE) {
                vcov <- as.matrix(c(t(u.hat)%*%u.hat/(df))*inv.xPzx)
                stderror <- as.matrix(sqrt(diag(vcov)))
            } else{
                meat <- dz * matrix(rep(c(u.hat), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                meat <- t(meat) %*% meat
                vcov <- inv.xPzx%*%(t(inv.z.zx)%*%meat%*%inv.z.zx)%*%inv.xPzx
                vcov <- dim(dx)[1] / df*vcov
                stderror <- as.matrix(sqrt(diag(vcov)))
            }

            Tx <- c(model.iv$coefficients)/c(stderror)

            P_t <- NULL
            for (i in 1:length(Tx)) {
                subt <- pt(Tx[i], df)
                P_t <- c(P_t, 2 * min(1 - subt, subt))
            }
            CI <- cbind(c(model.iv$coefficients) - qt(0.975,df=df)*c(stderror), c(model.iv$coefficients) + qt(0.975,df=df)*c(stderror))
            model.iv$df.residual <- df

            ## F test
            if (robust == FALSE) {
                ## full model
                ##fF <- R2/(1 - R2) * df/(dim(x)[1] - df - 1)
                ## projection model
                projF <- t(model.iv$coefficients) %*% solve(vcov) %*% model.iv$coefficients/dim(x)[2]

                ##F_statistic <- cbind(fF, dim(x)[1] - df - 1, df, 1 - pf(fF, dim(x)[1] - df - 1, df))
                proj_F_statistic <- cbind(projF, dim(x)[2], df, 1 - pf(projF, dim(x)[2], df))

                ##colnames(F_statistic) <- c("F_statistic", "df1", "df2", "P value")
                colnames(proj_F_statistic) <- c("F_statistic", "df1", "df2", "P value")

                ##model.iv$F_statistic <- F_statistic
                model.iv$proj_F_statistic <- proj_F_statistic
            } else {
                ## robust wald test
                fF <- t(model.iv$coefficients) %*% solve(vcov) %*% model.iv$coefficients
                fF <- c(fF) / dim(x)[2]
                F_statistic <- cbind(fF, dim(x)[2], df, 1 - pf(fF, dim(x)[2], df))
                colnames(F_statistic) <- c("F_statistic", "df1", "df2", "P value")
                model.iv$proj_F_statistic <- F_statistic
            }

            est.coefficients <- cbind(model.iv$coefficients, stderror, Tx, P_t, CI)
            colnames(est.coefficients) <- c("Coef", "Std. Error", "t value", "Pr(>|t|)", "CI_lower", "CI_upper")
            rownames(est.coefficients) <- colnames(x)
            model.iv$est.coefficients <- est.coefficients
        }else{
            #clusted fe
            model.iv$cl <- cl
            if (dim(cl)[2] == 1) {
                stderror <- iv.cluster.se(cl = cl, x = x, u.hat = u.hat, dz=dz,
                                          sfe.index = sfe.index,
                                          cfe.index = cfe.index,
                                          ind = ind, df = df, df.cl = df.cl.use,
                                          model = model,
                                          inv.z.zx = inv.z.zx,
                                          inv.xPzx = inv.xPzx
                                          )
                num.cl <- stderror$num.cl
                vcov <- stderror$vcov.cl
                df.cl <- stderror$df.cl
                dof <- stderror$dof
                stderror <- stderror$stderror
                model.iv$dof <- dof
            }
            else if (dim(cl)[2] == 2) {

                stderror1 <- iv.cluster.se(cl = as.matrix(cl[,1]), x = x, u.hat = u.hat, dz=dz,
                                           sfe.index = sfe.index,
                                           cfe.index = cfe.index,
                                           ind = ind, df = df, df.cl = df.cl.use[1],
                                           model = model,
                                           inv.z.zx = inv.z.zx,
                                           inv.xPzx = inv.xPzx)
                num.cl1 <- stderror1$num.cl
                vcov1 <- stderror1$vcov.cl
                df.cl1 <- stderror1$df.cl
                dof1 <- stderror1$dof
                stderror1 <- stderror1$stderror

                stderror2 <-  iv.cluster.se(cl = as.matrix(cl[,2]), x = x, u.hat = u.hat, dz=dz,
                                            sfe.index = sfe.index,
                                            cfe.index = cfe.index,
                                            ind = ind, df = df, df.cl = df.cl.use[2],
                                            model = model,
                                            inv.z.zx = inv.z.zx,
                                            inv.xPzx = inv.xPzx)
                num.cl2 <- stderror2$num.cl
                vcov2 <- stderror2$vcov.cl
                df.cl2 <- stderror2$df.cl
                dof2 <- stderror2$dof
                stderror2 <- stderror2$stderror

                cl_inter <- as.numeric(as.factor(paste(cl[,1], "-:-", cl[,2], sep = "")))

                #if cl_inter is unique; then stderror3 is robust standard error
                cl_inter.count <- table(cl_inter)
                if(max(cl_inter.count)==1){
                    meat3 <- dz * matrix(rep(c(u.hat), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                    meat3 <- as.matrix(t(meat3) %*% meat3)
                    vcov3 <- inv.xPzx%*%(t(inv.z.zx)%*%meat3%*%inv.z.zx)%*%inv.xPzx
                    vcov3 <- dim(dx)[1]/model.iv$df.original*vcov3
                    stderror3 <- c()
                    for (i in 1:dim(x)[2]) {
                        stderror3 <- c(stderror3, sqrt(vcov3[i, i]))
                    }
                    stderror3 <- as.matrix(stderror3)
                    num.cl3 <- length(cl_inter.count)
                    df.cl3 <- model.iv$df.original
                    dof3 <- model.iv$dof
                }else{
                    stderror3 <- iv.cluster.se(cl = as.matrix(cl_inter), x = x, u.hat = u.hat, dz=dz,
                                            sfe.index = sfe.index,
                                            cfe.index = cfe.index,
                                            ind = ind, df = df, df.cl = df.cl.use[3],
                                            model = model,
                                            inv.z.zx = inv.z.zx,
                                            inv.xPzx = inv.xPzx)
                    num.cl3 <- stderror3$num.cl
                    vcov3 <- stderror3$vcov.cl
                    df.cl3 <- stderror3$df.cl
                    dof3 <- stderror3$dof
                    stderror3 <- stderror3$stderror
                }

                df.cl <- c(df.cl1,df.cl2,df.cl3)
                num.cl <- min(num.cl1,num.cl2,num.cl3)
                dof.output <- list()
                dof.names <- names(dof1)
                for(sub.dof.name in dof.names){
                    min.index <- which.min(c(dof1[[sub.dof.name]][1]-dof1[[sub.dof.name]][2],
                                           dof2[[sub.dof.name]][1]-dof2[[sub.dof.name]][2],
                                           dof3[[sub.dof.name]][1]-dof3[[sub.dof.name]][2]))
                    if(min.index==1){
                        dof.output[[sub.dof.name]] <- dof1[[sub.dof.name]]
                    }
                    if(min.index==2){
                        dof.output[[sub.dof.name]] <- dof2[[sub.dof.name]]
                    }
                    if(min.index==3){
                        dof.output[[sub.dof.name]] <- dof3[[sub.dof.name]]
                    }
                }

                model.iv$dof <- dof.output
                vcov <- vcov1+vcov2-vcov3
                stderror <- sqrt(stderror1^2 + stderror2^2 - stderror3^2)
            }

            df <- min(num.cl-1,df)
            Tx <- c(model.iv$coefficients)/c(stderror)
            P_t <- NULL
            for (i in 1:length(Tx)) {
                subt <- pt(Tx[i], df)
                P_t <- c(P_t, 2 * min(1 - subt, subt))
            }

            CI <- cbind(c(model.iv$coefficients) - qt(0.975,df)*c(stderror), c(model.iv$coefficients) + qt(0.975,df)*c(stderror))
            est.coefficients <- cbind(model.iv$coefficients, stderror, Tx, P_t, CI)
            colnames(est.coefficients) <- c("Coef", "Std. Error", "t value", "Pr(>|t|)", "CI_lower", "CI_upper")
            rownames(est.coefficients) <- colnames(x)
            model.iv$est.coefficients <- est.coefficients

            #Wald Test

            fF <- try(t(model.iv$coefficients) %*% solve(vcov) %*% model.iv$coefficients,silent = T)
            if ('try-error' %in% class(fF)) {
                fF <- NULL
                F_statistic <- NULL
                warning("Number of clusters insufficient to calculate robust covariance matrix.\n")
            }
            else{
                fF <- c(fF) / dim(x)[2]
                F_statistic <- cbind(fF, dim(x)[2], df, 1 - pf(fF, dim(x)[2], df))
                colnames(F_statistic) <- c("F_statistic", "df1", "df2", "P value")
            }

            model.iv$proj_F_statistic <- F_statistic
            model.iv$df.residual <- df
            model.iv$df.cl <- df.cl

            df.cl.max <- max(df.cl)
            sigma2 <- t(u.hat)%*%u.hat/df.cl.max
            RMSE <- sqrt(sigma2)
            R2 <- 1 - sum(t(u.hat)%*%u.hat)/sum((data[, 1] - mean(data[, 1]))^2)
            Adj_R2 <- 1 - (1 - R2) * (dim(x)[1] - 1) / df.cl.max
            projR2 <- 1 - sum(t(u.hat)%*%u.hat)/sum((c(model$demeaned$y) - mean(model$demeaned$y))^2)
            projAdj_R2 <- 1 - (1 - projR2) * (dim(x)[1] - 1) / df.cl.max
        }
        colnames(vcov) <- rownames(vcov) <- colnames(x)
        model.iv$vcov <- vcov
        model.iv$RMSE <- RMSE
        model.iv$R2 <- R2
        model.iv$Adj_R2 <- Adj_R2
        model.iv$projR2 <- projR2
        model.iv$projAdj_R2 <- projAdj_R2
    }

    if(need.fe==TRUE){ #recover the fixed effects
        model.y <- SolveFixedEffects(matrix(y,ncol=1), fe$ptr, core.num)
        model.y <- name.fe.model(model.y, inds, fe)
        sfe.x.list <- list()
        cfe.x.list <- list()
        intercept.x <- c()

        if(identical(model.y$sfe.coefs,character(0))==FALSE){
            for(sub.sfe.name in names(model.y$sfe.coefs)){
                sfe.x.list[[sub.sfe.name]] <- model.y$sfe.coefs[[sub.sfe.name]]
            }
        }

        if(identical(model.y$cfe.coefs,character(0))==FALSE){
            for(sub.cfe.name in names(model.y$cfe.coefs)){
                cfe.x.list[[sub.cfe.name]] <- model.y$cfe.coefs[[sub.cfe.name]]
            }
        }

        intercept.x <- model.y$intercept

        if(dim(x)[2]!=0){
            for(i in 1:dim(x)[2]){
                model.x <- SolveFixedEffects(matrix(x[,i],ncol=1), fe$ptr, core.num)
                model.x <- name.fe.model(model.x, inds, fe)

                if(identical(model.y$sfe.coefs,character(0))==FALSE){
                    for(sub.sfe.name in names(model.y$sfe.coefs)){
                        sfe.x.list[[sub.sfe.name]] <- sfe.x.list[[sub.sfe.name]]-iv.coef[i,]*model.x$sfe.coefs[[sub.sfe.name]]
                    }
                }

                if(identical(model.y$cfe.coefs,character(0))==FALSE){
                    for(sub.cfe.name in names(model.y$cfe.coefs)){
                        cfe.x.list[[sub.cfe.name]] <- cfe.x.list[[sub.cfe.name]]-iv.coef[i,]*model.x$cfe.coefs[[sub.cfe.name]]
                    }
                }
                intercept.x <- intercept.x-iv.coef[i,]*model.x$intercept
            }
        }

        if(identical(cfe.x.list,list())){
            cfe.x.list <- character(0)
        }
        model.iv$sfe.coefs <- sfe.x.list
        model.iv$cfe.coefs <- cfe.x.list
        model.iv$intercept <- intercept.x
    }

    model.iv$y <- y
    model.iv$x <- x
    model.iv$z <- z
    model.iv$residuals <- u.hat
    model.iv$fitted.values <- y - u.hat
    model.iv$ols.model <- model
    model.iv$reduce.model <- model.reduce
    model.iv$demeaned <- list(dx=dx,dy=dy,dz=dz)
    model.iv$inds <- inds
    model.iv$matrix <- list(inv.x=inv.x,inv.z=inv.z,inv.z.zx=inv.z.zx,inv.xPzx=inv.xPzx,XZ=XZ,ZY=ZY)

    #all endogenous variables, extracted from x
    en.var.x <- c()
    ex.var.x <- c()
    #from z
    include.iv <- c()
    exclude.iv <- c()
    for(sub.dx in colnames(x)){
        get.ex <- matrix(sapply(as.data.frame(dz), identical, dx[,sub.dx]),nrow = 1)
        colnames(get.ex) <- colnames(z)
        if(any(get.ex)==TRUE){
            include.iv <- c(include.iv,colnames(get.ex)[which(get.ex==TRUE)])
            ex.var.x <- c(ex.var.x,sub.dx)
        }
    }
    include.iv <- unique(include.iv)
    ex.var.x <- unique(ex.var.x)
    exclude.iv <- colnames(dz)[which(!colnames(dz)%in%include.iv)]
    en.var.x <- colnames(dx)[which(!colnames(dx)%in%ex.var.x)]
    model.iv$names <- list(en.var.x=en.var.x,ex.var.x=ex.var.x,include.iv=include.iv,exclude.iv=exclude.iv)

    if(iv.test == TRUE){
        iv.test.results <- iv.test(model.iv, robust=robust, cl=cl, first = first, orthog=orthog, endog=endog)
        model.iv$tests <- iv.test.results
    }

    class(model.iv) <- "ivfastplm"
    return(model.iv)

}


library(randomForest)
library(ROCR)
library(MLmetrics)
library(caret)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# drop possible all NA columns
finalData <- finalData[, !apply(is.na(finalData), 2, all)]
# keep way from training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# class imbalance problem
# hist(as.numeric(finalData$DE) - 1, col = 'blue', main = 'Class Imbalance', xlab = 'FALSE = 0 \t TRUE = 1', ylim = c(0,length(finalData$DE)))
# set seed
numModels <- 20 # increase
# search grid
rfGrid <- expand.grid(ntreeArg = (1:5)*500,
                      replaceAge = c(TRUE, FALSE),
                      mtryArg = (round(sqrt(length(finalData))) + (-2:2)),
                      nodesize = c(1, 3, 5, 7)
)
colnames(rfGrid) <- c("ntree", "replace", "mtry", "nodesize")
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(rfGrid) + 6))
colnames(currParams) <- c(colnames(rfGrid), "sampsizeArg" ,"Accuracy", "AUC", "F1score", "trainingLength", "testingLength")
currParams <- rfGrid[sample(nrow(rfGrid), size = 1),] #sample random combination and train the forest
currParams[c(1:20),c(1:4)] <- currParams
split <- .99
# generate 20 models and measure metrics
for (i in 1:numModels){
  print(paste0("building model", i))
  set.seed(123)
  # shuffle data
  finalData <- finalData[sample(nrow(finalData)),]
  # split to training and testing datasets
  rndsplt <- sample(x = 2, size = nrow(finalData), replace = TRUE, prob = c(split, 1-split))
  trainingData <- finalData[rndsplt == 1, ]
  testingData <- finalData[rndsplt == 2, ]
  # select arguments
  sampsizeArg  = c(nrow(trainingData), round(nrow(trainingData)*.9), round(nrow(trainingData)*.8), round(nrow(trainingData)*.75))
  samp <- sampsizeArg[sample(length(sampsizeArg), 1)]
  currParams[i, "sampsizeArg"] <- samp
  # Train Model
  rfModel <- randomForest(x = trainingData[,-ncol(trainingData)], y = trainingData$DE,
                          ntree = currParams[i, "ntree"],
                          replace = currParams[i, "replace"],
                          mtry = currParams[i, "mtry"],
                          sampsize = currParams[i, "sampsizeArg"],
                          nodesize = currParams[i, "nodesize"])
  # Predict
  pred <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'response')
  predprob <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'prob')
  # Evaluate model
  # Confusion Matrix
  # confusionMatrix(data = pred, reference = testingData$DE, positive = 'TRUE')
  # Accuracy
  currParams[i, "Accuracy"] <- Accuracy(y_pred = pred, y_true = testingData[,ncol(testingData)])
  pred_obj = prediction(predprob[,2], testingData[,ncol(testingData)], label.ordering = c("FALSE", "TRUE"))
  # AUC
  currParams[i, "AUC"] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  # F1 score
  currParams[i, "F1score"] <- F1_Score(y_true = testingData$DE, y_pred = pred, positive = 'TRUE')
  currParams[i, "trainingLength"] <- nrow(trainingData)
  currParams[i, "testingLength"] <- nrow(testingData)
  split <- split - .05
}
saveRDS(object = currParams[,c(6:10)], file = "./test/rfAccAucF1.rds")


#' Plot MCMC
#'
#' Makes a number of diagnostic plots to evaluate convergence in the Monte Carlo Markov Chain results.
#' @param wd directory where ASAP run is located
#' @param asap.name Base name of original dat file (without the .dat extension)
#' @param asap name of the variable that read in the asap.rdat file
#' @param mcmc.burn number of realizations to remove from start of MCMC (defaults to 0)
#' @param mcmc.thin thinning parameter for MCMC (defaults to 1)
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotMCMC  <- function(wd,asap.name,asap,mcmc.burn=0,mcmc.thin=1,save.plots,od,plotf){

  # kk5 <- library(plotMCMC, logical.return=T)
  # if (kk5==F) install.packages("plotMCMC" )
  # library(plotMCMC)

  f.chain <- paste0(asap.name, ".MCM" )
  #f.chain <- "asap3MCMC.dat"
  # don't run this function if chains are not present
  # just in case Enable MCMC Calculations box checked in General Tab of GUI but MCMC not actually run
  if (file.exists(paste0(wd,"\\",f.chain)) == FALSE){
    return()
  }
  chain1c <- read.table(paste0(wd,"\\",f.chain), header=T)
  ## new stuff
  niter <-  dim(chain1c)[1]
  if (niter == 0) return() # in case asap$options$do.mcmc>0 but MCMC not actually run
  chain1b <-  chain1c[(mcmc.burn+1):niter,]
  niter <-  dim(chain1b)[1]
  chain1a <-  chain1b[seq(1,niter,by=mcmc.thin),]

  bsn1c <- read.table(paste0(wd,"\\",asap.name, ".BSN"), header=T)
  niter <-  dim(bsn1c)[1]
  bsn1b <-  bsn1c[(mcmc.burn):niter,]
  niter <-  dim(bsn1b)[1]
  bsn1a <-  bsn1b[seq(1,niter,by=mcmc.thin),]
  write.table(bsn1a, file=paste0(od, "New_BSN_file.BSN"), row.names=T)
  write.table(bsn1a, file=paste0(wd, "\\New_", asap.name,".BSN"), row.names=F, col.names=F)

  niter <-  dim(chain1a)[1]
  nyears <- asap$parms$nyears
  years <- seq(asap$parms$styr, asap$parms$endyr)

  f.chain <- chain1a[,seq(1,nyears)]
  ssb.cols1 <- which(substr(names(chain1a),1,3)=="SSB")
  ssb.chain <- chain1a[,ssb.cols1[1:(length(ssb.cols1)-2)] ]
  fmult.chain <- chain1a[,which(substr(names(chain1a),1,3)=="Fmu")]
  totB.chain <- chain1a[,which(substr(names(chain1a),1,3)=="tot")]
  MSY.chain <- chain1a[,which(substr(names(chain1a),1,3)=="MSY")]
  MSY.col <- which(substr(names(chain1a),1,3)=="MSY")
  SSBmsy.chain <- chain1a[,(MSY.col+1)]
  Fmsy.chain <- chain1a[,(MSY.col+2) ]
  SSBmsy.ratio.chain <- chain1a[,(MSY.col+3) ]
  Fmsy.ratio.chain <- chain1a[,(MSY.col+4 ) ]

  # examine Trace in first and last year

  par(mfcol=c(2,1),mar=c(4,4,2,2), oma=c(1,1,1,1))
  plot(seq(1,niter), ssb.chain[,1], type='l', xlab="Iteration", ylab=paste0("SSB",years[1]) )
  plot(seq(1,niter), ssb.chain[,nyears], type='l', xlab="Iteration", ylab=paste0("SSB",years[nyears]))
  if (save.plots==T)  savePlot(paste0(od,'Trace.SSB.first.last.yr.',plotf),type=plotf)

  par(mfcol=c(2,1),mar=c(4,4,2,2), oma=c(1,1,1,1))
  plot(seq(1,niter), f.chain[,1], type='l', xlab="Iteration", ylab=paste0("Freport",years[1]) )
  plot(seq(1,niter), f.chain[,nyears], type='l', xlab="Iteration", ylab=paste0("Freport",years[nyears]))
  if (save.plots==T)  savePlot(paste0(od,'Trace.Freport.first.last.yr.',plotf),type=plotf)

  ##NEW
  # examine cumuplot in first and last year to determine if chain long enough (quartiles stabilized)
  mcmc.outs <- cbind( f.chain[,c(1,nyears)],  ssb.chain[,c(1,nyears)])
  plotMCMC::plotCumu(mcmc.outs,probs=c(0.05,0.95), div=1, xlab="Iterations",
           ylab="Median with 90% PI", lty.median=1, lwd.median=2, col.median="black", lty.outer=2, lwd.outer=1,
           col.outer="black"  )

  if (save.plots==T)  savePlot(paste0(od,'Cumu.F_and_SSB.first.last.yr.',plotf),type=plotf)

  # look at auto-correlation plot
  par(mfcol=c(2,1),mar=c(4,4,2,2))
  ac.ssb1<-acf(ssb.chain[,1], lag.max=10, plot=F)
  ac.ssb2<-acf(ssb.chain[,nyears], lag.max=10, plot=F)
  ylims <- c(1.1*min(ac.ssb1$acf,-2/sqrt(niter)), 1 )
  plot(seq(0,10), ac.ssb1$acf, xlab=paste0("Lag SSB",years[1]), ylab="ACF", type="h",ylim=ylims )
  abline(h=0, lwd=2, col='black')
  abline(h=2/sqrt(niter), col='red', lty=2)
  abline(h=-2/sqrt(niter), col='red', lty=2)

  plot(seq(0,10), ac.ssb2$acf, xlab=paste0("Lag SSB",years[nyears]), ylab="ACF", type="h",ylim=ylims )
  abline(h=0, lwd=2, col='black')
  abline(h=2/sqrt(niter), col='red', lty=2)
  abline(h=-2/sqrt(niter), col='red', lty=2)

  if (save.plots==T)  savePlot(file=paste0(od, "lag.autocorrelation.SSB.",plotf), type=plotf)

  par(mfcol=c(2,1),mar=c(4,4,2,2))
  ac.f1<-acf(f.chain[,1], lag.max=10, plot=F)
  ac.f2<-acf(f.chain[,nyears], lag.max=10, plot=F)
  ylims <- c(1.1*min(ac.f1$acf,-2/sqrt(niter)), 1 )
  plot(seq(0,10), ac.f1$acf, xlab=paste0("Lag F",years[1]), ylab="ACF", type="h",ylim=ylims )
  abline(h=0, lwd=2, col='black')
  abline(h=2/sqrt(niter), col='red', lty=2)
  abline(h=-2/sqrt(niter), col='red', lty=2)

  plot(seq(0,10), ac.f2$acf, xlab=paste0("Lag F",years[nyears]), ylab="ACF", type="h",ylim=ylims )
  abline(h=0, lwd=2, col='black')
  abline(h=2/sqrt(niter), col='red', lty=2)
  abline(h=-2/sqrt(niter), col='red', lty=2)

  if (save.plots==T)  savePlot(file=paste0(od, "lag.autocorrelation.Freport.",plotf), type=plotf)

  # examine Distribution in first and last year
  ssb1.hist<-hist(ssb.chain[,1],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  ssb2.hist<-hist(ssb.chain[,nyears],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  xlims <- c(min(ssb1.hist$mids, ssb2.hist$mids), max(ssb1.hist$mids, ssb2.hist$mids))

  x1 <- (ssb1.hist$mids)
  y1 <- (ssb1.hist$counts)
  x2 <- (ssb2.hist$mids)
  y2 <- (ssb2.hist$counts)

  par(mfrow=c(2,1) )
  plot(x1,y1, type="l",lty=2,col="blue",lwd=4,xlab=paste0("SSB", years[1]), ylab="Freq",
       ylim=c(0, max( 1.02*y1)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=asap$SSB[1], col='red', lty=4)
  legend('topleft', legend=c("MCMC", "Point Est."), col=c("blue", "red"), lwd=c(2,2),
         lty=c(1,4), cex=0.85 )

  plot(x2,y2, type="l",lty=2,col="blue",lwd=4,xlab=paste0("SSB", years[nyears]), ylab="Freq",
       ylim=c(0, max( 1.02*y2)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=asap$SSB[nyears], col='red', lty=4)
  if (save.plots==T)  savePlot(paste0(od, 'Distribution.SSB.first.last.yr.',plotf), type=plotf)

  f1.hist<-hist(f.chain[,1],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  f2.hist<-hist(f.chain[,nyears],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  xlims <- c(min(f1.hist$mids, f2.hist$mids), max(f1.hist$mids, f2.hist$mids))

  x1 <- (f1.hist$mids)
  y1 <- (f1.hist$counts)
  x2 <- (f2.hist$mids)
  y2 <- (f2.hist$counts)

  par(mfrow=c(2,1) )
  plot(x1,y1, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Freport", years[1]), ylab="Freq",
       ylim=c(0, max( 1.02*y1)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=asap$F.report[1], col='red', lty=4)
  legend('topleft', legend=c("MCMC", "Point Est."), col=c("blue", "red"), lwd=c(2,2),
         lty=c(1,4), cex=0.85 )

  plot(x2,y2, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Freport", years[nyears]), ylab="Freq",
       ylim=c(0, max( 1.02*y2)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=asap$F.report[nyears], col='red', lty=4)

  if (save.plots==T)  savePlot(paste0(od, 'Distribution.Freport.first.last.yr.',plotf), type=plotf)

  fm1.hist<-hist(fmult.chain[,1],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  fm2.hist<-hist(fmult.chain[,nyears],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  xlims <- c(min(fm1.hist$mids, fm2.hist$mids), max(fm1.hist$mids, fm2.hist$mids))

  x1 <- (fm1.hist$mids)
  y1 <- (fm1.hist$counts)
  x2 <- (fm2.hist$mids)
  y2 <- (fm2.hist$counts)
  full.f <- apply(asap$F.age,1,max)

  par(mfrow=c(2,1) )
  plot(x1,y1, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Full F", years[1]), ylab="Freq",
       ylim=c(0, max( 1.02*y1)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=full.f[1], col='red', lty=4)
  legend('topleft', legend=c("MCMC", "Point Est."), col=c("blue", "red"), lwd=c(2,2),
         lty=c(1,4), cex=0.85 )

  plot(x2,y2, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Full F", years[nyears]), ylab="Freq",
       ylim=c(0, max( 1.02*y2)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=full.f[nyears], col='red', lty=4)

  if (save.plots==T)  savePlot(paste0(od, 'Distribution.Fmult.first.last.yr.',plotf), type=plotf)

  b1.hist<-hist(totB.chain[,1],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  b2.hist<-hist(totB.chain[,nyears],breaks = "Sturges", include.lowest = TRUE, right = TRUE, plot=F)
  xlims <- c(min(b1.hist$mids, b2.hist$mids), max(b1.hist$mids, b2.hist$mids))

  x1 <- (b1.hist$mids)
  y1 <- (b1.hist$counts)
  x2 <- (b2.hist$mids)
  y2 <- (b2.hist$counts)
  tot.B <- asap$tot.jan1.B

  par(mfrow=c(2,1) )
  plot(x1,y1, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Jan-1 B", years[1]), ylab="Freq",
       ylim=c(0, max( 1.02*y1)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=tot.B[1], col='red', lty=4)
  legend('topleft', legend=c("MCMC", "Point Est."), col=c("blue", "red"), lwd=c(2,2),
         lty=c(1,4), cex=0.85 )

  plot(x2,y2, type="l",lty=2,col="blue",lwd=4,xlab=paste0("Jan-1 B", years[nyears]), ylab="Freq",
       ylim=c(0, max( 1.02*y2)), xlim=c(0.98*xlims[1], 1.02*xlims[2]) )
  abline(v=tot.B[nyears], col='red', lty=4)

  if (save.plots==T)  savePlot(paste0(od, 'Distribution.Jan1.B.first.last.yr.',plotf), type=plotf)

  ####   Probability Interval Plots
  #plot 95% PI

  #sort
  par(mfrow=c(1,1), mar=c(4,4,2,3), oma=c(1,1,1,1)  )

  ssb.sort<- (apply(ssb.chain,2,sort ))
  p5 <- trunc( dim(ssb.sort)[1] *.05)
  p95 <-  trunc( dim(ssb.sort)[1] *.95)

  p50 <- median(dim(ssb.sort)[1])
  p10 <-  trunc( dim(ssb.sort)[1] *.10)
  p90 <-  trunc( dim(ssb.sort)[1] *.90)

  plot(years, ssb.sort[p5,], type='l', col='grey35', lwd=2, xlab='Year',
       ylab='', ylim=c(0,1.03*max(ssb.sort[p95,])), axes=F  )
  axis(side=1, at=years[seq(1,nyears,by=2)], labels=years[seq(1,nyears,by=2)], las=2)
  axis(side=2, at=pretty(seq(0,1.01*max(ssb.sort)), n=10) ,
       labels=format(pretty(seq(0,1.01*max(ssb.sort)), n=10), scientific=T), las=1)
  axis(side=4, at=pretty(seq(0,1.01*max(ssb.sort)), n=10) ,
       labels=format(pretty(seq(0,1.01*max(ssb.sort)), n=10), scientific=T), las=1)
  box()
  mtext(side=2, text="SSB", outer=T)
  lines( years, ssb.sort[p95,] , col='grey35', lwd=2)
  lines( years, apply(ssb.sort,2,median) , col='red', lwd=2)
  lines( years, asap$SSB , col='green3', lwd=1)
  points( years, asap$SSB , col='green3', pch=17, cex=0.7)

  legend('topleft', horiz=T, legend=c("5th, 95th", "Median","Point Est."),
         col=c("grey35", "red", "green3"), lwd=c(2,2,2), lty=c(1,1,1), cex=0.85,
         pch=c(1,1,17), pt.cex=c(0,0,1) )

  if (save.plots==T)  savePlot(paste0(od, "SSB.90PI.", plotf), type=plotf)

  ssb.pi <- cbind(years, "5th"=ssb.sort[p5,], "Median"=apply(ssb.sort,2,median), "95th"=ssb.sort[p95,])
  write.csv(ssb.pi, file=paste0(od, "ssb.90pi_",asap.name,".csv"),
            row.names=F )

  f.sort <- (apply(f.chain,2,sort ))
  p5 <- trunc( dim(f.sort)[1] *.05)
  p95 <- trunc( dim(f.sort)[1] *.95)

  p50 <- median(dim(f.sort)[1])
  p10 <- trunc( dim(f.sort)[1] *.10)
  p90 <- trunc( dim(f.sort)[1] *.90)

  par(mfrow=c(1,1), mar=c(4,4,2,3), oma=c(1,1,1,1)  )
  plot(years, f.sort[p5,], type='l', col='grey35', lwd=2, xlab='Year',
       ylab='Freport', ylim=c(0,1.1*max(f.sort[p95,])), axes=F  )
  axis(side=1, at=years[seq(1,nyears,by=2)], labels=years[seq(1,nyears,by=2)], las=2)
  axis(side=2, at=pretty(seq(0,1.01*max(f.sort), by=0.1), n=10) ,
       labels=pretty(seq(0,1.01*max(f.sort), by=0.1), n=10), las=1)
  axis(side=4, at=pretty(seq(0,1.01*max(f.sort), by=0.1), n=10) ,
       labels=pretty(seq(0,1.01*max(f.sort), by=0.1), n=10), las=1)
  box()

  lines( years, f.sort[p95,] , col='grey35', lwd=2)
  lines( years, apply(f.sort,2,median) , col='red', lwd=2)
  lines( years, asap$F.report , col='green3', lwd=1)
  points( years, asap$F.report , col='green3', pch=17, cex=0.7)
  legend('topleft', horiz=T, legend=c("5th, 95th", "Median","Point Est."),
         col=c("grey35", "red", "green3"), lwd=c(2,2,2), lty=c(1,1,1), cex=0.85,
         pch=c(1,1,17), pt.cex=c(0,0,1) )

  if (save.plots==T)  savePlot(paste0(od, "Freport.90PI.", plotf), type=plotf)

  Freport.pi <- cbind(years, "5th"=f.sort[p5,], "Median"=apply(f.sort,2,median), "95th"=f.sort[p95,])
  write.csv(Freport.pi, file=paste0(od, "Freport.90pi_",asap.name,".csv"),   row.names=F)

  fm.sort <- (apply(fmult.chain,2,sort ))
  p5 <- trunc( dim(fm.sort)[1] *.05)
  p95 <- trunc( dim(fm.sort)[1] *.95)

  p50 <- median(dim(fm.sort)[1])
  p10 <- trunc( dim(fm.sort)[1] *.10)
  p90 <- trunc( dim(fm.sort)[1] *.90)

  par(mfrow=c(1,1), mar=c(4,4,2,3), oma=c(1,1,1,1)  )
  plot(years, fm.sort[p5,], type='l', col='grey35', lwd=2, xlab='Year',
       ylab='Full F', ylim=c(0,1.1*max(fm.sort[p95,])), axes=F  )
  axis(side=1, at=years[seq(1,nyears,by=2)], labels=years[seq(1,nyears,by=2)], las=2)
  axis(side=2, at=pretty(seq(0,1.01*max(fm.sort), by=0.1), n=10) ,
       labels=pretty(seq(0,1.01*max(fm.sort), by=0.1), n=10), las=1)
  axis(side=4, at=pretty(seq(0,1.01*max(fm.sort), by=0.1), n=10) ,
       labels=pretty(seq(0,1.01*max(fm.sort), by=0.1), n=10), las=1)
  box()

  lines( years, fm.sort[p95,] , col='grey35', lwd=2)
  lines( years, apply(fm.sort,2,median) , col='red', lwd=2)
  lines( years, full.f , col='green3', lwd=1)
  points( years, full.f, col='green3', pch=17, cex=0.7)
  legend('topleft', horiz=T, legend=c("5th, 95th", "Median","Point Est."),
         col=c("grey35", "red", "green3"), lwd=c(2,2,2), lty=c(1,1,1), cex=0.85,
         pch=c(1,1,17), pt.cex=c(0,0,1) )

  if (save.plots==T)  savePlot(paste0(od, "Full.F.90PI.", plotf), type=plotf)

  Full.F.pi <- cbind(years, "5th"=fm.sort[p5,], "Median"=apply(fm.sort,2,median), "95th"=fm.sort[p95,])
  write.csv(Full.F.pi, file=paste0(od, "Full.F.90pi_",asap.name,".csv"), row.names=F)

  tb.sort <- (apply(totB.chain,2,sort ))
  p5 <- trunc( dim(tb.sort)[1] *.05)
  p95 <- trunc( dim(tb.sort)[1] *.95)

  p50 <- median(dim(tb.sort)[1])
  p10 <- trunc( dim(tb.sort)[1] *.10)
  p90 <- trunc( dim(tb.sort)[1] *.90)

  par(mfrow=c(1,1), mar=c(4,4,2,3), oma=c(1,1,1,1)  )
  plot(years, tb.sort[p5,], type='l', col='grey35', lwd=2, xlab='Year',
       ylab='', ylim=c(0,1.03*max(tb.sort[p95,])), axes=F  )
  axis(side=1, at=years[seq(1,nyears,by=2)], labels=years[seq(1,nyears,by=2)], las=2)
  axis(side=2, at=pretty(seq(0,1.01*max(tb.sort), by=max(tb.sort)/10), n=10) ,
       labels=format(pretty(seq(0,1.01*max(tb.sort), by=max(tb.sort)/10), n=10), scientific=T), las=1)
  axis(side=4, at=pretty(seq(0,1.01*max(tb.sort), by=max(tb.sort)/10), n=10) ,
       labels=format(pretty(seq(0,1.01*max(tb.sort), by=max(tb.sort)/10), n=10), scientific=T), las=1)

  box()
  mtext(side=2, text="Jan-1 Biomass", outer=T)
  lines( years, tb.sort[p95,] , col='grey35', lwd=2)
  lines( years, apply(tb.sort,2,median) , col='red', lwd=2)
  lines( years, asap$tot.jan1.B , col='green3', lwd=1)
  points( years, asap$tot.jan1.B, col='green3', pch=17, cex=0.7)
  legend('topleft', horiz=T, legend=c("5th, 95th", "Median","Point Est."),
         col=c("grey35", "red", "green3"), lwd=c(2,2,2), lty=c(1,1,1), cex=0.85,
         pch=c(1,1,17), pt.cex=c(0,0,1) )

  if (save.plots==T)  savePlot(paste0(od, "Jan1.B.90PI.", plotf), type=plotf)

  Tot.B.pi <- cbind(years, "5th"=tb.sort[p5,], "Median"=apply(tb.sort,2,median), "95th"=tb.sort[p95,])
  write.csv(Tot.B.pi, file=paste0(od, "Jan1.B.90pi_",asap.name,".csv"), row.names=F)

  return()
}  # end function


#' @title Livestock resilience model
#'
#' @description A model of resilience in arid rangelands.
#' @usage
#' library(livestock)
#'
#'
#' library(caspr)
#' ca(l, livestock, parms = p)
#'
#' @param b environmental quality
#' @param m intrinsic plant mortality, i.e. inverse of av. lifespan
#' @param r max. regeneration rate of plants
#' @param K carrying capacity of the landscape (i.e. global competition)
#' @param f local facilitation
#' @param c local competition
#' @param L livestock density
#' @param a attack rate of livestock
#' @param h handling time of livestock
#' @param q hill-exponent of livestock
#' @param p associational resistance against livestock grazing
#' @param v attractant-decoy effect of plants to livestock
#'
#' @author F.D. Schneider
#' @family models
#' @details
#' An unpublished, generalized model of positive and negative local feedbacks in arid rangelands, including mechanisms such as local facilitation, competition, associational resistance and attractant-decoy.
#'
#' @export

"livestock"

livestock <- list(
  name = "Livestock resilience model",
  ref = NA , # a bibliographic reference,
  states = c("1", "0"),
  cols = c("black", "white"),
  template = ini_rho(rho_1 = 0.9999),
  parms = list(
    r = 1,
    b = 1,
    K = 1,
    alpha = 0,
    c = 0,
    f = 0,
    m = 0.05,
    a = 10,
    h = 20,
    L = 1,
    q = 0,
    v = 0,
    p = 0
  ),
  pair = function(t, rho, parms = model_parms) {

    # insert equations here
    delta_1 = (1-rho[[1]]) * colonization(rho, parms) - rho[[1]] * death(rho, parms)
    delta_11 = 2 * (rho[[1]]-rho[[2]]) * colonization(rho, parms) - 2 * rho[[2]] * death(rho, parms)

    if(rho[[1]] < 1e-6) {
      out <- list(c(
        rho_1 = 0,
        rho_11 = 0
      )  )
    } else {
      out <- list(c(
        rho_1 = delta_1,
        rho_11 = delta_11
      )  )
    }
    return(out)
  },
  pairmeanfield = function(t, rho, parms = model_parms) {
    pair(t, ini_rho(rho[[1]]), parms)
  },
  meanfield = function(t, rho, parms = model_parms) {

    rho <- ini_rho(rho[[1]])
    delta_1 <- (1-rho[[1]])*colonization(rho, parms) - rho[[1]]*death(rho, parms)

    if(rho[[1]]+delta_1 < 1e-6) {
      out <- list(c(
        rho_1 = 0,
        rho_11 = 0
      )  )
    } else {
      out <- list(c(
        rho_1 = delta_1,
        rho_11 = delta_1
      )  )
    }
    return(out)
  },
  update = function(x_old, parms, subs = 24, i = i) {  #for cellular automata simulation in package caspr

    x_new <- x_old

    for(s in 1:subs) {

      # define update procedures depending on parms

      # model specific part:
      # 1 - setting time-step parameters
      rho_one <- as.numeric(sum(x_old$cells == "1")/(x_old$dim[1]*x_old$dim[2])) # get initial vegetation cover
      q_one_one <- neighbors(x_old, "1")/4  # count local density of occupied fields for each cell

      # 2 - drawing random numbers
      rnum <- runif(x_old$dim[1]*x_old$dim[2]) # one random number between 0 and 1 for each cell

      # 3 - setting transition probabilities
      growth <- colonization(ini_rho(rho_one, q_11 = q_one_one), parms) *1/subs  # recolonisation rates of all cells

      growth[growth < 0] <- 0

      death <- death(ini_rho(rho_one, q_11 = q_one_one), parms) *1/subs   # set probability of death for each cell

      death[death < 0] <- 0

      # check for sum of probabilities to be inferior 1 and superior 0
      if(any(c(growth, death) > 1 )) warning(paste("a set probability is exceeding 1 ! decrease delta!!!"))
      #if(any(c(growth, death) < 0)) warning(paste("a set probability falls below 0 in time step", i, "! balance parameters!!!"))

      # 4 - apply transition probabilities

      x_new$cells[which(x_old$cells == "0" & rnum <= growth)] <- "1"
      x_new$cells[which(x_old$cells == "1" & rnum <= death)] <- "0"

      # 5- store x_new as next x_old

      x_old <- x_new

    }

    return(x_new)

  }

)

class(livestock) <- c("ca_model", "list")


count = function(haystack, needle)
   {v = attr(gregexpr(needle, haystack, fixed = T)[[1]], "match.length")
    if (identical(v, -1L)) 0 else length(v)}

print(count("hello", "l"))


library(band)

x <- as.banded(matrix(1:100, 10, 10), 2, 2)

test <- zeromat(getdim(x))
stopifnot(identical(test, x*0))
stopifnot(identical(test, 0*x))

stopifnot(identical(x, x*1.0))
stopifnot(identical(x, x*1L))
stopifnot(identical(x, 1*x))

test <- 2*x
truth <- 2*getData(x)
stopifnot(identical(test, truth))


# Altitude analysis in continuation with v08. Here we compare the barometers
# which are on the same location.

source('./drifts/analysis_08.r', encoding = 'UTF-8')

location <- function(logger.name) {
  sub('[^/]*/([^_]+).*', '\\1', logger.name)
}

df.altitude <- data.table::data.table('location' = location(names(altitude.m.bf)),
                                      'altitude.m.bf' = altitude.m.bf)

# DIFFERENCE BETWEEN AVERAGE PRESSURE ON THE SAME LOCATION
df.altitude[, altitude.diff.m.bf := max(altitude.m.bf) - min(altitude.m.bf), by = location]
df.altitude[, N := .N, by = location]
df.altitude[!duplicated(location), !'altitude.m.bf'][altitude.diff.m.bf != 0, ][order(altitude.diff.m.bf, decreasing = TRUE), ]

plot.location <- function(location, df.list) {
  df.sel <- df.list[location(names(df.list)) == location]

  plot.baro <- function(df) {
    med <- median(df$PRESSURE_VALUE)
    ggplot2::ggplot(data = df, mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_VALUE)) +
      ggplot2::geom_line(color = 'grey90') +
      ggplot2::geom_hline(yintercept = med) +
      ggplot2::annotate("text", vjust = -0.25, hjust = 0,
                        x = min(df$TIMESTAMP_UTC), y = med,
                        label = sprintf('Median: %0.2f cmH2O @ %.2fm (MSL)', med,
                                        altitude.m.bf[sprintf('barometer/%s', unique(df$FILE))])) +
      ggplot2::theme_light() +
      ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                     plot.title = ggplot2::element_text(size = 10)) +
      ggplot2::ggtitle(sprintf('%s (%i observations)', unique(df$FILE), nrow(df)))
  }
  plots <- lapply(df.sel, plot.baro)

  df <- data.table::rbindlist(df.sel, use.names = TRUE)
  p.box <- ggplot2::ggplot(df, ggplot2::aes(y = PRESSURE_VALUE, x = FILE)) +
    ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(0)), size = 1, col = 'darkblue', linetype = 'dotted') +
    ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(50*c(-1,1))), size = 1, col = 'green', linetype = 'dotted') +
    ggplot2::geom_hline(yintercept = bf$P.Pa_to_cmH2O(bf$P.lr(100*c(-1,1))), size = 1, col = 'red', linetype = 'dotted') +
    ggplot2::geom_boxplot() +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                   axis.title.x = ggplot2::element_blank())

  layout_matrix <- matrix(rep(1L:length(plots), 2L), ncol = 2)
  layout_matrix <- cbind(layout_matrix, length(plots) + 1L)

  altitude.diff.max <- max(altitude.m.bf[names(df.sel)]) - min(altitude.m.bf[names(df.sel)])

  grob.title <- grid::textGrob(sprintf('%s: max difference in altitude: %.2fm', location, altitude.diff.max),
                               x = 0.05, hjust = 0)

  do.call(gridExtra::grid.arrange, c(unname(plots),
                                     list(p.box,
                                          layout_matrix = layout_matrix,
                                          top = grob.title)))

}

local({
  locations <- df.altitude[!duplicated(location), ][altitude.diff.m.bf != 0, location]

  save.plot <- function(filename, plot) {
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    plot
  }

  for (loc in locations) {
    alt.diff.m <- df.altitude[location == loc, altitude.diff.m.bf][1L]
    filename <- sprintf('./drifts/analysis_14/LOC_%03.0fm_%s.png', alt.diff.m, loc)
    save.plot(filename, plot.location(loc, df.list = df.list))
  }
})


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

NE = 44514
t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
te = strptime("2010-09-01 0:0:0", "%Y-%m-%d %H:%M:%S");
NM = 116
Mlen = (te-t0)/NM

A <- scan(paste(RESDIR,'edit_times.csv',sep=''),'character');
stopifnot(length(A) == NE)

MatAll <- array(0,c(NE,NM+1))
MatUnq <- array(0,c(NE,NM+1))

fsdt = read.csv(paste(RESDIR,'eid_fsdt_regdate_table.csv',sep=''), header = TRUE);

for (ia in 1:NE){

	if (ia%%2000 == 0) {cat(sprintf("Parsed %i of %i editors",ia,NE),"\n")}
	MatAll[ia,1] = fsdt[ia,1]
	MatUnq[ia,1] = fsdt[ia,1]

	splita <- as.integer(strsplit(A[ia],",",fixed=T)[[1]])
	for (m in 1:NM){
		winst = (m-1)*Mlen
		winen = winst + Mlen
		iwithin = (splita > winst & splita <= winen)
		MatAll[ia,m+1] = sum(iwithin)
		MatUnq[ia,m+1] = length(unique(splita[iwithin]))
	}
}
cat(sprintf("Writing tables into CSV files..."),"\n")
colnames(MatAll) = c("user_id",seq(1,NM,1));
colnames(MatUnq) = c("user_id",seq(1,NM,1));

# write(t(MatAll),paste(RESDIR,'editor_monthly_edits.csv',sep=''),ncolumns = dim(MatAll)[2],sep = ",")
# write(t(MatUnq),paste(RESDIR,'editor_monthly_edits_unique_days.csv',sep=''),ncolumns = dim(MatUnq)[2],sep = ",")
write.csv(MatAll, file=paste(RESDIR,'editor_monthly_edits.csv',sep=''),row.names=F)
write.csv(MatUnq, file=paste(RESDIR,'editor_monthly_edits_unique_days.csv',sep=''),row.names=F)
alarm()

RD <- read.csv(paste(DATADIR,'regdates.tsv',sep=''),header=T,sep='\t')
EL <- scan(paste(RESDIR,'editor_list.txt',sep=''),what='integer')
EL = as.integer(EL)
ELT = array(0,c(length(EL),2))
t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
ELT[,1] = EL
for (i in 1:length(EL)){
	ix <- which(RD[,1] == EL[i])
	ELT[i,2] <- strptime(RD[ix,2],"%Y-%m-%d") - t0
}
ibad = which(is.na(ELT[,2]))
for (ib in ibad){
	ELT[ib,2] <- min(as.integer(strsplit(A[ib],',',fixed=T)[[1]]))
}
#write(t(ELT),file=paste(RESDIR,'editor_regdate.csv',sep=''),sep=',',ncolumns=2)
colnames(ELT) = c("user_id","reg_date")
write.csv(ELT, file=paste(RESDIR,'editor_regdate.csv',sep=''),row.names=F)


#
# Example R program
#

library("topicmodels")

data("AssociatedPress", package = "topicmodels")
lda <- LDA(AssociatedPress[1:20,], control = list(alpha = 0.1), k = 2)
lda_inf <- posterior(lda, AssociatedPress[21:30,])


#' @title
#' Plot heatmap for the functional regression surface
#'
#' @description
#' This function creates heatmaps for the functional regression surface in a
#' multivariate functional linear regression. Based on the fitting results from the
#' nested reduced-rank regression, different kinds of regression surfaces
#' (at the original scale or the latent scale) can be visualized to give a
#' clear illustration of the functional correlation between the user-specified
#' predictor (or latent predictor) trajectory and response
#' (or latent response) trajectory.
#'
#'
#' @usage
#' NRRR.plot.reg(Ag, Bg, Al, Bl, rx, ry, sseq, phi, tseq, psi,
#'               x_ind, y_ind, x_lab = NULL, y_lab = NULL,
#'               tseq_index = NULL, sseq_index = NULL,
#'               method = c("latent", "x_original",
#'               "y_original", "original")[1])
#'
#'
#' @param Ag,Bg,Al,Bl,rx,ry the estimated U, V, A, B, rx and ry from a NRRR fitting.
#' @param sseq the sequence of time points at which the predictor trajectory is observed.
#' @param phi the set of basis functions to expand the predictor trajectory.
#' @param tseq the sequence of time points at which the response trajectory is observed.
#' @param psi the set of basis functions to expand the response trajectory.
#' @param x_ind,y_ind two indices to locate the regression surface for which the heat map is to be drawn.
#'                    If \code{method = "original"}, then \eqn{0 < x_ind <= p, 0 < y_ind <= d}
#'                    and the function plots \eqn{C_{x_ind,y_ind}(s,t)} in Eq. (1) of the NRRR paper.
#'                    If \code{method = "latent"}, then \eqn{0 < x_ind <= rx, 0 < y_ind <= ry}
#'                    and the function plots \eqn{C^*_{x_ind,y_ind}(s,t)} in Eq. (2) of the NRRR paper.
#'                    If \code{method = "y_original"}, then \eqn{0 < x_ind <= rx, 0 < y_ind <= d}.
#'                    If \code{method = "x_original"}, then \eqn{0 < x_ind <= p, 0 < y_ind <= ry}.
#' @param x_lab,y_lab the user-specified x-axis (with x_lab for predictor) and
#'                    y-axis (with y_lab for response) label,
#'                    and it should be given as a character string, e.g., x_lab = "Temperature".
#' @param tseq_index,sseq_index the user-specified x-axis (with sseq_index for predictor)
#'                              and y-axis (with tseq_index for response) tick marks, and it should be
#'                              given as a vector of character strings of the same length as sseq or tseq, respectively.
#' @param method 'original': the function plots the correlation heatmap between the original
#'               functional response \eqn{y_i(t)} and the original functional predictor \eqn{x_j(s)};
#'               'latent': the function plots the correlation heatmap between
#'               the latent functional response \eqn{y^*_i(t)} and the latent functional predictor \eqn{x^*_j(s)};
#'               'y_original': the function plots the correlation heatmap between \eqn{y_i(t)} and \eqn{x^*_j(s)};
#'               'x_original': the function plots the correlation heatmap between \eqn{y^*_i(t)} and \eqn{x_j(s)}.
#'
#' @return A ggplot2 object.
#'
#' @details
#' More details and the examples of its usage can be found in the vignette of electricity demand analysis.
#'
#' @references
#' Liu, X., Ma, S., & Chen, K. (2020). Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#' @import ggplot2
#' @importFrom reshape2 melt
#' @export

NRRR.plot.reg <- function(Ag, Bg, Al, Bl, rx, ry,
                                 sseq, phi, tseq, psi,
                                 x_ind, y_ind,
                                 x_lab = NULL, y_lab = NULL,
                                 tseq_index = NULL, sseq_index = NULL,
                                 method = c("latent", "x_original", "y_original","original")[1]
){
  ry <- ry
  rx <- rx
  Al <- Al
  Bl <- Bl
  Ag <- Ag
  Bg <- Bg
  p <- dim(Bg)[1]
  d <- dim(Ag)[1]
  ns <- dim(phi)[1]
  nt <- dim(psi)[1]
  jx <- dim(phi)[2]
  jy <- dim(psi)[2]

  if (method == "original" & any(c(0 > x_ind, x_ind > p, 0 > y_ind, y_ind > d))) stop("when 'original' is selected, 0 < x_ind <= p, 0 < y_ind <= d")
  if (method == "latent" & any(c(0 > x_ind, x_ind > rx, 0 > y_ind, y_ind > ry))) stop("when 'latent' is selected, 0 < x_ind <= rx, 0 < y_ind <= ry")
  if (method == "y_original" & any(c(0 > x_ind, x_ind > rx, 0 > y_ind, y_ind > d))) stop("when 'y_original' is selected, 0 < x_ind <= rx, 0 < y_ind <= d")
  if (method == "x_original" & any(c(0 > x_ind, x_ind > p, 0 > y_ind, y_ind > ry))) stop("when 'x_original' is selected, 0 < x_ind <= p, 0 < y_ind <= ry")

  Jpsi <- matrix(nrow = jy, ncol = jy, 0)
  tdiff <- (tseq - c(0, tseq[-nt]))
  for (t in 1:nt) Jpsi <- Jpsi + psi[t, ] %*% t(psi[t, ]) * tdiff[t]
  eJpsi <- eigen(Jpsi)
  Jpsihalf <- eJpsi$vectors %*% diag(sqrt(eJpsi$values)) %*% t(eJpsi$vectors)
  Jpsihalfinv <- eJpsi$vectors %*% diag(1 / sqrt(eJpsi$values)) %*% t(eJpsi$vectors)

  alindex <- rep(1:ry,jy)
  Alstar <- Al[order(alindex),]
  blindex <- rep(1:rx,jx)
  Blstar <- Bl[order(blindex),]

  Alstar <- kronecker(diag(ry),Jpsihalfinv)%*%Alstar
  Core <- Alstar%*%t(Blstar)

  comp <- array(dim = c(ry, rx, nt, ns), NA)

  for (i in 1:ry){
    for (j in 1:rx){
      comp[i,j,,] <- psi%*%Core[c(((i-1)*jy + 1):(i*jy)),
                                    c(((j-1)*jx + 1):(j*jx))]%*%t(phi) # nt \times ns
    }
  }

  if (method == "original"){
    comp.ori <- array(dim = c(d, p, nt, ns), NA)
    for (i in 1:nt){
      for (j in 1:ns){
        comp.ori[ , , i, j] <- Ag%*%comp[ , , i, j]%*%t(Bg)
      }
    }
    comp <- comp.ori
  } else if (method == "y_original"){
    comp.ori <- array(dim = c(d, rx, nt, ns), NA)
    for (i in 1:nt){
      for (j in 1:ns){
        comp.ori[ , , i, j] <- Ag%*%comp[ , , i, j]
      }
    }
    comp <- comp.ori
  } else if (method == "x_original"){
    comp.ori <- array(dim = c(ry, p, nt, ns), NA)
    for (i in 1:nt){
      for (j in 1:ns){
        comp.ori[ , , i, j] <- comp[ , , i, j]%*%t(Bg)
      }
    }
    comp <- comp.ori
  }

  # heatmap for coefficient function
  # library(ggplot2)
  # library(reshape2)

    dat <- reshape2::melt(as.matrix(comp[y_ind, x_ind, , ]))

    dat$Var1 <- factor(dat$Var1)
    dat$Var2 <- factor(dat$Var2)
    if (is.null(tseq_index)) {
      levels(dat$Var1) <- factor(tseq)
      y_breaks <- tseq[seq(1,nt,2)]
    } else {
      levels(dat$Var1) <- tseq_index
      y_breaks <- tseq_index[seq(1,nt,2)]
    }

    if (is.null(sseq_index)) {
      levels(dat$Var2) <- factor(sseq)
      x_breaks <- sseq[seq(1,ns,2)]
    } else {
      levels(dat$Var2) <- sseq_index
      x_breaks <- sseq_index[seq(1,ns,2)]
    }

    # Var1 <- dat$Var1
    # Var2 <- dat$Var2
    # value <- dat$value

    ggplot2::ggplot(dat, aes(Var2, Var1, fill = value)) + geom_tile() +
      scale_fill_gradient2(low = "blue", mid = "white",
                           high = "red", midpoint = 0, limits= range(comp),
                           space = "Lab", name = "",
                           na.value = "grey50", guide = "colourbar", aesthetics = "fill")+
      scale_x_discrete(breaks = x_breaks) +
      scale_y_discrete(breaks = y_breaks) +
      ylab(ifelse(is.null(y_lab), "response (t)", y_lab)) +
      xlab(ifelse(is.null(x_lab), "predictor (s)", x_lab)) +
      theme_classic() +
      theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
      theme(axis.text=element_text(size=10),axis.title=element_text(size=13),
            plot.title = element_text(hjust = 0.5, size = 15))
}