#'## Compute CIs for prediction ratios
#'### Functions for computing Ratio CIs
FiellerRatioCI <- function(a, b, V, t)
{
  theta <- a/b
  g <- (t^2)*V[2,2]/b^2
  se <- sqrt(V[1,1] - 2*theta*V[1,2] + theta^2 * V[2,2] - g*(V[1,1]-V[1,2]^2/V[2,2]))
  LCL <- (1/(1-g))*(theta- g*V[1,2]/V[2,2] - t/b * se)
  UCL <- (1/(1-g))*(theta- g*V[1,2]/V[2,2] + t/b * se)
  if (!is.na(UCL) & !is.na(LCL) & UCL < LCL) {
    UCL <- NA; LCL <- NA
  }
  return(list(pred.ratio=theta, upper.Confidence.limit = UCL, lower.Confidence.limit = LCL))
}

makeContrastMatrix <- function(preds, indx, pairs.factor, first.level, second.level)
{
  X <- model.matrix(~ Combinations-1, data = preds)
  ## Form the contrast matrix
  #Determine the columns of X for each contrast
  colsets <- split(colnames(X), preds[indx], lex.order = TRUE)
  prediv <- split(preds, preds[indx], lex.order = TRUE)
  locns <- lapply(colsets,
                  function(x, cols = colnames(X))
                  { pair <-  na.omit(match(x, cols)); names(pair) <- x; return(pair) })
  contr <- mapply(function(pred, cols, pairs.factor, first.level, second.level)
  {
    names(cols) <- gsub("Combinations", "", names(cols), fixed = TRUE)
    #    k1 <- (1:length(cols))[grepl(first.level, names(cols), fixed = TRUE)]
    #    k2 <- (1:length(cols))[grepl(second.level, names(cols), fixed = TRUE)]
    k1 <- (1:length(cols))[pred[pairs.factor] == first.level]
    k2 <- (1:length(cols))[pred[pairs.factor] == second.level]

    if (any(c(length(k1),length(k2)) == 0)) #no contrast
      cols <- NA
    else
    {
      if (length(k1) != 1)
        stop("There is more than one observation with the level ", first.level, " in combination ", names(cols))
      else
      {
        if (length(k2) != 1)
          stop("There is more than one observation with the level ", second.level, " in combination ", names(cols))
        else
        {
          cols[1:length(cols)] <- 0
          cols[k1] <- 1
          cols[k2] <- -1
        }
      }
    }
    return(cols)
  }, prediv, locns, MoreArgs = list(pairs.factor = pairs.factor,
                                   first.level = first.level, second.level = second.level),
  SIMPLIFY = FALSE)

  #Substitute the contrast in one column and NA in the other for each contrast
  for (k in 1:length(locns))
  {
    for (j in 1:length(locns[[k]]))
    {
      X[locns[[k]][j], locns[[k]][1]] <- contr[[k]][j]
      if (j != 1)
        X[locns[[k]][j], locns[[k]][j]] <- 0
    }
  }

  #Form contrast matrix
  X <- X[, unlist(locns)[order(unlist(locns))]]
  which.cols <- unlist(lapply(1:ncol(X),
                              function(k)
                              {
                                if   (any(is.na(as.vector(X[,k])))) retain <- FALSE
                                else retain <- !all(X[,k] == 0)
                              }))
  L <- t(X[, which.cols])

  rownames(L) <- gsub(paste0("Combinations"), "", rownames(L), fixed = TRUE)
  lev <- levels(preds[[pairs.factor]])[1]
  rownames(L) <- gsub(paste0(",",lev), "", rownames(L), fixed = TRUE)
  rownames(L) <- gsub(paste0(lev,","), "", rownames(L), fixed = TRUE)
  return(L)
}

ratioTransform.alldiffs <- function(alldiffs.obj, ratio.factor,
                                    numerator.levels, denominator.levels,
                                    method = "Fieller", alpha = 0.05,
                                    response = NULL, response.title = NULL,
                                    tables = "predictions",
                                    ...)
{
  #Check that a valid object of class alldiffs
  validalldifs <- validAlldiffs(alldiffs.obj)
  if (is.character(validalldifs))
    stop(validalldifs)
  alldiffs.obj <- renameDiffsAttr(alldiffs.obj)

  meth.options <- c("Fieller")
  method.opt <- meth.options[check.arg.values(method, meth.options)]
  options <- c("none", "predictions", "backtransforms", "vcov",
               "differences", "p.differences", "sed", "LSD", "all")
  opt <- options[unlist(lapply(tables, check.arg.values, options=options))]

  #Get a t-value (use z if no tdf attribute)
  tdf <- attr(alldiffs.obj, which = "tdf")
  if (!is.null(tdf))
  {
    t <- qt(1 - alpha/2, df = tdf)
  } else
    t <- qnorm(1 - alpha/2)

  if (is.null(response))
    response <- attr(alldiffs.obj, which = "response")
  if (is.null(response.title))
    response.title <- attr(alldiffs.obj, which = "response.title")
  classify <- attr(alldiffs.obj, which = "classify")

  facs <- fac.getinTerm(classify, rmfunction = TRUE)
  alldiffs.obj <- renewClassify(alldiffs.obj, newclassify = classify) #make sure in standard order
  tmp <- alldiffs.obj$predictions
  tmp$Combinations <- dae::fac.combine(as.list(tmp[facs]), combine.levels = TRUE, sep = ",")
  if (length(ratio.factor) != 1 | !(ratio.factor %in% facs))
    stop("ratio factor must specify a single factor that is in the classify attribute of the alldiffs object")
  if (!all(c(numerator.levels, denominator.levels) %in% levels(tmp[[ratio.factor]])))
    stop("Not all numerator.levels and denominator.levels are levels in ", ratio.factor, " in the alldiffs object")
  sortFactor <- attr(alldiffs.obj, which = "sortFactor")

  indx <- setdiff(facs, ratio.factor)

  # if (length(indx) == 1)
  # {
  #   ratios.dat <- as.data.frame(ratios.dat, row.names = NULL)
  #   names(ratios.dat)[1] <- indx
  # }
  tmp <- split(tmp, tmp[indx], sep = ",", lex.order = TRUE)
  Ratios <- lapply(denominator.levels, function(denom.lev,tmp, t)
  {
    lapply(numerator.levels, function(num.lev, denom.lev, tmp, t)
    {

      if (!(num.lev %in% alldiffs.obj$predictions[[ratio.factor]]) ||
          !(denom.lev %in% alldiffs.obj$predictions[[ratio.factor]]) ||
          num.lev == denom.lev)
        ratioCIs <-NULL
      else
      {
        ratioCIs <- do.call(rbind, lapply(tmp, function(preds, num.lev, denom.lev, V, t)
        {
          indx.vals <- (lapply(preds[indx], function(x) as.character(x)[1])) #current levels of indx factors
          ratio.pair <- c(indx.vals, rep(NA,3))
          names(ratio.pair) <- c(indx, "pred.ratio", "upper.Confidence.limit", "lower.Confidence.limit")
          if (all(c(num.lev, denom.lev) %in% preds[[ratio.factor]]))
          {
            a <- preds[preds[ratio.factor] == num.lev, "predicted.value"]
            b <- preds[preds[ratio.factor] == denom.lev, "predicted.value"]
            labs <- preds$Combinations
            posns <- unlist(lapply(c(num.lev,denom.lev), grep, x =labs, fixed = TRUE))
            lab <- labs[posns]
            Vpair <- V[lab,lab]
            ratio.pair <- as.data.frame(c(indx.vals, (FiellerRatioCI(a, b, Vpair, t = t))))
          }
          return(ratio.pair)
        }, V = alldiffs.obj$vcov, num.lev = num.lev, denom.lev = denom.lev, t = t))

        rownames(ratioCIs) <- NULL
        names(ratioCIs)[match("pred.ratio", names(ratioCIs))] <- "predicted.value"
        ratioCIs$standard.error <- NA
        ratioCIs$est.status <- "Estimable"
        ratio.names <- names(ratioCIs)
        n <- match("standard.error", ratio.names)
        k <- match("upper.Confidence.limit", ratio.names)
        if (n-k+1 != 3)
          stop("Standard.error and confidence limits not together in ratios data frame")
        ratio.names[k:n] <- c("standard.error", "upper.Confidence.limit", "lower.Confidence.limit")
        ratioCIs <- ratioCIs[ratio.names]
        ratioCIs[indx] <-  lapply(indx,
                                  function(fac) new.fac <- factor(ratioCIs[[fac]],
                                                                  levels = levels(alldiffs.obj$predictions[[fac]])))
        ratioCIs <- as.predictions.frame(ratioCIs)
        class(ratioCIs) <- c("predictions.frame", "data.frame")
        attr(ratioCIs, which = "response") <- response
        attr(ratioCIs, which = "response.title") <- response.title

        #sort the predictions.frame, if it was previously sorted
        if (!is.null(sortFactor))
        {
          if (sortFactor != ratio.factor)
            ratioCIs <- sort(ratioCIs, sortFactor = sortFactor, classify = paste(indx, collapse = ":"),
                             sortOrder = attr(alldiffs.obj, which = "sortOrder"))
        }
      }
      return(ratioCIs)
    }, tmp = tmp, denom.lev = denom.lev, t = t)
  }, tmp = tmp, t = t)
  Ratios <- unlist(Ratios, recursive = FALSE)
  nams <- outer(numerator.levels, denominator.levels, paste, sep = ",")
  names(Ratios) <- nams

  if ("predictions" == opt)
  {
    cat("\n\n#### Table(s) of ratio predictions and confidence limits for ", response, "\n\n")
    print(Ratios)
  }
  invisible(Ratios)
}

