#' @export
#'
#' @title labels.eoar - Extract parameter labels from \code{eoar} objects.
#'
#' @param obj An \code{eoar} model object.  See \code{\link{eoar}}.
#'
#' @param type The type of parameter label requred or a regular expression.
#' Parameter type possibilities are "coef" or
#' "derived".  Regular expressions are used to match parameter labels using \code{grep}.
#' If \code{type} is not "coef" and not "derived" and the regular expression
#' fails to match anything, all parameter labels.
#'
#' @details Coefficient labels are for variables in the log-linear model for
#' lambda.  Derived parameter labels are non-coefficient parameters link
#' M, Mtot, and lambda.
#'
#' @author Trent McDonald
#'
#' @seealso \code{\link{coef}}, \code{\link{eoar}}
#'
#' @examples
#' # A 3 year study of 7 sites. 21 "cells". lambda change = 20/year
#' set.seed(9430834) # fixes Y and g of this example, but not the RNG's used in chains
#' ns <- 3
#'
#' ny <- 7
#' g <- data.frame(
#'  alpha = rnorm(ns*ny,70,2),
#'  beta = rnorm(ns*ny,700,25)
#' )
#' Y <- rbinom(ns*ny, c(rep(20,ny), rep(40,ny), rep(60,ny)), g$alpha/(g$alpha+g$beta))
#'
#' df <- data.frame(year=factor(c(rep("2015",ny),rep("2016",ny),rep("2017",ny))),
#'    Year=c(rep(1,ny),rep(2,ny),rep(3,ny)))
#'
#' # Uninformed eoar (use low number of iterations because it's and example)
#' eoar.1 <- eoar(Y~year, g, df, nburn = 1000, niters= 50*10, nthins = 10 )
#'
#' labels(eoar.1)
#' labels(eoar.1,"derived")
#' labels(eoar.1,"^M")  # all M parameters
#' labels(eoar.1,"\\[3\\]$") # M[3] and lambda[3]
#' labels(eoar.1,".") # all parameter labels
#'
#' plot(eoar.1$out[,labels(eoa.1)])  # trace plot of coefficients.
#'
labels.eoar <- function(obj, type="coef"){

  if(type=="coef"){
    ans <- obj$coef.labels
  } else {
    ans <- dimnames(obj$estimates)[[1]]
    if(type=="derived"){
      ans <- ans[!(ans %in% obj$coef.labels)]
    } else {
      ind <- grep(type, ans)
      if(length(ind)>0){
        ans <- ans[ind]
      }
    }
  }
  ans
}


#!/usr/bin/env Rscript

f2si2 <- function (number, rounding=F, sep=" ") {
  lut <- c(1e-24, 1e-21, 1e-18, 1e-15, 1e-12, 1e-09, 1e-06,
      0.001, 1, 1000, 1e+06, 1e+09, 1e+12, 1e+15, 1e+18, 1e+21,
      1e+24)
  pre <- c("y", "z", "a", "f", "p", "n", "u", "m", "", "k",
      "M", "B", "T", "P", "E", "Z", "Y")
  ix <- findInterval(number, lut)
  if (ix>0 && lut[ix]!=1) {
    if (rounding==T) {
      sistring <- paste(round(number/lut[ix], 1), pre[ix], sep=sep)
    } else {
      sistring <- paste(number/lut[ix], pre[ix], sep=sep)
    }
  } else {
    sistring <- as.character(number)
  }
  return(sistring)
}

urirdf <- read.csv("benchmark/urir-growth.csv", header=T)

print(urirdf)

png("benchmark/urir-growth.png", height=400, width=600, pointsize=18)

x <- urirdf$accumulated_urim_count
y <- urirdf$accumulated_urir_count
df <- data.frame(x, y)
s <- seq(from=0, to=max(x), length=500)

ypos <- pretty(c(0, max(y)), n=3)
ylb <- lapply(ypos, f2si2, rounding=T, sep="")
xpos <- pretty(c(0, max(x)), n=4)
xlb <- lapply(xpos, f2si2, rounding=T, sep="")

#par(mar=c(4,4,1,1)+0.1)
par(mar=c(3,3,1,1)+0.1, mgp=c(1.5,0.5,0), lwd=2)

plot(x, y, type="p", xaxt="n", yaxt="n", pch=0, col="red", ylab="URI-R Count", xlab="URI-M Count", ylim=c(0, max(y)))
axis(1, at=xpos, labels=xlb)
axis(2, at=ypos, labels=ylb)

m <- nls(y~I(K*x^beta), data=df, start=list(beta=1, K=1), trace=T)
lines(s, predict(m, list(x=s)), col="red")

summary(m)

x <- urirdf$urim_count
y <- urirdf$urir_count
m <- lm(y~x)

lines(x, y, type="p", col="blue")
lines(s, predict(m, list(x=s)), col="blue")

legend("topleft", inset=0.01, title="Collection", pch=c(1,0), col=c("blue", "red"), legend=c("Individual", "Accumulated"))

dev.off()

png("benchmark/relate-cdx-size-vs-urim-count-lineplot.png", height=400, width=600, pointsize=18)

x <- urirdf$cdx_size
y <- urirdf$urim_count
df <- data.frame(x, y)
s <- seq(from=0, to=max(x), length=500)

ypos <- pretty(c(0, max(y)), n=3)
ylb <- lapply(ypos, f2si2, rounding=T, sep="")
xpos <- pretty(c(0, max(x)), n=4)
xlb <- lapply(xpos, f2si2, rounding=T, sep="")

#par(mar=c(4,4,1,1)+0.1)
par(mar=c(3,3,1,1)+0.1, mgp=c(1.5,0.5,0), lwd=2)

plot(x, y, type="p", xaxt="n", yaxt="n", pch=0, col="red", ylab="URI-M Count", xlab="CDX Size", ylim=c(0, max(y)))
axis(1, at=xpos, labels=xlb)
axis(2, at=ypos, labels=ylb)

m <- lm(y~x)

lines(s, predict(m, list(x=s)), col="red")

dev.off()


## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for testing the Soay sheep coat colour IBM
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

getInvaderGrRt <- function(mPar, resG, resT=50, invT=50, init.pop=500, inv.prop=0.01) {
    ## Calculate average marginal growth rate for an invading allele
    ## introduced at low frequency into an existing population
    ## initially consisting of individuals of a single genotype.

    ## Args:
    ##   mPar: Model parameters. Numeric vector or matrix.
    ##   resG: Resident genotype.
    ##   resT: Number of timesteps to iterate with resident only.
    ##   invT: Number of timesteps to iterate with invader.
    ##   init.pop: Initial population size.
    ##   inv.prop: Invader proportion.

    ## Returns:
    ##   Mean of log invader growth rate.
    invG <- switch(resG, GG="TT", TT="GG")
    if (is.null(invG)) {
        stop (paste ("Invalid resident genotype:", resG))
    }

    ## Simulate resident population
    sim.res <- doSim(mPar, sim.length=resT, init.pop.size=init.pop, init.G = resG)
    res.z <- sim.res[[resT]]

    ## Introduce invader - sample sizes from resident population,
    ## assign to random sex/age.
    invN <- inv.prop*sum(unlist(res.z))
    validA <- sapply(dimnames(res.z)$A, function(x) !is.null(res.z[["F", x, resG]]))
    invA <- sample(dimnames(res.z)$A[validA], invN, replace=TRUE)
    invS <- sample(dimnames(res.z)$S, invN, replace=TRUE)
    invZ <- sample(unlist(res.z), invN, replace=TRUE)
    for (i in seq_len(invN)) {
        res.z[[invS[i], invA[i], invG]] <- invZ[i]
    }
    sim.inv <- doSim(mPar, sim.length=invT, init.state=res.z)
    simRunSum <- summariseSimRun(sim.inv)
    invNt <- with(simRunSum, switch(invG, GG=ntGG+ntGT/2, TT=ntTT+ntGT/2))

    ## Return arithmetic mean of stochastic log growth rate of invader.
    return(mean(diff(log(invNt[invNt>0]))))
}

simInv <- function(mod.params, inv.prop, num.reps, res="TT", resT=100, invT=500) {
    invRate <- numeric(num.reps)
    for (i in seq_len(num.reps)) {
        invRate[i] <- getInvaderGrRt(mod.params, resG=resG,
                                     resT=resT, invT=invT, inv.prop=inv.prop)
    }
    return(invRate)
}


library(hdfmat)

f = tempfile()
n = "mydata"
type = "double"

nr = 3
nc = 10
x = matrix(1:(nr*nc), nr, nc)
storage.mode(x) = type

h = crossprod_ooc(x, f, name=n)

test = h$read()
truth = crossprod(x)

stopifnot(all.equal(test, truth))

h$close()
unlink(f)


#' Create a bias-corrected distribution model
#'
#' This function implements a bayesLand model
#' @param x SpatialPolygonsDataFrame
#' @param effort Character, name of field in \code{x} indicating collection effort.
#' @param detect Character, name of field in \code{x} indicating number of detections of focal species.
#' @param stateProv Character, name of field with state/province.
#' @param county Character, name of field with county.
#' @param qGivenDetect Either \code{NULL} (default) or logical. If \code{TRUE} or \code{FALSE} then the model will try to estimate the rate of false detection (mistaken positive identifications). If \code{NULL}, then the model will not.  If \code{TRUE}, false detection rate \emph{q} reflects the probability of all collections in a location being of mistaken identification. If \code{FALSE} (default), then \emph{q} reflects the probability that for a county where the species does not truly occur, similar species (which could be mistaken for the focal species) do occur (and may or may not have been sampled and mis-identified).
#' @param covariate Either \code{NULL} (default) or a character or character vector. If not \code{NULL}, these are the name(s) field(s) with covariates.
#' @param niter Positive integer, number of MCMC iterations (including burn-in). The default is 2000, but this is often too low for most cases (i.e., try numbers in the range 10000, 100000, etc.).
#' @param nburnin Positive integer, number of burn-in samples (less than \code{niter}). The default is 1000, but this is often too low for most cases (i.e., try numbers in the range 10000, 100000, etc.).
#' @param nchains Positive integer, number of MCMC chains (default is 4).
#' @param thin Positive integer, number of MCMC samples by which to thin the results (default is 1; i.e., no thinning). To reduce memory requirements, you can use \code{thin} while increasing \code{niter} and/or \code{nburnin}.
#' @param na.rm Logical, if \code{TRUE} (default), then remove rows in \code{x} that have \code{NA} in any input field. If this is \code{FALSE} and \code{NA}s occur in any fields then an error may occur.
#' @param verbose Logical, if \code{TRUE} (default) display progress.
#' @param ... Arguments to pass to \code{\link[nimble]{configureMCMC}} and \code{\link[nimble]{runMCMC}}.
#' @return A list object with three elements, one with the MCMC chains, a second with the object \code{x} with model output appended to the data portion of the object, and a third with model information. The new columns in \code{x} represent:
#' \itemize{
#' 		\item{\code{cvScale}} (only if \code{covariate} is not \code{NULL}): Value of centered and scaled covariate
#' 		\item{\code{psi}} Probability of occurrence
#' 		\item{\code{psi95CI}} 95% credibility interval for probability of occurrence
#' 		\item{\code{p}} Probability of detecting the focal species assuming it is present
#' 		\item{\code{p95CI}} 95% credibility interval for probability of detection
#' }
#' @examples
#' @export

