#!/usr/bin/Rscript

require(stats) # for lowess, rpois, rnorm

x11()

plot(cars)
lines(lowess(cars))

cat("Press Enter to continue...")
invisible(scan("stdin", character(), nlines = 1, quiet = TRUE))

plot(sin, -pi, 2*pi) # see ?plot.function

cat("Press Enter to continue...")
invisible(scan("stdin", character(), nlines = 1, quiet = TRUE))

## Discrete Distribution Plot:
plot(table(rpois(100, 5)), type = "h", col = "red", lwd = 10,
     main = "rpois(100, lambda = 5)")

cat("Press Enter to continue...")
invisible(scan("stdin", character(), nlines = 1, quiet = TRUE))

## Simple quantiles/ECDF, see ecdf() {library(stats)} for a better one:
plot(x <- sort(rnorm(47)), type = "s", main = "plot(x, type = \"s\")")
points(x, cex = .5, col = "dark red")

cat("Press Enter to continue...")
invisible(scan("stdin", character(), nlines = 1, quiet = TRUE))

# while(names(dev.cur()) !='null device') Sys.sleep(1)


# Selection by comparison

# Poker and roulette winnings from Monday to Friday:
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Which days did you make money on poker?
selection_vector <- c(poker_vector) > 0

# Print out selection_vector - returns TRUE and FALSE values for each element reviewed
selection_vector

# Select from poker_vector these days - only select the elements that match
poker_winning_days <- poker_vector[selection_vector]

# Which days did you make money on roulette?
selection_vector <- roulette_vector > 0

# Select from roulette_vector these days
roulette_winning_days <- roulette_vector[selection_vector]


source("svmRegresja.r")
source("glmRegresja.r")
source("lmRegresja.r")

svm_regression_mtCars() #pokaż RMSE dla regresji SVM na mtcars
svm_regression_imports() #pokaż RMSE dla regresji SVM na imports
svm_regression_machine() #pokaż RMSE dla regresji SVM na machines
svm_regression_energy() #pokaż RMSE dla regresji SVM na Energy efficiency

glm_regression_mtCars() #pokaż RMSE dla regresji GLM na mtcars
glm_regression_imports() #pokaż RMSE dla regresji GLM na imports
glm_regression_machine() #pokaż RMSE dla regresji GLM na machines
glm_regression_energy() #pokaż RMSE dla regresji GLM na Energy efficiency

lm_regression_mtCars() #pokaż RMSE dla regresji LM na mtcars
lm_regression_imports() #pokaż RMSE dla regresji LM na imports
lm_regression_machine() #pokaż RMSE dla regresji LM na machines
lm_regression_energy() #pokaż RMSE dla regresji LM na Energy efficiency


library(dplyr)
library(knitr)

get_summary_information <- function() {
  df_facility <- read.csv("data/Mental Health Facilities.csv")
  df_countries <- read.csv("data/suicide-rates-overview-1985-to-2016.csv")

  matches <- df_facility %>%
    select(Country, Year)

  df_countries_filtered <- df_countries %>%
    filter(year %in% matches$Year) %>%
    filter(country %in% matches$Country) %>%
    group_by(country) %>%
    filter(year == max(year)) %>%
    summarise(
      "Gpd per capita" = mean(gdp_per_capita....),
      "Number of suicides (per 100k population)" = sum(suicides.100k.pop)
    )

  df_facility_filtered <- df_facility %>%
    filter(Country %in% df_countries_filtered$country) %>%
    group_by(Country) %>%
    summarise(
      "total avalibility per 100k population" =
        sum(Mental.hospitals..per.100.000.population.,
        Mental.health.units.in.general.hospitals..per.100.000.population.,
        Mental.health.outpatient.facilities..per.100.000.population.,
        Mental.health.day.treatment.facilities..per.100.000.population.,
        Community.residential.facilities..per.100.000.population.,
        na.rm = TRUE
      )
    )

  df_summary <- df_countries_filtered %>%
    mutate(
      "Mental Health Facility Avaliable(per 100k population)" =
        df_facility_filtered$"total avalibility per 100k population"
    ) %>%
    arrange(`Number of suicides (per 100k population)`)

  result <- kable(df_summary)

  return(result)
}


library(psych)
library(arsenal)
library(ggplot2)
library(data.table)

### GLOBAL VARIABLES
num_fac = 9

# this.dir<- dirname(parent.frame(2)$ofile)
# parent.dir <- strsplit(this.dir,'scripts')[[1]]
# setwd(parent.dir)

orig_var_order <- read.csv('efa/variable_order_mplus.csv')[,2]
city_names <- read.csv('data/urbandata2019-64var-citynames-countries.csv')[,1:2]

## LOADINGS || DATA || FACTOR CORRELATION
loading <- read.csv(paste0('efa/',num_fac,'f-loadings-missing-sig.csv'),header=FALSE)
data_scaled <-read.table('data/urbandata2019-64var-id-sorted-updated.dat')
#NOTE: Full-information maximum likelihood was used to estimate the factor model and obtain loadings
#But the mean-imputed dataset is used to compute the factor scores from these loadings as starting point for the iteration

## DATA
## Missingness
dm <-read.table('data/urbandata2019-64var-id-sorted-updated-missing.dat')
dm[dm=="."]<-NA
missrate <- as.numeric(table(is.na(dm))[2])/sum(table(is.na(dm)))*100
print(paste0("Percent missingness in data: ", round(missrate,2)))

## Support for factor choice (Figure 1 in paper)
datacor = cor(as.matrix(sapply(dm, as.numeric)),use="pairwise.complete.obs")
eigval = eigen(datacor)$values
ablinecolor <- rgb(31, 120, 180, alpha=255,maxColorValue = 255)
plot(c(1:64),eigval[1:64],xlab="Index",ylab="Eigenvalue",color='k',pch=19,xlim=c(0,64))
#axis(1, at = 0:64)
abline(v=9, col=ablinecolor)
rectcolor <- rgb(166, 206, 227, alpha=90,maxColorValue = 255)
rect(8, -2, 12, 17,border=NA,col=rectcolor)