pairdiffsTransform.alldiffs <- function(alldiffs.obj, pairs.factor, first.levels, second.levels,
                                        Vmatrix = FALSE,
                                        error.intervals = "Confidence",
                                        avsed.tolerance = 0.25, accuracy.threshold = NA,
                                        LSDtype = "overall", LSDsupplied = NULL, LSDby = NULL,
                                        LSDstatistic = "mean", LSDaccuracy = "maxAbsDeviation",
                                        response = NULL, response.title = NULL, tables = "all",
                                        pairwise = TRUE, alpha = 0.05, ...)
{
  #Check for deprecated argument meanLSD.type and warn
  tempcall <- list(...)
  if (length(tempcall))
    if ("meanLSD.type" %in% names(tempcall))
      stop("meanLSD.type has been deprecated - use LSDtype")

  #Check that a valid object of class alldiffs
  validalldifs <- validAlldiffs(alldiffs.obj)
  if (is.character(validalldifs))
    stop(validalldifs)
  alldiffs.obj <- renameDiffsAttr(alldiffs.obj)
  attr(alldiffs.obj, which = "alpha") <- alpha

  #get transform attributes from backtransforms
  transform.power = 1; offset <- 0; scale <- 1
  if (!is.null(alldiffs.obj$backtransforms))
  {
    transform.power = attr(alldiffs.obj$backtransforms, which = "transform.power")
    offset = attr(alldiffs.obj$backtransforms, which = "offset")
    scale = attr(alldiffs.obj$backtransforms, which = "scale")
  }

  sortFactor <- attr(alldiffs.obj, which = "sortFactor")

  int.options <- c("none", "Confidence", "StandardError", "halfLeastSignificant")
  int.opt <- int.options[check.arg.values(error.intervals, int.options)]
  options <- c("none", "predictions", "backtransforms", "vcov",
               "differences", "p.differences", "sed", "LSD", "all")
  opt <- options[unlist(lapply(tables, check.arg.values, options=options))]
  #Get a t-value (use z if no tdf attribute)
  tdf <- attr(alldiffs.obj, which = "tdf")
  if (!is.null(tdf))
  {
    t <- qt(1 - alpha/2, df = tdf)
  } else
    t <- qnorm(1 - alpha/2)

  if (is.null(response))
    response <- attr(alldiffs.obj, which = "response")
  if (is.null(response.title))
    response.title <- attr(alldiffs.obj, which = "response.title")
  classify <- attr(alldiffs.obj, which = "classify")
  facs <- fac.getinTerm(classify, rmfunction = TRUE)
  alldiffs.obj <- renewClassify(alldiffs.obj, newclassify = classify) #make sure in standard order
  tmp <- alldiffs.obj$predictions
  tmp$Combinations <- dae::fac.combine(as.list(tmp[facs]), combine.levels = TRUE, sep = ",")
  if (length(pairs.factor) != 1 | !(pairs.factor %in% facs))
    stop("pairs factor must specify a single factor that is in the classify attribute of the alldiffs object")
  if (!all(c(first.levels, second.levels) %in% levels(tmp[[pairs.factor]])))
    stop("Not all first.levels and second.levels are levels in ", pairs.factor, " in the all diffs object")

  indx <- setdiff(facs, pairs.factor)

  Diffs <- lapply(second.levels, function(second.lev,tmp)
  {
    lapply(first.levels, function(first.lev, second.lev, tmp)
    {

      if (!(first.lev %in% alldiffs.obj$predictions[[pairs.factor]]) ||
          !(second.lev %in% alldiffs.obj$predictions[[pairs.factor]]))
        diffs <-NULL
      else
      {
        L <- makeContrastMatrix(tmp, indx = indx, pairs.factor = pairs.factor, first.lev, second.lev)

        #form the factors indexing the pair-difference predictions
        new.facs <- lapply(indx, function(fac, data)
        {
          levels(tmp[[fac]])
        }, data = tmp)
        names(new.facs) <- indx
        if (length(indx) == 1)
        {
          pairs.dat <- as.data.frame(rownames(L), stringsAsFactors = FALSE)
          names(pairs.dat) <- indx
          pairs.dat[indx] <- factor(pairs.dat[[indx]], levels = rownames(L))
        }
        else
          pairs.dat <- dae::fac.uncombine(rownames(L), new.factors = new.facs, sep = ",")

        #Calculate the differences for the current pair
        diffs <- linTransform(alldiffs.obj, classify = classify,
                              linear.transformation = L, Vmatrix = Vmatrix,
                              error.intervals = "Confidence",
                              avsed.tolerance = avsed.tolerance, accuracy.threshold = accuracy.threshold,
                              response = response, response.title = response.title,
                              pairwise = pairwise, alpha = alpha,
                              tables = "none", ...)
        diffs$predictions <- cbind(pairs.dat, diffs$predictions)
        diffs$predictions <- diffs$predictions[, -match("Combination", names(diffs$predictions))]
        diffs <- renewClassify(diffs, newclassify = paste(indx, collapse = ":"))
        diffs <- redoErrorIntervals(diffs,  error.intervals = int.opt, alpha = alpha,
                                    avsed.tolerance = avsed.tolerance, accuracy.threshold = accuracy.threshold,
                                    LSDtype = LSDtype, LSDby = LSDby, LSDsupplied = LSDsupplied,
                                    LSDstatistic = LSDstatistic, LSDaccuracy = LSDaccuracy)
        # if (!is.null(diffs$backtransforms))
        # {
        #   diffs$backtransforms <- cbind(pairs.dat, diffs$backtransforms)
        #   diffs$backtransforms <- diffs$backtransforms[, -match("Combination", names(diffs$backtransforms))]
        #   #Find missing attributes in new alldiffs.obj and add them back in
        #   newattr <- attributes(diffs$backtransforms)
        #   back.attr <- attributes(alldiffs.obj$backtransforms)
        #   back.attr <- back.attr[names(back.attr)[!(names(back.attr) %in% names(newattr))]]
        #   if (length(back.attr) > 0)
        #   {
        #     newattr <- c(newattr,back.attr)
        #     attributes(diffs$backtransforms) <- newattr
        #   }
        # }

        #sort the alldiffs if it was previously sorted
        if (!is.null(sortFactor))
        {
          if (sortFactor != pairs.factor)
            diffs <- sort(diffs, sortFactor = sortFactor,
                             sortOrder = attr(diffs, which = "sortOrder"))
        }

        if (opt != "none")
          print(diffs, which = opt)
        return(diffs)
      }
    }, tmp = tmp, second.lev = second.lev)
  }, tmp = tmp)
  Diffs <- unlist(Diffs, recursive = FALSE)
  nams <- outer(first.levels, second.levels, paste, sep = ",")
  names(Diffs) <- nams
  invisible(Diffs)
}


#' Build a Link-path Incidence Matrix
#'
#' This function builds a link-path incidence matrix, in which feasible routes are determined using stochastic network loading based on user-specified link costs. The routes are based on a probit model, implemented via simulation.
#' @param Links For a network with N nodes, Links is an NxN matrix. The i,j entry of Links is the link number (ID) for the node connecting node i to node j. Entries should be set to NA if there is no link between the node pair in question.
#' @param Costs A 2-column matrix, the first column of which is the link number (ID) and the second the link travel cost. Costs should be strictly positive.
#' @param theta Standard deviation of link costs when apply probit-based stochastic network loading to identify routes. Can be vector of length equal to the number of links, or a scalar (which is then replicated if necessary). Default value is theta=0, so that only shortest paths between OD pairs are generated.
#' @param nsim Number of simulation runs to find routes. In each run, link costs are modified by adding normal error, and the shortest paths computed with respect to these modified costs. nsim defaults to 100.
#' @param orig Set of nodes specified as possible origins of travel. Defaults to all nodes for which there is at least one feasible route to another node.
#' @param dest Set of nodes specified as possible destinations of travel. Defaults to all nodes that are reachable from elsewere by a feasible path.
#' @return A list containing the link-path incidence matrix A, a vector O specifying the origin for each path, and a vector D specifying the destination for each path.
#' @keywords link-path incidence matrix
#' @export
#' @examples
#' Links <- matrix(0,nrow=9, ncol=9)
#' Links[1,7] <- 1
#' Links[2,7] <- 2
#' Links[1,5] <- 3
#' Links[7,8] <- 4
#' Links[2,6] <- 5
#' Links[5,8] <- 6
#' Links[8,5] <- 7
#' Links[8,6] <- 8
#' Links[6,8] <- 9
#' Links[5,3] <- 10
#' Links[8,9] <- 11
#' Links[6,4] <- 12
#' Links[9,3] <- 13
#' Links[9,4] <- 14
#' Costs <- cbind(1:14,rep(1,14))
#' buildA(Links,Costs)
#' buildA(links,Costs,theta=0.4,orig=c(1,2),dest=c(3,4))

buildA <- function(Links,Costs,theta=0,nsim=100,orig=NA,dest=NA){
	require(e1071)
	r <- nrow(Links)
	n <- nrow(Costs)
	A <- D <- O <- numeric(0)
	X <- Links*NA
	theta <- rep(theta,length.out=n)
	if (is.na(orig[1])) orig <- 1:r
	if (is.na(dest[1])) dest <- 1:r
	if (theta[1] <= 0) nsim <- 1
	for (i in 1:nsim){
		for ( i in Costs[,1]){
			X[Links==Costs[i,1]] <- Costs[i,2] + rnorm(1,sd=theta[i])
		}
		X[X<0] <- 1e-6
		SP <- allShortestPaths(X)
		for (o in orig){
			for (d in dest){
				if (o!=d){
					if(!is.na(SP$length[o,d])){
						p <- extractPath(SP,o,d)
						a <- rep(0,n)
						for (j in 1:(length(p)-1) ){
							link <- Links[p[j],p[j+1]]
							a[link] <- 1
						}
						A <- cbind(A,a)
						O <- c(O,o)
						D <- c(D,d)
					}
				}
			}
		}
	}
	indx <- duplicated(A,MARGIN=2)
	A <- A[,!indx]
	O <- O[!indx]
	D <- D[!indx]
	indx <- order(O,D)
	A <- A[,indx]
	O <- O[indx]
	D <- D[indx]
	list(A=unname(A),O=O,D=D)
}


#' Create spline curve and calculate 1st derivative
#'
#' @param YValues
#' @param XValues
#' @param xlabel
#' @param ylabel
#' @param mainlabel
#' @param ylim
#'
#' @return plot
#'
#' @examples
SplineCurveAndDerivative <- function(YValues, XValues,xlabel="x",ylabel="y",mainlabel="main",ylim=c(-0.5,0.5)){
  if(length(YValues)!=length(XValues)){
    stop("Number of elements in maturity and discount margin must be the same")
  }

  #spline

  spl <- smooth.spline(YValues~ XValues,all.knots = TRUE)
  par(mfrow=c(2,1))

  plot(spl,ylab = ylabel ,xaxt='n',xlab = xlabel,main = mainlabel)
  graphics::abline(h = 0, lty = 2)
  splData <- seq(min(XValues),max(XValues),(max(XValues)-min(XValues))/500)
  sx <- seq(from=head(XValues,1),to = tail(XValues,1),by = (tail(XValues,1)-head(XValues,1))/1000)
  lines(predict(spl,as.numeric(sx)))
  if(class(XValues) == "Date" || class(XValues)=="POSIXt"){
    axis.Date(side = 1,XValues,format = '%m/%Y',labels = T,at=XValues,las=2)
  }
  pred.prime<-predict(spl,as.numeric(sx),deriv=1)
  d1 <- data.frame(pred.prime)
  plot(d1,type = "l",xaxt='n',xlab=xlabel,ylab="derivative",ylim = ylim)
  graphics::abline(h = 0, lty = 2)
  if(class(XValues) == "Date"){
    axis.Date(side=1,sx,format = "%m/%Y",labels = T,at =XValues,las=2)
  }
  par(mfrow=c(1,1))
  recordedPlot =recordPlot()
  return(recordedPlot)

}


#' Function that carries out a sinusoidal regression
#'
#' Fits a sinusoid through data provided as an \code{x} and \code{y}
#' vector and returns a list containing both the fitted curve and the
#' parameters of that curve.
#' Used to produce initial values for modeling data windows and later
#' to find peaks in modeled julian day values to align the result to
#' a cumulative age timeline.
#'
#' @param x Vector of \code{x} values of input data
#' @param y Vector of \code{y} values of input data
#' @param fixed_period Optional variable for fixing the period of the sinusoid
#' in the depth domain. Defaults to \code{NA}, period is not fixed. Supply a
#' single value to fix the period.
#' @param plot Should the fitting result be plotted? \code{TRUE/FALSE}
#' @return A list containing a vector of parameters of the fitted sinusoid
#' and the fitted values belonging to each \code{x} value.
#' Fitting parameters:
#' \code{I} = the mean annual value of the sinusoid (height)
#' \code{A} = the amplitude of the sinusoid
#' \code{Dper} = the period of the sinusoid in \code{x} domain
#' \code{peak} = the location of the peak in the sinusoid
#' \code{R2adj} = the adjusted \code{R^2} value of the fit
#' \code{p} = the p-value of the fit
#' @examples
#' # Create dummy data
#' x <- seq(1000, 11000, 1000)
#' y <- sin((2 * pi * (seq(1, 11, 1) - 8 + 7 / 4)) / 7)
#' sinlist <- sinreg(x, y, plot = FALSE) # Run the function
#' @export
sinreg <- function(x, # Function to perform sinusoid regression meant to estimate the starting parameters for fitting growth and temperature sinusoids
    y,
    fixed_period = NA, # Option to fix the period in depth domain. Default = NA (Period not fixed)
    plot = FALSE # Plot results?
    ){

    if(is.na(fixed_period)){ # If period is not fixed, run simple periodogram to find the most likely period
        Ots <- ts(y) # Turn y into a time series
        ssp <- spectrum(Ots, plot = FALSE) # Create periodogram of y
        Nper <- 1/ssp$freq[ssp$spec==max(ssp$spec)] # Estimate period in terms of sample number
        Dper <- Nper * diff(range(x))/length(x) # Convert period to depth domain
    }else if(is.numeric(fixed_period) & length(fixed_period) == 1){ # Check if a valid entry is provided for Dper
        Dper <- fixed_period
    }else{
        stop("ERROR: Supplied value for fixed period is not recognized")
    }

    sinlm <- lm(y ~ sin(2*pi/Dper*x)+cos(2*pi/Dper*x)) # Run linear model, cutting up d18O = Asin(2*pi*D) into d18O = asin(D)+bcos(D)
    sinm<-sinlm$fitted # Extract model result
    if(plot == TRUE){
        dev.new()
        plot(x, y); lines(x, sinm, col = "red")
    }

    coeff<-summary(sinlm)[["coefficients"]] # Extract a, b and intercept + uncertainties

    # Calculate coefficients of the form d18O = I + Asin(2*pi*D + p)
    I<-coeff[1,1] # Intercept (mean annual value)
    A<-sqrt(coeff[2,1]^2+coeff[3,1]^2) # Amplitude of seasonality
    phase<--acos(coeff[2,1]/A) # Phase of sinusoid
    peak<-(0.25+(phase/(2*pi))) * Dper # timing of seasonal peak
    R2adj<-summary(sinlm)$adj.r.squared # Goodness of model fit (adjusted R2)
    p <- as.numeric(pf(summary(sinlm)$fstatistic[1],summary(sinlm)$fstatistic[2],summary(sinlm)$fstatistic[3],lower.tail=F)) # p-value of model

    return(list(c(I,A,Dper,peak,R2adj,p),sinm)) # Return results of regression
}


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 18

rm(list = ls())

observed <- c(0.59, 0.72, 0.47, 0.44, 0.31, 0.56, 0.22, 0.90, 0.96, 0.78, 0.66, 0.18, 0.73, 0.43, 0.58, 0.11)

test <- ks.test(observed, punif)

(pvalue <- test$p.value)
# 0.614776160341058


## Indicator Library

