tai = import('./tai')
import_package('dplyr', attach = TRUE)

# Rules for wobble pairing
# Codon   Anti        i % 4  wobble_match_index
# TTT --- AAA (1, 2)  1      1
#      X/
# TTC -/- GAA (1, 2)  2     -1
#     /
# TTA --- TAA (1, 3)  3     -2
#      /
# TTG --- CAA (3, 4)  0     -1
rc_anticodons = data.frame(Codon = tai$rc_anticodons) %>%
    mutate(Order = seq_along(Codon))

#' Adaptation between codon and anticodon abundanc
#'
#' Calculate the adaptation as the rank correlation between codon and anticodon
#' abundance. The abundance of non-existent anticodons is replaced by the
#' abundance of the alternative decoding anticodon for the matching codon.
#' When the exactly matching anticodon exists, wobble base pairing anticodons
#' are not considered. This relies on the (inaccurate) assumption that
#' matching anticodons will generally out-compete wobble matching anticodons
#' at the ribosome.
adaptation = function (cu, aa) {
    wobble_match_index = function (i)
        i + c(-1, 1, -1, -2)[i %% 4 + 1]

    data = cu %>%
        group_by(Codon) %>%
        summarize(CU = sum(CU)) %>%
        full_join(aa, by = 'Codon') %>%
        full_join(rc_anticodons, by = 'Codon') %>%
        arrange(Order)
    unmatched_codon_indices = which(is.na(data$AA))
    wobble_codon_indices = unlist(lapply(unmatched_codon_indices,
                                         wobble_match_index))

    data[unmatched_codon_indices, 'AA'] = data[wobble_codon_indices, 'AA']
    data %>%
        filter(! is.na(CU)) %>%
        mutate(CU = CU / sum(CU),
               AA = AA / sum(AA)) %>%
        summarize(Cor = cor(CU, AA, use = 'complete.obs', method = 'spearman')) %>%
        .$Cor
}


make_samples <- function(tokens, sample_length) {
  samples <- array(dim = c(length(tokens) - sample_length + 1, sample_length))
  for(i in 1:(dim(samples)[1])) {
    samples[i, ] <- tokens[i:(i + sample_length - 1)]
  }
  samples
}

make_batch <- function(samples, batch_start, batch_size) {
  sz = dim(samples)
  batch <- batch_start:min(sz[1], batch_start + batch_size - 1)
  batch_x <- samples[batch,-sz[2]]
  batch_y <- samples[batch, sz[2]]
  list(x = batch_x, y = batch_y)
}

one_hot_batch <- function(batch, unique_tokens) {
  one_hot_x <- array(0, dim = c(dim(batch$x), length(unique_tokens)))
  one_hot_y <- array(0, dim = c(length(batch$y), length(unique_tokens)))
  sz = dim(batch$x)
  for(i in 1:sz[1]) {
    for(j in 1:sz[2]) {
      one_hot_x[i,j,] <- as.integer(unique_tokens == batch$x[i,j])
    }
    one_hot_y[i,] <- as.integer(unique_tokens == batch$y[i])
  }
  list(x = one_hot_x, y = one_hot_y)
}


#required packages
library("openxlsx")
library("stringr")
library(ComplexHeatmap)
library(circlize)
library(colorspace)
library(GetoptLong)
library(ggplot2)
library(gplots)
library(survival)
require("survival")
# install.packages("svglite")
library(survminer)
# library(reticulate)

#set the project path
project_path = "./project/"

#load patient data (include survival info)
entire_cohort = read.xlsx(paste(project_path, "data/tcga/entire_cohort.xlsx",sep=""), sheet = 1, colNames = TRUE)

length(rownames(entire_cohort))

individual = entire_cohort[entire_cohort$type=='BRCA',] # change the cancer type to results for others
length(rownames(individual))

fit = coxph(Surv(OS, Censor) ~

ENSG00000187185.4+
ENSG00000259641.4+
ENSG00000218510.5 +
ENSG00000257989.1+
ENSG00000206567.8
, data=individual)

# summary(fit)

HR <- exp(coef(fit))
CI <- exp(confint(fit))
P <- round(coef(summary(fit))[,5],8)
COEF <- coef(fit)

colnames(CI) <- c("Lower", "Higher")

table2 <- as.data.frame(cbind(HR, CI,COEF, P))
table2

#calculate the risk score
individual$risk_lnc = (
    individual$ENSG00000187185.4   * table2[1,4] +
    individual$ENSG00000259641.4 * table2[2,4]+
    individual$ENSG00000218510.5 * table2[3,4] +
    individual$ENSG00000257989.1 * table2[4,4] +
    individual$ENSG00000206567.8 * table2[5,4] )

#calculate the time-dependent roc
library(timeROC)
ROC<-timeROC(T=individual$OS,# survival time

delta=individual$Censor,# results, alive or death

marker=individual$risk_lnc,# variables

cause=1,

weighting="marginal",

times=c(365*3, 365*5),# time, survival 3,5 years

ROC = TRUE,

iid = TRUE)
ROC