trainBayesODM <- function(
	x,
	effort,
	detect,
	stateProv,
	county,
	qGivenDetect = NULL,
	covariate = NULL,
	niter = 2000,
	nburnin = 1000,
	nchains = 4,
	thin = 1,
	na.rm=TRUE,
	verbose=TRUE,
	...
) {

	### prepare data
	################

		if (verbose) omnibus::say('Preparing data...')

		# remove missings
		if (na.rm) {
			ok <- complete.cases(x@data[ , c(effort, detect, stateProv, county, covariate)])
			x <- x[ok, ]
		}

		### CAR setup for counties
		##########################

			neighs <- spdep::poly2nb(x, queen=TRUE)

			hasNeighs <- !sapply(neighs, function(x) { length(x == 1) && (x == 0) })

			neighsList <- spdep::nb2WB(neighs)
			carAdjCounty <- neighsList$adj
			carWeightCounty <- neighsList$weights
			carNumCounty <- neighsList$num

		### inputs
		##########

			### data
			data <- list(
				y = x@data[ , detect],
				N = x@data[ , effort],
				carAdjCounty = carAdjCounty,
				carWeightCounty = carWeightCounty,
				carNumCounty = carNumCounty
			)

			# add covariates
			if (!is.null(covariate)) {
				predVals <- as.numeric(scale(x@data[ , covariate]))
				predList <- list(predVals)
				names(predList) <- 'predictor'
				data <- c(data, predList)
			}

			### constants
			constants <- list(
				numCounties = nrow(x),
				numStates = length(unique(x@data[ , stateProv])),
				state = as.numeric(as.factor(x@data[ , stateProv])),
				lengthAdjCounties = length(carAdjCounty),
				isOcc = as.numeric(data$y > 0)
			)

			### initializations
			inits <- list(

				z = as.numeric(data$y > 0),

				q = 0.01,

				p = runif(constants$numCounties, 0.1, 0.3),
				logit_p = logit(p),
				p_stateMean = rnorm(constants$numStates, 0, 0.5),

				psi = runif(constants$numCounties, 0.4, 0.6),

				psi_island = rnorm(constants$numCounties, 0, 0.1),
				psi_islandMean = -0.1,

				psi_tau = 0.1,
				psi_car = rnorm(constants$numCounties)

			)

			if (!is.null(covariate)) {

				inits <- c(
					inits,
					list(psi_beta = 0.1)
				)

			}

			### monitors
			monitors <- names(inits)
			monitors <- monitors[!(monitors %in% c('logit_p'))]
			monitors <- monitors[!(monitors %in% c('z'))]

	### model setup
	###############

		if (verbose) omnibus::say('Model setup...')

		### model specification
		if (is.null(covariate)) {

			### WITHOUT covariate
			code <- nimble::nimbleCode({

				## likelihood
				for (i in 1:numCounties) {

					# detection
					y[i] ~ dbin(pstar[i], N[i])
					pstar[i] <- psi[i] * p[i] + (1 - psi[i]) * isOcc[i] * (p[i] * q) # viable but gives large q if isOcc is {0, 1}
					logit(p[i]) ~ dnorm(p_stateMean[state[i]], tau=0.001)

					# occupancy
					logit(psi[i]) <- hasNeighs[i] * psi_car[i] + (1 - hasNeighs[i]) * psi_island[i]
					psi_island[i] ~ dnorm(psi_islandMean, tau=0.001)

				}

				## priors
				q ~ dbeta(10, 1)

				# state effects
				for (j in 1:numStates) {
					p_stateMean[j] ~ dnorm(0, tau=0.001)
				}

				psi_islandMean ~ dnorm(0, tau=0.001)

				# county occupancy CAR
				psi_tau ~ dgamma(0.001, 0.001)
				psi_car[1:numCounties] ~ dcar_normal(adj=carAdjCounty[1:lengthAdjCounties], weights=carWeightCounty[1:lengthAdjCounties], num=carNumCounty[1:numCounties], tau=psi_tau, c=3, zero_mean=0)

			})

		} else {

			### WITH covariate
			code <- nimble::nimbleCode({

				## likelihood
				for (i in 1:numCounties) {

					# detection
					y[i] ~ dbin(pstar[i], N[i])
					pstar[i] <- psi[i] * p[i] + (1 - psi[i]) * isOcc[i] * (p[i] * q) # viable but gives large q if isOcc is {0, 1}
					logit(p[i]) ~ dnorm(p_stateMean[state[i]], tau=0.001)

					# occupancy
					logit(psi[i]) <- hasNeighs[i] * psi_car[i] + (1 - hasNeighs[i]) * psi_island[i] + psi_beta * predictor[i]
					psi_island[i] ~ dnorm(psi_islandMean, tau=0.001)

				}

				## priors
				q ~ dbeta(10, 1)

				# state effects
				for (j in 1:numStates) {
					p_stateMean[j] ~ dnorm(0, tau=0.001)
				}

				psi_islandMean ~ dnorm(0, tau=0.001)

				beta ~ dnorm(0, tau=0.001)

				# county occupancy CAR
				psi_tau ~ dgamma(0.001, 0.001)
				psi_car[1:numCounties] ~ dcar_normal(adj=carAdjCounty[1:lengthAdjCounties], weights=carWeightCounty[1:lengthAdjCounties], num=carNumCounty[1:numCounties], tau=psi_tau, c=3, zero_mean=0)

			})

		} # if covariate

		### construct and compile model
		model <- nimble::nimbleModel(code=code, constants=constants, data=data, inits=inits, check=TRUE)
		flush.console()

		# conf <- nimble::configureMCMC(model, monitors = monitors, thin = thin, print = verbose, ...)
		conf <- nimble::configureMCMC(model, monitors = monitors, thin = thin, print = verbose)
		flush.console()

		## modify samplers
		conf$removeSamplers('psi_tau')
		conf$addSampler(target='psi_tau', type='slice')

		conf$removeSamplers('q')
		conf$addSampler(target='q', type='slice')

		if (!is.null(covariate)) {
			conf$removeSamplers('psi_beta')
			conf$addSampler(target='psi_beta', type='slice')
		}

		for (i in 1:constants$numCounties) {
			conf$removeSamplers(paste0('logit_p[', i, ']'))
			conf$addSampler(target=paste0('logit_p[', i, ']'), type='slice')

		}

		for (i in 1:constants$numCounties) {
			conf$removeSamplers(paste0('psi_island[', i, ']'))
			conf$addSampler(target=paste0('psi_island[', i, ']'), type='slice')

		}

		confBuild <- nimble::buildMCMC(conf)
		flush.console()
		compiled <- nimble::compileNimble(model, confBuild)
		flush.console()

	### MCMC
	########

		if (verbose) omnibus::say('Modeling...')
		# mcmc <- runMCMC(compiled$confBuild, niter = niter, nburnin = nburnin, nchains = nchains, inits = inits, progressBar = verbose, samplesAsCodaMCMC = TRUE, summary = FALSE, ...)
		mcmc <- runMCMC(compiled$confBuild, niter = niter, nburnin = nburnin, nchains = nchains, inits = inits, progressBar = verbose, samplesAsCodaMCMC = TRUE, summary = FALSE)
		flush.console()

		# rm(model, compiled, confBuild)
		# gc()

	### process model output
	########################

		omnibus::say('Processing model output...')

		### remove unneeded stuff
		#########################

			mcmc <- list(samples = mcmc)

			# remove unneeded
			ignores <- c('logit_p[[]', 'z[[]')
			for (ignore in ignores) {
				bads <- grepl(colnames(mcmc$samples$chain1), pattern=ignore)
				if (any(bads)) {
					for (chain in 1:nchains) {
						mcmc$samples[[chain]] <- mcmc$samples[[chain]][ , !bads]
					}
				}
			}

			# remove island coefficients for non-islands and CAR coefficients for islands
			if (any(!hasNeighs)) {

				# psi_car for islands
				index <- which(!hasNeighs)
				bads <- paste0('psi_car[', index, ']')
				for (chain in 1:nchains) {
					remove <- which(colnames(mcmc$samples[[chain]]) %in% bads)
					mcmc$samples[[chain]] <- mcmc$samples[[chain]][ , -remove]
				}

				# psi_island for non-islands
				index <- which(hasNeighs)
				bads <- paste0('psi_island[', index, ']')
				for (chain in 1:nchains) {
					remove <- which(colnames(mcmc$samples[[chain]]) %in% bads)
					mcmc$samples[[chain]] <- mcmc$samples[[chain]][ , -remove]
				}

			# no islands
			} else {

				# remove psi_island and psi_islandMean for all
				index <- which(hasNeighs)
				bads <- c(paste0('psi_island[', index, ']'), 'psi_islandMean')
				for (chain in 1:nchains) {
					remove <- which(colnames(mcmc$samples[[chain]]) %in% bads)
					mcmc$samples[[chain]] <- mcmc$samples[[chain]][ , -remove]
				}

			}

						# conv <- rhatStats(mcmc$samples, rhatThresh=1.1, minConv=minUnconverged)
						# print(str(conv))
						# w <- as.Bwiqid(mcmc$samples)

						# caterplot(mcmc$samples, regex='p[[]')
						# caterplot(mcmc$samples, regex='psi[[]')

						# diagPlot(w, params='p')
						# diagPlot(w, params='psi')
						# diagPlot(w, params='q')
						# diagPlot(w, params='psi_tau')

		### calculate summary
		#####################

			mcmc$summary$all.chains <- matrix(NA, nrow=ncol(mcmc$samples[[1]]), ncol=6)
			rownames(mcmc$summary$all.chains) <- colnames(mcmc$samples[[1]])
			colnames(mcmc$summary$all.chains) <- c('Mean', 'Median', 'St.Dev', '95%CI_low', '95%CI_upp', 'rhat')

			samps <- mcmc$samples[[1]]
			if (nchains > 1) {
				for (chain in 2:nchains) {
					samps <- rbind(samps, mcmc$samples[[chain]])
				}
			}

			mcmc$summary$all.chains[ , 'Mean'] <- colMeans(samps)
			mcmc$summary$all.chains[ , 'Median'] <- apply(samps, 2, median)
			mcmc$summary$all.chains[ , 'St.Dev'] <- apply(samps, 2, sd)
			mcmc$summary$all.chains[ , '95%CI_low'] <- apply(samps, 2, quantile, probs=0.025)
			mcmc$summary$all.chains[ , '95%CI_upp'] <- apply(samps, 2, quantile, probs=0.975)
			mcmc$summary$all.chains[ , 'rhat'] <- wiqid::simpleRhat(mcmc$samples, n.chains=nchains)

			rm(samps); gc()

		### update shapefile
		####################

			psi <- mcmc$summary$all.chains[grepl(rownames(mcmc$summary$all.chains), pattern='psi[[]'), 'Mean']
			p <- mcmc$summary$all.chains[grepl(rownames(mcmc$summary$all.chains), pattern='p[[]'), 'Mean']

			uncer <- mcmc$summary$all.chains[ , '95%CI_upp'] - mcmc$summary$all.chains[ , '95%CI_low']
			names(uncer) <- rownames(mcmc$summary$all.chains)
			occUncer <- uncer[grepl(names(uncer), pattern='psi[[]')]
			pUncer <- uncer[grepl(names(uncer), pattern='p[[]')]

			x@data$psi <- psi
			x@data$occUncer <- occUncer
			x@data$p <- p
			x@data$pUncer <- pUncer

			names(x@data)[(ncol(x@data) - 3):ncol(x@data)] <- c('psi', 'psi95CI', 'p', 'p95CI')

		### collate
		###########

			meta <- list(
				niter=niter,
				nburnin=nburnin,
				nchains=nchains,
				thin=thin,
				effort=effort,
				detect=detect,
				stateProv=stateProv,
				county=county,
				covariate=covariate,
				hasIslands=any(!hasNeighs),
				qGivenDetect=qGivenDetect,
				na.rm=na.rm
			)

			attr(x, 'meta') <- meta

	### output
	list(mcmc=mcmc, code=code, shape=x, meta=meta)

}


# Goal: To do sorting.
#
# The approach here needs to be explained. If `i' is a vector of
# integers, then the data frame D[i,] picks up rows from D based
# on the values found in `i'.
#
# The order() function makes an integer vector which is a correct
# ordering for the purpose of sorting.

D <- data.frame(x=c(1,2,3,1), y=c(7,19,2,2))
D

# Sort on x
indexes <- order(D$x)
D[indexes,]

# Print out sorted dataset, sorted in reverse by y
D[rev(order(D$y)),]

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b2.r


#  James Rekow

computeUnivWithinSS  = function(abdList, rollRange = 0.025){

  #  ARGS:
  #
  #  RETURNS:

  source("computeInfoWeightMat.r")

  #  compute matrix of info weights
  infoMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

  meanInfoVec = apply(infoMat, 2, mean)

  squaredDistanceFromMean = function(infoVec) sum((infoVec - meanInfoVec) ^ 2)

  seVec = apply(infoMat, 2, squaredDistanceFromMean)
  sse = sum(seVec)

  #  deprecated, below computes the sse, but in a ridiculous way
  # kmr = kmeans(x = infoMat, centers = 1, iter.max = 1000, nstart = 100)
  #
  # withinSS = kmr$withinss

  return(sse)

} #  end  computeUnivWithinSS function


bogosort <- function(x)
{
   is.sorted <- function(x) all(diff(x) >= 0)
   while(!is.sorted(x)) x <- sample(x)
   x
}

n <- c(1, 10, 9, 7, 3, 0)
print(bogosort(n))


## calculate correlations between total and each cell fraction

source("rmdConfig.mrc")
setwd(dataDir)
load(normData)

## remove rs probes
celltypenormbeta<-celltypenormbeta[grep("rs", rownames(celltypenormbeta), invert = TRUE),]

## exclude IRF8+ve as not present in sufficient sample numbers
pheno<-pheno[pheno$Cell.type %in% c("Double -ve","NeuN +ve","Sox10 +ve", "Total"),]
celltypenormbeta<-celltypenormbeta[,pheno$Basename]
pheno$Cell.type<-factor(pheno$Cell.type)

## reformat as a list with matrix for each cell type, with samples in the same order
allSamples<-unique(pheno$Indidivual.ID)

betas.list<-list("Total" = celltypenormbeta[,which(pheno$Cell.type == "Total")[match(allSamples, pheno$Indidivual.ID[which(pheno$Cell.type == "Total")])]],
"NeuN" = celltypenormbeta[,which(pheno$Cell.type == "NeuN +ve")[match(allSamples, pheno$Indidivual.ID[which(pheno$Cell.type == "Total")])]],
"Sox10" = celltypenormbeta[,which(pheno$Cell.type == "Sox10 +ve")[match(allSamples, pheno$Indidivual.ID[which(pheno$Cell.type == "Total")])]],
"DNeg" = celltypenormbeta[,which(pheno$Cell.type == "Double -ve")[match(allSamples, pheno$Indidivual.ID[which(pheno$Cell.type == "Total")])]])

res<-matrix(data = NA, ncol = 3, nrow = nrow(celltypenormbeta))
colnames(res)<-c("NeuN", "Sox10", "DNeg")
rownames(res)<-rownames(celltypenormbeta)
for(i in 1:nrow(celltypenormbeta)){
	res[i,1]<-cor(betas.list[["Total"]][i,], betas.list[["NeuN"]][i,], use = "p")
	res[i,2]<-cor(betas.list[["Total"]][i,], betas.list[["Sox10"]][i,], use = "p")
	res[i,3]<-cor(betas.list[["Total"]][i,], betas.list[["DNeg"]][i,], use = "p")
}

save(res, file="Analysis/CellType/CTCorwithTotal.rdata")


# R Program to find the multiplicationtable (from 1 to 10)
# take input from the user
num = as.integer(readline(prompt = "Enter a number: "))
# use for loop to iterate 10 times
for(i in 1:10) {
print(paste(num,'x', i, '=', num*i))
}
print(paste(num,'x', i, '=', num*i))


# Enter your code here. Read input from STDIN. Print output to STDOUT
x=c(15 , 12,  8,   8,   7,   7,   7,   6,   5,  3)
y=c(10,  25,  17,  11,  13,  17,  20,  13,  9,   15)
model=lm(y~x)
result=predict(model,data.frame(x=10))
cat(round(result,1))

Artificial Intelligence/Statistics and machine learning/Correlation_and_Regression_Lines _A_quick_recap_#3.r


# if (!is.na(Projects_metadata$confound_by)) {
#  out_sel = Multi_datainput_m2[order(Multi_datainput_m2$groupingvar, Multi_datainput_m2$confoundvar),]
#  out_sel =out_sel %>% select (-confoundvar)
# }else {
#  out_sel = Multi_datainput_m[order(Multi_datainput_m$groupingvar),]
# }

if (kernel !="radial") message ("2_out_svm should be using a radial kernel, check your code")

xx= as.matrix(out_sel %>% select (-groupingvar))
yy = as.numeric(out_sel$groupingvar)-1
#pp  <- rep(NA, length(yy))
ppsvm  <- rep(NA, length(yy))
#ppsvm_L  <- rep(NA, length(yy))

num_per_class <- nrow(out_sel)/2

