#' @title calcCm
#'
#' @description  Calculates the midship section coefficient (\code{Cm})
#' (dimensionless).
#'
#' @param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with \code{tankerBulkCarrierShipTypes}, \code{tugShipTypes}, and
#' \code{roroPaxShipTypes} groupings
#' @param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCbw}})
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param CmEquationType Equation type: \itemize{
#' \item"kristensen"
#' \item"benford"
#' \item"schneekluth"}
#' This argument is not vectorized, as it takes only a single string
#'@param tankerBulkCarrierShipTypes Ship types specified in input \code{shipTypes}
#'to be modeled as tankers and bulk carriers (vector of strings)
#'@param tugShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as tugs (vector of strings)
#'@param roroPaxShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as RORO and passenger ships (vector of strings)
#'
#' @details
#' The midship section coefficient calculation depends on the ship type, in
#' addition to the actual draft. Actual draft is typically obtained from sources
#' such as AIS messages or ship records.
#'
#' This function can calculate \code{Cm} using three different methods:
#' Kristensen, Benford, and Schneekluth. The Kristensen method requires ship
#' types to be grouped. Use the \code{tankerBulkCarrierShipTypes},
#' \code{tugShipTypes}, and \code{roroPaxShipTypes} parameters to provide these
#' ship type groupings. Any ship types not included in these groupings will be
#' considered as miscellaneous vessels.
#'
#' Use the \code{CmEquationType} parameter to indicate which method to use:\itemize{
#'
#'  \item "kristensen" (see Kristensen 2013 & 2017): \itemize{
#'    \item Bulk Carriers and Tankers: \code{Cm} = 0.995
#'    \item Passenger Vessels: \code{Cm} = 0.95
#'    \item Tugboats: \code{Cm} = 0.92
#'    \item Miscellaneous Vessels: \code{Cm} = 0.98
#'  }
#'
#'  \item "benford" (see Rakke 2016):
#'  \deqn{Cm=0.977+0.085*(Cbw-0.6)}
#'
#'  \item "schneekluth" (see Schneekluth 1998):
#'  \deqn{Cm=1.006-0.0056*Cbw^-3.65}
#'
#' }
#'
#' @return \code{Cm} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'Schneekluth, H. and Bertram, V. 1998. "Ship Design for Efficiency and Economy."
#'2nd ed. Oxford, Boston: Butterworth-Heinemann.
#'
#' @seealso \itemize{
#'   \item \code{\link{calcCbw}}
#'   \item \code{\link{calcShipType}}
#'  }
#'
#' @examples
#' calcCm(c("chemical.tanker","container.ship"),c(0.8,0.75),c(13.6,15.6),c(12.5,14.1),"kristensen")
#' calcCm(c("chemical.tanker","container.ship"),c(0.8,0.75),c(13.6,15.6),c(12.5,14.1),"kristensen",
#'        tankerBulkCarrierShipTypes=c("other.tanker"))
#'
#' @export

calcCm <-function(shipType,Cbw,maxDraft,actualDraft,CmEquationType,
                  tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                  tugShipTypes=c("service.tug","tug"),
                  roroPaxShipTypes=c("ferry.pax","ferry.ro.pax","cruise","cruise.ed","yacht","ro.ro","passenger")
                  ){

  if(grepl("kristensen",tolower(CmEquationType))==TRUE){
    Cm<- ifelse(#case 1
          shipType %in% tankerBulkCarrierShipTypes
        ,
        0.995,
        ifelse(#case 2
          shipType %in% tugShipTypes,
          0.92,
          ifelse(#case 3
            shipType %in% roroPaxShipTypes,
            0.95,# passenger case
            0.98 # misc type case
          )#end of case 3

        )#end of case 2
      )#end of case 1

    #adjust for actual draft
    Cm<-1-maxDraft/actualDraft*(1-Cm)

  }else if(grepl("benford",tolower(CmEquationType))==TRUE){

    Cm<-0.977+0.085*(Cbw-0.6)

  }else if(grepl("schneekluth",tolower(CmEquationType))==TRUE){

    Cm<-1.006-0.0056*Cbw^-3.56

  }
  return(Cm)
}


# I haven't matched "13-260 Centennial Park" yet.

library(dplyr)
library(ggmap)
library(shiny)
library(leaflet)
#load ggmap maps
load("osm_map.rda")
#load election results
load("voting_results.rda")
#load polygons of precints
load("precinct_polygons.rda")

race <- "Ballot Measure 2 - 13PSUM"

yeses <- voting_results %>%
  filter(Race == race) %>%
  filter(Value == "YES") %>%
  select(n)

noes <- voting_results %>%
  filter(Race == race) %>%
  filter(Value == "NO") %>%
  select(n, DISTRICT)

registered <- voting_results %>%
  filter(Race == race) %>%
  filter(Value == "Registered Voters") %>%
  select(n, DISTRICT)

summarized <- cbind(registered, var = yeses$n  / (noes$n + yeses$n))
summarized$DISTRICT <- factor(summarized$DISTRICT)
summarized <- arrange(summarized, var)
summarized$DISTRICT <- factor(summarized$DISTRICT,
                              levels = as.character(summarized$DISTRICT))

registered <- cbind(registered, turnout = (noes$n + yeses$n) / registered$n)
registered$DISTRICT <- factor(registered$DISTRICT)
registered <- arrange(registered, turnout)
registered$DISTRICT <- factor(registered$DISTRICT,
                              levels = as.character(registered$DISTRICT))

sum(noes$n) - sum(yeses$n)

summarized <- cbind(summarized, passed = summarized$var > .5)

mapping_obj <- inner_join(summarized, anc.df, by="DISTRICT")

#anc <- get_map("anchorage, AK", zoom = 8)
p <- ggmap(anc)
p +  geom_polygon(data = mapping_obj, aes(long,lat,group=DISTRICT, color = factor(as.character(passed))), color = "black", alpha = 0.5) +
  scale_fill_continuous(guide = guide_legend(title = "Yes on 2"))

ggplot(data = mapping_obj, aes(long,lat,group=DISTRICT, fill = passed)) +
  geom_polygon() + geom_path(color = "white")

ggplot(data = summarized, aes(x = var)) + geom_histogram(binwidth = 0.01)

ggplot(data = filter(mapping_obj, var > median(mapping_obj$var)), aes(DISTRICT, var)) +
  geom_bar(stat = "identity", aes(label = DISTRICT)) +
  coord_flip() +
  labs(title = "var in Anchorage Precincts - Nov. 2014",
       y = "Percent of mapping_obj Voters That Casted Ballots",
       x = "Precinct")+
  ylim(c(0, 1))

ggplot(data = filter(mapping_obj, var <= median(mapping_obj$var)), aes(DISTRICT, var)) +
  geom_bar(stat = "identity", aes(label = DISTRICT)) +
  coord_flip() +
  labs(title = "var in Anchorage Precincts - Nov. 2014",
       y = "Percent of mapping_obj Voters That Casted Ballots",
       x = "Precinct") +
  ylim(c(0, 1))

median(summarized$var)
mean(summarized$var)

filter(summarized, var < .5)


diag <- function(mc.out) {

  require(coda)

  traceplot(mc.out)
  densplot(mc.out)
  cumuplot(mc.out)
  autocorr.plot(mc.out)
  crosscorr.plot(mc.out)
  #caterplot(mc.out)    #require(mcmcplot)

  summary(mc.out)
  effectiveSize(mc.out)
  heidel.diag(mc.out)
  geweke.diag(mc.out)
  #gelman.diag(mc.list)   #multiple chains

  cat("acceptance % = ", 1-mean(duplicated(mc.out)))

  unload("package:coda", unload=T)
}


# # 4. faza: Analiza podatkov
#
# # Uvozimo funkcijo za uvoz spletne strani.
# source("lib/xml.r")
#
# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()

pdf("slike/internationalplayers.pdf")

leto <- ANA2$SEZONA - 2000
ply <- ANA2$TUJCI

plot(leto, ply, xlab = "Leto", ylab = "Tuji igralci v NBA", main = "Naraščanje števila tujcev v ligi NBA")
legend(4.5, 102, c("Linearna", "Kvadratna"), lty=c(1,1), col = c("blue","red"))

#Napišem funkcijo za linearno rast

linearna <- lm(ply ~ leto)
abline(linearna, col="blue")

#Napišem funkcijo za kvadratno rast

kvadratna <- lm(ply ~ I(leto^2) + leto)
curve(predict(kvadratna, data.frame(leto=x)), add = TRUE, col = "red")

#Loess model za primerjavo (model loess uporablja lokalno prilagajanje)

loess <- loess(ply ~ leto)

#Pogledamo ostanke pri modelih. Tisti, ki ima manjši ostanek je bolj natančen

vsota.kvadratov <- sapply(list(linearna, kvadratna, loess), function(x) sum(x$residuals^2))

dev.off()

#Narisali bomo napoved za rast števila tujcev v NBA za linearni in kvadratni model

pdf("slike/napoved.pdf")

plot(ANA2$SEZONA, ply, xlim = c(2005, 2030), ylim = c(50, 150),
     xlab = "Leto", ylab = "Tuji igralci v NBA",
     main = "Predvidena rast števila tujcev v ligi NBA po različnih modelih")
abline(h = 120,col = "black", lwd = 1.5, lty = 1)

#Presečišča izračunamo na roko

points(2028.950332, 120,  col = "black", pch = 21)
points(2016.57562, 120,  col = "black", pch = 21)

#V presečiščih potegnemo navpične črte

abline(v=2028.950332, col = "magenta", lty = 1)
abline(v=2016.57562, col = "magenta", lty = 1)

napoved <- function(x,model){predict(model, data.frame(leto=x-2000))}

curve(napoved(x, linearna), add= TRUE, lwd = 1.5, col = "blue")
curve(napoved(x, kvadratna), add = TRUE, lwd = 1.5, col = "red")

#Narišemo še legendo

legend(2004, 65, c("Linearna (lm(ply ~ leto))", "Kvadratna (lm(ply ~ I(leto^2) + leto))",
                    "120 tujcev"),
       lty=c(1,1), col = c("blue","red", "black"))

dev.off()

pdf("slike/analiza.pdf")
normaliziranje <- scale(ANA1[c(2,3,4,5,6)])
normal <- data.frame(ANA1[1], normaliziranje)
plot(normal$YEAR, normal$W, type = "l", col = "red", lwd = 3.6, xlab = "Leto", ylab = "Normalizirani podatki",
     main = "Podatki za ekipo Phoenix Suns - korelacija med spremenljivkami")
lines(normal$YEAR, normal$REB, col = "blue")
abline(h = normal$W, lty = "dotted", col = "grey")
abline(v = normal$YEAR, lty = "dotted", col = "grey")
lines(normal$YEAR, normal$AST, col = "green")
lines(normal$YEAR, normal$TOV, col = "orange")
lines(normal$YEAR, normal$PTS, col = "cyan")
legend("topright",
       legend=c("Zmage", "Skoki", "Asistence", "Napake","Točke"),
       col=c("red","blue","green","orange","cyan"),
       title="Legenda",
       lwd = c(5, 5, 5, 5, 5, 5),
       bg = "white")

dev.off()

pdf("slike/hierarhija1.pdf")

X <- scale(as.matrix(NBA2))
t <- hclust(dist(X), method = "ward.D")

plot(t, hang=-1, cex=0.4, main = "Delitev ekip v skupine glede na športno uspešnost")

legend("topright",
       c("Skupina 1", "Skupina 2","Skupina 3"),
       lty=c(1,1,1), col = c("red","blue","green"))

rect.hclust(t,k=3,border=c("blue","green","red"))

p1 <- cutree(t, k=3)

dev.off()

pdf("slike/hierarhija2.pdf")

Y <- scale(as.matrix(place[1]))
z <- hclust(dist(Y), method = "ward.D")

plot(z, hang=-1, cex=0.4, main = "Izdatki za plače")

legend("topright",
       c("Skupina 1", "Skupina 2","Skupina 3"),
       lty=c(1,1,1), col = c("red","blue","green"))

rect.hclust(z,k=3,border=c("red","blue","green"))

p2 <- cutree(z, k=3)

dev.off()

# V tem delu bom preveril, kateri izmed igralcev je bil najbolj koristen kar se košev tiče, glede na to, kako dolgo je preživel na parketu.
# Torej učinkovitost igralcev.

pdf("slike/indeksphx.pdf")

povprecje <- apply(phoenix, 1, function(x) x[20]/x[2])
phoenix$indeks <- povprecje

priimki <- gsub("^.* ", "", rownames(phoenix))
barplot(phoenix$indeks, las = 2, cex.names = 0.65,
        ylab = "Dane točke / minutaža",
        ylim = c(0,1),
        names.arg = priimki, col = "orange",
        main = "Učinkovitost posameznega igralca ekipe PHX Suns")

dev.off()

pdf("slike/dendogram1.pdf")

barve1 = c("red", "green", "blue")
XX <- scale(as.matrix(phoenix[c(2,5,8,11:16,20,21)]))
e1 <- hclust(dist(XX), method = "ward.D")
p1 <- cutree(e1, k=3)
pairs(XX, col = barve1[p1])
dev.off()

pdf("slike/dendogram2.pdf")

plot(e1, hang=-1, cex=0.4, main = "Razdelitev igralcev v skupine glede na kvaliteto")
rect.hclust(e1,k=3,border=c("red","blue","green"))
legend("topright",
       c("Skupina 1", "Skupina 2","Skupina 3"),
       lty=c(1,1,1), col = c("red","blue","green"))
dev.off()


## From Shane McIntosh

library(rms)

# Prep data
Load(qt50)
dd <- datadist(qt50); options(datadist = "dd")
with(qt50, table(round(entropy, 5)))

# Find smallest model that fails
f <- ols(log1p(post_bugs) ~ entropy, data=qt50, x=T, y=T)
X <- f$x
n <- nrow(X)
y <- f$y
set.seed(1)
# Wild estimates on 22nd resample
for(i in 1 : 22) {
  j <- sample(1 : n, replace=TRUE)
  g <- lm.fit.qr.bare(X[j,], y[j])
  print(coef(g))
}
plot(X[j,], y[j], xlim=range(qt50$entropy))
abline(coef(g))
with(qt50, scat1d(entropy))
# Only 1 value of entropy > .0002, this bootstrap sample had none

set.seed(1)
validate(f, B=100)


## Function to do Wright-Fisher simulation with selection and a finite sample size
# using priors on Ne and s
# and specify initial sample allele frequency, f1samp (compare to wfs.r, which sets a prior on initial true allele freq f1)
# Sample at THREE time points

# f1samp: the initial sample allele frequency. Initial true allele freq will be sampled with this constraint.
# smin: the minimum for the selection coefficient uniform prior
# smax:
# c1: the size of the first sample (in # chromosomes)
# c2: the size of the second sample (in # chromosomes)
# c3: the size of the third sample (in # chromosomes)
# gen1: the number of generations for sample c2
# gen2: the number of generations for sample c3
# ne: a vector of possible Ne values. Simulation picks one to use.
# h: dominance effect

wfs_byf1samp_3samps <- function(f1samp=0.5, smin=-1, smax=1, c1=58, c2=48, c3=48, gen1=10, gen2=20, ne=100, hmin=0.5, hmax=0.5){
	tol <- .Machine$double.eps^0.5 # tolerane for equality. default tolerance in all.equal

	# make sure f1samp is possible given initial sample size (c1)
	# test whether difference from a possible sample size is less than tol
	if(!any(abs(f1samp - ((0:c1)/c1)) < tol)) stop(paste('f1samp=', f1samp, 'not possible given c1=', c1))

	# choose parameters for this simulation
	s <- runif(1, min=smin, max=smax) # selection coefficient
	h <- runif(1, min=hmin, max=hmax) # dominance coefficient
	if(length(ne)>1) thisne <- round(sample(ne, 1)) # ne has to be integer for binomial sampling
	if(length(ne)==1) thisne <- round(ne)

	# choose initial population frequency
	# brute force method: keep picking possible f1s until one produces the correct f1samp
	thisf1 <- -100
	while(abs(thisf1 - f1samp) >= tol){
		f1 <- runif(1, min=0, max=1) # pick a starting allele frequency
		thisf1 <- rbinom(1,c1,f1)/c1 # pick a first sample allele frequency that corresponds
	}

#	print(paste(f1, s, thisne))

	p <- f1 # current allele frequency
	waa <- 1+s # relative fitness of genotype AA
	wab <- 1+s*h
	wbb <- 1
	for(i in 1:gen2){
		x <- (waa*p^2 + wab*p*(1-p))/(waa*p^2 + wab*2*p*(1-p) + wbb*(1-p)^2) # probability of sampling allele A, given selection
		p <- rbinom(1,thisne,x)/thisne
#		print(paste(x,p))
		if(i==gen1){
			f2 <- p # take second sample
		}
	}
	f3 <- p # third sample

	f2samp <- rbinom(1,c2,f2)/c2 # second sample allele frequency
	f3samp <- rbinom(1,c3,f3)/c3 # third sample allele frequency

	# return values
#	out <- c(ne=thisne, f1=f1, s=s, gen=gen, f2=f2, f1samp=f1samp, f2samp=f2samp, fsdprime=stats[1], fsiprime=stats[2])
	out <- c(ne=thisne, f1=f1, s=s, h=h, gen1=gen1, gen2=gen2, f2=f2, f3=f3, f1samp=f1samp, f2samp=f2samp, f3samp=f3samp)
	return(out)
}


############################################################
# kmer_model_qmer.r
#
# Read in a file full of kmer coverages, and optimize
# a probabilistic model in which kmer coverage is simulated
# as follows:
#
# 1. Choose error or no as binomial(p.e)
# 2. Choose copy number as zeta(zp.copy)
# 3a. If error, choose coverage as gamma(shape.e, scale.e)
# 3b. If not, choose coverage as normal(copy*u.v, copy*var.v)
#
# Finally, output the ratio of being an error kmer vs being
# a non-error kmer for varying levels of low coverage.
#
# Because there is a lot of variation between each integer
# that isn't very gamma-like, I discretize the distribution
# during the optimization.
############################################################
library(VGAM)

# get ratio from input
if(length(commandArgs(trailingOnly=TRUE)) > 0) {
  ratio.goal = as.integer(commandArgs(trailingOnly=TRUE)[1])
} else {
  ratio.goal = 200
}

outf = "cutoff.txt"
max.copy = 30

############################################################
# est.cov
#
# Estimate the coverage mean by finding the max past the
# first valley.
############################################################
est.cov = function(d) {
  # make histogram
  hc = hist(d, breaks=seq(0,round(max(d))+1,1), plot=F)$counts

  # find first valley (or right before it)
  valley = hc[1]
  i = 2
  while(hc[i] < valley) {
    valley = hc[i]
    i = i + 1
  }

  # return max over the rest
  max.hist = hc[i]
  max.cov = i
  while(i <= length(hc)) {
    if(hc[i] > max.hist) {
      max.hist = hc[i]
      max.cov = i
    }
    i = i + 1
  }

  if(max.hist / valley < 1.5) {
    stop("Cannot identify reliable trusted k-mer coverage peak. Please verify the integrity of your dataset (e.g. by running kmer_hist.r). If there is no clear trusted k-mer distribution, the coverage is too low to correct these reads. If there is, please e-mail dakelley@umiacs.umd.edu and choose the cutoff by hand in the meantime")
    # print("Quake is struggling to identify a reliable trusted k-mer coverage peak. Most likely you just have low coverage (i.e. < 20x), but check the model's cutoff choice carefully before proceeding")
    #max.cov = 15
  }

  return( max.cov )
}

############################################################
# load data
############################################################
cov = scan("kmers.txt")

cov.est = est.cov(cov)

# filter extremes from kmers
cov = cov[cov < 1.25*max.copy*cov.est]
max.cov = max(cov)
max.cov.discrete = ceiling(max.cov)

# add epsilon to zeroes
cov[cov == 0] = 1e-12

############################################################
# model
############################################################
model = function(params) {
  #print(params)
  zp.copy = params[1]
  p.e = params[2]
  shape.e = params[3]
  scale.e = params[4]
  u.v = params[5]
  var.v = params[6]

  if(zp.copy <= 0 | p.e <= 0 | p.e >= 1 | shape.e <= 0 | scale.e <= 0 | var.v <= 0)
    return(list(like=-Inf))

  dcopy = dzeta(1:max.copy, p=zp.copy)

  kmers.probs = matrix(0, nrow=length(cov), ncol=(max.copy+1))

  # error
  dgamma.discrete = pgamma(1:max.cov.discrete, shape=shape.e, scale=scale.e) - pgamma(0:(max.cov.discrete-1), shape=shape.e, scale=scale.e)
  kmers.probs[,1] = p.e * dgamma.discrete[ceiling(cov)]
  #kmers.probs[,1] = p.e * dgamma(cov, shape=shape.e, scale=scale.e)

  # no error
  for(copy in 1:max.copy) {
    kmers.probs[,1+copy] = dcopy[copy] * (1-p.e) * dnorm(cov, mean=(copy*u.v), sd=sqrt(copy*var.v))
  }

  logprobs = log(apply(kmers.probs, 1, sum))
  #print(sum(logprobs))
  return(list(like=-sum(logprobs), probs=kmers.probs))
}

############################################################
# display.params
############################################################
display.params = function(x, print) {
  if(print) {
    cat("zp.copy: ",x[1],"\n", file=outf, append=T)
    cat("p.e: ",x[2],"\n", file=outf, append=T)
    cat("shape.e: ",x[3],"\n", file=outf, append=T)
    cat("scale.e: ",x[4],"\n", file=outf, append=T)
    cat("u.v: ",x[5],"\n", file=outf, append=T)
    cat("var.v: ",x[6],"\n", file=outf, append=T)
  }
  return(list(zp.copy=x[1], p.e=x[2], shape.e=x[3], scale.e=x[4], u.v=x[5], var.v=x[6]))
}

############################################################
# cutoff
#
# Use a grid search to find the coverage number that
# makes the ratio of error probability to nonerror
# probability closest to ratio.goal
############################################################
ratios = function(cov, p) {
  dcopy = dzeta(1:max.copy, p=p$zp.copy)
  error = p$p.e * dgamma(cov, shape=p$shape.e, scale=p$scale.e)
  no.error = 0
  for(copy in 1:max.copy) {
    no.error = no.error + dcopy[copy] * (1-p$p.e) * dnorm(cov, mean=(copy*p$u.v), sd=sqrt(copy*p$var.v))
  }
  return(error/no.error)
}

error.max = function(p) {
  cov.max = 0
  dens.max = 0
  for(c in seq(0,30, .01)) {
    dens = dgamma(c, shape=p$shape.e, scale=p$scale.e)
    if(dens > dens.max) {
      dens.max = dens
      cov.max = c
    }
  }
  return(cov.max)
}

cutoff = function(p) {
  cut.start = error.max(p)

  #ratio.goal = exp(3 + .05*p$u.v)
  #ratio.goal = 1000
  cov.best = 0
  ratio.best = abs(ratios(0,p) - ratio.goal)
  for(c in seq(cut.start, 25, .01)) {
    r = abs(ratios(c,p) - ratio.goal)
    if(r < ratio.best) {
      ratio.best = r
      cov.best = c
    }
    #cat(c," ",ratios(c,p),"\n")
  }
  return(cov.best)
}

############################################################
# action
############################################################
init = c(2, .9, .8, .5, cov.est, 3*cov.est)
#ol = c(.001, .001, 0.001, 0, 10)
#ou = c(20, .999, 20, 1000, Inf)
#opt = optim(init, function(x) model(x)$like, lower=ol, upper=ou, method="L-BFGS-B", control=list(trace=1, maxit=1000))
opt = optim(init, function(x) model(x)$like, method="BFGS", control=list(trace=1, maxit=1000))
cat('value:',opt$value,"\n")
p=display.params(opt$par, F)

cut = cutoff(p)
cat(cut,"\n", file=outf)
display.params(opt$par, T)
write(cut, file=outf, append=T)

max.x = 250
dcopy = dzeta(1:max.copy, p=p$zp.copy)

kmers.probs = matrix(0, nrow=max.x, ncol=(max.copy+1))
# error
#kmers.probs[,1] = p$p.e * (ppareto(2:251, loc.e, p$shape.e) - ppareto(1:250, loc.e, p$shape.e))
kmers.probs[,1] = p$p.e * (pgamma(1:250, shape=p$shape.e, scale=p$scale.e) - pgamma(0:249, shape=p$shape.e, scale=p$scale.e))

# no error
for(copy in 1:max.copy) {
  kmers.probs[,1+copy] = dcopy[copy] * (1-p$p.e) * (pnorm(1:250, mean=(copy*p$u.v), sd=sqrt(copy*p$var.v)) - pnorm(0:249, mean=(copy*p$u.v), sd=sqrt(copy*p$var.v)))
}

all.dist = apply(kmers.probs, 1, sum)
err.dist = kmers.probs[,1]/p$p.e
norm.dist = apply(kmers.probs[,2:(1+max.copy)], 1, sum)/(1-p$p.e)

en.ratios = err.dist*p$p.e/norm.dist/(1-p$p.e)


par_initializeR <- function(data,model="Multinomial", init_pars,end_beta, period_start, init_state_num, fix_pars, opt_num = 100,... ) {

  if(period_start[1]==1){
    n_period=length(period_start)
  }
  else{
    n_period=length(period_start)+1
  }

  negLL_func<- function(pars,period_start = parent.frame()$period_start, init_state_num = parent.frame()$init_state_num,
                          ftime = parent.frame()$ftime, fix_pars = parent.frame()$fix_pars){

    pars=c(exp(c(pars[1:n_period])),invlogit(pars[(n_period+1):(2*n_period)]))
    ypred <- model_deterministic_simulateR(init_obs = init_state_num, period_start = period_start,
                                           times = ftime, pars = pars, fix_pars = fix_pars)

    p_new_pred_n <- round(ypred[, 10])
    p_new_pred_prob <- ypred[, 11]
    rd_new_pred_n <- round(ypred[, 12])
    r_new_pred_prob <- ypred[, 13]
    d_new_pred_prob <- ypred[, 14]
    p <- c()
    if(model=="Poisson"){
      ypred <-  p_new_pred_n  *  p_new_pred_prob
      p<-try(dpois(data$Confirmed, round(ypred),log=T),silent=T)
      if(any(is.nan(p))||any(p==-Inf)){
        logL <- -Inf
      }
      else{
        logL <- sum(p)
      }
    }
    else if(model=="Binomial"){
      p <- dbinom(data$Confirmed,round( p_new_pred_n), p_new_pred_prob, log = T)
      if(any(p == -Inf) || any(is.nan(p))){
        logL <- -Inf
      }else{
        logL <- sum(p)
      }
    }
    else if(model=="Multinomial"){
      for(i in 1:dim(ypred)[1]){
        p[i] = try(dbinom(data$Confirmed[i], round(p_new_pred_n[i]) , p_new_pred_prob[i], log = T),silent=T)

        obs_size = data$Confirmed[max(i - 1, 1)]
        pred_size = round(ypred[max(i - 1, 1),"P"])

        if((data$Recovered[i] + data$Deceased[i]) > pred_size){
          logL = -Inf
        }
        else{
          p[i] = p[i] + try(dmultinom(c(round(c(data$Recovered[i], data$Deceased[i])), pred_size - (data$Recovered[i] + data$Deceased[i])),
                                      pred_size, c(r_new_pred_prob[i], d_new_pred_prob[i], 1-r_new_pred_prob[i]-d_new_pred_prob[i]),
                                      log = T),silent=T)
        }
      }
      if(any(p ==-Inf) || any(is.nan(p))){
        logL <- -Inf
      }else{
        logL <- sum(p)
      }
    }

    return(-logL)
  }
  ftime <- 1:dim(data)[1]
  result_mat <- matrix(NA, opt_num, n_period * 2 + 2)
  colnames(result_mat) <- c("likelihood", "convergence", unlist(lapply(c("b","r") , function(y) lapply(1:n_period, function(x) paste(y,x, sep = "")))))
  result_mat[, 1] <- -Inf
  cat("Finding MLE", fill = T)
  i = 1
  while(i <= opt_num) {
    passed <- FALSE
    while (!passed) {
      if(is.null(init_pars)){
        initial_param<-c(runif(n_period,0.1,end_beta),rep(0.2,times=n_period))
        end_beta
        }
     else{
       initial_param<-init_pars
     }
      mle_opt <- try(optim(par = c(log(c(initial_param[1:n_period])),logit(c(initial_param[(n_period+1):(2*n_period)]))), f =  negLL_func,init_state_num = init_state_num,period_start=period_start,fix_pars=fix_pars,
                           ftime =  ftime,hessian = FALSE),silent=T)
      passed <- exists("mle_opt")
    }

    if(class(mle_opt) == "try-error"){
      next
    }

    try(result_mat[i, 1] <- mle_opt$value,silent=T)
    try(result_mat[i, 2] <- mle_opt$convergence,silent=T)
    try(result_mat[i, (3:(n_period+2))] <- exp(mle_opt$par[1:n_period]),silent=T)
    try(result_mat[i,(n_period+3):(2*n_period+2)]<-invlogit(mle_opt$par[(n_period+1):(2*n_period)]),silent=T)
    cat(i, "MLE run finished!", fill = T)
    rm(mle_opt)

    i = i+1
  }

  result <- result_mat[which(result_mat[, 1] == min(result_mat[which(result_mat[,1]!=-Inf,1)]))[1], ]

  return(result)
}


# Functions to extract the neighborhood of a post in a tree
# Function to detect the changepoints of a tree w.r.t time
# between posts
# author: Alberto Lumbreras
##############################################################
library(changepoint)

#t3_2eh5kz    141
#t3_2dyzfs     36
#t3_2dz84u     11
#t3_2dz884     81
#t3_2dz88i     84
#t3_2e049q      7
#t3_2e04x4     11
#t3_2e05bb     14
DEBUG <- FALSE

changepoints.cp <- function(gp, vertical=FALSE, horizontal=FALSE){
  # Changepoints based of changepoint detection algorithms over the full sequence
  # Detect the posts that took a time too long to the previous post
  # - to its parent (vertical changepoint)
  # - to its siblings (horizontal changepoints)
  if(!is.numeric(V(gp)$date)){
    stop('Dates are not numeric')
  }

  breakpoints.v <- c()
  breakpoints.h <- c()

  # Vertical changepoints (from root to every leaf)
  ##################################################
  if(vertical==TRUE){
    leafs <- which(ego_size(gp, 1, mode='in', mindist=1)==0)
    root <-  which(ego_size(gp, 1, mode='out', mindist=1)==0)
    for(j in 1:length(leafs)){
      #j<-17
      # Path and its deltas
      path <- unlist(shortest_paths(gp, root, to=leafs[j], mode='all')$vpath)
      if(length(path)<5){
        next
      }
      dates <- as.numeric(V(gp)[path]$date)
      bp <- cpts(cpt.meanvar(dates, class=TRUE, method="PELT"))+1
      breakpoints.v <- c(breakpoints.v, path[bp])
    }
    breakpoints.v <- names(breakpoints.v)

  }

  # Horizontal changepoints (between siblings)
  ############################################
  if(horizontal==TRUE){
    candidates.h <- c()
    dist.matrix <- distances(gp, mode = 'in')
    for (i in 1:nrow(dist.matrix)){
      children.mask <- dist.matrix[i,]==1
      if(sum(children.mask)>3){
        children <- colnames(dist.matrix)[which(children.mask)]

        # sort children by date
        children <- children[order(V(gp)[children]$date)]
        candidates.h <- c(candidates.h, children)
        dates <- as.numeric(V(gp)[children]$date)

        # this both cases should give the same result
        if(is.unsorted(dates)){
          stop("Posts are not sorted by date")
        }
        else{
          bp <- cpts(cpt.meanvar(dates, class=TRUE, method="PELT"))+1
          breakpoints.h <- c(breakpoints.h, children[bp])

          #colors <- rep("black", length(dates))
          #colors[bp] <- 'red'
          #plot(dates, col=colors, pch=19, cex=0.5)
          #title("debug")
        }
      }
    }
  }
  # Breakpoint only if both in vertical
  # and horizontal
  ########################################
  if(vertical && horizontal){
    # include posts that are breakpoints in vertical and horizontal
    # and posts that are vertical breakpoints but have no chance to be horizontal breakpoints
    # because they have not enough siblings
    breakpoints <- union(intersect(breakpoints.v, breakpoints.h),
                         setdiff(breakpoints.v, candidates.h))
  }
  if(vertical && !horizontal){
    breakpoints <- breakpoints.v
  }
  if(!vertical && horizontal){
    breakpoints <- breakpoints.h
  }

  list(breakpoints.vh = V(gp)[breakpoints],
       breakpoints.v = V(gp)[breakpoints.v],
       breakpoints.h = V(gp)[breakpoints.h])
}

##########################"
# Test neighborhoods
#########################
# Debug changepoint detection
if(DEBUG){
  rad <- 4
  max.neighbors <- 20
  j <- 1

  #breakpoints <- changepoints.deltasequence(gp, vertical=T, horizontal=T)
  #breakpoints <- changepoints.bertrand(gp, vertical=T, horizontal=T)
  breakpoints <- changepoints.cp(gp, vertical=T, horizontal=T)

  breakpoints.h <- breakpoints$breakpoints.h
  breakpoints.v <- breakpoints$breakpoints.v
  breakpoints.vh <- breakpoints$breakpoints.vh

  #Add breakpoint info as attribute
  V(gp)$bp.v <- FALSE
  V(gp)$bp.h <- FALSE
  V(gp)$bp.vh <- FALSE
  V(gp)[breakpoints.v]$bp.v <- TRUE
  V(gp)[breakpoints.h]$bp.h <- TRUE
  V(gp)[breakpoints.vh]$bp.vh <- TRUE

  # Detect and plot neighborhoods
  test <- function(){

    #Rprof()
    for(i in 1:vcount(gp)){
      cat("\nvcount:", vcount(gp))
      cat("\n******", i)
      eg <- neighborhood.temporal(gp, i, 3, breakpoints.v, breakpoints.h)
      #plot(eg)
    }
    #summaryRprof()$by.total

  }
  library('lineprof')
  l <- lineprof(test())

  if(FALSE){
    par(mfrow=c(1,1))
    gp_ <- as.undirected(gp)
    la = layout_as_tree(gp_, mode='out', root=which.min(V(gp_)$date), circular=FALSE)
    V(gp_)$size <- 1

    V(gp_)$color <- 'black'
    #V(gp_)[V(eg)$name]$color <- 'darkgreen'
    #V(gp_)[V(eg)$name]$size <- 2
    V(gp_)[j]$size <- 3
    V(gp_)[j]$color <- 'green'
    V(gp_)[breakpoints.v]$color <- 'orange'
    V(gp_)[breakpoints.h]$color <- 'yellow'
    V(gp_)[breakpoints.vh]$color <- 'red'
    plot(gp_,
         layout = la,
         #vertex.label = order(V(gp)),
         vertex.label = NA,
         edge.width = 0.2,
         edge.arrow.size=0.02,
         asp=9/16,
         margin=-0.15)
    }
}

BERTRAND <- FALSE
if(BERTRAND){
  # Show that score>2 is not enough. It should be score>10.
  # but this is quite arbitrary...
  posts <- V(gp)[which(ego_size(gp, 2, mode='out', mindist = 1)==1)]
  dates <- sort(posts$date)
  plot(dates)
  deltas <- diff(dates)
  bp <- c()
  scores <- rep(1, length(dates))
  for(i in 2:length(deltas)){
    score <- (deltas[i]-deltas[i-1])/deltas[i-1]
    scores[i+1] <- score
    if(score>10){
      bp <- c(bp, i+1)
    }
  }
  colors <- rep("black", length(dates))
  colors[bp] <- 'red'
  plot(dates, col=colors, pch=19, cex=0.5)
}
CHANGEPOINT <- FALSE
if(CHANGEPOINT){

  # Horizontal
  posts <- V(gp)[which(ego_size(gp, 2, mode='out', mindist = 1)==1)]
  dates <- sort(posts$date)
  res <- cpt.meanvar(dates, class=TRUE, method="PELT")
  #res <- cpt.meanvar(dates, penalty="None", class=TRUE, method="SegNeigh") # slow
  plot(res)

  bp <- cpts(res)+1
  colors <- rep("black", length(dates))
  colors[bp] <- 'red'
  plot(dates, col=colors, pch=19, cex=0.5)

  # Vertical
  leafs <- which(ego_size(gp, 1, mode='in', mindist=1)==0)
  root <-  which(ego_size(gp, 1, mode='out', mindist=1)==0)
  branches <- shortest_paths(gp, root, to=leafs, mode='all')$vpath
  depths <- unlist(lapply(branches, length))
  longest.branch <- which.max(depths)
  path <- unlist(shortest_paths(gp, root, to=leafs[longest.branch], mode='all')$vpath)
  posts <- V(gp)[path]
  dates <- sort(posts$date)
  res <- cpt.meanvar(dates, class=TRUE, method="PELT")
  plot(res)

  bp <- cpts(res)+1
  colors <- rep("black", length(dates))
  colors[bp] <- 'red'
  plot(dates, col=colors, pch=19, cex=1)

}

##############################
##############################
# Sequential show (for demos)
if(FALSE){
  dates <- as.numeric(V(gp_)$date)
  steps <- seq(min(dates), max(dates), length.out = 700)
  for(i in 1:100){
    V(gp_)$color <- 'black'
    V(gp_)[breakpoints]$color <- 'red'
    inactive <- as.numeric(V(gp_)$date) > steps[i]
    V(gp_)[inactive]$color <- 'white'
    plot(gp_,
         layout = la,
         vertex.size = 1,
         vertex.label = NA,
         edge.width = 0.2,
         edge.arrow.size=0.02,
         asp=9/16,
         margin=-0.15)
    title((steps[i]-min(dates))/3600)
    readline(paste(i, " next..."))
  }
}


xx <- x <- 1:100
xx[x %% 3 == 0] <- "Fizz"
xx[x %% 5 == 0] <- "Buzz"
xx[x %% 15 == 0] <- "FizzBuzz"
xx


rm(list = ls())

# input path
fileName="~/fuzzy.dat"

conn=file(fileName, open="r")
linn=readLines(conn)

# contains membership functions that fuzzify input variables and the decision
# results are fuzzy sets
# line 1 theta
# line 2 h_low[theta]
# line 3 h_mid[theta]
# line 4 h_hgh[theta]
# line 5 x ranging [0,1]
# line 6 Q_YES
# line 7 Q_MAYBE
# line 8 Q_NO

######### start reading #########
# load data from log file
# line 1 theta
lineNr = 1; t <- unlist(strsplit(linn[lineNr], split=" "));
theta_name = expression("" * theta)
theta <- vector()
for (j in 2:length(t)){
  theta <- c(theta, as.numeric(t[j]))
}

# line 2 h_low[theta]
lineNr = 2; t <- unlist(strsplit(linn[lineNr], split=" "));
h_low_name = expression("h LOW(" * theta * ")")
h_low <- vector()
for (j in 2:length(t)){
  h_low <- c(h_low, as.numeric(t[j]))
}

# line 3 h_mid[theta]
lineNr = 3; t <- unlist(strsplit(linn[lineNr], split=" "));
h_mid_name = expression("h MID(" * theta * ")")
h_mid <- vector()
for (j in 2:length(t)){
  h_mid <- c(h_mid, as.numeric(t[j]))
}

# line 4 h_hgh[theta]
lineNr = 4; t <- unlist(strsplit(linn[lineNr], split=" "));
h_hgh_name = expression("h HGH(" * theta * ")")
h_hgh <- vector()
for (j in 2:length(t)){
  h_hgh <- c(h_hgh, as.numeric(t[j]))
}

# line 5 x
lineNr = 5; t <- unlist(strsplit(linn[lineNr], split=" "));
x_name = expression("" * x * "")
x <- vector()
for (j in 2:length(t)){
  x <- c(x, as.numeric(t[j]))
}

# line 6 q_yes[x]
lineNr = 6; t <- unlist(strsplit(linn[lineNr], split=" "));
q_yes_name = expression("q YES(" * x * ")")
q_yes <- vector()
for (j in 2:length(t)){
  q_yes <- c(q_yes, as.numeric(t[j]))
}

# line 7 q_maybe[x]
lineNr = 7; t <- unlist(strsplit(linn[lineNr], split=" "));
q_maybe_name = expression("q MAYBE(" * x * ")")
q_maybe <- vector()
for (j in 2:length(t)){
  q_maybe <- c(q_maybe, as.numeric(t[j]))
}

# line 8 q_no[x]
lineNr = 8; t <- unlist(strsplit(linn[lineNr], split=" "));
q_no_name = expression("q MAYBE(" * x * ")")
q_no <- vector()
for (j in 2:length(t)){
  q_no <- c(q_no, as.numeric(t[j]))
}

close(conn)
######### finished reading #########

#########  export pdf plot 2 vs. 1
pdf(file='~/h_low.pdf', width = 10, height = 7)

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(5.0, 6.5, 0.5, 0.5))

