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

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

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

  # Calculates the shrinkage-based estimator of the pooled covariance matrix.
  obj$var_shrink <- var_shrinkage(
    N = obj$N,
    K = obj$num_groups,
    var_feature = obj$var_pool,
    num_alphas = num_alphas,
    t = -1
  )

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

  obj
}

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

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

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

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

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

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

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

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

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

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


beta1=-7.859 # caclulated in 11.4
error=1.090
alpha=0.05/2
df=18
t.alpha=qt(1-alpha,df)
print(t.alpha)
# corresponding confidence interval for the true value of beta1
left_i=beta1-t.alpha*error
right_i=beta1+t.alpha*error
print("confidence interval")
print(left_i)
print(right_i)


###Spatial Bayesian regression
## Author: Ying-Jung Deweese
## Date: 2017-08-24
## Load the libraries to be used
library(coda)
library(abind)
library(magic)
library(maps)
library(Matrix)
library(Formula)
library(spBayes)
library(MBA)
library(geoR)
library(spam)
library(grid)
library(fields)
library(sp)
library(maptools)
library(rgdal)
library(classInt)
library(lattice)
library(raster)

### Read file
year = 2005
filename = sprintf("all_2005fok_0920.csv", year);

A=read.csv(filename,header=T)

## Data preliminaries
## Read data length
S_num = dim(A)[2]-7

## Compute the spatial Bayesian regression
for (i in 1:S_num)
{

print(sprintf("start of loop %d", i))

## Subset data variable for elevation, rain variables
bio <- A[,i+7]
elv <- A[,2]

## Extract the coordinates
coords <- as.matrix(A[,c("long","lat")])

p <- 2 ## This is the number of columns in the design matrix
## Set the prior mean and precision for the regression
beta.prior.mean <- as.matrix(rep(0, times=p))
beta.prior.precision <- matrix(0, nrow=p, ncol=p)

## For use with bayesGeostatExact, do the following
phi <- 0.5 ## Set the spatial range (from the variogram)
alpha <- 1600/0.5 ## Set the nugget/partial-sill ratio
sigma.sq.prior.shape <- 2.0 ## Set IG shape for sigma.sq (partial sill)
sigma.sq.prior.rate <- 0.5 ## Set IG scale for sigma.sq (partial sill)

## Run bayesGeostatExact to deliver exact posterior samples
sp.exact <- bayesGeostatExact(
bio~elv,
coords=coords, n.samples=1000,
beta.prior.mean=beta.prior.mean,
beta.prior.precision=beta.prior.precision,
cov.model="spherical",
phi=phi, alpha=alpha,
sigma.sq.prior.shape=sigma.sq.prior.shape,
sigma.sq.prior.rate=sigma.sq.prior.rate,
sp.effects=FALSE)

##Produce the posterior summaries
round(summary(sp.exact$p.samples)$quantiles,3)

cook=coords
## Run spLM to deliver MCMC samples from marginal posterior distributions
n.samples <- 1000
bef.sp <- spLM(bio~elv,
coords=cook, starting=list("phi"=3/200,"sigma.sq"=0.08,

                           "tau.sq"=0.02), tuning=list("phi"=0.1, "sigma.sq"=0.05, "tau.sq"=0.05),

priors=list("phi.Unif"=c(3/1500, 3/50), "sigma.sq.IG"=c(2, 0.08),"tau.sq.IG"=c(2, 0.02)), cov.model="spherical",n.samples=n.samples)

round(summary(mcmc(bef.sp$p.theta.samples))$quantiles,3)

## Recover spatial residuals using spRecover
burn.in <- floor(0.75*n.samples)
bef.sp <- spRecover(bef.sp, start=burn.in, thin=2)

## The posterior samples of the regression coefficients and the spatial effects can then be obtained as
beta.samples = bef.sp$p.beta.recover.samples
w.samples = bef.sp$p.w.recover.samples

## Obtain trace plots for regression coefficients
par(mfrow=c(3,2))
plot(beta.samples, auto.layout=TRUE, density=FALSE)

## Obtain posterior means and sd's of spatial residuals for each location
w.hat.mu <- apply(w.samples,1,mean)
w.hat.sd <- apply(w.samples,1,sd)

## Obtain OLS residuals
lm.test = lm(bio~elv)
test.resid = resid(lm.test)

## Plot the spatial residual mean surface and a map of sd's
par(mfrow=c(1,2))
surf <- mba.surf(cbind(coords, test.resid), no.X=100, no.Y=100, extend=FALSE)$xyz.est
z.lim <- range(surf[[3]], na.rm=TRUE)
image.plot(surf, xaxs = "r", yaxs = "r", zlim=z.lim, main="LM residuals")
surf <- mba.surf(cbind(coords, w.hat.mu), no.X=100, no.Y=100, extend=FALSE)$xyz.est
image.plot(surf, xaxs = "r", yaxs = "r", zlim=z.lim, main="Mean spatial effects")

## Predictions
BEF.shp <- readShapePoly("coastalbasinsdata.shp")
shp2poly <- BEF.shp@polygons[[1]]@Polygons[[1]]@coords
BEF.poly <- as.matrix(shp2poly)
BEF.grids <- readGDAL("all_ok_Projec.tif")

## Construct the prediction design matrix for the entire grid extent.
pred.covars <- cbind(BEF.grids[["band1"]], BEF.grids[["band2"]], BEF.grids[["band3"]], BEF.grids[["band4"]], BEF.grids[["band5"]])
pred.covars <- cbind(rep(1, nrow(pred.covars)), pred.covars)
p=SpatialPointsDataFrame(coordinates(BEF.grids),data=BEF.grids@data) # convert spatialgrid dataframe to spatial point dataframe

## Extract the coordinates of the BEF bounding polygon vertices and use the pointsInPoly (spBayes) function to obtain the desired subset of the prediction design matrix and associated prediction coordinates (i.e., pixel centroids).
pred.coords <- SpatialPoints(BEF.grids)@coords
pointsInPolyOut <- pointsInPoly(BEF.poly, pred.coords)
pred.coords <- pred.coords[pointsInPolyOut,]
pred.covars <- p[pointsInPolyOut,]
#convert spdf to matrix
DF <- as.matrix(pred.covars@data)
DF <- cbind(rep(1, nrow(DF)), DF)# generate 2 column
bef.bio.pred <- spPredict(bef.sp, start=burn.in, thin=2, pred.coords=pred.coords, pred.covars=DF)

## Mapping the predicted values
bef.bio.pred.mu = apply(bef.bio.pred$p.y.predictive.samples,1,mean)
bef.bio.pred.sd = apply(bef.bio.pred$p.y.predictive.samples,1,sd)
surf <- mba.surf(cbind(coords,bio), no.X=500, no.Y=500, extend=TRUE, sp=TRUE)$xyz.est

## write out raster

ras3_name = sprintf("All_%d-S%d_spBayes.tif", year, i)
writeGDAL(surf, ras3_name, drivername="GTiff", options=NULL)

}


#The law of Large Numbers

#The rnorm() function in R generates a random number using a normal(bell curve) distribution.
#It takes the sample size as Input and generate that many random numbers.

#E(x) = 68.2 or 0.682
#Try N = input(10, 100, 1000, 10000....)

#Begin
N <- 1000
counter <- 0
for (i in rnorm(N)){
  if(i> -1 & i <1){
    counter <- counter +1

  }
}

answer <- counter/N *100
answer

#END


vsa=function(fun,par.mins,par.maxs,nrun){
  par.range = par.maxs - par.mins
  k=length(par.range)
  M = array(runif(nrun*k),dim=c(nrun,k))      #CREATE U(0,1) n x k MATRIX
  for (i in 1:k) M[,i] = M[,i] * par.range[i] + par.mins[i] #TRANSFORM TO FIT RANGE OF EACH PAR

  #Now we are going to make a different input matrix, M2, the same way
  M2 = array(runif(nrun*k),dim=c(nrun,k))     #CREATE U(0,1) n x k MATRIX
  for (i in 1:k) M2[,i] = M2[,i] * par.range[i] + par.mins[i] #TRANSFORM TO FIT RANGE OF EACH PAR

  #Now we are going to make K different matrices, where in the jth matrix, all parameters are taken from M2 except parameter j is taken from M
  NJ.list = list()
  for (j in 1:k) {
    temp = M2
    temp[,j] = M[,j]
    NJ.list[[j]] = temp
  }

  #Now, to compute the first-order effects (S) of factor J, we need to compute the values UJ, as discussed in class
  S = numeric(length=k)
  ST = numeric(length=k)
  y1 = y2 = y3 = numeric(length = nrun)
  for (i in 1:nrun) {
      y1[i] = fun(M[i,])
      y2[i] = fun(M2[i,])
  }
 #Now to compute the expected value (EY) and total variance (VY) of Y, for which we will use M2
  EY=mean(y1)
 # VY=var(y3)
 #For computational reasons, we will estimate EY^2 using both M and M2
 # EY2=mean(y1*y2)
#  EY2=EY^2
  VY=sum(y1*y1)/(nrun-1)-EY^2

  for (j in 1:k) {
    NJ = NJ.list[[j]]
    for (i in 1:nrun) y3[i] = fun(NJ[i,])
    UJ = sum(y1*y3) / (nrun-1)   #here everything but factor j is resampled
    UJ2 = sum(y2*y3) / (nrun-1)  #here only factor j is resampled
    S[j] = (UJ - EY^2) / VY
    ST[j] = 1.0 - (UJ2 - EY^2) / VY
  }

  list(S,ST)
}


########################################################################
#                                                                      #
#   lib/finite-group.rb                                                #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
((<Algebra::OperatorDomain>))
/
((<Algebra::Set>))
/
((<Algebra::Group>))
/
((<Algebra::QuotientGroup>))

= Algebra::OperatorDomain

This is the module for the set oprated by groups.
This is included by ((<Group>)).

== File Name:
* ((|finite-group.rb|))

== Methods:

--- right_act(other)
    Returns the products of ((|self|)) and ((|other|)), i.e.
    ((|Set|)) of (({x * y})) for
    ((|x|)) element of ((|self|)) and ((|y|)) element of ((|other|)).

--- act
    Alias of ((<right_act>)).

--- left_act(other)
    Returns the products of ((|self|)) and ((|other|)), i.e.
    ((|Set|)) of (({y * x})) for
    ((|x|)) element of ((|self|)) and ((|y|)) element of ((|other|)).

--- right_quotient(other)
    Returns the ((|Set|)) of right residue classes
    of ((|self|)) by ((|other|)).

--- quotient
--- right_coset
--- coset
    Alias of ((<right_quotient>)).

--- left_quotient(other)
    Returns the ((|Set|)) of left residue classes
    of ((|self|)) by ((|other|)).

--- left_coset
    Alias of ((<left_quotient>)).

--- right_representatives(other)
    Returns the representatives of the
    right residue classes ((<right_quotient>)).

--- representatives
    Alias of ((<right_representatives>)).

--- left_representatives(other)
    Returns the representatives of the
    left residue classes ((<left_quotient>)).

--- right_orbit!(other)
    Extends ((|self|)) operating the elements of ((|other|)) by right action
    ((|*|)).

--- orbit!
    Alias of ((<right_orbit!>)).

--- left_orbit!(other)
    Extends ((|self|)) operating the elements of ((|other|)) by left action
    ((|*|)).

= Algebra::Set

== File Name:
* ((|finite-group.rb|))

== Included Module:

* ((|OperatorDomain|))

== Methods:

--- * act
    Alias of ((<act>))

--- /
    Alias of ((<quotient>)).

--- %
    Alias of ((<representatives>)).

--- increasing_series([x])
    Returns the increasing series begining with ((|x|)).
    This is equivalent to the following code:

      def increasing_series(x = unit_group)
        a = []
        loop do
          a.push x
          if x >= (y = yield x)
            break
          end
          x = y
        end
        a
      end

--- decreasing_series([x])
    Returns the decreasing series begining with ((|x|)).
    This is equivalent to the following code:

      def decreasing_series(x = self)
        a = []
        loop do
          a.push x
          if x <= (y = yield x)
            break
          end
          x = y
        end
        a
      end

= Algebra::Group

== File Name:
* ((|finite-group.rb|))

== SuperClass:
* ((|Set|))

== Included Module:
(None)

== Class Methods:

--- ::new(u, [g0, g1, ...]])
    Returns the group which consists of ((|u|)), ((|g0|)), ((|g1|)), ...
    and whose unity is ((|u|)).

--- ::generate_strong(u, [g0, [g1, ...]])
    Returns the group strongly generated by ((|g0|)), ((|g1|)), ...
    and whose unity is ((|u|)).

== Methods:

--- quotient_group(u)
    Returns the residue class group of the normal subgroup ((|u|)).

--- separate
    Returns the subgroup whose elements makes the block true.

--- to_a
    Returns the array of elements. The first is the unity.

--- unity
    Returns the unity.

--- unit_group
    Returns the unit group.

--- semi_complete!
    Makes ((|self|)) be the semi-group generated by the elements.

--- semi_complete
    Returns the semi-group generated by the elements.

--- complete!
    Makes ((|self|)) be the semi-group generated by the elements.

--- complete
    Returns the group generated by the elements.