getScore <- function(df, load, factor_cor=NULL){
  if(num_fac==8){colnames(load) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8")}
  if(num_fac==9){colnames(load) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9")}
  if(num_fac==11){colnames(load) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9","F10","F11")}
  print(head(load))
  load <- as.matrix(load[,-1])
  load <- cbind(load, as.matrix(orig_var_order))
  load_sorted <- load[order(load[,num_fac+1]),]
  load_sorted <- load_sorted[,1:num_fac]
  print("Loading:")
  print(head(load_sorted))
  if (is.null(factor_cor)){
    tf = factor.scores(data.matrix(df),load_sorted,method='components')
    }else{
    tf = factor.scores(data.matrix(df),load_sorted, factor_cor,method='components')
  }
  print("Scores")
  xform = tf$scores
  xform = xform[]
  xform = data.frame(xform)
  xform$city = city_names$City
  xform$cityID = city_names$cityID
  print(head(xform))
  write.csv(xform,'output/fscores-mean-imputed.csv',row.names=FALSE)
  return(xform)
}

scores <- getScore(data_scaled,loading)

viewLoadings <- function(df, n) {
  df2 <- melt(df, id="Variables", variable.name="Factors", value.name="Loading", measure = colnames(df)[1:n+1])
  print(head(df2))
  xd <- ggplot(df2, aes(Variables, abs(Loading), fill=Loading)) + facet_wrap(~ Factors, nrow=1) + geom_bar(stat="identity")+ coord_flip()+
    scale_fill_gradient2(name="Loading",high="blue",mid="white",low="red",midpoint=0,guide=F)+ylab("Loading")+theme_bw(base_size=10)
  ggsave(paste0("output/", "loadings-", nrow(df),"-variables-", n,"-factors.pdf"), xd, width=18, height=15)
}

if(num_fac==8){colnames(loading) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8")}
if(num_fac==9){colnames(loading) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9")}
if(num_fac==11){colnames(loading) = c("Variables", "F1", "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9","F10","F11")}

loading$Variables <- factor(loading$Variables, levels=loading$Variables[c(1:64)])
viewLoadings(loading,num_fac)

## Loading stats
colMeans(loading[,-1])
apply(loading[,-1], 2, function(x) max(x, na.rm = TRUE))
apply(loading[,-1], 2, function(x) sd(x, na.rm = TRUE))


randPars <- function() {
  pars <- iniPars()
  ubp <- ubPars()
  lbp <- lbPars()
  for (j in 1:length(pars)) {
    m <- pars[j]
    s <- (ubp[j] - lbp[j]) / 6
    x <- rnorm(1, mean=m, sd=s)
    while ( !(x >= lbp[j] && x <= ubp[j])) {
      x <- rnorm(1, mean=m, sd=s)
    }
    pars[j] <- x
  }
  pars
}


library(ggplot2)
library(gridExtra)
library(MASS)
library(grDevices)
library(cowplot)
library(gridGraphics)

#############################
# 1. Confidence band plots
#############################

setwd("Enrichment-Inference-Supplemental-Materials\\simulation_files\\final_figure")
source("cp_bands_plots.r")
source("convenience.r")
load("cp_bands_all_dist.rdata")
cp_plot_res1 <- cp_band_plot(increment = c("Case 1", "Case 2", "Case 3", "Case 4", "Case 5"), axis.ylim = c(.15, .15), nox = 1)

#############################
# 2. Difference confidence band plots
#############################
source("cp_diff_bands_plots.r")

fn.v <- c("cp_diff_bands_binorm_nocorr.rdata", "cp_diff_bands_binorm_corr.rdata", "cp_diff_bands_bibeta_nocorr.rdata", "cp_diff_bands_bibeta_corr.rdata")
m.ls <- c()
k.true.ls <- list()
dist.v <- c("binorm", "binorm", "bibeta", "bibeta")
for(idx in seq_along(fn.v)) {
  print(fn.v[idx])

  load(fn.v[idx])

  m = 150000
  pi.0.true = 1/500
  params <- k.ls[[1]][[1]]$params
  r <- k.ls[[1]][[1]]$r
  dist <- dist.v[idx]
  k.diff.true <- computeTrueKDiff()

  k.true.ls <- c(k.true.ls, rep(list(k.diff.true), 6))

  tmp.ls <- c(k.ls[[1]][1:3], k.c.ls[[1]][1:3])
  tmp.ls <- tmp.ls[c(1,4,2,5,3,6)]
  m.ls <- c(m.ls, tmp.ls)
}

cp_plot_res2 <- cp_band_plot(m.ls, increment = c("Case 1", "Case 2", "Case 3", "Case 4"), axis.ylim = c(.15, .15), nox = 1)

pdf("simulation_plot2.pdf", height = 9, width = 7)
plot_grid(cp_plot_res1[[1]], cp_plot_res2[[1]], cp_plot_res1[[2]],  ncol = 1, rel_heights = c( .9, .9, .2))
dev.off()


# Dexter Barrows
#
# IF2 parametric bootstrapping function

library(foreach)
library(parallel)
library(doParallel)
library(Rcpp)

if2_sirs_paraboot <- function(if2data_parent, T, Tlim, steps, N, nTrials, if2file, stoc_sir_file, NP, nPasses, coolrate) {

	source(stoc_sir_file)
	#print(stoc_sir_file)

	if(nTrials < 2) {
		nTrials <- 2
	}

	# unpack if2 first fit data
	# ...parameters
	paramdata_parent <- data.frame( if2data_parent$paramdata )
	names(paramdata_parent) <- c("R0", "r", "re", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")
	parmeans_parent <- colMeans(paramdata_parent)
	names(parmeans_parent) <- c("R0", "r", "re", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")
	# ...states
	statedata_parent <- data.frame( if2data_parent$statedata )
	names(statedata_parent) <- c("S","I","R","B")
	statemeans_parent <- colMeans(statedata_parent)
	names(statemeans_parent) <- c("S","I","R","B")

	#print(1:nTrials)

	## use parametric bootstrapping to generate forcasts
	##
	trajectories <- foreach( i = 1:nTrials, .combine = rbind, .packages = "Rcpp") %dopar% {

		source(stoc_sir_file)

		## draw new data
		##

		pars <- with( as.list(parmeans_parent),
		              c(R0 = R0,
	          			r = r,
	          			re = re,
	          			N = N,
	          			eta = eta,
	          			berr = berr) )

		init_cond <- with( as.list(parmeans_parent),
		                   c(S = Sinit,
	                   		 I = Iinit,
	                   		 R = Rinit) )

		# generate trajectory
		sdeout <- StocSIRS(init_cond, pars, Tlim + 1, steps)
		colnames(sdeout) <- c('S','I','R','B')

		# add noise
		counts_raw <- sdeout[,'I'] + rnorm(dim(sdeout)[1], 0, parmeans_parent[['sigma']])
	    counts     <- ifelse(counts_raw < 0, 0, counts_raw)

	    ## refit using new data
	    ##

	    rm(if2) # because stupid things get done in packages
	    sourceCpp(if2file)
	    if2time <- system.time( if2data <- if2_sirs(counts, Tlim+1, N, NP, nPasses, coolrate) )

	    paramdata <- data.frame( if2data$paramdata )
		names(paramdata) <- c("R0", "r", "re", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")
		parmeans <- colMeans(paramdata)
		names(parmeans) <- c("R0", "r", "re", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

		## generate the rest of the trajectory
		##

		# pack new parameter estimates
		pars <- with( 	as.list(parmeans),
		              c(R0 = R0,
	          			r = r,
	          			re = re,
	          			N = N,
	          			eta = eta,
	          			berr = berr) )
		init_cond <- c(S = statemeans_parent[['S']],
	                   I = statemeans_parent[['I']],
	                   R = statemeans_parent[['R']])

		# generate remaining trajectory part
		sdeout_future <- StocSIRS(init_cond, pars, T-Tlim, steps)
		colnames(sdeout_future) <- c('S','I','R','B')

		return ( c( counts = unname(sdeout_future[,'I']),
		       	    parmeans,
		       	    time = if2time[['user.self']]) )

	}

	return(trajectories)

}


# nCoV Transmission;
# Transmission analysis with linking kernel;
# Global Setting
setwd("C:\\Users\\holin\\Desktop\\Transmission Dynamics Team Work\\nCoV_GA\\nCoV_GA\\v6\\")

ver <- "v6"
main_dir <- paste("~/stat/nCoV_GA/",sep="")
dat_dir <- paste("~/stat/nCoV_GA/","data/",sep="")
mcmc_dir <- paste("./",sep="")

# define type matrix
source(paste(mcmc_dir,ver,'.type.r',sep=""))
#likelihood function
source(paste(mcmc_dir,ver,'.likelihood.r',sep=""))
# mcmc function
source(paste(mcmc_dir,ver,'.mcmc.r',sep=""))
#select counties; value range from 1-19;
ind.county <- 7
#read data
source(paste(mcmc_dir,ver,'.data.r',sep=""))

# initialize everything
source(paste(mcmc_dir,ver,'.initial.r',sep=""))
source(paste(mcmc_dir,ver,'.initial2.r',sep=""))

sigp <- 0.15

# set a timer;
ptm <- proc.time()
# Iterations
iterskip <- 1
burn <- 500; thin <- 10;
numiter <- 600;
cat("Generating samples...\n");
gentimes(numiter)

# running time;
runtime <- proc.time() - ptm
runtime/3600

# Post processing MCMC
source(paste(mcmc_dir,ver,'.post.r',sep=""))
out.data <- list(pmpmat, unitdata, timedata, time, counties)
save(out.data,file = paste("./output/pmpmat",ind.county,".rda",sep=""))

# Graph output
source(paste(mcmc_dir,ver,'.output.r',sep=""))

#not using the right censor correction;
#source(paste(mcmc_dir,ver,'.right.censor.r',sep=""))


context("Cluster Assign Mode Tests")

test_that("Test Cluster Assignments", {
  set.seed(1)
  n<-200 ## generate from clustered, skewed, data distribution
  d <- data.frame(y = rnorm(n), x = rnorm(n))
  d$y[1:30] <- 0

  res <- ZDPMix(d_train = d, formula = y ~ x, burnin=10, iter=50)

  train_clus <- cluster_assign_mode(res$cluster_inds$train)

  expect_equal( dim(train_clus$adjmat), c(n, n)  )
  expect_length( train_clus$class_mem,  n)
})


#Code to correlate each sample's number of unique HLA alleles with their neoantigen depletion values
#Query at the top counts each patient's total number of HLA loci from the analysis.neoantigens_by_aliquot table
#First correlation: All samples (reported in manuscript)
#Second correlation: initial only samples
#Third correlation: recurrent only samples
#-----------------------------------------------------

library(DBI)
library(odbc)
library(ggplot2)
library(reshape)

rm(list=ls())

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q = "WITH hla_table AS
(
	SELECT aliquot_barcode, hla_allele
	FROM analysis.neoantigens_by_aliquot
	GROUP BY aliquot_barcode, hla_allele
),
hla_tot AS
(
	SELECT aliquot_barcode, COUNT(*) AS hla_num
	FROM hla_table
	GROUP BY aliquot_barcode
)

SELECT nd.*,hla.hla_num
FROM analysis.neoantigen_depletion nd
INNER JOIN hla_tot hla ON hla.aliquot_barcode = nd.aliquot_barcode
ORDER BY rneo"

res <- dbGetQuery(con,q)

res[,"hla_num"] <- as.numeric(res[,"hla_num"])

cor.test(res[,"rneo"],res[,"hla_num"],method="s")		#R = 0.29	P = 2.1e-9

pri <- res[grep("-TP-",res[,1]),]
rec <- res[grep("-R1-|-R2-|-R3-|-R4-",res[,1]),]

cor.test(pri[,"rneo"],pri[,"hla_num"],method="s")		#R = 0.23	P = 5e-4
cor.test(rec[,"rneo"],rec[,"hla_num"],method="s")		#R = 0.32	P = 5.6-7


set.seed(1234)
n=1000

## snp score data

id = 1:n
score <- rnorm(n, 0, 1);
score = score[order(score)]
datax  = cbind.data.frame(id, score)
colnames(datax)[1] <- "userId"
colnames(datax)[2] <- "exposure"

write.table(datax, file='data/exposure.csv', sep=',', col.names=TRUE, row.names=FALSE);

##### phenotype data

## age
age <- 2*score + rnorm(n, 60, 10);
sex = round(runif(n, 0, 1));
genoBatch = round(rnorm(n, 0, 1))

data  = cbind.data.frame(id, age, sex, genoBatch);

colnames(data)[1] <- "userId"
colnames(data)[2] <- "x21022_0_0"
colnames(data)[3] <- "x31_0_0"
colnames(data)[4] <- "x22000_0_0"

######
###### continuous data fields

## x1 - continuous main path through inverse rank normal transformation, N=1000
## Expected result: association ~ 2
cont1 <- 2*score + 20 + rnorm(n, 0.0, 0.2)

## x2 - continuous main path but removed because < 500 examples SKIPPED
cont2 = cont1
cont2[0:800] = NA

## x3 - continuous - a value has > 20% of the examples that are not NA, so treated as categorical ordinal, N=1000
cont3 = c(rep(0, 400), score[401:1000]+round(rnorm(600, 0, 1)))

## x4 - continuous - a value has > 20% of the examples that are not NA, so treated as categorical ordinal, but < 500 examples SKIPPED
cont4 = c(rep(NA,800), rep(0, 100), round(5+5*rnorm(100, 0, 1)))

## x5 - continuous - only two numbers so we treat as binary, N=(120/380)500
cont5 = c(rep(NA,500), rep(0, 100), rep(1, 400))
randidx = sample(501:600, 10)
cont5[randidx] = 1
randidx = sample(601:1000, 30)
cont5[randidx] = 0

## x6 - continuous - only two numbers so we treat as binary but one has < 10 examples SKIPPED
cont6 = c(rep(NA,800), rep(0, 5), rep(1, 195))

data  = cbind.data.frame(data, cont1, cont2, cont3, cont4, cont5, cont6);

colnames(data)[5] <- "x1_0_0"
colnames(data)[6] <- "x2_0_0"
colnames(data)[7] <- "x3_0_0"
colnames(data)[8] <- "x4_0_0"
colnames(data)[9] <- "x5_0_0"
colnames(data)[10] <- "x6_0_0"

######
###### integer data fields

## integer x21 - >20 values, treat as continuous, tested with N=900
int1 = c(rep(NA,100),cut(score[101:1000]*10 + rnorm(900, 0, 1), 20))
if(length(unique(na.omit(int1)))!=20) stop("Not 20");

## integer x22 - 2 distinct values with one having less than 10 examples = only one value SKIPPED
int2 = c(rep(NA,100),rep(0,891), rep(1,9));

## integer x23 - 2 distinct values = binary, N=800/100(900)
int3 = c(rep(NA,100),rep(0,800), rep(1,100));
int3[sample(101:900, 30)] = 1
int3[sample(901:1000, 30)] = 0

## integer x24 - 3 distinct values but one <10 examples = binary, N=760/131(891)
int4 = c(rep(NA,100),rep(0,800), rep(1,9), rep(2,91));
int4[sample(101:900, 50)] = 2
int4[sample(909:1000, 10)] = 0

## integer x25 - 3 distinct values = ordered cat, N=900
int5 = c(rep(NA,100), rep(0, 500), rep(1, 200), rep(2, 200))
int5[sample(101:600, 10)] = 1
int5[sample(101:600, 10)] = 2
int5[sample(601:800, 10)] = 0
int5[sample(601:800, 10)] = 2
int5[sample(801:1000, 10)] = 0
int5[sample(801:1000, 10)] = 1

## integer x26 - 3 distinct values = ordered cat with one having less than 10 examples, N=(600/291)891 = binary
int6 = c(rep(NA,100),rep(0,600), rep(1,291), rep(2,9))
int6[sample(101:700, 50)] = 1
int6[sample(701:991, 50)] = 0

## integer x27 - 19 distinct values = ordered cat, N=891 (9 are removed because <10 in some categories)
int7 = c(rep(NA,100),cut(score[101:1000], 19))
int7[sample(101:1000, 50)] = 1
int7[sample(101:1000, 50)] = 2
int7[101:1000] = int7[101:1000]+10

if(length(unique(na.omit(int7)))!=19) stop("Not 19");

data  = cbind.data.frame(data, int1, int2, int3, int4, int5, int6, int7);
#data  = cbind.data.frame(data, int1, int2, int3, int4, int5)

colnames(data)[11] <- "x21_0_0"
colnames(data)[12] <- "x22_0_0"
colnames(data)[13] <- "x23_0_0"
colnames(data)[14] <- "x24_0_0"
colnames(data)[15] <- "x25_0_0"
colnames(data)[16] <- "x26_0_0"
colnames(data)[17] <- "x27_0_0"

######
###### categorical single data fields

## x32 - binary but one value < 10 = only one value SKIPPED
cats1 = c(rep(NA,100),rep(0,891),rep(1,9));

## x33 - binary but 499 < 500 examples SKIPPED
cats2 = c(rep(NA,501),rep(0,300),rep(1,199));

## x34 - binary success, N=300/600(900)
cats3 = c(rep(NA,100),rep(0,300),rep(1,600));
cats3[sample(101:400, 50)] = 1
cats3[sample(401:1000, 50)] = 0

## x35 - cat ord but 499 < 500 examples SKIPPED
cats4 = c(rep(NA,501),rep(0,300),rep(1,100),rep(2,99));

## x36 - cat ord success, N=889 (11 removed because <10 examples)
cats5 = c(rep(NA,100), 10+5*round(score[101:1000]) + round(runif(900, 0, 5)))

## x37 - cat not-ord but 499 < 500 examples SKIPPED
cats6 = c(rep(NA,501),rep(0,300),rep(1,100),rep(2,99));

## x38 - cat not-ord success, reference=4, N=750
cats7 = c(rep(NA,250),rep(0,50), rep(1,200), rep(4,300), rep(9,200));
cats7[sample(301:500, 50)] = 4
cats7[sample(501:800, 50)] = 1
cats7[sample(251:300, 10)] = 9
cats7[sample(801:1000, 10)] = 0

## x39 - same as 38 but default value set in variable information file
## the first 250 of field cats8 are NA and have a value in field 99 so these are set to the default value 100
cats8 = cats7

data  = cbind.data.frame(data, cats1, cats2, cats3, cats4, cats5, cats6, cats7, cats8);

# 31 is the variable number for sex so we don't use it in this dataset
colnames(data)[18] <- "x32_0_0"
colnames(data)[19] <- "x33_0_0"
colnames(data)[20] <- "x34_0_0"
colnames(data)[21] <- "x35_0_0"
colnames(data)[22] <- "x36_0_0"
colnames(data)[23] <- "x37_0_0"
colnames(data)[24] <- "x38_0_0"
colnames(data)[25] <- "x39_0_0"

######
###### categorical multiple data fields

## 14 people with A1, 470 people NA, 516 people with some value not A1
## 35 people with A2, 470 people NA, 495 people with some value not A2
## 505 people with A3, 670 people NA, 25 people with some value not A3

## cat multiple with 3 arrays
catm1_0_0 = c(rep("A1", 5), rep("A2", 25), rep("A3", 495), rep("",370), rep(NA,100), rep("A1", 5));
catm1_0_1 = c(rep("A2", 5), rep("A1", 4), rep(NA,986), rep("A2", 5));
catm1_0_2 = c(rep("A3",5), rep(NA,990), rep("A3",5));

## var 99 determines who is in sample for var 43 (N=510)
var99 = c(rep(1,30), rep("ZZ",495), rep(NA,465),rep(2,10));

#### 14 people with A1, 516 people with some value not A1 + 5 with no A1 value but having var99 value: binary variable TRUE=14,FALSE=521
#### 35 people with A2, 495 people with some value not A2 + 5 with no A2 value but having var99 value: binary variable TRUE=35,FALSE=500
#### 505 people with A3, 25 people with some value not A3 + 5 with no A3 value but having var99 value: binary variable TRUE=505,FALSE=30

## 3 different versions of catm1 field to test 3 different ways of treating categorical multiple fields
data  = cbind.data.frame(data, catm1_0_0, catm1_0_1, catm1_0_2, catm1_0_0, catm1_0_1, catm1_0_2, catm1_0_0, catm1_0_1, catm1_0_2, catm1_0_0, catm1_0_1, catm1_0_2, var99)

colnames(data)[26] <- "x41_0_0"
colnames(data)[27] <- "x41_0_1"
colnames(data)[28] <- "x41_0_2"
colnames(data)[29] <- "x42_0_0"
colnames(data)[30] <- "x42_0_1"
colnames(data)[31] <- "x42_0_2"
colnames(data)[32] <- "x43_0_0"
colnames(data)[33] <- "x43_0_1"
colnames(data)[34] <- "x43_0_2"
colnames(data)[35] <- "x44_0_0"
colnames(data)[36] <- "x44_1_0"
colnames(data)[37] <- "x44_2_0"
colnames(data)[38] <- "x99_0_0"

write.table(data, file='data/phenotypes.csv', sep=',', col.names=TRUE, row.names=FALSE, quote=TRUE, na="");


# fuzzyclust.r
#
# usage =  R --file fuzzyclust.r --args fname_data k membexp runs outdir forceflag maxattempts alpha
#
# Created:  04/17/17 by Don Hagler
# Last Mod: 04/18/17 by Don Hagler
#
# use version R2.10
#
# Based on code by Chi-Hua Chen
#

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

library(MCMCpack) # needs this library to run!  run install.packages
library(cluster)

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

opts = commandArgs(trailingOnly = TRUE);

fname_data = 'distmat.txt'
k = 2
membexp = 1.27
runs = 1
outdir = getwd()
forceflag = FALSE
maxattempts = 5
alpha = 1 # concentration parameter for Dirichlet distribution

if (length(opts)>0) {
  fname_data = opts[1]
}
if (length(opts)>1) {
  k = as.numeric(opts[2])
}
if (length(opts)>2) {
  membexp = as.numeric(opts[3])
}
if (length(opts)>3) {
  runs = as.numeric(opts[4])
}
if (length(opts)>4) {
  outdir = opts[5]
}
if (length(opts)>5) {
  forceflag = as.logical(opts[6])
}
if (length(opts)>6) {
  maxattempts = as.numeric(opts[7])
}
if (length(opts)>7) {
  alpha = as.numeric(opts[8])
}

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

print(sprintf("loading data from %s...",fname_data))
disttab = read.table(fname_data)
distmat = as.dist(disttab)
dm = dim(disttab)
n = dm[1]

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

dir.create(outdir,showWarnings=FALSE,recursive=TRUE)

outstem = sprintf("clust%d_membexp%0.2f_runs%d",k,membexp,runs)
fname_clust = sprintf("%s/%s_clusters.txt",outdir,outstem)
fname_silh = sprintf("%s/%s_silhouette.txt",outdir,outstem)

if (!file.exists(fname_clust) || !file.exists(fname_silh) || forceflag) {
  print(paste("running fuzzy clusters for",k,"..."))
  p = matrix(0, n, k)
  obj = matrix(0,1,runs) # container for objective function values
  alphavec = rep(alpha,k) # concentration parameter for Dirichlet distribution
  f = list(); # temporarily contains all the solutions produced by fanny for a certain k
  converged_once = FALSE
  for (j in 1:runs) {
    converged = FALSE
    nattempts = 0
    while (converged==FALSE) {
      print(paste("cluster=",k,"run=",j,sep=" "))
      for (i in 1:n) {
        p[i,] = rdirichlet(1, alphavec)
      }
      f[[j]] = fanny(distmat, k, memb.exp = membexp, iniMem.p = p)
      obj[j] = f[[j]][["objective"]][["objective"]] # extract objective function value for each run
      converged = f[[j]][["convergence"]][["converged"]]
      if (converged==FALSE) {
        nattempts = nattempts + 1
        if (nattempts>=maxattempts) {
          print(sprintf('WARNING: failed to converge after %d attempts, quitting.',nattempts))
          break
        }
        print("failed to converge, retrying...")
      } else {
        converged_once = TRUE
      }
    }
  }
  if (converged_once==TRUE) {
    q = which(obj == min(obj), arr.ind = TRUE) # find index of minimum of the objective function
    q = q[2]
    mean_obj = apply(obj,1,mean)
    stdev_obj = apply(obj,1,sd)
    membership = f[[q]][["membership"]]
    silhouette = f[[q]][["silinfo"]]$avg.width
    write.table(membership,fname_clust)
    write(silhouette, file = fname_silh, append = FALSE, sep = " ")
  }
}

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

#quit("no",1,FALSE)


library(copent)
library(ggplot2)

adult = read.csv("https://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.data",header = FALSE, col.names = c("age","workclass","fnlwgt","edu","edunum","marital","occupation","relationship","race","sex","capital-gain","capital-loss","hpw","native","income"),sep = ",", strip.white = TRUE)

income = 0
income[which(adult$income=="<=50K")] = 1
income[which(adult$income==">50K")] = 2
sex = 0
sex[which(adult$sex=="Male")] = 1
sex[which(adult$sex=="Female")] = 2

x11(width = 10, height = 5)
ggplot(adult, aes(x = edunum, color = sex)) + geom_density(alpha = 0.6) + xlab("Education")

k = 50
n = 500 # number of the used samples
ci1 = 0 # ci btw income, education given sex
ci2 = 0 # ci btw income, sex given education
for (i in 1:k){
  i1 = income[1:n] + 0.000001 * runif(n)
  s1 = sex[1:n] + 0.000001 * runif(n)
  edu1 = adult$edunum[1:n] + 0.000001 * runif(n)
  ci1 = ci1 + ci(i1,edu1,s1)
  ci2 = ci2 + ci(i1,s1,edu1)
}
ci = c(ci1,ci2)
ci = ci / k

x11()
names(ci) = c("Sex2Edu","Edu2Sex")
min1 = min(ci)
if (min1 > 0) {min1 = 0.003}
xci1 = barplot(ci, col = "grey", border = "grey", ylab = "CI", ylim = c(min1-0.003, max(ci)+0.003))
text(cex = 1, x = xci1, y = ci+ sign(ci) * 0.0015, labels = round(ci,digits = 4), col = "red")


# P-value analysis for AR(1) model
# We are mainly interested here in the distribution of p-values
# in case of drift an LR test. The key question is whether the distribution
# is uniform.

# Helper function for correlated errors ----
xy.errors <- function(n = 1000, mu = rep(1032, 2L), Sigma = matrix(c(23, 20, 20, 23), ncol = 2)) {
  as.list(data.frame(
    MASS::mvrnorm(n, mu = c('x' = mu[1], 'y' = mu[2]), Sigma = Sigma)
  ))
}

lin.sig <- function(z, dfdiff) {

  n <- length(z)

  seekmin <- function(M0, bps, xreg = NULL) {
    for (bp in bps) {
      bptrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
      reg <- if (!is.null(xreg)) cbind(xreg, bptrend) else cbind(bptrend)
      .M <- lm(z ~ reg - 1)
      .M[['xreg']] <- reg
      .M[['bp']] <- bp
      if (logLik(.M) > logLik(M0)) M0 <- .M
    }
    M0
  }

  bps.local <- function(M) {
    unique(c(max(1L, M$bp - 2*sidays):M$bp, M$bp:min(M$bp + 2*sidays, length(z) - 1)))
  }

  # Regressor definitions
  trend <- 1:n
  sidays <- as.integer(sqrt(n)) # first sweep seek interval in days
  bps <- which(!duplicated((trend[-length(trend)] - trend[1L]) %/% (sidays))) # breakpoints for fitting

  M0 <- lm(z ~ -1)

  M1 <- seekmin(M0 = M0, bps = bps)
  M1 <- seekmin(M1, bps = bps.local(M1))

  gwloggeR:::lrtest(logLik(M0), logLik(M1), df.diff = dfdiff)
}

# AR(1) model: intecept (OK) ----
set.seed(2020)
list2env(xy.errors(n = 1000, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
x <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = x)
y <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = y)
plot(x - y, type = 'l')
forecast::auto.arima(x - y, stationary = TRUE, trace = TRUE)

p <- replicate(n = 1000, expr = {
  n <- 10000
  list2env(xy.errors(n = n, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = y)
  gwloggeR:::lrtest(
    logLik(arima(x - y, order = c(1, 0, 0), include.mean = FALSE)),
    logLik(arima(x - y, order = c(1, 0, 0))),
    df.diff = 1L
  )
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are distributed uniformly

# AR(1) model: drift (NOK) ----
set.seed(2020)
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1000, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1050, phi1 = 0.9, a = y)
  fit <- gwloggeR:::model_drifts.fit(
    x = x - y,
    timestamps = seq(as.POSIXct('2000-01-01'), by = '12 hours', length.out = n),
    ar1 = 0.9,
    dfdiff = 2.8
  )
  fit$drift.significance
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are not distributed uniformly under 2L df difference LR test.
# LR test df difference seems also to be dependent on number of observations (n).
# For 1000-10000 obs. a df difference of 2.8 seems to produce good results.

# AR(1) model: correlated + drift (NOK) ----
set.seed(2020)
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, mu = c(0,0)), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1000, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1050, phi1 = 0.9, a = y)
  fit <- gwloggeR:::model_drifts.fit(
    x = x - y,
    timestamps = seq(as.POSIXct('2000-01-01'), by = '12 hours', length.out = n),
    ar1 = 0.9,
    dfdiff = 2.8
  )
  fit$drift.significance
})
hist(p)
sum(p < 0.05)/length(p)
# Doesn't seem to be different from non-correlated AR(1) drift.

# Linear model: drift (NOK) ----
set.seed(2020)
list2env(xy.errors(Sigma = diag(c(5, 5))), envir = environment())
plot(x, y)
plot(x - y, type = 'l')

list2env(xy.errors(), envir = environment())
plot(x, y)
plot(x - y, type = 'l')

p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, Sigma = diag(c(5, 5))), envir = environment())
  lin.sig(z = x - y, dfdiff = 2.8)
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are not distributed uniformly under 2L df difference LR test.
# LR test df difference seems also to be dependent on number of observations (n).
# For 1000-10000 obs. a df difference of 2.8 seems to produce good results, just like in AR(1) case.

# Linear model: correlated + drift (NOK) ----
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n), envir = environment())
  lin.sig(z = x - y, dfdiff = 2.8)
})
hist(p)
sum(p < 0.05)/length(p)
# Doesn't seem to be different from non-correlated drift.


#Reproduction figure 6

library(ggplot2)
library(tidyr)
library(plyr)
library(ggplot2)
library(scales)

#input file is within this folder
time_exec <- read.table("Time_Execution_Methods_TT_plus_Linda.txt",header=T)
head(time_exec)
#names(time_exec)[8] <- "cov1mln.250k"
long_df <- time_exec
#long_df <- time_exec %>%  gather(coverage, time, cov50k:cov1mln.250k)
#long_df <- time_exec %>%  gather(coverage, time, Method)

head(long_df)
long_df$Time <- as.numeric(long_df$Time)
long_df$Coverage <- factor(long_df$Coverage, levels=c("50K", "100K", "250K", "500K", "750K", "1M", "1M250K"))
long_df$Read_Length <- factor(long_df$Read_Length, levels=c("25bp", "50bp", "75bp", "100bp"))
#now lets plot using the standatd deviation

#1) first create a function for this

data_summary <- function(data, varname, groupnames){
  require(plyr)
  summary_func <- function(x, col){
    c(mean = mean(x[[col]], na.rm=TRUE),
      sd = sd(x[[col]], na.rm=TRUE))
  }
  data_sum<-ddply(data, groupnames, .fun=summary_func,
                  varname)
  data_sum <- rename(data_sum, c("mean" = varname))
  return(data_sum)
}

#2) compute the standard deviation
long_df <- as.data.frame(long_df)
df2 <- data_summary(long_df, varname="Time",
                    groupnames=c("Coverage", "Method","Read_Length"))
#quality check
head(df2)

#3) plot the standard deviation and the median of each method
p <- ggplot(df2,aes(Coverage,Time,colour=Method,group=Read_Length))
pd<-position_dodge(.9)

p +   geom_errorbar(aes(ymin=Time-sd,ymax=Time+sd),width=.1,position=pd,colour="black") +
  geom_point(position=pd,size=4) + geom_line(position=pd) +
  theme_bw() +
  facet_grid(Method~Read_Length)+theme(axis.text.x=element_text(angle = 90, vjust = 0.5)) +
  scale_y_continuous(trans = log2_trans(),breaks = trans_breaks("log2", function(x) 2^x),labels = trans_format("log2", math_format(2^.x)))+
  scale_y_log10()+
  annotation_logticks()+
  ggtitle("")+ theme(plot.title = element_text(hjust = 0.5))+theme(text=element_text(size=15))+ xlab("Coverage") + ylab("Time (Seconds)")+
  theme(text=element_text(size=15))+theme(axis.text.x = element_text(face="bold", color="#000001")) + theme(axis.text.y = element_text(face="bold", color="#000001"))+theme(text = element_text(size = 18, face="bold"))+theme(axis.title.y = element_text(size = 18))+theme(legend.text = element_text(size = 18,face="plain"))+theme(legend.title = element_text(size = 18))

#p+axis.title=element_text(size=18,face="bold")+theme(plot.title = element_text(hjust = 0.5))+theme(axis.text=element_text(size=14),axis.title=element_text(size=14,face="bold"))+ggtitle("")+ xlab("") + ylab("Time (Seconds)") +


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

autoplot(austres)

prev = rwf(austres, h=12, drift = F)
autoplot(prev)

prev = rwf(austres, h=12, drift = T)
autoplot(prev)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/6.5.R Drift.r


bogo_sort <- function(a) {
  while(is.unsorted(a)) {
    a <- sample(a)
  }
  return(a)
}

test <- c(20, -3, 50, 1, -6, 59)

print("unsorted list")
print(test)

print("sorted list")
print(bogo_sort(test))


#' This function is used to estimate  the  different paramters of interest like the time varying transmission rates, proportion of reported cases and thebasic reproduction rates.
#'
#' @param N  (Mandatory) : The population size.
#' @param data (Mandatory) input :If the model is Multinomial then the data matrix should contain 3 columns namely Confirmed,Recovered and Death, while if the model is Poisson or Binomial, then the data should contain only one column namely Confirmed. Please see that the names of the colums are maintained.
#' @param data_init (Mandatory) This is the initial data values that should be provided by the user which is a six size length vector. The first entry should contain the Total Confirmed, Total Recovered ,Total Death , Daily Confirmed ,Daily Recovered and Daily Death for the Starting Date.If the starting total confirmed is 0 , please replace it by 1
#' @param init_pars = NULL( default) . Else the user can give a user input initial paramters which should consist of the initial values of the time varying beta , proportion of testing for the different periods.
#' @param niter = 1e5 (default)  No of iteration for the MCMC metropolis hasting algorithm.
#' @param BurnIn = 5e4 (default) This is the Burn-In Period for the MCMC algorithm
#' @param model = Multinomial(DEFAULT) This is the likelihood function that will be used. There are three options available namely Multinomial, Poisson and Binomial.
#' @param plot = TRUE(Default) This will give the box plot for the basic reproductuon number for the different periods.
#' @param auto.initialize = TRUE(default) This is the option for using a mle based initial parameter.
#' @param period_start The total time period is divided into small periods depending on the lockdowm measures imposed by the goverment. So this is a vector consisting of the start dates for the different time periods.
#' @param ... arguments passed to the function model_initializeR and model_plotR which is used for the initializing the parameters. The parameters are described below:
#'            \itemize{
#'                 \item{"step_pars"}{=init_pars/500 (default) . It is the variance of the proposal distribution for the Metropolis Hastings Algorithm which is assumed to be a Random Walk.
#'                 \item{"alpha_p"}{= 0.5 (default) It is defined as the ratio of rate of spread of infection by tested positive patients to that by false negatives. We have taken $\alpha_p < 1$ as patients who are tested positive are subjected to quarantine where the chance of spreading the disease is less than that of false negative patients who are mostly unaware of their infectious nature. So, false negative individuals continue to spread the disease freely at a higher rate than tested positive individuals. }
#'                 \item{"alpha_u"}{= 0.7 (default) It is defined as the  scaling factor for the rate of spread of infection by untested individuals. $\alpha_u$ is assumed to be < 1 as U mostly consists of asymptomatic or mildly symptomatic cases who are known to spread the disease at a much lower rate than those with higher levels of symptoms.}
#'                 \item{"beta_1 }{= 0.6 (default) . It is the scaling factor for rate of recovery  for untested individuals .  $\beta_1$ is  assumed to be less than 1.  The condition of Untested individuals is not so severe as they consists of mostly asymptomatic people. So, they are assumed to recover faster than the Current Positive Ones. }
#'                 \item{"beta_2"}{= 0.7 (default) . It is the inverse of the scaling factor for rate of recovery  for false negative individuals .  $\beta_2$ is assumed to be less than 1. It is assumed that the recovery rate is slower than the detected ones for the False Negative ones because they are not getting any hospital treatments. }
#'                 \item{"delta_1}{= 0.3 (default) It is the scaling factor for death rate for undetected individuals .  $\delta_1 $ is assumed to be less than 1. Similarly  for the Untested ones, the death rate is taken to be lesser because they are mostly asymptomatic. So, their probability of dying is much less.}
#'                 \item{"delta_2"}{= 0.7 (default). It is the inverse of  the scaling factor for death rate for false negative individuals . $\delta_2$ is assumed to be less than 1. Same as before, the death rate for False Negative ones are assumed to be higher than the Current detected Positive as they are not receiving proper treatment.}
#'                 \item{"lambda"}{=  1 / (66.26 * 365)(default) Natural birth  rate. The value given here as the default value is the world's common birth  rate.}
#'                 \item{"mu"}{=  1 / (66.26 * 365)(default) Natural  death rates. This is assumed to be equal with natural birth rate for the sake of simplicity.}
#'                 \item{"D_d"}{= 17.8 (default) Mean days till death for positive individuals.}
#'                 \item{"D_e"}{= 5.2 (default) Incubation period .}
#'                 \item{"Dr"}{= 17.8 (default) Mean days till recovery for positive individuals.}
#'                 \item{"f"}{=0.15 (default) False negative probability of RT-PCR test.}
#'                 \item{"mCFR"}{= NULL (It is calculated from the data  by default) It is defined as the ratio of the total reported deceased cases and the total removed cases  till that day.}
#'                 \item{"init.exposed.ratio "}{= 3 (default) This is the scaling factor for the calculation of the initial number of exposed people from the sum of the initial number of unreported, repoted people.}
#'                 \item{"init.confirmed.ratio"}{= 0.15 (default) This is the initial value of the probability of being tested.}
#'                 \item{"opt_num"}{= 100 (default) The number of times an user wants to run the mle optimization before deciding on the best initial parameter.}
#'                 \item{"trace_plot.common_axis"}{=FALSE(Default) This will give the trace plot for  the convergence of the mcmc estimated time varying parameters}
#'                 \item{"save plot"}{=TRUE (Default) It is the option for saving the plots in the directory folder.}
#'
#'                        }
#'
#'
#'
#' @return
#' @export
#'
#' @examples

model_estimateR <- function(data, data_init,N, init_pars = NULL, niter = 1e5, BurnIn = 5e3,
                            model = "Multinomial", plot = TRUE, period_start, end_beta, auto.initialize = TRUE,
                            ... ){
  library(dplyr)

  if(model == "Multinomial"){
    if(! all(c("Confirmed", "Recovered", "Deceased" ) %in% colnames(data))){
      stop("Data does not contain required columns")
    }
  } else if (model == "Poisson" || model == "Binomial"){
    if(! all(c("Confirmed") %in% colnames(data))){
    stop("Data does not contain required columns")
    }
  } else
    stop("Incorrect model specified")

  if(length(data_init) != 6) stop("Incorrect initial values: length must be 6")

  if(any(data < 0) || data_init < 0) stop("Negative values in data")

  var_init = model_initializeR(data = data, data_init = data_init, init_pars = init_pars, model = model, end_beta=end_beta,
                               period_start = period_start, auto.initialize = auto.initialize, ...)

  fix_pars = var_init$fix_pars
  init_state_num = var_init$init_state_num
  init_pars = var_init$init_pars
  period_start = var_init$period_start

  pars_estimate = mcmc_performR(data = data, init_state_num =  init_state_num, init_pars = init_pars, model = model,
                                niter = niter, BurnIn = BurnIn, fix_pars = fix_pars, period_start = period_start, ...)

  ## Plot

  if(plot == TRUE){
    plots <- model_plotR(mcmc_pars = pars_estimate, n_period = length(period_start), data = data,
                         data_initial = data_initial, call = "estimateR", model = model, ...)
    return(list(mcmc_pars = pars_estimate, "plots" = plots))
  }

  return(list(mcmc_pars = pars_estimate))
}


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

# = Example 4 - Transfer entropy on continuous data using Kraskov estimators =

# Simple transfer entropy (TE) calculation on continuous-valued data using the Kraskov-estimator TE calculator.

# Load the rJava library and start the JVM
library("rJava")
.jinit()

# Change location of jar to match yours:
#  IMPORTANT -- If using the default below, make sure you have set the working directory
#   in R (e.g. with setwd()) to the location of this file (i.e. demos/r) !!
.jaddClassPath("../../infodynamics.jar")

# Generate some random normalised data.
numObservations<-1000
covariance<-0.4
sourceArray<-rnorm(numObservations)
destArray = c(0, covariance*sourceArray[1:numObservations-1] + (1-covariance)*rnorm(numObservations-1, 0, 1))
sourceArray2<-rnorm(numObservations) # Uncorrelated source

# Create a TE calculator:
teCalc<-.jnew("infodynamics/measures/continuous/kraskov/TransferEntropyCalculatorKraskov")
.jcall(teCalc,"V","setProperty", "k", "4") # Use Kraskov parameter K=4 for 4 nearest points

# Perform calculation with correlated source:
.jcall(teCalc,"V","initialise", 1L) # Use history length 1 (Schreiber k=1)
.jcall(teCalc,"V","setObservations", sourceArray, destArray)
result <- .jcall(teCalc,"D","computeAverageLocalOfObservations")
# Note that the calculation is a random variable (because the generated
#  data is a set of random variables) - the result will be of the order
#  of what we expect, but not exactly equal to it; in fact, there will
#  be a large variance around it.
cat("TE result ",  result, "nats; expected to be close to ", log(1/(1-covariance^2)), " nats for these correlated Gaussians\n")

# Perform calculation with uncorrelated source:
.jcall(teCalc,"V","initialise") # Initialise leaving the parameters the same
.jcall(teCalc,"V","setObservations", sourceArray2, destArray)
result2 <- .jcall(teCalc,"D","computeAverageLocalOfObservations")
cat("TE result ",  result2, "nats; expected to be close to 0 nats for uncorrelated Gaussians\n")

# We can also compute the local TE values for the time-series samples here:
#  (See more about utility of local TE in the CA demos)
localTE <- .jcall(teCalc,"[D","computeLocalOfPreviousObservations")
cat("Notice that the mean of locals", sum(localTE)/(numObservations-1),
	"nats equals the above result\n")


rowSums(iris[,-5]) #row wise sum for col 1 to 4

R Community/R functions Assignments/Assignment2.r


---
  title: "Double Auction Experiment"
author: "Ryan McWay"
output:
  word_document: default
---
  ###**ECON663-Experimental Economics**
setwd("")
library("readxl")
sample <- read_excel("<raw>", sheet = "Data")
View(sample2)

#Supply and Demand
demand <- c(25:1)
supply1 <- sort(c(1:25,5,10,15,20,25))
supply2 <- sort(c(7:31,11,16,21,26,31))

#Regular Equilibrium
plot(supply1, type = "l",
     lwd = 2,
     main = "Anticipated Equilibrium for Periods 1 and 2",
     xlab = "Quantity",
     ylab = "Price")
par(new=T)
plot(demand, type = "l",
    lwd = 2,
    axes = F,
    ann = F)
mtext("(12,15)", at = 12)

#Equilibrium with Tax
plot(supply2, type = "l",
     lwd = 2,
     main = "Antcipated Equilibrium for Period 3 with Tax",
     xlab = "Quantity",
     ylab = "Price")
par(new=T)
plot(demand, type = "l",
     lwd = 2,
     axes = F,
     ann = F)
mtext("(15.5,10.5)", at = 12.5)

#T-Test for each period in order
t.test(sample$PriceP1, mu=12)
t.test(sample$PriceP2, mu=12)
t.test(sample$PriceP3, mu=15.5)

#Market Price over Period
plot(Transactions~Price1, Data = sample,
     type = "l",
     lty = 2,
     col = "Dark Green",
     main = "Price and Quantity for Period 1 and 2",
     ylab = "Bid/Ask Equilibrium Price (P)",
     xlab = "Transactions (Q)")
par(new=T)
plot(sort(sample$PriceP2),
     type = "l",
     lty = 2,
     col = "Red"
     )
par(new=T)
plot(sort(sample$PriceP3),
     type = "l",
     col = "Maroon",
     lty = 2,
     axes = F,
     ann = F
     )
mtext("Period1 = $9.75 | Period2 = $10.46 | Period3 = $13.25")


#'@title Return the two digit month for a each element of a given time series
#'
#'@description The function \code{time} in the \cr\code{stats} package returns the date in fractions.
#'             This function converts that value to the proper integer.
#'
#'@details Since yearly (4 digit only) time series have no month and since weeks can span months,
#'         this function is only supported for daily and monthly time series.
#'
#'@usage  tsMonth <- getMonth(tsData)
#'
#'@param tsData  A time series object.
#'
#'@return A vector of integers (representing months).
#'
#'@export

getTsMonth <- function(tsData)
{
	freqNum <- frequency(tsData)

	if (freqNum == 365) {
		month <- as.integer(strftime(as.Date(paste0(floor(time(tsData)),cycle(tsData)),"%Y%j"),"%m"))
	} else if (freqNum ==  12) {
		month <- as.integer(cycle(tsData))
	} else {
		stop("Invalid frequency: This functions is applicable to only daily and monthly time series.")
	}

	return (month)

}


#' Logarithm of the difference between two logarithms
#'
#' @param x log of first value.
#' @param y log of second value.
#'
#' @return log of the difference of exp(x) and exp(y).
#' @export log_diff_exp
#'
#'
log_diff_exp <- function(x, y) {
  # if(x <= y) stop("computing the log of a negative number")
  if(y == -Inf){
    return (x)
  }else{
    return (x + log1p(-exp(y-x)) )
  }
}
#' Returns the size of a clade.
#'
#' @param x a string containing a clade.
#'
#' @return a numeric value with the size of x
#' @export get_clade_size
#'
#' @examples
#' all.c4 <- make_all_clades(4)
#' get_clade_size(all.c4)
get_clade_size <- function(x){
  length(get_clade_elements(x))
}
get_clade_size <- Vectorize(get_clade_size)

#' Get elements of a clade
#'
#' @param x a string containing a clade.
#'
#' @return a vector of strings with the elements of \code{x}.
#' @export get_clade_elements
#'
#' @examples
#' all.c4 <- make_all_clades(4)
#' get_clade_elements(all.c4)
get_clade_elements <- function(x){
  y <- gsub("\\{", "", gsub("\\}", "", x))
  strsplit(y, ",")[[1]]
}
get_clade_elements <- Vectorize(get_clade_elements)

#' Returns whether two clades are compatible
#'
#' @param x a clade.
#' @param y a clade.
#'
#' @return logical. \code{TRUE} if \code{x} and \code{y} are compatible and \code{FALSE} otherwise.
#' @export compatible
#'
#' @examples
#' compatible(x = "{t1,t2}", y = "{t1,t3,t4}")
#' compatible(x = "{t1,t2}", y = "{t1,t2,t4}")
compatible <- function(x, y){
  x <- gsub(" ", "", x)
  y <- gsub(" ", "", y)
  x.el <- get_clade_elements(x)
  y.el <- get_clade_elements(y)
  sx <- length(x.el)
  sy <- length(y.el)
  Inters <- intersect(x.el, y.el)
  invCond <- length(Inters) > 0 && length(Inters) != min(sx, sy)
  return(!invCond)
}


pack.circles <- function(rfix, xfix,
  size=c(100, 100), max.iter=10, overlap=0 ) {
  #
  # Simple circle packing algorithm based on inverse size weighted repulsion
  #
  # config   - matrix with two cols: radius, N
  # size     - width and height of bounding rectangle
  # max.iter - maximum number of iterations to try
  # overlap  - allowable overlap expressed as proportion of joint radii

  # ============================================================================
  #  Global constants
  # ============================================================================
  # round-off tolerance
  TOL <- 0.0001

  # convert overlap to proportion of radius
  if (overlap < 0 | overlap >= 1) {
    stop("overlap should be in the range [0, 1)")
  }
  PRADIUS <- 1 - overlap

  NCIRCLES <- length(rfix)
  # ============================================================================
  #  Helper function - Draw a circle
  # ============================================================================
  draw.circle <- function(x, y, r, col) {
    lines( cos(seq(0, 2*pi, pi/180)) * r + x, sin(seq(0, 2*pi, pi/180)) * r + y , col=col )
  }

  # ============================================================================
  #  Helper function - Move two circles apart. The proportion of the required
  #  distance moved by each circle is proportional to the size of the other
  #  circle. For example, If a c1 with radius r1 overlaps c2 with radius r2,
  #  and the movement distance required to separate them is ds, then c1 will
  #  move ds * r2 / (r1 + r2) while c2 will move ds * r1 / (r1 + r2). Thus,
  #  when a big circle overlaps a little one, the little one moves a lot while
  #  the big one moves a little.
  # ============================================================================
  repel <- function(xyr, c0, c1) {
    dx <- xyr[c1, 1] - xyr[c0, 1]
    dy <- xyr[c1, 2] - xyr[c0, 2]
    d <- sqrt(dx*dx + dy*dy)
    r <- xyr[c1, 3] + xyr[c0, 3]
    w0 <- xyr[c1, 3] / r
    w1 <- xyr[c0, 3] / r

    if (d < r - TOL) {
      p <- (r - d) / d
      # xyr[c1, 1] <<- toroid(xyr[c1, 1] + p*dx*w1, 1)
      xyr[c1, 2] <<- toroid(xyr[c1, 2] + p*dy*w1, 2)
      # xyr[c0, 1] <<- toroid(xyr[c0, 1] - p*dx*w0, 1)
      xyr[c0, 2] <<- toroid(xyr[c0, 2] - p*dy*w0, 2)

      return(TRUE)
    }

    return(FALSE)
  }

  # ============================================================================
  #  Helper function - Adjust a coordinate such that if it is distance d beyond
  #  an edge (ie. outside the area) it is moved to be distance d inside the
  #  opposite edge. This has the effect of treating the area as a toroid.
  # ============================================================================
  toroid <- function(coord, axis) {
    tcoord <- coord

    if (coord < 0) {
      tcoord <- coord + size[axis]
    } else if (coord >= size[axis]) {
      tcoord <- coord - size[axis]
    }

    tcoord
  }

  # ============================================================================
  #  Main program
  # ============================================================================

  # ------------------------------------------
  # create a random initial layout
  # ------------------------------------------
  xyr <- matrix(0, NCIRCLES, 3)

  # generate random y axis
  all_y <- runif(NCIRCLES, size[2] * 0.3, size[2] * 0.7)
  # arrange y axis so larger dot in the middle
  generated.rank <- order(abs(all_y - size[2] / 2), decreasing = TRUE)
  data.rank <- order(rfix)

  for (i in 1:length(rfix)) {
    # rearranging x axis to new size
    xyr[i, 1] <- (xfix[i] - min(xfix))/(max(xfix) - min(xfix)) * size[1]
    xyr[data.rank[i], 2] <- all_y[generated.rank[i]]
    xyr[i, 3] <- rfix[i] * PRADIUS
  }

  # ------------------------------------------
  # iteratively adjust the layout
  # ------------------------------------------
  for (iter in 1:max.iter) {
    moved <- FALSE
    for (i in 1:(NCIRCLES-1)) {
      for (j in (i+1):NCIRCLES) {
        if (repel(xyr, i, j)) {
          moved <- TRUE
        }
      }
    }
    cat(".")
    if (!moved) break
  }

  cat(paste(iter, "iterations\n"));

  # ------------------------------------------
  # draw the layout
  # ------------------------------------------
  plot(0, type="n", xlab="x", xlim=c(0,size[1]), ylab="y", ylim=c(0, size[2]))

  xyr[, 3] <- xyr[, 3] / PRADIUS
  for (i in 1:nrow(xyr)) {
    draw.circle(xyr[i, 1], xyr[i, 2], xyr[i, 3], "gray")
  }

  # ------------------------------------------
  # return the layout
  # ------------------------------------------
  colnames(xyr) <- c("x", "y", "radius")
  invisible(xyr)
}


#' math
#'
#' Basic math operations, like trig, rounding, exp/logs.
#'
#' @details
#' In each case, the corresponding base R function is called on the local data.
#'
#' @section Communication:
#' Each operation is completely local.
#'
#' @param x
#' A shaq or a numeric vector.
#' @param base
#' Logarithm base.
#' @param digits
#' Number of decimal places to use.
#' @param ...
#' Additional arguments.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' y = ranshaq(runif, 10, 3)
#'
#' sqrt(x)
#' log(y)
#'
#' finalize()
#' }
#'
#' @name math
#' @rdname math
NULL

ply_simple = function(x, fun, ...)
{
  DATA(x) = fun(DATA(x), ...)
  x
}

# ------------------------------------------------------------------------------
# exp and log
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("sqrt", signature(x="shaq"), function(x) ply_simple(x, sqrt))

#' @rdname math
#' @export
setMethod("abs", signature(x="shaq"), function(x) ply_simple(x, abs))

#' @rdname math
#' @export
setMethod("exp", signature(x="shaq"), function(x) ply_simple(x, exp))

#' @rdname math
#' @export
setMethod("log", signature(x="shaq"), function(x, base=exp(1)) ply_simple(x, log, base=base))

#' @rdname math
#' @export
setMethod("log2", signature(x="shaq"), function(x) ply_simple(x, log2))

#' @rdname math
#' @export
setMethod("log10", signature(x="shaq"), function(x) ply_simple(x, log10))

# ------------------------------------------------------------------------------
# trig
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("sin", signature(x="shaq"), function(x) ply_simple(x, sin))

#' @rdname math
#' @export
setMethod("cos", signature(x="shaq"), function(x) ply_simple(x, cos))

#' @rdname math
#' @export
setMethod("tan", signature(x="shaq"), function(x) ply_simple(x, tan))

#' @rdname math
#' @export
setMethod("asin", signature(x="shaq"), function(x) ply_simple(x, asin))

#' @rdname math
#' @export
setMethod("acos", signature(x="shaq"), function(x) ply_simple(x, acos))

#' @rdname math
#' @export
setMethod("atan", signature(x="shaq"), function(x) ply_simple(x, atan))

#' @rdname math
#' @export
setMethod("sinh", signature(x="shaq"), function(x) ply_simple(x, sinh))

#' @rdname math
#' @export
setMethod("cosh", signature(x="shaq"), function(x) ply_simple(x, cosh))

#' @rdname math
#' @export
setMethod("tanh", signature(x="shaq"), function(x) ply_simple(x, tanh))

#' @rdname math
#' @export
setMethod("asinh", signature(x="shaq"), function(x) ply_simple(x, asinh))

#' @rdname math
#' @export
setMethod("acosh", signature(x="shaq"), function(x) ply_simple(x, acosh))

#' @rdname math
#' @export
setMethod("atanh", signature(x="shaq"), function(x) ply_simple(x, atanh))

# ------------------------------------------------------------------------------
# rounding
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("ceiling", signature(x="shaq"), function(x) ply_simple(x, ceiling))

#' @rdname math
#' @export
setMethod("floor", signature(x="shaq"), function(x) ply_simple(x, floor))

#' @rdname math
#' @export
setMethod("trunc", signature(x="shaq"), function(x, ...) ply_simple(x, trunc, ...))

#' @rdname math
#' @export
setMethod("round", signature(x="shaq"), function(x, digits=0) ply_simple(x, round, digits=digits))


##Shape=vector point
##enestacolumnaestaelrinde=field Shape
##Poligono=vector polygon
##Distancia_busqueda=number 40
##showplots
##kriging=output raster
#output_plots_to_html
##showplots

if("sp" %in% rownames(installed.packages()) == FALSE) {install.packages("sp")} else {print("sp ya esta..")}
if("gstat" %in% rownames(installed.packages()) == FALSE) {install.packages("gstat")} else {print("gstat ya esta..")}
if("spdep" %in% rownames(installed.packages()) == FALSE) {install.packages("spdep")} else {print("spdep ya esta..")}
if("raster" %in% rownames(installed.packages()) == FALSE) {install.packages("raster")} else {print("raster ya esta..")}
if("rgdal" %in% rownames(installed.packages()) == FALSE) {install.packages("rgdal")} else {print("rgdal ya esta..")}
if("foreach" %in% rownames(installed.packages()) == FALSE) {install.packages("foreach")} else {print("foreach ya esta..")}
if("parallel" %in% rownames(installed.packages()) == FALSE) {install.packages("parallel")} else {print("parallel ya esta..")}
if("doParallel" %in% rownames(installed.packages()) == FALSE) {install.packages("doParallel")} else {print("doParallel ya esta..")}
if("doSNOW" %in% rownames(installed.packages()) == FALSE) {install.packages("doSNOW")} else {print("doSNOW ya esta..")}

library(sp)
library(spdep)
library(gstat)
library(foreach)
library(parallel)
library(doParallel)
library(doSNOW)

crs_imagen<-st_crs(Shape)
datos <- as_Spatial(Shape)
poligono <- as_Spatial(Poligono)

#require(tcltk)
#datos<-tk_choose.files()
#poligono<-tk_choose.files()
#datos<-readOGR(datos)
#poligono<-readOGR(poligono)

proj4string(datos) <- CRS(proj4string(datos))

>print("ARMO GRILLA DE MUESTREO")
poligono <- buffer(poligono, width=100)
grdpts <- makegrid(poligono, cellsize = 5)
spgrd <- SpatialPoints(grdpts, proj4string = crs((poligono)))
spgrdWithin <- SpatialPixels(spgrd[poligono,])
par(mfrow= c(1,1))
>plot(spgrdWithin,col = "red", pch = 10, cex = 0.2,xlab="X",ylab="Y")
gri<-spgrdWithin
print(str(gri))
print(CRS(proj4string(poligono)))

>print("ARMO VARIOGRAMA")
require(gstat)
#enestacolumnaestaelrinde = "WetMass"
semivariograma <- variogram(get(enestacolumnaestaelrinde)~1, datos, cutoff=250)

sill<-max(semivariograma$gamma)
nugget<-semivariograma[1,3]
Limite_distancia<-max(semivariograma$dist)

modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,"Sph",Limite_distancia,nugget))
error1<-attr(modelovgm , 'SSErr')
>print(paste("Error inicial",error1))
modelo_final = "Sph"