nnfitsdss <- function(files, dname="spectra",
                      lambda.em = lambda_em,
                      nz=length(Z), nt=length(ages),
                      snrthresh=5, tsf=0.1, rlaw=calzetti, dlogl=1.e-4,
                      starts = c(0.25, 1., 1.), lb=c(0, 0.7, 0), ub=c(3., 5., 5.),
                      flux.em.bad=1.e5,
                      which.lick=c(1, 13:15, 20),
                      PLOT=TRUE) {
  require(nnls)
  require(cosmo)
  if (PLOT) {
    require(ggplot2)
    require(reshape2)
    options("warn" = -1)
  }

  ## variables and function definition for nonlinear fit to get tau, vdisp.st, vdisp.em

  fit.nn <- NULL
  x.st <- NULL
  x.em <- NULL
  in.em <- NULL
  allok <- NULL
  fn <- function(pars) {
    tauv <- pars[1]
    vdisp.em <- 100*pars[2]
    vdisp.st <- 100*pars[3]
    x.st <<- blur.lib(lib.ssp, vdisp.st)
    allok <<- complete.cases(flux, ivar, x.st)
    lib.em <- make_emlib(lambda.em, vdisp.em, logl, allok)
    x.em <<- lib.em$x_em
    in.em <<- lib.em$in_em
    att <- as.vector(rlaw(lambda.rest[allok], tauv))
    if (is.null(in.em)) {
      fit.nn <<- nnls(x.st[allok,]*att*sqrt(ivar[allok]), flux[allok]*sqrt(ivar[allok]))
    } else {
      fit.nn <<- nnls(cbind(x.st[allok,]*att, x.em[allok, ])*sqrt(ivar[allok]),
                      flux[allok]*sqrt(ivar[allok]))
    }
    fit.nn$deviance/2
  }

  nr <- length(files)
  lib.ssp$lambda <- airtovac(lib.ssp$lambda)
  olib.ssp <- lib.ssp
  tauv_err <- rep(NA, nr)
  vdisp.em_err <- rep(NA, nr)
  vdisp.st_err <- rep(NA, nr)
  tauv <- rep(NA, nr)
  vdisp.em <- rep(NA, nr)
  vdisp.st <- rep(NA, nr)

  T.gyr <- 10^(ages-9)
  isf <- which.min(abs(tsf-T.gyr))
  n.em <- length(lambda.em)
  ##needed to correct for log lambda grid
  em.mult <- lambda.em * log(10)/10000
  n.st <- ncol(lib.ssp)-1

  nnfits <- matrix(NA, nr, n.em+n.st)
  log_lik <- rep(NA, nr)
  tbar <- rep(NA, nr)
  tbar.lum <- rep(NA, nr)
  zbar <- rep(NA, nr)
  Mstar <- rep(NA, nr)
  gri <- matrix(NA, nr, nrow(gri.ssp))
  d4000_n <- rep(NA, nr)
  d4000_n_err <- rep(NA, nr)
  lick <- matrix(NA, nr, length(which.lick))
  lick.err <- matrix(NA, nr, length(which.lick))
  flux.em <- matrix(NA, nr, n.em)
  flux.em.err <- matrix(NA, nr, n.em)

  for (i in 1:nr) {
    gdat <- readsdssfit(files[i], dname=dname, extcor=TRUE, rest=TRUE)
    lambda.rest <- gdat$lambda
    flux <- gdat$flux
    ivar <- gdat$ivar
    z <- gdat$meta$z
    logl <- log10(lambda.rest)
    lib.ssp <- regrid(lambda.rest, olib.ssp)
    fitij <- Rsolnp::solnp(pars=starts, fn, LB=lb, UB=ub)
    tauv[i] <- fitij$pars[1]
    vdisp.em[i] <- 100*fitij$pars[2]
    vdisp.st[i] <- 100*fitij$pars[3]
    errs <- tryCatch(sqrt(diag(solve(fitij$hessian))), error=function(e) rep(NA, 3))
    tauv_err[i] <- errs[1]
    vdisp.em_err[i] <- 100*errs[2]
    vdisp.st_err[i] <- 100*errs[3]

    b <- fit.nn$x
    b.st <- b[1:n.st]
    b.em <- b[(n.st+1):length(b)]
    nnfits[i, 1:length(b)] <- b
    ni.em <- length(b)-n.st
    nl <- length(lambda.rest[allok])
    fitted <- cbind(x.st*as.vector(rlaw(lambda.rest,tauv[i])), x.em) %*% b
    fitted.em <- x.em %*% b.em
    gflux.net <- flux-fitted.em
    residual <- (flux-fitted)*sqrt(ivar)

    ## basic measures of goodness of fit
    log_lik[i] <- fit.nn$deviance/2

    ## plot spectrum and fit
    tdat <- data.frame(lambda=lambda.rest, gflux=flux, fitted=fitted,
                       residual=residual)
    tlong <- melt(tdat, id.vars="lambda")
    val <- c(rep(" obs",length(lambda.rest)), rep("fitted",length(lambda.rest)),
             rep("residual",length(lambda.rest)))
    tlong <- cbind(tlong, val = val)
    tlong$variable[tlong$variable=="gflux"] <- "fitted"
    base <- qplot(lambda, value, data=tlong, geom="line", xlab=expression(lambda),
                  ylab="", col=val,
                  main=paste("(",i,") log_lik= ",
                             format(log_lik[i], digits=3), sep=""))
    add.resid <- facet_grid(variable ~ ., scale="free_y")
    plot(base+add.resid)

    ## emission line fluxes and errors
    flux.em[i,in.em] <- b.em*em.mult[in.em]
    nzeros <- sort(fit.nn$passive)
    X <- cbind(x.st*as.vector(rlaw(lambda.rest,tauv[i])), x.em)[allok,nzeros]
    V <- max(log_lik[i]*2/nl, 1)*mpinv(crossprod(X, diag(ivar[allok])) %*% X)
    sd.b <- rep(NA, n.st+ni.em)
    sd.b[nzeros] <- sqrt(diag(V))
    flux.em.err[i,in.em] <- sd.b[(n.st+1):(n.st+ni.em)]*em.mult[in.em]

    ## gri magnitudes
    gri[i,] <- -2.5*log10(gri.ssp %*% b.st) + 20.092

    ## summaries from estimated sfh
    tbar[i] <- log10(sum(rep(T.gyr, nz)*b.st)/sum(b.st))+9
    tbar.lum[i] <- log10(sum(rep(T.gyr, nz) * b.st * gri.ssp["r",])/
    sum(b.st * gri.ssp["r",]))+9
    m.st <- cosmo::lum.sol(1, z)*b.st
    Mstar[i] <- log10(sum(m.st*mstar))

    ##d4000 and lick indices
    d4 <- d4000n(lambda.rest, gflux.net, ivar)
    d4000_n[i] <- d4$d4000_n
    d4000_n_err[i] <- d4$d4000_n_err

    d4 <- lickew(lambda.rest, gflux.net, ivar, which.index=which.lick)
    lick[i,] <- d4[1:length(which.lick)]
    lick.err[i,] <- d4[(length(which.lick)+1):length(d4)]
  }
  flux.em[flux.em > flux.em.bad] <- NA
  flux.em.err[!is.finite(flux.em)] <- NA
  dimnames(lick)[[2]] <- as.list(names(d4)[1:length(which.lick)])
  dimnames(lick.err)[[2]] <- as.list(names(d4)[(length(which.lick)+1):length(d4)])
  dimnames(gri)[[2]] <- dimnames(gri.ssp)[[1]]
  dimnames(flux.em)[[2]] <- as.list(names(lambda.em))
  dimnames(flux.em.err)[[2]] <- as.list(paste(names(lambda.em), "_err", sep=""))
  options("warn"=0)
  returns <- list(tauv=tauv, vdisp.em=vdisp.em, vdisp.st=vdisp.st,
                  tauv_err=tauv_err, vdisp.em_err=vdisp.em_err, vdisp.st_err=vdisp.st_err,
                  d4000_n=d4000_n, d4000_n_err=d4000_n_err,
                  lick=lick, lick.err=lick.err,
                  flux.em=flux.em, flux.em.err=flux.em.err, gri=gri,
                  tbar=tbar, tbar.lum=tbar.lum, Mstar=Mstar,
                  log_lik=log_lik, nnfits=nnfits)
  returns
}


pmv_holmer <- function(Ta, rh, v, Tr, w, Icl) {
    .Call('biometeoR_pmv_holmer', PACKAGE = 'biometeoR', Ta, rh, v, Tr, w, Icl)
}


suppressMessages(library(stats)) # for prcomp()
suppressMessages(library(fmlr))

m = 3
n = 2
x = cpumat(m, n)
x$fill_linspace(1, m*n)
xr = x$to_robj()

s = cpuvec()

source("internals/common.r")
source("internals/stats.r")