--- closed?
    Returns true when ((|self|)) is closed by product and inverse.

--- subgroups
    Returns the all subgroups.

--- centralizer(s)
    Returns the centralize of ((|s|)) in ((|self|)).

--- center
    Returns the center of((|self|)).

--- center?(x)
    Returns true if ((|x|)) is in the center of ((|self|)).

--- normalizer(s)
    Returns the normalizer of ((|s|)) in ((|self|)).

--- normal?(s)
    Returns true if ((|s|)) is a normal subgroup of ((|self|)).

--- normal_subgroups
    Returns the all normal subgroups.

--- conjugacy_class(x)
    Returns the conjugacy class of the element ((|x|)).

--- conjugacy_classes
    Returns the set of all conjucacy claases of ((|self|)).

--- simple?
    Retuns true if ((|self|)) is a simple group.

--- commutator([h])
    Returns the commutator subgroup of ((|self|)) and ((|h|)).
    If the parameter is omitted, ((|h|)) is assumed to be ((|self|)).

--- D([n])
    Returns the ((|n|))-the commutator subgroup.
    (({D(0) = self})) and (({D(n+1) = [D[n], D[n]]})).
    If the parameter ommitted, ((|n|)) is assumed to be 1.

--- commutator_series
    Returns the array (({[D(0), D(1), D(2),..., D(n)]})) .
    This sequence is terminated for ((|n|)) with (({D(n) == D(n+1)})).

--- solvable?
    Returns true if ((|self|)) is solvable.

--- K([n])
    Returns the subgroup definend such that (({K(0) = self})) and
    (({K(n+1) = [self, K[n]})).
    If the parameter is omitted, ((|n|)) is asumed to be 1.

--- descending_central_series
    Returns the descending central series:
    (({[K(0), K(1), K(2),..., K(n)]})).
    This sequence is terminated for ((|n|)) with (({K(n) == K(n+1)})).

--- Z([n])
    Returns the subgroup that defined by: (({Z(0) = unit group})),
    (({Z(n+1) = separate{|x| commutator(Set[x]) <= Z(n-1)}})) .
    If the parameter is omitted, ((|n|)) is assumed to be 1.

--- ascending_central_series
    Returns the array of  ascending central series:
    (({[Z(0), Z(1), Z(2),..., Z(n)]})).
    This sequence is terminated for ((|n|)) such that
    (({Z(n) == Z(n+1)})).

--- nilpotent?
    Returns true if ((|self|)) is nilpotent.

--- nilpotency_class
    Returns the class of nilpotency.
    If ((|self|)) is not nilpotent, returns nil.

= Algebra::QuotientGroup

== File Name:
* ((|finite-group.rb|))

== SuperClass:
* ((|Group|))

== Class Methods:
--- new(u, [g0, [g1,...]])
    Returns the residue class group by ((|u|)) of which the residues are
    ((|u|)), ((|g0|)), ((|g1|)), ... Here ((|u|)) is assumed to be
    the normal subgroup of ((|self|)).

== Methods:

--- inverse
    Returns the inverse element.

--- inv
    Alias of ((<inverse>)).
=end


getZ = function() {
  return((as.numeric(rawScore) - as.numeric(mean)) / as.numeric(sd))
}

getT = function(z) {
  return(z*10+50)
}

getStanine = function(z) {
  stanine = round(z*2+5)
  stanine = min(max(stanine, 1), 9)
  return(stanine)
}

getSten = function(z) {
  sten = round(z*2+5.5)
  sten = min(max(sten, 1), 10)
  return(sten)
}

getIq = function(z) {
  return(z*15+100)
}

getPercentile = function(z) {
  return(pnorm(z)*100)
}

getPercentileRange = function() {
  ranges = NULL
  score = NULL
  if(scoreType == "percentileRanges") {
    rangesList = fromJSON(percentileRanges)
    if(length(rangesList) > 0) {
      for(i in 1:length(rangesList)) {
        ranges = rbind(ranges, data.frame(rangesList[[i]], stringsAsFactors=F))
      }
    }
  }
  if(scoreType == "percentileRangesTable") {
    rangesTable = fromJSON(percentileRangesTable)
    sql = "SELECT
{{lowerBoundColumn}} AS lowerBound,
{{upperBoundColumn}} AS upperBound,
{{scoreColumn}} AS score
FROM {{table}}"
    ranges = concerto.table.query(sql, params=list(
      lowerBoundColumn=rangesTable$columns$lowerBound,
      upperBoundColumn=rangesTable$columns$upperBound,
      scoreColumn=rangesTable$columns$score,
      table=rangesTable$table
    ))
  }

  if(dim(ranges)[1] > 0) {
    for(i in 1:dim(ranges)[1]) {
      range = ranges[i,]
      range$lowerBound = as.numeric(range$lowerBound)
      range$upperBound = as.numeric(range$upperBound)
      if(!is.na(range$lowerBound) && range$lowerBound > as.numeric(rawScore)) { next }
      if(!is.na(range$upperBound) && range$upperBound <= as.numeric(rawScore)) { next }
      score = as.numeric(range$score)
    }
  }

  return(score)
}

score = switch(scoreType,
               "zScore" = getZ(),
               "tScore" = getT(getZ()),
               "stanine" = getStanine(getZ()),
               "sten" = getSten(getZ()),
               "iq" = getIq(getZ()),
               "percentile" = getPercentile(getZ()),
               "percentileRanges" = getPercentileRange(),
               "percentileRangesTable" = getPercentileRange(),
               "custom" = eval(parse(text=customScoreFormula)),
               "rawScore" = as.numeric(rawScore),
               as.numeric(rawScore)
              )

feedback = NULL
if(feedbackType != "none") {
  ranges = NULL
  if(feedbackType == "ranges") {
    rangesList = fromJSON(feedbackRanges)
    if(length(rangesList) > 0) {
      for(i in 1:length(rangesList)) {
        ranges = rbind(ranges, data.frame(rangesList[[i]], stringsAsFactors=F))
      }
    }
  }
  if(feedbackType == "rangesTable") {
    rangesTable = fromJSON(feedbackRangesTable)
    sql = "SELECT
{{lowerBoundColumn}} AS lowerBound,
{{upperBoundColumn}} AS upperBound,
{{feedbackColumn}} AS feedback
FROM {{table}}"
    ranges = concerto.table.query(sql, params=list(
      lowerBoundColumn=rangesTable$columns$lowerBound,
      upperBoundColumn=rangesTable$columns$upperBound,
      feedbackColumn=rangesTable$columns$feedback,
      table=rangesTable$table
    ))
  }

  if(!is.null(ranges) && dim(ranges)[1] > 0) {
    for(i in 1:dim(ranges)[1]) {
      range = ranges[i,]
      range$lowerBound = as.numeric(range$lowerBound)
      range$upperBound = as.numeric(range$upperBound)
      if(!is.na(range$lowerBound) && range$lowerBound > score) { next }
      if(!is.na(range$upperBound) && range$upperBound <= score) { next }
      feedback = range$feedback
    }
  }
}


malthus <- function(initial_time, initial_population, time_interval, N, growth_rate) {
    time <- initial_time
    population <- initial_population
    times <- c(time)
    populations <- c(population)
    for(i in 1:N) {
        population <- population + growth_rate*time_interval*population
        time <- time + time_interval
        times <- c(times, time)
        populations <- c(populations, population)
    }

    return(data.frame(times, populations))
}

plot(malthus(1900, 76.2, 1, 300, 0.013))


### Reference implementations. Fairly direct translations from the paper

.alldist = function(d, x) sapply(1:nrow(x), function(i) sum((d-x[i, ])^2))

.fastmap = function(x)
{
  d_i = sample(nrow(x), size=1)
  d = x[d_i, ]

  dists = .alldist(d, x)
  a_i = which.max(dists)
  a = x[a_i, ]

  dists = .alldist(a, x)
  b_i = which.max(dists)
  b = x[b_i, ]

  list(a=a, b=b)
}

.cma = function(x, k)
{
  n = ncol(x)

  for (i in 1:k)
  {
    x.i = x[, i:n, drop=FALSE]
    ab = .fastmap(x.i)

    x.i = sweep(x.i, MARGIN=2, STATS=ab$a, FUN="-")

    w = matrix(ab$b - ab$a)
    v = w
    v[1] = w[1] + sign(w[1]) * norm(w, "2")
    v = v / norm(v, "2")
    y = x.i %*% v
    x[, i:n] = x.i - tcrossprod(2*y, v)
  }

  x[, 1:k, drop=FALSE]
}


#
# Test package against LV dynamics
#

require(deSolve)
require(ggplot2)
require(tidyr)
require(tibble)
#
#

parms <- tibble::tribble(
  ~a1,   ~a2,  ~a3,    ~a4,   ~a5,  ~a6,    ~r,
    0,  4e-6, 3e-5,   2e-5,     0,    0,  -0.01,
-1e-5, -1e-4,    0,   1e-4,  6e-5,    0, -0.001,
-1e-4,     0,    0,      0,  6e-5, 5e-5,  -0.01,
-1e-4,  1e-4,    0,  -5e-4, -1e-5,    0,   0.08,
    0, -1e-4,-1e-4,      0, -1e-6,    0,   0.04,
    0,     0,-1e-4,   2e-4,     0,    0,   0.00
)

# Solve for equilibrium populations
#
eq <- lm(r ~ . + 0, parms)
-coef(eq)

# Generalized Lotka-Volterra 6 species  equation
#
GLV_det<-function(Time,State,Pars){
  with(as.list(c(State, Pars)), {
    A <- matrix(Pars,6,7)
    dP1 <- N1*(A[1,7]+A[1,1]*N1+A[1,2]*N2+A[1,3]*N3+A[1,4]*N4+A[1,5]*N5+A[1,6]*N6)
    dP2 <- N2*(A[2,7]+A[2,1]*N1+A[2,2]*N2+A[2,3]*N3+A[2,4]*N4+A[2,5]*N5+A[2,6]*N6)
    dP3 <- N3*(A[3,7]+A[3,1]*N1+A[3,2]*N2+A[3,3]*N3+A[3,4]*N4+A[3,5]*N5+A[3,6]*N6)
    dP4 <- N4*(A[4,7]+A[4,1]*N1+A[4,2]*N2+A[4,3]*N3+A[4,4]*N4+A[4,5]*N5+A[4,6]*N6)
    dP5 <- N5*(A[5,7]+A[5,1]*N1+A[5,2]*N2+A[5,3]*N3+A[5,4]*N4+A[5,5]*N5+A[5,6]*N6)
    dP6 <- N6*(A[6,7]+A[6,1]*N1+A[6,2]*N2+A[6,3]*N3+A[6,4]*N4+A[6,5]*N5+A[6,6]*N6)

    return(list(c(dP1,dP2,dP3,dP4,dP5,dP6)))
  })
}

# Simulate the model by integration
#
pars  <- c(A <- as.matrix(parms[,1:6]),
           r<- as.numeric(parms$r)
)

yini  <- c(N1 = 100,N2=100,N3=100,N4=100,N5=100,N6=100)
out   <- as.data.frame(ode(yini, 1:600, GLV_det, pars))
df <- gather(out,key="Species",value="N", -time)
ggplot(df, aes(time,N,colour=Species)) + geom_line(size=.5)

A <- as.matrix(parms[,1:6])
r<- as.numeric(parms$r)
m <- c(0,0,0,0,0,0)
#NumericMatrix metaW,NumericVector m, NumericVector r, NumericVector ini, int time, double tau=0.01)
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,1000,0.1)
df1 <- as.data.frame(t(A1$STime))
df1$time <- 1:1000
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,1000,0.1)
df2 <- as.data.frame(t(A1$STime))
df2$time <- 1:1000

df1 <- rbind(df1,df2 )

names(df1)[1:6] <- unique(df$Species)
require(tidyr)
df1 <- gather(df1,key="Species",value="N", N1:N6)
require(ggplot2)
ggplot(df, aes(time,N,colour=Species)) + geom_line() + geom_point(data=df1,aes(time,N,colour=Species),size=0.1) + theme_bw() + scale_color_viridis_d()

ggplot(df1, aes(time,N,colour=Species)) + geom_point(size=0.1) +  theme_bw() + scale_color_viridis_d()

#
# LV with migration
#

parms <- tibble::tribble(
  ~a1,   ~a2,  ~a3,    ~a4,   ~a5,  ~a6,    ~r,   ~m,
    0,  4e-6, 3e-5,   2e-5,     0,    0,  -0.01, 0.1,
-1e-5, -1e-4,    0,   1e-4,  6e-5,    0, -0.001, 0.1,
-1e-4,     0,    0,      0,  6e-5, 5e-5,  -0.01, 0.1,
-1e-4,  1e-4,    0,  -5e-4, -1e-5,    0,   0.08, 0.1,
    0, -1e-4,-1e-4,      0, -1e-6,    0,   0.04, 0.1,
    0,     0,-1e-4,   2e-4,     0,    0,   0.00, 0.1
)