for (k in 1:num_per_class) {

  hold_out = c(k, k+num_per_class) ## hold out one pos and one neg examples so samples are still balanced
  # ##---logregression, deprecated
  # fit <- glmpath::glmpath(x=xx[-hold_out,], y=yy[-hold_out], family=binomial, max.arclength=1)
  # bestdex <- which.min(fit$bic)
  # if (bestdex==1) {bestdex <- 2}  ## break ties by avoiding degenerate classifiers
  # bestlambda <- fit$lambda[bestdex]
  # pred <- predict(fit, newx=xx[hold_out,], s=bestlambda, type="link", mode="lambda")
  # pp[hold_out] = pred

  ##-- svm
  groupingvar=as.data.frame(yy[-hold_out])

  ##---linear svm
  #objL <- tune.svm(groupingvar~., data =out_sel[-hold_out,], gamma = 4^(-5:5), cost = 4^(-5:5),
  #                 tune.control(sampling = "cross"),kernel = "linear")
  #best.parameters_L = objL$best.parameters
  #svm.model_L <- svm(yy[-hold_out] ~ ., data = xx[-hold_out,], cost = best.parameters_L$cost, gamma = best.parameters_L$gamma, kernel = "linear")
  #ppsvm_L[hold_out] = predict(svm.model_L, xx[hold_out,])

  ##---radial svm
  objR <- tune.svm(groupingvar~., data =out_sel[-hold_out,], gamma = 4^(-5:5), cost = 4^(-5:5),
                   tune.control(sampling = "fix"),kernel = "radial")
  plot(objR)
  best.parameters = objR$best.parameters
  svm.model_R <- svm(yy[-hold_out] ~ ., data = xx[-hold_out,], cost = best.parameters$cost, gamma = best.parameters$gamma, kernel = "radial")
  ppsvm[hold_out] = predict(svm.model_R, xx[hold_out,])
}

true_class <- sign(yy - 0.5)
pred_classsvm <- sign(ppsvm);
prediction_res2=table(true_class, pred_classsvm)
temp =classAgreement (prediction_res2)

#Accuracyreal = temp$kappa
##--logreg:
#pred_class <- sign(pp);
#prediction_res1=table(true_class, pred_class)
##--svmlionear:
#pred_classsvm_L <- sign(ppsvm_L);
#prediction_res3=table(true_class, pred_classsvm_L)

#Accuracy of grouping and plot

# ACURRACY=NA
# temp =classAgreement (prediction_res1)
# ACURRACY = c(Accuracyreal, temp$kappa)
#
# temp =classAgreement (prediction_res3)
# ACURRACY = c(ACURRACY, temp$kappa)
# ACURRACY


# Glossary ----

# n.b. the following employs a mix of snake_case and camelCase that is sure to
#  vex some, but represents the author's best attempt to balance to the competing
#  aims of clarity & brevity.

# Y: observed outcome
# nY: number of observed outcomes
# X: predictor/contrast matrix
# nX: number of predictors (columns in the contrast matrix)
# rX: number of rows in the contrast matrix X
# (i)ndividual: a unit of observation within which correlated measurements may take place
# (c)ondition: a labelled set of observations within an individual that share some feature/predictor or conjunction of features/predictors
# Xc: condition-level contrast matrix
# nXc: number of predictors in the condition-level contrast matrix
# rXc: number of rows in the condition-level contrast matrix
# yXc: for each observation in y, an index indicating the associated row in Xc corresponding to that observation's individual/condition combo
# (g)roup: a collection of individuals that share some feature/predictor
# Xg: group-level contrast matrix
# nXg: number of predictors in the group-level contrast matrix
# rXg: number of rows in the group-level contrast matrix
# Z: matrix of coefficient row-vectors to be dot-product'd with a contrast matrix
# iZc: matrix of coefficient row-vectors associated with each individual

# Preamble (options, installs, imports & custom functions) ----

options(warn=1) # really should be default in R
`%!in%` = Negate(`%in%`) # should be in base R!

# specify the packages used:
required_packages = c(
	'github.com/rmcelreath/rethinking' # for rlkjcorr & rmvrnom2
	, 'github.com/stan-dev/cmdstanr' # for Stan stuff
	, 'github.com/mike-lawrence/aria/aria' # for aria
	, 'tidyverse' # for all that is good and holy
)

# load the helper functions:
for(file in fs::dir_ls('r')){
	cat('Loading function: ',fs::path_ext_remove(fs::path_file(file)),'()\n',sep='')
	source(file)
}

# install any required packages not already present
install_if_missing(required_packages)

# load tidyverse & aria
library(tidyverse)
library(aria)

# Simulate data ----
set.seed(1) # change this to make different data

# setting the data simulation parameters

# parameters you can play with
nG_vars = 1 # number of 2-level variables manipulated as crossed and across individuals, must be an integer >0
nC_vars = 2 # number of 2-level variables manipulated as crossed and within each individual, must be an integer >0
nI_per_group = 3 # number of individuals, must be an integer >1
nY_per_ic = 4 # number of observations per individual/condition combo, must be an integer >1
# the latter two combine to determine whether centered or non-centered will sample better

# the rest of these you shouldn't touch
nXc = 2^(nC_vars)
nXg = 2^(nG_vars)
Z = matrix(rnorm(nXg*nXc),nrow=nXg,ncol=nXc)
iZc_sd = rweibull(nXc,2,1)
iZc_r_mat = rethinking::rlkjcorr(1,nXc,eta=1)
Y_sd = rweibull(1,2,1)
iZc_r_vec = iZc_r_mat[lower.tri(iZc_r_mat)]

# compute Xg
Xg = sim_contrasts(nG_vars,'G')

# compute gZc
gZc = matrix(NA,nrow=nXg,ncol=nXc)
for(this_nXc in 1:nXc){
	for(this_nXg in 1:nXg){
		gZc[this_nXg,this_nXc] = Xg[this_nXg,] %*% Z[,this_nXc]
	}
}

# compute iZc
(
	1:nXg
	%>% map_dfr(
		.f = function(this_nXg){(
			rethinking::rmvnorm2(
				n = nI_per_group
				, Mu = gZc[this_nXg,]
				, sigma = iZc_sd
				, Rho = iZc_r_mat
			)
			%>% as_tibble(
				.name_repair = function(x) paste0('iZc[.,',1:length(x),']')
			)
			%>% mutate(
				g = this_nXg
				, individual = paste(g,1:n(),sep='_') # important that individuals have unique identifiers across groups
			)
		)}
	)
) ->
	iZc

# compute Xc
uXc = sim_contrasts(nC_vars,'C')

# compute iZc_dot_Xc
(
	iZc
	%>% group_by(g,individual)
	%>% summarise(
		{function(x){
			x = t(as.matrix(select(x,starts_with('iZc')),))
			this_dot = rep(NA,nXc)
			for(this_nXc in 1:nXc){
				this_dot[this_nXc] = uXc[this_nXc,] %*% x
			}
			tibble(c=1:nXc,value=this_dot)
		}}(cur_data())
		, .groups = 'keep'
	)
) ->
	iZc_dot_Xc

# compute Y
(
	iZc_dot_Xc
	%>% group_by(c,.add=T)
	%>% summarise(
		value = rnorm(nY_per_ic,value,Y_sd)
		, .groups = 'keep'
	)
) ->
	Y

# join with group & condition columns
(
	Y
	%>% left_join((
		attr(Xg,'data')
		%>% mutate(g=1:n())
	))
	%>% left_join((
		attr(uXc,'data')
		%>% mutate(c=1:n())
	))
	%>% ungroup()
	%>% select(everything(),-g,-c,-value,value)
) ->
	dat

# dat is now what one would typically have as collected data
dat

# if there's no missing data (as in this synthetic example), we could proceed with modelling,
#  but to demonstrate how to handle missing data, we'll do a bit of extra work:

# Uncomment next section to induce data-missingness (causes some Ss to be missing whole conditions)
# (
# 	dat
# 	# select all but value
# 	%>% select(-value)
# 	# get distinct rows (no more individual trials)
# 	%>% distinct()
# 	# group by individual
# 	%>% group_by(individual)
# 	# toss one condition
# 	%>% slice_sample(n=(nXc-1))
# 	# semi-join to keep all in dat that have been kept above
# 	%>% semi_join(
# 		x = dat
# 		, y = .
# 	)
# ) ->
# 	dat

nrow(dat)

# Compute inputs to Stan model ----

# Some data prep
(
	dat
	# ungroup (necessary)
	%>% ungroup()
	# ensure individual is a sequential numeric
	%>% mutate(
		individual = as.numeric(factor(individual))
	)
	# arrange rows by individual
	%>% arrange(individual)
) ->
	dat

# compute Xg from distinct combinations of groups
(
	dat
	# select down to any G vars
	%>% select(starts_with('G'))
	# collapse to distinct set of rows (combinations of grouping variables)
	%>% distinct()
	# arrange (not really necessary, but why not)
	%>% arrange()
	# add the contrast matrix columns
	%>% mutate(
		contrasts = get_contrast_matrix_rows_as_list(
			data = .
			# the following complicated specification of the formula is a by-product of making this example
			# work for any number of variables =  normally you would do something like this
			# (for 2 variables for example):
			# formula = ~ G1*G2
			, formula = as.formula(paste0('~',paste0('G',1:nG_vars,collapse='*')))
			# half-sum contrasts are nice for 2-level variables bc they yield parameters whose value
			# is the difference between conditions
			, contrast_kind = halfsum_contrasts
		)
	)
) ->
	Xg_with_vars

# show contrasts
(
	Xg_with_vars
	%>% unnest(contrasts)
)

# join Xg with dat to label individuals with corresponding row from Xg
(
	Xg_with_vars
	# add row identifier
	%>% mutate(Xg_row=1:n())
	# join with dat, collapsed to 1-row per individual with their group info
	%>% right_join((# right-join to apply the row order from dat
		dat
		%>% select(individual,starts_with('G'))
		%>% distinct()

	))
	%>% arrange(individual)
	%>% pull(Xg_row)
) ->
	iXg

# compute complete_Xc from distinct combinations of individuals & conditions
(
	dat
	# select individual & any condition-defining columns
	%>% select(individual,starts_with('C'))
	# collapse down to distinct rows (1 per individual/conditions combo)
	%>% distinct()
	# expand (in case there's any missing data; doesn't hurt if not)
	# %>% exec(expand_grid,!!!.) #should work, but doesn't, so need the next three instead
	%>% as.list()
	%>% map(unique)
	%>% cross_df()
	# arrange (not really necessary, but why not)
	%>% arrange()
	# add the contrast matrix columns
	%>% mutate(
		contrasts = get_contrast_matrix_rows_as_list(
			data = .
			# the following complicated specification of the formula is a by-product of making this example
			# work for any number of variables =  normally you would do something like this
			# (for 2 variables for example):
			# formula = ~ C1*C2
			, formula = as.formula(paste0('~',paste0('C',1:nC_vars,collapse='*')))
			# half-sum contrasts are nice for 2-level variables bc they yield parameters whose value
			# is the difference between conditions
			, contrast_kind = halfsum_contrasts
		)
	)
) ->
	complete_Xc_with_vars

# show the unique contrasts
(
	complete_Xc_with_vars
	%>% select(-individual)
	%>% distinct()
	%>% unnest(contrasts)
)

# subset down to just those individual-condition combos actually present in the data
#  it's ok if there's no missing data and nrow(complete_Xc_with_vars)==nrow(Xc_with_vars)
(
	complete_Xc_with_vars
	%>% semi_join(dat)
) ->
	Xc_with_vars

# join Xc with dat to label observations with corresponding row from Xc
(
	Xc_with_vars
	# add row identifier
	%>% mutate(Xc_row=1:n())
	# right-join with dat to preserve dat's row order
	%>% right_join(
		mutate(dat,dat_row=1:n())
	)
	%>% arrange(dat_row)
	# pull the Xc row identifier
	%>% pull(Xc_row)
) ->
	yXc

# package for stan & sample ----

data_for_stan = lst( # lst permits later entries to refer to earlier entries

	# # # #
	# Entries we need to specify ourselves
	# # # #

	# Xg: group-level predictor matrix
	Xg = (
		Xg_with_vars
		%>% select(contrasts)
		%>% unnest(contrasts)
		%>% as.matrix()
	)

	# iXg: which group each individual is associated with
	, iXg = iXg

	# Xc: condition-level predictor matrix
	, Xc = (
		Xc_with_vars
		%>% select(contrasts)
		%>% unnest(contrasts)
		%>% as.matrix()
	)

	# iXc: which individual is associated with each row in Xc
	, iXc = as.numeric(factor(Xc_with_vars$individual))

	# Y: observations
	, Y = dat$value

	# yXc: which row in Xc is associated with each observation in Y
	, yXc = yXc

	# # # #
	# Entries computable from the above
	# # # #

	# nXg: number of cols in the group-level predictor matrix
	, nXg = ncol(Xg)

	# rXg: number of rows in the group-level predictor matrix
	, rXg = nrow(Xg)

	# nI: number of individuals
	, nI = max(iXc)

	# nXc: number of cols in the condition-level predictor matrix
	, nXc = ncol(Xc)

	# rXc: number of rows in the condition-level predictor matrix
	, rXc = nrow(Xc)

	# nY: num entries in the observation vectors
	, nY = length(Y)

)

# double-check:
glimpse(data_for_stan)

# set the model path (automated bc in this repo there's only one)
mod_path = fs::dir_ls(
	path = 'stan'
	, glob = '*.stan'
)

# set the model centered/non-centeredness
#  generally, if *either* nI_per_group *or* num_Y_per_ic is small, non-centered will sample better than centered
data_for_stan$centered = F

# conversion to 1/0 for stan
data_for_stan$centered = as.numeric(data_for_stan$centered)

# set the posterior path (automated but you could do your own if you had multiple models)
(
	mod_path
	%>% fs::path_file()
	%>% fs::path_ext_remove()
	%>% paste0(
		ifelse(data_for_stan$centered,'_c','_nc')
	)
	%>% fs::path(
		'posteriors'
		, .
		, ext = 'netcdf4'
	)
) -> post_path

# ensure model is compiled
aria:::check_and_compile(mod_path,block=T)

# compose
aria::compose(
	data = data_for_stan
	, code_path = mod_path
	, out_path = post_path
	, overwrite = T
	, block = T
)

# how long did it take?
aria::marginalia()$time

# check posterior diagnostics ----
post = aria::coda(post_path)