EMA <- function(starttime, endtime, duration, symbol, env,datatype){
  if (starttime == endtime){
    return(SMA(starttime, duration, symbol, env, datatype)) #### Change when SMA function is written
  }
  else{
    timeweight = 2/(duration +1)
    EMAval = (env[[datatype]][["CLOSE"]][currtime] -
                EMA(starttime - 1, endtime, duration, symbol, env,datatype))*timeweight +
                EMA(starttime - 1, endtime, duration, symbol, env,datatype)
    return (EMAval)
  }
}

MACD <- function(starttime, endtime1, endtime2, endtime3, duration1, duration2, duration3, symbol, env,datatype){
  MACDval = EMA(starttime, endtime1, duration1, symbol, env, datatype) -
            EMA(starttime, endtime2, duration2, symbol, env, datatype)
  signalval = EMA(starttime, endtime3, duration3, symbol, env, datatype)
  return (MACDval - signalval)
}


l0 <- 15 # length going at sea
l.inf <- c(100, 110) # theoritical max length, different by country
k <- .5 # yearly growth rate start
k.year <- k * (1 - .01 * 0:(year.end - year.start))# growth rate decreasing with year
sd.length <- 5 # var around mean
t0 <- -.91 # parameter shifting von bertalanffy growth curve

# mean length faben version von bertqlanffy growth model
mean.length <- l0 +
  (l.inf[as.numeric(as.factor(salmons$country))] - l0) *
  (1 -
     exp(- k.year[salmons$year - min(salmons$year) + 1] *
           (salmons$sea.age - t0)))

hist(mean.length)

# add gamma noise
length <- rgamma(n = dim(salmons)[1],
                 shape = (mean.length / sd.length) ^ 2,
                 scale = (sd.length ^ 2) / mean.length)
hist(length)
min(length)
salmons$length <- round(length, 1)
# add noise with normal and coeffcient of variation
#length <- rnorm(n = dim(salmons)[1], mean = mean.length, sd = mean.length * .1)
#length <- round(length, 1)
#hist(length)


library(dplyr)
library(tidyr)
library(ggplot2)
library(ascii)
library(lubridate)
library(ellipse)
library(mclust)
library(cluster)

###############################################################
## Import datasets needed for chapter 7
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

sp500_px <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_px.csv'), row.names = 1)
sp500_sym <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_sym.csv'), stringsAsFactors = FALSE)
loan_data <- read.csv(file.path(PSDS_PATH, 'data', 'loan_data.csv'))
loan_data$outcome <- ordered(loan_data$outcome, levels=c('paid off', 'default'))

###############################################################
## PCA for oil data
oil_px = as.data.frame(scale(oil_px, scale=FALSE))
oil_px <- sp500_px[, c('CVX', 'XOM')]
pca <- princomp(oil_px)
pca$loadings

## Figure 7-1: principal components for oil stock data
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0701.png'), width = 4, height=4, units='in', res=300)
loadings <- pca$loadings
ggplot(data=oil_px, aes(x=CVX, y=XOM)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values=c(46)) +
  stat_ellipse(type='norm', level=.99, color='grey25') +
  geom_abline(intercept = 0, slope = loadings[2,1]/loadings[1,1], color='grey25', linetype=2) +
  geom_abline(intercept = 0, slope = loadings[2,2]/loadings[1,2],  color='grey25', linetype=2) +
  scale_x_continuous(expand=c(0,0), lim=c(-3, 3)) +
  scale_y_continuous(expand=c(0,0), lim=c(-3, 3)) +
  theme_bw()

dev.off()

## Figure 7-2: screeplot
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0702.png'), width = 4, height=4, units='in', res=300)

syms <- c( 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM', 'SLB', 'COP',
           'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
top_cons <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]
sp_pca <- princomp(top_cons)
par(mar=c(6,3,0,0)+.1, las=2)
screeplot(sp_pca, main='')

dev.off()

## Loadings for stock data
loadings = sp_pca$loadings[,1:5]
loadings <- as.data.frame(loadings)
loadings$Symbol <- row.names(loadings)
loadings <- gather(loadings, "Component", "Weight", -Symbol)
head(loadings)

## Figure 7-3: Plot of component loadings
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0703.png'), width = 4, height=4, units='in', res=300)

loadings$Color = loadings$Weight > 0
ggplot(loadings, aes(x=Symbol, y=Weight, fill=Color)) +
  geom_bar(stat='identity', position = "identity", width=.75) +
  facet_grid(Component ~ ., scales='free_y') +
  guides(fill=FALSE)  +
  ylab('Component Loading') +
  theme_bw() +
  theme(axis.title.x = element_blank(),
        axis.text.x  = element_text(angle=90, vjust=0.5))

dev.off()

###############################################################
## K-means chapter

set.seed(1010103)
df <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
km <- kmeans(df, centers=4, nstart=1)

df$cluster <- factor(km$cluster)
head(df)

centers <- data.frame(cluster=factor(1:4), km$centers)
centers

## Figure 7-4: K-means clusters for two stocks
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0704.png'), width = 4, height=3, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values = 1:4,
                     guide = guide_legend(override.aes=aes(size=1))) +
  geom_point(data=centers,  aes(x=XOM, y=CVX), size=2, stroke=2)  +
  theme_bw() +
  scale_x_continuous(expand=c(0,0), lim=c(-2, 2)) +
  scale_y_continuous(expand=c(0,0), lim=c(-2.5, 2.5))

dev.off()

## cluster means algorithm
syms <- c( 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM', 'SLB', 'COP',
           'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
df <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]

set.seed(10010)
km <- kmeans(df, centers=5, nstart=10)
km$size
centers <- km$centers

#centers <- scale(scale(centers, center=FALSE, scale=1/attr(df, 'scaled:scale')),
#                 center=-attr(df, 'scaled:center'), scale=FALSE)

## Figure 7-5 interpreting the clusters
centers <- as.data.frame(t(centers))
names(centers) <- paste("Cluster", 1:5)
centers$Symbol <- row.names(centers)
centers <- gather(centers, "Cluster", "Mean", -Symbol)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0705.png'), width = 4, height=5, units='in', res=300)

centers$Color = centers$Mean > 0
ggplot(centers, aes(x=Symbol, y=Mean, fill=Color)) +
  geom_bar(stat='identity', position = "identity", width=.75) +
  facet_grid(Cluster ~ ., scales='free_y') +
  guides(fill=FALSE)  +
  ylab('Component Loading') +
  theme_bw() +
  theme(axis.title.x = element_blank(),
        axis.text.x  = element_text(angle=90, vjust=0.5))

dev.off()

## Figure 7-6: selecting the number of clusters (elbow plot)
pct_var <- data.frame(pct_var = 0,
                      num_clusters=2:14)
totalss <- kmeans(df, centers=14, nstart=50, iter.max = 100)$totss
for(i in 2:14){
  pct_var[i-1, 'pct_var'] <- kmeans(df, centers=i, nstart=50, iter.max = 100)$betweenss/totalss
}

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0706.png'), width = 4, height=3, units='in', res=300)

ggplot(pct_var, aes(x=num_clusters, y=pct_var)) +
  geom_line() +
  geom_point() +
  labs(y='% Variance Explained', x='Number of Clusters') +
  scale_x_continuous(breaks=seq(2, 14, by=2))   +
  theme_bw()
dev.off()

################################################################
## hclust chapter

syms1 <- c('GOOGL', 'AMZN', 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX',
           'XOM', 'SLB', 'COP', 'JPM', 'WFC', 'USB', 'AXP',
           'WMT', 'TGT', 'HD', 'COST')

df <- sp500_px[row.names(sp500_px)>='2011-01-01', syms1]
d <- dist(t(df))
hcl <- hclust(d)

## Figure 7-7: dendograme of stock data
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0707.png'), width = 4, height=4, units='in', res=300)

par(cex=.75, mar=c(0, 5, 0, 0)+.1)
plot(hcl, ylab='distance', xlab='', sub='', main='')

dev.off()

## Figure 7-8: comparison of the different measuresof dissimilarity
cluster_fun <- function(df, method)
{
  d <- dist(df)
  hcl <- hclust(d, method=method)
  tree <- cutree(hcl, k=4)
  df$cluster <- factor(tree)
  df$method <- method
  return(df)
}

df0 <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
df <- rbind(cluster_fun(df0, method='single'),
            cluster_fun(df0, method='average'),
            cluster_fun(df0, method='complete'),
            cluster_fun(df0, method='ward.D'))
df$method <- ordered(df$method, c('single', 'average', 'complete', 'ward.D'))

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0708.png'), width = 5.5, height=4, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values = c(46, 3, 1,  4),
                     guide = guide_legend(override.aes=aes(size=2))) +
  facet_wrap( ~ method) +
  theme_bw()

dev.off()

###############################################################
# Model-based clusting
# Multivariate normal

mu <- c(.5, -.5)
sigma <- matrix(c(1, 1, 1, 2), nrow=2)
prob <- c(.5, .75, .95, .99) ## or whatever you want
names(prob) <- prob ## to get id column in result
x <- NULL
for (p in prob){
  x <- rbind(x,  ellipse(x=sigma, centre=mu, level=p))
}
df <- data.frame(x, prob=factor(rep(prob, rep(100, length(prob)))))
names(df) <- c("X", "Y", "Prob")

## Figure 7-9: Multivariate normal ellipses
dfmu <- data.frame(X=mu[1], Y=mu[2])
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0709.png'), width = 4, height=4, units='in', res=300)

ggplot(df, aes(X, Y)) +
  geom_path(aes(linetype=Prob)) +
  geom_point(data=dfmu, aes(X, Y), size=3) +
  theme_bw()

dev.off()

## Figure 7-10 mclust applied XOM and CVX

df <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
mcl <- Mclust(df)
summary(mcl)

cluster <- factor(predict(mcl)$classification)
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0710.png'), width = 5, height=4, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.8) +
  theme_bw() +
  scale_shape_manual(values = c(46, 3),
                     guide = guide_legend(override.aes=aes(size=2)))

dev.off()

summary(mcl, parameters=TRUE)$mean
summary(mcl, parameters=TRUE)$variance

## Figure 7-11: BIC scores for the different models fit by mclust

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0711.png'), width = 4, height=4, units='in', res=300)

par(mar=c(4, 5, 0, 0)+.1)
plot(mcl, what='BIC', ask=FALSE, cex=.75)

dev.off()
#

#######################################################################
# Scaling chapter

defaults <- loan_data[loan_data$outcome=='default',]
df <- defaults[, c('loan_amnt', 'annual_inc', 'revol_bal', 'open_acc', 'dti', 'revol_util')]
km <- kmeans(df, centers=4, nstart=10)
centers <- data.frame(size=km$size, km$centers)
round(centers, digits=2)

df0 <- scale(df)
km0 <- kmeans(df0, centers=4, nstart=10)
centers0 <- scale(km0$centers, center=FALSE, scale=1/attr(df0, 'scaled:scale'))
centers0 <- scale(centers0, center=-attr(df0, 'scaled:center'), scale=FALSE)
centers0 <- data.frame(size=km0$size, centers0)
round(centers0, digits=2)

km <- kmeans(df, centers=4, nstart=10)
centers <- data.frame(size=km$size, km$centers)
round(centers, digits=2)

## Figure 7-12: screeplot for data with dominant variables

syms <- c('GOOGL', 'AMZN', 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM',
          'SLB', 'COP', 'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
top_15 <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]
sp_pca1 <- princomp(top_15)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0712.png'), width = 4, height=4, units='in', res=300)

par(mar=c(6,3,0,0)+.1, las=2)
screeplot(sp_pca1, main='')

dev.off()

round(sp_pca1$loadings[,1:2], 3)

#
###############################################################
## Figure 7-13: Categorical data and Gower's distance

x <- loan_data[1:5, c('dti', 'payment_inc_ratio', 'home_', 'purpose_')]
x

daisy(x, metric='gower')

set.seed(301)
df <- loan_data[sample(nrow(loan_data), 250),
                c('dti', 'payment_inc_ratio', 'home_', 'purpose_')]
d = daisy(df, metric='gower')
hcl <- hclust(d)
dnd <- as.dendrogram(hcl)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0713.png'), width = 4, height=4, units='in', res=300)
par(mar=c(0,5,0,0)+.1)
plot(dnd, leaflab='none', ylab='distance')
dev.off()

dnd_cut <- cut(dnd, h=.5)
df[labels(dnd_cut$lower[[1]]),]

## Problems in clustering with mixed data types
df <- model.matrix(~ -1 + dti + payment_inc_ratio + home_ + pub_rec_zero, data=defaults)
df0 <- scale(df)
km0 <- kmeans(df0, centers=4, nstart=10)
centers0 <- scale(km0$centers, center=FALSE, scale=1/attr(df0, 'scaled:scale'))
round(scale(centers0, center=-attr(df0, 'scaled:center'), scale=FALSE), 2)


# Enter your code here. Read input from STDIN. Print output to STDOUT
rej <- 0.12
answer1 <- pbinom(2, size = 10, prob = rej)
write(round(answer1, 3), stdout())
answer2 <- pbinom(8, size = 10, prob = 1 - rej)
write(round(answer2, 3), stdout())


# FUNCTION

