#' Read MODFLOW .dis File
#'
#' This function reads in a dis file and creates a list
#' composed of the following vectors:
#' \describe{
#' \item{NLAY}{Atomic Vector of the Number of Layers in the Model Grid}
#' \item{NROW}{Atomic Vector of the Number of Rows in the Model Grid}
#' \item{NCOL}{Atomic Vector of the Number of Columns in the Model Grid}
#' \item{NPER}{Atomic Vector of the Number of Stress Periods in the Model Grid}
#' \item{ITMUNI}{Atomic Vector Indicating the Time Unit of Model Data : 0 = Undefined, 1 = Seconds, 2 = Minutes, 3 = Hours, 4 = Days, 5 = Years}
#' \item{LENUNI}{Atomic Vector Indicating the Length Unit of Model Data : 0 = Undefined, 1 = Feet, 2 = Meters, 3 = Centimeters}
#' \item{LAYCBD}{Flag With One Value for Each Model Layer that Indicates Whether or Not a Layer has a Quasi-3D Confining Bed Below it. 0 Indicates No Confining Bed and Not 0 Indicates Confining Bed}
#' \item{dX}{Cell Width Along Columns}
#' \item{dY}{Cell Width Along Rows}
#' \item{TOP}{Top Elevation of Layer 1}
#' \item{BOT}{Bottom Elevation of Each Model Cell or a Quasi-3D Confining Bed}
#' \item{PERLEN}{Length of Each Stress Period}
#' \item{NSTP}{Number of Time Steps in a Stress Period}
#' \item{TSMULT}{Multiplier Length of Successive Time Steps. See the MODFLOW2005 Manual For a Description.}
#' \item{SS}{Character Vector Indicating Whether The Stressperiod is Transient ("TR") or Steady State ("SS")}
#' }
#' @param rootname This is the root name of the dis file
#' @export
#' @examples
#' readdis("F95")
#' $NLAY
#' [1] 8
#'
#' $NCOL
#' [1] 610
#'
#' $NROW
#' [1] 414
#'
#' $NPER
#' [1] 16
#'
#' $ITMUNI
#' [1] 4
#'
#' $LENUNI
#' [1] 1
#'
#' $LAYCBD
#'   L1 L2 L3 L4 L5 L6 L7 L8
#'   0  0  0  0  0  0  0  0
#' etc.

readdis <- function(rootname = NA){
    if(is.na(rootname)){
            rootname <- MFtools::getroot()
    }
    infl <- paste0(rootname, ".dis")
    linin <- readr::read_lines(infl) %>% .[!grepl("#", .)]              # READ IN DIS FILE BUT REMOVE COMMENTED LINES
                                                                # THIS IS IN PREPARATION FOR MODFLOW 6
    indx <- 1
    NLAY <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.integer()
    NROW <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.integer()
    NCOL <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(3) %>% as.integer()
    NPER <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(4) %>% as.integer()
    ITMUNI <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(5) %>% as.integer()
    LENUNI <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(6) %>% as.integer()

    HDGLOC       <- grep("\\(", linin)
    HDG          <- linin[HDGLOC]
    UNI          <- substr(HDG, start = 1, stop = 10) %>% as.integer()
    MULT         <- substr(HDG, start = 11, stop = 20) %>% as.numeric()
    ARR_MULT     <- UNI / UNI
    ARR_MULT[is.na(ARR_MULT)] <- 0
    MULTLOC      <- grep("^0$", UNI)
    FRMT         <- substr(HDG, start = 21, stop = 30)
    FRMTREP      <- regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT)) %>% lapply('[[', 1) %>% unlist() %>% as.integer()
    BLOCK_START  <- HDGLOC + 1
    BLOCK_END    <- dplyr::lead(BLOCK_START) - 2
    BLOCK_LENGTH <- (NROW * ceiling(NCOL / FRMTREP))
    BLOCK_END[length(BLOCK_END)] <- BLOCK_END[length(BLOCK_END) - 1] + BLOCK_LENGTH[length(BLOCK_END)] + 1
    BLOCK_START  <- BLOCK_START * ARR_MULT
    BLOCK_END    <- BLOCK_END * ARR_MULT
    CELL_INDX    <- Map(seq, BLOCK_START, BLOCK_END)

    indx <- indx + 1
    BLOCKSIZE <- NROW * NCOL
    BLOCKEND <- ceiling(NLAY / 50)
    LAYCBD <- linin[indx + seq(1:BLOCKEND) - 1] %>% MFtools::parse_MF_FW_LINE() %>%
              as.integer()

# COLUMN WIDTHS
#---------------------------------------------------------
    indx <- HDGLOC[1]
    dX <- vector(mode = "numeric", length = NCOL)
    X <- vector(mode = "numeric", length = NCOL)
    BLOCKEND <- (ceiling(NCOL / FRMTREP[1]))
    indx <- indx + 1
    if(UNI[1] == 0){
    dX <- rep(MULT[1], NCOL)
    }else{
        dX <- linin[indx + seq(1:BLOCKEND) - 1] %>% parse_MF_FW_LINE()
        }
    dX %<>% as.numeric()
    X <- c(dX[1] / 2., dX[1:(NCOL - 1)] / 2 + dX[2:NCOL] / 2) %>% cumsum()
# ROW WIDTHS
#----------------------------------------------------------
    indx <- HDGLOC[2]
    dY <- vector(mode = "numeric", length = NROW)
    Y <- vector(mode = "numeric", length = NROW)
    BLOCKEND <- (ceiling(NROW / FRMTREP[2]))
    indx <- indx + 1
    if(UNI[2] == 0){
    dY <- rep(MULT[2], NROW)
    }else{
        dY <- linin[indx + seq(1:BLOCKEND) - 1] %>% MFtools::parse_MF_FW_LINE()
        }
    dY %<>% as.numeric()
    Y <- sum(dY) - (c(dY[1] / 2., dY[1:(NROW - 1)] / 2. + dY[2:NROW] / 2.) %>% cumsum())
# TOP ELEVATION
#-----------------------------------------------------------
    indx <- HDGLOC[3]
    TOPin <- vector(mode = "numeric", length = BLOCKSIZE)
    BLOCKEND <- (NROW * ceiling(NCOL / FRMTREP[3]))
    indx <- indx + 1
    if(UNI[3] == 0){
        TOPin <- rep(MULT[3], BLOCKSIZE)
    }else{
        TOPin <- linin[indx + seq(1:BLOCKEND) - 1] %>% parse_MF_FW_LINE()
    }
    TOPin %<>% as.numeric()

    TOP <- tibble::data_frame(ROW = rep(1:NROW, each = NCOL) %>% as.integer(),
                              COL = rep(seq(1, NCOL, 1), NROW) %>% as.integer(),
                              X   = rep(X, NROW) %>% as.numeric(),
                              Y   = rep(Y, each = NCOL) %>% as.numeric(),
                              TOP = TOPin %>% as.numeric())
    rm(TOPin)

# BOTTOM ELEVATIONS
#-----------------------------------------------------------
    indx <- HDGLOC[4]
    #BOTin <- vector(mode = "numeric", length = NLAY * BLOCKSIZE)

    VAL <- vector(mode = "numeric", length = NLAY * BLOCKSIZE)
if(length(MULTLOC[MULTLOC > 3]) > 0){
    # SPECIFIED CELLS: CELL BOTTOM ELEVATIONS SPECIFED USING MULT
    # SPEC_CELLS ARE THE CELLS THAT ARE DEFINED WHEN UNIT == 0
    SPEC_CELLS <- rep(BLOCKSIZE * (MULTLOC[MULTLOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    # ARR_CELLS ARE SPEFICIED IN ARRAYS.
    ARR_LOC    <- grep("^1$", ARR_MULT)
    ARR_CELL   <- rep(BLOCKSIZE * (ARR_LOC[ARR_LOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    VAL[SPEC_CELLS] <- rep(MULT[MULTLOC[MULTLOC > 3]], each = BLOCKSIZE)
    VAL[ARR_CELL] <- CELL_INDX %>% MFtools::parse_MF_CELL_INDX(LINE = linin)
    }else{
    VAL <- CELL_INDX %>% MFtools::parse_MF_CELL_INDX(LINE = linin)
    }

    BOT <- tibble::data_frame(
                      LAY = rep(1:NLAY, each = NCOL * NROW) %>% as.integer(),
                      ROW = rep(rep(1:NROW, each = NCOL), NLAY) %>% as.integer(),
                      COL = rep(rep(seq(1, NCOL, 1), NROW), NLAY) %>% as.integer(),
                      X   = rep(rep(X, NROW), NLAY) %>% as.numeric(),
                      Y   = rep(rep(Y, each = NCOL), NLAY) %>% as.numeric(),
                      BOT = VAL %>% as.numeric())
    rm(VAL)
    indx <- HDGLOC[length(HDGLOC)] +
            ifelse(UNI[length(UNI)] >= 1, 1, 0) *
            BLOCK_LENGTH[length(BLOCK_LENGTH)] + 1
#
#----------------------------------------------------------------
    PERLEN <- vector(mode = "numeric", length = NPER)
    NSTP <- vector(mode = "integer", length = NPER)
    TSMULT <- vector(mode = "numeric", length = NPER)
    SS <- vector(mode = "character", length = NPER)
    PERLEN <- linin[indx:(indx + NPER - 1)] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.numeric()
    NSTP   <- linin[indx:(indx + NPER - 1)] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.integer()
    TSMULT <- linin[indx:(indx + NPER - 1)] %>% MFtools::parse_MF_FW_ELMT(3) %>% as.numeric()
    SS     <- linin[indx:(indx + NPER - 1)] %>% MFtools::parse_MF_FW_ELMT(4) %>% as.character()
    DIS <- list(NLAY = NLAY,
                NCOL = NCOL,
                NROW = NROW,
                NPER = NPER,
                ITMUNI = ITMUNI,
                LENUNI = LENUNI,
                LAYCBD = LAYCBD,
                dX = dX,
                dY = dY,
                TOP = TOP,
                BOT = BOT,
                PERLEN = PERLEN,
                NSTP = NSTP,
                TSMULT = TSMULT,
                SS = SS)
    return(DIS)
    }


#Aula 08 - 19/09/2019
#Algoritmo para reconhecer o nariz de um cachorro
#
#
install.packages("jpeg")
library(jpeg)

dogs = readJPEG("doguinhos.jpg")
dim(dogs)
dev.new()
plot(1:2, type='n')

rasterImage(dogs, 1, 1, 2, 2)

DATA = data.frame(R = c(dogs[,,1]),G = c(dogs[,,2]), B = c(dogs[,,3]))

mod = kmeans(DATA, centers = 2)
cl = mod$cluster
for(i in 1:nrow(DATA)){
  if(cl[i] == 1){
    DATA[i,] = c(0,0,1)
  }
}

R = matrix(DATA[,1],325,480)
G = matrix(DATA[,2],325,480)
B = matrix(DATA[,3],325,480)

dogs2      = array(0,dim = c(325,480,3))
dogs2[,,1] = R
dogs2[,,2] = G
dogs2[,,3] = B
dev.new()
plot(1:2, type='n')

rasterImage(dogs2, 1, 1, 2, 2)

####### Nose

nose = readJPEG("nose.jpg")
DATA2 = data.frame(R = c(nose[,,1]),
                   G = c(nose[,,2]),
                   B = c(nose[,,3]))

summary(DATA2)
pairs(DATA2)
hist(DATA2[,1])
hist(DATA2[,2])
hist(DATA2[,3])

library(mixsmsn)
library(sn)
modsn = smsn.mmix(y = DATA2, g = 1, family = "Normal")

for(i in 1:nrow(DATA)){
  p = pmsn(DATA[1,],xi=modsn$mu[[1]],
       ,Omega =  modsn$Sigma[[1]]
       , alpha = c(modsn$shape[[1]]))
  if(p >=0.2 & p <=0.8){
    DATA[i,] = c(0,1,0)
  }
}
R = matrix(DATA[,1],325,480)
G = matrix(DATA[,2],325,480)
B = matrix(DATA[,3],325,480)

dogs2      = array(0,dim = c(325,480,3))
dogs2[,,1] = R
dogs2[,,2] = G
dogs2[,,3] = B
dev.new()
plot(1:2, type='n')

rasterImage(dogs2, 1, 1, 2, 2)


subroutine master(x,y,rw,npd,ntot,nadj,madj,eps,delsgs,ndel,delsum,
                  dirsgs,ndir,dirsum,collinchk,nerror)

# Master subroutine:
# One subroutine to rule them all,
# One subroutine to find them.
# One subroutine to bring them all in,
# And in the darkness bind them.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot)
dimension nadj(-3:ntot,0:madj)
dimension rw(4)
dimension delsgs(6,ndel), dirsgs(10,ndir)
dimension delsum(npd,4), dirsum(npd,3)
integer collinchk

# Define one.
one = 1.d0

# Initialize the adjacency list; counts to 0, other entries to -99.
do i = -3,ntot {
	nadj(i,0) = 0
	do j = 1,madj {
		nadj(i,j) = -99
	}
}

# Put the four ideal points into x and y and the adjacency list.
# The ideal points are given pseudo-coordinates
# (-1,-1), (1,-1), (1,1), and (-1,1).  They are numbered as
#    0       -1      -2         -3
# i.e. the numbers decrease anticlockwise from the
# `bottom left corner'.
x(-3) = -one
y(-3) =  one
x(-2) =  one
y(-2) =  one
x(-1) =  one
y(-1) = -one
x(0)  = -one
y(0)  = -one

do i = 1,4 {
        j = i-4
        k = j+1
        if(k>0) k = -3
	call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps)
        if(nerror>0) return
}

# Put in the first of the point set into the adjacency list.
do i = 1,4 {
        j = i-4
	call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps)
        if(nerror>0) return
}
ntri = 4

# Now add the rest of the point set
do j = 2,npd {
	call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror)
        if(collinchk==1) call collincheck(nadj,j,madj,x,y,ntot,eps)
        if(nerror>0) {
            return
        }
        ntri = ntri + 3
}

# Obtain the description of the triangulation.
call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror)
if(nerror>0) return

call delout(delsum,nadj,madj,x,y,ntot,npd,nerror)
if(nerror>0) return

call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror)
if(nerror>0) return
call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror)
return
end