# Check treedepth, divergences, & rebfmi
(
	post$draws(group='sample_stats')
	%>% posterior::as_draws_df()
	%>% group_by(.chain)
	%>% summarise(
		max_treedepth = max(treedepth)
		, num_divergent = sum(divergent)
		, rebfmi = var(energy)/(sum(diff(energy)^2)/n()) # n.b. reciprocal of typical EBFMI, so bigger=bad, like rhat
	)
)

# gather summary for core parameters (inc. r̂ & ess)
(
	post$draws(group='parameters')
	%>% posterior::summarise_draws(.cores=parallel::detectCores())
) ->
	par_summary

# show the ranges of r̂/ess's
(
	par_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

# View those with suspect r̂
(
	par_summary
	%>% filter(rhat>1.01)
	%>% (function(suspects){
		if(nrow(suspects)>1){
			View(suspects)
		}
		return(paste('# suspect parameters:',nrow(suspects)))
	})()
)

# Viz recovery of non-correlation parameters ----
(
	post$draws(variables=c('Y_sd','Z','iZc_sd'))
	%>% posterior::as_draws_df()
	%>% select(-.draw)
	%>% pivot_longer(
		cols = -c(.chain,.iteration)
		, names_to = 'variable'
	)
	%>% group_by(variable)
	%>% arrange(variable,.chain,.iteration)
	%>% summarise(
		rhat = 1.01<posterior::rhat(matrix(value,ncol=length(unique(.chain))))
		, ess_bulk = 100>posterior::ess_bulk(matrix(value,ncol=length(unique(.chain))))
		, ess_tail = 100>posterior::ess_tail(matrix(value,ncol=length(unique(.chain))))
		, as_tibble(t(posterior::quantile2(value,c(.05,.25,.5,.75,.95))))
	)
	#add true values
	%>% left_join(
		bind_rows(
			tibble(
				true = Y_sd
				, variable = 'Y_sd'
			)
			, tibble(
				true = as.vector(Z)
				, variable = paste0(
					'Z['
					,rep(1:nXg,times=nXc)
					,','
					,rep(1:nXc,each=nXg)
					,']'
				)
			)
			, tibble(
				true = iZc_sd
				, variable = paste0('iZc_sd[',1:length(true),']')
			)
		)
	)
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
		, alpha = .5
	)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q25
			, ymax = q75
			, colour = ess_bulk
		)
		, size = 3
		, alpha = .5
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = q50
			, fill = rhat
		)
		, shape = 21
		, size = 3
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = true
		)
		, size = 4
		, shape = 4
		, colour = 'blue'
	)
	+ coord_flip()
	+ scale_color_manual(
		values = lst(`TRUE`='red',`FALSE`='black')
		, labels = lst(`TRUE`='<100',`FALSE`='>=100')
	)
	+ scale_fill_manual(
		values = lst(`TRUE`='red',`FALSE`='white')
		, labels = lst(`TRUE`='>1.01',`FALSE`='<=1.01')
	)
	+ labs(
		y = 'True & Posterior Value'
		, x = 'Variable'
		, colour = 'ESS'
		, fill = 'Rhat'
	)
)

# Viz recovery of correlations ----
(
	post$draws(variables='iZc_r_vec')
	%>% posterior::as_draws_df()
	%>% select(-.draw)
	%>% pivot_longer(
		cols = -c(.chain,.iteration)
		, names_to = 'variable'
	)
	%>% group_by(variable)
	%>% arrange(variable,.chain,.iteration)
	%>% summarise(
		rhat = 1.01<posterior::rhat(matrix(value,ncol=length(unique(.chain))))
		, ess_bulk = 100>posterior::ess_bulk(matrix(value,ncol=length(unique(.chain))))
		, ess_tail = 100>posterior::ess_tail(matrix(value,ncol=length(unique(.chain))))
		, as_tibble(t(posterior::quantile2(value,c(.05,.25,.5,.75,.95))))
	)
	#add true values
	%>% left_join(
		tibble(
			true = iZc_r_vec
			, variable = case_when(
				length(true)==1 ~ 'r'
				, T ~ paste0('iZc_r_vec[',1:length(true),']')
			)
		)
	)
	%>% mutate(variable = factor_1d(variable))
	%>% ggplot()
	+ geom_hline(yintercept = 0)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q5
			, ymax = q95
			, colour = ess_tail
		)
		, alpha = .5
	)
	+ geom_linerange(
		mapping = aes(
			x = variable
			, ymin = q25
			, ymax = q75
			, colour = ess_bulk
		)
		, size = 3
		, alpha = .5
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = q50
			, fill = rhat
		)
		, shape = 21
		, size = 3
	)
	+ geom_point(
		mapping = aes(
			x = variable
			, y = true
		)
		, size = 4
		, shape = 4
		, colour = 'blue'
	)
	+ coord_flip()
	+ scale_color_manual(
		values = lst(`TRUE`='red',`FALSE`='black')
		, labels = lst(`TRUE`='<100',`FALSE`='>=100')
	)
	+ scale_fill_manual(
		values = lst(`TRUE`='red',`FALSE`='white')
		, labels = lst(`TRUE`='>1.01',`FALSE`='<=1.01')
	)
	+ labs(
		y = 'True & Posterior Value'
		, x = 'Variable'
		, colour = 'ESS'
		, fill = 'Rhat'
	)
)

# fit with brms to compare sampling speed ----
library(brms)
brms_data = mutate(dat,id = factor(individual))
brms_formula = bf(
	formula = value ~ G1*G2*C1*C2 + ( C1*C2 | id )
	, family = gaussian()
)
brms_prior = c(
	prior(normal(0, 1), class = 'Intercept')
	, prior(normal(0, 1), class = 'b')
	, prior(weibull(2, 1), class = 'sigma')
	, prior(lkj(1), class = 'cor')
	, prior(normal(0, 1), class = 'sd')
)
brms_standata = make_standata(
	data = brms_data
	, formula = brms_formula
)
attr(brms_standata,'class') = NULL
brms_stancode = make_stancode(
	data = brms_data
	, formula = brms_formula
	, prior = brms_prior
	, normalize = F
)
brms_code_path = 'brms/brms_hmg.stan'
# write( brms_stancode, file = brms_code_path ) #commented-out bc after initial write I edited the file a bit

# ensure model is compiled
aria:::check_and_compile(
	brms_code_path
	, compile_debug = F
	, run_debug = F
	, block = T
)

# compose
brms_post_path = 'posteriors/brms.netcdf4'
aria::compose(
	data = brms_standata
	, code_path = brms_code_path
	, out_path = brms_post_path
	, overwrite = T
	, block = T
)

# how long did it take?
aria::marginalia()$time

# check posterior diagnostics ----
post = aria::coda(brms_post_path)

# Check treedepth, divergences, & rebfmi
(
	post$draws(group='sample_stats')
	%>% posterior::as_draws_df()
	%>% group_by(.chain)
	%>% summarise(
		max_treedepth = max(treedepth)
		, num_divergent = sum(divergent)
		, rebfmi = var(energy)/(sum(diff(energy)^2)/n()) # n.b. reciprocal of typical EBFMI, so bigger=bad, like rhat
	)
)

# gather summary for core parameters (inc. r̂ & ess)
(
	post$draws(group='parameters')
	%>% posterior::summarise_draws(.cores=parallel::detectCores())
) ->
	par_summary

# show the ranges of r̂/ess's
(
	par_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

# View those with suspect r̂
(
	par_summary
	%>% filter(rhat>1.01)
	%>% (function(suspects){
		if(nrow(suspects)>1){
			View(suspects)
		}
		return(paste('# suspect parameters:',nrow(suspects)))
	})()
)


### Function to simulate traits with causative markers for GWAS

# need genomic data . A sample of 22k random SNPs from the Arabidopsis 1001G Projekt is available as example for Arabidopsis traits
# a file with the Information of all 2029 accessions for which genotype data exist is also provided (lat_long_2029.csv). This information has been downloaded from the AraPheno database

#A<-read.csv('~/git/GWAS/data/lat_long_2029.csv')
#If you use own data ensure that the id should be in a column called 'accession_id'
#load('~/git/GWAS/data/X_Mix.rda')
#rownames(X) needs to be the ids of the accessions
# for models with multiple causative markers, it is recommended to have them orderd by the amount of variance explained (ve)

# the simulation create random, but reproducible (seed) phenotypes.
# to simulate only in specific accession provide an integer of accessions ids in sp_acc (length need to be >1).
# to siumulate distinct markers, the script can be modified manually.

sim_Y<-function(n=100,acc=A,sp_acc=0,no_acc=200,fix_acc=TRUE,SNPs=X,no_snps=1,ve=.1,mac=5,h2=0.7,seed=42) {
  stopifnot(no_snps>0)
  stopifnot(length(ve)==no_snps)
  set.seed(seed)

  Sim<-list()
  Caus<-list()
if (length(sp_acc)>1){
  a<-sp_acc
  no_acc=length(a)
}else {
a<-sample(acc$accession_id,no_acc) }

X_<-SNPs[rownames(SNPs)%in%a,]

af<-apply(X_,2,sum)
X_ok<-X_[,which(af>mac&af<(no_acc-mac))]

u<-1
# set the seed
set.seed(seed+u)

caus<-X_ok[,sample(1:ncol(X_ok),(no_snps+1))]

#generating polygenic background

X3<-X_ok[,!colnames(X_ok)%in%colnames(caus)]

back<-X3[,sample(1:ncol(X3),1000)]

betas<-rnorm(1000,mean=0,sd=0.1)
first<- back %*% betas
### adding genetic background to data
sim<-data.frame(ecot_id=as.integer(rownames(back)),value=first)
### set heritability
dat<-var(sim[,2])

h_2<-dat/h2-dat
fix1<-rnorm(nrow(back),0,sqrt(h_2))
sim_<-data.frame(ecot_id=as.integer(rownames(back)),value=first+fix1)

for ( t in 1:length(ve)) {
beta<-sqrt((ve[t]/(1-ve[t]))*(var(sim_[,2])/var(caus[,t])))

cand<-beta*caus[,t]
sim_$value<-sim_$value+cand

}
Sim[[u]]<-sim_
Caus[[u]]<-colnames(caus)[1:t]

if (fix_acc==FALSE) {
  for ( u in 2:n ) {
    set.seed(seed+u)
  a<-sample(A$accession_id,no_acc)
  X_<-subset(X,rownames(X)%in%a)

  af<-apply(X_,2,sum)
  X_ok<-X_[,which(af>mac&af<(no_acc-mac))]

  caus<-X_ok[,sample(1:ncol(X_ok),(no_snps+1))]

  #generating polygenic background

  X3<-X_ok[,!colnames(X_ok)%in%colnames(caus)]

  back<-X3[,sample(1:ncol(X3),1000)]

  betas<-rnorm(1000,mean=0,sd=0.1)
  first<- back %*% betas
  ### adding genetic background to data
  sim<-data.frame(ecot_id=as.integer(rownames(back)),value=first)
  ### set heritability
  dat<-var(sim[,2])

  h_2<-dat/h2-dat
  fix1<-rnorm(nrow(back),0,sqrt(h_2))
  sim_<-data.frame(ecot_id=as.integer(rownames(back)),value=first+fix1)

  for ( t in 1:length(ve)) {
    beta<-sqrt((ve[t]/(1-ve[t]))*(var(sim_[,2])/var(caus[,t])))

    cand<-beta*caus[,t]
    sim_$value<-sim_$value+cand

  }
  Sim[[u]]<-sim_
  Caus[[u]]<-colnames(caus)[1:t]
}
  }else {
  for ( u in 2:n ) {
    set.seed(seed+u)

  caus<-X_ok[,sample(1:ncol(X_ok),(no_snps+1))]

  #generating polygenic background

  X3<-X_ok[,!colnames(X_ok)%in%colnames(caus)]

  back<-X3[,sample(1:ncol(X3),1000)]

  betas<-rnorm(1000,mean=0,sd=0.1)
  first<- back %*% betas
  ### adding genetic background to data
  sim<-data.frame(ecot_id=as.integer(rownames(back)),value=first)
  ### set heritability
  dat<-var(sim[,2])

  h_2<-dat/h2-dat
  fix1<-rnorm(nrow(back),0,sqrt(h_2))
  sim_<-data.frame(ecot_id=as.integer(rownames(back)),value=first+fix1)

  for ( t in 1:length(ve)) {
    beta<-sqrt((ve[t]/(1-ve[t]))*(var(sim_[,2])/var(caus[,t])))

    cand<-beta*caus[,t]
    sim_$value<-sim_$value+cand

  }
  Sim[[u]]<-sim_
  Caus[[u]]<-colnames(caus)[1:t]
}
}

return(list(Y=Sim,Caus=Caus))
}


#' net_index
#'
#' Calculate the Net Effective Temperature (NET) incorporating ambient temperature in degC , wind speed (m/s), and relative humidity (%). It is used in  hot and cold situations.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @param wind numeric Windspeed in meters per second.
#' @return Net Effective Temperature
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references Cho KLA, Margaret Loughnan M, and Tapper T, 2013, An Exploration of Temperature Metrics for Further Developing the Heat-Health Weather Warning System in Hong Kong.
#' @export
#'
#'
#'
#'

net_index=function(t, rh, wind) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=net_index(t[i],rh[i],wind[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


paren <- function(xs, ys) {
  if (length(ys) == 0 || is.na(ys[1])) {
    return(length(xs) == 0 || is.na(xs[1]))
  }
  if (length(xs) > 0) {
    if ((ys[1] == ")" && xs[1] == "(") || (ys[1] == "]" && xs[1] == "[") || (ys[1] == "}" && xs[1] == "{")) {
      return(paren(xs[2:length(xs)], ys[2:length(ys)]))
    }
  }
  if (ys[1] %in% ")]}") {
    return(FALSE)
  }
  paren(c(ys[1], xs, recursive=TRUE), ys[2:length(ys)])
}

cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  if (paren(vector(), strsplit(s, "")[[1]])) {
    "True"
  } else {
    "False"
  }
}), sep="\n")


#problem <- "wfg4"

#pdf(paste("forces_",problem,".pdf"))

pdf("rose.pdf")
#par(mfrow=c(2,1))

require(CircStats)

#k <- read.table("all_evaluations")

k <- read.table("all_forces")
k <- k[ k[,1] > -500, ]