plot(theta, h_low,
     xlab=theta_name,
     ylab=h_low_name,
     col="red",
     type="l",
     lwd=6,
     las=1,
     #font = 1,
     #family = "serif",
     cex.axis=1.8,
     cex.lab=2.8
)
box(); grid()
dev.off()

#########  export pdf plot 3 vs. 1
pdf(file='~/h_mid.pdf', width = 10, height = 7)

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(5.0, 6.5, 0.5, 0.5))

plot(theta, h_mid,
     xlab=theta_name,
     ylab=h_mid_name,
     col="blue",
     type="l",
     lwd=6,
     las=1,
#      font = 1,
#      family = "serif",
     cex.axis=1.8,
     cex.lab=2.8
)
box(); grid()
dev.off()

#########  export pdf plot 4 vs. 1
pdf(file='~/h_hgh.pdf', width = 10, height = 7)

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(5.0, 6.5, 0.5, 0.5))

plot(theta, h_hgh,
     xlab=theta_name,
     ylab=h_hgh_name,
     col="blue",
     type="l",
     lwd=6,
     las=1,
     #font = 1,
     #family = "serif",
     cex.axis=1.8,
     cex.lab=2.8
)
box(); grid()
dev.off()

#################################
colors=c(rgb(1,0,0,1),rgb(0,1,0,1),rgb(0,0,1,1))