# --------------------------------------------
# COMMANDS FOR FITTING CONSTANT MODEL FOR EX1
# SECTION 4.1.1
# --------------------------------------------

library(bivpois)       # load bivpois library
data(ex1.sim)          # load data of example 1
# -------------------------------------------------------------------------------

xtemp<-readline(prompt = "Press Enter to Continue")

# Simple Bivariate Poisson Model
ex1.simple<-simple.bp( ex1.sim$x, ex1.sim$y ) # fit simple model of section 4.1.1

names(ex1.simple)      # monitor output variables
ex1.simple$lambda      # view lambda1
ex1.simple$BIC         # view BIC
ex1.simple             # view all results of the model
xtemp<-readline(prompt = "Press Enter to Continue")
#
# plot of loglikelihood vs. iterations
win.graph()
plot( 1:ex1.simple$iterations, ex1.simple$loglikelihood, xlab='Iterations',ylab='Log-likelihood', type='l' )

# -------------------------------------
# COMMANDS FOR FITTING MODELS FOR EX1
# SECTION 4.1.2
# -------------------------------------
ex1.m2<-lm.bp(x~1 , y~1 , data=ex1.sim, zeroL3=TRUE)			# Model 2: DblPoisson(l1, l2)
ex1.m3<-lm.bp(x~1 , y~1 , data=ex1.sim)					# Model 3: BivPoisson(l1, l2, l3)
ex1.m4<-lm.bp(x~. , y~. , data=ex1.sim, zeroL3=TRUE)			# Model 4: DblPoisson (l1=Full, l2=Full)
ex1.m5<-lm.bp(x~. , y~. , data=ex1.sim)					# Model 5: BivPoisson(l1=full, l2=full, l3=constant)
ex1.m6<-lm.bp(x~z1 , y~z1+z5 , l1l2=~z3, data=ex1.sim, zeroL3=TRUE)	# Model 6: DblPois(l1,l2)
ex1.m7<-lm.bp(x~z1 , y~z1+z5 , l1l2=~z3, data=ex1.sim)			# Model 7: BivPois(l1,l2,l3=constant)
ex1.m8<-lm.bp(x~. , y~. , l3=~., data=ex1.sim)				# Model 8: BivPoisson(l1=full, l2=full, l3=full)
ex1.m9<-lm.bp(x~. , y~. , l3=~.-z5, data=ex1.sim)			# Model 9: BivPoisson(l1=full, l2=full, l3=z1+z2+z3+z4)
ex1.m10<-lm.bp(x~z1 , y~z1+z5 , l1l2=~z3, l3=~., data=ex1.sim)		# Model 10: BivPoisson(l1, l2, l3=full)
ex1.m11<-lm.bp(x~z1 , y~z1+z5 , l1l2=~z3, l3=~.-z5, data=ex1.sim)	# Model 11: BivPoisson(l1, l2, l3= z1+z2+z3+z4)
ex1.m11$coef  # monitor all beta parameters of model 11
#
ex1.m11$beta1 # monitor all beta parameters of lambda1 of model 11
ex1.m11$beta2 # monitor all beta parameters of lambda2 of model 11
ex1.m11$beta3 # monitor all beta parameters of lambda3 of model 11


pofi <- function(n) c('1','i','-1','-i')[n %% 4 + 1]


    holes_bruteforce <- function(candidatepoints, database) {
        ## calculate the minimum distance from the test point to the nearest point in the database.
        ## candidatepoints = dataframe of parameters
        ## database        = dataframe of database parameters (i.e., datapointnames removed)
        dfxs <- database   # dfxs is needed for mindistance function
        candidatepoints  <- candidatepoints
        nparam <- ncol(candidatepoints)
        ## calculate mininimum distance to new dfxs data set
        candidatepoints$mindist <- apply(candidatepoints, 1, mindistance)
        ## sort results from max to min distance
        holes <- candidatepoints[order(candidatepoints$mindist, decreasing=TRUE),]
        return(holes)
    }


library(tibble)
library(dplyr)
library(ggplot2)

# Load custom simulation functions
source(file.path("util", "simulate_expression.R"))

# Store seeds for each dataset
seeds <- c(1, 2, 3, 4)

# Set Variables
num_samples <- 12000

group_mean <- as.matrix(cbind(c(1, 5, 3), c(4, 0, 2)))
group_sd <- as.matrix(cbind(c(1, 1, 1), c(1, 1, 1)))

num_boolean_features <- 1

cell_mean <- as.matrix(cbind(c(1, 4), c(5, 2)))
cell_sd <- as.matrix(cbind(c(1, 1), c(1, 1)))

x_squared <- function(x) { x ** 2 + 1}
two_x_third <- function(x) {2 * x ** 3 + 1}
func_list <- list(x_squared, two_x_third)

random_noise <- c(0, 5, 20, 100)

# Simulate data and save to folder
output_folder <- file.path("..", "data", "simulation")
noise_idx <- 1
for (num_noise_features in random_noise) {
  sim_df <- getSimulatedExpression(n = num_samples,
                                   mean_df = group_mean,
                                   sd_df = group_sd,
                                   b = num_boolean_features,
                                   func_list = func_list,
                                   seed = seeds[noise_idx],
                                   cell_type_mean_df = cell_mean,
                                   cell_type_sd_df = cell_sd,
                                   r = num_noise_features,
                                   concat = TRUE)

  sim_data_file <- paste0("sim_data_", num_noise_features, "_noise.tsv")
  sim_data_file <- file.path(output_folder, sim_data_file)
  write.table(sim_df, sim_data_file, sep = "\t")

  noise_idx <- noise_idx + 1
}

# Example with 100 noise features
head(sim_df)

ggplot(sim_df, aes(x=group_1, y=group_2)) + geom_point(aes(color=groups), alpha=0.5) +
  theme_bw()

ggplot(sim_df, aes(x=continuous_domain_1, y=continuous_1)) +
  geom_point(aes(color=groups), alpha=0.5) + theme_bw()

ggplot(sim_df, aes(x=continuous_domain_2, y=continuous_2)) +
  geom_point(aes(color=groups), alpha=0.5) + theme_bw()

ggplot(sim_df, aes(x=group_1, y=presence_1)) + geom_point(aes(color=groups), alpha=0.5) +
  theme_bw()

ggplot(sim_df, aes(x=cell_type_1, y=cell_type_2)) +
  geom_point(aes(color=groups, size=cell_type_prop), alpha=0.5) +
  theme_bw()

ggplot(sim_df, aes(x=random_1, y=random_2)) + geom_point(aes(color=groups), alpha=0.5) +
  theme_bw()


library(tidyverse)
# 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, ~None,
       "Normal",       1,     1,      1,         1,      1,    1,         1,       1,       1,       1,        1,    1,   0.5,      0,       1,     1,    0.5,      1,
         "Fire",       1,   0.5,    0.5,         1,      2,    2,         1,       1,       1,       1,        1,    2,   0.5,      1,     0.5,     1,      2,      1,
        "Water",       1,     2,    0.5,         1,    0.5,    1,         1,       1,       2,       1,        1,    1,     2,      1,     0.5,     1,      1,      1,
     "Electric",       1,     1,      2,       0.5,    0.5,    1,         1,       1,       0,       2,        1,    1,     1,      1,     0.5,     1,      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,      1,
          "Ice",       1,   0.5,    0.5,         1,      2,  0.5,         1,       1,       2,       2,        1,    1,     1,      1,       2,     1,    0.5,      1,
     "Fighting",       2,     1,      1,         1,      1,    2,         1,     0.5,       1,     0.5,      0.5,  0.5,     2,      0,       1,     2,      2,      1,
       "Poison",       1,     1,      1,         1,      2,    1,         1,     0.5,     0.5,       1,        1,    1,   0.5,    0.5,       1,     1,      0,      1,
       "Ground",       1,     2,      1,         2,    0.5,    1,         1,       2,       1,       0,        1,  0.5,     2,      1,       1,     1,      2,      1,
       "Flying",       1,     1,      1,       0.5,      2,    1,         2,       1,       1,       1,        1,    2,   0.5,      1,       1,     1,    0.5,      1,
      "Psychic",       1,     1,      1,         1,      1,    1,         2,       2,       1,       1,      0.5,    1,     1,      1,       1,     0,    0.5,      1,
          "Bug",       1,   0.5,      1,         1,      2,    1,       0.5,     0.5,       1,     0.5,        2,    1,     1,    0.5,       1,     2,    0.5,      1,
         "Rock",       1,     2,      1,         1,      1,    2,       0.5,       1,     0.5,       2,        1,    2,     1,      1,       1,     1,    0.5,      1,
        "Ghost",       0,     1,      1,         1,      1,    1,         1,       1,       1,       1,        2,    1,     1,      2,       1,   0.5,    0.5,      1,
       "Dragon",       1,     1,      1,         1,      1,    1,         1,       1,       1,       1,        1,    1,     1,      1,       2,     1,    0.5,      1,
         "Dark",       1,     1,      1,         1,      1,    1,       0.5,       1,       1,       1,        2,    1,     1,      2,       1,   0.5,    0.5,      1,
        "Steel",       1,   0.5,    0.5,       0.5,      1,    2,         1,       1,       1,       1,        1,    1,     2,      1,       1,     1,    0.5,      1,
      	 "None",       1,     1,      1,         1,      1,    1,         1,       1,	      1,       1,	       1,    1,     1,      1,       1,     1,      1,      1
)

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

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

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

Immunities <- tidied_comparison %>%
  group_by(Defending) %>%
  summarize(Immunities = sum(ifelse(outcome == 0, 1, 0))) %>%
  arrange(desc(Immunities)) %>%
  head(6) %>%
  knitr::kable()

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

m[m == 2] <- -1
m[m >= 0 & m < 1 ] <- 3
m[m == 1 ] <- 0
m[m == 3 ] <- 1

super_effective_m <- t(m)

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

all_combinations <- combn(18, 2)

super_effective_results <- apply(all_combinations, 2, super_effective_nb)

dim(all_combinations)

sort(super_effective_results,decreasing = TRUE)

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

head(order(super_effective_results,decreasing = TRUE), n=53)

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

Weaknesses
Resistances
Immunities

strongest_teams <- t(matrix(rownames(super_effective_m)[best_combos], nrow = 2))

strongest_teams

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

type


# Compare within cluster correlation

rm(list = ls())

source("../project_support.r")

# Load data
correlations <- readRDS("./input/b_f_con_50_50_cor.rds")
clusters <- read_csv("./input/b_f_con_50_50.csv")

# Find the overall correlation for each comparison method
overall_correlations <- kendall_output(correlations)
# Save results
write_csv(overall_correlations, "../results/overall_correlations.csv")

# Find the correlation within clusters by branch length vs. shortest tagging tree
# This comparison method was chosen as it has the strongest correlation
cluster_correlations <- cluster_cor(correlations, clusters, "branch_length_short_tag_tree")

# Perform Kruskal-Wallis rank sum test
kruskal.test(cor ~ Cluster, data = cluster_correlations)

# Visualize cluster correlations and save figure
box_plot <- ggplot(cluster_correlations, aes(x=Cluster, y=cor)) +
  geom_boxplot(width=0.5) +
  theme_bw() +
  theme(
    axis.text = element_text(colour = "black"),
    axis.line.x = element_line(color="black", size = 0.5),
    axis.line.y = element_line(color="black", size = 0.5),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    panel.border = element_blank(),
    panel.background = element_blank(),
    legend.position="none") +
  ylab("Correlation")
cairo_pdf("../figures/within_cluster_correlation_box.pdf", height = 3.5, width = 3.5)
plot(box_plot)
dev.off()


#!/usr/bin/env Rscript
# Author: Cody Lewis
# Date: 2019-02-13
# Description:
# Show the relationship between capability, QR, and Reputation

# The max values of service and capability respectively
S_MAX = 101
C_MAX = 101

# Get a scalar distance between 2 values
find_dist <- function(target, current) {
    return(abs(target - current))
}

# Find the distance between a report's context and a target context
report_dist <- function(c_j, s_j, c_target, s_target, eta, note,
			dS_max_sq, dC_max_sq, S_max, C_max) {
    shared_term = sqrt(
        (dS_max_sq + dC_max_sq) *
        (
         (find_dist(s_target, s_j)**2 /
          dS_max_sq) +
             (find_dist(c_target, c_j)**2 /
              dC_max_sq)
        )
    )
    unique_term = `if`(
        note >= 0,
        sqrt(
            (dS_max_sq + dC_max_sq) *
            (
             ((S_max - s_j) /
              (S_max - (s_target - eta)))**2 +
             (c_j /
              (c_target + eta))**2
            )
        ),
        sqrt(
            (dS_max_sq + dC_max_sq) *
            (
             ((C_max - c_j) /
              (C_max - (c_target - eta)))**2 +
             (s_j / (s_target + eta))**2
            )
        )
    )
    return(min(shared_term, unique_term))
}

find_s <- function(note_j) {
    return((1 / 2) * (note_j**2 - note_j))
}

# Find the weight of a report
find_weight <- function(lambda, theta, note, report_time, distance, time) {
    theta_exp = ((find_s(note) + 1) * (time - report_time))
    return((lambda ** distance) * (theta ** theta_exp))
}

# Give a value stating the significance of older occurances
find_c_i <- function(theta, t_1, t_i) {
    return(theta ** (t_1 - t_i))
}

# Find a quality of reccomendation for a given report weight
find_qr <- function(weight, client_note, theta, time, node_note,
                    client_qr, node_qrs, node_qr_times) {
    QR = 1
    C_F = weight * client_qr
    QRXF = C_F * (-abs(node_note - client_note))
    numerator=denominator=0
    numerator = sum(sapply(1:length(node_qrs),
        function(i) {
            c_i = find_c_i(theta, node_qr_times[[1]],
                           node_qr_times[[i]])
            c_i * node_qrs[[i]] + QRXF
        }
    ))
    denominator = sum(sapply(1:length(node_qrs),
        function(i) {
            c_i = find_c_i(theta, node_qr_times[[1]],
                           node_qr_times[[i]])
            c_i + abs(C_F)
        }
    ))
    QR = `if`(
        denominator == 0,
        0,
        numerator / denominator
    )
    if(QR < -1) {
       QR = -1
    } else if(QR > 1) {
        QR = 1
    }
    return(QR)
}