#nrow(k)

#print(k)
#print(a)

x <- k[,1]
y <- k[,2]
#x <- rep(-0.002,1000)
#y <- rep(-0.002,1000)

#write.table(atan2(y,x),"aaa")

rose.diag(atan2(y,x), bins = 36, main = 'Stacked Points', pts=F)

dev.off()


# movies is already pre-loaded from the IMDB api

# Display the structure of movies
str(movies)

# Plot the genre variable of movies
plot(movies$genre)

# Plot the genre variable against the rating variable
plot(movies$genre, movies$rating)

# Plot the runtime variable of movies
plot(movies$runtime)

# Plot rating (x) against runtime (y)
plot(movies$rating, movies$runtime)


# Script to test the performance of tempering algorithms.

rm(list = ls())
gc()
set.seed(1954)  # change seed to check if behavior is consistent

# Adjust to your settings.
.libPaths("~/Rlib/")
setwd("~/Code/ising_model/scripts/")

library(ggplot2)
library(tidyverse)
library(posterior)
source("tools.r")
source("algorithms.r")
source("algorithms_potts.r")
source("algorithm_tempering.r")

## Tuning parameters for the problem
n_states <- 4  # 2 reduces to Ising model
beta_vector <- c(0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3)
# beta_vector <- c(0.5, 0.75, 1)
# options: "complete", "grid", "cube", and "gaussian"
graph_type <- "gaussian"
anti_corr <- FALSE  # allow bonds to be negative for grid and cubic graphs
B <- 0  # magnetic field
graph_size <- 128  # 16

A <- adjacency_graph(graph_size, type = graph_type, anti_corr = anti_corr)

## Tuning parameters for the algorithm
n_mc_iter <- 1e3
n_exchange <- 40  # pick an exchange such that r_hat goes to 1.0
n_burnin <- 1e3
total_sample <- n_mc_iter * n_exchange
n_chains <- 4

algo_names <- c("temp_AG", "temp_HB")
# algo_names <- c("temp_AG", "temp_HB", "AG")  #, "temp_AG_lr")
# algo_names <- c("temp_AG", "temp_HB", "temp_AG_lr")

f1 <- function(A, beta, B, init, n_iter) {
  ag_potts_simple(A = A, beta = beta, init = init, n_states = n_states,
                  n_iter = n_iter)
}

sub_adjust <- 10  # get biased results with small updates
f2 <- function(A, beta, B, init, n_iter) {
  hb_sampler(A = A, beta = beta, init = init,
             n_iter = n_iter, is_potts = TRUE,
             n_states = n_states,
             sub_sample = ceiling(graph_size / sub_adjust))
}

f3 <- function(A, beta, B, init, n_iter) {
  ag_potts_lowrank(A = A, beta = beta, init = init, n_states = n_states,
                   n_iter = n_iter, epsilon = 1e-15)
}

n_temp <- length(beta_vector)
n_algorithms <- length(algo_names)
# which_sampler <- array(c(rep(1, n_temp),
#                          rep(2, n_temp),
#                          c(1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2),
#                          rep(NA, n_temp)), dim = c(n_temp, n_algorithms))

## Tuning parameters for generated quantities
n_gen_quant <- 2
n_gen_sample <- total_sample - n_burnin

##########################################################################
## Run experiment
print(paste0("graph_size: ", graph_size, ", B-field: ", B,
             ", type: ", graph_type, ", beta: varying",
             ", anti_corr: ", anti_corr))
print("beta_vector")
print(beta_vector)

init <- array(NA, dim = c(n_chains, n_temp, graph_size))
for (c in 1:n_chains) {
  for (b in 1:n_temp) init[c, b, ] <- sample(1:n_states, graph_size, replace = T)
}

## Draw samples
samples <-
  array(NA, c(n_algorithms, n_chains, n_temp, total_sample, graph_size))
time <- rep(NA, n_algorithms)

print("Doing temp_AG sampling")
time[1] <- system.time (
  for (c in 1:n_chains) {
    samples[1, c, , , ] <- tempering(A, beta_vector, init[c, , ], n_exchange,
                                   n_mc_iter, B, f1, is_potts = TRUE,
                                   n_states = n_states)
  }
)[3]

print("Doing temp_HB sampling")
time[2] <- system.time (
  for (c in 1:n_chains) {
    samples[2, c, , , ] <- tempering(A, beta_vector, init[c, , ], n_exchange,
                                   n_mc_iter, B, f2, is_potts = TRUE,
                                   n_states = n_states)
  }
)[3]

# print("Doing AG sampling")
# time[3] <- system.time (
#   for (c in 1:n_chains) {
#     for (b in 1:n_temp) {
#       samples[3, c, b, , ] <-
#         ag_potts_simple(A = A, beta = beta_vector[b], init = init[c, b, ],
#                         n_iter = total_sample, n_states = n_states)
#     }
#   })[3]

# TODO: check implementation of AG lowrank.

# print("Doing AG_lr sampling")
# time[1] <- system.time (
#   for (c in 1:n_chains) {
#    for (b in 1:n_temp) {
#     samples[1, c, b, , ] <-
#       ag_potts_lowrank(A = A, beta = beta_vector[b], init = init[c, b, ],
#                        n_iter = total_sample, n_states = n_states,
#                        epsilon = 1e-12)
#    }
#   })[1]

# print("Doing temp_AG_lr sampling")
# time[3] <- system.time (
#   for (c in 1:n_chains) {
#       samples[3, c, , , ] <-
#         tempering(A, beta_vector, init[c, , ], n_exchange, n_mc_iter, B, f3)
#   })[3]

# Compute generated quantities
# NOTE: this part takes quite a long time...
print("Computing generated quantities")
n_gen_quant <- 2  # Add dummy gen quant to help with structure.
                  # TODO: find a better way to handle this.
gen_quant <-
  array(NA, c(n_gen_quant, n_algorithms, n_chains, n_temp,
              n_gen_sample))
index_start <- n_mc_iter * n_exchange - n_gen_sample + 1
for (j in 1:n_algorithms) {
  print(paste0("Chain: ", 0, " / ", n_chains))
  for (c in 1:n_chains) {
    for (b in 1:n_temp) {
      for (i in 1:n_gen_sample) {
        gen_quant[1, j, c, b, i] <-
          potts_log_kernel(beta_vector[b], A,
                           samples[j, c, b, index_start - 1 + i, ])
      }
    }
    print(paste0("Chain: ", c, " / ", n_chains))
  }
}

# Compute ESS, eff, and other diagnostics using the package Posterior.
dim_summary <- c(n_gen_quant, n_algorithms, n_temp)
sample_mean <- array(NA, dim = dim_summary)
sample_mcse <- array(NA, dim = dim_summary)
sample_r_hat <- array(NA, dim = dim_summary)
sample_ess <- array(NA, dim = dim_summary)
sample_eff <- array(NA, dim = dim_summary)

# TODO: check Rhat computation is working
for (j in 1:n_algorithms) {
  for (b in 1:n_temp) {
    perm_gen_quant <- array(NA, c(n_gen_quant, n_chains, n_gen_sample))
    perm_gen_quant <- aperm(gen_quant[, j, , b, ], perm = c(3, 2, 1))
    draws_formatted <- as_draws_df(perm_gen_quant)
    names(draws_formatted)[1:2] <- c("potts_log_kernel", "dummy")

    summary_sample <- summarize_draws(draws_formatted,
                               measure = c("mean", "mcse_mean", "ess_bulk", "rhat"))
    names(summary_sample) <-
      c("variable", "mean", "mcse_mean", "ess_bulk", "rhat")

    sample_mean[, j, b] <- summary_sample$mean
    sample_mcse[, j, b] <- summary_sample$mcse_mean
    sample_r_hat[, j, b] <- summary_sample$rhat
    sample_ess[, j, b] <- summary_sample$ess_bulk
    sample_eff[, j, b] <- sample_ess[, j, b] / time[j]
  }
}

# create an output file for each replica
for (b in 1:n_temp) {
  saved_summary <- data.frame(cbind(sample_mean[, , b],
                                    sample_mcse[, , b],
                                    sample_r_hat[, , b],
                                    sample_ess[, , b],
                                    sample_eff[, , b]))
  names(saved_summary) <-
    c(paste0("mean_", algo_names),
      paste0("mcse_", algo_names),
      paste0("rhat_", algo_names),
      paste0("ess_", algo_names),
      paste0("eff_", algo_names))

  print(paste0("beta = ", beta_vector[b]))
  print(paste0(saved_summary$mean_temp_AG, " ", saved_summary$mean_temp_HB))

  saved_summary
  # Can see from the summary that the heat bath algorithm is strongly biased.

  output_name <- paste0("deliv/measurements_temp/potts/", graph_size, graph_type,
                        "_", B, "_", beta_vector[b], "_summary_lr")
  write.csv(saved_summary, paste0(output_name, ".csv"))
}

# Examine the efficiency over betas.
gen_quant_index <- 1  # 1, 2, 3

# CAUTION: Don't include algorithm with biased estimates.
plot_eff <- as.vector(sample_eff[gen_quant_index, 1:2, ]) # %*%
                        # diag(1 /sample_eff[gen_quant_index, 1, ]))
plot_algo <- rep(algo_names[1:2], n_temp)
plot_beta <- rep(beta_vector, each = n_algorithms)

plot <- ggplot(data = data.frame(eff = plot_eff,
                                 algo = plot_algo,
                                 beta = plot_beta),
               aes(x = beta, y = eff, color = algo)) +
  theme_bw() + geom_point() + geom_line() +
  scale_y_continuous(trans = 'log10')
plot

# plot the mean estimated by each algorithm
# Note: the gen_quant are replaced with 1, since we're only computing
# one sufficient statistic.
mean_data <- data.frame(mean = as.vector(sample_mean[1, , ]),
                        mcse = as.vector(sample_mcse[1, , ]),
                        parm = rep(c("log_potts_kernel"),
                                   n_temp * n_algorithms),
                        algo = rep(rep(algo_names, each = 1),
                                   n_temp),
                        beta = rep(beta_vector, each = 1 * n_algorithms))

plot <-
  ggplot(data = mean_data, aes(x = beta, y = mean, color = algo)) +
  theme_bw() + geom_point() + geom_line() +
  # facet_wrap(~parm, scale = "free") +
  geom_errorbar(aes(ymin = mean - mcse, ymax = mean + mcse), alpha = 0.25)
plot

dens_data <- data.frame(potts_kernel = as.vector(gen_quant[1, , , , ]),
                    # corr = as.vector(gen_quant[3, , , , ]),
                    algo = rep(algo_names, n_chains * n_temp * n_gen_sample),
                    chain = as.factor(rep(rep(1:n_chains, each = n_algorithms),
                                n_temp * n_gen_sample)),
                    beta = rep(rep(beta_vector,
                                   each = n_algorithms * n_chains),
                               n_gen_sample)
                    )

## Compare posterior samples generated by both algorithms
dens_plot <-
  ggplot(data = dens_data[dens_data$algo %in% c("temp_AG", "temp_HB"), ],
        aes(x = potts_kernel, fill = algo)) + theme_bw() +
  geom_histogram(color = "black",alpha = 0.5,
                 bins = 30, position = "identity") +
  facet_wrap(~beta, scale = "free")
dens_plot

## Compare samples between chains
dens_plot3 <-
  ggplot(data = dens_data[dens_data$algo == "temp_AG", ],
         aes(x = potts_kernel, fill = chain)) + theme_bw() +
  geom_histogram(color = "black",alpha = 0.5,
                 bins = 30, position = "identity") +
  facet_wrap(~beta, scale = "free")
dens_plot3


# Machine learning - Breast Cancer detection with a Support Vector Machine (SVM) and k-nearest neighbours clustering model to compare results

library(readr)
breast_cancer_wisconsin <- read_csv("https://archive.ics.uci.edu/ml/machine-learning-databases/breast-cancer-wisconsin/breast-cancer-wisconsin.data", col_names = c('id', 'clump_thickness', 'uniform_cell_size', 'uniform_cell_shape', 'marginal_adehsion', 'single_epithelial_size', 'bare_nuclei', 'bland_chromatin', 'normal_nucleioli', 'mitoses', 'class'))


# Filename: audio2stl.r
# Date: 2019-06-13
# Author: Christopher Carignan
# Email: c.carignan@phonetik.uni-muenchen.de
# Institution: Institute of Phonetics and Speech Processing (IPS), Ludwig-Maximilians-Universität München, Munich, Germany
# Description:
#   Converts an audio file to a 3D spectrogram; (optionally) saves as a stereolithography (STL) file for 3D printing
# Arguments:
#   inputfile (required): filepath string associated with WAV audio file
#   outputfile (optional): filepath sring associated with STL file to save
#   sampfreq: re-sampling frequency
#   axisnorm: keep the x- and y-axes scaling (FALSE) or normalize so that they have the same dimensions (TRUE)
#   preemph: value for pre-emphasis of audio
#   window: option for windowing audio using a variety of Matlab/Octave compatible filters found in the "signal" package
#     ex: 'bartlett', 'blackman', 'hamming', 'hanning', 'triang'

# Load required libraries
libraries <- c("rayshader","dplyr","tuneR","matlab","raster","png","signal")
lapply(libraries, require, character.only = TRUE)