#########  export pdf plot 2,3,4 vs. 1
pdf(file='~/h.pdf', width = 5, height = 3)

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(3.3, 4.5, 0.5, 0.5),mgp=c(2.4, 0.7, 0))

plot(theta, h_hgh,
     xlab=theta_name,
     ylab=expression("h("*theta*")"),
     col=colors[1],
     type="l",
     lwd=5,
     las=1,
     #font = 1,
     #family = "serif",
     cex.axis=1.5,
     cex.lab=2.1 ,
     lty=5,
     axes=F,
     frame.plot=T
)

axis(2, at=c(0, 0.5, 1.0),las=1,tck=-0.03,cex.axis=1.5)
axis(1,,cex.axis=1.5,tck=-0.03)
# points(theta, h_hgh,
#        xlab="",
#        ylab="",
#        col="black",
#        #type="o",
#        lwd=2,
#        pch=20
# )

lines(theta, h_mid,
      xlab=theta_name,
      ylab=h_mid_name,
      col=colors[2],
      type="l",
      lwd=5,
      lty=1
)
# points(theta, h_mid,
#        xlab="",
#        ylab="",
#        col="black",
#        #type="o",
#        lwd=2,
#        pch=5
# )

lines(theta, h_low,
      xlab=theta_name,
      ylab=h_low_name,
      col=colors[3],
      type="l",
      lwd=5,
      lty=2
)
# points(theta, h_low,
#        xlab="",
#        ylab="",
#        col="black",
#        #type="o",
#        lwd=2,
#        pch=12
# )