# Calculate the reputation of a server
calculate_reputation <- function(theta, client_notes, client_qrs,
                                 transactions, time, node_qr_times) {
    sum = 0
    for(i in 1:transactions) {
        c_i = find_c_i(theta, time, node_qr_times[[i]])
        sum = sum + c_i * client_notes[[i]] * client_qrs[[i]]
    }
    return(sum)
}

# Give a vector of notes produce during operation of the system
take_notes <- function(c, c_target, s, s_target, client_qrs) {
    correct_notes = rep(
        `if`(
            c < c_target,
            `if`(s < s_target, -1, 0),
            `if`(s < s_target, 0, 1),
        ),
        each=length(client_qrs)
    )
    ifelse(
        runif(length(client_qrs)) < client_qrs,
        correct_notes,
        setdiff(c(-1, 0, 1), correct_notes)[[floor(runif(1, min=1, max=3))]]
    )
}

plot_reputation <- function(reputations) {
    plot(
        reputations,
        xlab = "Number of Transactions",
        ylab = "Reputation Value",
        main = "Reputation of the Node in a Trust Model Network",
        type = "l",
        col = "blue"
    )
}

plot_cap_qr <- function(final_qrs) {
    png("graphs/cap_qr.png")
    plot(
        x = 1:100,
        y = final_qrs,
        xlab = "Capability Values",
        ylab = "Final QRs",
        main = "Capability vs. QR when Good Mouthing a Good Service",
        col = "blue"
    )
    dev.off()
}


# This code estimates seroprevalence by narrowly
# define age and sex groups for IR/IFR estimation
# for COVID-19 pandemic in Saint Petersburg, Russia
# paper
library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(stats)
library(w)
library(GJRM)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load and prepare the serosurvey data for model fit
source("code/analysis/wave3/create_serosurvey_data_for_model_fit.r")

# Update the agegroups
serosurvey_data[, agegroup := NULL]
serosurvey_data[, agegroup := NA_character_]
serosurvey_data[age <= 29, agegroup := "18-29"]
serosurvey_data[age >= 30 & age < 40, agegroup := "30-39"]
serosurvey_data[age >= 40 & age < 50, agegroup := "40-49"]
serosurvey_data[age >= 50 & age < 60, agegroup := "50-59"]
serosurvey_data[age >= 60 & age < 70, agegroup := "60-69"]
serosurvey_data[age >= 70, agegroup := "70+"]
serosurvey_data[, agegroup := as.factor(agegroup)]

############################
# Parametric sample selection bivariate probit fit

# Define regressors list
basic_regressors <- "agegroup*male + highereduc + lives_alone + was_sick + selftested_covid + district"

# Fit the models with given regressors
model <- estimate_bivariate_selection(data = serosurvey_data, subset_condition = NULL, selection_type = "2step", agreementvar = "agreed", clinicvisitvar = "agreed_and_tested", outcomevar = "IgA_or_G_or_M_testC", regressors = basic_regressors, semiparametric_age = F, exclusion_restriction_clinicvisit = NULL, error_distribution = "N", surveyweightsvar = "raking_weight")

############################
# Prevalence estimation

# Set test characteristics from own validation
## Genetico CoronaPass
sensitivity_iga_g_m_genetico <- 0.920
specificity_iga_g_m_genetico <- 1

# Initiate an object to store the results
prevalence_by_agegroup_sex <- CJ(agegroup = unique(serosurvey_data$agegroup), male = unique(serosurvey_data$male), prevalence_type = c("naive", "univariate"))

for(i in 1:nrow(prevalence_by_agegroup_sex) ) {

	agegroup_row <- prevalence_by_agegroup_sex$agegroup[i]
	male_row <- prevalence_by_agegroup_sex$male[i]
	prevalence_type_row <- prevalence_by_agegroup_sex$prevalence_type[i]

	# True/False indicators for variable levels
	## Outcome equation
	var_indicators_outcome <- model$fit$gam2$model[["agegroup"]] == agegroup_row & model$fit$gam2$model[["male"]] == male_row
	## Selection equation
	var_indicators_selection <- model$fit$gam1$model[["agegroup"]] == agegroup_row & model$fit$gam1$model[["male"]] == male_row

	# Count the number of entries
	n_var_indicators_outcome <- sum(var_indicators_outcome)
	n_var_indicators_selection <- sum(var_indicators_selection)

	# Blank survey weights
	group_survey_weights_outcome <- rep(1, sum(var_indicators_outcome))
	group_survey_weights_selection <- rep(1, sum(var_indicators_selection))

	if( prevalence_type_row == "naive" ) {

		var_prev <- adjust_prev_test_chars(prev_modified(model$fit, ind = var_indicators_outcome, type = prevalence_type_row, delta = T, sw = group_survey_weights_outcome), sensitivity = sensitivity_iga_g_m_genetico, specificity = specificity_iga_g_m_genetico)

	}

	if( prevalence_type_row == "univariate" ) {

		var_prev <- adjust_prev_test_chars(prev_modified(model$fit, ind = var_indicators_selection, type = prevalence_type_row, delta = T, sw = group_survey_weights_selection), sensitivity = sensitivity_iga_g_m_genetico, specificity = specificity_iga_g_m_genetico)

	}

	set(prevalence_by_agegroup_sex, i = i, j = "lowerbound", value = var_prev$res[1])
 	set(prevalence_by_agegroup_sex, i = i, j = "pointest", value = var_prev$res[2])
 	set(prevalence_by_agegroup_sex, i = i, j = "upperbound", value = var_prev$res[3])
 	set(prevalence_by_agegroup_sex, i = i, j = "n_selection", value = n_var_indicators_selection)
 	set(prevalence_by_agegroup_sex, i = i, j = "n_outcome", value = n_var_indicators_outcome)

}
# Round the results
prevalence_by_agegroup_sex[, c("lowerbound", "pointest", "upperbound") := lapply(.SD, function(x) { round(x*100, 1) }), .SDcols = c("lowerbound", "pointest", "upperbound") ]

# Ordering
setorderv(prevalence_by_agegroup_sex, c("prevalence_type", "agegroup", "male"))

# Save the object with computed prevalences for future use
save(prevalence_by_agegroup_sex, file = "estimates/pandemic_course_paper/prevalence_by_agegroup_sex.rdata", compress = "gzip")


library(gmp)
a <- as.bigz("18446744073709551616")
mul.bigz(a,a)


library('ggplot2')

ggplot(data=mtcars, aes(x=disp, y=mpg)) + geom_point(aes(size=hp, color=wt))


library(stringr)
library(lattice)
library(gtools)
library(SNPassoc)

load(file = "Allpop_invstatus.Rdata")
superpop <- unique(invstatus_allpop$superpop)

mylistinv <- c("inv8_001", "inv17_007", "inv11_001")

mylistinv <- c("inv1_004", "inv1_008", "inv2_002", "inv6_006", "inv7_003", "inv7_014", "inv8_001",
               "inv11_001", "inv11_004", "inv12_004", "inv12_006", "inv14_005", "inv16_017", "inv17_007",
               "inv21_005")

myeurlist <- colnames(invstatus_eur[,-(1:2)])

AFR_freq <- lapply(mylistinv, function(i) {
  inversion <- invstatus_allpop[,c("superpop", "pop", i)]
  inversion$N <- str_count(inversion[[i]], "N")
  inversion$I <- str_count(inversion[[i]], "I")
  Ntot <- sum(inversion[inversion$superpop=="AFR",]$N, na.rm=TRUE)
  Itot <- sum(inversion[inversion$superpop=="AFR",]$I, na.rm=TRUE)
  invfreq <- 100*(Itot/(Ntot+Itot))
  invfreq
})
AFR_freq <- as.numeric(AFR_freq)
AFR_freq <- as.numeric(lapply(AFR_freq, function(x) {format(round(x, 2))}))

AMR_freq <- lapply(mylistinv, function(i) {
  inversion <- invstatus_allpop[,c("superpop", "pop", i)]
  inversion$N <- str_count(inversion[[i]], "N")
  inversion$I <- str_count(inversion[[i]], "I")
  Ntot <- sum(inversion[inversion$superpop=="AMR",]$N, na.rm=TRUE)
  Itot <- sum(inversion[inversion$superpop=="AMR",]$I, na.rm=TRUE)
  invfreq <- 100*(Itot/(Ntot+Itot))
  invfreq
})
AMR_freq <- as.numeric(AMR_freq)
AMR_freq <- as.numeric(lapply(AMR_freq, function(x) {format(round(x, 2))}))

EAS_freq <- lapply(mylistinv, function(i) {
  inversion <- invstatus_allpop[,c("superpop", "pop", i)]
  inversion$N <- str_count(inversion[[i]], "N")
  inversion$I <- str_count(inversion[[i]], "I")
  Ntot <- sum(inversion[inversion$superpop=="EAS",]$N, na.rm=TRUE)
  Itot <- sum(inversion[inversion$superpop=="EAS",]$I, na.rm=TRUE)
  invfreq <- 100*(Itot/(Ntot+Itot))
  invfreq
})
EAS_freq <- as.numeric(EAS_freq)
EAS_freq <- as.numeric(lapply(EAS_freq, function(x) {format(round(x, 2))}))

EUR_freq <- lapply(myeurlist, function(i) {
  inversion <- invstatus_eur[,c("superpop", "pop", i)]
  inversion$N <- str_count(inversion[[i]], "N")
  inversion$I <- str_count(inversion[[i]], "I")
  Ntot <- sum(inversion[inversion$superpop=="EUR",]$N, na.rm=TRUE)
  Itot <- sum(inversion[inversion$superpop=="EUR",]$I, na.rm=TRUE)
  invfreq <- 100*(Itot/(Ntot+Itot))
  invfreq
})
EUR_freq <- as.numeric(EUR_freq)
EUR_freq <- as.numeric(lapply(EUR_freq, function(x) {format(round(x, 2))}))

SAS_freq <- lapply(mylistinv, function(i) {
  inversion <- invstatus_allpop[,c("superpop", "pop", i)]
  inversion$N <- str_count(inversion[[i]], "N")
  inversion$I <- str_count(inversion[[i]], "I")
  Ntot <- sum(inversion[inversion$superpop=="SAS",]$N, na.rm=TRUE)
  Itot <- sum(inversion[inversion$superpop=="SAS",]$I, na.rm=TRUE)
  invfreq <- 100*(Itot/(Ntot+Itot))
  invfreq
})
SAS_freq <- as.numeric(SAS_freq)
SAS_freq <- as.numeric(lapply(SAS_freq, function(x) {format(round(x, 2))}))

AFR_freq
AMR_freq
EAS_freq
EUR_freq
SAS_freq

allpop3 <- data.frame(row.names = mylistinv, AFR_freq, AMR_freq, EAS_freq, SAS_freq)

eurpop3 <- data.frame(row.names = myeurlist, EUR_freq)

allpop3$namesinversions <- rownames(allpop3)

eurpop3$namesinversions <- rownames(eurpop3)

mytable3 <- merge(allpop3, eurpop3, all.y = TRUE, by = "namesinversions")

mytable3 <- mytable3[c(1,2,10,11,13:20,3:9,12,21), c(1,2,3,4,6,5)]

rownames(mytable3) <- mytable3$namesinversions

mytable3 <- mytable3[,-1]

pdf("invfreq_allpop.pdf")
grid.table(mytable)
dev.off()
#

#################################
# Same but with SNPassoc. Problem: I freq not always in the same place in the table
#################################
a <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="EAS",]$inv17_007))

invfreq$allele.freq[2,2]

superpop <- unique(invstatus_allpop$superpop)

mylistinv <- c("inv8_001", "inv17_007", "inv11_001")

AFRinvfreq <- lapply(mylistinv, function(x){
  freq <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="AFR",][[x]]))
  freq$allele.freq[2,2]
})
AFRinvfreq <- as.numeric(AFRinvfreq)

AMRinvfreq <- lapply(mylistinv, function(x){
  freq <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="AMR",][[x]]))
  freq$allele.freq[2,2]
})
AMRinvfreq <- as.numeric(AMRinvfreq)

EASinvfreq <- lapply(mylistinv, function(x){
  freq <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="EAS",][[x]]))
  freq$allele.freq[2,2]
})
EASinvfreq <- as.numeric(EASinvfreq)

EURinvfreq <- lapply(mylistinv, function(x){
  freq <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="EUR",][[x]]))
  freq$allele.freq[2,2]
})
EURinvfreq <- as.numeric(EURinvfreq)

SASinvfreq <- lapply(mylistinv, function(x){
  freq <- summary(snp(invstatus_allpop[invstatus_allpop$superpop=="SAS",][[x]]))
  freq$allele.freq[2,2]
})
SASinvfreq <- as.numeric(SASinvfreq)

df <- data.frame(row.names = mylistinv, AFRinvfreq, AMRinvfreq, EASinvfreq, EURinvfreq, SASinvfreq)


## Mapping made easy
## basic philosophy: KISS
## use simple constructs for mapping as much as possible
## Proposed solution: use the "maps" library
## Remember: this is to do quick and dirty plots/visualization not to do exact analyses
##   for the latter: use "sp", "rproj", "rgdal", "lattice", etc
# Created Wednesday 11 February 2015

library(maps)
library(mapdata)  # high resolution world coastlines/polygons
require(lubridate)
require(lattice)
bioLibrary("bio.groundfish")
bioLibrary("bio.utilities")
bioLibrary("bio.bathymetry")

m = maps::map()   # low resolution map of the world .. default is rectangular coords
str(m)

# dealing with projections in a simple manner: use "mapproj"
graphics.off()
require(mapproj)
maps::map(projection="polyconic")