\docType{data}
\name{paises}
\alias{paises}
\title{Datos de Gapminder}
\format{El cuadro de datos principal tiene 1704 filas y 6 columnas
\describe{
\item{pais}{países incluídos (factor con 142 niveles)}
\item{continente}{continentes (factor con 5 niveles)}
\item{anio}{desde 1952 a 2007, datos cada 5 años}
\item{esperanza_de_vida}{esperanza de vida al nacer, en años}
\item{poblacion}{población}
\item{pib_per_capita}{PIB per cápita (en dólares americanos, ajustados según inflación)}
}}
\usage{paises}
\description{Extracto de datos de Gapminder sobre expectativa de vida, PIB per cápita y población, según país}
\source{http://www.gapminder.org/data/}
\keyword{datasets}


#  James Rekow

identifySubgroupsVer1ErrorCheck_Exp_Weight = function(MVec = NULL, NVec = NULL, lambdaVec = NULL,
                                             numSubgroupsVec = NULL, iStrength = 1, univVec = NULL,
                                             sigmaMax = 0.1, thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4,
                                             tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01,
                                             conGraph = NULL, rollRange = 0.025, numReplicates = 10,
                                             numClustKnown = FALSE){

  #  ARGS:
  #
  #  RETURNS: percentErrorDF - data frame containing columns for all the input data and the average
  #                            percent of samples placed in the wrong subgroup in each treatment

  source("identifySubgroupsVer1Test_Exp_Weight.r")

  #  default setting is that number of clusters in each treatment is unknown
  numClust = NULL

  #  set default value of MVec
  if(is.null(MVec)){
    MVec = seq(40, 200, 80)
  } #  end if

  #  set default value of NVec
  if(is.null(NVec)){
    NVec = seq(20, 100, 40)
  } #  end if

  #  set default value of numSubgroupsVec
  if(is.null(numSubgroupsVec)){
    numSubgroupsVec = seq(1, 4, 1)
  } #  end if

  #  set default value of lambdaVec
  if(is.null(lambdaVec)){
    lambdaVec = seq(0, 200, 50)
  } #  end if

  #  set default value of univVec
  if(is.null(univVec)){
    univVec = seq(0, 1, 0.5)
  } #  end if

  percentErrorProducer = function(inputVec){

    #  ARGS: inputVec - a vector of the form c(M, N, numSUbgroups, lambda, univ)
    #
    #  RETURNS:

    #  extract parameter values from inputVec
    M = inputVec[1]
    N = inputVec[2]
    numSubgroups = inputVec[3]
    lambda = inputVec[4]
    univ = inputVec[5]

    #  if number of clusters for treatments is known, set it equal to the number of subgroups
    if(numClustKnown){
      numClust = numSubgroups
    } #  end if

    #  compute percent error of algorithm's subgroup classification
    percentError = identifySubgroupsVer1Test_Exp_Weight(M = M, numSubgroups = numSubgroups, N = N,
                                                        iStrength = iStrength, univ = univ,
                                                        sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                                        maxSteps = maxSteps, tStep = tStep,
                                                        intTime = intTime, interSmplMult = interSmplMult,
                                                        lambda = lambda, returnParams = FALSE,
                                                        conGraph = NULL,  rollRange = rollRange,
                                                        numClust = numClust)

    return(percentError)

  } #  end percentErrorProducer function

  meanPercentErrorProducer = function(inputVec){

    #  ARGS: inputVec - vector of the form c(M, N, lambda, univ)
    #
    #  RETURNS: meanPercentError - mean percent error of algorithm guesses at subgroup composition for
    #                              the given input vector

    #  compute the percent error of the algorithm in numReplicates replicates for the given inputs
    errorVec = replicate(numReplicates, percentErrorProducer(inputVec = inputVec))

    #  compute the mean percent error of the algorithm for the given inputs
    meanPercentError = mean(errorVec)

    return(meanPercentError)

  } #  end meanPercentErrorProducer function

  #  create a matrix of all unique combinations of elements from Mvec, NVec, lambdaVec, and univVec
  inputMat = expand.grid(MVec, NVec, numSubgroupsVec, lambdaVec, univVec)

  #  for each combination of inputs, compute the percent error of the algorithm using those inputs
  meanPercentError = apply(inputMat, 1, meanPercentErrorProducer)

  #  store data in a data frame
  meanPercentErrorDF = data.frame(M = inputMat[ , 1], N = inputMat[ , 2], numSubgroups = inputMat[ , 3],
                                  lambda = inputMat[ , 4], univ = inputMat[ , 5],
                                  meanPercentError = meanPercentError)

  return(meanPercentErrorDF)

} #  end identifySubgroupsVer1ErrorCheck_Exp_Weight function


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Test for Stop functionality for Backtests
# Copyright (C) 2013  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Helper function to visualize signal / strategy
#
# plot strategy, highligh invested periods with green
#' @export
###############################################################################
bt.stop.strategy.plot <- function(
	data,
	model,
	dates = '::',
	main = NULL,
	layout = NULL,		# flag to idicate if layout is already set
	extra.plot.fn = NULL,
	...
) {
	# highlight logic based on weight
    weight = model$weight[dates]
    	col = iif(weight > 0, 'green', iif(weight < 0, 'gray', 'white'))
    	plota.control$col.x.highlight = col.add.alpha(col, 100)
    	highlight = T

    if(is.null(layout)) layout(1)

    plota(data$prices[dates], type='l', x.highlight = highlight, ...)

    if(!is.null(extra.plot.fn)) match.fun(extra.plot.fn)()

   	plota.legend('Long,Short,Not Invested','green,gray,white')

    if(!is.null(main))
    	legend('top', legend=main, bty='n')
}

###############################################################################
# Tests
# http://www.optionetics.com/market/articles/2012/08/22/kaeppels-corner-the-40-week-cycle-and-theory-versus-reality
###############################################################################
bt.stop.kaeppels.40w.test <- function()
{
	load.packages('quantmod')

	#*****************************************************************
	# Load historical data
	#******************************************************************
	tickers = spl('SPY')
	tickers = spl('^DJI')
	tickers = spl('DIA')
	tickers = spl('^GSPC')

	data <- new.env()
		getSymbols(tickers, src = 'yahoo', from = '1967-01-01', env = data, auto.assign = T)
	bt.prep(data, align='keep.all', dates='1967:04:21::')

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	prices = data$prices
	nperiods = nrow(prices)

	models = list()

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	data$weight[] = NA
		data$weight[] = 1
	models$buy.hold = bt.run.share(data, clean.signal=T)

	#*****************************************************************
	# 40W cycle
	#******************************************************************
	# start 40W - 21-04-1967
	# 280 days
	# 140 days bullish
	# 180 days bear
	# bull 13-07-2012
	# bear 30-11-2012
	# bull 19-4-2013
	#******************************************************************
	start.cycle = as.Date("1967-04-21")

	diff = data$dates - start.cycle
	diff.cyc = diff / 280
	diff.int = as.integer(diff.cyc)

	signal=iif((diff.cyc-diff.int) < 0.5, 1, 0)
		# to prevent entering the same signal after the stop
		signal = exrem(signal)

	data$weight[] = NA
		data$weight[] = signal
	models$cycle = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Stops
	#******************************************************************
	fixed.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0)
			price[ index ] < (1 - pstop) * price[ tstart ]
		else
			price[ index ] > (1 + pstop) * price[ tstart ]
	}

	trailing.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0) {
			temp = price[ index ] < (1 - pstop) * cummax(price[ index ])
		} else {
			temp = price[ index ] > (1 + pstop) * cummin(price[ index ])
		}
		return( temp )
	}

	#*****************************************************************
	# Add 12.5% fixed stop loss
	#******************************************************************
	# same as custom.fixed.stop
	#data$weight[] = NA
	#	data$weight[] = bt.ts.price.stop(signal, prices, 8.5/100 * prices)
	#models$cycle.12.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	pstop = 8.5 / 100

	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), fixed.stop, pstop = pstop)
	models$cycle.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), trailing.stop, pstop = pstop)
	models$cycle.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)
	#*****************************************************************
	# Create Report
	#******************************************************************
	plotbt.custom.report.part1(models)
	plotbt.custom.report.part2(models$cycle)
	plotbt.strategy.sidebyside(models)
	plotbt.custom.report.part3(models$cycle, trade.summary = TRUE)

	strategy.performance.snapshoot(models, T)

	plotbt.custom.report.part2(models$cycle.trailing.stop)
	plotbt.custom.report.part3(models$cycle.trailing.stop, trade.summary = TRUE)
	#models$cycle.trailing.stop$trade.summary$trades

	#*****************************************************************
	# Create Plot
	#******************************************************************
	dates = '2009:04::'

	layout(1:3)
	bt.stop.strategy.plot(data, models$cycle, dates = dates, layout=T, main = '40 week cycle', plotX = F)
	bt.stop.strategy.plot(data, models$cycle.fixed.stop, dates = dates, layout=T, main = '40 week cycle fixed stop', plotX = F)
	bt.stop.strategy.plot(data, models$cycle.trailing.stop, dates = dates, layout=T, main = '40 week cycle trailing stop')

}

###############################################################################
# MA Cross strategy with various stop examples
#
# http://www.investopedia.com/articles/trading/08/trailing-stop-loss.asp
###############################################################################
bt.stop.ma.cross.test <- function()
{
	load.packages('quantmod')

	#*****************************************************************
	# Load historical data
	#******************************************************************
	tickers = spl('SPY')

	data <- new.env()
		getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
		for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)
	bt.prep(data, align='keep.all', dates='1999::')

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	prices = data$prices

	models = list()

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	data$weight[] = NA
		data$weight[] = 1
	models$buy.hold = bt.run.share(data, clean.signal=T)

	#*****************************************************************
	# Code Strategies : MA Cross Over
	#******************************************************************
	sma.fast = SMA(prices, 20)
	sma.slow = SMA(prices, 50)

	buy.signal = iif(cross.up(sma.fast, sma.slow), 1, NA)

	data$weight[] = NA
		data$weight[] = iif(cross.up(sma.fast, sma.slow), 1, iif(cross.dn(sma.fast, sma.slow), 0, NA))
	models$ma.cross = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Stops
	#******************************************************************
	# fixed stop: exit trade once price falls below % from entry price
	fixed.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0)
			price[ index ] < (1 - pstop) * price[ tstart ]
		else
			price[ index ] > (1 + pstop) * price[ tstart ]
	}

	# trailing stop: exit trade once price falls below % from max price since start of trade
	trailing.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0) {
			temp = price[ index ] < (1 - pstop) * cummax(price[ index ])
		} else {
			temp = price[ index ] > (1 + pstop) * cummin(price[ index ])
		}
		return( temp )
	}

	# trailing stop: exit trade once price either
	# - falls below % from max price since start of trade OR
	# - rises above % from entry price
	trailing.stop.profit.target <- function(weight, price, tstart, tend, pstop, pprofit) {
		index = tstart : tend
		if(weight > 0) {
			temp = price[ index ] < (1 - pstop) * cummax(price[ index ])

			# profit target
			temp = temp | price[ index ] > (1 + pprofit) * price[ tstart ]
		} else {
			temp = price[ index ] > (1 + pstop) * cummin(price[ index ])

			# profit target
			temp = temp | price[ index ] < (1 - pprofit) * price[ tstart ]
		}
		return( temp )
	}

	#*****************************************************************
	# Exit using fixed stop
	#******************************************************************
	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), fixed.stop,
		pstop = 1/100)
	models$ma.cross.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Exit using trailing stop
	#******************************************************************
	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), trailing.stop,
		pstop = 1/100)
	models$ma.cross.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Exit using trailing stop or profit target
	#******************************************************************
	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), trailing.stop.profit.target,
		pstop = 1/100, pprofit = 1.5/100)
	models$ma.cross.trailing.stop.profit.target = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Create Report
	#******************************************************************