# plot on top again
lines(theta, h_hgh,
     xlab=theta_name,
     ylab=expression("h("*theta*")"),
     col=colors[1],
     type="l",
     lwd=5,
     las=1,
     #font = 1,
     #family = "serif",
     cex.axis=1.5,
     cex.lab=2.1 ,
     lty=5
)

legend("left",
       c("HIGH","MID","LOW"),
       lty=c(1,1,1),
       lwd=c(4,4,4),
       col=colors,
       bty = "n",
       cex=1.3
)  #,
# places a legend at the appropriate place, puts text in the legend, gives the legend appropriate symbols (lines)
# gives the legend lines the correct color and width
box();
#grid()
dev.off()

#########  export pdf plot 6,7,8 vs. 5
pdf(file='~/q.pdf', width = 5, height = 3)

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(3.3, 4.5, 0.5, 0.5),mgp=c(2.4, 0.7, 0))

plot(x, q_yes,
     xlab=x_name,
     ylab=expression("q("*x*")"),
     col=colors[1],
     type="l",
     lwd=5,
     las=1,
     #font = 1,
     #family = "serif",
     cex.axis=1.5,
     cex.lab=2.1,
     axes=F,
     frame.plot=T,
     lty=5
)
axis(2, at=c(0, 0.5, 1.0),las=1,tck=-0.03,cex.axis=1.5)
axis(1,,cex.axis=1.5,tck=-0.03)