seleccion_modelo<-function(){
	modelos<-c("Sph","Exp","Lin","Gau","Ste","Mat")
		for (i in 1:length(modelos)){
                print(i)
		modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelos[i],Limite_distancia,nugget))
	 	error<-(attr(modelovgm , 'SSErr'))
			print(modelos[i])
			print(error)
			if(error < error1){
                        modelo_final <<- modelos[i]
		        error1<-error
 			print(paste("Por ahora el mejor modelo es",modelo_final))

                        }
            }
}

suppressWarnings(seleccion_modelo())
>print(paste("Modelo final",modelo_final))
modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelo_final,Limite_distancia,nugget))
plot(semivariograma,modelovgm ,main="",xlab="Distancia",ylab="Semivarianza")

data2<-remove.duplicates(datos)
>print("Datos originales")
>print(nrow(datos))
>print("Datos filtrados")
>print(nrow(data2))

crs(data2)<-NA
crs(gri)<-NA

>print("---------Distancia de interpolado---------------")
>print(Distancia_busqueda)

#------------------------------------------------------------------
#Inicio procesamiento multiparalelo

# Calculo en numero de nucelos.
no_cores <- detectCores() - 1

modulo <-1
i<-1

while (modulo != 0){
  print(i)
  modulo<-(length(gri)-i)%%no_cores
  if(modulo == 0) {reductor <- i}
  i<-i+1
}