jpeg(filename = 'plot1.jpg', width = 500, height = 500, units = 'px', pointsize = 12)

	strategy.performance.snapshoot(models, T)

dev.off()
	#*****************************************************************
	# Create Plot
	#******************************************************************
	dates = '2010::2010'
	# add moving averages to the strategy plot
	extra.plot.fn <- function() {
		plota.lines(sma.fast, col='red')
		plota.lines(sma.slow, col='blue')
	}

jpeg(filename = 'plot2.jpg', width = 500, height = 500, units = 'px', pointsize = 12)

    layout(1:4)
	bt.stop.strategy.plot(data, models$ma.cross, dates = dates, layout=T, main = 'MA Cross', extra.plot.fn = extra.plot.fn, plotX = F)
	bt.stop.strategy.plot(data, models$ma.cross.fixed.stop, dates = dates, layout=T, main = 'Fixed Stop', plotX = F)
	bt.stop.strategy.plot(data, models$ma.cross.trailing.stop, dates = dates, layout=T, main = 'Trailing Stop', plotX = F)
	bt.stop.strategy.plot(data, models$ma.cross.trailing.stop.profit.target, dates = dates, layout=T, main = 'Trailing Stop and Profit Target')

dev.off()
}

###############################################################################
# MA Cross strategy with pull-back and various stop examples
#
# http://www.investopedia.com/articles/trading/08/trailing-stop-loss.asp
###############################################################################
bt.stop.ma.cross.pullback.test <- function()
{
	load.packages('quantmod')

	#*****************************************************************
	# Load historical data
	#******************************************************************
	tickers = spl('SPY')
	tickers = spl('^GSPC')

	data <- new.env()
		getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
	bt.prep(data, align='keep.all', dates='1999::')

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	prices = data$prices

	models = list()

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	data$weight[] = NA
		data$weight[] = 1
	models$buy.hold = bt.run.share(data, clean.signal=T)

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	sma.fast = SMA(prices, 50)
	sma.slow = SMA(prices, 200)

	data$weight[] = NA
		data$weight[] = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, sma.slow), 0, NA))
	models$ma.crossover = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	data$weight[] = NA
		data$weight[] = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, 0.95 * sma.slow), 0, NA))
	models$ma.crossover.pullback = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Stops
	#******************************************************************
	fixed.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0)
			price[ index ] < (1 - pstop) * price[ tstart ]
		else
			price[ index ] > (1 + pstop) * price[ tstart ]
	}

	trailing.stop <- function(weight, price, tstart, tend, pstop) {
		index = tstart : tend
		if(weight > 0) {
			temp = price[ index ] < (1 - pstop) * cummax(price[ index ])
		} else {
			temp = price[ index ] > (1 + pstop) * cummin(price[ index ])
		}
		return( temp )
	}

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	signal = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, sma.slow), 0, NA))
	signal = iif(cross.up(prices, sma.slow), 1, NA)
	signal = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, 0.95 * sma.slow), 0, NA))
	pstop = 8.5 / 100

	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), fixed.stop, pstop = pstop)
	models$cycle.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	data$weight[] = NA
		data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), trailing.stop, pstop = pstop)
	models$cycle.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE)

	#*****************************************************************
	# Create Report
	#******************************************************************
	strategy.performance.snapshoot(models, T)

	#*****************************************************************
	# Create Plot
	#******************************************************************
	dates = '::'
	# add moving averages to the strategy plot
	extra.plot.fn <- function() {
	    plota.lines(sma.slow, col='blue')
    	plota.lines(0.95 * sma.slow, col='red')
	}

	layout(1:4)
	bt.stop.strategy.plot(data, models$ma.crossover, dates = dates, layout=T, main = 'base', plotX = F)
	bt.stop.strategy.plot(data, models$ma.crossover.pullback, dates = dates, layout=T, main = 'base + 5% pull-back', extra.plot.fn = extra.plot.fn, plotX = F)
	bt.stop.strategy.plot(data, models$cycle.fixed.stop, dates = dates, layout=T, main = 'fixed stop', plotX = F)
	bt.stop.strategy.plot(data, models$cycle.trailing.stop, dates = dates, layout=T, main = 'trailing stop')

}

###############################################################################
# Dual Moving Average System
# http://www.tradingblox.com/Manuals/UsersGuideHTML/dualmovingaverage.htm
###############################################################################
bt.stop.dual.ma.strategy <- function
(
	data,
	short.ma.len = 50,
	long.ma.len = 200,
	n.atr = NA,
	atr.len = 39
)
{
	#*****************************************************************
	# Stop
	#******************************************************************
	atr.trailing.stop <- function(weight, price, tstart, tend, atr) {
		index = tstart : tend
		if(weight > 0)
			price[ index ] < cummax( price[ index ] ) - atr[ index ]
		else
			price[ index ] > cummin( price[ index ] ) + atr[ index ]
	}

	#*****************************************************************
	# The MA Crossover system
	#******************************************************************
	prices = data$prices
	short.ma = SMA(prices, short.ma.len)
	long.ma = SMA(prices, long.ma.len)

	signal = iif(cross.up(short.ma, long.ma), 1, iif(cross.dn(short.ma, long.ma), 0, NA))
	if( !is.na(n.atr) ) {
		atr = bt.apply(data, function(x) ATR(HLC(x), atr.len)[,'atr'])

		signal = custom.stop.fn(coredata(signal), coredata(prices),
							atr.trailing.stop, atr = coredata(n.atr * atr))
	}

	data$weight[] = NA
		data$weight[] = signal
	bt.run.share(data, clean.signal=T)
}

bt.stop.dual.ma.test <- function()
{
	load.packages('quantmod')

	#*****************************************************************
	# Load historical data
	#******************************************************************
	tickers = spl('SPY')

	data <- new.env()
		getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
	bt.prep(data, align='keep.all')

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	models = list()

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	data$weight[] = NA
		data$weight[] = 1
	models$buy.hold = bt.run.share(data, clean.signal=T)

	#*****************************************************************
	# Dual Moving Average System parameters
	#******************************************************************
	models$ma = bt.stop.dual.ma.strategy(data, 50, 200)

	models$ma.stop = bt.stop.dual.ma.strategy(data, 50, 200, 5, 39)

	#*****************************************************************
	# Create Report
	#******************************************************************

	strategy.performance.snapshoot(models, T)

	#*****************************************************************
	# Create Plot
	#******************************************************************
	dates = '2010::'
	# add moving averages to the strategy plot
	extra.plot.fn <- function() {
		short.ma.len = 50
		long.ma.len = 200
		n.atr = 5
		atr.len = 39

		short.ma = SMA(data$prices, short.ma.len)
		long.ma = SMA(data$prices, long.ma.len)
		atr = bt.apply(data, function(x) ATR(HLC(x), atr.len)[,'atr'])

	    plota.lines(short.ma, col='red')
	    plota.lines(long.ma, col='blue')
	    plota.lines(data$prices - n.atr * atr, col='orange')
	}

	layout(1:2)
	bt.stop.strategy.plot(data, models$ma, dates = dates, layout=T, main = 'MA base', extra.plot.fn=extra.plot.fn, plotX = F)
	bt.stop.strategy.plot(data, models$ma.stop, dates = dates, layout=T, main = 'base + 5% pull-back', extra.plot.fn=extra.plot.fn)

}


## clear
rm(list = ls());

this.dir <- dirname(parent.frame(2)$ofile) # get current dir
source_dir <- file.path(this.dir, "summary") # directory to read input from

load(file=file.path(source_dir, "det.RData"))
# load(file=file.path(source_dir, "eval.RData"))
load(file=file.path(source_dir, "param.RData"))

df<-cbind(det, param) # , eval
remove(param, det ) # , eval

# no multiscale
#df<-df[df$D %in% c("4.0", "6.0", "8.0", "10.0"),]

# correct for the wrong tests
# df <- df[df$sthH %in% c("0.00", "5.00", "10.00"),]

################################################################################################
## take the one with min SD for each NAME (and bring along some more columns)
SD<-do.call(rbind, lapply(split(df, df[,"NAME"]), function(x) x[which.min(x[,"SD"]), ]) ) #c("NAME","eJUN", "D", "dsens", "nccL", "lhoodH", "sthH", "sthL")
cat("SD\n");print(SD)