# Generalized Lotka-Volterra with migration 6 species  equation
#
GLVM_det<-function(Time,State,Pars){
  with(as.list(c(State, Pars)), {
    A <- matrix(Pars,6,8)
    dP1 <- N1*(A[1,7]+A[1,1]*N1+A[1,2]*N2+A[1,3]*N3+A[1,4]*N4+A[1,5]*N5+A[1,6]*N6)+A[1,8]
    dP2 <- N2*(A[2,7]+A[2,1]*N1+A[2,2]*N2+A[2,3]*N3+A[2,4]*N4+A[2,5]*N5+A[2,6]*N6)+A[2,8]
    dP3 <- N3*(A[3,7]+A[3,1]*N1+A[3,2]*N2+A[3,3]*N3+A[3,4]*N4+A[3,5]*N5+A[3,6]*N6)+A[3,8]
    dP4 <- N4*(A[4,7]+A[4,1]*N1+A[4,2]*N2+A[4,3]*N3+A[4,4]*N4+A[4,5]*N5+A[4,6]*N6)+A[4,8]
    dP5 <- N5*(A[5,7]+A[5,1]*N1+A[5,2]*N2+A[5,3]*N3+A[5,4]*N4+A[5,5]*N5+A[5,6]*N6)+A[5,8]
    dP6 <- N6*(A[6,7]+A[6,1]*N1+A[6,2]*N2+A[6,3]*N3+A[6,4]*N4+A[6,5]*N5+A[6,6]*N6)+A[6,8]

    return(list(c(dP1,dP2,dP3,dP4,dP5,dP6)))
  })
}

pars <- as.matrix(parms)
yini  <- c(N1 = 0,N2=0,N3=0,N4=0,N5=0,N6=0)
out   <- as.data.frame(ode(yini, 1:600, GLVM_det, pars))
df <- gather(out,key="Species",value="N", -time)
ggplot(df, aes(time,N,colour=Species)) + geom_line(size=.5)
calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

A <- as.matrix(parms[,1:6])
r<- as.numeric(parms$r)
m <-as.numeric(parms$m)
#NumericMatrix metaW,NumericVector m, NumericVector r, NumericVector ini, int time, double tau=0.01)
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,600,0.1)
df1 <- as.data.frame(t(A1$STime))
df1$time <- 1:600
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,600,0.1)
df2 <- as.data.frame(t(A1$STime))
df2$time <- 1:600

df1 <- rbind(df1,df2 )

names(df1)[1:6] <- unique(df$Species)
require(tidyr)
df1 <- gather(df1,key="Species",value="N", N1:N6)
require(ggplot2)
ggplot(df, aes(time,N,colour=Species)) + geom_line() + geom_point(data=df1,aes(time,N,colour=Species),size=0.1) + theme_bw() + scale_color_viridis_d()

#
# Generate random adjacency matrix
#
require(igraph)

#### ER random graph
build.random.structure <- function(n, connectance){
  S <- matrix(0, nrow = n, ncol = n)
  S[upper.tri(S)] <- rbinom(n * (n - 1)/2,size = 1, p = connectance)
  S[lower.tri(S)] <- rbinom(n * (n - 1)/2,size = 1, p = connectance)
  #S <- S + t(S)
  #diag(S) <- 0
  return(S)
}

#
# Size 106, links 4623
#
require(multiweb)

C <- 4623/(106*106)

#
# Generate random GLV matrix
#

A <- generateRandomGLVadjMat(100,0.01,c(0.3,0.3,0.3,0.05,0.05))
A1 <- generateGLVparmsFromAdj(A,0.01,0.01)
yini <- rep(10,times=nrow(A1$interM))
calcPropInteractionsGLVadjMat(A ,yini)

yini <- rep(0,times=nrow(A1$interM))
A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,600,0.1)
A2$STime[,600]
df1 <- as.data.frame(t(A2$STime))
df1$time <- 1:600
require(tidyr)
require(ggplot2)
require(dplyr)
df1 <- gather(df1,key="Species",value="N", -time)
ggplot(filter(df1,time>500), aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)
ggplot(df1, aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)

df1 <- data_frame(time=1:600,S = A2$S,C = A2$L/(A2$S*A2$S))
ggplot(filter(df1,time>500), aes(time,S)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(time,S)) + geom_line() +  theme_bw() + scale_color_viridis_d()