print(paste("el dataset original fue reducido en un ",reductor," punto para poder ser compartimentado",sep=""))

parts <- split(x = 1:(length(gri)-reductor), f = 1:no_cores)

#genero una dummy grid para ir concatenando los procesos
variables<-data.frame(grdpts$x1[1:3],grdpts$x2[1:3],c(-9999,-9999,-9999),c(-9999,-9999,-9999))
colnames(variables)<-c("x","y","var1.pred","var1.var")
coordinates(variables) = c("x", "y") # promote to SpatialPointsDataFrame
gridded(variables) <- TRUE

cl <- makeCluster(no_cores, outfile="")
registerDoParallel(cl)
registerDoSNOW(cl)

progress <- function(nfin, tag) {
  cat(sprintf('Bucle completado: %d \n', nfin))
}
opts <- list(progress=progress)

print("CALCULANDO KRIGING EN MODO MULTIHILO")

datoskriging <- foreach(i=1:no_cores,.init = variables,.combine = rbind,.packages= c('sp','gstat'),
                .options.snow=opts,.inorder = FALSE) %dopar% {

                  salida<-krige(formula = get(enestacolumnaestaelrinde)~1, locations = data2, newdata = gri[parts[[i]],], model = modelovgm,maxdist=Distancia_busqueda,debug.level=-1)

                  return(salida)
                }