pdf(file.path(source_dir, "f(SD,image).pdf"), width=4, height=3)
par(mar=c(1.2,3,0.5,0.5)+0.1, mgp=c(2.0,1,0))
mp<-barplot(SD$SD, ylab=expression('SD'), col=rgb(1,0,0,0.4),  xpd=F, las=2) #ylim=c(.0, 1),
text(mp, par("usr")[3] - 0.015, srt = 45, adj = 1, labels=SD$NAME, xpd = TRUE, font = 2, cex=0.8)
grid()
dev.off()

################################################################################################
## take the one with min SSD for each NAME (and bring along some more columns)
SSD<-do.call(rbind, lapply(split(df, df[,"NAME"]), function(x) x[which.min(x[,"SSD"]), ]) ) #c("NAME","eEND", "D", "dsens", "nccL", "lhoodH", "sthH", "sthL")
cat("SSD\n")
print(SSD)

pdf(file.path(source_dir, "f(SSD,image).pdf"), width=4, height=3)
par(mar=c(1.2,3,0.5,0.5)+0.1, mgp=c(2.0,1,0))
mp<-barplot(SSD$SSD, ylab=expression('SSD'), col=rgb(1,1,0,0.4), ylim=c(.0, 1), xpd=F, las=2)
text(mp, par("usr")[3] - 0.015, srt = 45, adj = 1, labels=SSD$NAME, xpd = TRUE, font = 2, cex=0.8)
grid()
dev.off()

################################################################################################
## take the one with min percSSD for each NAME (and bring along some more columns)
percSSD<-do.call(rbind, lapply(split(df, df[,"NAME"]), function(x) x[which.min(x[,"percSSD"]), ]) ) # c("NAME","eII", "eJUN", "eEND", "D", "dsens", "nccL", "lhoodH", "sthH", "sthL")
cat("percSSD\n")
print(percSSD)

pdf(file.path(source_dir, "f(percSSD,image).pdf"), width=8, height=3)
par(mar=c(1.2,3,0.5,0.5)+0.1, mgp=c(2.0,1,0))
mp<-barplot(percSSD$percSSD, ylab=expression('percSSD'), col=rgb(0,0,0,0.4), ylim=c(.0, 1), xpd=F, las=2)
text(mp, par("usr")[3] - 0.015, srt = 45, adj = 1, labels=percSSD$NAME, xpd = TRUE, font = 2, cex=0.8)
grid()
dev.off()

################################################################################################
## save data.frame out with [name,eI,eII,eJUN,eEND] to be used later on when concatenating data.frames for different snr-s
out<-cbind(
  data.frame(NAME=SD$NAME),
  data.frame(SD=SD[,"SD"]),
  data.frame(SSD=SSD[,"SSD"]),
  data.frame(percSSD=percSSD[,"percSSD"])
)

save(out, file=file.path(source_dir, "out.RData"))

cat("TABLE (ISBI15) \n");
tabl <- rbind(as.character(SD$NAME),
              format(SD$SD, digits=4),
              format(SSD$SSD, digits=4),
              format(percSSD$percSSD, digits=4)
              )
write.table(tabl, "", row.names=F, col.names=F, sep=" & ", eol=" \\\\ \n", quote=F)

stop("HEY!!!! OK");

out <- rbind(
  data.frame(t( SD[ ,"SD"  ] )),
  data.frame(t( SSD[,"SSD"] )),
  data.frame(t( percSSD[,"percSSD"] ))
)

names(out) <- levels(SD$NAME)
row.names(out) <- c("SD", "SSD", "percSSD")

stop("HEY!!!! OK");
# print table with the detection scores and parameters for different (4) evaluation categories
# write.table(  format(out, digits=2),
#               quote=F, row.names=T, col.names=NA,sep=" & ", eol=" \\\\ \n",
#               file=file.path(source_dir, "all.txt")
# );

cat("OUT: \n")
print(out)

# pdf(file.path(source_dir, "f(f+fJUN+fEND,image).pdf"), width=6, height=4)
# par(mar=c(3,2.5,1.5,1)+0.1, mgp=c(2, 1, 0))
# bp<-barplot(t(as.matrix(outII[,c("eJUN", "eII", "eEND")])), beside = T, col=c(rgb(1,0,0,0.4), rgb(0,0,0,0.6), rgb(1,1,0,0.4)),
#             density=c(NA,10,NA), axisnames=F, ylim=c(.0, 1), xpd=F,
#             width=c(0.2,1,0.2))
# text(colMeans(bp), par("usr")[3] - 0.010, srt = 45, adj = 1, labels=names(out), xpd = TRUE, font = 2, cex=0.6)
# legend("topright", c(expression('F'['JUN']), "F", expression('F'['END'])), bty="n", fill=c(rgb(1,0,0,0.4), rgb(0,0,0,0.6), rgb(1,1,0,0.4)),
#        density=c(NA,10,NA), horiz=F, xpd=T, inset=c(-0.05,-0.1)) #, lwd=c(4,4,4)
# grid()
# dev.off()

# pdf(file.path(source_dir, "f_boxplot.pdf"), width=6, height=4)
# par(mar=c(3,2.5,1.5,1)+0.1, mgp=c(2, 1, 0))
# boxplot(outII$eII, ylim=c(.5, 1)) # ylab=expression('F'['']), cex=0.5,
# grid()
# dev.off()
cat("MEDIAN \n")
cat("eI :  ", median(outI$eI),     "\n")
cat("eII:  ", median(outII$eII),   "\n")
cat("eJUN: ", median(outJUN$eJUN), "\n")
cat("eEND: ", median(outEND$eEND), "\n")


(10
* 15)

foo <- function(arg =
                10) {
  arg
}

(foo
    (10,
     20))

if(1
 + 2) 3

for (x in 1
          :10) 20

while(1
      + 3)  break


# Create a vector of pies
x <- c(10,20,30,40)

# Create a vector of labels
mylabel <- c("Apples", "Bananas", "Cherries", "Dates")

colors <- c("red", "yellow", "pink", "blue")

# Display the pie chart with labels
pie(x, label = mylabel, main = "Fruits", init.angle = 90, col = colors)

# Display the explanation box
legend("bottomright", mylabel, fill = colors)


\name{default_smooth_fun}
\alias{default_smooth_fun}
\title{
Default Smoothing function
}
\description{
Default Smoothing function
}
\usage{
default_smooth_fun(x)
}
\arguments{

  \item{x}{Input numeric vector.}

}
\details{
The smoothing function is applied to every row in the normalized matrix. For this default smoothing function,
\code{\link[locfit]{locfit}} is first tried on the vector. If there is error, \code{\link[stats]{loess}} smoothing is tried afterwards.
If both smoothing are failed, there will be an error.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
# There is no example
NULL

}


#' Generate functions to create colors for edges
#' @noRd
new_edge_coloring <- function(
  vertex_color_i = NULL,
  vertex_alpha_i = NULL,
  vertex_color_j = NULL,
  vertex_alpha_j = NULL,
  edge_color = NULL,
  edge_alpha = NULL,
  mix = NULL
  ) {

  list(
    vertex = function(e, i, j, n) {

      # Adjusting alpha levels
      col_i <- vertex_color_i[i]
      col_j <- vertex_color_j[j]

      # Getting alpha levels
      alpha_i <- vertex_alpha_i[i]
      alpha_j <- vertex_alpha_j[j]

      # [OPTIONAL] ---------------------------------------------------------------
      # Linear combination between i and j
      col_i <- colorRamp2(x=c(col_i, col_j))(mix[e])
      col_i <- grDevices::rgb(col_i, alpha=col_i[,4], maxColorValue = 255)
      col_j <- col_i
      # --------------------------------------------------------------------------

      # Applying alpha levels and getting mix
      col <- colorRamp2(
        x = c(
          grDevices::adjustcolor(col = col_i, alpha.f = alpha_i),
          grDevices::adjustcolor(col = col_j, alpha.f = alpha_j)
        )
      )(seq(0, 1, length.out = n))

      # Returning
      grDevices::rgb(col, alpha = col[,4], maxColorValue = 255)

    },
    edge = function(e, i, j, n) {

      # Getting alpha levels
      alpha_i <- vertex_alpha_i[i]
      alpha_j <- vertex_alpha_j[j]

      # Edge level params
      col_ij   <- grDevices::adjustcolor(col = edge_color[e], alpha.f = edge_alpha[e])

      # Applying alpha levels and getting mix
      col <- colorRamp2(x=
        c(
          grDevices::adjustcolor(col = col_ij, alpha.f = alpha_i),
          grDevices::adjustcolor(col = col_ij, alpha.f = alpha_j)
        )
      )(seq(0, 1, length.out = n))

      # Returning
      grDevices::rgb(col, alpha = col[,4], maxColorValue = 255)

    }
  )

}