ggplot(filter(df1,time>500), aes(time,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(time,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(S,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

# With no migration
yini <- rep(100,times=nrow(A1$interM))
A1$m <- rep(0.0, 100)
A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,600,0.1)
A2$STime[,600]
df1 <- as.data.frame(t(A2$STime))
df1$time <- 1:600
require(tidyr)
require(ggplot2)
require(dplyr)
df1 <- gather(df1,key="Species",value="N", -time)
ggplot(df1, aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

#
# To igraph
#
require(multiweb)
require(igraph)
diag(A2$A) <- 0
g <- graph_from_adjacency_matrix(A2$A,mode="directed")
plotTrophLevel(g,modules=TRUE)
calcTopologicalIndices(g)

#
# More testing
#

A <- generateRandomGLVadjMat(100,0.05,c(0.2,0.5,0.1,0.0,0.0))
A
A1 <- generateGLVparmsFromAdj(A,0.1,0.01)

yini <- rep(1,times=nrow(A1$interM))

calcPropInteractionsGLVadjMat(A1$interM,yini)

A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,100,0.1)

df <- as.data.frame(t(A2$STime))
df$Time <- 1:100
require(tidyr)
df <- gather(df,key="Species",value="N", V1:V100)
require(ggplot2)
ggplot(df, aes(Time,N,colour=Species)) + geom_line() +guides(colour=FALSE)

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,100])

# Delete diagonals
diag(A2$A) <- FALSE
# Delete columns and rows with no species
d <- A2$STime[,100]!=0
A <- A2$A[d,d]
# Size of d == Number of species
sum(d)==A2$S[100]

g <- graph_from_adjacency_matrix(A,mode="directed")
g
plotTrophLevel(g)
calcTopologicalIndices(g) # Trophic level do not work with multiple interactions types

require(NetIndices)
TrophInd(A2$A)


## library(devtools)
## library(roxygen2)
## library(testthat)
##
## Build and Reload Package:  'Ctrl + Shift + B'
## Check Package:             'Ctrl + Shift + E'
## Test Package:              'Ctrl + Shift + T'
## Document:                  'Ctrl + Shift + D'

##
#' @title Scaling of X-Axis (as vector or as scalar) to [-1,1]
#' @param x_axis urspruengliche beliebige X-Achse (Vektor)
#' @param x_val Einzelwert auf X-Achse (Skalar)
#' @return x_cheb_scaled Abhaengig von Eingangsparametern: Skalierte X-Achse (Vektor) oder skalierter Einzelwert anhand vorgegebener X-Achse
#' @description
#' \code{cheb_scale} skaliert beliebige X-Achse auf Achse, die fuer Polynom-fits vertraeglich ist.
#' @export
cheb_scale <- function(x_axis, x_val = NA) {#, scale) {
  ## Funktion zur Skalierung von Stuetzpunkten
  ## von beliebigen Gittern auf [-1, 1]
  ## ##
  if ( is.na(x_val) == TRUE ) { # Fuer Skalierung von vektoriellen Achsen
    x_cheb_scaled <- 2 * (x_axis - min(x_axis)) / (max(x_axis) - min(x_axis)) - 1
  }
  if ( is.na(x_val) == FALSE ) { # Fuer Skalierung von Einzelwert(en) auf Achse
    x_cheb_scaled <- 2 * (x_val - min(x_axis)) / (max(x_axis) - min(x_axis)) - 1
  }
  return(x_cheb_scaled)
}

##
#' @title Rescaling of X-Axis (as vector or as scalar)
#' @param x_cheb skalierte X-Achse (Skalar oder Vektor)
#' @param x_axis beliebige X-Achse (Vektor)
#' @return x_rescaled reskalierte X-Achse (Skalar oder Sektor)
#' @description
#' cheb_rescale reskaliert die fuer den Fit erzeugte Achse auf die Urspruengliche
#' @export
cheb_rescale <- function(x_cheb, x_axis) {
  ## Funktion zur Reskalierung vom [-1, 1]-Gitter
  ## auf das Ursprungsgitter (in diesem Fall - Lat)
  x_rescaled <- (1/2 * (x_cheb + 1) * (max(x_axis) - min(x_axis))) + x_axis[1]
  return(x_rescaled)
}

##
#' @title Generating Chebyshev Polynomials of first kind
#' @param x_axis beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_t Chebyshev-Polynome Erster Art (Vektor)
#' @description
#' cheb_1st erzeugt Chebyshev Polynome erster Art aus beliebiger X-Achse
#' @export
cheb_1st <- function(x_axis, n){
  ## Funktion zur Erzeugung von Chebyshev-Polynomen Erster Art
  ## ## Fehlerabfrage nur mit Schwellwert. Korrigieren! Auch cheb_2nd
  x_cheb <- if (length(x_axis) > 7) cheb_scale(x_axis) else x_axis
  m <- n + 1
  # Rekursionsformel Wiki / Bronstein
  cheb_t_0 <- 1;  cheb_t_1 <- x_cheb;
  cheb_t <- cbind(cheb_t_0, cheb_t_1)
  if (n >= 2) {
    for (i in 3:m) {
      cheb_t_i <- 2 * x_cheb * cheb_t[,(i - 1)] - cheb_t[,(i - 2)]
      cheb_t <- cbind(cheb_t, cheb_t_i)
      rm(cheb_t_i)
    }
  }
  return(cheb_t)
}

##
#' @title Generating Chebyshev Polynomials of second kind
#' @param x_axis beliebigie X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_u Chebyshev-Polynome Zweiter Art (Vektor)
#' @description
#' cheb_2nd erzeugt Chebyshev Polynome zweiter Art aus beliebiger X-Achse
#' @export
cheb_2nd <- function(x_axis, n){
  ## Funktion zur Erzeugung von Chebyshev-Polynomen Zweiter Art
  ## ##
  x_cheb <- if (length(x_axis) > 7) cheb_scale(x_axis) else x_axis
  m <- n + 1
  cheb_u_0 <- 1; cheb_u_1 <-  2*x_cheb
  cheb_u <- cbind(cheb_u_0, cheb_u_1)
  if (n >= 2) {
    for (i in 3:m) {
      cheb_u_i <- 2 * x_cheb * cheb_u[,(i - 1)] - cheb_u[,(i - 2)]
      cheb_u <- cbind(cheb_u, cheb_u_i)
      rm(cheb_u_i)
    }
  }
  return(cheb_u)
}

##
#' @title Calculation of Values of the model fit
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model gefiltertes Modell (Skalar oder Vektor)
#' @description
#' cheb_model berechnet aus den Chebyshev-Koeffizienten die Y-Werte
#' @export
cheb_model_filter <- function(x_axis, cheb_coeff) {
  ## Funktion zur Berechnung der Y-Werte aus X-Stellen und Cheb-Koeffizienten
  ## ##
  n <- length(cheb_coeff) - 1
  cheb_t <- cheb_1st(x_axis, n)
  cheb_model <- cheb_t %*% cheb_coeff
  return(cheb_model)
}

##
#' @title Calculation of the values of the first derivation
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model_deriv_1st Erste Ableitung des gefilterten Modells (Skalar oder Vektor)
#' @description
#' cheb_deriv_1st berechnet aus den Chebyshev-Koeffizienten die Werte der ersten Ableitung
#' @export
cheb_deriv_1st <- function(x_axis, cheb_coeff) {
  ## Funktion zur Berechnung der Y-Werte der Ableitung des Modells
  ## aus X-Stellen und Chebyshev-Koeffizienten
  ## ##
  if (length(x_axis) != 0) { ### ueberpruefen, ob noetig
    n <- length(cheb_coeff) - 1
    m <- n + 1
    cheb_u <- cheb_2nd(x_axis, n)

    # berechnung der ableitung der polynome erster art
    # rekursionsformel 0
    # dT/dx = n * U_(n-1)

    cheb_t_deriv_1st <- if (length(x_axis) == 1) (1:n)*t(cheb_u[,1:n]) else t((1:n) * t(cheb_u[,1:n]))
    cheb_t_deriv_1st <- cbind(0, cheb_t_deriv_1st)
    cheb_model_deriv_1st <- cheb_t_deriv_1st %*% cheb_coeff

    return(cheb_model_deriv_1st)
  }
}

##
#' @title Calculation of the values of the second derivation
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model_deriv Zweite Ableitung des gefilterten Modells (Skalar oder Vektor)
#' @description
#' cheb_deriv_2nd berechnet aus den Chebyshev-Koeffizienten die Werte der zweiten Ableitung
#' @export
cheb_deriv_2nd <- function(x_axis, cheb_coeff) {
  n <- length(cheb_coeff) - 1
  #  m <- n + 1
  l <- length(x_axis)
  cheb_t <- cheb_1st(x_axis, n)
  cheb_u <- cheb_2nd(x_axis, n)
  x_cheb <- cheb_scale(x_axis)

  cheb_t_deriv_2nd <- t((0:n) * t(t((0:n + 1) * t(cheb_t )) - cheb_u)) / (x_cheb ** 2 - 1)
  cheb_t_deriv_2nd[1,] <- (-1) ** (0:n) * ((0:n) ** 4 - (0:n) ** 2) / (3)
  cheb_t_deriv_2nd[l,] <- ((0:n) ** 4 - (0:n) ** 2) / (3)

  cheb_model_deriv_2nd <- cheb_t_deriv_2nd %*% cheb_coeff

  return(cheb_model_deriv_2nd)
}

##
#' @title Curve Fitting with Chebyshev Polynomials
#' @param d Zu fittender Datensatz/Zeitreihe (Vektor)
#' @param x_axis Beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_model Werte des gefilterten Modells
#' @description
#' \code{cheb_fit} fittet ein Chebyshev-Polynom beliebiger Ordnung an einen Datensatz/Zeitreihe mittels Least Squares Verfahren
#' @export
cheb_fit <- function(d, x_axis, n){
  ## Herausfiltern von fehlenden Werten (NAs)
  mss_ind  <- which(is.na(d))

  # Fallunterscheidung fuer NAs im Datensatz
  if (length(mss_ind) >= 1) {
    cheb_t <- cheb_1st(x_axis[-mss_ind], n)
  } else {
    cheb_t <- cheb_1st(x_axis, n)
  }

  ## modell berechnungen
  # berechnung der koeffizienten des polyfits
  if (length(mss_ind) >= 1) {
    cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d[-mss_ind]
  } else {
    cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d
  }

  # berechnung des gefilterten modells
  x_cheb <- cheb_scale(x_axis)
  cheb_model <- cheb_model_filter(x_cheb, cheb_coeff)

  # uebergabe der Variablen
  return(cheb_model)
}

##
#' @title Curve Fitting with Chebyshev Polynomials and Finding of its Roots
#' @param d Zu fittender Datensatz/Zeitreihe (Vektor)
#' @param x_axis Beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @param roots_bound_lower Unterer Rand des Bereichs der Nullstellensuche
#' @param roots_bound_upper Oberer Rand des Bereichs der Nullstellensuche
#' @return cheb_list Liste berechneter Parameter (Koeffizienten, gefiltertes Modell, erste und zweite Ableitung des gefilterten Modells, Extremstellen und -Werte)
#' @description
#' \code{cheb_fit.extr} fittet ein Chebyshev-Polynom beliebiger Ordnung an einen Datensatz/Zeitreihe mittels Least Squares Verfahren
#' @export
#' @importFrom rootSolve uniroot.all
cheb_find_extr <- function(d, x_axis, n, roots_bound_lower = NA, roots_bound_upper = NA){

  x_cheb <- cheb_scale(x_axis)
  cheb_t <- cheb_1st(x_axis, n)

  ## modell berechnungen
  # berechnung der koeffizienten des polyfits
  cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d

  # Berechnung der Extrema ueber Nullstellen der ersten Ableitung
  extr <- uniroot.all(cheb_deriv_1st, cheb_coeff = cheb_coeff, lower = -1, upper = 1)
  # reskalierung der Extrema auf normale Lat- Achse
  extr_x <- if (length(extr) != 0) cheb_rescale(extr, x_axis = x_axis)

  # ueberpruefen, welche Extrema im gesuchten Bereich liegen
  if (!is.na(roots_bound_lower) | !is.na(roots_bound_upper)) {
    ind <- which(extr_x >= roots_bound_lower & extr_x <= roots_bound_upper)
    extr <- extr[ind]
    extr_x <- extr_x[ind]
  }
  extr.y <- if (length(extr_x) != 0) cheb_model_filter(x_axis = extr, cheb_coeff = cheb_coeff)
  extr_deriv_2nd <- if (length(extr) != 0) cheb_deriv_2nd(x_axis = extr, cheb_coeff = cheb_coeff)

  cheb_list <- list(extr_x = extr_x,
                    extr.y = extr.y,
                    extr_deriv_2nd = extr_deriv_2nd)
  return(cheb_list)
}

##
#' @title Routine to find maximum values of a curve
#' @param d Zu fittender Datensatz
#' @param x_axis beliebiege X-Achse
#' @param n Ordnung des Skalars
#' @param maxima_bound_lower Unterer Rand des Bereichs der Maxima-Suche
#' @param maxima_bound_upper Oberer Rand des Bereichs der Maxima-Suche
#' @return max_list Positionen und Werte der Maxima als Liste
#' @description
#' \code{cheb_find_max} fittet ein Polynom und sucht mittel dessen Ableitung die Maxima des Datensatzes
#' @export
#' @importFrom rootSolve uniroot.all
cheb_find_max <- function(d, x_axis, n, maxima_bound_lower = NA, maxima_bound_upper = NA){
  x_cheb <- cheb_scale(x_axis)
  cheb_t <- cheb_1st(x_axis, n)

  ## modell berechnungen
  # koeffizienten d poly fits
  cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d

  # berechnen d maxima
  # nullstellen d ableitung
  extr <- uniroot.all(cheb_deriv_1st, cheb_coeff = cheb_coeff, lower = -1, upper = 1)

  # reskalierung der Extrema auf normale Lat- Achse
  extr_x <- cheb_rescale(extr, x_axis = x_axis)

  # ueberpruefen, welche Extrema im gesuchten Bereich liegen
  if (!is.na(maxima_bound_lower) | !is.na(maxima_bound_upper)) {
    ind <- which(extr_x >= maxima_bound_lower & extr_x <= maxima_bound_upper)
    extr <- extr[ind]
    extr_x <- extr_x[ind]
  }

  # ueberpruefen, welche Extrema Maxima sind
  if (length(extr) != 0) {
    extr_deriv_2nd <- cheb_deriv_2nd(x_axis = extr, cheb_coeff = cheb_coeff)

    # filtern der maxima | wert d zweiten ableitung < 0
    ind_max <- which(extr_deriv_2nd < 0)
    if (length(ind_max) != 0) {
      max_x <- extr_x[ind_max]
      max_y <- cheb_model_filter(x_axis = extr[ind_max], cheb_coeff = cheb_coeff)
    } else {
      max_x <- NA; max_y <- NA
    }
  } else {
    max_x <- NA; max_y <- NA;
  }
  max_list <- list(max_x = max_x,
                   max_y = max_y)
  return(max_list)
}


if (tau < tauAlpha){
    AlphaE = 1

}else{

    AlphaE = Alpha - ((Alpha - 1.0) * (1.0 - tau) / (1.0 - tauAlpha))
}
energyLimitedEvaporation= (evapoTranspirationPriestlyTaylor / Alpha) * AlphaE * tau


#data_url <- "https://files.datapress.com/london/dataset/2011-boundary-files/2011_london_boundaries.zip"
#zip_fn <- "london.zip"
#download.file(data_url, zip_fn)
#unzip(zip_fn)

library(maptools)
library(rgdal)
library(data.table)
library(ggplot2)
library(plyr)
library(gganimate)

set.seed(33333334)

crswgs84=CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")

lon <- maptools::readShapePoly("LSOA_2011_BFE_City_of_London.shp")
cam <- readShapePoly("LSOA_2011_BFE_Camden.shp")
lon <- rbind(lon, cam)
plot(lon)

lon_coords <- sp::coordinates(lon)  # Coordinates of polygon centers
lon_nbs <- spdep::poly2nb(lon)  # Neighbour relationships based on a triangulation

rownames(lon_coords) <- lon$LSOA11NM
plot(lon)
points(lon_coords)
points(lon_coords[2,1], lon_coords[2,2], col="red")

lon_w_mat <- spdep::nb2mat(lon_nbs)  # Weight matrix between the nodes.
colnames(lon_w_mat) <- rownames(lon_w_mat)
hist(Filter(f = function(x) x > 0, x = as.vector(lon_w_mat)))

num_nbs <- length(lon_nbs)
threshold <- 0.16
plot(lon)
points(lon_coords)

adj_matrix <- lon_w_mat>threshold
dimnames(adj_matrix) <- NULL

edges <- which(adj_matrix, arr.ind = TRUE)
apply(edges, 1, function(r){
  lines(lon_coords[r,1], lon_coords[r,2], col="blue")
})

#transmission rate
beta <- 3

#recovery rate
gamma <- 1

n.nodes <- ncol(adj_matrix)
status.vector <- rep("S", n.nodes)

status.vector[sample(length(status.vector), 1)] <- "I"
names(status.vector) <- 1:n.nodes
colnames(adj_matrix) <- rownames(adj_matrix) <- 1:n.nodes

#matrix and vector to store results at each time step
time.steps <- rep(NA, 2*n.nodes)
status.matrix <- matrix(NA, nrow = 2*n.nodes, ncol = n.nodes)

time.steps[[1]] <- 0
status.matrix[1,] <- status.vector

#run until
stopping.time <- 10

#initialise time
current.time <- 0
time.step <- 1

while(current.time < stopping.time){
  # message for debugging
  # message(paste(c("time step:", time.step, "current time:", current.time), collapse = " "))

  #calculate vector recovery rates for each infected person
  recovery.rates <- rep(gamma, sum(status.vector=="I"))
  names(recovery.rates) <- c(1:n.nodes)[status.vector=="I"]

  #infection rates for each suceptiable person
  infection.rates <- rowSums(adj_matrix[,status.vector=="I",drop=FALSE])[status.vector=="S"]
  infection.rates <- infection.rates*beta
  names(infection.rates) <- c(1:n.nodes)[status.vector=="S"]

  #sample event
  event.rate <- sum(recovery.rates, infection.rates)
  if(event.rate<=0){
    #we've reached the end of the simulation
    break
  }

  p <- c(recovery.rates, infection.rates)/event.rate
  event.num <- sample(names(p), 1, prob = p)

  #update status
  if(status.vector[event.num]=="S"){
    status.vector[event.num] <- "I"
  } else if (status.vector[event.num]=="I") {
    status.vector[event.num] <- "R"
  } else {
    stop("bad index!")
  }

  #sample time to event
  current.time <- current.time + rexp(1, rate = event.rate)
  time.step <- time.step + 1

  #update results
  time.steps[[time.step]] <- current.time
  status.matrix[time.step, ] <- status.vector
}

time.steps <- time.steps[1:time.step]
status.matrix <- status.matrix[1:time.step,]

results.df <- data.frame(t(apply(status.matrix, 1, function(r){
  table(factor(r, levels = list("S", "I", "R")))
  })), stringsAsFactors = FALSE)

results.df$time <- time.steps
results.df <- melt(results.df, id.vars="time")

# Plot
ggplot(results.df, aes(x=time, y=value, col=variable)) + geom_line()

results.df <- melt(status.matrix)
colnames(results.df) <- c("time step", "node", "status")
results.df <- cbind(results.df, lon_coords[results.df$node,], rownames(lon_coords))
results.df$node <- rownames(lon_coords)[results.df$node]
colnames(results.df) <- c("time step", "node", "status", "lat", "long", "area")

lon@data$id = rownames(lon@data)
london.points = fortify(lon, region="id")
london.df = join(london.points, lon@data, by="id")

plot.df <- do.call(rbind, lapply(unique(results.df$`time step`), function(t){
  temp.df <- results.df[results.df$`time step`==t,]
  london.df$status <- temp.df$status[match(as.character(london.df$LSOA11NM), temp.df$node)]
  london.df$time <- t
  return(london.df)
}))

gg <- ggplot(plot.df) +
  aes(long,lat, group=group, fill=status) +
  geom_polygon() +
  geom_path(color="white") +
  coord_equal() +
  # Here comes the gganimate code
  transition_manual(time)

anim_save("london.gif",animate(gg))

contents <- base64enc::base64encode("london.gif")
tag <- '<img src="data:image/gif;base64,%s">'
IRdisplay::display_html(sprintf(tag, contents))


#' Curbe ball algorithm to generate random networks with given an igraph network
#'
#' This extract the adjacency matrix from an igraph object and generates a randomized version
#' of the network with the same row and column totals, the results have the same in and out degree sequence
#' than the original network. The diagonals are not avoided so it can generate self-links or cannibalism in
#' the context of food-webs. In the case that the network has multiple components (or disconnected networks)
#' the algorithm simulates around the same number of components, if the original network has 1 component
#' the algorithm enforces that the results have all 1 component. If the edge attribute weight is present
#' and istrength=TRUE then the weigth is additionally randomized keeping the column sum equal to the original matrix.
#'
#' Based on:
#'
#' @references Strona, G. et al. 2014. A fast and unbiased procedure to randomize ecological binary matrices with
#' fixed row and column totals. -Nat. Comm. 5: 4114. doi: 10.1038/ncomms5114
#'
#' @aliases curveBall
#' @param g igraph object to extract adjacency matrix
#' @param nsim number of generated random networks
#' @param istrength if TRUE the edge attribute weight is taken as interaction strength and randomized keeping the column sum equal to the original matrix.
#'
#' @return a list of randomized igraph objects
#' @export
#'
#' @examples
#'
#' curve_ball(netData[[1]])
#'
curve_ball<-function(g,nsim=1000,istrength=FALSE){
  stopifnot(class(g)=="igraph")

  m <- get.adjacency(g,sparse=FALSE)

  if(components(g)$no>1) {

    nets<- lapply(1:nsim, function (x) {
      # repeat {
      RC <- dim(m)
      R  <- RC[1]
      C  <- RC[2]
      hp <- list()
      for (row in 1:dim(m)[1]) {hp[[row]] <- (which(m[row,]==1))}
      l_hp <- length(hp)
      for (rep in 1:5*l_hp){
        AB <- sample(1:l_hp,2)
        a  <- hp[[AB[1]]]
        b  <- hp[[AB[2]]]
        ab <- intersect(a,b)
        l_ab <- length(ab)
        l_a <- length(a)
        l_b <- length(b)
        if ((l_ab %in% c(l_a,l_b))==FALSE){
          tot <- setdiff(c(a,b),ab)
          l_tot <- length(tot)
          tot <- sample(tot, l_tot, replace = FALSE, prob = NULL)
          L <- l_a-l_ab
          hp[[AB[1]]]  <-  c(ab,tot[1:L])
          hp[[AB[2]]]  <-  c(ab,tot[(L+1):l_tot])}

      }
      rm <- matrix(0,R,C)
      for (row in 1:R){rm[row,hp[[row]]] <- 1}

      g <- graph_from_adjacency_matrix(rm,mode="directed")
      return(g)
    })
  } else {   #if the the networks has only one component enforce that in the simulations

    nets<- lapply(1:nsim, function (x) {
      repeat {
      RC <- dim(m)
      R  <- RC[1]
      C  <- RC[2]
      hp <- list()
      for (row in 1:dim(m)[1]) {hp[[row]] <- (which(m[row,]==1))}
      l_hp <- length(hp)
      for (rep in 1:5*l_hp){
        AB <- sample(1:l_hp,2)
        a  <- hp[[AB[1]]]
        b  <- hp[[AB[2]]]
        ab <- intersect(a,b)
        l_ab <- length(ab)
        l_a <- length(a)
        l_b <- length(b)
        if ((l_ab %in% c(l_a,l_b))==FALSE){
          tot <- setdiff(c(a,b),ab)
          l_tot <- length(tot)
          tot <- sample(tot, l_tot, replace = FALSE, prob = NULL)
          L <- l_a-l_ab
          hp[[AB[1]]]  <-  c(ab,tot[1:L])
          hp[[AB[2]]]  <-  c(ab,tot[(L+1):l_tot])}

      }
      rm <- matrix(0,R,C)
      for (row in 1:R){rm[row,hp[[row]]] <- 1}

      g <- graph_from_adjacency_matrix(rm,mode="directed")
      if(components(g)$no==1)
         break
      }
      return(g)
    })
  }

  if(istrength) {
    m <- get.adjacency(g,sparse=FALSE,attr="weight")
    r <- dim(m)[1]
    c <- dim(m)[2]

    wnets<- lapply(nets, function (x) {
      m1 <- get.adjacency(x,sparse=FALSE)
      for(i in seq_len(c) ){
        ss <- sample(m[,i])
        ss <- ss[ss>0]
        k <- 1
        for( j in seq_len(r)){
          if(m1[j,i]>0 ) {
            m1[j,i] <- ss[k]
            k <- k+1
          }
        }
      }
      graph_from_adjacency_matrix(m1,mode="directed",weighted = "weight")
    })
  } else {
    return(nets)
  }
}

#' @export
curveBall<-function(g,nsim=1000,istrength=FALSE){curve_ball(g,nsim,istrength)}

#' Generate directed Erdos-Renyi random networks with at least 1 basal node and only one component
#'
#' This uses the igraph's function sample_gnm to generate nsim random networks with the same number of nodes
#' and links than the parameter ig and two restrictions:
#' 1) at least one basal species/node, that is a species that has no prey, 2) 1 connected component so there is no
#' disconnected species or sub-community.
#'
#' @param ig igraph object with parameters to use in the random network simulations: number of species/nodes
#'           and number of links/edges
#' @param nsim number of simulations
#'
#' @aliases generateERbasal
#'
#' @return a list with igraph objects
#' @export
#'
#' @examples
#'
#' generateERbasal(netData[[1]])
generate_er_basal <- function(ig,nsim=1000){
  if(!is_igraph(ig))
    stop("Parameter ig must be an igraph object")

  size <- vcount(ig)

  links <- ecount(ig)

  er <- lapply(1:nsim, function (x) {
    e <- sample_gnm(size, links, directed = TRUE)
    basal <- length(V(e)[degree(e,mode="in")==0])
    while(components(e)$no>1 | basal==0){
      e <- sample_gnm(size, links,directed = TRUE)
      basal <- length(V(e)[degree(e,mode="in")==0])
    }
    return(e) })
}

#' @export
generateERbasal <- function(ig,nsim=1000){generate_er_basal(ig,nsim)}


##' Vortex transform.
##'
##' Fringe analysis by Vortex aka Spiral Quadrature transform.
##'
##' @param imagedata matrix containing the interferogram data
##' @param cp list with circle parameters describing interferogram location. Defaults to NULL
##' @param filter size of filter to remove background
##' @param fw.o size of gaussian blur to smooth orientation estimate
##' @param options A list with general fitting and display options. See [psfit_options()].
##'
##' @return a list with wavefront estimates, wrapped phase, modulation, etc.
##'
##' @seealso This is one of two routines provided for analysis of single interferograms,
##'   along with [fftfit()]. This \emph{may} be suitable for interferograms with
##'   closed fringes.
##'
##' @details Implements the Vortex or spiral phase quadrature transform method
##'  of Larkin et al. (2001) [https://doi.org/10.1364/JOSAA.18.001862] including the
##'  fringe orientation estimation approach in Larkin (2005) [https://doi.org/10.1364/OPEX.13.008097].
##'  Thanks to Steve Koehler for ideas on implementation details.
##'
##' @section Warning:
##'   This routine is offered as is with no license, as it may be in violation of one or more
##'   US and international patents.
##'
##' @examples
##' require(zernike)
##' fpath <- file.path(find.package(package="zernike"), "psidata")
##' fname <- "Image197.jpg"
##' img <- load.images(file.path(fpath, fname))
##'
##' # parameters for this run
##'
##' source(file.path(fpath, "parameters.txt"))
##'
##' # target SA coefficients for numerical null.
##'
##' sa.t <- sconic(diam,roc,lambda=wavelength)
##' zopt <- psfit_options()
##' zopt$satarget <- sa.t
##'
##' # display an interferogram
##'
##' if (tolower(.Platform$OS.type) == "windows") windows() else x11()
##' image(1:nrow(img), 1:ncol(img), img, col=grey256, asp=1,
##'  xlab="X", ylab="Y", useRaster=TRUE)
##' mtext("Sample Interferogram")
##'
##' if (tolower(.Platform$OS.type) == "windows") windows() else x11()
##' vfit <- vortexfit(img, filter=15, fw.o=10, options=zopt)
vortexfit <- function(imagedata, cp=NULL, filter=NULL, fw.o=10, options=psfit_options()) {

  nr <- nrow(imagedata)
  nc <- ncol(imagedata)
  npad <- nextn(max(nr,nc))
  xs <- (-npad/2):(npad/2-1)
  im <- padmatrix(imagedata, npad=npad, fill=mean(imagedata))
  im.fft <- fftshift(fft(im))
  if (is.null(filter)) {
    sldata <- pick.sidelobe(imagedata, logm=TRUE)
    filter <- sldata$filter
  }
  if (filter > 0) {
    xss <- 2*xs/filter
    rho2 <- outer(xss, xss, function(x,y) x^2+y^2)
    im.fft <- im.fft*(1-exp(-rho2/2))
  }
  theta <- function(x,y) atan2(y,x)
  phi <- outer(xs, xs, theta)
  im.nb <- Re(fft(fftshift(im.fft), inv=TRUE))/(npad^2)
  D <- fft(fftshift(exp(1i*phi)*im.fft), inv=TRUE)/(npad^2)
  D2 <- fft(fftshift(exp(2*1i*phi)*im.fft), inv=TRUE)/(npad^2)
  sx <- (D^2-im.nb*D2)[1:nr, 1:nc]
  if (fw.o > 0) {
    rsx <- gblur(Re(sx), fw=fw.o)
    isx <- gblur(Im(sx), fw=fw.o)
    sx <- rsx + 1i*isx
  }
  orient <- Arg(sx)
  mod.o <- Mod(sx)
  if (options$plots) {
    image(1:nr, 1:nc, orient, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    mtext("Orientation")
  }
  dir <- wrap(pi * qpuw(orient, mod.o))
  if (options$plots) {
    image(1:nr, 1:nc, dir, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    mtext("Direction")
  }
  Q <- Re(D[1:nr, 1:nc] * exp(-1i*dir))
  phase <- atan2(Q, im.nb[1:nr, 1:nc])
  mod <- sqrt(Q^2+(im.nb[1:nr, 1:nc])^2)
  mod <- (mod-min(mod))/(max(mod)-min(mod))
  if (is.null(cp)) {
    cp <- circle.pars(mod, plot=options$plots)
  }
  cp.orig <- cp
  if (options$crop) {
    mod <- crop(mod, cp)$im
    phase <- crop(phase, cp)
    cp <- phase$cp
    phase <- phase$im
  }
  nr <- nrow(phase)
  nc <- ncol(phase)
  prt <- pupil.rhotheta(nr, nc, cp)
  phase[is.na(prt$rho)] <- NA
  class(phase) <- "pupil"
  wf.raw <- switch(options$puw_alg,
                   qual = qpuw(phase, mod),
                   brcut = brcutpuw(phase),
                   qpuw(phase, mod)
  )
  wf.raw <- options$fringescale*wf.raw
  class(wf.raw) <- "pupil"
  wf.nets <- wf_net(wf.raw, cp, options)
  outs <- list(im.bgclean=im.nb[1:nr, 1:nc], orient=orient, dir=dir, phi=phase, mod=mod,
       cp=cp, cp.orig=cp.orig,
       wf.net=wf.nets$wf.net, wf.smooth=wf.nets$wf.smooth,
       wf.residual=wf.nets$wf.residual, fit=wf.nets$fit, zcoef.net=wf.nets$zcoef.net)
  class(outs) <- append(class(outs), "wf_fitted")
  outs
}


## Ch06.확률분포 : 도수분포(frequency table)의 %

abs <- c(0:4)
stu.n <- c(40,35,15,7,3)

pro.stu <- data.frame(abs,stu.n)

prop.stu1 <- prop.table(stu.n)

barplot(prop.stu1 ~ abs,
        main ="확률분포",
        xlab = "결석일수",
        ylab = "학생수")

# 이산확률변수와 연속확률변수의 차이 이해 (특정수치(사건 수, 방문자 수 등) vs. 연속변수(몸무게, 체온, 통근시간 등)

# 확률밀도함수: d~ 개별 건수에 대한 확률 확인
# 누적분포함수(점수): p~ 점수(숫자)를 가지고 몇 %에 해당하는지를 파악
# 누적분포함수(확률): q~ 확률을 가지고 몇 점에 해당하는지를 파악

## 01.이항분포
# 이항분포 확률밀도 : 확률이 두 가지로 구분되어 있을 경우 활용하는 방법
# dbinom(성공회수, size(시행횟수(n)), prob(성공확률)

# fortune 쿠키 성공사례 : 식당에서 쿠키를 나누어줌
# 시행횟수: 3명
# 성공확률: 90% (쿠키가 들어있을 확률)
# P(X = a) 확률 계산
dbinom(0, size=3, prob=0.9)
dbinom(1, size=3, prob=0.9)
dbinom(2, size=3, prob=0.9)
dbinom(3, size=3, prob=0.9)

# 이항분포 확률밀도 graph
y <- dbinom(0:3, size=3, prob=0.9)
plot(0:3, y,    # x를 0부터 3까지 4개로 쪼개라
     type='h',  #   유형이 달라지면, 그래프의 모양도 달라짐. 옵션은 찾아봐야 함
     lwd=10,
     col="red",
     ylab="확률",
     xlab="성공확률 X",
     main = "이항분포")

# 이항분포 누적확률계산
# 이하 : P(X <= a) lower.tail = TRUE * 여기가 옵션 넣을 때 매우 중요한 부분임. R의 기본 옵션은 이하와 초과로 구분
# 초과: P(X > a) lower.tail = FALSE
# P(X <= 1)이하로 받을 확률 => 3번 중에 1번 이하로 성공할 확률(누적확률이므로 pbinom사용 )
pbinom(1, size=3, prob=0.9, lower.tail = TRUE)

# 1명이상 받을 확률: P(X >= 1) 확률 계산, 초과이므로 최소 0을 넣어야 함. lowe.tail 옵션은 FALSE
pbinom(0, size=3, prob=0.9, lower.tail = FALSE)

# 누적이항분포  graph

plot(pbinom(0:3, size=3, prob=0.9),
     type='h',
     lwd=10,
     col="red",
     main = "누적이항분포")

## 퀴즈
# 성공확률 0.7, 10명중 7명 이상: P(X >= 7) 확률 계산

pbinom(6, size=10, prob=0.7, lower.tail = FALSE)

# 확률밀도 graph
y <- dbinom(0:10, size=10, prob=0.7)
plot(0:10, y,
     type='h',
     lwd=10,
     col="red",
     ylab="확률",
     xlab="성공확률 X",
     main = "이항분포")

# 누적이항분포  graph
plot(pbinom(0:10, size=10, prob=0.7),
     type='h',
     lwd=10,
     col="red",
     main = "누적이항분포")


# Benjamini-Hochberg with two-sided p-values
BenjaminiHochberg = function(zscores, fdr_level) {
# zscores is a vector of z scores
# fdr_level is the desired level (e.g. 0.1) of control over FDR
# returns a binary vector where 0=nofinding, 1=finding at given FDR level
    N = length(zscores)
    pval2 = 2*pmin(pnorm(zscores), 1- pnorm(zscores))
    cuts = (1:N)*fdr_level/N
    bhdiff = sort(pval2)-cuts
    bhcutind2 = max(which(bhdiff < 0))
    bhcut2 = sort(pval2)[bhcutind2]
    0+{pval2 <= bhcut2}
}

args <- commandArgs(trailingOnly = TRUE)
z = as.numeric(t(as.matrix(read.csv(args[1], header=FALSE))))#testing
discoveries = BenjaminiHochberg(z, 0.1)
write.table(discoveries, args[2], row.names=FALSE, col.names=FALSE, sep=",")


[[[[[
   Show that a real r is Solovay random
   iff it is Martin-Lof random.

   An effective covering A_k of k is a function
   of k that enumerates bit strings s,
   which are the initial bits of the covered
   reals.  We assume that no s in A_k is a
   proper prefix or extension of another.
   Thus the measure of the cover A_k of k is
   exactly Sum_{s in A_k} of 2^{-|s|},
   where |s| is the length of the bit string s.
]]]]]

[First part: not M-L random ===> not Solovay random]

[
This is immediate.  We are given coverings A_k such
that real r is in A_k for all k and the measure of A_k <= 2^{-k}.
It follows immediately that r is in infinitely many of the
A_k and the sum of the measure of A_k summed over all k converges.
Thus r is not Solovay random.
]

[Second part: not Solovay random ===> not M-L random]

[
Suppose that a real r is in infinitely many of the
coverings A_n and that Sum_k mu A_n <= 2^c.
Consider B_k defined as the set of all reals that are
in at least 2^{k+c} of the A_n.
Then r is in all of the B_k and the measure of
B_k is <= 2^{-k}, so r is not Martin-Lof random.

Now let's program this!

Instead, I'll program B_k which is the set of all reals
that are in at least k of the A_n.
The proof then results from considering B_{2^{k+c}} .

The main function has two parameters, the stage n, and
the number of times something has to be repeated to
be taken into account.  At stage n, with number
of repeats r, we look at A_0 through A_n for time n,
and put into our condensed result cover only subintervals
that are covered at least r times.

The key auxiliary function given n generates A_0 through A_n for time n,
then expands all intervals to the same max length and counts how
many times each is repeated.  Then it is easy to select those that
are covered the requisite number of times.

First step is to run A_0 through A_n for time n and append the results.
Then we get the max length and do a binary tree walk.  We start with
s and see if it's a prefix of at least r things.
If so, s will be in our result, and we backtrack.
If not, if s has max length, we stop recursion.
Otherwise, we look at s0 and at s1.
And we start with s = nil.
This gives our covering at stage n,
then we have to eliminate overlaps to
get our final result.
]

[
 Test case: A_n is defined to be the set of
 all natural numbers greater than n,
 where k is represented as k 1's followed by a 0.
 Then measure of A_n is 2^{-n-1}, and
 1=10 is in one of the A_n, 2=110 is in two of them,
 3=1110 is in three of them, etc.

 I.e., 1=10 is only in A_0,
       2=110 is only in A_0 & A_1,
       3=1110 is only in A_0 A_1 & A_2, etc.

 In this case the total measure of the A_n is
 1/2 + 1/4 + 1/8 + ... = 1.
 For the proof in general, all we know is that
 this total measure converges to a finite sum, not 1.
]
define (A n) [displays infinite set 1^k 0, k > n]
  let (loop k)
      cons display
         append base10-to-2 - ^ 2 k 1 [2^k - 1 = k 1's]
            cons 0 nil [followed by a 0 bit]
      (loop + k 1)
  (loop + n 1)

define      A
value       (lambda (n) ((' (lambda (loop) (loop (+ n 1)))) ('
             (lambda (k) (cons (display (append (base10-to-2 (
            - (^ 2 k) 1)) (cons 0 nil))) (loop (+ k 1)))))))

[now put together in one list stage n of A_0 through A_n]
define (sum n)
   let (loop k sum)
      if > k n sum
      (loop + k 1
            append caddr try n cons cons "' cons A nil cons k nil nil
                   sum)
   (loop 0 nil)

define      sum
value       (lambda (n) ((' (lambda (loop) (loop 0 nil))) (' (
            lambda (k sum) (if (> k n) sum (loop (+ k 1) (appe
            nd (car (cdr (cdr (try n (cons (cons ' (cons A nil
            )) (cons k nil)) nil)))) sum)))))))

[
 (count x y)
 Now count how many times something x is contained in /
 is an extension of an element of y
]
define (count x y)
   if atom y 0
   if (is-prefix-of? car y x) + 1 (count x cdr y)
   (count x cdr y)

define      count
value       (lambda (x y) (if (atom y) 0 (if (is-prefix-of? (c
            ar y) x) (+ 1 (count x (cdr y))) (count x (cdr y))
            )))

define (is-prefix-of? x y) [is bit string x a prefix of bit string y?]
   if atom x  true
   if atom y  false
   if = car x car y (is-prefix-of? cdr x cdr y)
   false

define      is-prefix-of?
value       (lambda (x y) (if (atom x) true (if (atom y) false
             (if (= (car x) (car y)) (is-prefix-of? (cdr x) (c
            dr y)) false))))

[get maximum length of a list of bit strings]
define (max-length list)
   if atom list   0
   let len1 length car list
   let len2 (max-length cdr list)
   if > len1 len2
      [then] len1
      [else] len2

define      max-length
value       (lambda (list) (if (atom list) 0 ((' (lambda (len1
            ) ((' (lambda (len2) (if (> len1 len2) len1 len2))
            ) (max-length (cdr list))))) (length (car list))))
            )

[
 Now we get what (sum n) covers with multiplicity >= k.
 The measure of the multiplicity k covering will
 be bounded by the finite total measure (here 1) divided by k.
]

define (exceeds-count n k)
   let sum-n (sum n)
   let max-length-sum-n (max-length sum-n)
   (look-at nil)

define      exceeds-count
value       (lambda (n k) ((' (lambda (sum-n) ((' (lambda (max
            -length-sum-n) (look-at nil))) (max-length sum-n))
            )) (sum n)))