lines(x, q_maybe,
      xlab=x_name,
      ylab=q_maybe_name,
      col=colors[2],
      type="l",
      lwd=5,
      lty=1
)
lines(x, q_no,
      xlab=x_name,
      ylab=q_no_name,
      col=colors[3],
      type="l",
      lwd=5,
      lty=2
)
legend("center",
       c("YES","MAY","NO"),
       lty=c(1,1,1),
       lwd=c(4,4,4),
       col=colors,
       cex=1.3,
       bty = "n"
) # ,
#box();
#grid()
dev.off()


# Source: https://tensorflow.rstudio.com/tutorials/beginners/basic-ml/tutorial_basic_classification/

library(keras)
library(tidyr)
library(ggplot2)

# Load data
fashion_mnist <- dataset_fashion_mnist()

c(train_images, train_labels) %<-% fashion_mnist$train
c(test_images, test_labels) %<-% fashion_mnist$test

class_names = c('T-shirt/top',
                'Trouser',
                'Pullover',
                'Dress',
                'Coat',
                'Sandal',
                'Shirt',
                'Sneaker',
                'Bag',
                'Ankle boot')

dim(train_images)
dim(train_labels)
train_labels[1:20]
dim(test_images)
dim(test_labels)

image_1 <- as.data.frame(train_images[1, , ])
colnames(image_1) <- seq_len(ncol(image_1))
image_1$y <- seq_len(nrow(image_1))
image_1 <- gather(image_1, "x", "value", -y)
image_1$x <- as.integer(image_1$x)