# Main function
audio2stl <- function (inputfile, outputfile=NULL, sampfreq=16000, axisnorm=FALSE, preemph=0.97, window=NULL) {
  # Function for resampling audio
  resampleWave <- function (object, samp.rate) {
    if ((!is.numeric(samp.rate)) || (samp.rate < 2000) || (samp.rate > 192000))
      stop("samp.rate must be an integer in [2000, 192000].")
    if (object@samp.rate > samp.rate) {
      ll      <- max(dim(object@.Data))
      object  <- object[round(seq(1, ll, length = samp.rate * ll/object@samp.rate))]
      object@samp.rate <- samp.rate
    }
    else warning("samp.rate > object's original sampling rate, hence object is returned unchanged.")
    return(object)
  }

  sndWav  <- tuneR::readWave(inputfile, toWaveMC=T) # load WAV file
  rsWav   <- resampleWave(sndWav, sampfreq) # resample to desired sampling frequency
  rsWav   <- tuneR::normalize(rsWav,unit="1") # scale audio
  fs      <- rsWav@samp.rate # get the sampling frequency
  snd     <- rsWav@.Data / (2^(rsWav@bit-1)) # get the audio data
  # if the file is stereo, only use the first channel
  if (length(dim(snd)) > 1){
    snd <- snd[,1]
  }

  # Implement pre-emphasis of audio, according to the function:
  # ŝ(x) = s(x)-k*s(x-1)
  snd_preemph <- rep(0, length(snd))
  for(i in 2:length(snd)){
    snd_preemph[i] <- snd[i] - preemph * snd[i - 1]
  }

  # Implement windowing of audio, if a window is provided
  if (!is.null(window)) {
    eval(parse(text=paste("wind <- signal::",window,"(length(snd_preemph))")))
    snd_preemph <- snd_preemph*wind
  }

  # Create standard (i.e., 2.5D) spectrogram
  spec  <- powspec(snd_preemph, sr=fs, wintime=0.025, steptime=0.01, dither=FALSE) # power spectrum
  spec  <- 10*log10(abs(spec)) # convert to absolute spectrum

  # Optional normalization of dimensions of x- and y-axes
  if (axisnorm) {
    height  <- nrow(spec)
    width   <- ncol(spec)

    r <- raster::raster(spec) # rasterize the spectrogram
    raster::extent(r) <- raster::extent(c(-180, 180, -90, 90)) # geographical coordinates of raster
    if (height > width) {
      s <- raster::raster(ncol=height, nrow=height) # stretch width if height > width
    } else if (width > height) {
      s <- raster::raster(ncol=width, nrow=width) # stretch height if height < width
    } else {
      return # if the dimensions are already the same, do nothing
    }
    s <- raster::resample(r,s) # resample rasterized matrix
    spec <- as.matrix(s) # convert rasterized spectrogram back to matrix object
  }

  # Create grayscale map to overlay on 3D spectrogram
  tempfilename <- tempfile()
  png(tempfilename, width=nrow(spec), height=ncol(spec))
  par(mar=c(0,0,0,0))
  raster::image(matlab::fliplr(spec), axes=FALSE, col=rev(gray.colors(50, start=0, end=1)))
  dev.off()
  #tempmap <- png::readPNG(tempfilename)

  # Create and plot the 3D spectrogram
  spec %>%
    rayshader::sphere_shade(texture="bw", sunangle=45) %>%
    #rayshader::add_overlay(tempmap, alphalayer=0.75) %>%
    rayshader::add_overlay(tempfilename, alphalayer=0.75) %>%
    rayshader::plot_3d(spec, zscale=1, theta=225)

  # If an output file is provided, save the 3D spectrogram as an STL file
  if (!is.null(outputfile)) {
    rayshader::save_3dprint(outputfile, maxwidth=50, unit="mm")
  }

  rayshader::render_snapshot()
}