[
 This routine has free parameters sum-n, max-length-sum-n, k.
 It gets us the MINIMAL multiplicity >= k covering for (sum n)!
]
define (look-at x) [produces strings x covered with multiplicity >= k in (sum n)]
   if = length x max-length-sum-n
      let n (count x sum-n)
      if >= n k cons x nil [found an interval x that is covered >= k times]
                nil  [didn't find an interval x that is covered >= k times]
   [otherwise break x into subintervals]
   let x0 append x cons 0 nil
   let x1 append x cons 1 nil
   let v  append (look-at x0)
                 (look-at x1)
   [consolidate subintervals?]
   if = v cons x0 cons x1 nil [yes!] cons x nil
          [no, leave covering as is] v

define      look-at
value       (lambda (x) (if (= (length x) max-length-sum-n) ((
            ' (lambda (n) (if (>= n k) (cons x nil) nil))) (co
            unt x sum-n)) ((' (lambda (x0) ((' (lambda (x1) ((
            ' (lambda (v) (if (= v (cons x0 (cons x1 nil))) (c
            ons x nil) v))) (append (look-at x0) (look-at x1))
            ))) (append x (cons 1 nil))))) (append x (cons 0 n
            il)))))

[
 Now we put this all together into B_k, which is
 the limit as n goes to infinity of (exceeds-count n k),
 k fixed, n --> infinity.

 I.e., B_k is what A_0, A_1, A_2, ... covers with
 multiplicity >= k.

 Thus the measure of B_k will be bounded by the
 total measure of the A_n (if it exists) divided by k.

 The main problem is to avoid overlaps in B_k,
 which we do using a completely general algorithm.
]