is_triplet <- function(a, b, c) {
    (a < b) && (b < c) && (a ** 2 + b ** 2 == c ** 2)
}

# SCRIPT

for (a in 1:1000) {
    for (b in (a + 1):(1000 - a)) {
        c = 1000 - (a + b)
        if (is_triplet(a, b, c)) {
            cat(a, b, c, "\n", sep = " ")
            quit("no")
        }
    }
}


##' @title
##' Classification Metrics Parameters
##'
##' @description
##'
##' Documentation for shared parameters of functions that computes
##' classification metrics.
##'
##' @param actual \code{[numeric]} Ground truth binary numeric vector containing
##'     1 for the positive class and 0 for the negative class.
##' @param predicted \code{[numeric]} A vector of estimated probabilities.
##' @param cutoff \code{[numeric]} A cutoff value for \code{predicted} vector
##'     which classify a sample into a given class. Default value is 0.5
##'
##' @include helper-functions.r
##' @name classification_params
NULL

##' @title
##' Confusion Matrix
##'
##'
##' @description
##'
##' Confusion matrix - a special kind of contingency table - is a specific table
##' layout that allows the visualization of performance of a classification
##' model (or classifier). It composes of four different combinations of
##' predicted and actual values.
##'
##' \code{confusion_list} computes and returns those combinations as a
##' \code{named list} while \code{mtr_confusion_matrix} returns a \code{named
##' matrix}.
##'
##' Here's elements of confusion matrix:
##'
##' \itemize{
##'   \item True Positive (TP)
##'   \item False Positive (FP)
##'   \item True Negative (TN)
##'   \item False Negative (FN)
##' }
##'
##' @inheritParams classification_params
##' @return A named list or a named two dimensions matrix
##' @author An Chu
##' @examples
##'
##' act <- c(1, 0, 0, 1, 1)
##' pred <- c(0.9, 0.3, 0.6, 0.5, 0.2)
##'
##' ## output as a R's list
##' ## metrics:::confusion_list(act, pred) # default value of cutoff = 0.5
##' ## metrics:::confusion_list(act, pred, cutoff = 0.7)
##'
##' ## output as a R's matrix
##' mtr_confusion_matrix(act, pred)
##' mtr_confusion_matrix(act, pred, cutoff = 0.7)
##'
##'
##' @name confusion_matrix
confusion_list <- function(actual, predicted, cutoff = 0.5) {

    check_equal_length(actual, predicted)
    check_binary(actual)
    check_cutoff_range(cutoff)

    TP <- sum((predicted > cutoff) & (actual == 1))
    TN <- sum((predicted <= cutoff) & (actual == 0))
    FN <- sum((predicted <= cutoff) & (actual == 1))
    FP <- sum((predicted > cutoff) & (actual == 0))

    list(TP = TP, TN = TN, FP = FP, FN = FN)
}

##' @rdname confusion_matrix
##' @export
mtr_confusion_matrix <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    conf_mat <- matrix(numeric(4), ncol = 2,
                       dimnames = list(c("Positive", "Negative"),
                                       c("True", "False")))

    conf_mat["Positive", "True"] <- conf_list[["TP"]]
    conf_mat["Positive", "False"] <- conf_list[["FP"]]
    conf_mat["Negative", "True"] <- conf_list[["FN"]]
    conf_mat["Negative", "False"] <- conf_list[["TN"]]

    conf_mat
}

## True Positive Rate ----------------------------------------------------------

##' @title
##' True Positive Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name tpr
##' @export
mtr_tpr <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FN <- conf_list[["FN"]]
    FP <- conf_list[["FP"]]
    denominator <- TP + FN

    if (denominator == 0 && FP != 0) return(0)
    if (denominator == 0 && FP == 0) return(1)

    TPR <- TP / denominator
    TPR
}

##' @rdname tpr
##' @export
mtr_true_positive_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_hit_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_sensitivity <- mtr_tpr

##' @rdname tpr
##' @export
mtr_detection_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_recall <- mtr_tpr

## True Negative Rate ----------------------------------------------------------

##' @title
##' True Negative Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name tnr
##' @export
mtr_tnr <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TN <- conf_list[["TN"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]
    denominator <- TN + FP

    if (denominator == 0 && FN == 0) return(1)
    if (denominator == 0 && FN != 0) return(0)

    TNR <- TN / denominator
    TNR
}

##' @rdname tnr
##' @export
mtr_true_negative_rate <- mtr_tnr

##' @rdname tnr
##' @export
mtr_specificity <- mtr_tnr

##' @rdname tnr
##' @export
mtr_selectivity <- mtr_tnr

## False Negative Rate ---------------------------------------------------------

##' @title
##' False Negative Rate
##'
##' @inheritParams classification_params
##' @return A numeric output
##' @author An Chu
##' @name fnr
##' @export
mtr_fnr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_tnr(actual, predicted, cutoff = cutoff)
}

##' @rdname fnr
##' @export
mtr_miss_rate <- mtr_fnr

##' @rdname fnr
##' @export
mtr_false_negative_rate <- mtr_fnr

## False Positive Rate ---------------------------------------------------------

##' @title
##' False Positive Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name fpr
##' @export
mtr_fpr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_tnr(actual, predicted, cutoff = cutoff)
}

##' @rdname fpr
##' @export
mtr_fallout <- mtr_fpr

##' @rdname fpr
##' @export
mtr_false_alarm_rate <- mtr_fpr

##' @rdname fpr
##' @export
mtr_far <- mtr_fpr

##' @rdname fpr
##' @export
mtr_false_positive_rate <- mtr_fpr

## Accuracy --------------------------------------------------------------------

##' @title
##' Accuracy
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_balanced_accuracy}}
##' @author An Chu
##' @name acc
##' @export
mtr_accuracy <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    TN <- conf_list[["TN"]]

    accuracy <- (TP + TN) / Reduce(sum, conf_list)

    accuracy
}

##' @rdname acc
##' @export
mtr_ccr <- mtr_accuracy

## Misclassification Rate ------------------------------------------------------

##' @title
##' Misclassification rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_misclassification_rate <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_accuracy(actual, predicted, cutoff = cutoff)
}

## Balanced Accuracy -----------------------------------------------------------

##' @title
##' Balanced Accuracy
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_accuracy}}
##' @author An Chu
##' @export
mtr_balanced_accuracy <- function(actual, predicted, cutoff = 0.5) {

    sensitivity <- mtr_sensitivity(actual, predicted, cutoff = cutoff)
    specificity <- mtr_specificity(actual, predicted, cutoff = cutoff)

    (sensitivity + specificity) / 2
}

## Positive Predicted Value ----------------------------------------------------

##' @title
##' Positive Predicted Value
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name ppv
##' @author An Chu
##' @export
mtr_ppv <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    denominator <- TP + FP

    if (denominator == 0) return(0)

    PPV <- TP / (TP + FP)
    PPV
}

##' @rdname ppv
##' @export
mtr_positive_predicted_value <- mtr_ppv

##' @rdname ppv
##' @export
mtr_precision <- mtr_ppv

## Average Precision -----------------------------------------------------------

##' @title
##' Average Precision
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_average_precision <- function(actual, predicted) {

    ## keep distinct index of prediction and truth  vector
    ordering <- order(predicted)
    thresholds <- predicted[ordering]
    predicted <- predicted[ordering]
    actual <- actual[ordering]

    precision <- map_dbl(thresholds, function(x) mtr_precision(actual, predicted, x))
    recall <- map_dbl(thresholds, function(x) mtr_recall(actual, predicted, x))

    avg_prec <- sum(diff(recall) * precision[-1], na.rm = TRUE) * (-1)
    avg_prec
}

## False Discovery Rate --------------------------------------------------------

##' @title
##' False Discovery Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name fdr
##' @author An Chu
##' @export
mtr_fdr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_ppv(actual, predicted, cutoff = cutoff)
}

##' @rdname fdr
##' @export
mtr_false_discovery_rate <- mtr_fdr

## Negative Predicted Value ----------------------------------------------------

##' @title
##' Negative Predicted Value
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name npv
##' @author An Chu
##' @export
mtr_npv <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TN <- conf_list[["TN"]]
    FN <- conf_list[["FN"]]
    denominator <- TN + FN

    if (denominator == 0) return(0)

    NPV <- TN / (TN + FN)
    NPV
}

##' @rdname npv
##' @export
mtr_negative_predicted_value <- mtr_npv

## False Omission Rate ---------------------------------------------------------

##' @title
##' False Omission Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name for
##' @author An Chu
##' @export
mtr_for <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_npv(actual, predicted, cutoff = cutoff)
}

##' @rdname for
##' @export
mtr_false_omission_rate <- mtr_for

## F1 Score --------------------------------------------------------------------

##' @title
##' F1 Score
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_fbeta_score}}
##' @author An Chu
##' @export
mtr_f1score <- function(actual, predicted, cutoff = 0.5) {

    precision <- mtr_precision(actual, predicted, cutoff = cutoff)
    recall <- mtr_recall(actual, predicted, cutoff = cutoff)
    f1score <- (2 * precision * recall) / (precision + recall)

    f1score
}

## F-beta Score ----------------------------------------------------------------

##' @title
##' F-beta Score
##'
##'
##' @param beta \code{[numeric]} To be filled
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_f1score}}
##' @author An Chu
##' @export
mtr_fbeta_score <- function(actual, predicted, cutoff = 0.5, beta = 1) {

    precision <- mtr_precision(actual, predicted, cutoff = cutoff)
    recall <- mtr_recall(actual, predicted, cutoff = cutoff)
    fbeta <- (1 + beta^2) * ((precision * recall) / (beta^2 * precision + recall))

    fbeta
}

## Fowlkes-Mallows Index -------------------------------------------------------

##' @title
##' Fowlkes-Mallows Index
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name gscore
##' @export
mtr_gscore <- function(actual, predicted, cutoff = 0.5) {

    conf_list = confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]
    gscore <- sqrt((TP / (TP + FP)) * (TP / (TP + FN)))

    gscore
}

##' @rdname gscore
##' @export
mtr_fowlkes_mallows <- mtr_gscore

## Prevalence ------------------------------------------------------------------

##' @title
##' Prevalence
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_prevalence <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FN <- conf_list[["FN"]]
    prevalence <- (TP + FN) / Reduce(sum, conf_list)

    prevalence
}

##' @title
##' Detection Prevalence
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_detection_prevalence <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)
    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    dec_pre <- (TP + FP) / Reduce(sum, conf_list)

    dec_pre
}

## KS statistic ----------------------------------------------------------------

##' @title
##' KS Statistic
##'
##' @description
##'
##' Kolmogorov–Smirnov statistic quantifies a distance between the empirical
##' distribution function of the sample and the cumulative distribution function
##' of the reference distribution.
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_ks_statistic <- function(actual, predicted) {

    descending <- order(predicted, decreasing = TRUE)
    actual <- actual[descending]
    predicted <- predicted[descending]

    bins <- 10                          # this is arbitrary
    len <- length(actual)
    n <- len %/% bins        # number of obs per bin

    group_index <- rep(1:(bins - 1), each = n)
    group_index <- append(group_index, rep(bins, len - length(group_index)))

    perct_pos <- tapply(actual, group_index, function(x) sum(x == 1)) / sum(actual == 1)
    perct_neg <- tapply(actual, group_index, function(x) sum(x == 0)) / sum(actual == 0)

    max(cumsum(perct_pos) - cumsum(perct_neg))
}

## Informedness ----------------------------------------------------------------

##' @title
##' Informedness
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name yindex
##' @export
mtr_informedness <- function(actual, predicted, cutoff = 0.5) {

    sensitivity <- mtr_sensitivity(actual, predicted, cutoff = cutoff)
    specificity <- mtr_specificity(actual, predicted, cutoff = cutoff)

    sensitivity + specificity - 1
}

##' @rdname yindex
##' @export
mtr_youden_index <- mtr_informedness

## Markedness ------------------------------------------------------------------

##' @title
##' Markedness
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_markedness <- function(actual, predicted, cutoff = 0.5) {

    ppv <- mtr_positive_predicted_value(actual, predicted, cutoff = cutoff)
    npv <- mtr_negative_predicted_value(actual, predicted, cutoff = cutoff)

    ppv + npv - 1
}

## Matthews Correlation Coefficient --------------------------------------------

##' @title
##' Matthews Correlation Coefficient
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_matthews_corr_coef <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)
    TP <- conf_list[["TP"]]
    TN <- conf_list[["TN"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]

    denom1 <- TP + FP
    denom2 <- TP + FN
    denom3 <- TN + FP
    denom4 <- TN + FN

    if (denom1 == 0 || denom2 == 0 || denom3 == 0 || denom4 == 0) return(NA_real_)

    mcc <- ((TP * TN) - (FP * FN)) / sqrt(prod(denom1, denom2, denom3, denom4))
    mcc
}

## Hamming Loss ----------------------------------------------------------------

mtr_hamming_loss <- function(actual, predicted, cutoff = 0.5) {

}