position=c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50)
A_count=c(5,6,5,11,5,4,11,9,12,8,9,9,14,10,9,10,8,9,7,12,10,9,14,13,12,9,11,11,13,9,8,7,7,11,6,8,9,11,8,8,12,9,10,7,10,10,7,9,10,8,7)
C_count=c(7,7,9,9,9,11,7,8,9,9,8,6,8,6,9,10,4,9,5,8,6,9,6,11,8,13,16,8,6,9,6,9,8,11,12,17,8,9,9,12,9,13,12,13,12,10,10,9,6,10,8)
G_count=c(18,15,18,14,12,19,12,12,11,8,9,11,12,9,7,9,6,10,11,4,9,15,11,11,7,4,7,13,9,12,15,11,14,10,13,11,7,12,10,11,10,11,9,11,6,9,10,12,14,13,9)
T_count=c(10,8,5,4,14,6,10,9,8,10,14,14,6,15,15,9,14,9,12,10,15,7,9,5,10,8,6,8,12,10,11,13,11,8,9,4,16,8,13,9,9,7,9,9,12,11,13,10,10,9,16)
N_count=c(0,4,3,2,0,0,0,2,0,5,0,0,0,0,0,2,8,3,5,6,0,0,0,0,3,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
X_count=c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
total= A_count + C_count + G_count + T_count
ym=max(A_count/total,C_count/total,G_count/total,T_count/total) + 0.05
yn=min(A_count/total,C_count/total,G_count/total,T_count/total)
pdf("output.NVC_plot.pdf")
plot(position,A_count/total,type="o",pch=20,ylim=c(yn,ym),col="dark green",xlab="Position of Read",ylab="Nucleotide Frequency")
lines(position,T_count/total,type="o",pch=20,col="red")
lines(position,G_count/total,type="o",pch=20,col="blue")
lines(position,C_count/total,type="o",pch=20,col="cyan")
legend(41,ym,legend=c("A","T","G","C"),col=c("dark green","red","blue","cyan"),lwd=2,pch=20,text.col=c("dark green","red","blue","cyan"))
dev.off()


# Data Visualization with ggplot
# Modifying the Background
# Video 3.1

# Load the dataset as described in Video 1.3
library(tidyverse)
college <- read_csv('http://672258.youcanlearnit.net/college.csv')
college <- college %>%
  mutate(state=as.factor(state), region=as.factor(region),
         highest_degree=as.factor(highest_degree),
         control=as.factor(control), gender=as.factor(gender),
         loan_default_rate=as.numeric(loan_default_rate))

# Create the bar graph from Video 2.3
ggplot(data=college) +
  geom_bar(mapping=aes(x=region, fill=control))


library(SummarizedExperiment)

counts_to_fpkm <- function(counts, featureLength) {
  stopifnot(length(featureLength) == nrow(counts))

  # Process one column at a time.
  result <- do.call(cbind, lapply(1:ncol(counts), function(i) {
    countI<-counts[,i]
    totalCount<-sum(countI)
    res<-(10^9)*countI/(featureLength*totalCount)
    return(res)
  }))

  # Copy the row and column names from the original matrix.
  colnames(result) <- colnames(counts)
  rownames(result) <- rownames(counts)
  return(result)
}

counts_to_tpm <- function(counts, featureLength) {
  stopifnot(length(featureLength) == nrow(counts))

  logFeatureLength<-log(featureLength)

  # Process one column at a time.
  tpm <- do.call(cbind, lapply(1:ncol(counts), function(i) {
    rate = log(counts[,i]) - logFeatureLength[i]
    denom = log(sum(exp(rate)))
    exp(rate - denom + log(1e6))
  }))

  # Copy the row and column names from the original matrix.
  colnames(tpm) <- colnames(counts)
  rownames(tpm) <- rownames(counts)
  return(tpm)
}

DEBUG=0

args = commandArgs(trailingOnly=TRUE)
cancerName = args[1]
outputFolder = args[2]
geneLengthFile = args[3]

if(DEBUG){
  cancerName = "SKCM"
  outputFolder = "/scratch/cqs/shengq2/guoyan/prepareRnaseq/result/SKCM"
  geneLengthFile = "/scratch/cqs/shengq2/references/gencode/hg19/gencode.v19.chr_patch_hapl_scaff.annotation.gtf.genelength"
}

setwd(outputFolder)

project = paste0("TCGA-", cancerName)
countFile<-paste0(cancerName, ".rnaseq2.count.rdata")

if(!file.exists(countFile)){
  library(TCGAbiolinks)
  query <- GDCquery(project = project,
                    data.category = "Gene expression",
                    data.type = "Gene expression quantification",
                    experimental.strategy = "RNA-Seq",
                    platform = "Illumina HiSeq",
                    file.type  = "results",
                    legacy = TRUE)

  source <- ifelse(query$legacy, "legacy", "harmonized")
  files <- file.path(outputFolder, "GDCdata", query$project, source, gsub(" ", "_", query$results[[1]]$data_category), gsub(" ", "_", query$results[[1]]$data_type),
                     gsub(" ", "_", query$results[[1]]$file_id), gsub(" ", "_", query$results[[1]]$file_name))
  tcgaNames<-substring(query$results[[1]]$cases,1,15)

  tcgaFiles<-data.frame(Name=tcgaNames, File=files)
  write.table(tcgaFiles, paste0(cancerName, ".rnaseq2.filelist"), sep="\t", quote=F, row.names=F)

  GDCdownload(query, method = "api", files.per.chunk = 10)
  rnaseq <- GDCprepare(query)

  save(rnaseq, file=countFile)
}else{
  load(countFile)
}

pos<-rowRanges(rnaseq)
pos<-data.frame(pos)
pos<-pos[,c("ensembl_gene_id", "seqnames", "start", "end", "gene_id")]

exp<-assay(rnaseq)
rownames(exp)<-pos$ensembl_gene_id

isdup<-duplicated(pos$ensembl_gene_id)
pos<-pos[!isdup,]
exp<-exp[!isdup,]

#get gene length
geneLength<-read.table(geneLengthFile, sep="\t", header=T, stringsAsFactor=F)
rownames(geneLength)<-gsub("\\.\\d+","",geneLength$gene_id)
pos$length<-geneLength[pos$ensembl_gene_id,"length"]

#sort pos by chromosome and start
pos$seqnames<-substring(pos$seqnames, 4)
pos$seqnamesX<-grepl('[XYZ]', pos$seqnames)
pos$seqnamesN<-as.numeric(pos$seqnames)
pos<-pos[with(pos, order(seqnamesX, seqnamesN, seqnames, start, end)), c("ensembl_gene_id", "seqnames",    "start" ,     "end"      ,"length","gene_id")]

#save position file
genepos<-pos[,c("ensembl_gene_id", "seqnames",    "start" ,     "end" )]
colnames(genepos)<-c("geneid", "chr", "s1", "s2")
write.table(genepos, file=paste0(cancerName, ".rnaseq2.gene.pos"), sep="\t", row.names=F, quote=F)

exp<-exp[as.character(pos$ensembl_gene_id),]
colnames(exp)<-substring(colnames(exp), 1, 15)
colnames(pos)<-c("Feature", "Feature_chr", "Feature_start", "Feature_end", "Feature_length", "Feature_gene_name")

fpkm<-counts_to_fpkm(exp, pos$Feature_length)
tpm<-counts_to_tpm(exp, pos$Feature_length)

normalNames<-colnames(exp)[grepl("11$", colnames(exp))]
tumorNames<-colnames(exp)[grepl("01$", colnames(exp))]

names(normalNames)<-gsub("-11", "", normalNames)
names(tumorNames)<-gsub("-01", "", tumorNames)

exportNames<-list()
exportNames[["Solid_Tissue_Normal"]]<-normalNames
exportNames[["Primary_Solid_Tumor"]]<-tumorNames

dataMap<-list()
dataMap[["count"]]<-exp
dataMap[["fpkm"]]<-fpkm
dataMap[["tpm"]]<-tpm

for(dataName in names(dataMap)){
  data<-dataMap[[dataName]]
  write.table(cbind(pos, data), file=paste0(cancerName, ".rnaseq2.", dataName, ".tsv"), sep="\t", row.names=F, quote=F)

  for(exportName in names(exportNames)){
    fileNames<-exportNames[[exportName]]
    subdata<-data[,fileNames]
    if(is.matrix(subdata) && ncol(subdata) > 0){
      write.table(cbind(pos, subdata), file=paste0(cancerName, ".rnaseq2.", dataName, "." , exportName, ".tsv"), sep="\t", row.names=F, quote=F)
    }
  }
}


#Preenchimento com Knn
setwd('/home/lucas/Dev/git/mlclass-private/01_Preprocessing')
diaInfo <- read.csv(file = 'diabetes_dataset.csv')
diaAva <- read.csv(file = 'diabetes_app.csv')
diaFilled <- read.csv(file = 'fillKnn.csv')
meanDia1 <- c()
meanDia0 <- c()
maxValue <- c()
minValue <- c()
sdDia0 <- c()
sdDia1 <- c()
medianDia0 <- c()
medianDia1 <- c()

setDia1 <- diaInfo[which(diaInfo$Outcome == 1),]
setDia0 <- diaInfo[which(diaInfo$Outcome == 0),]

setDia1Fill<-diaFilled[which(diaFilled$Outcome==1),]
setDia0Fill<-diaFilled[which(diaFilled$Outcome==0),]
# corDia1 <- c()
# corDia0 <- c()
# corDia1 <- cor(setDia1,use="complete.obs")
# corDia0 <- cor(setDia0,use="complete.obs")
# lm(setDia1[,2] ~ setDia1[,5], data=setDia1)
# pairs(setDia1)
# pairs(setDia0)

distance = function(line1, line2) {
  distVector <- abs(line1 - line2)
  dist <- abs(sum(distVector, na.rm = TRUE))
  return(dist)
}

fillKnn = function(dataSet, number) {
  for(row in 1:nrow(dataSet)) {
    for(col in 1:length(dataSet)) {
      if(is.na(dataSet[row,col])){
        bests <- c()
        for (rowTemp in 1:nrow(dataSet)) {
          if(!is.na(dataSet[rowTemp,col])){
            dist <- distance(dataSet[row,],dataSet[rowTemp,])
            line <- rowTemp
            pair <- c(line, dist)

            if( is.null(bests)||nrow(bests) < number ) {
              bests <- rbind(bests,pair)
            } else {
              for(i in 1:number) {
                if( pair[2] < bests[i,2] ) {
                  bests[i,] <- pair
                  break()
                }
              }
            }
          }
        }
        value <- c()
        for(i in number) {
          value <- cbind(value,dataSet[bests[i,1],col])
        }
        dataSet[row,col] <- mean(value)
      }
    }
  }
  return(dataSet)
}

randomize = function(dataSet,dataVerif) {
  for(i in 1:nrow(dataSet)){
    for(j in 1:8){
      if(is.na(dataVerif[i,j])) {
        if(dataSet[i,9] == 1) {
          dataSet[i,j] = rnorm(1, mean = dataSet[i,j], sd = dataSet[i,j]*0.7)
        } else {
          dataSet[i,j] = rnorm(1, mean = dataSet[i,j], sd = dataSet[i,j]*0.7)
        }
      }
    }
  }
  return(dataSet)
}

for(categ in 1:8){
  meanDia1[categ] <- mean(setDia1[,categ],na.rm = TRUE)
  meanDia0[categ] <- mean(setDia0[,categ],na.rm = TRUE)
  maxValue[categ] <- max (diaInfo[,categ],na.rm = TRUE)
  minValue[categ] <- min (diaInfo[,categ],na.rm = TRUE)
  sdDia1  [categ] <- sd  (setDia1[,categ],na.rm = TRUE)
  sdDia0  [categ] <- sd  (setDia0[,categ],na.rm = TRUE)
  medianDia1[categ] <- median(setDia1[,categ],na.rm = TRUE)
  medianDia0[categ] <- median(setDia0[,categ],na.rm = TRUE)
}
removeOutliers = function(dataSet) {
  for (row in nrow(dataSet)){
    if (dataSet[row,9] == 0){
      if (dataSet[row,2] > 175) {
        dataSet[row,2] = rnorm(1, mean = meanDia0[2], sd = sdDia0[2])
      }
      if (dataSet[row,5] > 400) {
        dataSet[row,5] = rnorm(1, mean = meanDia0[5], sd = sdDia0[5])
      }
      if (dataSet[row,6] > 46) {
        dataSet[row,6] = rnorm(1, mean = meanDia0[6], sd = sdDia0[6])
      }
      if (dataSet[row,8] > 62) {
        dataSet[row,8] = rnorm(1, mean = meanDia0[8], sd = sdDia0[8])
      }
    } else {
      if (dataSet[row,5] > 350) {
        dataSet[row,5] = rnorm(1, mean = meanDia1[5], sd = sdDia1[5])
      }
      if (dataSet[row,6] > 50) {
        dataSet[row,6] = rnorm(1, mean = meanDia1[6], sd = sdDia1[6])
      }
    }
  }
  return(dataSet)
}
{
  weight <- c()
  weight[1]<-3        #Pregnancies
  weight[2]<-2.7        #Glucose
  weight[3]<-0.5        #BloodPressure
  weight[4]<-0        #SkinThickness
  weight[5]<-1        #Insulin
  weight[6]<-2.8       #BMI
  weight[7]<-0        #Pedigree
  weight[8]<-6.3        #Age

  normalizeData = function(df) {
    for(i in 1:8){
      df[,i] <- (df[,i]/maxValue[i])*weight[i]
    }
    return(df)
  }

  test0 = randomize(removeOutliers(setDia0Fill), setDia0)
  test1 = randomize(removeOutliers(setDia1Fill), setDia1)
  dfAva <- normalizeData(diaAva)
  dfInfo <- normalizeData(removeOutliers(diaFilled))
  # dfInfo <- normalizeData(rbind(setDia0Fill10,setDia1Fill10))#normalizeData(diaFilled)
  # dfInfo <- normalizeData(rbind(test0,test1))
  write.csv(dfAva[1:8], file = 'Valuator.csv', row.names = FALSE)
  write.csv(dfInfo[1:9], file = 'Output.csv', row.names = FALSE)
}


##################################################################################################################
####  Purpose: Final Project - Classification - KKNN
####  Group: Ravi P., Derek P., Aneesh K., Ninad K.
####  Date: 11/28/2018
####  Comment:
####    setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
####
##################################################################################################################

setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")

#### 0. Clean environment ####
rm(list = ls())

#### 1. Import libraries and datasets ####
library(kknn)

df_train <- read.csv("./data/train_new.csv")
df_test <- read.csv("./data/test_new.csv")

#### 2. Remove unwanted column ####
df_train <- df_train[,-1]
df_test <- df_test[,-1]

summary(df_test)

df_train$SimpleColor <- as.integer(df_train$SimpleColor)
df_test$SimpleColor<- as.integer(df_test$SimpleColor)

df_k1 <- kknn(OutcomeType~ AnimalType + AgeinDays + HasName + IsNeutered + IsMix + Gender + SimpleColor, df_train, df_test, k = 1)
fit <- fitted(df_k1)
table(df_test$OutcomeType, fit)
wrong<- (df_test[,2] != fit)
rate<-sum(wrong)/length(wrong)
print(rate)

#### 3. KKNN Test and Error Rate ####

for(i in c(1,5,10,20,30,40,50,60,70,80,90,100)){
  predict<- kknn(OutcomeType~ AnimalType + AgeinDays + HasName + IsNeutered + IsMix + Gender +SimpleColor, train = df_train, test = df_test, k = i)
  fit<- fitted(predict)
  wrong<- (df_test[,2] != fit)
  rate<-sum(wrong)/length(wrong)
  cat(sprintf("k = %f Performance: %f \n",i, rate))
}

predict<- kknn(OutcomeType~ AnimalType + AgeinDays + HasName + IsNeutered + IsMix + Gender +SimpleColor, train = df_train, test = df_test, k = 70)
fit<- fitted(predict)
wrong<- (df_test[,2] != fit)
rate<-sum(wrong)/length(wrong)
cat(sprintf("k = %f Performance: %f \n",70, rate))
table(df_test$OutcomeType, fit)


require( dplyr )
require( raster )
require( rgdal )
require( rgeos )
require( ncdf4 )

basin = c('Indus')
setwd('P:/is-wel/indus/message_indus')

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
proj4string(basin.sp) = proj4string(basin.spdf)

# Import the groundwater table depth from the p drive
gtd.raster = raster('input/groundwater_table_depth/Eurasia_model_wtd_v2.nc')
gtd.raster = mask( x = crop( gtd.raster, extent( basin.sp ), snap = "out" ), mask = rasterize( spTransform( basin.sp, crs( gtd.raster ) ), crop( gtd.raster, extent( basin.sp ), snap="out") ) )

# Average depth by district
bsn = spTransform( basin.spdf[,'PID'], crs(gtd.raster) )
gtd.df = data.frame( PID = basin.spdf@data$PID,
					 avg_depth_m = sapply( 1:length( bsn ), function( bbb ){ mean( unlist( raster::extract( gtd.raster, bsn[bbb,] ) )  , na.rm=TRUE ) } ) )

### For the Indus will alternatively use raw well data

# Raw well depth data from csv
res = data.frame( read.csv('input/Water level data _2000_2014.csv', stringsAsFactors = FALSE ) ) %>%
		dplyr::select( Lat_dec , Lon_dec , SITE_ID , SITE_NAME , TOPOSHEET_ , SITE_TYPE , STATE_NAME , DISTRICT_N , TAHSIL_NAM , BLOCK_NAME , VILLAGE_NA , WLS_DATE , Date , Water.Level..m.bgl. ) %>%
		mutate( year = sapply( Date , function(x){ unlist( strsplit( x, '-' ) )[3] } ) )

# Add the year
res$year = sapply( res$Date , function(x){ unlist( strsplit( x, '-' ) )[3] } )

# Get the unique site ids
site_ids = unique(res$SITE_ID)

# Aseemble list of measurements for each station
water_table_sites.list = lapply( site_ids, function(x){ res[ res$SITE_ID == x , ] } )
names( water_table_sites.list ) = site_ids

# Get the years
yrs = unique( res$year )[ order( unique( res$year ) ) ]

# Return a data frame that contains the measuresments at each site in each year
water_table_sites.df = data.frame( do.call( rbind, lapply( site_ids, function(s){ sapply( yrs, function(yy){ if( yy %in% water_table_sites.list[[ s ]]$year ){ return( mean( water_table_sites.list[[ s ]][ water_table_sites.list[[ s ]]$year == yy, 'Water.Level..m.bgl.' ] ) ) }else{ return( NA ) } } ) } ) ) )
names( water_table_sites.df ) = yrs
row.names( water_table_sites.df ) = site_ids

# Add the id and lat and lon and re-organize
water_table_sites.df$id = row.names( water_table_sites.df )
water_table_sites.df$lat = sapply( 1:length(water_table_sites.list), function(x){ water_table_sites.list[[ x ]]$Lat_dec[1] } )
water_table_sites.df$lon = sapply( 1:length(water_table_sites.list), function(x){ water_table_sites.list[[ x ]]$Lon_dec[1] } )
water_table_sites.df = water_table_sites.df[,c('id','lat','lon',yrs)]

# Convert to spatial data frame
water_table_sites.spdf = water_table_sites.df
coordinates(water_table_sites.spdf) = ~lon+lat

# Harmonize the geographical projections
proj4string( water_table_sites.spdf ) = proj4string( gtd.raster )
water_table_sites.spdf = spTransform( water_table_sites.spdf, crs( gtd.raster ) )

# Just keep the parts in the Indus basin
basin.spdf = spTransform( basin.spdf, crs( gtd.raster ) )
basin.sp = spTransform( basin.spdf, crs( gtd.raster ) )

# Add the global groundwater depth data from Fan et al 2013
pts = as( water_table_sites.spdf, 'SpatialPoints' )
water_table_sites.spdf@data$Fan_2010 = unlist( extract( gtd.raster, pts ) )

x1 = water_table_sites.spdf@data$Fan_2010
x2 = unlist( data.frame(water_table_sites.spdf)[,'X2010'] )
nn = which( is.na(x1) | is.na(x2) | x1 <= 0 | x2 <= 0 )
x1 = x1[-1*nn]
x2 = x2[-1*nn]
plot(x1,x2,xlab='Fan et al 2013',ylab='Well data')
x3 = x1/x2-1
x3 = x3[-1*which(is.na(x3))]

# Rasterize @ 0.25 degrees (~25km),
# the data is irregularly spaced data and is rasterized using the mean of points found in each 0.25 degree cell
# Create empty raster @ 0.25 degrees - this will be used to sample the irregularly spaced data
rb = raster() #
res(rb) = 0.25 # Set the resolution
rb[] = -9999 # Some values for now
rb = crop(rb,extent(pts)) # crop to the area containing the sites
clls = cellFromXY(rb,pts) # Get the 0.25 degree grid cell associated with each site
clls = clls[!is.na(clls)] # Remove NA
df = data.frame(water_table_sites.spdf) # Get the data frame containing all the site data

# Create a raster stack containing each year in the site data
stk = do.call( stack, lapply( yrs, function(yy){
	r1 = rb
	# The raster cell value is equal to the mean of all sites found to lie within that raster cell
	r1[ unique( clls ) ]  = sapply( unique( clls ), function( cc ){ return( mean( unlist( df[ which( clls == cc ) , paste('X',yy,sep='') ] ), na.rm = TRUE ) ) } )
	# Set non-sensical values to NA
	r1[ r1[] <= 1 ] = NA
	return(r1)
	} ) )
names(stk) = yrs

# Keep specific years and take mean
gtd2.raster = mean( do.call( stack, lapply( c('X2010','X2011','X2012','X2013','X2014'), function( ttt ){ stk[[ttt]] } ) ) )

gtd2.df = data.frame( 	PID = basin.spdf@data$PID,
						avg_depth_m = sapply( 1:length( bsn ), function( bbb ){

							x  = unlist( raster::extract( gtd2.raster, bsn[bbb,] ) )

							if( length(x) > 1 ){

								return( quantile( x, 0.5, na.rm=TRUE ) )

								}else{ return( NA ) }

							} )

						)

# Temporary - Use mean where no data exists - will update
gtd2.df[ which( is.na(gtd2.df$avg_depth_m) ), 'avg_depth_m' ] = mean( gtd2.df$avg_depth_m, na.rm = TRUE )

# Energy use in GW / MCM/day
gtd2.df$GW_per_MCM_per_day = round( 0.85 * 9.81 / 86400 * gtd2.df$avg_depth_m , digits = 5 )

write.csv( gtd2.df, 'input/gw_energy_intensity.csv', row.names = FALSE)


# source("lib/tabeli.r")

prvi.graf <- function() {
  attach(nutrition)
  y <- table(Calories.per.Serving.Size)

  plot(c(0, 5), c(0, 41), type="n", xlab = "Kategorija \n (Glede na kalorije na velikost porcije)", ylab = "Število jedi")
  abline(h = 0)
  abline(v = 0)

  rect(0:4, 0, 1:5, y, col = c("red", "blue", "#82c5dc", "grey", "green"))

  lines(c(0, 1), c(y[2], y[2]), lty = "dashed")
  lines(c(0, 2), c(y[3], y[3]), lty = "dashed")
  lines(c(0, 0.25), c(y[4], y[4]), lty = "dashed")

  text(0.07, y[1:4], pos = 2, y[1:4])

  legend("topright",
         legend = rownames(y),
         col = c("red", "blue", "#82c5dc", "grey", "green"),
         lty = c("solid", "solid", "solid", "solid", "solid"),
         bg = "white")

  detach(nutrition)
}

drugi.graf <- function() {
  attach(sestavine)
  y <- table(RAZVRSTITEV)
  barplot(y, names.arg = rownames(y), col = c("grey", "#82c5dc", "red"), xlab = "Razvrstitev \n (Glede na stevilo sestavin iz seznama, ki so v jedi)", ylab = "Število jedi")
  detach(sestavine)
}

tretji.graf <- function() {
  attach(nutrition)

  urejeni <- nutrition[order(Calories, decreasing=TRUE),]
  plot(c(0, 16), c(-80, 760), type="n", xlab = "Jedi", ylab = "Kalorije", axes = FALSE)
  abline(h = 0)
  abline(v = 0)

  rect(11:15, 0, 12:16, urejeni[5:1, 3])
  rect(6:10, 0, 7:11, urejeni[30:26, 3])
  rect(0:5, 0, 1:6, sort(tail(urejeni[,3])))

  lines(c(-0.05, 15), c(urejeni[1, 3], urejeni[1, 3]), lty = "dashed")
  lines(c(-0.05, 8), c(urejeni[28, 3], urejeni[28, 3]), lty = "dashed")
  lines(c(-0.05, 0.05), c(100, 100))
  lines(c(-0.05, 0.05), c(300, 300))
  lines(c(-0.05, 0.05), c(500, 500))
  lines(c(-0.05, 0.05), c(700, 700))
  lines(c(-0.05, 0), c(sort(tail(urejeni[,3]))[1], sort(tail(urejeni[,3]))[1]))

  text(0.15, c(100, 300, 500, 700), pos = 2, c(100, 300, 500, 700), cex = 0.5)
  text(0.15, sort(tail(urejeni[,3]))[1], pos = 2, sort(tail(urejeni[,3]))[1], cex = 0.5)
  text(0.15, urejeni[28, 3], pos = 2, urejeni[28, 3], cex = 0.5)
  text(0.15, urejeni[1, 3], pos = 2, urejeni[1, 3], cex = 0.5)

  text(0.5:5.5, c(-60, -60, -60, -60, -60, -60), substr(sort(tail(urejeni[,1])), 1, 12), srt = -60, cex = 0.5)
  text(6.5:10.5, c(-60, -60, -60, -60, -60, -60), substr(urejeni[30:26, 1], 1, 12), srt = -60, cex = 0.5)
  text(11.5:15.5, c(-60, -60, -60, -60, -60, -60), substr(urejeni[5:1, 1], 1, 12), srt = -60, cex = 0.5)

  detach(nutrition)
}

#Izven uporabe
# tretji.graf1 <- function() {
#   attach(nutrition)
#   plot(0:54, Calories, type = "l", xlab = "Jedi", ylab = "Kalorije")
#   text(grep(max(Calories), Calories), max(Calories), pos = 4, Jed[grep(max(Calories), Calories)])
#   text(grep(min(Calories), Calories), min(Calories), pos = 2, Jed[grep(min(Calories), Calories)])
#   detach(nutrition)
# }

# pdf("slike/grafi.pdf", paper = "a4r")
# graf1 <- prvi.graf()
# graf2 <- drugi.graf()
# graf3 <- tretji.graf()
# dev.off()

# pdf("slike/graf1.pdf")
# graf1 <- prvi.graf()
# dev.off()

# Drugače nam ne prikazuje črke "Č" pravilno, "Š" in "Ž" delata normalno
cairo_pdf("slike/graf1.pdf", family="Courier New")
graf_test <- prvi.graf()
dev.off()

cairo_pdf("slike/graf2.pdf", family="Courier New")
graf1 <- drugi.graf()
dev.off()

pdf("slike/graf3.pdf")
graf1 <- tretji.graf()
dev.off()


# Day 10: Syntax Scoring

get_day10_input_path <- function() {
    paste(getwd(), "/2021/Day 10/Day10_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day10_input_path())

    open_chars <- c("(", "[", "{", "<")
    close_chars <- c(")", "]", "}", ">")
    scores <- c(3, 57, 1197, 25137)
    total_score <- 0

    for (i in seq_len(length(readings))) {
        line <- unlist(strsplit(readings[i], ""))
        expected_closes <- c()

        for (c in seq_len(length(line))) {
            op_match <- match(line[c], open_chars)
            if (!is.na(op_match)) {
                expected_closes <- append(expected_closes,
                                        close_chars[op_match])
            } else {
                if (line[c] == expected_closes[length(expected_closes)]) {
                    expected_closes <- expected_closes[-length(expected_closes)]
                } else {
                    syntax_score <- scores[match(line[c], close_chars)]
                    total_score <- total_score + syntax_score
                    break
                }
            }
        }
    }
    print(total_score)
}

part2 <- function() {
    readings <- readLines(get_day10_input_path())

    open_chars <- c("(", "[", "{", "<")
    close_chars <- c(")", "]", "}", ">")
    scores <- c(1, 2, 3, 4)
    total_scores <- c()

    for (i in seq_len(length(readings))) {
        line <- unlist(strsplit(readings[i], ""))
        is_corrupt <- FALSE
        expected_closes <- c()

        for (c in seq_len(length(line))) {
            op_match <- match(line[c], open_chars)
            if (!is.na(op_match)) {
                expected_closes <- append(expected_closes,
                                        close_chars[op_match])
            } else {
                if (line[c] == expected_closes[length(expected_closes)]) {
                    expected_closes <- expected_closes[-length(expected_closes)]
                } else {
                    is_corrupt <- TRUE
                    break
                }
            }
        }

        if (!is_corrupt) {
            expected_closes <- rev(expected_closes)
            total_score <- 0
            for (e in seq_len(length(expected_closes))) {
                char_score <- scores[match(expected_closes[e], close_chars)]
                total_score <- (total_score * 5) + char_score
            }
            total_scores <- append(total_scores, total_score)
        }
    }
    print(median(sort(total_scores)))
}

part1()
part2()


# https://ourcodingclub.github.io/2017/03/15/mixed-models.html
# https://rpsychologist.com/r-guide-longitudinal-lme-lmer
# https://stackoverflow.com/questions/49033016/plm-or-lme4-for-random-and-fixed-effects-model-on-panel-data
# https://www.princeton.edu/~otorres/Panel101R.pdf
# fredr_set_key('d0b9e64aba30b479343a06037a5a10c1')

library(rvest)
library(httr)
library(data.table)
library(tidyverse)
library(WDI)
library(countrycode)
library(lmtest)
library(tseries)
library(plm)
library(rvest)
library(httr)
library(quantmod)
# library(fredr)
library(scales)
library(quantreg)

refresh_downloads = T
setwd('~\\Public_Policy\\Projects\\Taxes vs. Deficits\\data')

##### Get political data #####

if (refresh_downloads) {
  the_url = 'https://www.presidency.ucsb.edu/statistics/data/house-and-senate-concurrence-with-presidents'
  concurrence_table = html_table(GET(the_url) %>% content(), fill = TRUE)
  concurrence_table[[1]] %>% write.csv('concurrence_with_president.csv')
}

concurrence_with_president_clean = read_csv('concurrence_with_president_clean.csv')

# MIT data lab
house_elections = read.csv('1976-2018-house.csv') %>%
  mutate(candidate_votes = as.numeric(candidatevotes)) %>%
  filter(stage == 'gen') %>% data.table()

senate_elections = read.csv('1976-2018-senate.csv') %>% filter(stage == 'gen') %>% data.table()
presidential_elections = read.csv('1976-2016-president.csv') %>% data.table()

##### Combine historical top tax rate data from Brookings and Current OECD Data #####
## Brookings source:
# http://www.taxpolicycenter.org/sites/default/files/legacy/taxfacts/content/PDF/oecd_historical_toprate.pdf
## OECD source:
# https://www.oecd.org/tax/tax-policy/tax-database/tax-database-update-note.pdf

# get TOP marginal tax rates

brookings_oecd_toptax = read_csv('oecd_historical_toprate_raw.csv', na = '--') %>%
  pivot_longer(cols = paste(c(1975:2013)), names_to = 'Year', values_to = 'TOP_TRATE')

current_oecd_toptax = read_csv('TABLE_I7_30102020214927846.csv') %>%
  pivot_wider(id_cols = c('Country', 'Year'), names_from = 'TAX', values_from = 'Value')

# get tax revenues to GDP
all_oecd_downloads =
  c("oecd_net_lending.csv"   ,         "oecd_revenue.csv"   ,             "oecd_spending.csv" ) %>%
  map(read_csv) %>%
  bind_rows() %>%
  filter(LOCATION != 'OAVG', MEASURE == 'PC_GDP', SUBJECT == 'TOT')

# map country names
country_code_name_mappings = data.frame(
  LOCATION = unique(all_oecd_downloads$LOCATION)
) %>%
  mutate(
    Country = map_chr(LOCATION, function(the_country){
      countrycode(the_country, 'iso3c', 'country.name')
    }),
    Country = recode(Country, `South Korea` = 'Korea')
  )

stacked_extra_oecd_stats = inner_join(all_oecd_downloads, country_code_name_mappings)

# check col classes
map_chr(brookings_oecd_toptax, class)
map_chr(current_oecd_toptax, class)

# check if any countries aren't found in either dataset, may need to change names
current_oecd_toptax$Country[!current_oecd_toptax$Country %in% brookings_oecd_toptax$Country] %>% unique()
brookings_oecd_toptax$Country[!brookings_oecd_toptax$Country %in% current_oecd_toptax$Country]  %>% unique()

# check year ranges -- only keep non-overlapping
range(brookings_oecd_toptax$Year)
range(current_oecd_toptax$Year)

# recode columns
brookings_oecd_toptax_clean = mutate(
  brookings_oecd_toptax,
  Country = recode(Country, `Korea, Republic of` = 'Korea'),
  Year = as.numeric(Year),
  TOP_TRATE = TOP_TRATE * 100 # to match OECD
) %>%
  filter(
    Year < min(current_oecd_toptax$Year, na.rm = T)
  )
range(brookings_oecd_toptax_clean$Year)

# clear memory
rm(brookings_oecd_toptax)

# outer join on country and year, keeping the year overlaps from oecd
joined_oecd_brookings_toptax = bind_rows(
  brookings_oecd_toptax_clean,
  current_oecd_toptax
) %>%
  arrange(
    Country, Year
  )

# take a look at the data
ggplot(joined_oecd_brookings_toptax, aes(Year, TOP_TRATE, colour = Country)) +
  geom_line()

# lots of missing values in the middle of the dataset, let's interpolate those
joined_oecd_brookings_toptax_dt = data.table(joined_oecd_brookings_toptax)

joined_oecd_brookings_toptax_filled = joined_oecd_brookings_toptax_dt[, {
  # cat("\nCountry ==",.BY[[1]],"\n\n")

  non_na_years = Year[!is.na(TOP_TRATE)]
  na_years = Year[is.na(TOP_TRATE)]

  # find the most recent existing value
  filled_vals = map_dbl(na_years, function(this_year){
    years_to_check = non_na_years[non_na_years < this_year]
    if (length(years_to_check) == 0) {
      return(NA)
    } else {
      closest_year = max(years_to_check)
      return(TOP_TRATE[Year == closest_year])
    }
  })

  filled_df = data.frame(
    Year = na_years,
    TOP_TRATE = filled_vals
  )

  full_df = data.frame(
    Year, TOP_TRATE
  ) %>%
    filter(Year %in% non_na_years)

  stacked_df = bind_rows(filled_df, full_df) %>% arrange(Year)

  list(
    Year = stacked_df$Year,
    TOP_TRATE = stacked_df$TOP_TRATE
  )
}, by = Country]

# add back other variables
joined_oecd_brookings_toptax_fin = inner_join(
  select(joined_oecd_brookings_toptax, -TOP_TRATE),
  joined_oecd_brookings_toptax_filled
)

rm(joined_oecd_brookings_toptax, joined_oecd_brookings_toptax_dt)

# looks much better now
ggplot(joined_oecd_brookings_toptax_filled, aes(Year, TOP_TRATE, colour = Country)) +
  geom_line()

##### Get fiscal data from the world bank #####
# WDIsearch('debt') %>% View()

start_year = min(joined_oecd_brookings_toptax_filled$Year, na.rm = T)
end_year = max(joined_oecd_brookings_toptax_filled$Year, na.rm = T)

wdi_indicators = c('NY.GDP.PCAP.KD.ZG', 'GC.TAX.TOTL.GD.ZS',
                   'DT.DOD.DECT.GN.ZS', 'GC.TAX.YPKG.RV.ZS', 'GC.XPN.INTP.RV.ZS',
                   'GC.REV.TOTL.CD', 'PAY.TAX.RK.DB19', 'NY.GDP.MKTP.KD.ZG', 'NY.GDP.PCAP.KD', 'GC.DOD.TOTL.GD.ZS')

wdi_names = map(wdi_indicators, function(ind){
  WDIsearch(ind, field = 'indicator') %>% t() %>% as.data.frame()
}) %>%
  bind_rows()

if (refresh_downloads | !file.exists('wdi_download_long.csv')) {

  wdi_download = WDI(indicator = wdi_indicators,
                     start = start_year,
                     end = end_year, extra = T) %>%
    filter(
      income == 'High income'
    )

  wdi_download_long = pivot_longer(wdi_download, cols = wdi_indicators, names_to = 'indicator') %>%
    inner_join(wdi_names) %>%
    mutate(
      country = recode(country, `Korea, Rep.` = 'Korea')
    )
  write.csv(wdi_download_long, 'wdi_download_long.csv', row.names = F)

} else {
  wdi_download_long = read_csv('wdi_download_long.csv')
}
# check country names
# wdi_download_long$country[!wdi_download_long$country %in% joined_oecd_brookings_toptax_filled$Country] %>% unique()
# joined_oecd_brookings_toptax_filled$Country[!joined_oecd_brookings_toptax_filled$Country %in% wdi_download_long$country] %>% unique()

##### Combine all world bank and OECD data together #####

stacked_oecd_wdi_data = bind_rows(
  joined_oecd_brookings_toptax_fin %>% mutate(Indicator = 'top_tax_rate') %>% select(Country, Year, Value = TOP_TRATE, Indicator),
  stacked_extra_oecd_stats %>% select(Country, Year = TIME, Value, Indicator = INDICATOR)
) %>%
  bind_rows(
    wdi_download_long %>% select(Country = country, Year = year, Indicator = indicator, Value = value)
  ) %>%
  arrange(
    Country, Indicator, Year
  ) %>%
  filter(!is.na(Country))

# test uniqueness of observations
unique_obs = select(stacked_oecd_wdi_data, Country, Year, Indicator) %>% unique()
stopifnot(nrow(unique_obs) == nrow(stacked_oecd_wdi_data))
stacked_oecd_wdi_data_dt = data.table(stacked_oecd_wdi_data)
duped_dt = stacked_oecd_wdi_data_dt[duplicated(stacked_oecd_wdi_data_dt, by = c('Country', 'Year', 'Indicator')),]
inner_join(stacked_oecd_wdi_data, duped_dt) %>% dim()

##### Compute new variables #####
# for each country and indicator, compute:
# Lags
# First differences
stacked_oecd_wdi_data_dt = data.table(stacked_oecd_wdi_data)
stacked_oecd_wdi_data_lags_diffs = stacked_oecd_wdi_data_dt[, {
  last_value = dplyr::lag(Value, 1)
  diff_value = Value - last_value
  lag_diff_value = dplyr::lag(diff_value, 1)

  pct_change = diff_value / last_value
  lag_pct_change = dplyr::lag(pct_change, 1)

  list(
    Year = Year,
    value = Value, # lowercase now
    last_value = last_value,
    diff_value = diff_value,
    pct_change = pct_change,
    lag_pct_change = lag_pct_change,
    lag_diff_value = lag_diff_value
  )

}, by = list(Country, Indicator)]

wide_oecd_wdi_data = pivot_wider(
  stacked_oecd_wdi_data_lags_diffs,
                                 id_cols = c('Country', 'Year'),
  names_from = 'Indicator',
  values_from = c('value', 'last_value', 'diff_value', 'pct_change', 'lag_pct_change', 'lag_diff_value')
  ) %>%
  arrange(
    Country, Year
  )

write.csv(stacked_oecd_wdi_data_lags_diffs, 'stacked_oecd_wdi_data_lags_diffs.csv', row.names = F)
write.csv(wide_oecd_wdi_data, 'wide_oecd_wdi_data.csv', row.names = F)