[list of intervals in covering so far]
[used to avoid overlapping intervals in covering]
define intervals ()

define      intervals
value       ()

define (process-all x) [process list of intervals x]
   if atom x  intervals
   let intervals append (process car x) intervals
   (process-all cdr x)

define      process-all
value       (lambda (x) (if (atom x) intervals ((' (lambda (in
            tervals) (process-all (cdr x)))) (append (process
            (car x)) intervals))))

define (process interval) [process individual interval]
   if (new-interval-covered-by-previous-one? interval intervals)
      [then don't need to repeat it]
      nil
   let holes (new-interval-covers-previous-ones interval intervals)
   if atom holes
      [then interval is fine as is]
      [output it with display!]
      cons display interval nil
   [get max granularity needed]
   let max (max-length holes)
   [convert everything to same granularity]
   let holes (extend-all holes max)
   [and remove overlap]
   [subtract will output residue with display]
   (subtract (extend interval max) holes)

define      process
value       (lambda (interval) (if (new-interval-covered-by-pr
            evious-one? interval intervals) nil ((' (lambda (h
            oles) (if (atom holes) (cons (display interval) ni
            l) ((' (lambda (max) ((' (lambda (holes) (subtract
             (extend interval max) holes))) (extend-all holes
            max)))) (max-length holes))))) (new-interval-cover
            s-previous-ones interval intervals))))

[returns true/false]
define (new-interval-covered-by-previous-one? interval intervals)
   if atom intervals  false
   if (is-prefix-of? car intervals interval)  true
   (new-interval-covered-by-previous-one? interval cdr intervals)

define      new-interval-covered-by-previous-one?
value       (lambda (interval intervals) (if (atom intervals)
            false (if (is-prefix-of? (car intervals) interval)
             true (new-interval-covered-by-previous-one? inter
            val (cdr intervals)))))

[returns set of previous intervals covered by this one]
define (new-interval-covers-previous-ones interval intervals)
   if atom intervals  nil
   if (is-prefix-of? interval car intervals)
      [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals)
      [else]                    (new-interval-covers-previous-ones interval cdr intervals)

define      new-interval-covers-previous-ones
value       (lambda (interval intervals) (if (atom intervals)
            nil (if (is-prefix-of? interval (car intervals)) (
            cons (car intervals) (new-interval-covers-previous
            -ones interval (cdr intervals))) (new-interval-cov
            ers-previous-ones interval (cdr intervals)))))

[produce set of all extensions of a given bit string to a given length]
[(assumed >= to its current length)]
define (extend bit-string len)
   if = len length bit-string
      [has correct length; return singleton set]
      cons bit-string nil
   append (extend append bit-string cons 0 nil len)
          (extend append bit-string cons 1 nil len)

define      extend
value       (lambda (bit-string len) (if (= len (length bit-st
            ring)) (cons bit-string nil) (append (extend (appe
            nd bit-string (cons 0 nil)) len) (extend (append b
            it-string (cons 1 nil)) len))))

[extend all the bit strings in a given list to the same length]
define (extend-all list len)
   if atom list   nil
   append (extend     car list len)
          (extend-all cdr list len)

define      extend-all
value       (lambda (list len) (if (atom list) nil (append (ex
            tend (car list) len) (extend-all (cdr list) len)))
            )

[subtract set of intervals y from set of intervals x]
[output residue with display!]
define (subtract x y)
   if atom x   nil
   if (is-in? car x y)
   [then]                    (subtract cdr x y)
   [else] cons display car x (subtract cdr x y)

define      subtract
value       (lambda (x y) (if (atom x) nil (if (is-in? (car x)
             y) (subtract (cdr x) y) (cons (display (car x)) (
            subtract (cdr x) y)))))

define (is-in? x l) [is x an element of list l?]
   if atom l     false
   if = x car l  true
   (is-in? x cdr l)

define      is-in?
value       (lambda (x l) (if (atom l) false (if (= x (car l))
             true (is-in? x (cdr l)))))

[
 Put it all together---Here is cover B_k,
 which is what is covered by A_0, A_1, A_2, ...
 with multiplicity >= k, and therefore has
 measure bounded by the total measure of the A_n
 divided by k.
 Supposing that this total measure is <= 2^c
 and considering B_{2^{k+c}},
 we see that if a real r is in infinitely many of
 the A_n, then it will be in all of the
 B_{2^{k+c}}, each of which has measure <= 1/2^k.
 Hence if a real r is not Solovay random,
 it follows that it will not be M-L random.
 Here we write the code for B_k, not for
 B_{2^{k+c}}.
]
define (B k)
   let intervals nil
   let (stage n)
      if = n 6 stop! [to stop test run---remove if real thing]
      let exceed-count (exceeds-count n k)
      let intervals (process-all exceed-count)
      (stage + 1 n)
   [go!!!!!]
   (stage 0)

define      B
value       (lambda (k) ((' (lambda (intervals) ((' (lambda (s
            tage) (stage 0))) (' (lambda (n) (if (= n 6) stop!
             ((' (lambda (exceed-count) ((' (lambda (intervals
            ) (stage (+ 1 n)))) (process-all exceed-count))))
            (exceeds-count n k)))))))) nil))

[k = multiplicity = repeated/covered 2 or more times in the A_n]
(B 2)

expression  (B 2)
display     (1 1 0)
display     (1 1 1 0)
display     (1 1 1 1 0)
display     (1 1 1 1 1 0)
display     (1 1 1 1 1 1 0)
display     (1 1 1 1 1 1 1 0)
value       stop!