## Hinge Loss ------------------------------------------------------------------

mtr_hinge_loss <- function(actual, predicted, cutoff = 0.5) {

}

## Jaccard Score ---------------------------------------------------------------

mtr_jaccard_score <- function(actual, predicted, cutoff = 0.5) {

}


setabc <- function(f, fb, sr) {
  pit = pi/sr
  r = exp(-pit*fb)
  coefs = c(0,0,0)
  coefs[3] = -r * r
  coefs[2] = 2*r*cos(2*pit*f)
  coefs[1] = 1 - coefs[2] - coefs[3]
  if (f < 0.0) {
    coefs[1] = 1 / coefs[1]
    coefs[2] = -coefs[1] * coefs[2]
    coefs[3] = -coefs[1] * coefs[3]
  }
  return(coefs)
}

res <- function(x,f,fb,sr) {
  cf = setabc(f,fb,sr)
  m1 = 0
  m2 = 0
  y = x
  if (f >= 0) {
    for (j in 1:length(x)) {
      y[j] = x[j]*cf[1] + m1*cf[2] + m2*cf[3]
      m2 = m1
      m1 = y[j]
    }
  } else {
    for ( j in 1:length(x)) {
      y[j] = x[j]*cf[1] + m1*cf[2] + m2*cf[3]
      m2 = m1
      m1 = x[j]
    }
  }
  return(y)
}


                      #### Clark and West test 2007 ####

#Before simulating MC I have to set the coefficients of the simulated regressions to predefined values.
#All this values are given/calculated by given numbers in paper by Paye.

#Set the coefficients to prespecified values..
const2=0.27
coef_ar1_x=0.60
unconexp_x=const2/(1-coef_ar1_x)

#Set the autoregresseive coefficients to predetermined values.
const1=-0.61
coef_ar1_y=0.52
coef_ar2_y=0.22
unconexp_y=(const1+unconexp_x)/(1-coef_ar1_y-coef_ar2_y)

# To generate the error terms one need to specify the variances/std.dev of error terms.
var_et=0.092
var_vt=0.160
cov_et_vt=0.026
corr_et_vt=cov_et_vt/sqrt(var_et*var_vt)

# Generate the distribution according to standard normal distribution. I set n=2000
set.seed(123456)
zt1<-rnorm(2000,0,1)
zt2<-rnorm(2000,0,1)

et<-zt1*sqrt(var_et)
vt<-(zt1*corr_et_vt+zt2*sqrt(1-corr_et_vt))*sqrt(var_vt)

#For loop inside the prediction/estimation
set.seed(123456)
wndw = 20 #number of observations for the in-sample (estimation) analysis.
T = 120  #number of observations for the out-of-sample (forecast) analysis.
y <- matrix(NA, 2000,10000)  #Randomly generated dependent variable matrix.
y_sample <- matrix(NA,T+wndw,10000) #creating a matrix which incorporates both in-sample and out-of-sample analysis osbervations: T+wndw=150 observations.
x <-matrix(NA,2000,10000)
x_sample <-matrix(NA,T+wndw,10000)

for (ii in 1:10000) {
  # Generate first two datapoints
  y[1,ii] <- unconexp_y
  y[2,ii] <- 1
  x[1,ii] <-unconexp_x
  x[2,ii] <-1
  #randomly generate the rest of the data for indep.var. starting from the third obs.
  for (tt in 3:2000) {
    x[tt,ii] = const2+coef_ar1_x*x[tt-1,ii]+rnorm(1)*sqrt(var_vt)
    y[tt,ii] = const1 + coef_ar1_y*y[tt-1,ii] + coef_ar2_y*y[tt-2,ii] + rnorm(1)*sqrt(var_et)
  }
  #Select last 150 observations for later in- and out-of-sample analysis and assign them to predefined y_sample matrix.
  y_sample[,ii] <- y[(2000 - wndw - T + 1) : 2000, ii]
  x_sample[,ii] <- x[(2000 - wndw - T + 1) : 2000, ii]
}

# Estimate model on rolling window
prediction <- matrix(NA,T+wndw,10000) #create an empty matrix later to be filled by forecasting values. First 20 observations are not gonna be used, only T=120 observations are used.
losses<-matrix(NA,T+wndw,10000) #This command generates a matrix for the forecast errors where it is calculated by subtracting actual generated data from the forecasted values.
losses_sqr<-matrix(NA,T+wndw,10000) #This command generates a matrix for the forecast error squares where it is calculated by taking the square of 'losses' series.
prediction4 <- matrix(NA,T+wndw,10000)
losses4<-matrix(NA,T+wndw,10000)
losses4_sqr<-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  for (kk in wndw:(T+wndw-1)) {
    # estimate with data from (kk-wndw+1) : kk.Model is defined as AR(2) model and estimated with linear regression.
    fit2<-lm(y_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y_sample[(kk-wndw+1): kk,ii],2))
    #Forecasts are obtained by extracting the coefficients from the regression model of AR(2).
    prediction[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y_sample[kk,ii]+fit2$coefficients[3]*y_sample[kk-1,ii]
    #Forecast errors are the difference between the actual and predicted(forecast) values.
    losses[kk+1,ii] <- y_sample[kk+1,ii] - prediction[kk+1,ii]
    losses_sqr[kk+1,ii] <- (y_sample[kk+1,ii] - prediction[kk+1,ii])^2

    fit<-lm(y_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y_sample[(kk-wndw+1): kk,ii],2)+dplyr::lead(x_sample[(kk-wndw+1): kk,ii]))
    prediction4[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y_sample[kk,ii]+fit$coefficients[3]*y_sample[kk-1,ii]+fit$coefficients[4]*x_sample[kk,ii]
    losses4[kk+1,ii] <- y_sample[kk+1,ii] - prediction4[kk+1,ii]
    losses4_sqr[kk+1,ii] <- (y_sample[kk+1,ii] - prediction4[kk+1,ii])^2

  }
}

adj_term1<-matrix(NA,T+wndw,10000)
adj_term1<-(prediction-prediction4)^2

cw_stats1<-matrix(NA,T+wndw,10000)
cw_stats1<-(losses_sqr-losses4_sqr+adj_term1)*100

count<-matrix(NA,1,10000)

for (ii in 1:10000) {
  cw_stats1_eq<-lm(cw_stats1[21:140,ii]~1)
  if (summary(cw_stats1_eq)$coefficients[1, 4]<0.10){
    count[,ii]=1
  }else{
    count[,ii]=0
  }
}

#This code calculates the analysis percentage of rejection rates (at 10% sign. level)
#over 10000 simulated samples. The test is based on Clark and West (2007) test.

CW_test_stats1<-100*(rowSums(count)/10000)

#Here I am simulating from the model that sets the coefficient for the xt-1 variable (new variable) to zero.
#Therefore, I create a new variable called x.
wndw = 20
T = 120
set.seed(123456)

#Set the coefficients to prespecified values
const2=0.27
coef_ar1_x=0.60
unconexp_x=const2/(1-coef_ar1_x)

#Set the autoregresseive coefficients to predetermined values.
const1=-0.61
coef_ar1_y=0.52
coef_ar2_y=0.22
unconexp_y=(const1+unconexp_x)/(1-coef_ar1_y-coef_ar2_y)

# To generate the error terms one need to specify the variances/std.dev of error terms.
var_et=0.092
var_vt=0.160
cov_et_vt=0.026
corr_et_vt=cov_et_vt/sqrt(var_et*var_vt)

# Generate the distribution according to standard normal distribution. I set n=2000
set.seed(123456)
zt1<-rnorm(2000,0,1)
zt2<-rnorm(2000,0,1)

et<-zt1*sqrt(var_et)
vt<-(zt1*corr_et_vt+zt2*sqrt(1-corr_et_vt))*sqrt(var_vt)

#For loop inside the prediction/estimation
set.seed(123456)
wndw = 20
T = 120
y2 <- matrix(NA, 2000,10000)
y2_sample <- matrix(NA,T+wndw,10000)
x <-matrix(NA,2000,10000)
x_sample <-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  # Generate datapoints
  y2[1,ii] <- unconexp_y
  y2[2,ii] <- 1
  x[1,ii] <-unconexp_x
  x[2,ii] <-1
  for (tt in 3:2000) {
    x[tt,ii] = const2+coef_ar1_x*x[tt-1,ii]+rnorm(1)*sqrt(var_vt)
    y2[tt,ii] = const1 + coef_ar1_y*y2[tt-1,ii] + coef_ar2_y*y2[tt-2,ii] +0.09*x[tt-1,ii]+ rnorm(1)*sqrt(var_et)
  }
  y2_sample[,ii] <- y2[(2000 - wndw - T + 1) : 2000, ii]
  x_sample[,ii] <- x[(2000 - wndw - T + 1) : 2000, ii]
}

# Estimate model on rolling window
prediction2 <- matrix(NA,T+wndw,10000)
losses2<-matrix(NA,T+wndw,10000)
losses2_sqr<-matrix(NA,T+wndw,10000)
prediction4 <- matrix(NA,T+wndw,10000)
losses4<-matrix(NA,T+wndw,10000)
losses4_sqr<-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  for (kk in wndw:(T+wndw-1)) {
    # estimate with data from (kk-wndw+1) : kk
    fit<-lm(y2_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y2_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y2_sample[(kk-wndw+1): kk,ii],2)+dplyr::lead(x_sample[(kk-wndw+1): kk,ii]))
    prediction2[kk+1,ii]<-fit$coefficients[1]+fit$coefficients[2]*y2_sample[kk,ii]+fit$coefficients[3]*y2_sample[kk-1,ii]+fit$coefficients[4]*x_sample[kk,ii]
    losses2[kk+1,ii] <- y2_sample[kk+1,ii] - prediction2[kk+1,ii]
    losses2_sqr[kk+1,ii] <- (y2_sample[kk+1,ii] - prediction2[kk+1,ii])^2
    fit2<-lm(y2_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y2_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y2_sample[(kk-wndw+1): kk,ii],2))
    prediction4[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y2_sample[kk,ii]+fit$coefficients[3]*y2_sample[kk-1,ii]
    losses4[kk+1,ii] <- y2_sample[kk+1,ii] - prediction4[kk+1,ii]
    losses4_sqr[kk+1,ii] <- (y2_sample[kk+1,ii] - prediction4[kk+1,ii])^2
  }
}

#...

adj_term1<-matrix(NA,T+wndw,10000)
adj_term1<-(prediction2-prediction4)^2

cw_stats1<-matrix(NA,T+wndw,10000)
cw_stats1<-(losses2_sqr-losses4_sqr+adj_term1)*100

count<-matrix(NA,1,10000)

for (ii in 1:10000) {
  cw_stats1_eq<-lm(cw_stats1[21:140,ii]~1)
  if (summary(cw_stats1_eq)$coefficients[1, 4]<0.10){
    count[,ii]=1
  }else{
    count[,ii]=0
  }
}

#This code calculates the analysis percentage of rejection rates (at 10% sign. level)
#over 10000 simulated samples. The test is based on Clark and West (2007) test.
CW_test_stats2<-100*(rowSums(count)/10000)


 ZGEEVX Example Program Results

 Eigenvalues

          Eigenvalue           rcond    error
  1 (-6.0004E+00,-6.9998E+00)  0.9932  3.2E-15
  2 (-5.0000E+00, 2.0060E+00)  0.9964  3.2E-15
  3 ( 7.9982E+00,-9.9637E-01)  0.9814  3.3E-15
  4 ( 3.0023E+00,-3.9998E+00)  0.9779  3.3E-15

 Eigenvectors

          Eigenvector          rcond    error

  1 ( 8.4572E-01, 0.0000E+00)  8.4011    -
    (-1.7723E-02, 3.0361E-01)
    ( 8.7521E-02, 3.1145E-01)
    (-5.6147E-02,-2.9060E-01)

  2 ( 3.8655E-01,-1.7323E-01)  8.0214    -
    ( 3.5393E-01,-4.5288E-01)
    (-6.1237E-01,-0.0000E+00)
    ( 8.5928E-02, 3.2836E-01)

  3 ( 1.7297E-01,-2.6690E-01)  5.8292    -
    (-6.9242E-01,-0.0000E+00)
    (-3.3240E-01,-4.9598E-01)
    (-2.5039E-01, 1.4655E-02)

  4 ( 3.5614E-02, 1.7822E-01)  5.8292    -
    (-1.2637E-01,-2.6663E-01)
    (-1.2933E-02, 2.9657E-01)
    (-8.8982E-01,-0.0000E+00)

 Errors below 10*machine precision are not displayed


# treeEnsembles.r
# MWL, Lecture 2
# Author(s): [Phil Snyder]

"
An ensemble is a predictor that obtains its predictions by taking a weighted average of multiple
single predictors. We will look at three different types of tree-based ensembles: bagging,
random forests, and boosting with trees. Both random forests and boosting are methods
used in industry every day - and can be very powerful predictors.
"

library("ElemStatLearn")
data("spam")