#' @noRd
#' @importFrom stats terms
netplot_edge_formulae <- function(x, fm) {

  # Basic validation
  np_validate$is_netplot(x)

  if (!inherits(fm, "formula"))
    stop("Not a formula", call. = FALSE)

  tm  <- stats::terms(fm)
  mat <- attr(tm, "factors")
  nam <- unique(gsub("\\(.+", "", rownames(mat)))

  # 1. Checking no repeated
  if (length(nam) > nrow(mat))
    stop("One or more terms are repated.", call. = FALSE)

  # 2. edge only goes alone
  if (("edge" %in% nam) & length(nam) > 1)
    stop("`edge` must be used alone.", call. = FALSE)

  # 3. Only one of the
  if (any(!(nam %in% c("edge", "alter", "ego"))))
    stop("Invalid term.", call. = FALSE)

  # 4. Checking if it is linear or an interaction
  linear <- ifelse(ncol(mat) == 1, TRUE, FALSE)

  # Applying formulas
  # Mofiying the likelihood function and the parameters for the mcmc
  val <- attr(tm, "variables")

  # Space where we will save the parameters
  par <- new.env()

  for (i in 2:length(val))
    if (!is.call(val[[i]])) {
      eval(
        call(as.character(val[[i]]), x = x, env = par)
      )
    } else {
      val[[i]]$x   <- bquote(x)
      val[[i]]$env <- bquote(par)
      eval(val[[i]])
    }

  # Creating the coloring
  col <- do.call(new_edge_coloring, as.list(par))

  lapply(seq_len(x$.M), function(e) {

    nam <- netplot_name$make(x$.edgelist[e,])

    col$vertex(
      e = e,
      i = x$.edgelist[e, 1],
      j = x$.edgelist[e, 2],
      n = length(x$children$graph$children[[nam]]$children$line$id.lengths)
    )

  })
}

#' Formulas in `netplot`
#'
#' Edge colors in both [nplot()] and [set_edge_gpar()] can be specified using
#' a formula based on `ego()` and `alter()` (source and target). This way the
#' user can set various types of combination varying the mixing of the colors,
#' the alpha levels, and the actual mixing colors to create edge colors.
#'
#' @param col Any valid color. Can be a single color or a vector.
#' @param alpha Number. Alpha levels
#' @param mix Number. For mixing colors between `ego` and `alter`
#' @param env,type,postfix For internal use only.
#' @param ... Passed to `color_formula`.
#' @param x An object of class [netplot].
#' @examples
#' if (require(gridExtra) & require(magrittr)) {
#'   library(igraph)
#'   net <- make_ring(4)
#'
#'   set.seed(1)
#'   np <- nplot(net, vertex.color = grDevices::hcl.colors(4), vertex.size.range=c(.1, .1))
#'   np %<>% set_edge_gpar(lwd = 4)
#'
#'   grid.arrange(
#'     np,
#'     np %>% set_edge_gpar(col =~ego + alter),
#'     np %>% set_edge_gpar(col =~ego(alpha=0) + alter),
#'     np %>% set_edge_gpar(col =~ego + alter(alpha=0)),
#'     np %>% set_edge_gpar(col =~ego(mix=0) + alter(mix=1)),
#'     np %>% set_edge_gpar(col =~ego(mix=1) + alter(mix=0))
#'   )
#' }
#' @name netplot-formulae
#' @export
#' @return Nothing. These functions are called internally when using
#' formulas. `color_formula` modifies the environment `env`.
color_formula <- function(x, col, alpha, env, type, mix = 1, postfix = NULL) {

  n <- switch(type, vertex = x$.N, edge = x$.M)

  # Checking color
  col <- if (missing(col))
    get_vertex_gpar(x, "core", "fill")$fill
  else if (length(col) == 1)
    rep(col, x$.N)
  else if (length(col) != n)
    stop("`col` has the wrong length (", length(col), "). When passing a ",
         "vector it should be of length ", n, ".", call. = FALSE)

  # Checking alpha
  alpha <- if (missing(alpha))
    rep(.8, n)
  else if (length(alpha) == 1)
    rep(alpha, n)
  else if (length(alpha) != n)
    stop("`alpha` has the wrong length (", length(alpha), "). When passing a ",
         "vector it should be of length ", n, ".", call. = FALSE)

  # Checking mixing levels
  mix <- if (missing(mix))
    rep(1, x$.M)
  else if (length(mix) == 1)
    rep(mix, x$.M)
  else if (length(mix) != x$.M)
    stop("`mix` has the wrong length (", length(mix), "). When passing a ",
         "vector it should be of length ", x$.M, ".", call. = FALSE)

  # Assigning values
  if (type == "vertex") {
    env[[sprintf("vertex_color_%s", postfix)]] <- col
    env[[sprintf("vertex_alpha_%s", postfix)]] <- alpha
  } else {
    env[["edge_color"]] <- col
    env[["edge_alpha"]] <- alpha
  }

  if (!length(env$mix))
    env$mix <- mix
  else {
    env$mix <- 1 - env$mix/(env$mix + mix)
  }

  invisible()
}

#' @export
#' @rdname netplot-formulae
ego   <- function(...) {

  dots        <- list(...)
  dots$type   <- "vertex"
  dots$postfix <- "i"

  do.call(color_formula, dots)
}

#' @export
#' @rdname netplot-formulae
alter <- function(...) {

  dots        <- list(...)
  dots$type   <- "vertex"
  dots$postfix <- "j"

  do.call(color_formula, dots)

}

edge <- function(x, col, alpha = .8) {

  # obtain default
  col <- if (missing(col))
    get_edge_gpar(x, "line", "col")$col
  else if (length(col) == 1)
    rep(col, x$.M)
  else if (length(col) != x$.M)
    stop("`col` has the wrong length (", length(col), "). When passing a ",
         "vector it should be of length ", x$.M, ".", call. = FALSE)

  # Checking alpha
  alpha <- if (missing(alpha))
    rep(.8, x$.M)
  else if (length(alpha) == 1)
    rep(alpha, x$.M)
  else if (length(alpha) != x$.M)
    stop("`alpha` has the wrong length (", length(alpha), "). When passing a ",
         "vector it should be of length ", x$.M, ".", call. = FALSE)

  list(
    col   = col,
    alpha = alpha
  )
}

# netplot_edge_formulae(~ego:alter)


# 3. faza: Vizualizacija podatkov

# Uvozimo zemljevid.
zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
                             pot.zemljevida="OB", encoding="Windows-1250")
levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>%
  { gsub("Slovenskih", "Slov.", .) } %>% { gsub("-", " - ", .) }
zemljevid$OB_UIME <- factor(zemljevid$OB_UIME, levels=levels(obcine$obcina))
zemljevid <- fortify(zemljevid)

# Izračunamo povprečno velikost družine
povprecja <- druzine %>% group_by(obcina) %>%
  summarise(povprecje=sum(velikost.druzine * stevilo.druzin) / sum(stevilo.druzin))

stevilo.po.letih <- data %>% group_by(leto) %>% summarise(Stevilo=sum(stevilo, na.rm = TRUE))

#Graf po stevilu priseljenih po letih
graf1 <- ggplot(stevilo.po.letih) + aes(x = leto, y = Stevilo) +
  geom_bar(stat = 'identity',position = 'dodge', fill = "darkcyan") +
  xlab("Leto") + ylab("Število") + ggtitle("Število priseljenih glede na leto")
graf1

#Graf po stevilu priseljenih po namenu
stevilo.po.namenu <- data %>% group_by(namen) %>% summarise(Stevilo=sum(stevilo, na.rm = TRUE))
graf2 <- ggplot(stevilo.po.namenu) + aes(x = namen, y = Stevilo) +
  geom_bar(stat = 'identity',position = 'dodge', fill = "darksalmon") +
  xlab("Leto") + ylab("Namen") + ggtitle("Število priseljenih glede na namen")
#2021/22
###################################################################################

#mojzemljevid

library(tmap)

zemljevid <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip","SVN_adm1", encoding = "UTF-8")
zemljevid$NAME_1 <- c("Gorenjska", "Goriška","Jugovzhodna Slovenija", "Koroška", "Primorsko-notranjska", "Obalno-kraška",
                      "Osrednjeslovenska", "Podravska", "Pomurska", "Savinjska", "Posavska", "Zasavska")