graphics.off()
maps::map(projection="albers", par=c(30,40) )

graphics.off()
maps::map(projection="mollweide" )

graphics.off()
maps::map("worldHires", projection="gnomonic", orient=c(0,-100,0)) # example of orient

graphics.off()
m = maps::map("worldHires", plot=FALSE)
maps::map("worldHires", projection='orth',orient=c(41,-74,0))
str(m)
maps::map.grid(m, col="lightgray", label=FALSE, lty="dotted")

# to add layers to a projected map, we need to deal with projections
points(mapproject(list(y=42.5,x=-68)),col="red", pch="x", cex=3 )

# if more complex projection-based computations are required then
# use library(sp) and the function "CRS"
# as well as rgdal::project
# .. see bio.spatialmethods::lonlat2planar

graphics.off()
maps::map( "worldHires", projection="ortho", xlim=c(-165,-53), ylim=c(-0, 90 ),  )      # national boundaries
maps::map( "worldHires", projection="azequalarea", xlim=c(-165,-53), ylim=c(-0, 90 ),  )      # national boundaries
maps::map( "worldHires", projection="eisenlohr", xlim=c(-165,-53), ylim=c(-0, 90 ),  )      # national boundaries

# Canada only
graphics.off()
maps::map( "worldHires", regions="Canada", xlim=c(-141,-53), ylim=c(40,85), col="gray90", fill=TRUE)

# oops forgot US
maps::map( "worldHires", regions=c("USA"), resolution=0, add=TRUE )

# or both together
graphics.off()
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-141,-53), ylim=c(40,85), col="gray90", fill=TRUE)

# aside .. how to extract polygons
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-141,-53), ylim=c(40,85))
mCan = maps::map( "worldHires", regions="Canada", plot=FALSE, resolution=0)
lines( mCan,col="green" )

# zoom in and use all data
graphics.off()
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=FALSE, resolution=0 )

# add some more things
maps::map.scale()
title('Nova Scotia, High resolution')
points( -60, 44, col="red", pch=21, cex=10 )
text( -60, 44, "Sable Island" )
box()

# bring in real data
gs = groundfish.db( "gsinf" )
gs = gs[ which( year( gs$timestamp) == 2010 ), ]

# locations of sets
points( lat~lon, data=gs, col="green", pch=19, cex=0.2 )

# look at salinity in space
graphics.off()
z = gs$bottom_salinity
ncats = 100 ## number of colours
drange = range(z, na.rm=TRUE)

cols = color.code( "seis", seq( drange[1], drange[2], length.out=ncats) ) [ cut( z, ncats, label = FALSE) ]  ## see color.code.r to contruct your own
zi <- rev(order( z ))
points( lat~lon, data=gs, col=cols[zi], pch=21, cex=1 )

# or to fill in the points
points( lat~lon, data=gs, bg=cols[zi], col=cols[zi], pch=21, cex=1.5 )

# zoom in and use all data .. look at temperature as bubble plots
graphics.off()
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=FALSE, resolution=0 )
maps::map.scale()
title('Nova Scotia, High resolution')

z = gs$bottom_temperature
ncats = 100 ## number of colours
drange = range(z, na.rm=TRUE)

sz = seq( drange[1], drange[2], length.out=ncats)
zcat = sz[ cut( z, ncats, label = FALSE) ]
zi <- rev(order( z ))
points( lat~lon, data=gs, col="green", pch=21, cex=zcat[zi]/10 )

# or both colour and size of circles
cols = color.code( "seis", seq( drange[1], drange[2], length.out=ncats) ) [ cut( z, ncats, label = FALSE) ]
points( lat~lon, data=gs,  bg=cols[zi], col=cols[zi], pch=21, cex=zcat[zi]/10 )

# or to use transparencies for temperture in this case
library(scales)  #for transparency
graphics.off()
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=FALSE, resolution=0 )
maps::map.scale()
title('Nova Scotia, High resolution')

z = gs$bottom_temperature
ncats = 100 ## number of colours
drange = range(z, na.rm=TRUE)

zcat = seq( drange[1], drange[2], length.out=ncats)[ cut( z, ncats, label = FALSE) ]
zalpha = seq( 0.1, 0.9, length.out=ncats)[ cut( z, ncats, label = FALSE) ]
zi <- rev(order( z ))
points( lat~lon, data=gs, col="green", pchR=21, cex=zcat[zi]/10 )

# or both size of circles and transparancy
cols = color.code( "seis", seq( drange[1], drange[2], length.out=ncats) ) [ cut( z, ncats, label = FALSE) ]
points( lat~lon, data=gs,  bg=alpha("darkgreen", zalpha[zi] ), col=alpha("darkgreen", zalpha[zi] ), pch=21, cex=zcat[zi]/10 )

# or both size of circles and transparency and colour! :)
cols = color.code( "seis", seq( drange[1], drange[2], length.out=ncats) ) [ cut( z, ncats, label = FALSE) ]
points( lat~lon, data=gs,  bg=alpha(cols[zi], zalpha[zi] ), col=alpha(cols[zi], zalpha[zi] ), pch=21, cex=zcat[zi]/10 )

## to get some isobaths
graphics.off()
i1000 = isobath.db( p=p, DS="isobath", depths=c(1000 )
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=FALSE, resolution=0 )
lines(i1000)

## to bring in some ARCinfo shape files:
library(maptools)  #for shapefiles .. 100 m isobath
fn = find.bio.gis( "dm100_region" )
dm100 <- readShapePoly( fn)   #
maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=FALSE, resolution=0 )
plot( dm100, add=TRUE )  # there seem to be some problems with the polygon data ... :)

### an example using lattice plots and passing the map coastline to it
# non-lattice plots do not work well inside of lattice .. but you can pass data
datatoplot = groundfish.db( DS="gsinf" )
datatoplot$year = lubridate::year( datatoplot$timestamp )
datatoplot = datatoplot[ which(datatoplot$year %in% 2000:2014 ), ]

# trellis.par.set(col.whitebg())
xyplot( lat ~ lon| factor(year), data=datatoplot,
  as.table=TRUE, xlab="Longitude", ylab="Latitude", main="Example",
  panel = function(x, y, subscripts, ...) {
    panel.xyplot( x, y, pch=21, cex=0.4, col="orange" , ...)
  }
)

print(pl)

require(maps)
require(mapdata)
coast =  maps::map( "worldHires", regions=c("Canada", "USA"), xlim=c(-72, -56 ), ylim=c(42,49), fill=TRUE, resolution=0, plot=FALSE)

trellis.par.set(col.whitebg())
xyplot( lat ~ lon| factor(year), data=datatoplot, coast=coast,
  as.table=TRUE, xlab="Longitude", ylab="Latitude", main="Example",
  panel = function(x, y, subscripts, ...) {
    panel.lines( coast$x, coast$y, col = "grey", lwd=0.7 )
    panel.xyplot( x, y, pch=21, cex=0.4, col="orange" , ...)
  }
)

ncats = 100
drange = range( z, na.rm=TRUE)
cols = color.code( "seis", seq( drange[1], drange[2], length.out=ncats) ) [ cut( z, ncats, label = FALSE) ]

trellis.par.set(col.whitebg())
xyplot( lat ~ lon| factor(year), data=datatoplot, coast=coast, cols=cols,
  as.table=TRUE, xlab="Longitude", ylab="Latitude", main="Example",
  panel = function(x, y, subscripts, cols=cols, colorkey=colorkey, ...) {
    panel.lines( coast$x, coast$y, col = "grey", lwd=0.7 )
    panel.xyplot( x, y, pch=21, cex=0.4, col=cols , ...)
  }
)

Cairo( file="zooplankton_data_yearly.pdf", type="pdf", bg="white",  units="in", width=6, height=8 )
  print(pl)
dev.off()


#' Use EpiEstim to estimate the Efective reproductive Number by week
#'
#' @param df data.frame with the incidence data to convert to an incidence object
#' @param region name of the region to plot
#'
#' @return a list with the incidence object and the fitted Re
#' @export
#'
#' @examples
estima_Re_from_df <- function(df,region){
  if(!inherits(df, "data.frame")) stop("Parameter df must be a data.frame")
  require(EpiEstim)
  require(lubridate)
  if(any(names(df)=="nue_casosconf_diff")) {

    cor_incidence <- df  %>% dplyr::select(nue_casosconf_diff,fecha) %>% uncount(nue_casosconf_diff)
    if(class(cor_incidence$fecha)!="Date") {
      cor_incidence_obj <- incidence::incidence(dmy(cor_incidence$fecha))
    } else {
      cor_incidence_obj <- incidence::incidence(cor_incidence$fecha)
    }

  } else if(any(names(df)=="localesdia")) {

    cor_incidence_obj <- df %>% dplyr::select(localesdia,importadosdia,fecha) %>% rename(local=localesdia,imported=importadosdia,dates=fecha)

  }

  obj_res_parametric_si <- estimate_R(cor_incidence_obj,
                                     method = "uncertain_si",
                                     config = make_config(list(mean_si = 7.5, std_mean_si = 2,
                                                               min_mean_si = 1, max_mean_si = 8.4,
                                                               std_si = 3.4, std_std_si = 1,
                                                               min_std_si = 0.5, max_std_si = 4, n1 = 1000, n2 = 1000)))

  cor_quarantine <- ymd("2020-03-20")
  cor_incidence_real_peak <- ifelse(inherits(cor_incidence_obj,"incidence"), incidence::find_peak(cor_incidence_obj),cor_quarantine)

  print(
    plot(obj_res_parametric_si, "incid" ) + labs(title = paste(region,"Casos por dia Importados y Locales"),
                                    subtitle = " COVID-19, Argentina, 2020 by @larysar") + theme_bw() +
                                    geom_vline(xintercept = cor_quarantine, col = "red", lty = 2)  +
                                    geom_vline(xintercept = cor_incidence_real_peak, col = "brown", lty = 2)
  )

  # print(plot(obj_res_parametric_si, "SI")+ theme_bw())

  print(
    plot(obj_res_parametric_si, "R")+ theme_bw() + labs(title = paste(region,"Nro Reproductivo Efectivo Basado en 7 días"),
                                                       subtitle = "COVID-19, Argentina, 2020 by @larysar") + theme_bw() +
                                      geom_vline(xintercept = cor_quarantine, col = "red", lty = 2) +
                                      geom_vline(xintercept = cor_incidence_real_peak, col = "brown", lty = 2)
    )

  return(list(cor_incidence_obj,obj_res_parametric_si))
  }


# Team Rython, Dainius Masiliunas and Tim Weerman
# Date: 11 January, 2016
# Apache License 2.0

# Needed packages
library(raster)

rm(list=ls())

# Source
source("src/RMSE.r")
source("src/LinearModel.r")

# Download/load information
GetFromWURgit = function(filename)
{
    download.file(paste("https://github.com/GeoScripting-WUR/AdvancedRasterAnalysis/raw/gh-pages/data/", filename, sep=""),
        paste("data/", filename, sep=""), "wget")
    return(paste("data/", filename, sep=""))
}
load(GetFromWURgit("GewataB1.rda"))
load(GetFromWURgit("GewataB2.rda"))
load(GetFromWURgit("GewataB3.rda"))
load(GetFromWURgit("GewataB4.rda"))
load(GetFromWURgit("GewataB5.rda"))
load(GetFromWURgit("GewataB7.rda"))
load(GetFromWURgit("vcfGewata.rda"))
load(GetFromWURgit("trainingPoly.rda"))

DataBrick = brick(GewataB1, GewataB2, GewataB3, GewataB4, GewataB5, GewataB7, vcfGewata)
names(DataBrick) = c("Blue", "Green", "Red", "NIR", "SWIR", "Emission", "VCF")
# Sanitise data
DataBrick[["VCF"]][DataBrick[["VCF"]] > 100] = NA
DataValues = as.data.frame(getValues(DataBrick))

# Create a training raster for RMSE
trainingRaster = rasterize(trainingPoly, DataBrick[["VCF"]], field='Class', filename="data/trainingRaster.grd", overwrite=TRUE)

# Plot relationships
pairs(DataBrick)
## We can conclude that they are all negatively correlated with VCF, except for NIR.
## The bands are also highly correlated with each other.

LM = lmValidation(VCF ~ Blue + Green + Red + NIR + SWIR + Emission, data=DataValues, printstep = TRUE)
# Emission can be dropped
LM = lmValidation(VCF ~ Blue + Green + Red + NIR + SWIR, data=DataValues, printstep = TRUE)
# Nothing further can be dropped, the most significant bands are NIR and green
## NB: a linear model isn't very appropriate, because normality and independence assumptions are violated!

BrickSubset = dropLayer(DataBrick, "Emission")
# Plot a histogram of predicted values
Prediction = predictValidation(BrickSubset, model=LM, na.rm=TRUE, plothist=TRUE)
# Out of reasonable range, apply a range constraint and compare
Prediction = predictValidation(BrickSubset, model=LM, na.rm=TRUE, overwrite=TRUE, filename="data/PredictionRaster.grd",
    truthlayer="VCF", range=c(0, +Inf), plotcomparison=TRUE)
names(Prediction) = "Predicted.LM"
# Compute the RMSE
RMSE(getValues(DataBrick[["VCF"]]), getValues(Prediction))
# RMSE per zone
zonestats = StratifiedRMSE(DataBrick[["VCF"]], Prediction, trainingRaster, zonenames=levels(trainingPoly@data$Class))
zonestats
# As a bonus, plot the difference raster
plot(raster("data/Predicted.LM.grd"))

## If we use only independent (not highly correlated) variables for the model:
ReducedBrick = dropLayer(DataBrick, "Emission")
ReducedBrick = dropLayer(ReducedBrick, "Green")
ReducedBrick = dropLayer(ReducedBrick, "Red")
ReducedBrick = dropLayer(ReducedBrick, "SWIR")