# Kvantitativni podaci

trajanje.posmatranja <- sum(faithful$eruptions) + sum(faithful$waiting)
trajanje.posmatranja
trajanje.posmatranja <- trajanje.posmatranja / c(60, 60*24, 60*24*7)
trajanje.posmatranja

trajanja <- faithful$eruptions
trajanja
opseg <- range(trajanja)
opseg
# alternativni nacin
opseg <- c( min(trajanja), max(trajanja))
opseg
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 25
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
granice
izrezano <- cut(trajanja, granice, right=FALSE)
izrezano
frekfencija.trajanja <- table(izrezano)
barplot(frekfencija.trajanja)

cekanja <- faithful$waiting
opseg <- c( min(cekanja), max(cekanja))
donja.granica <- 45
gornja.granica <- 100
broj.podintervala <- 125
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(cekanja, granice, right=FALSE)
barplot(table(izrezano))

trajanja <- faithful$eruptions
hist(trajanja, right = FALSE)
hist(trajanja, breaks = 20, right = FALSE)
hist(trajanja,
     breaks = c(1.5, 2, 2.5, 3, 4.7, 5, 5.5),
     right = FALSE)
hist(trajanja,
     breaks = c(1.5, 2, 2.5, 3, 4.7, 5, 5.5),
     main = "Histogram za trajanje",
     xlab = "trajanje erupcije",
     col = c( "purple", "red", "blue"),
     right = FALSE)

cekanja <- faithful$waiting
hist(cekanja,
     breaks = 5,
     col = c( "purple", "red", "blue"),
     right = FALSE)

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / nrow(faithful)
relativna.frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / length(trajanja)
relativna.frekfencija.trajanja
relativna.frekfencija.trajanja <- frekfencija.trajanja / sum(frekfencija.trajanja)
relativna.frekfencija.trajanja

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
frekfencija.trajanja
kumulativna.frekfencija.trajanja <- cumsum(frekfencija.trajanja)
kumulativna.frekfencija.trajanja

cekanja <- faithful$waiting
donja.granica <- 45
gornja.granica <- 100
broj.podintervala <- 15
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
frekfencija.cekanja <- table(cut(cekanja, granice, right=FALSE))
frekfencija.cekanja
kumulativna.frekfencija.cekanja <- cumsum(frekfencija.cekanja)
kumulativna.frekfencija.cekanja

trajanja <- faithful$eruptions
donja.granica <- 1.5
gornja.granica <- 5.5
broj.podintervala <- 10
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
izrezano <- cut(trajanja, granice, right=FALSE)
frekfencija.trajanja <- table(izrezano)
kumulativna.frekfencija.trajanja <- cumsum(frekfencija.trajanja)
kumulativna.frekfencija.trajanja
plot(granice,c(0, kumulativna.frekfencija.trajanja) )
lines(granice,c(0, kumulativna.frekfencija.trajanja) )

cekanja <- faithful$waiting
donja.granica <- 40
gornja.granica <- 110
broj.podintervala <- 45
granice <- seq(donja.granica,
               gornja.granica,
               (gornja.granica-donja.granica)/broj.podintervala )
relativna.frekfencija.cekanja <-
  table(cut(cekanja, granice, right=FALSE))/ length(cekanja)
kumulativna.relativna.frekfencija.cekanja <- cumsum(relativna.frekfencija.cekanja)
kumulativna.relativna.frekfencija.cekanja
plot(granice,c(0, kumulativna.relativna.frekfencija.cekanja),
     xlab="cekanje(u minutama)",
     ylab="deo populacije")
lines(granice,c(0, kumulativna.relativna.frekfencija.cekanja) )

donja.granica <- -4
gornja.granica <- 4
broj.tacaka <- 40
x <- seq(donja.granica, gornja.granica,
         by = (gornja.granica-donja.granica)/broj.tacaka )
y <- sin (x)
plot(x,y)
lines(x,y)

trajanja <- faithful$eruptions
cekanja <- faithful$waiting
plot( trajanja, cekanja, xlab="trajanje", ylab= "cekanje")
model <- lm(cekanja ~ trajanja )
abline(model)

trajanja <- faithful$eruptions
cekanja <- faithful$waiting
plot(  cekanja, trajanja, xlab="cekanje", ylab= "trajanje")
model <- lm( trajanja ~ cekanja )
abline(model)


x = 3
while(x != 1) {
  cat(x, ",")
  if(x%%2 == 0) {
    x = x/2
  } else {
    x = x*3+1
  }
}
cat(1)


#kvalitativni podaci
painters

prosecna.ocena.kompozicija <-  mean(painters$Composition)
prosecna.ocena.kompozicija

prosecna.ocena.crtanje <-  mean(painters$Drawing)
prosecna.ocena.crtanje

prosecna.ocena.boja <-  mean(painters$Colour)
prosecna.ocena.boja

prosecna.ocena.izrazajnost <-  mean(painters$Expression)
prosecna.ocena.izrazajnost

izrazajnosti <- painters$Expression
izrazajnosti
izrazajnosti.frekfencija <- table(izrazajnosti)
izrazajnosti.frekfencija

skole <- painters$School
skole
skole.frekfencija <- table(skole)
skole.frekfencija

skole <- painters$School
skole
skole.relativna.frekfencija <- table(skole) / length(skole)
skole.relativna.frekfencija

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
skole.frekfencija.procenat

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
cbind(skole.frekfencija.procenat)

skole <- painters$School
skole
skole.frekfencija.procenat <- table(skole) / length(skole) * 100
skole.frekfencija.procenat
staro.podesavanje <- options(digits=3)
skole.frekfencija.procenat
options(staro.podesavanje)

skole <- painters$School
skole
skole.frekfencija <- table(skole)
barplot( skole.frekfencija)

skole <- painters$School
skole
skole.frekfencija <- table(skole)
boje <- c("red","green", "yellow", "purple", "violet")
barplot( skole.frekfencija,
         col = boje)

ocene.kompozicija <- painters$Composition
ocene.kompozicija.frekfencija <- table (ocene.kompozicija)
boje <- c("red","green", "yellow", "purple", "violet")
barplot(ocene.kompozicija.frekfencija, col = boje)

barplot( table(painters$Composition),
        col = c("red","green", "yellow", "purple", "violet")
        )

skole <- painters$School
skole
skole.frekfencija <- table(skole)
pie( skole.frekfencija)

pie( table(painters$School))

pie( table(painters$School),
     col = c("red","green", "yellow", "purple", "violet"))

prosecna.ocena.kompozicija.svi <-  mean(painters$Composition)
prosecna.ocena.kompozicija.svi

# prosecna.ocena.kompozicija.skola.A ???
filter.skola.A <- painters$School == "A"
slikari.skola.A <- painters[filter.skola.A,]
ocena.kompozicija.skola.A <- slikari.skola.A$Composition
prosecna.ocena.kompozicija.skola.A <- mean(ocena.kompozicija.skola.A)
prosecna.ocena.kompozicija.skola.A

prosecna.ocena.kompozicija.skola.A <-
  mean(painters[painters$School == "A",]$Composition)
prosecna.ocena.kompozicija.skola.A

prosecna.ocena.kompozicija.skola.B <-
  mean(painters[painters$School == "B",]$Composition)
prosecna.ocena.kompozicija.skola.B

sve.prosecne.ocene.kompozicija <-
  tapply(painters$Composition, painters$School, mean)
sve.prosecne.ocene.kompozicija

sve.prosecne.ocene.boja <-
  tapply(painters$Colour, painters$School, mean)
sve.prosecne.ocene.boja


# portfolio.r
#
# Functions for portfolio analysis
# to be used in Introduction to Computational Finance & Financial Econometrics
# last updated: November 7, 2000 by Eric Zivot
#               Oct 15, 2003 by Tim Hesterberg
#               November 18, 2003 by Eric Zivot
#               November 9, 2004 by Eric Zivot
#		            November 9, 2008 by Eric Zivot
#               August 11, 2011 by Eric Zivot
#
# Functions:
#	1. efficient.portfolio			compute minimum variance portfolio
#							                subject to target return
#	2. globalMin.portfolio			compute global minimum variance portfolio
#	3. tangency.portfolio			  compute tangency portfolio
#	4. efficient.frontier			  compute Markowitz bullet
#	5. getPortfolio					    create portfolio object
#

getPortfolio <-
function(er, cov.mat, weights)
{
	# contruct portfolio object
	#
	# inputs:
	# er				   N x 1 vector of expected returns
	# cov.mat  		 N x N covariance matrix of returns
	# weights			 N x 1 vector of portfolio weights
	#
	# output is portfolio object with the following elements
	# call				original function call
	# er				  portfolio expected return
	# sd				  portfolio standard deviation
	# weights			N x 1 vector of portfolio weights
	#
	call <- match.call()

	#
	# check for valid inputs
	#
	asset.names <- names(er)
	weights <- as.vector(weights)
	names(weights) = names(er)
  	er <- as.vector(er)					# assign names if none exist
	if(length(er) != length(weights))
		stop("dimensions of er and weights do not match")
 	cov.mat <- as.matrix(cov.mat)
	if(length(er) != nrow(cov.mat))
		stop("dimensions of er and cov.mat do not match")
	if(any(diag(chol(cov.mat)) <= 0))
		stop("Covariance matrix not positive definite")

	#
	# create portfolio
	#
	er.port <- crossprod(er,weights)
	sd.port <- sqrt(weights %*% cov.mat %*% weights)
	ans <- list("call" = call,
	      "er" = as.vector(er.port),
	      "sd" = as.vector(sd.port),
	      "weights" = weights)
	class(ans) <- "portfolio"
	ans
}

efficient.portfolio <-
function(er, cov.mat, target.return)
{
  # compute minimum variance portfolio subject to target return
  #
  # inputs:
  # er					    N x 1 vector of expected returns
  # cov.mat  			  N x N covariance matrix of returns
  # target.return	  scalar, target expected return
  #
  # output is portfolio object with the following elements
  # call				    original function call
  # er					    portfolio expected return
  # sd					    portfolio standard deviation
  # weights			    N x 1 vector of portfolio weights
  #
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)					# assign names if none exist
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semidefinite

  #
  # compute efficient portfolio
  #
  ones <- rep(1, length(er))
  top <- cbind(2*cov.mat, er, ones)
  bot <- cbind(rbind(er, ones), matrix(0,2,2))
  A <- rbind(top, bot)
  b.target <- as.matrix(c(rep(0, length(er)), target.return, 1))
  x <- solve(A, b.target)
  w <- x[1:length(er)]
  names(w) <- asset.names

  #
  # compute portfolio expected returns and variance
  #
  er.port <- crossprod(er,w)
  sd.port <- sqrt(w %*% cov.mat %*% w)
  ans <- list("call" = call,
	      "er" = as.vector(er.port),
	      "sd" = as.vector(sd.port),
	      "weights" = w)
  class(ans) <- "portfolio"
  ans
}

globalMin.portfolio <-
function(er, cov.mat)
{
  # Compute global minimum variance portfolio
  #
  # inputs:
  # er				N x 1 vector of expected returns
  # cov.mat		N x N return covariance matrix
  #
  # output is portfolio object with the following elements
  # call			original function call
  # er				portfolio expected return
  # sd				portfolio standard deviation
  # weights		N x 1 vector of portfolio weights
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)					# assign names if none exist
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semi-definite

  #
  # compute global minimum portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  one.vec <- rep(1,length(er))
#  w.gmin <- cov.mat.inv %*% one.vec/as.vector(one.vec %*% cov.mat.inv %*% one.vec)
  w.gmin <- rowSums(cov.mat.inv) / sum(cov.mat.inv)
  w.gmin <- as.vector(w.gmin)
  names(w.gmin) <- asset.names
  er.gmin <- crossprod(w.gmin,er)
  sd.gmin <- sqrt(t(w.gmin) %*% cov.mat %*% w.gmin)
  gmin.port <- list("call" = call,
		    "er" = as.vector(er.gmin),
		    "sd" = as.vector(sd.gmin),
		    "weights" = w.gmin)
  class(gmin.port) <- "portfolio"
  gmin.port
}

tangency.portfolio <-
function(er,cov.mat,risk.free)
{
  # compute tangency portfolio
  #
  # inputs:
  # er				   N x 1 vector of expected returns
  # cov.mat		   N x N return covariance matrix
  # risk.free		 scalar, risk-free rate
  #
  # output is portfolio object with the following elements
  # call			  captures function call
  # er				  portfolio expected return
  # sd				  portfolio standard deviation
  # weights		 N x 1 vector of portfolio weights
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  if(risk.free < 0)
    stop("Risk-free rate must be positive")
  er <- as.vector(er)
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")
  # remark: could use generalized inverse if cov.mat is positive semi-definite

  #
  # compute global minimum variance portfolio
  #
  gmin.port <- globalMin.portfolio(er,cov.mat)
  if(gmin.port$er < risk.free)
    stop("Risk-free rate greater than avg return on global minimum variance portfolio")

  #
  # compute tangency portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  w.t <- cov.mat.inv %*% (er - risk.free) # tangency portfolio
  w.t <- as.vector(w.t/sum(w.t))	# normalize weights
  names(w.t) <- asset.names
  er.t <- crossprod(w.t,er)
  sd.t <- sqrt(t(w.t) %*% cov.mat %*% w.t)
  tan.port <- list("call" = call,
		   "er" = as.vector(er.t),
		   "sd" = as.vector(sd.t),
		   "weights" = w.t)
  class(tan.port) <- "portfolio"
  tan.port
}