ggplot(image_1, aes(x = x, y = y, fill = value)) +
  geom_tile() +
  scale_fill_gradient(low = "white", high = "black", na.value = NA) +
  scale_y_reverse() +
  theme_minimal() +
  theme(panel.grid = element_blank())   +
  theme(aspect.ratio = 1) +
  xlab("") +
  ylab("")

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

# Split data set
train_images <- train_images / 255
test_images <- test_images / 255

par(mfcol=c(5,5))
par(mar=c(0, 0, 1.5, 0), xaxs='i', yaxs='i')
for (i in 1:25) {
  img <- train_images[i, , ]
  img <- t(apply(img, 2, rev))
  image(1:28, 1:28, img, col = gray((0:255)/255), xaxt = 'n', yaxt = 'n',
        main = paste(class_names[train_labels[i] + 1]))
}

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

# Build model

model <- keras_model_sequential()
model %>%
  layer_flatten(input_shape = c(28, 28)) %>%
  layer_dense(units = 128, activation = 'relu') %>%
  layer_dense(units = 10, activation = 'softmax')

model %>% compile(
  optimizer = 'adam',
  loss = 'sparse_categorical_crossentropy',
  metrics = c('accuracy')
)

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

# Fit model

model %>% fit(train_images, train_labels, epochs = 5, verbose = 2)

score <- model %>% evaluate(test_images, test_labels, verbose = 0)

cat('Test loss:', score$loss, "\n")

cat('Test accuracy:', score$acc, "\n")

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

# Make predictions

predictions <- model %>% predict(test_images)

predictions[1, ]

which.max(predictions[1, ])

class_pred <- model %>% predict_classes(test_images)
class_pred[1:20]

test_labels[1]

par(mfcol=c(5,5))
par(mar=c(0, 0, 1.5, 0), xaxs='i', yaxs='i')
for (i in 1:25) {
  img <- test_images[i, , ]
  img <- t(apply(img, 2, rev))
  # subtract 1 as labels go from 0 to 9
  predicted_label <- which.max(predictions[i, ]) - 1
  true_label <- test_labels[i]
  if (predicted_label == true_label) {
    color <- '#008800'
  } else {
    color <- '#bb0000'
  }
  image(1:28, 1:28, img, col = gray((0:255)/255), xaxt = 'n', yaxt = 'n',
        main = paste0(class_names[predicted_label + 1], " (",
                      class_names[true_label + 1], ")"),
        col.main = color)
}

img <- test_images[1, , , drop = FALSE]
dim(img)

predictions <- model %>% predict(img)
predictions

# subtract 1 as labels are 0-based
prediction <- predictions[1, ] - 1
which.max(prediction)

class_pred <- model %>% predict_classes(img)
class_pred


"
С клавиатуры ввести целое число N. Рассчитать соответствующий числу день недели
месяц и год, исходя из того, что в каждом месяце 30 дней, 1 задает понедельник января
2 – вторник января и т.д. Вывести результат в виде строки следующего шаблона:
«Введенное значение N соответствует среде марта, 22-й год».
"

{
  number <- as.integer(readline("Введите число -> "))
  year <- number %/% 360 + 1
  number <- number %% 360
  month <- (number %/% 30) + 1
  day <- number %% 7
  monthwrite <- switch(
    month,
    "Январь",
    "Февраль",
    "Март",
    "Апрель",
    "Май",
    "Июнь",
    "Июль",
    "Август",
    "Сентябрь",
    "Октябрь",
    "Ноябрь",
    "Декабрь"
  )
  daywrite <- switch (
    day,
    "Понедельник",
    "Вторник",
    "Среда",
    "Четверг",
    "Пятница",
    "Суббота",
    "Воскресенье"
  )

  print(paste(
    "Введенное значение N соответствует",
    day ,
    daywrite,
    monthwrite,
    year,
    "год"
  ))
}


require(tictoc)

dyn.load("chartr-ModelSpecFast.so")
interval=0.00001
LUT=qnorm(seq(interval,1-interval,interval))
n=length(LUT);
nmc = 10000;
rts <- resps <- numeric(nmc)
z = 0.04;
v = 0.4;
eta=0.003;
aU = 0.08
aL = 0;
stoch.s = 0.1;
dt = 0.001;
maxTimeStep = 4000;
tic("fast rnd")
out=.C("DDM",z=z,v=v,aU=aU,aL=aL, s=stoch.s,dt=dt, response=resps,rt=rts,n=nmc,maxTimeStep=maxTimeStep,
                rangeLow =as.integer(0), rangeHigh = as.integer(n-1), randomTable = as.double(LUT));
L1 = mean(out$rt)
S1 = sum(out$response==1)
toc()

dyn.load("chartr-ModelSpec.so")
tic("slowrnd")
out=.C("DDM",z=z,v=v,aU=aU,aL=aL, s=stoch.s,dt=dt, response=resps,rt=rts,n=nmc,maxTimeStep=maxTimeStep,
       rangeLow =as.integer(0), rangeHigh = as.integer(n-1), randomTable = as.double(LUT));
L2 = mean(out$rt)
S2 = sum(out$response==1)
toc()