# 1.zemljevid: priseljevanje prebivalstva po regijah
regije_pri <- medregijske %>% group_by(regijapri) %>% summarise(skupaj = sum(stevilo, na.rm = TRUE ))
regije_pri$regijapri = regije_pri$regijapri %>% trimws()

podatki_pri = merge(zemljevid, regije_pri, by.x = "NAME_1", by.y = "regijapri" )
tm_shape(podatki_pri) +
  tm_polygons("skupaj") +
  tm_format("NLD", title="Število prebivalstva, ki se je priselilo iz določene regije", bg.color="white")

#2. zemljevid: izseljevanje prebivalstva po regijah
regije_izs <- medregijske %>% group_by(regijaiz) %>% summarise(skupaj = sum(stevilo, na.rm = TRUE ))
regije_izs$regijaiz = regije_izs$regijaiz %>% trimws()

podatki_izs = merge(zemljevid, regije_izs, by.x = "NAME_1", by.y = "regijaiz" )
tm_shape(podatki_izs) +
  tm_polygons("skupaj") +
  tm_format("NLD", title="Število prebivalstva, ki se je izselilo iz določene regije", bg.color="white")

#ŠE LEGENDO UREDIT!

#Graf 1: Povprečno število prebivalstva, ki se je selilo glede na statistične regije Slovenije

graf1 <- ggplot(data = povprecje_regije, aes(x=" " ,y=povprecje, fill = regijaiz)) +
  geom_bar(stat="identity", position = 'dodge') +
  facet_wrap(~regijapri, ncol= 6) +
  xlab(" ") + ylab("Povprečno število") +
  ggtitle("Priseljevanje in odseljevanje po statističnih regijah Slovenije") +
  theme(plot.title = element_text(family="Trebuchet MS", face="bold", size=20, hjust=0, color="black")) +
  theme(axis.text.x = element_text(angle=90))
+ coord_flip() + theme_dark() +
  scale_fill_brewer(palette = "BrBG")

#Graf 2: Število priseljenih in izseljenih ljudi glede na drzavo selitve

graf2 <- ggplot(data=povprecje2, aes(x=drzava, y=povprecje, fill=`vrsta`)) +
  geom_col(position = 'dodge') +
  coord_flip() +
  labs(x = "Država", y = "Povprečno število", title = "Povprečno število v priseljenega ali odseljenega prebivalstva glede na države") +
  theme_dark() +
  scale_fill_brewer(palette = "BrBG")

odseljeni<- meddrzavne %>% filter( vrsta != "Priseljeni iz tujine") %>% select(- 'vrsta') %>%
  group_by (drzava, spol) %>% summarise(Stevio=sum(stevilo))

priseljeni <- meddrzavne %>% filter( vrsta != "Odseljeni iz tujino") %>% select(- 'vrsta') %>%
  group_by (drzava, spol) %>% summarise(Stevilo=sum(stevilo)) #to bos potrebovala za pielibr

# Graf 3: Graf, ki prikazuje število priseljenega prebivalstva glede na namen selitve in državo predhodnega bivališča.

graf3b <- ggplot(namen_priseljevanja, aes(x=leto,y=stevilo, group=1)) +
  geom_point(aes(col=drzava, size=stevilo)) +
  facet_grid(namen ~ .) + xlab("Leto") + ylab("Število") +
  ggtitle("Priseljeni prebivalci glede na namen selitve po letih") +
  coord_flip() + theme_dark() +
  scale_fill_brewer(palette = "BrBG")

#Graf 4: Graf, ki prikazuje število priseljenega prebivalstva glede na njihovo izobrazvo in državo predhodnega bivališča

povprecje4 <- izobrazba_priseljeni %>% group_by(drzava, izobrazba) %>%
  summarise(povprecje=(sum(stevilo)/9))

graf4 <- ggplot(izobrazba_priseljeni, aes(x=leto,y=stevilo, group=1)) +
  geom_point(aes(col=drzava, size=stevilo)) +
  facet_grid(izobrazba ~ .) +
  labs(y="Število ljudi",
      x="Vrsta izobrazbe",
      title="Število priseljenega prebivalstva glede na stopnjo izobrazbe") +
  theme_dark() +
  scale_fill_brewer(palette = "BrBG")

#Graf 5: Graf, ki prikazuje število izseljenega prebivalstva glede na njihovo izobrazbo in starostno skupino

#starost <- c("15-24", "25-54", "55-64") zdruziii

povprecje5 <- izobrazba_izseljeni %>% group_by(starost, izobrazba) %>%
  summarise(povprecje=(sum(stevilo)/9))

graf5 <- ggplot(povprecje5, aes(x=izobrazba, y=povprecje)) +
          geom_point(aes(col=starost, size=povprecje)) +
          geom_smooth(method="loess", se=F) +
          labs(y="Število ljudi",
          x="Vrsta izobrazbe",
          title="Povprečno število izseljenega prebivalstva glede na starostno skupino in vrsto izobrazbe") +
          theme_dark() +
          scale_fill_brewer(palette = "BrBG")

graf5a <- ggplot(data=izobrazba_izseljeni, aes(x=leto, y=stevilo, col=spol)) +
  geom_line(size=1) + facet_grid(~starost) +
  theme_bw() +
  scale_color_manual(values=c("darkgoldenrod3", "cadetblue")) +
  xlab("Država") + ylab("Povprečno število(/100)") +
  ggtitle("Odseljeni prebivalci glede na status aktivnosti") +
  coord_flip() +
  theme_dark() +
  scale_fill_brewer(palette = "BrBG") +
  scale_x_continuous(breaks=seq(2010, 2020, 4))

#Graf 6: Graf, ki prikazuje število izeljenega prebivalstva glede na status aktivosti in državo pihodnjega bivališča
povprecje6 <- izseljeni_status_akt %>% group_by(drzava, status) %>%
  summarise(povprecje=(sum(stevilo)/9)/100)