pairs(ReducedBrick)
ReducedLM = lmValidation(VCF ~ Blue + NIR, data=DataValues, printstep=TRUE)
RedPrediction = predictValidation(ReducedBrick, model=ReducedLM, na.rm=TRUE,
    filename="data/ReducedPredictionRaster.grd", overwrite=TRUE, range=c(0, +Inf),
    truthlayer="VCF", plothist=TRUE, plotcomparison=TRUE)
names(RedPrediction) = "Predicted.LM.Blue.NIR"
RMSE(getValues(ReducedBrick[["VCF"]]), getValues(RedPrediction))
zonestatsR = StratifiedRMSE(DataBrick[["VCF"]], RedPrediction, trainingRaster,
    zonenames=levels(trainingPoly@data$Class))
zonestatsR
plot(raster("data/Predicted.LM.Blue.NIR.grd"))


#Plotting multi-nomial-dirichlet fits to the training data set - are our models any good "in-sample"?
#clear environment, source paths, pacakges and functions.
rm(list=ls())
source('paths.r')
library(runjags)
source('NEFI_functions/crib_fun.r')

#load data.
fit <- readRDS(ted_ITS.prior_dmulti.ddirch_fg_JAGSfit)
fit <- fit$all.preds

#CHECK JAGS diagnostic plots. Did chains converge?
#plot(fit$jags_model)
#check prsf scores. Pathogens could run a little longer, probably because low abundance.
fit$species_parameter_output

#check plots.
par(mfrow = c(2,2))
for(i in 2:ncol(fit$predicted)){
  plot(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i], pch = 16)
  abline(0,1,lwd = 2)
  abline(lm(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i]), lty = 2, col = 'purple')
  mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
  rsq <-round(summary(mod)$pseudo.r.squared, 2)
  mtext(colnames(fit$predicted)[i], side = 3)
  mtext(paste0('R2=',rsq), side = 3, line = -1.5, adj = 0.05)

}

#Check cosmo genera.
fit <- readRDS(ted_ITS.prior_dmulti.ddirch_cosmo_JAGSfit)
fit <- fit$all.preds

#check convergence plots and prsf scores. Did not all converge.
fit$species_parameter_output
#plot(fit$jags_model)

#check the plots.
par(mfrow = c(3,3))
for(i in 1:ncol(fit$predicted)){
  plot(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i], pch = 16)
  abline(0,1,lwd = 2)
  abline(lm(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i]), lty = 2, col = 'purple')
  mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
  rsq <-round(summary(mod)$pseudo.r.squared, 2)
  mtext(colnames(fit$predicted)[i], side = 3)
  mtext(paste0('R2=',rsq), side = 3, line = -1.5, adj = 0.05)

}


setwd('/home/pc-752828/Dev/results-search-master/results-csv')

library(ggplot2)
library(reshape2)
library(ggstatsplot)
library(tcltk)
library(rstatix)
library(PMCMRplus)

data <- read.csv(file = 'output-n.out', sep = ',', header = T)
data_new <- data

value <- function(x, name) {
  mym = mean(x)
  mysd = sd(x)
  mysqrt = sqrt(length(x))

  return(c(mn = mym, sd = mysd/mysqrt, bo = name))
}

for(i in levels(factor(data_new$name))) {
print(i)
data_f<-data.frame(data[data['name'] == i & data['bo'] == 'bo1',])
bo1 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EIdef')))
bo1 <- as.data.frame(as.list(bo1))

data_f<-data.frame(data[data['name'] == i & data['bo'] == 'bo4' & data['target'] == 2,])
bo2 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'PB3Opt')))
bo2 <- as.data.frame(as.list(bo2))

data_f<-data.frame(data[data['name'] == i & data['bo'] == 'rs',])
bo3 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'RS')))
bo3 <- as.data.frame(as.list(bo3))

data_f<-data.frame(data[data['name'] == i & data['bo'] == 'bo5',])
bo4 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EInova')))
bo4 <- as.data.frame(as.list(bo4))

df <- rbind(bo1, bo2, bo3, bo4)
df$x.mn = as.numeric(as.character(df$x.mn))
df$Group.1 = as.numeric(as.character(df$Group.1))
df$x.sd = as.numeric(as.character(df$x.sd))
df_new <- df

name <- paste('imgs', i, sep = "/" )
pdf(paste(name, "-zoom.pdf", sep=""))