partition <- sample(nrow(spam), floor(0.7 * nrow(spam)))
trainData <- spam[partition,]
testData <- spam[-partition,]

# Bagging

"
Bagging is a portmanteau of 'bootstrap aggregation'. 'Bootstrap' is a sampling method where you
sample from a data set *with replacement*. Usually your sample size is equivalent to the size of
the original data set. 'Aggregation' refers to the fact that we are aggregating or averaging the
predictors (in the case of classification, by having them take a vote on the class) trained on
our bootstrap samples. Typically bagging only helps in the case of high variance predictors (such
as decision trees) because it reduces variance while maintaining bias (again, see bias-variance
trade-off). More info available in [ESL 8.7].
"

#install.packages("ipred")
library("ipred")
bagg <- bagging(spam ~ ., trainData, nbagg=50) # 50 trees
# Of course, normally we would do CV to find the optimal parameters
# (implicit here are the rpart parameters)
baggPredictions <- predict(bagg, testData)
baggResults <- table(baggPredictions == testData$spam) / length(baggPredictions)
baggResults # (approx.) TRUE: 0.924, FALSE: 0.0760

# Random Forests

"
Random Forests are similar to bagging, except each tree is only trained on a random subset of the
dimensions of the original dataset. For example, if our data had dimensions V1, ..., V10
we might train the first tree on dimensions V1, V4, V8 and our second tree on V2, V4, V5, etc.
We do this so that our individual trees become less *correlated*. The correlation between trees
limits how good of a predictor we may obtain by averaging their individual predictions. You
may also think of the individual trees in a random forest as being 'experts' in a specific domain.
The more limited the domain of the expert, the deeper and more refined the experts knowledge becomes
in that domain. For more info see [ESL 15].
"

#install.packages("randomForest")
library("randomForest")
rf <- randomForest(spam ~ ., trainData, ntree=80) # 80 trees trained on random dimensions
# in classification, by default we randomly select m = floor(sqrt(p)) dimensions to train on
# where p is the # of dimensions in our original dataset.
rfPredictions <- predict(rf, testData)
rfResults <- table(rfPredictions == testData$spam) / length(rfPredictions)
rfResults # (approx.) TRUE: 0.945, FALSE: 0.055

"
This is our best predictor yet, though random forests have their limits. If the dimensions
of our data have very little to do with how the class is determined, then it's likely many of
the trees will make decisions based on useless information, adding noise to our predictions.
"

# Boosting

"
Here we will do boosting with decision trees, though it is possible to do boosting with different
predictors. The general idea behind boosting is that each data point in the training set is given
a weight. At first these weights are all equal. We then fit a tree to the train data. For every data
point that the tree classifies incorrectly, we increase its weight. We then fit a second tree
to the data. The second tree gives the data points with greater weight greater importance, and is
less likely to classify them incorrectly. The process then repeats, iterating sequentially through
each dimension. This will perhaps become more clear when we talk about loss/objective
functions. For more info see [ESL 10].
"

#install.packages("adabag")
library("adabag")
boost <- boosting(spam ~ ., trainData, mfinal=100) # 100 boosted trees
boostPredictions <- predict(boost, testData)
boostPredictions$error # proportion incorrect

"
Boosting is a powerful idea, and we will generalize it to other predictors later.

You may have noticed that it took a fair amount of time to fit our models to the data. This is
where the 'computer science' portion of machine learning comes into play. The most powerful
predictors (usually ensembles, or various forms of neural nets, or both) can take days to train,
even with extreme computational optimization. Next lecture we will take a closer look at the
optimization of our model parameters as well as some more archetypical concepts in machine learning.
"


data <- read.csv(file="UrbanaData.csv",header = TRUE)
depot <- c(40.117844, -88.199203)

data$LAT <- (data$LAT-depot[1])*111.7
data$LON <- (data$LON-depot[2])*111.7*cos(40.1/360*2*pi)

plot(data$LON, data$LAT)
points(0, 0, col = "red")
n <- length(data$LON)
x <- cbind(data$LON, data$LAT)
d <- matrix(0, nrow = n, ncol = n)
for (i in 1:n)
  for (j in 1:n)
  {
    d[i, j] = abs(x[i,1]-x[j,1])+abs(x[i,2]-x[j,2])
  }

r <- abs(data$LON)+abs(data$LAT)
alpha <- atan(data$LAT/data$LON)
alpha <- ifelse(data$LAT<0 & data$LON<0, alpha-pi, alpha)
alpha <- ifelse(data$LAT>0 & data$LON<0, alpha+pi, alpha)
dmdori = data$Pop*4.4*7
dmd = qnorm(0.95, mean = data$Pop*4.4*7, sd = data$Pop*4.4*7*0.1)

p <- as.data.frame(cbind(data$BID, x, r, alpha, dmd))
colnames(p) <- c("id","lon","lat","r","alpha","demand")
plot(p$r, p$demand)
plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)
high <- which(p$demand>=10000)
mid <- which(p$demand>=5000 & p$demand<10000)
points(p$lon[high], p$lat[high], col = "green")
points(p$lon[mid], p$lat[mid], col = "blue")

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

searchnode <- function(x, conn, node, N)
{
  for (j in 1:N)
    if (conn[x, j]==1)
    {
      if (node[j]==FALSE) return(j)
    }
  return(0)
}

renode <- function(x, dist, node)
{
  l <- order(dist[x, ], decreasing = FALSE)
  for (j in l)
    if (node[j]==FALSE) return(j)
}

getsolu <- function(ppp, mark)
{
  print(mark)
  x <- c(0, ppp$lon)
  y <- c(0, ppp$lat)
  N <- length(x)
  dot <- cbind(x, y)
  #creating dist matrix for dist(i,j)
  dist <- matrix(0, nrow = N, ncol = N)
  for (i in 1:N)
    for (j in 1:N)
    {
      dist[i, j] = abs(x[i]-x[j])+abs(y[i]-y[j])
    }

  # use prim algorithm to find MST, set point 1 as the start point
  conn <- matrix(0, nrow = N, ncol = N) # if city i & j are connected
  cost <- dist[1,] #distance from the tree to other nodes
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  father <- c(NA, rep(1, N-1))

  for (i in 1:(N-1))
  {
    newdist <- Inf
    for (j in 1:N)
    {
      #find a new node to join
      if (node[j]==FALSE & cost[j]<newdist)
      {
        newnode <- j
        newdist <- cost[j]
      }
    }
    node[newnode] <- TRUE
    conn[father[newnode], newnode] <- 1
    conn[newnode, father[newnode]] <- 1
    #update the cost and father using node j
    for (k in 1:N)
    {
      if (node[k]==FALSE & dist[newnode, k]<cost[k])
      {
        cost[k] = dist[newnode, k]
        father[k] = newnode
      }
    }
  }

  lstt <- c()
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  front <- 1
  totd <- 0
  for (i in 1:(N-1))
  {
    tail<- searchnode(front, conn, node, N)
    if (tail==0) {tail <- renode(front, dist, node)}
    lstt <- c(lstt, mark[tail-1])
    node[tail] <- TRUE
    if (i!=1)
    {segments(x[front], y[front], x[tail], y[tail], col = 2, lwd = "1")}
    totd <- totd+dist[front, tail]
    front <- tail
  }
  totd <- totd+dist[1, tail]
  print(lstt)
  #segments(x[1], y[1], x[tail], y[tail], col = "red", lwd = "1")
  return(c(totd, lstt))
}

########################3333
plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)

ctg <- rep(0, n)
flag <- 1
tmp <- 0
pp <- p[order(p$alpha, decreasing = TRUE),]
#create data in the form suitable for Simulated Anealing
write.csv(pp, file="SA.csv")
lstt <- c()
for (i in 1:n)
{
  #i <- i+1
  if (tmp+pp$demand[i]>60000)
  {
    if (flag==1)
    {
      sol <- getsolu(pp[which(ctg==flag),], which(ctg==flag))
      solu <- sol[1]
      lstt <- sol[2:length(sol)]
    } else {
      sol <- c(getsolu(pp[which(ctg==flag),], which(ctg==flag)))
      solu <- c(solu, sol[1])
      lstt <- c(lstt, sol[2:length(sol)])
    }
    lstt <- c(lstt, flag+n)
    lines(c(0, pp$lon[i-1]*10), c(0, pp$lat[i-1]*10))
    flag <- flag+1
    tmp <- pp$demand[i]
    lines(c(0, pp$lon[i-1]*10), c(0, pp$lat[i-1]*10))

  } else {
    tmp <- tmp+pp$demand[i]
  }
  ctg[i] <- flag
}
lines(c(0, pp$lon[n]*10), c(0, pp$lat[n]*10))
sol <- c(getsolu(pp[which(ctg==flag),], which(ctg==flag)))
solu <- c(solu, sol[1])
lstt <- c(lstt, sol[2:length(sol)])
solu <- solu*0.621371

final <- data.frame(
  routelength = solu,
  demandpoint = sapply(1:flag, function(i) length(which(ctg==i))),
  totaldemand = sapply(1:flag, function(i) sum(pp$demand[which(ctg==i)]))
)
sum(final$routelength)

#####Cost Computation ##############33

cost <- (sum(solu)/25+sum(dmd)/5000/6)*15+
1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)+
0.2*(n+20)

cc <- rep(1,n)
cc <- ifelse(dmd>5000 & dmd<=10000, 5, cc)
cc <- ifelse(dmd>10000, 25, cc)
print(sum(cc*dmd)/5000)
print(sum(cc*p$demand)/5000+cost)

#provide initial solution for Simulated Anealing
write.table(t(as.matrix(lstt)), "ini2.txt")


### kClass: Generates k-class estimators (point est, se, p-value, and confint)
###         Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        k, a vector (or scalar) of k values for estimation
###        beta0, a vector (or scalar) of null values for testing and p-values
###        alpha, significance level for confidence intervals
###        heteroSE, use heteroscedastic robust standard errors?
###        clusterID, if cluster-robust standard errors are desired, please provide a vector of
###                   length that's identical to the sample size.
###                   For example, if n = 6 and clusterID = c(1,1,1,2,2,2),
###                   there would be two clusters where the first cluster
###                   is formed by the first three observations and the
###                   second cluster is formed by the last three observations
###                   clusterID can be numeric, character, or factor.
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
KClass = function(ivmodel,
                  beta0=0,alpha=0.05,k=c(0,1),
                  manyweakSE=FALSE,heteroSE=FALSE,clusterID=NULL) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("You must supply an ivmodel class. Run ivmodel() and see ivmodel() function for details")
    return(NULL)
  }
  if(missing(k)) {
    print("You must specify a value for k")
    return(NULL)
  }

  # Extract objects from ivmodel
  Yadj = ivmodel$Yadj; Dadj =ivmodel$Dadj; Zadj = ivmodel$Zadj; ZadjQR = ivmodel$ZadjQR
  degF = ivmodel$n - ivmodel$p - 1 # this looks strange, but it's from Wooldridge and Stock (2002)

  # Compute k-class estimator
  denom = (sum(Dadj^2) - k * sum(qr.resid(ZadjQR,Dadj)^2))
  kPointEst = (sum(Yadj * Dadj) - k * sum(Yadj * qr.resid(ZadjQR,Dadj))) / denom

  # Compute std error, testStat, and confidence intervals
  kVarPointEst = rep(0,length(k))
  kCI = matrix(0,length(k),2)
  for(i in 1:length(k)) {
    if(denom[i] <= 0) { #k exceeds the maximum possible value
	  kVarPointEst[i] = NA; kCI[i,] = c(NA,NA)
    } else {
        if (manyweakSE && k[i] != 0) { ## From Hansen et al. (2008)
            alpha <- - (1 - k[i])/k[i]
            H <- sum((Dadj - qr.resid(ZadjQR,Dadj))^2) - alpha * sum(Dadj^2)
            u <- Yadj - Dadj * kPointEst[i]
            D.tilde <- Dadj - u * sum(u  * Dadj) / sum(u^2)
            sigmaB <- sum(u^2) / degF * ( (1 - alpha)^2 * (sum(D.tilde^2) - sum(qr.resid(ZadjQR, D.tilde)^2)) + alpha^2 * sum(qr.resid(ZadjQR, D.tilde)^2) )
            Q <- qr.Q(ZadjQR)[, 1:ivmodel$L]
            P.diag <- apply(Q * Q, 1, sum)
            Dfitted <- Dadj - qr.resid(ZadjQR, Dadj)
            kappa <- sum(P.diag^2)/ivmodel$L
            tau <- ivmodel$L/ivmodel$n
            A <- sum((P.diag - tau) * Dfitted) * mean(u^2 * qr.resid(ZadjQR, D.tilde))
            B <- ivmodel$L * (kappa - tau) * sum((u^2 - sum(u^2) / degF) * qr.resid(ZadjQR, D.tilde)^2) / (ivmodel$n * (1 - 2 * tau + kappa * tau))
            kVarPointEst[i] = (sigmaB + 2 * A + B) / H^2
        } else if (heteroSE || (manyweakSE &&k[i] == 0)) {
	    kVarPointEst[i] = ivmodel$n/degF * sum( (Yadj - Dadj * kPointEst[i])^2 * (Dadj - k[i]*qr.resid(ZadjQR,Dadj))^2 ) / (denom[i])^2
	  } else if(!is.null(clusterID)){
	  	if(length(clusterID) != ivmodel$n) {
	  		### Missing problem here needs to be taken care of ###
	  		print("Cluster ID vector is not the same length as the sample size")
	  		return(NULL)
	  	}
	  	if(!is.character(clusterID) && !is.factor(clusterID) && !is.numeric(clusterID)) {
	  		print("Cluster ID must be either a character vector, a factor vector, or a numeric vector")
	  		return(NULL)
	  	}
	  	clusterID = as.factor(clusterID)
	  	clusterID = as.numeric(clusterID)
	  	nCluster <- length(unique(clusterID))
        dfc <- nCluster/(nCluster-1)*(ivmodel$n-1)/degF
        residFit = Yadj - Dadj * kPointEst[i]
        umat = tapply(residFit*(Dadj - k[i]*qr.resid(ZadjQR,Dadj)),clusterID, sum)
        kVarPointEst[i] = dfc * t(umat) %*% umat / denom[i]^2
	  }
	  else {
        kVarPointEst[i] = 1/(degF) *sum((Yadj - Dadj * kPointEst[i])^2) / denom[i]
	  }
	  # Note that R's AER package uses the z-scores instead of the t distribution. They are basically the same as n gets large.
	  kCI[i,] =  c(kPointEst[i] - qt(1-alpha/2,degF) * sqrt(kVarPointEst[i]),
	               kPointEst[i] + qt(1-alpha/2,degF) * sqrt(kVarPointEst[i]))
    }
  }

  # Compute test statistics
  # This operation takes a vector of k estimates (pointEst, k*1 dim) and
  # another vector of null values (beta0,1 * length(beta0))
  # and subtracts pointEst from a vector of null values.
  # The last operation of dividing by sqrt() is done column-wise
  # E.g. [1,2,3 ; 2,3,4] / (2,3,4) --> [0.5,2/3,0.75;1,1,1]
  kTestStat = outer(kPointEst,beta0,FUN="-") / sqrt(kVarPointEst)

  # Compute p-value
  kPValue = 2*(1 - pt(abs(kTestStat),degF))

  # Package output
  kPointEst = matrix(kPointEst,length(k),1)
  kVarPointEst = matrix(sqrt(kVarPointEst),length(k),1)
  rownames(kPointEst) = rownames(kVarPointEst) = rownames(kCI) = rownames(kPValue) = rownames(kTestStat) = k
  colnames(kPValue) = colnames(kTestStat) = beta0
  colnames(kPointEst) = "Estimate"
  colnames(kVarPointEst) = "Std. Error"
  colnames(kCI) = c(paste(as.character(round(alpha/2 * 100,1)),"%"),paste(as.character( round((1-alpha/2) * 100,1)),"%"))

  return(list(point.est = kPointEst,std.err = kVarPointEst,test.stat = kTestStat,p.value = kPValue,ci = kCI))
}