stopCluster(cl)

#------------------------------------------------------------------
#Fin procesamiento multiparalelo

raster<- raster(datoskriging,layer=1)
raster[raster==-9999]<-NA
crs(raster)<-crs(poligono)
kriging<- raster


There are 517 Heronian triangles up to a maximal side length of 200.
Showing the first ten ordered first by perimeter, then by area:
       a  b  c perimeter area
 [1,]  3  4  5        12    6
 [2,]  5  5  6        16   12
 [3,]  5  5  8        18   12
 [4,]  5 12 13        30   30
 [5,]  4 13 15        32   24
 [6,]  9 10 17        36   36
 [7,] 10 13 13        36   60
 [8,]  8 15 17        40   60
 [9,]  7 15 20        42   42
[10,] 13 14 15        42   84


# DM test
# 7 de julio de 2016

setwd("~/Documentos/tesina/datos")
rm(list=ls())
graphics.off()

# Leer los datos
library(xlsx)
df = read.xlsx("compModelos.xlsx", sheetName="res", colIndex = c(1:4), rowIndex = c(1:37))

library(forecast)
horizonte = 10
dm.stat = numeric(length=horizonte)
dm.p = numeric(length=horizonte)

for (i in c(1:horizonte)) {
  # H0 = Los dos metodos tienen la misma precision de pronostico
  dm1 = dm.test (
    e1 = df$ann18,
    e2 = df$ann19,
    # "less" implica que Ha = metodo 2 tiene menor precision que metodo 1
    alternative = "less",
    h = i,
    power = 2
  )
  dm.stat[i] = dm1$statistic
  dm.p[i] = dm1$p.value
}