efficient.frontier <-
function(er, cov.mat, nport=20, alpha.min=-0.5, alpha.max=1.5)
{
  # Compute efficient frontier with no short-sales constraints
  #
  # inputs:
  # er			  N x 1 vector of expected returns
  # cov.mat	  N x N return covariance matrix
  # nport		  scalar, number of efficient portfolios to compute
  #
  # output is a Markowitz object with the following elements
  # call		  captures function call
  # er			  nport x 1 vector of expected returns on efficient porfolios
  # sd			  nport x 1 vector of std deviations on efficient portfolios
  # weights 	nport x N matrix of weights on efficient portfolios
  call <- match.call()

  #
  # check for valid inputs
  #
  asset.names <- names(er)
  er <- as.vector(er)
  cov.mat <- as.matrix(cov.mat)
  if(length(er) != nrow(cov.mat))
    stop("invalid inputs")
  if(any(diag(chol(cov.mat)) <= 0))
    stop("Covariance matrix not positive definite")

  #
  # create portfolio names
  #
  port.names <- rep("port",nport)
  ns <- seq(1,nport)
  port.names <- paste(port.names,ns)

  #
  # compute global minimum variance portfolio
  #
  cov.mat.inv <- solve(cov.mat)
  one.vec <- rep(1,length(er))
  port.gmin <- globalMin.portfolio(er,cov.mat)
  w.gmin <- port.gmin$weights

  #
  # compute efficient frontier as convex combinations of two efficient portfolios
  # 1st efficient port: global min var portfolio
  # 2nd efficient port: min var port with ER = max of ER for all assets
  #
  er.max <- max(er)
  port.max <- efficient.portfolio(er,cov.mat,er.max)
  w.max <- port.max$weights
  a <- seq(from=alpha.min,to=alpha.max,length=nport)			# convex combinations
  we.mat <- a %o% w.gmin + (1-a) %o% w.max	# rows are efficient portfolios
  er.e <- we.mat %*% er							# expected returns of efficient portfolios
  er.e <- as.vector(er.e)
  names(er.e) <- port.names
  cov.e <- we.mat %*% cov.mat %*% t(we.mat) # cov mat of efficient portfolios
  sd.e <- sqrt(diag(cov.e))					# std devs of efficient portfolios
  sd.e <- as.vector(sd.e)
  names(sd.e) <- port.names
  dimnames(we.mat) <- list(port.names,asset.names)

  #
  # summarize results
  #
  ans <- list("call" = call,
	      "er" = er.e,
	      "sd" = sd.e,
	      "weights" = we.mat)
  class(ans) <- "Markowitz"
  ans
}

#
# print method for portfolio object
print.portfolio <- function(x, ...)
{
  cat("Call:\n")
  print(x$call, ...)
  cat("\nPortfolio expected return:    ", format(x$er, ...), "\n")
  cat("Portfolio standard deviation: ", format(x$sd, ...), "\n")
  cat("Portfolio weights:\n")
  print(round(x$weights,4), ...)
  invisible(x)
}

#
# summary method for portfolio object
summary.portfolio <- function(object, risk.free=NULL, ...)
# risk.free			risk-free rate. If not null then
#				compute and print Sharpe ratio
#
{
  cat("Call:\n")
  print(object$call)
  cat("\nPortfolio expected return:    ", format(object$er, ...), "\n")
  cat(  "Portfolio standard deviation: ", format(object$sd, ...), "\n")
  if(!is.null(risk.free)) {
    SharpeRatio <- (object$er - risk.free)/object$sd
    cat("Portfolio Sharpe Ratio:       ", format(SharpeRatio), "\n")
  }
  cat("Portfolio weights:\n")
  print(round(object$weights,4), ...)
  invisible(object)
}
# hard-coded 4 digits; prefer to let user control, via ... or other argument

#
# plot method for portfolio object
plot.portfolio <- function(object, ...)
{
  asset.names <- names(object$weights)
  barplot(object$weights, names=asset.names,
	  xlab="Assets", ylab="Weight", main="Portfolio Weights", ...)
  invisible()
}

#
# print method for Markowitz object
print.Markowitz <- function(x, ...)
{
  cat("Call:\n")
  print(x$call)
  xx <- rbind(x$er,x$sd)
  dimnames(xx)[[1]] <- c("ER","SD")
  cat("\nFrontier portfolios' expected returns and standard deviations\n")
  print(round(xx,4), ...)
  invisible(x)
}
# hard-coded 4, should let user control

#
# summary method for Markowitz object
summary.Markowitz <- function(object, risk.free=NULL)
{
  call <- object$call
  asset.names <- colnames(object$weights)
  port.names <- rownames(object$weights)
  if(!is.null(risk.free)) {
    # compute efficient portfolios with a risk-free asset
    nport <- length(object$er)
    sd.max <- object$sd[1]
    sd.e <- seq(from=0,to=sd.max,length=nport)
    names(sd.e) <- port.names

    #
    # get original er and cov.mat data from call
    er <- eval(object$call$er)
    cov.mat <- eval(object$call$cov.mat)

    #
    # compute tangency portfolio
    tan.port <- tangency.portfolio(er,cov.mat,risk.free)
    x.t <- sd.e/tan.port$sd		# weights in tangency port
    rf <- 1 - x.t			# weights in t-bills
    er.e <- risk.free + x.t*(tan.port$er - risk.free)
    names(er.e) <- port.names
    we.mat <- x.t %o% tan.port$weights	# rows are efficient portfolios
    dimnames(we.mat) <- list(port.names, asset.names)
    we.mat <- cbind(rf,we.mat)
  }
  else {
    er.e <- object$er
    sd.e <- object$sd
    we.mat <- object$weights
  }
  ans <- list("call" = call,
	      "er"=er.e,
	      "sd"=sd.e,
	      "weights"=we.mat)
  class(ans) <- "summary.Markowitz"
  ans
}

print.summary.Markowitz <- function(x, ...)
{
	xx <- rbind(x$er,x$sd)
	port.names <- names(x$er)
	asset.names <- colnames(x$weights)
	dimnames(xx)[[1]] <- c("ER","SD")
	cat("Frontier portfolios' expected returns and standard deviations\n")
	print(round(xx,4), ...)
	cat("\nPortfolio weights:\n")
	print(round(x$weights,4), ...)
	invisible(x)
}
# hard-coded 4, should let user control

#
# plot efficient frontier
#
# things to add: plot original assets with names
# tangency portfolio
# global min portfolio
# risk free asset and line connecting rf to tangency portfolio
#
plot.Markowitz <- function(object, plot.assets=FALSE, ...)
# plot.assets		logical. If true then plot asset sd and er
{
  if (!plot.assets) {
     y.lim=c(0,max(object$er))
     x.lim=c(0,max(object$sd))
     plot(object$sd,object$er,type="b",xlim=x.lim, ylim=y.lim,
          xlab="Portfolio SD", ylab="Portfolio ER",
          main="Efficient Frontier", ...)
     }
  else {
	  call = object$call
	  mu.vals = eval(call$er)
	  sd.vals = sqrt( diag( eval(call$cov.mat) ) )
	  y.lim = range(c(0,mu.vals,object$er))
	  x.lim = range(c(0,sd.vals,object$sd))
	  plot(object$sd,object$er,type="b", xlim=x.lim, ylim=y.lim,
          xlab="Portfolio SD", ylab="Portfolio ER",
          main="Efficient Frontier", ...)
        text(sd.vals, mu.vals, labels=names(mu.vals))
  }
  invisible()
}


#' @title Compute turnover components.
#'
#' @description Compute the a, b, c turnover components. Given two vectors, v1
#'   and v2, of species names or interactions, component "a" is the number of
#'   elements (species or interactions) present in both vectors v1 and v2, "b"
#'   is the number of elements present only in v1 and "c" only in v2. See the
#'   section "Beta diversity estimates" in  Novotny, V. (2009). Beta diversity
#'   of plant–insect food webs in tropical forests: a conceptual framework.
#'   Insect Conservation and Diversity, 2(1), 5-9.
#'
#' @param vect A list of two vectors with species names or interactions.
#'
#' @return A list with the 3 components a, b, c. The elements of the list are
#'   numeric vectors of length 1.
#'
#' @examples
#'
#' library(bootdissim)
#' library(bipartite)
#'
#' net1 <- reshape_net(vazarr, seed = 1)
#' net2 <- reshape_net(vazcer, seed = 1)
#' vect <- get_interactions(net1, net2)
#' abc <- get_abc(vect)
#'
#' @export
#'
#' @md
get_abc <- function(vect){
  v1 <- vect[[1]]
  v2 <- vect[[2]]

  # Fast testing if elements of a vector are present in a second vector. The
  # index position doesn't matter. What matters is if for a given element from
  # the first vector, the match() function returns a value of zero or above
  # zero. A zero indicates that the respective element from the first vector
  # doesn't exist in the second vector. A positive value indicates that the
  # respective element from the first vector exists in the second vector. The
  # value itself indicates the first position where that element is encountered
  # in the second vector, but this information is not important for our
  # purposes. We used match() function because is fast.
  match_v1_in_v2 <- match(v1, v2, nomatch = 0)
  match_v2_in_v1 <- match(v2, v1, nomatch = 0)

  # Get the a, b and c components.

  # "a" is the number of elements present in both vectors v1 and v2
  a <- sum(match_v2_in_v1 > 0) # same as sum(match_v1_in_v2 > 0)
  # "b" is the number of elements present only in v1
  b <- sum(!(match_v1_in_v2 > 0))
  # "c" is the number of elements present only in v2
  c <- sum(!(match_v2_in_v1 > 0))

  return(list(a = a, b = b, c = c))
}

#' @title Compute dissimilarity index.
#'
#' @description Compute various dissimilarity indices.
#'
#' @param abc A list with the turnover components a, b and c.
#'
#' @param index The name of the desired index, e.g.: "whittaker", "jaccard",
#'   "sorensen". Character type.
#'
#' @return A dissimilarity index. Numeric vector of length one.
#'
#' @examples
#'
#' library(bootdissim)
#' library(bipartite)
#'
#' net1 <- reshape_net(vazarr, seed = 1)
#' net2 <- reshape_net(vazcer, seed = 1)
#' vect <- get_interactions(net1, net2)
#' abc <- get_abc(vect)
#' get_beta(abc, index = "whittaker")
#' get_beta(abc, index = "jaccard")
#' get_beta(abc, index = "sorensen")
#'
#' @export
#'
#' @md

get_beta <- function(abc, index){
  a <- abc[["a"]]
  b <- abc[["b"]]
  c <- abc[["c"]]

  switch(index,
         whittaker = 2*(a+b+c)/(2*a+b+c) - 1, # sometimes written as ( (a + b + c) / ((2*a + b + c)/2) ) - 1
         jaccard = a/(a+b+c),
         sorensen = (2*a)/(2*a+b+c),
         stop("Your index is not recognised or available. Typo? Check help for options.",
              call. = FALSE))
  # Switch is generally faster than if statements.
  # https://stackoverflow.com/a/7826352/5193830
}


# Implementation of the Douglas-Peucker algorithm for line thinning
# http://en.wikipedia.org/wiki/Ramer-Douglas-Peucker_algorithm
simplify_rec <- function(points, tol = 0.01) {
  n <- nrow(points)
  if (n <= 2) return() # c(1, n))
  dist <- with(points, point_line_dist(x, y, x[1], y[1], x[n], y[n]))

  if (max(dist, na.rm = T) > tol) {
    furthest <- which.max(dist)
    c(
      simplify_rec(points[1:(furthest - 1), ], tol),
      furthest,
      simplify_rec(points[(furthest + 1):n, ], tol) + furthest
    )
  } else {
    c()
  }
}

# From http://mathworld.wolfram.com/Point-LineDistance2-Dimensional.html
point_line_dist <- function(px, py, lx_1, ly_1, lx_2, ly_2) {
  abs((lx_2 - lx_1) * (ly_1 - py) - (lx_1 - px) * (ly_2 - ly_1)) /
    sqrt((lx_2 - lx_1) ^ 2 + (ly_2 - ly_1) ^ 2)
}

# Precompute all tolerances so that we can post-select quickly
compute_tol <- function(points, offset = 0) {
  n <- nrow(points)
  if (n <= 2) {
    c()
  } else if (n == 3) {
    with(points,
      point_line_dist(long[2], lat[2], long[1], lat[1], long[3], lat[3]))
  } else {
    dist <- with(points,
      point_line_dist(long[2:(n-1)], lat[2:(n-1)], long[1], lat[1], long[n], lat[n])
    )

    furthest <- which.max(dist)
    if (length(furthest) == 0) browser()
    c(
      compute_tol(points[1:(furthest + 1), ], offset),
      dist[furthest],
      compute_tol(points[(furthest + 1):n, ], furthest + offset)
    )
  }
}