data <- read.csv(file="UrbanaData.csv",header = TRUE)
depot <- c(40.117844, -88.199203)

data$LAT <- (data$LAT-depot[1])*111.7
data$LON <- (data$LON-depot[2])*111.7*cos(40.1/360*2*pi)

plot(data$LON, data$LAT)
points(0, 0, col = "red")
n1 <- length(data$LON)
n2 <- length(data$LON)

r <- abs(data$LON)+abs(data$LAT)
alpha <- atan(data$LAT/data$LON)
alpha <- ifelse(data$LAT<0 & data$LON<0, alpha-pi, alpha)
alpha <- ifelse(data$LAT>0 & data$LON<0, alpha+pi, alpha)
dmdori = data$Pop*4.4*7
dmd = qnorm(0.95, mean = data$Pop*4.4*7, sd = data$Pop*4.4*7*0.1)

p <- as.data.frame(cbind(data$BID, x, r, alpha, dmd))
colnames(p) <- c("id","lon","lat","r","alpha","demand")
p$id <- rep(1:n1)
p$newid <- rep(1:n1)
p$spec <- rep(0,n1)
plot(p$r, p$demand, xlab = "Distance", ylab = "Demand")

plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)
high <- which(p$demand>=10000)
mid <- which(p$demand>=5000 & p$demand<10000)
points(p$lon[high], p$lat[high], col = "green", pch = 16)
points(p$lon[mid], p$lat[mid], col = "blue", pch = 16)
req <- matrix(0, nrow = n2, ncol = 5)

#############split points###################
for (i in high)
{
  req[i, 5] <- 1
  p$demand[i] <- p$demand[i]/5
  p$spec[i] <- 1
  newp <- p[i, ]
  newp$id[1] <- i
  for (j in 1:4)
  {
    n2 <- n2+1
    req <- rbind(req, rep(0, 5))
    req[n2, j] <- 1
    newp$newid[1] <- n2
    p <- rbind(p, newp)
  }
}

for (i in mid)
{
  req[i,] <- c(0, 1, 0, 0, 0)
  p$demand[i] <- p$demand[i]/2
  p$spec[i]<- 1
  newp <- p[i, ]
  newp$id[1] <- i

  n2 <- n2+1
  req <- rbind(req, rep(0, 5))
  req[n2, 4] <- 1
  newp$newid[1] <- n2
  p <- rbind(p, newp)
}

#data input for SA
write.table(p, "V2.csv")

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

searchnode <- function(x, conn, node, N)
{
  for (j in 1:N)
    if (conn[x, j]==1)
    {
      if (node[j]==FALSE) return(j)
    }
  return(0)
}

renode <- function(x, dist, node)
{
  l <- order(dist[x, ], decreasing = FALSE)
  for (j in l)
    if (node[j]==FALSE) return(j)
}

getsolu <- function(ppp, mark)
{
  #print(mark)
  x <- c(0, ppp$lon)
  y <- c(0, ppp$lat)
  N <- length(x)
  dot <- cbind(x, y)
  #creating dist matrix for dist(i,j)
  dist <- matrix(0, nrow = N, ncol = N)
  for (i in 1:N)
    for (j in 1:N)
    {
      dist[i, j] = abs(x[i]-x[j])+abs(y[i]-y[j])
    }

  # use prim algorithm to find MST, set point 1 as the start point
  conn <- matrix(0, nrow = N, ncol = N) # if city i & j are connected
  cost <- dist[1,] #distance from the tree to other nodes
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  father <- c(NA, rep(1, N-1))

  for (i in 1:(N-1))
  {
    newdist <- Inf
    for (j in 1:N)
    {
      #find a new node to join
      if (node[j]==FALSE & cost[j]<newdist)
      {
        newnode <- j
        newdist <- cost[j]
      }
    }
    node[newnode] <- TRUE
    conn[father[newnode], newnode] <- 1
    conn[newnode, father[newnode]] <- 1
    #update the cost and father using node j
    for (k in 1:N)
    {
      if (node[k]==FALSE & dist[newnode, k]<cost[k])
      {
        cost[k] = dist[newnode, k]
        father[k] = newnode
      }
    }
  }

  lstt <- c()
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  front <- 1
  totd <- 0
  for (i in 1:(N-1))
  {
    tail<- searchnode(front, conn, node, N)
    if (tail==0) {tail <- renode(front, dist, node)}
    lstt <- c(lstt, mark[tail-1])
    node[tail] <- TRUE
    if (i!=1)
    {segments(x[front], y[front], x[tail], y[tail], col = 2, lwd = "1")}
    totd <- totd+dist[front, tail]
    front <- tail
  }
  totd <- totd+dist[1, tail]
  #segments(x[1], y[1], x[tail], y[tail], col = "red", lwd = "1")
  print(totd)
  return(c(totd, lstt))
}
#################################
rangemust <- function(case, p)
{
  if (case==1)
  {
    tmp <- p$newid[which(p$alpha>=-pi & p$alpha<=-3*pi/4)]
    return(tmp)
  }
  if (case==2)
  {
    tmp <- p$newid[which(p$alpha>=-3*pi/4 & p$alpha<=-pi/4)]
    return(tmp)
  }
  if (case==3)
  {
    tmp <- p$newid[which(p$alpha>=-pi/4 & p$alpha<=pi/4)]
    return(tmp)
  }
  if (case==4)
  {
    tmp <- p$newid[which(p$alpha>=pi/4 & p$alpha<=pi)]
    return(tmp)
  }
}

rarange <- function(case, p)
{
  pp <- p
  if (case==1)
  {
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==2)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=-pi/2)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==3)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=0)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==4)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=pi/2)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
}

################# sweep ################
plot(p$lon, p$lat, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 16)

ctg <- rep(0, n2)
solu <- c()
lstt <- c()

rr<-0
newid <-c()
for (i in 1:5) #sweep for days
{
  for (j in 1:4) #sweep for tours in a day
  {
    flag <- (i-1)*4+j
    print("flag")
    print(flag)

    rg <- rangemust(j, p)
    must <- which((req[,i]==1) & (p$newid %in% rg))
    #points required to visit this tour, specified by newid
    ctg[must] <- flag
    newid <- c(newid, must)
    points(p$lon[must], p$lat[must], col = flag, pch = 16)
    pp <- rarange(j, p)
    tmp <- sum(p$demand[must])
    if (tmp>60000) {print("xxxxxx")}

    for (k in 1:n2)
    {
      if (ctg[pp$newid[k]]==0 & pp$spec[k]==0)
      {
        if (tmp+pp$demand[k]<=60000)
        {
          ctg[pp$newid[k]] <- flag
          tmp <- tmp+pp$demand[k]
          points(p$lon[pp$newid[k]], p$lat[pp$newid[k]], col = flag, pch = 16)
          newid <- c(newid, pp$newid[k])
        } else{
          break
        }
      }
    }
    rr <- rr+tmp
    sol <- getsolu(p[which(ctg==flag),], which(ctg==flag))
    solu <- c(solu, sol[1])
    lstt <- c(lstt, sol[2:length(sol)], flag+n2)
  }
}

solu <- solu*0.621371

final <- data.frame(
  routelength = solu,
  demandpoint = sapply(1:flag, function(i) length(which(ctg==i))),
  totaldemand = sapply(1:flag, function(i) sum(p$demand[which(ctg==i)]))
)
sum(final$routelength)

(sum(solu)/25+sum(p$demand)/5000/6)*15
1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)
0.2*(n2+20)

cost <- (sum(solu)/25+sum(dmd)/5000/6)*15+
  1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)+
  0.2*(n2+20)
#compute penalty
cc <- rep(1,n2)
cc <- ifelse(p$demand>5000 & p$demand<=10000, 5, cc)
cc <- ifelse(p$demand>10000, 25, cc)
print(sum(cc*p$demand)/5000)
print(sum(cc*p$demand)/5000+cost)

#initial solution for SA
write.table(t(as.matrix(lstt)), "sol2.txt")


#' Thanks John Quilty for providing this R script