data.frame(cbind(dm.stat, dm.p))


#  James Rekow

computeInfoWeightMat = function(abdList, rollRange = 0.025){

  #  ARGS: rollRange - the maximum difference in overlap between two DOC points for which the two points
  #                    are still considered close enough that they are included in each others local
  #                    dissimilarity profiles (e.g. in computing rolling mean, etc.)
  #
  #  RETURNS: infoMat - M x M numerical matrix, where M is the number of samples in abdList. The diagonal
  #                     elements are -1. The ijth element is equal to the weighted value assigned to the
  #                     DOC point corresponding to samples i and j. Negative weights indicate that the
  #                     samples are in the same subgroup, positive weights indicate that the samples
  #                     are in different subgroups

  source("DOCProcedure.r")

  #  identify number of samples
  M = length(abdList)

  #  compute DOC
  doc = DOCProcedure(abdList)

  #  make DOC a data frame (by default a doc is a named list)
  doc = data.frame(over = doc$x, diss = doc$y)

  computeInfoWeight = function(docPoint){

    #  ARGS: docPoint - vector of the form c(over, diss)
    #
    #  RETURNS: localDissMid - midpoint of local dissimilarities (unweighted, not the same as the mean)

    #  extract overlap and dissimilarity of DOC point
    over = docPoint[1]
    diss = docPoint[2]

    #  don't count DOC points that have low overlap but 0 dissimilarity, these have 0 diss because they
    #  only share a single species
    if(diss < 0.005){
      if(over < 0.7){
        return(0)
      } #  end if
    } #  end if

    #  identify data frame row indices of DOC points with similar overlap
    similarOver = abs(doc[[1]] - over) < rollRange

    #  create vector of dissimilarities of all DOC points with similar overlap to input docPoint
    localDiss = doc[[2]][similarOver]

    #  compute the midpoint of the local dissimilarities
    localDissMid = 0.5 * {max(localDiss) + min(localDiss)}

    #  compute weighted value whose sign corresponds to whether or not the samples corresponding to the DOC
    #  point are in the same or different subgroups (- same, + different) and whose absolute value
    #  corresponds to how much weight is given to the info from the given DOC point
    infoWeight = diss - localDissMid

    return(infoWeight)

  } #  end computeInfoWeight function

  #  compute info weight for each DOC point in data frame
  infoWeight = apply(doc, 1, computeInfoWeight)

  #  compute maximum absolute value of weights
  maxAbsWeight = max(abs(infoWeight))

  #  normalize info weights so that the greatest absolute value of weights is equal to 1
  #infoWeight = infoWeight / maxAbsWeight

  #  create matrix of info weights
  infoMat = matrix(rep(-1, M * M), nrow = M, ncol = M)
  infoMat[lower.tri(infoMat, diag = FALSE)] = infoWeight
  infoMat = t(infoMat)
  infoMat[lower.tri(infoMat, diag = FALSE)] = infoWeight

  return(infoMat)

} #  end computeInfoWeightMat function


# Exercise 1
#
# Time: 5 minutes

# The following command creates a vector of 100 random numbers between 1 and 1000:

my_vector <- c(sample(1:1000, 100))

# Answer the following questions about the vector:

# 1) Extract the third through the sixth elements from the vector:

# 2) Check to see if the numbers 99, 66, and 287 exist in this vector:

# 3) How many elements are greater than 500?


# # 4. faza: Analiza podatkov

#=========================================================================================================================================================================================
# 1. napredna analiza
Napoved_golov <- Primerjava_zadetkov_domace_gostujoce_ekipe_graf + geom_smooth(method="lm")

#=========================================================================================================================================================================================
# 2. napredna analiza
tocke_domaci_gosti <- inner_join(tocke_domacii, gostujoce_tocke) %>% data.frame()
rownames(tocke_domaci_gosti) <- tocke_domaci_gosti$Ekipa

k <- 5
razdelitev <- tocke_domaci_gosti %>% select(-Ekipa) %>% scale() %>% kmeans(k, nstart=1000)
skupine <- data.frame(Ekipa=tocke_domaci_gosti$Ekipa,
                      Skupina=factor(razdelitev$cluster,
                                     levels=unique(razdelitev$cluster),
                                     labels=1:k),
                      stringsAsFactors=FALSE)

tocke_regije3 <- skupine %>% inner_join(klubi.regija) %>%
  group_by(Regija) %>% summarise(Ekipa=unique(Ekipa) %>% sort() %>% paste(collapse=", "),
                                 Skupina=ifelse(n() == 1, paste(Skupina), "London"))

zem.tocke3 <- merge(EngWal, tocke_regije3, by.x="NAME_2", by.y="Regija")
tocke_brezLondona <- tocke_regije3 %>% filter(Skupina != "London")
zem.tocke3_brezLondona <- merge(EngWal, tocke_brezLondona, by.x="NAME_2", by.y="Regija")

zemljevid_AngWal <- tm_shape(zem.tocke3) + tm_polygons("Skupina") + tm_legend(show=TRUE)

zemljevid_severne_ANGLIJE <- tm_shape(zem.tocke3_brezLondona, xlim=c(-3.2, -1.7), ylim=c(53.3, 53.9)) + tm_polygons("Skupina") +
  tm_legend(show=TRUE) + tm_text("Ekipa", size=0.7)