print(ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  geom_errorbar(aes(ymin=x.mn-x.sd, ymax=x.mn+x.sd,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  coord_cartesian(ylim=c(1,2), xlim=c(1,30))+
  labs(color = element_blank(), x="Iteração", y="Média do Melhor Custo Normalizado")+
  theme(legend.justification=c(1, 1),legend.position=c(.8, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 30, 1)))
dev.off()

pdf(paste(name, "pdf", sep="."))
print(ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  geom_errorbar(aes(ymin=x.mn-x.sd, ymax=x.mn+x.sd,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  #coord_cartesian(ylim=c(1,2), xlim=c(1,30))+
  labs(color = element_blank(), x="Iteração", y="Média do Melhor Custo Normalizado")+
  theme(legend.justification=c(1, 1),legend.position=c(.8, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 30, 1)))
dev.off()
}

library(ggplot2)
library(reshape2)
library(reshape)
library(ggstatsplot)
library(tcltk)
library(rstatix)
library(dplyr)

data <- read.csv(file = 'output-n.out', sep = ',', header = T)
data_new <- data

my_ite <- 15
bo1 <- list()
bo2 <- list()
bo3 <- list()
bo4 <- list()
rs <- list()
app <- list()

for(seed in seq(2, 2)) {
  for(i in levels(factor(data_new$name))) {
    #r_my <- data[data['name'] == i & data['bo'] == 'bo4' & data['target'] == 2 & data['ite'] == my_ite,][seed,]
    r_bo1 <- data[data['name'] == i & data['bo'] == 'bo1' & data['ite'] == my_ite,][seed,]
    r_bo4 <- data[data['name'] == i & data['bo'] == 'bo4' & data['ite'] == my_ite,][seed,]
    r_bo3 <- data[data['name'] == i & data['bo'] == 'bo3' & data['ite'] == my_ite,][seed,]
    r_bo2 <- data[data['name'] == i & data['bo'] == 'bo5' & data['ite'] == my_ite,][seed,]
    r_rs <- data[data['name'] == i & data['bo'] == 'rs' & data['ite'] == my_ite,][seed,]
    bo1 <- append(bo1, levels(factor(r_bo1$best)))
    bo2 <- append(bo2, levels(factor(r_bo2$best)))
    bo3 <- append(bo3, levels(factor(r_bo3$best)))
    bo4 <- append(bo4, levels(factor(r_bo4$best)))
    rs <- append(rs, levels(factor(r_rs$best)))
    app <- append(app, i)
  }
}

df_1<-cbind(bo1, bo2, bo3, bo4, rs, app)
df_1 <- data.frame(df_1)

df_2<-cbind(bo1, bo2, bo3, bo4, rs, app)
df_2 <- data.frame(df_2)

df_1$bo1 = as.numeric(as.character(df_1$bo1))
df_1$bo2 = as.numeric(as.character(df_1$bo2))
df_1$bo3 = as.numeric(as.character(df_1$bo3))
df_1$bo4 = as.numeric(as.character(df_1$bo4))
df_1$rs = as.numeric(as.character(df_1$rs))

df_2$bo1 = as.numeric(as.character(df_2$bo1))
df_2$bo2 = as.numeric(as.character(df_2$bo2))
df_2$bo3 = as.numeric(as.character(df_2$bo3))
df_2$bo4 = as.numeric(as.character(df_2$bo4))
df_2$rs = as.numeric(as.character(df_2$rs))

summary(df$bo1)
summary(df$bo2)
summary(df$bo3)
summary(df$bo4)
summary(df$rs)

cols <- c("BO-6rnd-EIdef","BO-6rnd-EInova","BO-6sel-EIdef", "PB3Opt", "Ranking Search", "ID")
colnames(df_1) <- cols

View(df)
glimpse(df_1)

df_1$ID = as.character(df_1$ID)
df_1$ID <- factor(df_1$ID)

cols <- c("BO-6rnd-EIdef","BO-6rnd-EInova","BO-6sel-EIdef", "PB3Opt", "Ranking Search")
new_df <- melt(df, id = "ID", measured = cols)

glimpse(new_df)

#new_df$app = as.character(new_df$app)
write.csv(x=df_1,file="teste.csv", row.names = FALSE)

new_df <- data.frame(new_df)
glimpse(new_df)

new_df <- sort_df(new_df, vars = 'id')
new_df$id <- as.numeric(new_df$id)
new_df$id <- factor(new_df$id)

glimpse(new_df)

new_df %>% group_by(variable) %>%
  identify_outliers(value)

new_df %>% group_by('variable') %>%
  shapiro_test(value)

new_df %>% group_by("variable") %>%
  get_summary_stats(value, type = "median_iqr")

new_df %>% group_by(variable) %>%
  print(value)

shapiro.test(df$`Ranking Search`)

kruskal.test(value ~ variable, data = new_df)

dunn_test(value ~ variable, data = new_df, p.adjust.method = "holm", detailed = FALSE)

df$dif <- df$bo1-df$bo4

par(mfrow=c(2, 3))
xrange <- range( 0, 95, 50)
hist(df$bo1, breaks=50, col=rgb(1, 1,1,0.5), xlim = xrange,
     xlab="Custo Normalizado" , ylab="Frequência", main = "BO-6rnd-EIdef")
axis(1, at=seq(10,30,by=10), labels=seq(10,30,by=10) )

hist(df$bo2, breaks=50, col=rgb(1,1,1,0.5), xlab="height" , ylab="nbr of plants")
hist(df$bo3, breaks=50, col=rgb(1,1,1,0.5), xlab="height" , ylab="nbr of plants")
hist(df$bo4, breaks=50, col=rgb(1,1,1,0.5), xlab="height" , ylab="nbr of plants")
hist(df$rs, breaks=50, col=rgb(1,1,1,0.5), xlab="height" , ylab="nbr of plants")

ggplot(df, aes(x=bo3)) + geom_histogram()+
  theme(legend.justification=c(1, 1),legend.position=c(.9, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8),
        legend.background = element_rect(fill=alpha('white', 0.6)))

wilcox.test(df$bo1, df$bo4, paired = TRUE, alternative = "greater", conf.int = TRUE)

tikz('boxplot.tex')

par(mfrow=c(2, 3))

boxplot(df_1$bo1,df_1$bo2, df_1$bo3, df_1$bo4, df_1$rs, xlab = "Abordagem", ylab = "Custo Normalizado", outline = FALSE)
grid(nx=16, ny=16)
boxplot(df$bo1,df$bo2, df$bo3, df$bo4, df$rs, add = TRUE,
        xlab = "Abordagem",
        ylab = "Custo Normalizado",
        names=c('A1', 'A2', 'A3', 'A4', 'A5'))
legend(x=2,y=2,legend=c("A1 - BO-6rnd-EIdef",
                        "A2 - BO-6rnd-EInova",
                        "A3 - BO-6sel-EIdef",
                        "A4 - BO3Opt",
                        "A5 - Ranking Search"),
       fill=c("white","white","white","white","white"), bty = "n")

dev.off()

par(mfrow=c(3, 2))

p1<-ggplot(new_df, aes(x = value))+
  geom_histogram(aes(color = variable, fill = variable),
                 alpha = 0.3, position = "dodge", binwidth = 2)+
  labs(x="Custo Normalizado", y="Frequência")+
  #coord_cartesian(ylim=c(1,20), xlim=c(1,30))+
  theme(legend.justification=c(1, 1),legend.position=c(.9, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 97, 4))+
  ggtitle('a) Melhor Custo Encontrado')

p2<-ggplot(new_df, aes(x = value))+
  geom_histogram(aes(color = variable, fill = variable),
                 alpha = 0.3, position = "dodge", binwidth = 2)+
  labs(x="Custo Normalizado", y="Frequência")+
  coord_cartesian(ylim=c(1,20), xlim=c(1,30))+
  theme(legend.justification=c(1, 1),legend.position=c(.9, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 97, 4))+
  ggtitle('b) Zoom da Figura a')

tikz('hist.tex')
grid.arrange(p1, p2, nrow = 2, ncol=1, top="", left="Frequência")
dev.off()

library("ggpubr")

ggline(new_df, x = "variable", y = "value",
       add = c("mean_se", "jitter"),
       order = c("ctrl", "trt1", "trt2"),
       ylab = "Weight", xlab = "Treatment")

p0 <-ggplot(new_df, aes(x = value, y= variable, color = variable, fill = variable))+
  geom_boxplot(alpha=0.7, colour = "black")+
  stat_summary(fun.y=mean, geom="point", shape=20, size=2, color="red", fill="red") +
  theme(legend.position="none")+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  labs(color = element_blank(), x="Custo Normalizado", y="Frequência")

ylim1<- c(1, 2)
p0 + coord_cartesian(xlim = ylim1)

View(new_df)
View(df)

friedman.test(value ~ variable | ID, data = new_df)

frdAllPairsSiegelTest(new_df$Best, new_df$Abordagem, new_df$ID, p.adjust = "bonferroni")
frdAllPairsConoverTest(new_df$value, new_df$variable, new_df$ID, p.adjust = "bonferroni")
frdAllPairsNemenyiTest(new_df$value, new_df$variable, new_df$ID, p.adjust = "bonferroni")

new_df
colnames(new_df) <- c("ID", "Abordagem", "Best")
new_df %>% group_by(Abordagem) %>%
  get_summary_stats(Best, type = "median_iqr")
new_df


input = read.csv("D:/vaibhav/trend nxt/topgear/R Community/adult_census_income/Adult Census Income Binary Classification dataset.csv", header=TRUE)
head(input)
summary(input)
str(input)
input$income2 = ifelse(input$income == " <=50K",0, 1 )
head(input)
input1 = read.csv("D:/vaibhav/trend nxt/topgear/R Community/adult_census_income/Adult Census Income Binary Classification dataset.csv", header=TRUE, na.strings = c(" ?", " "))
na.omit(input1)
head(input1)
summary(input1)
str(input1)
input1$income2 = ifelse(input1$income == " <=50K",0, 1 )
head(input1)
shuffle_index = sample(1:nrow(input1))
head(shuffle_index)
input1 = input1[shuffle_index,]
head(input1)

test_data_size = 0.8
data_size = nrow(input1)
train_sample = 1:(test_data_size*data_size)
train_data = input1[train_sample, ]
test_data = input1[-train_sample, ]

##install if package is not installed
##install.packages("rpart.plot")
library(rpart)
library(rpart.plot)

fit <- rpart(income2 ~ age + workclass + fnlwgt + education + marital.status + occupation + relationship + race + sex + capital.gain + capital.loss + hours.per.week + native.country, data = train_data, method = 'class')
rpart.plot(fit, extra = 106)
predict_unseen <-predict(fit, test_data, type = 'class')
table_mat <- table(test_data$income2, predict_unseen)
table_mat
accuracy_Test <- sum(diag(table_mat)) / sum(table_mat)
accuracy_Test


library(readr)
library(data.table)
library(Rtsne)
library(Metrics)
path <- "../Data/"
train <- read_csv(paste0(path,"train_tfidf.csv"))
train <- as.data.frame(train)
dim(train)
test <- read_csv(paste0(path,"test_tfidf.csv"))
test <- as.data.frame(test)
dim(test)
TsneDim <- 3 # 2 or 3
tmp <- as.factor(train$target)
train$id <-NULL
test$id <- NULL
train$target <- NULL
x <- rbind(train,test)
dim(x)
N <- nrow(train)
rm(train)
rm(test)
gc()

print("constructing t-sne")
set.seed(131)
tsne <- Rtsne(x, dims = TsneDim, perplexity = 50, initial_dims = 50,
theta = 0.5, check_duplicates = F, pca = T, verbose=TRUE, max_iter = 500)

colors = rainbow(length(unique(tmp)))
names(colors) = unique(tmp)

if(TsneDim==2){
  plot(tsne$Y[1:N,], t='n', main="tsne")
  text(tsne$Y[1:N,], labels=tmp, col=colors[tmp])
}
if(TsneDim==3){
  library(rgl)
  plot3d(tsne$Y[1:N,1],tsne$Y[1:N,2],tsne$Y[1:N,3],col=colors[tmp])
}

train <- tsne$Y[1:N,]
test <- tsne$Y[(N+1):nrow(tsne$Y),]
if(TsneDim==2){
colnames(train) <- c("dim1","dim2")
colnames(test) <- c("dim1","dim2")
}
if(TsneDim==3){
colnames(train) <- c("dim1","dim2","dim3")
colnames(test) <- c("dim1","dim2","dim3")
}

train <- as.data.frame(train)
test <- as.data.frame(test)
for(i in 1:3){
train[,i] <- as.character(train[,i])
test[,i] <- as.character(test[,i])
}
gc()

write_csv(train,paste0(path,"tfidf_train_tsne.csv"),col_names=T)
write_csv(test,paste0(path,"tfidf_test_tsne.csv"),col_names=T)


# https://github.com/gjabel/migest/blob/master/demo/cfplot_reg2.R
pdf_file<-"pdf/networks_chord_diagram_migration.pdf"
cairo_pdf(bg="grey98", pdf_file, width=8,height=8)
par(omi=c(0.25,0.25,0.25,0.25), mai=c(0,0,0,0), family="Lato Light")

library("circlize")

# Read data and prepare chart

df0 <- read.csv("myData/reg_flow.csv", stringsAsFactors=FALSE)
df1 <- read.csv("myData/reg_plot.csv", stringsAsFactors=FALSE)

circos.par(start.degree = 90, gap.degree = 4, track.margin = c(-0.1, 0.1), points.overflow.warning = FALSE)
par(mar = rep(0, 4))

# Create chart

chordDiagram(x = df0, grid.col = df1$col, transparency = 0.25,
             order = df1$region, directional = 1,
             direction.type = c("arrows", "diffHeight"), diffHeight  = -0.04,
             annotationTrack = "grid", annotationTrackHeight = c(0.05, 0.1),
             link.arr.type = "big.arrow", link.sort = TRUE, link.largest.ontop = TRUE)

circos.trackPlotRegion(
  track.index = 1,
  bg.border = NA,
  panel.fun = function(x, y) {
    xlim <- get.cell.meta.data("xlim")
    sector.index <- get.cell.meta.data("sector.index")
    reg1 <- df1$reg1[df1$region == sector.index]
    reg2 <- df1$reg2[df1$region == sector.index]

    circos.text(x = mean(xlim), y = ifelse(test = nchar(reg2) == 0, yes = 5.2, no = 6.0),
                labels = reg1, facing = "bending", cex = 1.2)
    circos.text(x = mean(xlim), y = 4.4,
                labels = reg2, facing = "bending", cex = 1.2)
    circos.axis(h = "top",
                major.at = seq(from = 0, to = xlim[2], by = ifelse(test = xlim[2]>10, yes = 2, no = 1)),
                minor.ticks = 1, major.tick.percentage = 0.5,
                labels.niceFacing = FALSE)
  }
)

circos.clear()

# Titling

text(x = -1.1, y = -1, pos = 4, cex = 0.6,
     labels = "Based on estimates from:")
text(x = -1.1, y = -1 - 1*0.03, pos = 4, cex = 0.6,
     labels = expression(paste(
       plain(" Abel G.J. (2016) "), italic("Estimates of Global Bilateral Migration Flows by Gender")
     )))
text(x = -1.1, y = -1 - 2*0.03, pos = 4, cex = 0.6,
     labels = expression(paste(
         italic(" between 1960 and 2015. "), plain("Vienna Institute of Demography Working Papers. 2/2016")
     )))

dev.off()


#!/usr/bin/env Rscript

# install.packages("igraph", repos = "http://cran.us.r-project.org")
# install.packages("Matrix", repos = "http://cran.us.r-project.org")

library(igraph)
library(Matrix)

if (length(args) == 0)
{
  	stop("One argument must be supplied root vertex", call.=FALSE)
} 	else if (length(args) == 1)
{
	args <- commandArgs(trailingOnly = TRUE)
  	root <- strtoi(args[1])
}

adjm <- readMM("ecoli.hifi.result.mtx")
G <- graph_from_adjacency_matrix(adjm, weighted=TRUE)

# E(G)$weight
# str(adjm)

# print("Graph loaded")

# G2 <- graph_from_adjacency_matrix(adjm, weighted=TRUE, mode="max") # "max": an undirected graph will be created and max(A(i,j), A(j,i)) gives the edge weights.
# E(G2)$weight

## Callback function to stop seach past 10 dist
f <- function(graph, data, extra) {
  data['dist'] == 10
}

# bfs(G, root, unreachable = FALSE, restricted = NULL, order = TRUE,
#   rank = FALSE, father = FALSE, pred = FALSE, succ = FALSE,
#   dist = TRUE, callback = NULL, extra = NULL,
#   rho = parent.frame())

tmp <- bfs(G, root, unreachable = FALSE, restricted = NULL, order = TRUE,
  rank = FALSE, father = FALSE, pred = FALSE, succ = FALSE,
  dist = TRUE, callback = f, extra = NULL,
  rho = parent.frame())

# str(tmp)
# tmp

vid <- 1
vidvect <- vector()

for (hoop in tmp[['dist']])
{
	if(!is.nan(hoop))
	{
    	# print(hoop)
    	# print(vid)
    	vidvect <- append(vidvect, vid)
	}

	vid = vid + 1
}

# print(vidvect)

## Extract subgraph
S <- induced_subgraph(G, vidvect, impl = c("create_from_scratch")) # "create_from_scratch" constructs the result graph from scratch and then copies the attributes accordingly
E(S)$weight

write_graph(S, "testr1.dot", format = c("dot"))

## Type 'dot -T pdf -O testr1.dot -Ename=weight' from command line to generate the plot using GraphViz


library('missForest')

dm_traindf[dm_traindf==""] <- NA

imp <- missForest(dm_traindf, maxiter = 2, ntree = 30)

dm_scoreddf <- imp$ximp
dm_scoreddf$BAD <- as.numeric(dm_scoreddf$BAD) - 1

print("/nInput")
head(dm_traindf$BAD)

print("/nScored")
head(dm_scoreddf$BAD)

print("/nDataFrame")
head(dm_scoreddf)


library("zoo")
library("xts")
library("ggplot2")

attacks <- read.csv("../../out/snort/distinct/part-r-00000", header=F)

z_attacks <- zoo(attacks$V6, as.POSIXlt(attacks$V1,origin="1970-01-01", tz="GMT"))

plot(z_attacks,title="Time",ylab="Attacks")
points(z_attacks, col='blue', pch=20, cex=1)
qplot(x=attacks$V6, stat='density', geom='line', xlab="No of Attacks per bin period",ylab="Density")


# Performing basic data wrangling tasks

# Load the gapminder package
library(gapminder)

# Load the dplyr package
library(dplyr)

# Look at the gapminder dataset
gapminder

# 1. Verb - filter
library(gapminder)
library(dplyr)

# Filter the gapminder dataset for the year 1957. %>%: represents a pipe
gapminder %>% filter(year == 1957)

# Filter for China in 2002. Multiple filters can be separated by a comma
gapminder %>%
    filter(country == "China", year == 2002)

# 2. Verb - arrange, used for sorting data
# Sort in ascending order of lifeExp
gapminder %>%
    arrange(lifeExp)

# Sort in descending order of lifeExp
gapminder %>%
    arrange(desc(lifeExp))

# Filter for the year 1957, then arrange in descending order of population. Can use pipe operator multiple times (similar to bash) to produce the final dataset
gapminder %>%
    filter(year == 1957) %>%
        arrange(desc(pop))

# 3. Verb - mutate, used to alter or create a column
# Use mutate to change lifeExp to be in months
gapminder %>%
    mutate(lifeExp = lifeExp * 12)

# Use mutate to create a new column called lifeExpMonths
gapminder %>%
    mutate(lifeExpMonths = lifeExp * 12)

# 4. Bringing it all together
# Filter, mutate, and arrange the gapminder dataset
gapminder %>%
    filter(year == 2007) %>%
        mutate(lifeExpMonths = lifeExp * 12) %>%
            arrange(desc(lifeExpMonths))


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders")
library(tidyverse)

df <- readRDS("main_features_cln.rds")
icd <- read.csv("./ICD10 codes/icd10_vars.csv")

str(icd)

df <- df %>% mutate(IDm = paste(ID, days_to_lefteddate, sep="_"))
df <- left_join(df, icd)

#main_Frail_Fal_3L has zero value
##################################
library(infotheo)

X <- df %>% select(-ID, -IDm, - alc_status)
res <- mutinformation(X, df$alc_status, method = "emp")

res <- X %>% sapply(function(x){
mutinformation(x, df$alc_status, method = "emp") / sqrt(entropy(x) * entropy(df$alc_status)) })

write.csv(res[order(-res)], "./mutualInfo_features.csv")

##################################
df %>% group_by(admambul) %>%
summarise(n = n(),
 n_alc_perc = round(mean(as.numeric(alc_status)) * 100,digits = 2))

 #####################
 df %>% select(-ID, -days_to_lefteddate, -IDm) %>% sapply(tabna)


library(binom)
library(bbmle)

compute.gamma.stat = function (x, p.lower, p.upper) {
  gamma.mean.variance.loglik = function (mu, sigma.2) {
    alpha = mu * mu / sigma.2;
    beta = mu / sigma.2;
    loglik = -sum(dgamma(x, alpha, beta, log=TRUE));
    return(loglik);
  }

  if (sum(!is.na(x)) > 1 && sd(x) > 1e-5) {
    stat = mle2(gamma.mean.variance.loglik,
                start = list(mu = mean(x), sigma.2 = var(x)),
                method = 'L-BFGS-B',
                lower = p.lower, upper = p.upper);

    ci = confint(stat, 'mu', quitely=T)
    while (is(ci, 'mle2')) {
      stat = mle2(gamma.mean.variance.loglik,
                  start = list(
                    mu = unname(coef(ci)['mu.mu']),
                    sigma.2 = unname(coef(ci)['sigma.2'])
                  ),
                  method = 'L-BFGS-B',
                  lower = p.lower, upper = p.upper);

      ci = confint(stat, 'mu', quitely=T)
    }

    return(list(
      mean = unname(coef(stat)['mu']),
      sigma.2 = unname(coef(stat)['sigma.2']),
      lower = unname(ci[1]),
      upper = unname(ci[2])
    ));
  } else {
    return(compute.normal.stat(x, p.lower, p.upper, sigma.2 = var(x)));
  }
}

compute.beta.stat = function (x, p.lower, p.upper) {
  x = pmin(0.5 - 1e-16, pmax(1e-16, x))

  beta.mean.v.loglik = function (mu, v) {
    mu.2x = mu * 2;
    alpha = mu.2x * v;
    beta = (1 - mu.2x) * v;
    loglik = -sum(pmin(1e6, pmax(-1e6, dbeta(x, alpha, beta, log=TRUE))));
    return(loglik);
  }

  v.init = (mean(x) * (0.5 - mean(x))) / var(x) - 1

  if (sum(!is.na(x)) > 1 && sd(x) > 1e-10) {
    stat = mle2(beta.mean.v.loglik,
                start = list(
                  mu = mean(x),
                  v = v.init
                ),
                method = 'L-BFGS-B',
                lower = c(mu=0, v=1e-5), upper = c(mu=0.5, v=Inf));

    if (any(is.na(unname(summary(stat)@coef[, "Std. Error"])) &
        is.na(sqrt(1/diag(stat@details$hessian))))) {
      return(compute.normal.stat(x, p.lower, p.upper, v = v.init));
    }
    ci = confint(stat, 'mu', quitely=T)

    while (is(ci, 'mle2')) {
      stat = mle2(beta.mean.v.loglik,
                  start = list(
                    mu = unname(coef(ci)['mu.mu']),
                    v = unname(coef(ci)['v'])
                  ),
                  method = 'L-BFGS-B',
                  lower = c(mu=0, v=1e-5), upper = c(mu=0.5, v=Inf));

      if (any(is.na(unname(summary(stat)@coef[, "Std. Error"])) &
          is.na(sqrt(1/diag(stat@details$hessian))))) {
        return(compute.normal.stat(x, p.lower, p.upper, v = v.init));
      }
      ci = confint(stat, 'mu', quitely=T)
    }

    return(list(
      mean = unname(coef(stat)['mu']),
      v = unname(coef(stat)['v']),
      lower = unname(ci[1]),
      upper = unname(ci[2])
    ));
  } else {
    return(compute.normal.stat(x, p.lower, p.upper, v = v.init));
  }
}

compute.normal.stat = function (x, p.lower, p.upper, ...) {
  mu = mean(x);
  alpha = 0.95;

  if (length(x) > 1) {
    ci = abs(qt((1 - alpha) / 2, length(x) - 1)) * (sd(x) / sqrt(length(x)));

    return(list(
      mean = mu,
      lower = min(p.upper['mu'], max(p.lower['mu'], mu - ci)),
      upper = min(p.upper['mu'], max(p.lower['mu'], mu + ci)),
      ...
    ));
  } else {
    return(list(mean = mu, lower = NA, upper = NA, ...));
  }
}

compute.summary = function (df.group, vars, assume.normal = FALSE) {
  solved = with(df.group, solved);
  converged.at = with(df.group, extrapolation.step.solved[solved]);
  sparse.error = with(df.group, sparse.error.max[solved]);

  success.rate.stat = binom.confint(
    sum(solved), length(solved),
    conf.level = 0.95, method = 'wilson'
  );

  if (assume.normal) {
    sparse.error.stat = compute.normal.stat(
      sparse.error,
      c(mu=0, sigma.2=1e-5),
      c(mu=0.5, sigma.2=Inf),
      v = (mean(x) * (0.5 - mean(x))) / var(x) - 1
    );
  } else {
    sparse.error.stat = compute.beta.stat(
      sparse.error,
      c(mu=0, sigma.2=1e-5),
      c(mu=0.5, sigma.2=Inf)
    );
  }

  if (assume.normal) {
    converged.at.stat = compute.normal.stat(
      converged.at,
      c(mu=0, sigma.2=1e-5),
      c(mu=Inf, sigma.2=Inf),
      sigma.2 = var(x)
    );
  } else {
    converged.at.stat = compute.gamma.stat(
      converged.at,
      c(mu=0, sigma.2=1e-5),
      c(mu=Inf, sigma.2=Inf)
    );
  }

  return(data.frame(
    success.rate.mean = success.rate.stat$mean,
    success.rate.lower = success.rate.stat$lower,
    success.rate.upper = success.rate.stat$upper,
    success.rate.max = NA,

    converged.at.median = ifelse(length(converged.at) > 0, median(converged.at), NA),
    converged.at.sigma.2 = converged.at.stat$sigma.2,
    converged.at.mean = converged.at.stat$mean,
    converged.at.lower = converged.at.stat$lower,
    converged.at.upper = converged.at.stat$upper,
    converged.at.max = ifelse(length(converged.at) > 0, max(converged.at), NA),

    sparse.error.v = sparse.error.stat$v,
    sparse.error.mean = sparse.error.stat$mean,
    sparse.error.lower = sparse.error.stat$lower,
    sparse.error.upper = sparse.error.stat$upper,
    sparse.error.max = NA
  ));
}


remove(list = ls())
library(glmnet)
library(caret)
library(MLeval)
library(qpcR)
library(readxl)
library(dplyr)
library(ggplot2)
library(GGally)
library(pROC)
library(gbm)
set.seed(500)

## DATA set up for LASSO TRAIN
lasso_data <- read_excel("~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/3way/mb_t1_t2_3way.xlsx")
lasso_data[,"molec_id"]  <- NULL
lasso_data[,"seg_id"]  <- NULL
lasso_data[,"dx_date"]  <- NULL
lasso_data[,"alive"]  <- NULL
lasso_data[,"os"]  <- NULL
lasso_data[,"pfs"]  <- NULL

lasso_data$sex[lasso_data$sex == "M"] <- "0"
lasso_data$sex[lasso_data$sex == "F"] <- "1"
lasso_data$sex <- as.factor(lasso_data$sex)
#View(lasso_data)

#lasso_data<-lasso_data[!(lasso_data$molecular=="3 or 4"),]
#lasso_data<-lasso_data[!(lasso_data$molecular=="shh or 3 or 4"),]
#lasso_data<-lasso_data[!(lasso_data$molecular=="?"),]

#head(lasso_data)
count(lasso_data, molecular)
ncol(lasso_data)

inTraining <- createDataPartition(lasso_data$molecular, p = 0.70, list = FALSE)
training <- lasso_data[inTraining,]
testing <- lasso_data[-inTraining,]

count(lasso_data, molecular)
count(training, molecular)
count(testing, molecular)

#need to customize column range to match number of features
dimcol <- ncol(lasso_data) #check
x <- (training[, 2:dimcol])
View(x)

#formats features to dataframe
x_final.df <- data.frame(x)
x_final <- model.matrix( ~., x_final.df)
x_final <- x_final[,-1] #remove intercept
#View(x_final)

#extract output data, stored in column 1
y <- training[, 1]

#formats output to data frame, convert to binary/numeric
y.df <- data.frame(y)
View(y)

y_binary <- model.matrix( ~., y.df)
View(y_binary)

y_binary <- y_binary[,-1] #remove intercept
sapply(y_binary[1], class)
View(y_binary)

#####
#LASSO
print('Training Dataset -  LASSO Multi Classification')
cvfit = cv.glmnet(x_final, y_binary, family = "multinomial", nfolds = 10, type.measure = "mse", keep = TRUE)
cvfit
plot(cvfit)

#Set up matrix to collect predicted coefficients
#rows matching the number of columns in x_final i.e. the number of features
#need to add 1 because there is an intercept generated with "Coefficients" in the loop
AllCoefficients1 = sparseMatrix(ncol(x_final)+1,1)
AllCoefficients2 = sparseMatrix(ncol(x_final)+1,1)
#AllCoefficients3 = sparseMatrix(ncol(x_final)+1,1)

AllErrors1 <-matrix() # rows = length of lambda stored in "cvm"; default i 100. col = # of seeds
AllErrors2 <-matrix() # rows = length of lambda stored in "cvm"; default i 100. col = # of seeds
#AllErrors3 <-matrix() # rows = length of lambda stored in "cvm"; default i 100. col = # of seeds

#Loops through the number of iterations of LASSO
#Can change seed iterations here

head(coeff1) #should see all the coefficients
head(Active.Index1) #should see a vector of indices
head(coeff1[Active.Index1]) #should see the coeff for that vector
head(AllCoefficients1) #should see concatenation of indices

for (i in 1:100) {
  print(i)
  set.seed(1)
  cvfit = cv.glmnet(x_final, y_binary, family = "multinomial", nfolds = 10)
  Coefficients <- coef(cvfit, s = cvfit$lambda.min) #yields Coefficients for given cycle
  coeff1 <- Coefficients[["molecularshh"]] #access the matrix for molecularwnt in the list containing matrices for molecular subtypes
  coeff2 <- Coefficients[["molecularwnt"]]
  #coeff3 <- Coefficients[["molecularwnt"]]
  head(coeff1)
  head(coeff2)
  Active.Index1 <- which(coeff1 !=0) #yields vector returning the column-inputs that were significant
  Active.Index2 <- which(coeff2 !=0)
  #Active.Index3 <- which(coeff3 !=0)
  head(Active.Index1)
  head(Active.Index2)

  Active.Coefficients1 <- coeff1[Active.Index1] #yields the coefficients of those significant columns
  Active.Coefficients2 <- coeff2[Active.Index2]
  #Active.Coefficients3 <- coeff2[Active.Index3]

  AllCoefficients1 <- cbind(AllCoefficients1, coeff1) #stores all the estimated coefficients for output--includes zeros
  AllCoefficients2 <- cbind(AllCoefficients2, coeff2)
  #AllCoefficients3 <- cbind(AllCoefficients3, coeff3)

  cvfit$cvm <- append(cvfit$cvm,i) #where cvfit$cvm is the mean cross-validated error - a vector of length length(lambda).
  AllErrors1 <- qpcR:::cbind.na(AllErrors1, cvfit$cvm) #stores all the errors for output
  AllErrors2 <- qpcR:::cbind.na(AllErrors2, cvfit$cvm)
  #AllErrors3 <- qpcR:::cbind.na(AllErrors3, cvfit$cvm)
}
write.csv(as.data.frame(as.matrix(AllCoefficients1)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/3way/LASSO_multi_features1.csv") ## may not write if path is incorrect
write.csv(as.data.frame(as.matrix(AllCoefficients2)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/3way/LASSO_multi_features2.csv") ## may not write if path is incorrect
#write.csv(as.data.frame(as.matrix(AllCoefficients3)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/4way/LASSO_multi_features3.csv") ## may not write if path is incorrect

#write.csv(as.data.frame(as.matrix(AllErrors1)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/4way/LASSO_multi_errors1.csv")
#write.csv(as.data.frame(as.matrix(AllErrors2)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/4way/LASSO_multi_errors2.csv")
#write.csv(as.data.frame(as.matrix(AllErrors3)), file = "~/Desktop/peds_tumor/mbpyradiomics/molec_classifier/4way/LASSO_multi_errors3.csv")


#script to create moisture capital map for testing (for % chg)

#requires climate data from cru_ts4.zip (via https://crudata.uea.ac.uk/cru/data/hrg/)

rm(list = ls())
library(raster)
library(tidyverse)

#set scenario parms
initial_yr <- 2018
final_yr <- 2035
perc_chg <- -20   #this is the % difference over the entire period
additional_yr <- T  #if true generate a map for the year after the final year

count_yrs <- final_yr - initial_yr
final_diffc <- 1 + (perc_chg / 100)  #convert to final proportion diffc (over entire period)

#read update file
input_scenario <- "Data/Moisture/GSCap_JanFebMarAprMayJun_S_"
#input_scenario <- "Data/Moisture/GSCap_JanFebMarAprMayJun_S_"
#input_scenario <- "Data/Moisture/test_"
initial_map <- raster(paste0(input_scenario,initial_yr,".asc"))

#calculate final year values
final_map <- round(initial_map * final_diffc,3)
final_map[final_map < 0] <- 0
final_map[final_map > 1] <- 1

delta_map <- (final_map - initial_map) / count_yrs  #change by this amount each year (per pixel)

#plot(initial_map,main=initial_yr)

#loop over all years using delta_map to change each year
for(yr in seq(from=initial_yr+1,to=final_yr-1,by=1)){

  initial_map <- round(initial_map + delta_map,3)
  initial_map[initial_map < 0] <- 0
  initial_map[initial_map > 1] <- 1

  #plot(initial_map,main=yr)
  #m <- cellStats(initial_map, 'mean', na.rm=T)
  print(yr)

  writeRaster(initial_map,paste0(input_scenario,"testing",perc_chg,"_",yr,".asc"))

}

writeRaster(final_map,paste0(input_scenario,"testing",perc_chg,"_",final_yr,".asc"))
#plot(final_map,main=final_yr)

if(additional_yr){

  add_yr <- final_yr+1
  add_map <- round(final_map + delta_map,3)
  add_map[add_map < 0] <- 0
  add_map[add_map > 1] <- 1

  print(add_yr)
  writeRaster(add_map,paste0(input_scenario,"testing",perc_chg,"_",add_yr,".asc"))

}


#' Infers a partial correlation network from expression data
#'
#' @param expr      A gene expression matrix [genes x samples]
#' @param directed  Infer a directed network
#' @param qval      Only return edges with qvalue<cutoff
#' @param verbose   Print messages
#' @return          A data.frame of edges and their significance
infer_network = function(expr, directed=FALSE, qval=NULL, verbose=TRUE) {
    pm = GeneNet::ggm.estimate.pcor(t(expr))
    pm = GeneNet::network.test.edges(pm, direct=directed, plot=FALSE, verbose=verbose)

    if (!is.null(qval))
        pm = GeneNet::extract.network(pm, method.ggm="qval", cutoff.ggm=qval)

    pm$node1 = factor(rownames(expr)[pm$node1])
    pm$node2 = factor(rownames(expr)[pm$node2])
    pm
}

if (is.null(module_name())) {
    b = import('base')
    io = import('io')

    INFILE = commandArgs(TRUE)[1] %or% "../data/expr/STAD/cancer.RData"
    OUTFILE = commandArgs(TRUE)[2] %or% "genenet/STAD/1.RData"

    expr = io$load(INFILE)

    set.seed(strtoi(paste0("0x", substr(digest::digest(OUTFILE), 1, 5))))
    expr = expr[,sample(colnames(expr), replace=TRUE)]

    net = infer_network(expr, qval=0.1)

    save(net, file=OUTFILE)
}


## Functions for scaling the bootstrapped matrices

## These functions a helper functions that feed into scale_factor_R
## scale_factor_R takes the matrices elements of two contact matrices
## from the social mixR package, the matrices need to be bootstrapped ones
## as social mixr calls the element matrices when bootstrapped and matrix
## when just one value is created.

## mat1 and mat2 are the matrices objects

# Split contact matrix to only the required rows and columns
## This is because we do not have data for participants <18
split_cm <- function(mat, i = 1, row = 3:8, col = 3:8, ...){
  mat[[i]]$matrix[row,col]
}
split_cm_single <- function(mat, i = 1, row = 3:8, col = 3:8, ...){
  mat[row,col]
}

## Make the matrix symmetric
symm_mat <- function(x){
  (x + t(x))/ 2
}

## Calculate ratio of max eigen values
# This gives a sense of different magnitudes of the matrices
max_eigen_ratio <- function(x, y){
  max(eigen(x, only.values = TRUE)$values)/max(eigen(y, only.values = TRUE)$values)

}

# Take two matrices and calculate the scale factor for them
## Repeats the above functions to get the ratio of the max eigen values
## Of each matrix
scale_factor <- function(mat1, mat2, ... ){
  #x1 <- split_cm(mat1, ...)
  x2 <- split_cm(mat2, ...)
  x1 <- symm_mat(mat1)
  x2 <- symm_mat(x2)
  max_eigen_ratio(x1, x2)
}

# Take a full matrix and scale it based on ratio of mat1 and mat2
scale_matrix <- function(fullmat, mat1, mat2, i = 1, ...){
  mat1 <- mat1[[i]]$matrix

  fullmat[[i]]$matrix * scale_factor(mat1, mat2, i = i, ...)

}

## Specific for this analysis get imputed values for H2020 matrix
impute_values <- function(i = 1, school = FALSE, ...){
  imputed_values <- scale_matrix(
    polymod_boot_cm_home,
    h2020_boot_cm_home,
    polymod_boot_cm_home,
    i = i,
    ...
  ) +
    scale_matrix(
      polymod_boot_cm_work,
      h2020_boot_cm_work,
      polymod_boot_cm_work,
      i = i,
      ...
    ) +
    scale_matrix(
      polymod_boot_cm_other,
      h2020_boot_cm_other,
      polymod_boot_cm_other,
      i = i,
      ...
    )

  if(school){
    ## Schools were closed so can not scale by this so just add
    imputed_values <- imputed_values +
      polymod_boot_cm_school[[i]]$matrix
  }
  return(imputed_values)

}

update_cm <- function(
  mat1, mat2,
  impute_rows = 1:2, impute_cols = 1:8,
  i = 1,
  observed_rows = 2:8,
  observed_col = 1:8,
  school = FALSE,
  ...
){

  mat1 <- mat1[[i]]$matrix
  mat2 <- mat2[[i]]$matrix

  update_mat <- matrix(0, nrow = nrow(mat1), ncol = ncol(mat1))
  row.names(update_mat) <- colnames(mat1)
  colnames(update_mat)  <- colnames(mat1)

  #non_imputed_values <- mat1[row, col]
  update_mat <- mat1

  imputed_values <- impute_values(i = i, school = school, ... )[impute_rows, impute_cols]
  update_mat[impute_rows, impute_cols] <- imputed_values

  symm_mat(update_mat)
}

### Final function which calcualte the scaling factors for R.

scale_factor_R <- function(mat1, mat2, i = 1, ...){
  x1 <- update_cm(mat1, mat2, i = i, ...)
  x2 <- mat2[[i]]$matrix
  x1 <- symm_mat(x1)
  x2 <- symm_mat(x2)
  max_eigen_ratio(x1, x2)
}

### Repeat these for a single matrix objects.

##################

scale_factor_single <- function(mat1, mat2, ... ){
  x1 <- split_cm_single(mat1, ...)
  x2 <- split_cm_single(mat2, ...)
  x1 <- symm_mat(x1)
  x2 <- symm_mat(x2)
  max_eigen_ratio(x1, x2)
}

# Take a full matrix and scale it based on ratio of mat1 and mat2
scale_matrix_single <- function(fullmat, mat1, mat2, i = 1, ...){
  mat1 <- mat1

  fullmat * scale_factor_single(mat1, mat2, i = i, ...)

}

## Specific for this analysis get imputed values for H2020 matrix
impute_values_single <- function(i = 1, school = FALSE, ...){
  imputed_values <- scale_matrix_single(
    polymod_cm_home,
    h2020_cm_home,
    polymod_cm_home,
    i = i,
    ...
  ) +
    scale_matrix_single(
      polymod_cm_work,
      h2020_cm_work,
      polymod_cm_work,
      i = i,
      ...
    ) +
    scale_matrix_single(
      polymod_cm_other,
      h2020_cm_other,
      polymod_cm_other,
      i = i,
      ...
    )

  if(school){
    ## Schools were closed so can not scale by this so just add
    imputed_values <- imputed_values +
      polymod_cm_schoolmatrix
  }
  return(imputed_values)

}


# Winnings/losses each game per day
poker <- c(-11, 42, -49, 63, 74)
roulette <- c(-19, -8, -75, 92, 39)
days <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")

# Days assigned to each numerical value
names(poker) <- days
names(roulette) <- days

# Calculating total winnings/losses each day
total <- poker + roulette

# Show only profitable days
profit_check <- total > 0
profitable_days <- total[profit_check]

# Calculating profit/loss at end of week
final_amount <- sum(total)

# Comparing performance between games
total_poker <- sum(poker)
total_roulette <- sum(roulette)
if (total_poker > total_roulette) {
    print("Poker is better.")
} else {
    print("Roulette is better.")
}


library(tidyverse)
library(cmdstanr)
library(posterior)
library(bayesplot)
library(ggfan)
library(cowplot)
initialize_purrr_progress = function(x){
	.pp <<- progress::progress_bar$new(
		format = "[:bar] :percent eta: :eta"
		, total = length(x)
		, clear = FALSE
		, width= 60
	)
	return(x)
}
finalize_purrr_progress = function(x){
	x = identity(x) #to break lazy eval in pipe
	.pp$terminate()
	dt = difftime(Sys.time(),.pp$.__enclos_env__$private$start)
	cat('Operations took ',round(dt),' ',attr(dt,'units'))
	return(x)
}

generate_mod = cmdstan_model('stan/pvgp_generate.stan')
sample_mod = cmdstan_model('stan/pvgp_sample.stan')

f = function(z){
	if(!is.null(all_out)){
		if(nrow(semi_join(z,all_out,by=c('n','iter')))==1){
			return(NULL)
		}
	}
	n = z$n
	x = 1:n
	data_for_gen = lst(
		n = n
		, x = 1:n
		, pvn_ = .2
		, lengthscale_ = .1*diff(range(x))
		, sample_pvn = F
		, sample_lengthscale = F
	)
	capture.output(
		generated <- generate_mod$generate_quantities(
			data = data_for_gen
			, fitted_params = as_draws_array(tibble(dummy=0))
		)
	) -> captured_output

	#extract quantities
	(
		generated$draws(c('f','y'),format ="draws_list" )
		%>% as_draws_df()
		%>% as_tibble()
		%>% select(-.chain,-.iteration,-.draw)
		%>% pivot_longer(everything())
		%>% separate(
			name
			, into = c('name','index')
			, convert = TRUE
			, extra = 'drop'
		)
		# %>% View())
		%>% pivot_wider()
		%>% mutate(
			x = x[index]
		)
	) -> dat

	# compute distance matrix
	dx = matrix(NA,n,n)
	for(i in 1:n){
		for(j in 1:n){
			dx[i,j] = ((x[i]-x[j])^2)/-2 # divided by negative two to match standard kernel
		}
	}
	dx_ut_flat = as.numeric(dx[upper.tri(dx)])
	dx_lt_flat = as.numeric(dx[lower.tri(dx)])

	data_for_stan = lst(
		n_xy = nrow(dat)
		, x = dat$x
		, y = dat$y
		# udx: vector of unique differences in x (squared & divided by -2)
		, udx = unique(dx_ut_flat)
		# i_uk_k_ut: index array mapping between unique entries in k to the upper-triangle of k
		, i_uk_k_ut = match(dx_ut_flat,udx)
		# i_uk_k_lt: index array mapping between unique entries in k to the lower-triangle of k
		, i_uk_k_lt = match(dx_lt_flat,udx)
		# i_k_diag: index array indicating elements in flattened covariance matrix that are on the diagonal when unflattened
		, i_k_diag = which(as.numeric(diag(1,n,n))==1)
		# i_k_ut: index array indicating elements in flattened covariance matrix that are in the upper triangle when unflattened
		, i_k_ut = which(as.numeric(upper.tri(matrix(NA,n,n)))==1)
		# i_k_lt: index array indicating elements in flattened covariance matrix that are in the lower triangle when unflattened
		, i_k_lt = which(as.numeric(lower.tri(matrix(NA,n,n)))==1)
		# n_udx: number of unique differences in x
		, n_udx = length(udx)
		# n_ut: number of elements in covariance upper triangle
		, n_ut = length(i_k_ut)
	)

	#sample
	capture.output(
		sampled <- sample_mod$sample(
			data = data_for_stan
			, chains = parallel::detectCores()/2
			, parallel_chains = parallel::detectCores()/2
			, refresh = 0
			, show_messages = F
		)
	) -> captured_output

	#get max delta
	(
		sampled$draws('delta',format='draws_list')
		%>% map(.f=max)
		%>% unlist()
	) -> delta

	#get timing
	p = sampled$profiles()
	(
		p
		%>% bind_rows(.id = 'chain')
		%>% rename(value=total_time)
		%>% select(chain,name,value)
		%>% pivot_wider()
		%>% bind_cols(z)
		%>% mutate( delta = delta )
	) ->
		this_out
	all_out <<-bind_rows(all_out,this_out)
	saveRDS(all_out,file='all_out.rds')
	do_plots()
	# print(plot_grid(p1,p2,p3,nrow=3))#,rel_widths=c(5,1,5,1,5)))
	return(NULL)
}

do_plots = function(){
	(
		all_out
		%>% select(eqc,udx,n)
		%>% pivot_longer(cols=c(eqc,udx))
		%>% group_by(name,n)
		%>% summarize(
			med = median(value)
			, lo80 = quantile(value,.1)
			, hi80 = quantile(value,.9)
			, lo50 = quantile(value,.25)
			, hi50 = quantile(value,.75)
			, .groups = 'drop'
		)
		%>% ggplot()
		+ geom_line(aes(x=n,y=med,color=name))
		+ geom_linerange(aes(x=n,ymin=lo50,ymax=hi50,color=name),size=3,alpha=.5)
		+ geom_linerange(aes(x=n,ymin=lo80,ymax=hi80,color=name),size=1,alpha=.5)
		+ scale_y_log10(name='Time (s)')
		+ scale_x_log10(name= '# grid points in 1D GP')
		+ labs(color = 'Method')
		+ theme(legend.position = 'top')
	) -> p1
	(
		all_out
		%>% mutate(value = eqc/udx)
		%>% group_by(n)
		%>% summarize(
			med = median(value)
			, lo80 = quantile(value,.1)
			, hi80 = quantile(value,.9)
			, lo50 = quantile(value,.25)
			, hi50 = quantile(value,.75)
			, delta = max(delta)
			, .groups = 'drop'
		)
		%>% ggplot()
		+ geom_hline(yintercept = 1, linetype=3)
		+ geom_line(aes(x=n,y=med))
		+ geom_linerange(aes(x=n,ymin=lo50,ymax=hi50),size=3)
		+ geom_linerange(aes(x=n,ymin=lo80,ymax=hi80),size=1)
		# + geom_errorbar(aes(x=n,ymin=lo80,ymax=hi80,color=log(delta)),width=.1)
		# + geom_point(aes(x=n,y=med,color=log(delta)),size=3)
		# + scale_color_gradient(name='log(max(Δ))\n')
		+ scale_y_continuous(name='Time Ratio')
		+ scale_x_log10(name= '# grid points in 1D GP')
		+ theme(legend.position = 'top')
	) -> p2

	(
		all_out
		%>% mutate(
			value = (eqc+f_+model+tp)/(udx+f_+model+tp)
		)
		%>% group_by(n)
		%>% summarize(
			med = median(value)
			, lo80 = quantile(value,.1)
			, hi80 = quantile(value,.9)
			, lo50 = quantile(value,.25)
			, hi50 = quantile(value,.75)
			, delta = max(delta)
			, .groups = 'drop'
		)
		%>% ggplot()
		+ geom_hline(yintercept = 1, linetype=3)
		+ geom_line(aes(x=n,y=med))
		+ geom_linerange(aes(x=n,ymin=lo50,ymax=hi50),size=3)
		+ geom_linerange(aes(x=n,ymin=lo80,ymax=hi80),size=1)
		+ scale_y_continuous(name='Total (inc. rest of model) Time Ratio')
		+ scale_x_log10(name= '# grid points in 1D GP')
		+ theme(legend.position = 'top')
	) -> p3
	print(plot_grid(p1,NULL,p2,NULL,p3,nrow=1,rel_widths=c(5,1,5,1,5)))
	return(NULL)
}
f_tick = function(z){
	f(z)
	.pp$tick()
	return(z)
}

if(file.exists('all_out.rds')){
	all_out = readRDS('all_out.rds')
	do_plots()
}else{
	all_out = NULL
}
#all_out = NULL
(
	expand_grid(
		n = 2^8#2^(2:10)
		, iter = 1:1e2
	)
	%>% group_by(n,iter)
	%>% group_split()
	%>% initialize_purrr_progress()
	%>% walk(
		.f = f_tick
	)
	%>% finalize_purrr_progress()
)


pdf_file<-"pdf/maps_germany_choropleth_counties.pdf"
cairo_pdf(bg="grey98", pdf_file,width=8,height=9)

par(mai=c(0,0,0,0),omi=c(1,0.25,1,0.25),family="Lato Light",las=1)
library(maptools)
library(RColorBrewer)
library(gdata)

# Import data and prepare chart

x<-readShapeSpatial("myData/Geometrie_Wahlkreise_16DBT_VG1000.shp")
y<-read.csv(file="myData/struktbtwkr2005.csv",head=F,sep=";",dec=".")
myDistrict_structure_data<-subset(y,V2 > 0)
n<-length(x)
position<-vector()
for (i in 1:n){
	position[i]<-match(x$WKR_NR[i], myDistrict_structure_data$V2)
}
myColour_no<-cut(myDistrict_structure_data$V34[position],c(4,9,12.5,16.5,20,24,28))
levels(myColour_no)<-c("4 to 9 %","9 to 12.5 %","12.5 to 16.5 %","16.5 to 20 %","20 to 24 %","24 to 28 %")
myColours<-brewer.pal(6,"Oranges")

# Create chart

plot(x,col=myColours[myColour_no],border=grey(.8),lwd=.5)
legend("bottomright",levels(myColour_no),cex=0.95,border=F,bty="n",fill=myColours)

# Titling

mtext("Unemployed at electoral disctrict level 2005",3,line=1,adj=0,family="Lato Black",outer=T,cex=2)
mtext("Source (map geometry and data): www.bundeswahlleiter.de",1,line=2.6,adj=0,cex=0.95,font=3,outer=T)
dev.off()