#' Example R script to show the shift-invariancy and sensitivity to adding additional data points
#' when using VMD for to proivde inputs for operational forecasting tasks.
#' Note: run this script line by line instead of executing it in its entirety (as only the last plot
#' will be displayed in the latter case).
set.seed(123)
install.packages("EMD",repos = "http://cran.us.r-project.org")
install.packages("vmd",repos = "http://cran.us.r-project.org")
library(EMD) # this is so that we can use the sunspot series as a test case
library(vmd)
data("sunspot")
x <- sunspot$sunspot
###############################################################################################
#' CHECK 1: Is VMD shift-invariant?
#' If yes, any shifted copy of an IMF from a VMD decomposition, similar to a shifted copy of the
#' original time series, should be maintained.
#'
#' For example, given the sunspot time series x (of length 386) we can generate a 1-step
#' advanced copy of the original time series as follows:
#'
#' x0 = x[1:385]
#' x1 = x[2:386] # this is a 1-step advanced version of x0
#'
#' Obviously, shift-invariancy is preserved between x0 and x1 since x0[2:385] = x1[1:384]
#'
#'
#' For shift-invariancy to be preserved for VMD, we should observe, for example, that the
#' VMD IMF1 components for x0 (x0.IMF1) and x1 (x1.IMF1) should be exact copies of one another,
#' advanced by a single step.
#'
#' I.e., x0.IMF1[2:385] should equal x1.IMF1[1:384] if shift-invariancy is
#' preserved. However, this is not the case for VMD as shown below. Interestingly, we see
#' a high level of error at the boundaries of the time series, of high importance in
#' operational forecasting tasks.
###############################################################################################
# lag/advance sunspot data by 1-step
x0 = x[1:385]
x1 = x[2:386]
# perform VMD on both original and advanced time series
x0.vmd = vmd(x0)$getResult()$u # default settings
x1.vmd = vmd(x1)$getResult()$u # default settings
# plot IMF1 for x0.vmd and x1.vmd
plot(x0.vmd[2:385,1],type='l')
lines(x1.vmd[1:384,1],col='red')
# plot error (which should be a straight line of 0s if shift-invariancy was preserved)
err = x0.vmd[2:385] - x1.vmd[1:384]
plot(err)
# check the level of error (as measured by the mean square error) between the IMF components
mse = mean(err^2)
###############################################################################################
#' CHECK 2: The impact of appending data points to a time series then performing VMD, analogous
#' to the case in operational forecasting when new data becomes available and an updated forecast
#' is made using the newly arrived data.
#'
#' Ideally, for forecasting situations, when new data is appended to a time series an some pre-
#' processing is performed, it should not have an impact on previous measurements of the pre-
#' processed time series.
#'
#' For example, if IMF1_1:N represents the IMF1, which has N total measurements and was derived
#' by applying VMD to x_1:N then we would expect that when we perform VMD when x is appended with
#' another measurement, i.e., x_1:N+1, resulting in IMF1_1:N+1 that the first 1:N measurements in
#' IMF1_1:N+1 are equal to IMF1_1:N. In other words, IMF_1:N+1[1:N] = IMF1_1:N[1:N].
#'
#' Again, we see that this is not the case. Appending an additional observation to the time series
#' results in the updated VMD components to be entirely different then the original (as of yet
#' updated) VMD components. Interestingly, we see a high level of error at the boundaries of the
#' time series, of high importance in operational forecasting tasks.
###############################################################################################
# extend x with an additional measurement
x_1_385 = x[1:385]
x_1_386 = x[1:386]
# perform VMD on original and extended time series
x_1_385.vmd = vmd(x_1_385)$getResult()$u # default settings
x_1_386.vmd = vmd(x_1_386)$getResult()$u # default settings
# plot IMF1 for x_1_385.vmd and x_1_386.vmd
plot(1:386, x_1_386.vmd[1:386,1],type='l')
lines(1:385, x_1_385.vmd[1:385,1],col='red')
#' plot error (which should be a straight line of 0s if appending an additional observation has
#' no impact on VMD)
err.append = x_1_385.vmd[1:385] - x_1_386.vmd[1:385]
plot(err.append)
# check the level of error (as measured by the mean square error) between the IMF components
mse.append = mean(err.append^2)
# the problem gets exasperated if it is not a single time point that is updated, but several
x_1_300 = x[1:300]
# perform VMD on original and extended time series
x_1_300.vmd = vmd(x_1_300)$getResult()$u # default settings
# plot IMF1 for x_1_385.vmd and x_1_386.vmd
plot(1:386, x_1_386.vmd[1:386,1],type='l')
lines(1:300, x_1_300.vmd[1:300,1],col='red')
#' plot error (which should be a straight line of 0s if appending an additional observation has
#' no impact on VMD)
err.append.ext = x_1_300.vmd[1:300] - x_1_386.vmd[1:300]
plot(err.append.ext)
# check the level of error (as measured by the mean square error) between the IMF components
mse.append.ext = mean(err.append.ext^2)
# EOF


library(MASS)

computeWeightsWithStochasticGradient <- function(dset, classes, lossFunction, updateRule) {
  dsetLength <- dim(dset)[1]
  featuresCount <- dim(dset)[2]

  w <- runif(featuresCount, -1 / (2 * featuresCount), 1 / (2 * featuresCount))
  lambda <- 1 / dsetLength

  currentLoss <- 0
  for (i in 1:dsetLength) {
    margin <- sum(w * dset[i, ]) * classes[i]
    currentLoss <- currentLoss + lossFunction(margin)
  }
  prevLoss <- currentLoss

  step <- 1
  repeat {
    margins <- array(0, dim = dsetLength)
    for (i in 1:dsetLength) {
      margins[i] <- sum(w * dset[i, ]) * classes[i]
    }
    errorIndices <- which(margins <= 0)

    if (length(errorIndices) == 0) break

    randomErrorSampleIndex <- sample(errorIndices, 1)
    x <- dset[randomErrorSampleIndex, ]
    class <- classes[randomErrorSampleIndex]

    margin <- sum(w * x) * class
    loss <- lossFunction(margin)

    learningRate <- 1 / step
    w <- updateRule(w, learningRate, x, class)

    currentLoss <- (1 - lambda) * currentLoss + lambda * loss

    if (abs(prevLoss - currentLoss) / abs(max(prevLoss, currentLoss)) < 1e-5) break

    if (step > 25000) break

    prevLoss <- currentLoss
    step <- step + 1

    if (step == 10 || step == 50 || step == 100 || step == 500) {
      png(sprintf("sgd/astep-%03d.png", step), width = 700, height = 700, unit = "px", pointsize = 20)
      # cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
      #index <- index + 1

      #loo <- parzen_loo(iris[3:4], iris$Species, kernel, hs)
      #plot(hs, loo, type="l", xlab="h", ylab="LOO")
      #points(hs[which.min(loo)], loo[which.min(loo)], pch = 19, col = "red")
      #text(hs[which.min(loo)], loo[which.min(loo)] + 0.05, paste("best:", hs[which.min(loo)]))

      plot(dset[ ,1], dset[ ,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(gdset[ ,3])])
      drawLine(w, "darkgreen")
      #cat("\rDone.                      \n")
      dev.off()
    }
  }
  gsteps <<- gsteps+step
  # print(step)
  # Thanks, T. Orlova!
  return(w)
}

adalineLossFunction <- function(margin) (margin - 1) ^ 2

adalineUpdateRule <- function(w, learningRate, sample, class) w - learningRate * (sum(w * sample) - class) * sample

hebbLossFunction <- function(margin) max(-margin, 0)

hebbUpdateRule <- function(w, learningRate, sample, class) w + learningRate * sample * class

drawLine = function(w, color) {
  abline(a = w[3] / w[2], b = -w[1] / w[2], lwd = 2, col = color)
}

iterationsCount <- 100

gsteps <- 0
errorsCount <- 0

for (iter in 1:iterationsCount) {
  cat("\rIteration: ", iter)
  mu1 <- c(0, 0)
  mu2 <- c(4, 4)
  sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
  sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
  dset1 <- mvrnorm(250, mu1, sig1)
  dset2 <- mvrnorm(250, mu2, sig2)
  dset <- rbind(cbind(dset1, 1),cbind(dset2, -1))
  dset <- cbind(dset, -1)
  gdset <- dset

  w1 = computeWeightsWithStochasticGradient(dset[, c(1, 2, 4)], dset[, 3], adalineLossFunction, adalineUpdateRule)

  for (i in 1:dim(dset)[1]) {
    if (sum(c(dset[i, 1:2], -1) * w1) * dset[i, 3] < 0) {
      errorsCount <- errorsCount + 1
    }
  }
  # print(errorsCount)

  plot(dset[ ,1], dset[ ,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(dset[ ,3])])

  drawLine(w1, "darkgreen")
}

print(errorsCount / iterationsCount)
print(gsteps / iterationsCount)

# > w1
# [1] -1.0600585 -0.2050553 -3.6053360
# > w[3]  / w[2]
# Error: object 'w' not found
# > w1[3]  / w1[2]
# [1] 17.58226
# > ?abline
# > -w1[1] / w1[2]
# [1] -5.169623
# > 17.58226 -5.169623
# [1] 12.41264
# > 17.58226 -2*5.169623
# [1] 7.243014
# > c(2, 7.243, 0) * w1
# [1] -2.120117 -1.485215  0.000000
# > c(-1, 2, 7.243) * w1
# [1]   1.0600585  -0.4101105 -26.1134488
# > c(2, 7.243, -1) * w1
# [1] -2.120117 -1.485215  3.605336
# > sum(c(2, 7.243, -1) * w1)
# [1] 3.612683e-06
# > paste(sum(c(2, 7.243, -1) * w1))
# [1] "3.61268315218766e-06"


# 4. faza: Napredna analiza podatkov

JSC = data.frame(naselje = c("Jesenice"),
                 nmv = c(585),
                 lat = c(46.4327),
                 lon = c(14.0534)
                 )

podatki = tabela3

#===========TEMPERATURE NAPOVEDUJE ZA JSC
g_A_1 <- ggplot(podatki, aes(x=lat, y=avg_t)) + geom_point() + stat_smooth(method = lm)
#print(g_A_1)

g_A_2 = ggplot(tabela3) + aes(x=nmv , y = avg_t)+
  geom_point() + stat_smooth(method = lm)  +
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih temperatur[°C]",
    title = "Analiza povezave nadmorske višine in temperature"
  )
#print(g_A_2)
#Iz grafa 7 opazimo zelo lepo povezavo med avg_t in nmv
m_za_temp = avg_t ~ nmv + lat

lin.model1 = lm(m_za_temp, data = podatki)
#print(lin.model1)

tem_JSC = lm.napovedi1 = predict(lin.model1 , newdata = JSC)
JSC$avg_t = tem_JSC

#============= PADAVINE
g_A_3 = ggplot(podatki, aes(x = lat,y=avg_p))+geom_point() + stat_smooth(method = lm)
#print(g_A_3)
#iz grafa opazimo nikakršne povezave
g_A_4 = ggplot(podatki, aes(x = nmv,y=avg_p))+geom_point() + stat_smooth(method = lm)+
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih padavin za leto[mm/m^2]",
    title = "Analiza povezave nadmorske višine in padavin"
  )
#print(g_A_4)

#Opazim da bi bilo tu mogoče bolje uporabiti kaj drugega in zanemariti Kredarico

podatki1 = podatki%>% filter(naselje != "Kredarica")

g_A_5 = ggplot(podatki1, aes(x = nmv,y=avg_p))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2) + I(x^3))
#print(g_A_5)
g_A_6 = ggplot(podatki1, aes(x = nmv,y=avg_p))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2)) +
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih padavin za leto[mm/m^2]",
    title = "Analiza povezave nadmorske višine in padavin"
  )
#print(g_A_6)
#Stvar iz g_A_6 se mi zdi lepša saj z nmv naj bi se dvigovale padavine

m_za_padavine = avg_p ~nmv + I(nmv^2) + lat
lin.model2 = lm(m_za_padavine,data = podatki1)
lm.napovedi2 = predict(lin.model2,newdata = JSC)
#print(lm.napovedi2)
pad_JSC = lm.napovedi2
JSC$avg_p = pad_JSC

#===========PREBIVALSTVO
g_A_7= ggplot(podatki, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_7)
#Opazim,da Kredarica ni najbl fajn
g_A_8 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_8)
g_A_9 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2))
#print(g_A_9)
g_A_10 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2)+I(x^3))
#print(g_A_10)
#nekak se zdi najbolj logično 8

g_A_11= ggplot(podatki1, aes(x=avg_p,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_11)

g_A_12 = ggplot(podatki1, aes(x=avg_p,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2) )
#print(g_A_12)
#12 se zdi bols

g_A_13 = ggplot(podatki1, aes(x=avg_t,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_13)
g_A_14 = ggplot(podatki1, aes(x=avg_t,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2))
#print(g_A_14)
#oboje vredu

m_za_preb = avg_preb ~ nmv + avg_t + avg_p
lin.model3 = lm(m_za_preb,data = podatki1)
lm.napovedi3 = predict(lin.model3,newdata = JSC)
#print(lm.napovedi3)
preb_JSC = lm.napovedi3
JSC$avg_preb = preb_JSC

#print(JSC) #napoved za Jesenice

JSC_zares = gostota_prebivalci%>%filter(naselje == "Jesenice") %>%.[20,]
#Opazim, da se napoved od resnice za gostot prebivalcev razlikuje kar močno
#Mogoče se pa za temperature in padavine ne

SLO <- map_data("world") %>% filter(region=="Slovenia")
data = tabela3 %>%filter(leto=="2010")
data_12 = rbind(data , JSC)
data_12 =data_12[data_12$naselje != "Slap pri Vipavi",]
data_12 = data_12[data_12$naselje != "Brnik",]
data_12 = data_12 %>% filter(naselje != "Kredarica")
g12 = ggplot() +
  geom_polygon(data = SLO, aes(x=long, y = lat, group = group), fill="grey", alpha=0.3) +
  geom_point( data=(data_12), aes(x=lon, y=lat, size=avg_preb,color=nmv)) +
  scale_size_continuous(range=c(1,12)) +
  scale_colour_viridis(trans="identity",option = "C") +
  theme_void() + ylim(45,47) + coord_map()  +
  geom_text(
    data = data_12 %>% filter(naselje != "Jesenice"),
    mapping = aes(x = lon , y = lat+0.07, label = naselje),
    size = 2.5
  ) +
  geom_text(
    data = data_12 %>% filter(naselje == "Jesenice"),
    mapping = aes(x = lon , y = lat+0.07, label = naselje),
    size = 2.5 ,colour = "red"
  ) +
  labs(
    size = "Gostota poseljenosti [prebivalci/km^2]",
    color = "Nadmorska višina[m]"
  )