zemljevid_srednje_ANGLIJE <- tm_shape(zem.tocke3_brezLondona, xlim=c(-2.2, -1), ylim=c(52.3, 52.9)) + tm_polygons("Skupina") +
  tm_legend(show=TRUE) + tm_text("Ekipa", size=0.7)

#=========================================================================================================================================================================================
# Samo v Londonu

tocke_regije4 <- skupine %>% inner_join(klubi.regija2)
zem.tocke4 <- merge(Lond, tocke_regije4, by.x="NAME_3", by.y="Regija")
zemljevid_london_skupin <- tm_shape(zem.tocke4) + tm_polygons("Skupina") + tm_legend(show=TRUE) +
                        tm_text("Ekipa", size=0.7)


input <- readLines("input.dat")
ww <- lapply(strsplit(input," -> "),trimws)
q <- lapply(ww, function(x) strsplit(x,","))
n <- max(as.numeric(unlist(q)))+1
m <- matrix(0, nrow = n, ncol = n)
rt <- function(m, vr = FALSE){
    for(pair in ww){
        start <- as.numeric(strsplit(pair[[1]], ",")[[1]])+1
        end <- as.numeric(strsplit(pair[[2]], ",")[[1]])+1
        if(start[1] == end[1]){
            m[seq(start[2], end[2]), start[1]] <- m[seq(start[2], end[2]), start[1]]+1
        }else if(start[2] == end[2]){
            m[start[2], seq(start[1], end[1])] <- m[start[2], seq(start[1], end[1])]+1
        }else{
            if(vr){
                m[cbind(seq(start[2],end[2]),seq(start[1], end[1]))] <- m[cbind(seq(start[2],end[2]),seq(start[1],end[1]))]+1
            }}}sum(m >= 2)}
rt(m,FALSE)
rt(m,TRUE)
vj <- function(m, vr = FALSE){
    for(pair in ww){
        start <- as.numeric(strsplit(pair[[1]],",")[[1]]) + 1
        end <- as.numeric(strsplit(pair[[2]],",")[[1]]) + 1
        if(vr){
            m[cbind(seq(start[2], end[2]),seq(start[1], end[1]))] <- m[cbind(seq(start[2],end[2]),seq(start[1],end[1]))]+1
        }else{
            if(start[1] == end[1] || start[2] == end[2])
                m[cbind(seq(start[2], end[2]),seq(start[1],end[1]))] <- m[cbind(seq(start[2],end[2]),seq(start[1],end[1]))]+1
        }}sum(m >= 2)}
vj(m,FALSE)
vj(m,TRUE)


#calculates AR model-,p_value,My_aic,STD_AIC

rm(list=ls())
library(tseries)  #for arma process

alli<-NULL
zafari<-list.files("C:\\kindle_patrika\\jugnu_bholu\\")  #have potentials files

for(roll in zafari){
jai<-read.table(paste("C:\\kindle_patrika\\jugnu_bholu\\",roll,sep=""),skip=1)  #reading with avoiding first name
file_id<-substr(roll,1,(nchar(roll)-4) )  #file name

galiya<-jai$V1   #have whole time series
ts<-ts(galiya)

ishare<-ar(ts)   #Autoressive model
ts_p<-ishare$order    #order P value

#for AIC value
lm<-lm(ts ~ 1)     #fitting linear model
loglik<-logLik(lm)     #Extract Log-Likelihood
my_aic<-AIC(loglik)

arita<-arma(ts,order=c(ts_p,0))    #for calculating STD AIC value
y<-summary(arita)
std_aic<-y$aic

tun_tuna<-cbind(file_id,ts_p,my_aic,std_aic,deparse.level=0)   #making single row for each file
alli<-rbind(alli,tun_tuna)
}   #file iterating for

write.table(alli,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\AR\\AR_aic.txt",col.names=c("PDB_ID","P_value","MY_AIC","STD_AIC"),row.names=F)


#  James Rekow

elbowSSEMultiplot = function(elbowSSEDFLambda, elbowSSEDFM, elbowSSEDFNumSubgroups){

  #  lambda: c(150, 30, 0), M: c(40, 100, 160) (uses lambda = 100), numSubgroups: c(2, 5, 8)

  #  ARGS:
  #
  #  RETURNS:

  library(ggplot2)
  library(gridExtra)

  ##  compute meanDF

  SSELambda150 = sapply(1:10, function(n) mean(subset(elbowSSEDFLambda, numCenters == n & lambda == 150)$SSE))
  SSELambda30 = sapply(1:10, function(n) mean(subset(elbowSSEDFLambda, numCenters == n & lambda == 30)$SSE))
  SSELambda0 = sapply(1:10, function(n) mean(subset(elbowSSEDFLambda, numCenters == n & lambda == 0)$SSE))

  meanNumCenters = rep(1:10, 3)
  meanSSE = c(SSELambda150, SSELambda30, SSELambda0)
  meanLambda = as.factor(c(rep(150, 10), rep(30, 10), rep(0, 10)))

  meanDF1 = data.frame(numCenters = meanNumCenters, SSE = meanSSE, lambda = meanLambda)

  p1 = ggplot() +
         ggtitle("Effect of Interaction Rate on SSE of K-Means",
            subtitle = "M = 40, N = 20, numSubgroups = 6, univ = 1") +
         geom_point(data = elbowSSEDFLambda, aes(x = numCenters, y = SSE, group = runID, col = lambda),
                   alpha = 0.4) +
         geom_line(data = elbowSSEDFLambda, aes(x = numCenters, y = SSE, group = runID, col = lambda),
                    alpha = 0.4) +
         geom_point(data = meanDF1, aes(x = numCenters, y = SSE, col = lambda), size = 1.5) +
         geom_line(data = meanDF1, aes(x = numCenters, y = SSE, col = lambda), size = 1.5) +
         scale_x_discrete(limits = as.character(1:10)) +
         theme(axis.ticks.x = element_line(size = c(1, 1, 1, 1, 1, 3, 1, 1, 1, 1)))

  SSEM40 = sapply(1:10, function(n) mean(subset(elbowSSEDFM, numCenters == n & M == 40)$SSE))
  SSEM100 = sapply(1:10, function(n) mean(subset(elbowSSEDFM, numCenters == n & M == 100)$SSE))
  SSEM160 = sapply(1:10, function(n) mean(subset(elbowSSEDFM, numCenters == n & M == 160)$SSE))

  meanNumCenters = rep(1:10, 3)
  meanSSE = c(SSEM40, SSEM100, SSEM160)
  meanM = as.factor(c(rep(40, 10), rep(100, 10), rep(160, 10)))

  meanDF2 = data.frame(numCenters = meanNumCenters, SSE = meanSSE, M = meanM)

  p2 = ggplot() +
    ggtitle("Effect of Number of Samples on SSE of K-Means",
            subtitle = "N = 20, numSubgroups = 6, lambda = 100, univ = 1") +
    geom_point(data = elbowSSEDFM, aes(x = numCenters, y = SSE, group = runID, col = M),
               alpha = 0.4) +
    geom_line(data = elbowSSEDFM, aes(x = numCenters, y = SSE, group = runID, col = M),
              alpha = 0.4) +
    geom_point(data = meanDF2, aes(x = numCenters, y = SSE, col = M), size = 1.5) +
    geom_line(data = meanDF2, aes(x = numCenters, y = SSE, col = M), size = 1.5) +
    scale_x_discrete(limits = as.character(1:10)) +
    theme(axis.ticks.x = element_line(size = c(1, 1, 1, 1, 1, 3, 1, 1, 1, 1)))

  SSENumSubgroups2 = sapply(1:10, function(n) mean(subset(elbowSSEDFNumSubgroups,
                                                          numCenters == n & numSubgroups == 2)$SSE))
  SSENumSubgroups5 = sapply(1:10, function(n) mean(subset(elbowSSEDFNumSubgroups,
                                                          numCenters == n & numSubgroups == 5)$SSE))
  SSENumSubgroups8 = sapply(1:10, function(n) mean(subset(elbowSSEDFNumSubgroups,
                                                          numCenters == n & numSubgroups == 8)$SSE))

  meanNumCenters = rep(1:10, 3)
  meanSSE = c(SSENumSubgroups2, SSENumSubgroups5, SSENumSubgroups8)
  meanNumSubgroups = as.factor(c(rep(2, 10), rep(5, 10), rep(8, 10)))

  meanDF3 = data.frame(numCenters = meanNumCenters, SSE = meanSSE, numSubgroups = meanNumSubgroups)

  p3 = ggplot() +
    ggtitle("Effect of Number of Subgroups on SSE of K-Means",
            subtitle = "M = 40, N = 20, lambda = 0, univ = 1") +
    geom_point(data = elbowSSEDFNumSubgroups, aes(x = numCenters, y = SSE, group = runID, col = numSubgroups),
               alpha = 0.4) +
    geom_line(data = elbowSSEDFNumSubgroups, aes(x = numCenters, y = SSE, group = runID, col = numSubgroups),
              alpha = 0.4) +
    geom_point(data = meanDF3, aes(x = numCenters, y = SSE, col = numSubgroups), size = 1.5) +
    geom_line(data = meanDF3, aes(x = numCenters, y = SSE, col = numSubgroups), size = 1.5) +
    scale_x_discrete(limits = as.character(1:10)) +
    theme(axis.ticks.x = element_line(size = c(1, 3, 1, 1, 3, 1, 1, 3, 1, 1),
                                      color = c("black", "#F8766D", "black", "black", "#7CAE00", "black",
                                                "black", "#00BFC4", "black", "blacK")))

  grid.arrange(p1, p2, p3, ncol = 3)

} #  end elbowSSEMultiplot function


library(randomForest)
{{rimport}}('__init__.r')

infile       = {{i.infile | quote}}
outmodel     = {{o.outmodel | quote}}
outdir       = {{o.outdir | quote}}
args.plot    = {{args.plot | R}}
args.formula = {{args.formula | R}}
inopts       = {{args.inopts | R}}
devpars      = {{args.devpars | R}}
na           = {{args.na | R}}
prefix       = {{i.infile | stem | quote}}

indata = read.table.inopts(infile, inopts)
indata[is.na(indata)] = na

cnames = colnames(indata)
if (is.null(cnames)) {
	colnames(indata) = c(paste('X', 1:(ncol(indata)-1)), 'Y')
	cnames = colnames(indata)
}

if (is.null(args.formula)) {
	backtick = function(x) sprintf('`%s`', x)
	ycol = cnames[ncol(indata)]
	args.formula = as.formula(paste(cnames[ncol(indata)], '~', paste(backtick(cnames[1:(ncol(indata)-1)]), collapse = '+')))
} else {
	ycol = unlist(strsplit(args.formula, '\\s*~\\s*'))[1]
	args.formula = as.formula(args.formula)
}

model.rf = randomForest(args.formula, data = indata)
saveRDS(model.rf, outmodel)

# save importance
write.table(
	round(model.rf$importance[order(model.rf$importance[, 1], decreasing = T), , drop = F], 3),
	file.path(outdir, paste0(prefix, '.importance.txt')),
	col.names = T, row.names = T, quote = F, sep = "\t")

# plot importance
{% if args.plot %}
do.call(png, c(list(file.path(outdir, paste0(prefix, '.importance.png'))), devpars))
randomForest::varImpPlot(model.rf, main = 'Feature importance')
dev.off()
{% endif %}


context("Check accuracy of CLR using Card data")

test_that("CLR test without exogeneous covariates and intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.462792094452, 0.470402558674))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),6679.92118721)
})

test_that("CLR test without exogeneous covariates and intercept, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.463889965605, 0.471283479854))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),8327.04383792)
})

test_that("CLR test with intercept, but without exogeneous covariates, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.143037537021, 0.250862570435))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),82.7445324192)
})

test_that("CLR test with intercept, but without exogeneous covariates, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  foo = ivmodel(Y=Y,D=D,Z=Z)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.158839802213, 0.27417906789))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),99.3797747842)
})

test_that("CLR test with exogeneous covariates, but no intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.280764970946, 0.346153931564))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),113.307424185)
})

test_that("CLR test with exogeneous covariates, but no intercept, multi-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.309132826837, 0.356869350444))
  expect_equal(as.numeric(teststat_out$p.value),0)
  expect_equal(as.numeric(teststat_out$test.stat),267.050612418)
})

test_that("CLR test with exogeneous covariates and intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.0248043722948, 0.284824550722))
  expect_equal(as.numeric(teststat_out$p.value),0.0200276297596)
  expect_equal(as.numeric(teststat_out$test.stat),5.41527923822)
})