## Insang Song (isong@uoregon.edu)
## Spatially Enhanced and Entropy-Derived MATrix (SpEED-MAT)
speedmat <- function(sf,
                     mode = "CDE", # "CE"/"DE"/"CDE"
                     input_vars = c(), # Contiguity Distance Entropy
                     bandwidth = NULL, # bandwidth: Currently only supports gaussian
                     q_jsd = 0.05,     # quantile of j-s divergence
                     kneigh = NULL,    # k-nearest neighbor for point data
                     queen = TRUE,     # Queen's contiguity for "C" mode for polygon data
                     cutoff_dist = NULL,
                     cutoff_weightd = 0.001,
                     cutoff_weightc = 0.001,
                     sup_factor = 0.5){
    if (is.null(bandwidth) & grepl("D", mode))
        stop("No bandwidth was entered")
    if (length(input_vars) == 0)
        stop("No input variable were specified")
    if (!grepl("E", mode))
        stop("Please use the methods for standard spatial weight matrices for non-entropy matrices")
    if (!is.null(bandwidth)) {
        cutoff_dist <- bandwidth
    }
    sfp <- sf[1,]

    sf_ent <- sf %>%
        dplyr::select(input_vars) %>%
        st_set_geometry(NULL) %>%
        mutate_at(.vars = vars(input_vars),
                  .funs = list(~as.vector(scale(.)))) %>%
        mutate_at(.vars = vars(everything()),
                  .funs = list(~.+abs(min(.)))) %>%
        as.matrix %>%
        philentropy::JSD(.)
    sf_ent <- sf_ent * (sf_ent <= quantile(sf_ent, q_jsd))
    sf_ent_ex <- exp(-1 * sf_ent)
    sf_ent_f <- (sf_ent_ex * (sf_ent_ex != 1))

    if (grepl("C", mode)){
        if (queen){
            pat <- 'F***T****'
        } else {
            pat <- 'F***1****'
        }

        if (any(st_is(sfp, 'POLYGON'), st_is(sfp, 'MULTIPOLYGON'), st_is(sfp, "POLYGON Z"), st_is(sfp, "MULTIPOLYGON Z")))
            {sf_touch <- st_relate(sf, pattern = pat) %>% #poly2nb(sf, queen = queen) %>%
                as(., 'matrix')#nb2mat
             sf_touch_ <- sf_touch
            } else {
            sf_touch <- st_nn(sf, sf, k = kneigh + 1, sparse = FALSE, returnDist = TRUE) #%>%
            sf_touch_ <- sf_touch
            sf_touch_nn <- sf_touch$nn
            diag(sf_touch_nn) <- FALSE
            sf_touch <- sf_touch_nn
            }
        # 122820
        sf_invdv <- ((1-sup_factor)*sf_touch) + (sup_factor * sf_ent_f)
    }
    if (grepl("D", mode))
    {
        if (any(st_is(sfp, 'POLYGON'), st_is(sfp, 'MULTIPOLYGON'), st_is(sfp, "POLYGON Z"), st_is(sfp, "MULTIPOLYGON Z"))) {
            sf_interd <- as(st_distance(st_centroid(sf)), 'matrix')
        } else {
            sf_interd <- as(st_distance(sf), 'matrix')
        }
        sf_interd <- sf_interd * (sf_interd <= cutoff_dist)
        sf_invd <- exp(-1 * ((sf_interd^2)/(bandwidth^2)))
        sf_invd <- sf_invd * (sf_invd != 1)
        diag(sf_invd) <- 0

        if (grepl("^C", mode)) {
            if (!any(st_is(sfp, 'POLYGON'), st_is(sfp, 'MULTIPOLYGON'), st_is(sfp, "POLYGON Z"), st_is(sfp, "MULTIPOLYGON Z")))
            {
                sf_touch_ <- sf_touch
                sf_touch_d <- do.call(c, sf_touch_$dist)
                sf_touch_d <- sf_touch_d[sf_touch_d != 0]
                sf_touch_nn[sf_touch_nn == TRUE] <- sf_touch_d
                sf_touch <- sf_touch_nn
            }

            sf_invdv <- ((1-sup_factor) * (sf_touch * sf_invd)) + (sup_factor * sf_ent_f)
            sf_invdv <- sf_invdv * (sf_invdv >= cutoff_weightc)
        } else {
            sf_invdv <- ((1-sup_factor)* (sf_invd * (sf_invd >= cutoff_weightd))) + (sup_factor * sf_ent_f)
            sf_invdv <- sf_invdv * (sf_invdv >= cutoff_weightc)
        }
    }

    # error check
    checksum <- apply(sf_invdv, 1, sum)
    if (any(is.nan(checksum) | checksum == 0)){
        addr_check <- (is.nan(checksum) | checksum==0)
        diag(sf_invdv)[addr_check] <- 1
    }
    speedmat <- sf_invdv / apply(sf_invdv, 1, sum)
    return(speedmat)
}


# SMAA-u4: Uncertainty represented by 3 quantiles, with fixed quantile weights
# (Keefer-Bodily)

SMAA4<-function(nI,J,runs,input,dstbn,ta,la){

  # Assign input to x (Deterministic SMAA)
  x1=input$v1
  x2=input$v2
  x3=input$v3
  x=array(rep(0,3*nI*J),c(3,nI,J))
  x[1,,] = x1
  x[2,,] = x2
  x[3,,] = x3

  # Generate matrix of weights (inter-criteria importance)
  w=wts(nC, runs)

  # Compute utilities
  ut=array(rep(0,3*nI*J),c(3,nI,J))
  u=array(rep(0,runs*nI*J),c(runs,nI,J))
  for(j in 1:J)
  {
    cutoffs = c(0,ta[j],1)
    values = c(0,la[j],1)
    xt = as.vector(x[,,j])
    xt_pvf = smaa.pvf(xt,cutoffs=cutoffs,values=values,outOfBounds="clip")
    ut[,,j] = matrix(xt_pvf,3,nI)
  }
  ut = 0.185*ut[1,,] + 0.63*ut[2,,] + 0.185*ut[3,,]
  for(i in 1:runs){u[i,,] = ut}

  # Run SMAA
  b = smaa(u,w)$ra
  b = unclass(b)
  b
}


library(ape)
library(dplyr)
library(reshape2)

## Read in fasta file
    data <- read.FASTA(file = "postGubbins.filtered_polymorphic_sites.fasta") # Read input multi fasta file generate from gubbins output

## Calculate the pair-wise distance

    out <-  dist.dna(data,model="N",pairwise.deletion=TRUE,as.matrix=T) ## Full matrix
    out[lower.tri(out,diag=T)] <- NA ## take upper triangular matrix, when needed
   # out

D_out_melt = melt(as.matrix(out), varnames = c("row", "col"))
#D_out_melt

names(D_out_melt) <- c("Isolate1","Isolate2","SNPDiff")

D_out_melt_sorted = arrange(D_out_melt, SNPDiff)
#head(D_out_melt_sorted)

write.csv(D_out_melt_sorted, "postGubbins.filtered_polymorphic_sites_melt_sorted.csv") # Output file


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(magrittr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(ggrepel))
suppressPackageStartupMessages(library(cowplot))

set.seed(0112)

con <- curl::curl("https://raw.githubusercontent.com/broadinstitute/cytominer_scripts/master/write_gct.R")
source(con)

util_file <- file.path("..", "scripts", "processing_utils.R")
source(util_file)

viz_file <- file.path("..", "scripts", "visualization_utils.R")
source(viz_file)

file <- file.path("..", "data", "2019_06_25_Batch3_merged_intersected_variable_selected.csv")
data_df <- load_data(file)

print(dim(data_df))
head(data_df, 3)

feature_df <- data_df %>% dplyr::select(-starts_with("Metadata_"))

cor_mat <- cor(t(feature_df), method = "pearson")
dist_mat <- as.dist(cor_mat)
kmeans_result <- kmeans(dist_mat, centers = 4)

data_df <- data_df %>%
    dplyr::mutate(Metadata_cluster_groups = paste(kmeans_result$cluster))

table(kmeans_result$cluster)

gct_file <- file.path("results", "kmeans_batch3_group.gct")
write_gct(data_df, gct_file)

tstat_group <- c()
pval_group <- c()
subgroup_vector <- c()
feature_vector <- c()
shuffle_vector <- c()

for (subgroup in unique(data_df$Metadata_cluster_groups)) {

    data_subset_df <- data_df %>%
        dplyr::filter(Metadata_cluster_groups == !!subgroup)

    for (feature in colnames(data_subset_df)) {

        if (!grepl("Metadata_", feature)) {

            for (shuffle in c("no_shuffle", "shuffle")) {

                if (shuffle == "shuffle") {
                    data_subset_copy_df <- data_subset_df
                    data_subset_copy_df$Metadata_Plate <- sample(data_subset_copy_df$Metadata_Plate)
                } else {
                    data_subset_copy_df <- data_subset_df
                }
                # Perform Cell Line Experiment at 0.7uM Dose
                resistant_clones <- data_subset_copy_df %>%
                    dplyr::filter(Metadata_Plate == "MutClones") %>%
                    dplyr::pull(!!feature)

                wt_cells <- data_subset_copy_df %>%
                    dplyr::filter(Metadata_Plate == "WTClones") %>%
                    dplyr::pull(!!feature)

                result <- t.test(resistant_clones, wt_cells, var.equal = FALSE)

                tstat_group <- c(tstat_group, as.numeric(paste(result$statistic)))
                pval_group <- c(pval_group, result$p.value)
                subgroup_vector <- c(subgroup_vector, subgroup)
                feature_vector <- c(feature_vector, feature)
                shuffle_vector <- c(shuffle_vector, shuffle)
            }

        }
    }
}