graf6 <- ggplot(data=povprecje6, aes(x = drzava, y = povprecje, fill = status)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  xlab("Država") + ylab("Povprečno število(/100)") +
  ggtitle("Odseljeni prebivalci glede na status aktivnosti") +
  coord_flip() +
  theme_dark() +
  scale_fill_brewer(palette = "BrBG")
 #dva grafa: celine pa evropa po drzavah

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


data("iris")
library(sqldf)
colnames(iris)<-gsub("\\.","_",colnames(iris))
subiris<-sqldf("SELECT * FROM iris WHERE Sepal_Length>2.5")
View(subiris)
class(subiris)

R Community/R DaraManipulation Assignments/Assignment1.r


#' rbindlist alias
#'
#' @inheritParams data.table::rbindlist
#' @export
#' @keywords internal
rblist <- function(l, use.names = fill, fill = FALSE)
  as.data.frame(rbindlist(l, use.names, fill))

#' Plot ellipses on a existing graph
#'
#' @inheritParams ell.coords
#' @param ... other arguments to be passed to \code{\link{lines}}
#' @export
#' @keywords internal
#' @seealso \code{\link{ell.coords}}
#' @examples
#' plot(0:1, 0:1)
#' ellipses(.5, .5, .3, .1, pi/6)
#'
#' # Arguments are recycled
#' plot(0:1, 0:1)
#' ellipses(c(.5, .75), c(.5, .75), .3, .1, c(pi/6, -pi/2))
ellipses <- function(x0, y0, major, minor, agl, n = 50, ...) {
  # Get all named arguments in a list
  args <- as.list(environment(), all.names = TRUE)
  args <- args[names(args) != "..."]

  # Dispatch task according to the length of elements
  len_args <- sapply(args, length)
  if (any(len_args == 0)) {
    stop("One argument has length 0!")
  } else if (all(len_args == 1)) {
    with(do.call(ell.coords, args), lines(x, y, type = "l", ...))
  } else {
    do.call(Map, c(list(ellipses), args, list(...)))
  }

  invisible(NULL)
}

#' Ellipse coordinates
#' @param x0 x coordinate of the center
#' @param y0 y coordinate of the center
#' @param major semi-length of the major axe
#' @param minor semi-length of the minor axe
#' @param agl rotation angle  from the x-axis
#' @param n the number of points to use
#' @export
#' @keywords internal
#' @examples
#' str(ell.coords(.5, .5, .3, .1, pi/6))
ell.coords <- function(x0, y0, major, minor, agl, n = 50, ...) {
  theta <- seq(0, 2 * pi, length = n)
  list(
    x = x0 + major * cos(theta) * cos(agl) - minor * sin(theta) * sin(agl),
    y = y0 + major * cos(theta) * sin(agl) + minor * sin(theta) * cos(agl)
  )
}


library(assertthat)

source("utilities.r")

Data <- function(X,W,Y,N = length(W),N_treated=getN_treated(W)) {
  assert_that(is.numeric(X)&&is.numeric(Y)&&is.numeric(W))
  assert_integer(N)
  assert_that(is(N_treated,"numeric_treatment_dictionary"))

  W_bool <- rep(TRUE,times=N)
  W_bool[W==0] <- FALSE

  value <- list(X = X, W = W_bool, Y = Y,N=N,N_treated=N_treated)
  attr(value, "class") <- "data"
  value
}

Data_to_data_frame<-function(data){
  assert_that(is(data,"data"))
  #TODO if needed
}

data_frame_to_Data<-function(data){
  assert_that(is.data.frame(data))

  X<-data.matrix(data[,3:length(data)])
  return (Data(X,data$W,data$Y))

}

get_index.data <- function(obj,index){
  Data(obj$X[index,],
       obj$W[index]*1,
       obj$Y[index])
}

getN_treated <- function(W){
  assert_that(is.numeric(W))

  number_treated <- sum(W)
  number_untreated <- length(W)-number_treated
  NumericTreatmentDictionary(number_treated,number_untreated)
}

Counterfactuals <-function(treated,W,observed=init_observed(treated,W)){
  assert_that(is(treated,"numeric_treatment_dictionary"))
  value <- list(treated=treated,observed=observed,W=W)
  attr(value, "class") <- "counterfactuals"
  value
}

Synth_Validation_Result<-function(ates_methods,index_best){
  assert_that(is.numeric(ates_methods))
  assert_integer(index_best)
  assert_that(index_best>0&&index_best<=length(ates_methods))

  value <- list(ate=ates_methods[index_best],ates_methods=ates_methods,index_best=index_best)
  attr(value, "class") <- "synth_validation_result"
  value
}

get_index.counterfactuals <- function(obj,index){
  Counterfactuals(NumericTreatmentDictionary(obj$treated$`TRUE`[index],obj$treated$`FALSE`[index]),obj$W[index])
}

get_elements_by_treatment.counterfactuals <- function(obj,W,t,o){

  if(is.null(o)&&is.null(t)){
    stop("No conditions provided")
  }
  else if(is.null(o)){
    obj$treated[[as.character(t)]]
  }
  else if(is.null(t)){
    obj$observed[[as.character(o)]]
  }
  else{
    if(t){
      obj$observed[[as.character(o)]][W]
    }
    else{
      obj$observed[[as.character(o)]][!W]
    }
  }
}

add_counterfactuals<-function(c1,c2){

  assert_that(is(c1,"counterfactuals"))
  assert_that(is(c2,"counterfactuals"))
  assert_that(length(c1$W)==length(c2$W))

  treated<-NumericTreatmentDictionary(0,0)
  observed<-NumericTreatmentDictionary(0,0)

  for(tr in names(treated)){
    treated[[tr]]<-c1$treated[[tr]]+c2$treated[[tr]]
    observed[[tr]]<-c1$observed[[tr]]+c2$observed[[tr]]
  }

  return(Counterfactuals(treated,c1$W,observed))

}

TreatmentDictionary <- function(elements_true,elements_false){
  assert_that(all(class(elements_true)==class(elements_false)))
  assert_that(length(elements_true)==length(elements_false))

  dictionary <- vector(mode="list", length=2)
  names(dictionary) <- c(FALSE, TRUE)
  dictionary[[1]] <- elements_false; dictionary[[2]] <- elements_true
  attr(dictionary, "class") <- "treatment_dictionary"
  dictionary
}

NumericTreatmentDictionary <- function(elements_true,elements_false){
  dictionary = TreatmentDictionary(elements_true,elements_false)
  assert_that(is.numeric(elements_true)&&is.numeric(elements_false))
  attr(dictionary, "class") <- "numeric_treatment_dictionary"
  dictionary

}
init_observed <- function(treated,W){
  assert_that(is(treated,"numeric_treatment_dictionary"))
  assert_that(is.logical(W))
  assert_that(length(W)==length(treated$`TRUE`))

  observed <-NumericTreatmentDictionary(treated$`TRUE`,treated$`FALSE`)
  observed$`TRUE`[W]=treated$`TRUE`[W]
  observed$`TRUE`[!W]=treated$`FALSE`[!W]
  observed$`FALSE`[W]=treated$`FALSE`[W]
  observed$`FALSE`[!W]=treated$`TRUE`[!W]
  observed
}

get_index <- function(obj,index) {
  UseMethod("get_index")
}

get_index.default <- function(obj,index){
  obj[index]
}

get_elements_by_treatment <- function(obj,W,t=NULL,o=NULL) {

  assert_that(is.vector(obj)||is.matrix(obj)||is(obj,"counterfactuals"))

  assert_that(is.logical(W))
  assert_that(is.logical(t)||is.null(t))
  assert_that(is.logical(o)||is.null(o))

  UseMethod("get_elements_by_treatment")
}

get_elements_by_treatment.matrix <- function(obj,W,t=TRUE){
  if(t){
    obj[W,]
  }
  else{
    obj[!W,]
  }
}

get_elements_by_treatment.default<-function(obj,W,t=TRUE){
  get_elements_by_treatment.vector(obj,W,t)
}

get_elements_by_treatment.vector <- function(obj,W,t=TRUE){
  if(t){
    obj[W]
  }
  else{
    obj[!W]
  }
}

get_index.default <- function(obj,index){
  obj[index]
}

dummyData <- function(){
  # loading data
  N  = 2
  X1 = c(1,3)
  X2 = seq(0,0,length.out = N)
  X  = cbind(X1,X2)
  W  = c(1,0)
  Y  = X1+2
  data <- Data(X,W,Y)
}


                   FUNCTION:NAME
                          :BEGIN sizeof (int8_t) = 1
sizeof (int16_t) = 2
sizeof (int32_t) = 4
sizeof (int64_t) = 8
sizeof (intptr_t) = 8
sizeof (uint8_t) = 1
sizeof (uint16_t) = 2
sizeof (uint32_t) = 4
sizeof (uint64_t) = 8
sizeof (uintptr_t) = 8

-- @@stderr --
dtrace: script 'test/unittest/types/tst.inttypes.d' matched 1 probe


library(dplyr)
library(stringr)
library(tidyr)

meta2env <- function (meta, indv, grps, grp_order){

    # environmental data from channel
    indvs <- read.table(indv, header = F, col.names = "id")
    env <- sub('.indv', '',basename(indv))

    # environmental data
    meta <- read.table(meta, header = T , sep = ',') %>% select(id='bioinformatics_id',env)

    # Baypass groupings
    grps <- read.table(grps, header = FALSE, col.names = c("id","pop"))
    grp_order <- read.table(grp_order, header = FALSE, sep="",col.names="order")

    # recode discrete variables to numeric for standardization
    if (env == "H1_coast_noncoast"){
        meta <- mutate(meta, env = as.numeric(str_replace_all(meta[,2], c("noncoast" = "0", "coast" = "1"))))
    } else if (env == "H2_Aufeis_above_below_coast"){
        meta <- mutate(meta, env = as.numeric(str_replace_all(meta[,2], c("above" = "-1", "below" = "0", "coast" = "1"))))
    } else if (env == "H3_WShd_up_down_lower"){
        meta <- mutate(meta, env = as.numeric(str_replace_all(meta[,2], c("up" = "-1", "down" = "0", "lower" = "1"))))
    } else {
        meta <- mutate(meta, env = meta[,2])
    }

    # Standardize all records
    meta <- mutate(meta,
        standard_env = (as.numeric(env) - mean(as.numeric(env),na.rm=T)) / sd(as.numeric(env),na.rm=T))[,c(1,4)]

    # Remove problematic records to match indv in vcf
    correct <- left_join(grps, meta, by = "id")

    # Write lfmm format
    write.table(file = paste0(env,".env"), x = correct[,c(3)], row.names = FALSE, col.names = FALSE, quote = FALSE, sep = "\t")

    correct %>% group_by(pop) %>% summarise(avg = mean(as.numeric(standard_env))) %>% arrange(factor(pop,levels=grp_order$order)) %>% tidyr::pivot_wider(.,names_from = "pop", values_from = avg) %>%
        write.table(x=.,file=paste0(env,".bayenv"), row.names = FALSE, col.names = FALSE, quote = FALSE, sep = " ")
}