test_that("CLR test with exogeneous covariates, but no intercept, multi-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  teststat_out = CLR(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.0621199910211, 0.336180869927))
  expect_equal(as.numeric(teststat_out$p.value),0.00346295807184)
  expect_equal(as.numeric(teststat_out$test.stat),9.26245429367)
})


pdf_file<-"pdf/piecharts_allocation_of_seats_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=3.75)

par(omi=c(0.5,0.5,1,0.5),mai=c(0,0,0,0),xpd=T,mfcol=c(1,2),family="Lato Light")
library(plotrix)

# Define chart

plot(1:5,type="n",axes=F,xlab="",ylab="",xlim=c(1,5),ylim=c(1,10))
mySeats<-c(51,54,61,222,226)
myDes<-c(mySeats,""); mySlices<-50*mySeats /sum(mySeats)
myValues<-c(mySlices,50); myDisc<-100
MyColour<-c("white", "white", "black", "white", "white")

# Create chart

mySemiCircle<-floating.pie(3,1,myValues,border="white",radius=1.9,xpd=F,col=c("green","pink","yellow","red","black",par("bg")))
pie.labels(3,1,mySemiCircle,myDes,bg=NA,border=NA,radius=1.5,cex=2,col=MyColour)
floating.pie(3,1,myDisc,border="white",col=par("bg"),radius=0.7,xpd=F)
mtext("16th German Bundestag",3,line=0,adj=0.5,font=3,cex=1.3)

par(xpd=T)
legend(1,0.5,c("Union (CDU/CSU)","Socialist Party (SPD)","Free Democratic Party (FDP)","Left Party (Die Linke)"," Alliance '90/The Greens (Bündnis 90/Die Grünen)"),border=F,pch=15,col=c("black","red","yellow","pink","green"),bty="n",cex=0.7,xpd=NA,ncol=3)
par(xpd=F)

# Define chart

plot(1:5,type="n",axes=F,xlab="",ylab="",xlim=c(1,5),ylim=c(1,10))
mySeats<-c(68,76,93,146,237)
myDes<-c(mySeats,""); mySlices <-50*mySeats/sum(mySeats)
myValues<-c(mySlices,50); myDisc<-100

# Create chart

semicirlce<-floating.pie(3,1,myValues,border="white",radius=1.9,xpd=F,col=c("green","pink","yellow","red","black",par("bg")))
pie.labels(3,1,mySemiCircle,myDes,bg=NA,border=NA,radius=1.5,cex=2,col=MyColour)
floating.pie(3,1,myDisc,border="white",col=par("bg"),radius=0.7,xpd=F)
mtext("17th German Bundestag",3,line=0,adj=0.5,font=3,cex=1.3)

# Titling

mtext("Seat distribution in the German Bundestag",3,line=3,adj=0,family="Lato Black",outer=T,cex=1.8)
mtext("Source: www.bundestag.de",1,line=1,adj=1.0,cex=0.7,font=3,outer=T)
dev.off()


#' Shrinkage-based Diagonal Quadratic Discriminant Analysis (SDQDA)
#'
#' Given a set of training data, this function builds the Shrinkage-based
#' Diagonal Quadratic Discriminant Analysis (SDQDA) classifier, which is based
#' on the DQDA classifier, often attributed to Dudoit et al. (2002). The DQDA
#' classifier belongs to the family of Naive Bayes classifiers, where the
#' distributions of each class are assumed to be multivariate normal. To improve
#' the estimation of the class variances, Pang et al. (2009) proposed the SDQDA
#' classifier which uses a shrinkage-based estimators of each class covariance
#' matrix.
#'
#' The DQDA classifier is a modification to the well-known QDA classifier, where
#' the off-diagonal elements of the pooled covariance matrix are assumed to be
#' zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of
#' `x` contain the sample observations, and the columns contain the
#' features for each training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations
#' belonging to each class. Otherwise, `prior` should be a vector with the
#' same length as the number of classes in `y`. The `prior`
#' probabilities should be nonnegative and sum to one.
#'
#' @export
#'
#' @inheritParams lda_diag
#' @param num_alphas the number of values used to find the optimal amount of
#' shrinkage
#' @return `qda_shrink_cov` object that contains the trained SDQDA classifier
#'
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]#' set.seed(42)

#' sdqda_out <- qda_shrink_cov(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(sdqda_out, penguins[pred_rows, -1], type = "class")
#'
#' sdqda_out2 <- qda_shrink_cov(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(sdqda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
qda_shrink_cov <- function(x, ...) {
  UseMethod("qda_shrink_cov")
}

#' @rdname qda_shrink_cov
#' @export
qda_shrink_cov.default <- function(x, y, prior = NULL, num_alphas = 101, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x, y, prior, pool = FALSE)

  # Calculates the shrinkage-based estimator for each diagonal sample class
  # covariance matrix. We add these to the corresponding obj$est$var_shrink
  for(k in seq_len(obj$num_groups)) {
    obj$est[[k]]$var_shrink <- var_shrinkage(
      N = obj$est[[k]]$n,
      K = 1,
      var_feature = obj$est[[k]]$var,
      num_alphas = num_alphas,
      t = -1
    )
  }

  # Creates an object of type 'qda_shrink_cov'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "qda_shrink_cov")

  obj
}

#' @inheritParams lda_diag
#' @importFrom stats model.frame model.matrix model.response
#' @rdname qda_shrink_cov
#' @export
qda_shrink_cov.formula <- function(formula, data, prior = NULL, num_alphas = 101, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- qda_shrink_cov.default(x = x, y = y, prior = prior, num_alphas = num_alphas)

  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a SDQDA classifier object.
#'
#' Summarizes the trained SDQDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.qda_shrink_cov <- function(x, ...) {
  cat("Shrinkage-Based Diagonal QDA\n\n")
  print_basics(x, ...)
  invisible(x)
}

#' SDQDA prediction of the class membership of a matrix of new observations.
#'
#' The SDQDA classifier is a modification to QDA, where the off-diagonal
#' elements of the pooled sample covariance matrix are set to zero. To improve
#' the estimation of the pooled variances, we use a shrinkage method from Pang
#' et al.  (2009).
#'
#' @rdname qda_shrink_cov
#' @export
#' @inheritParams predict.lda_diag

predict.qda_shrink_cov <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / var_shrink + log(var_shrink))
           + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- lapply(object$est, "[[", "var_shrink")
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)

  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}


# load libraries
source("./00_functions_library.r")

library(coda)
library(rjags)

# paths
path.stata <- file.path('data', 'database_counts_all.dta', sep='')
path.model.separate <- file.path('model_separate.r', sep='')
res.path <- file.path('bayes_results', sep='')
stem <- 'separate'

# jags fitting
model.file <- path.model.separate
n.adapt <- 10000
n.burn.in <- 50000
n.record <- 100000

#########################################
# DATA
#########################################

data <- read.dta(path.stata)

#### humerus
    valid.hum <- !is.na(data[,"down_n_1dot"])  # only 11 studies have humerus
    data.hum <- data[valid.hum,]

    ## data
    K.hum <- dim(data.hum)[1]

    x.down.1dot <- as.vector(data.hum[,'down_n_1dot'])
    N.down.hum <- as.vector(data.hum[,'down_n_1dot'] + data.hum[,'down_n_0dot'])

    x.nodown.1dot <- as.vector(data.hum[,'nodown_n_1dot'])
    N.nodown.hum <- as.vector(data.hum[,'nodown_n_1dot'] + data.hum[,'nodown_n_0dot'])

    ## priors -- flat
    mu0.hum <- c(0, 0)
    prec.mu0.hum <- rep(10^-6, 2)
    s.lower.hum <- rep(10^-4, 2)
    s.upper.hum <- rep(5, 2)
    r.lower.hum <- rep(-.999, 2)
    r.upper.hum <- rep(+.999, 2)

#### femur
    valid.fem <- !is.na(data[,"down_n_dot1"]) # all studies have femur  - superfluous
    data.fem <- data[valid.fem,]

    ## data
    K.fem <- dim(data.fem)[1]

    x.down.dot1 <- as.vector(data.fem[,'down_n_dot1'])
    N.down.fem <- as.vector(data.fem[,'down_n_dot1'] + data.fem[,'down_n_dot0'])

    x.nodown.dot1 <- as.vector(data.fem[,'nodown_n_dot1'])
    N.nodown.fem <- as.vector(data.fem[,'nodown_n_dot1'] + data.fem[,'nodown_n_dot0'])

    ## priors -- flat
    mu0.fem <- c(0, 0)
    prec.mu0.fem <- rep(10^-6, 2)
    s.lower.fem <- rep(10^-4, 2)
    s.upper.fem <- rep(5, 2)
    r.lower.fem <- rep(-.999, 2)
    r.upper.fem <- rep(+.999, 2)

jags.data <- list('K.hum' = K.hum,
                  'x.down.1dot' = x.down.1dot, 'N.down.hum' = N.down.hum,
                  'x.nodown.1dot' = x.nodown.1dot, 'N.nodown.hum' = N.nodown.hum,
                  #'alpha.down.hum' = alpha.down.hum, 'beta.down.hum' = beta.down.hum,
                  'mu0.hum' = mu0.hum, 'prec.mu0.hum' = prec.mu0.hum,
                  's.lower.hum' = s.lower.hum, 's.upper.hum' = s.upper.hum,
                  'r.lower.hum' = r.lower.hum, 'r.upper.hum' = r.upper.hum,

                  'K.fem' = K.fem,
                  'x.down.dot1' = x.down.dot1, 'N.down.fem' = N.down.fem,
                  'x.nodown.dot1' = x.nodown.dot1, 'N.nodown.fem' = N.nodown.fem,
                  #'alpha.down.fem' = alpha.down.fem, 'beta.down.fem' = beta.down.fem,
                  'mu0.fem' = mu0.fem, 'prec.mu0.fem' = prec.mu0.fem,
                  's.lower.fem' = s.lower.fem, 's.upper.fem' = s.upper.fem,
                  'r.lower.fem' = r.lower.fem, 'r.upper.fem' = r.upper.fem )

#########################################
# RUN THE MODEL AND MONITOR RESULTS
#########################################

the.jags.model <- jags.model(file=model.file,
                  data=jags.data,
                  n.chains=3, n.adapt=n.adapt)

update(the.jags.model, n.iter=n.burn.in)

the.mcmc.res <- my.coda.samples(the.jags.model,
                              c('deviance', 'pD','tpr.hum', 'fpr.hum',
                              'tpr.fem', 'fpr.fem', 'diff.tpr', 'diff.fpr',
                              'or.tpr', 'or.fpr', 'Eta.Xi.hum', 'Eta.Xi.fem', 'diff.eta', 'diff.xi',
                              'Tau.hum[1,1]', 'Tau.hum[1,2]', 'Tau.hum[2,2]', 'R.hum[1,2]',
                              'Tau.fem[1,1]', 'Tau.fem[1,2]', 'Tau.fem[2,2]', 'R.fem[1,2]'),
                              n.iter=n.record, thin=10)

#########################################
# SPIT RESULTS TO STATA
#########################################

## collect stats -- the first part in the list is the non-pD chains
stats <- summary(the.mcmc.res[[1]])

pD <- c("pD", summary(the.mcmc.res[[2]], mean)$stat, NA, NA, NA)
stats.m <- cbind(rownames(stats[[1]]), stats[[1]])
stats.m <- rbind(stats.m, pD)
colnames(stats.m)[1:5]<-c("node", "mean", "sd", "naivese", "timeseriesse")

problist <- c(0.025, 0.25, 0.50, 0.75, 0.975)
pD <- c("pD", quantile(the.mcmc.res[[2]], probs=problist))
stats.q <- cbind(rownames(stats[[2]]), stats[[2]])
stats.q <- rbind(stats.q, pD)
colnames(stats.q)[1:6] <- c("node","p025","p250", "p500", "p750", "p975")

write.table(stats.m, file=paste(res.path,"/","stats_m_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)
write.table(stats.q, file=paste(res.path,"/","stats_q_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)

# save the trace plots
png(paste(res.path, "/", stem, "_%02d.png", sep=""))
plot(the.mcmc.res[[1]])
dev.off()

# collect diagnostics
gelman <- gelman.diag(the.mcmc.res[[1]])

gelman.row.names <- rownames(gelman[[1]])
gelman.table <-cbind(gelman.row.names, gelman[[1]], rep(gelman[[2]], length(gelman.row.names)))
colnames(gelman.table)<- c("node", "prsf500", "prsf975", "prsf975_multi")
write.table(gelman.table, file=paste(res.path,"/","gelman_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)