result_df <- as.data.frame(cbind(tstat_group, pval_group, subgroup_vector, feature_vector, shuffle_vector))

result_df$tstat_group <- as.numeric(paste(result_df$tstat_group))
result_df$pval_group <- as.numeric(paste(result_df$pval_group))
result_df$neglog10p <- -log10(result_df$pval_group)

result_file <- file.path("results", "subgroup_ttest_results.tsv")
result_df %>% readr::write_tsv(result_file)

head(result_df, 3)

yintercept = -log10(0.05 / (dim(result_df)[1] / 2))
yintercept

repel_logic <- result_df$neglog10p > yintercept * 1.4

subcluster_colors <- c("1" = "#d3aa5a",
                       "2" = "#1d6dab",
                       "3" = "#a9da7f",
                       "4" = "#2e9627")

volcano_gg <- ggplot(result_df,
       aes(x = tstat_group,
           y = neglog10p)) +
    geom_point(aes(color = subgroup_vector),
               alpha = 0.8,
               size = .8) +
    geom_hline(yintercept = yintercept,
               color = "red",
               linetype = "dashed") +
    xlab("t Statistic") +
    ylab("-log10 P") +
    facet_wrap(~shuffle_vector) +
    scale_color_manual(name = "subgroup",
                       values = subcluster_colors,
                       labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4")) +
    geom_text_repel(data = subset(result_df, repel_logic),
                    arrow = arrow(length = unit(0.01, "npc")),
                    size = 2,
                    segment.size = 0.1,
                    segment.alpha = 0.8,
                    force = 20,
                    aes(x = tstat_group,
                        y = neglog10p,
                        label = feature_vector)) +
    theme_bw() +
    theme(strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"))

file_base <- file.path("figures", "subcluster_volcano_plot")
save_figure(volcano_gg, file_base, height = 6, width = 12)

volcano_gg

result_df$mutant_high <- as.integer(result_df$tstat_group > 0)

sorted_result_df <- result_df %>%
    dplyr::group_by(feature_vector, shuffle_vector) %>%
    dplyr::mutate(feature_sum = sum(neglog10p),
                  same_direction_tstat = sum(mutant_high)) %>%
    dplyr::arrange(desc(feature_sum)) %>%
    dplyr::ungroup()

sorted_result_df$feature_vector <- factor(sorted_result_df$feature_vector,
                                          levels = unique(sorted_result_df$feature_vector))

head(sorted_result_df, 10)

all_feature_gg <- ggplot(sorted_result_df,
       aes(x = feature_vector,
           y = neglog10p)) +
    geom_bar(aes(fill = subgroup_vector), stat="identity") +
    theme_bw() +
    facet_wrap(~shuffle_vector, ncol = 1) +
    theme(axis.text.x = element_text(size = 5, angle = 90),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4")) +
    scale_fill_manual(name = "subgroup",
                       values = subcluster_colors,
                       labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4"))

file_base <- file.path("figures", "subcluster_all_feature_barchart")
save_figure(all_feature_gg, file_base, height = 10, width = 12)

all_feature_gg

all_tstat_feature_gg <- ggplot(sorted_result_df,
       aes(x = feature_vector,
           y = tstat_group)) +
    geom_bar(aes(fill = subgroup_vector), stat="identity") +
    theme_bw() +
    theme(axis.text.x = element_text(size = 5, angle = 90),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4")) +
    facet_wrap(~shuffle_vector, ncol = 1) +
    scale_fill_manual(name = "subgroup",
                       values = subcluster_colors,
                       labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4")) +
    geom_hline(yintercept = 0,
                   linetype = "dashed",
                   lwd = 0.5)

file_base <- file.path("figures", "subcluster_all_feature_barchart_tstat")
save_figure(all_tstat_feature_gg, file_base, height = 6, width = 12)

all_tstat_feature_gg

top_result_df <- sorted_result_df %>%
    dplyr::filter(feature_sum > 9)

top_feature_gg <- ggplot(top_result_df,
       aes(x = feature_vector,
           y = neglog10p)) +
    geom_bar(aes(fill = subgroup_vector), stat="identity") +
    theme_bw() +
    facet_wrap(~shuffle_vector, nrow = 1) +
    theme(axis.text.y = element_text(size = 10, angle = 0),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4")) +
    scale_fill_manual(name = "subgroup",
                       values = subcluster_colors,
                       labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4")) +
    coord_flip()

file_base <- file.path("figures", "subcluster_top_feature_barchart")
save_figure(top_feature_gg, file_base, height = 6, width = 9)

top_feature_gg

tstat_feature_gg <- ggplot(top_result_df,
       aes(x = feature_vector,
           y = tstat_group)) +
    geom_bar(aes(fill = subgroup_vector), stat="identity") +
    theme_bw() +
    facet_wrap(~shuffle_vector, nrow = 1) +
    theme(axis.text.y = element_text(size = 10, angle = 0),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4")) +
    scale_fill_manual(name = "subgroup",
                      values = subcluster_colors,
                      labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4")) +
    geom_hline(yintercept = 0,
               linetype = "dashed",
               lwd = 0.5) +
    coord_flip()

file_base <- file.path("figures", "subcluster_top_feature_barchart_tstat")
save_figure(tstat_feature_gg, file_base, height = 6, width = 9)

tstat_feature_gg

same_direction_df <- sorted_result_df %>%
    dplyr::filter(same_direction_tstat %in% c(0, 4))

tstat_feature_same_direction_gg <- ggplot(same_direction_df,
       aes(x = feature_vector,
           y = tstat_group)) +
    geom_bar(aes(fill = subgroup_vector), stat="identity") +
    theme_bw() +
    facet_wrap(~shuffle_vector, nrow = 1) +
    theme(axis.text.y = element_text(size = 10, angle = 0),
          strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4")) +
    scale_fill_manual(name = "subgroup",
                       values = subcluster_colors,
                       labels = c("1" = "1",
                                  "2" = "2",
                                  "3" = "3",
                                  "4" = "4")) +
    geom_hline(yintercept = 0,
               linetype = "dashed",
               lwd = 0.5) +
    coord_flip()

file_base <- file.path("figures", "subcluster_top_feature_barchart_tstat_samedirection")
save_figure(tstat_feature_same_direction_gg, file_base, height = 6, width = 9)

tstat_feature_same_direction_gg


# Parameters
THETA <- c(10L, 20L, 30L, 40L, 50L, 60L, 70L, 80L, 90L) # Fundamental Biodiversity Number. May et al. 2015 PRSB fit thetas of 25 to 90 to BCI data, depending on which pattern was fit. Tittensor & Worm 2016 GEB use 10, citing Hubbell. These values span a range.
M <- c(0.01, 0.05, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9) # migration rate (probability of new individual coming from regional pool)
N <- c(100L, 200L, 300L, 500L, 1000L, 2000L, 3000L, 5000L) # number of individuals in local community
NSAMPS <- 600L # Number of sampled timesteps
STEPL <- 0.01 # Sampling frequency multiplier (multiplies by N). Scaled so that, on average, half the individuals die between every sample. Make sure this times N is an integer.
SEED <- 41L # Seed (must be different than previous parameter sets)
NBURN = 100L # Burnin length multiplier (multiplies by N)

parameter_table <- rbind(
   data.table(THETA = THETA, M = 0.2, N = 1000, NSAMPS = NSAMPS, STEPL=STEPL, SEED=SEED, NBURN=NBURN),
   data.table(THETA = 40, M = M, N = 1000, NSAMPS = NSAMPS, STEPL=STEPL, SEED=SEED, NBURN=NBURN),
   data.table(THETA = 40, M = 0.2, N = N, NSAMPS = NSAMPS, STEPL=STEPL, SEED=SEED, NBURN=NBURN))
parameter_table$parameter_id <- seq_len(nrow(parameter_table))


library(yaml)
library(MASS)
CONFIG <- yaml.load_file("config_global.yaml")

main <- function() {
  total_vars <- 3
  total_draws <- 10^4
  x <- MASS::mvrnorm(total_draws, mu=rep(0, total_vars),
                     Sigma = diag(total_vars))
  write.table(x, sprintf("%s/draw_data.csv", CONFIG$build$draw_data),
              row.names = FALSE, col.names = TRUE, quote = FALSE, sep = ",")
}

main()