#-------------------------------------------------------------------
# vtfn -- Generate spectrum of vocal tract response given formant
#         frequency, amplitude, and bandwidth.
#
# Args:
#  pars -- A vector of named parameters. The first parameter is the
#          number of poles and zeros described in subsequent triplets
#          (frequency, bandwidth, amplitude) of parameters. Poles are
#          distinguished from zeros by having positive instead of
#          negative frequency values.
#
#  np   -- The number of points of spectrum values to cover the
#          Nyquist range from 0 - fs/2. This is deceptive because,
#          to be consistent with FFT concentions, there will really
#          be an np+1 point spectrum returned with the first value
#          corresponding to DC and the last to the Nyquist frequency.
#
#  fs   -- Sampling frequency in Hz.
#
# Notes: This is the "parallel formant" version with each formant
#        curve calculated independently and added to the others.
#        Each formant is also multiplied by an amplitude factor
#        that is passed as a quantity in dB via the pars vector.
#        Additionally, this function called the underlying formant
#        function with scaled=TRUE so that every formant response
#        curve is generated with a theoretical peak amplitude of 1.0.
#
# 1/10/20 -- htb
#-------------------------------------------------------------------

vtfn2 <- function(pars, np=512, fs=16000) {
  maxf <- fs/2
  nres <- pars[1]
  s <- rep(0,np+1)
  z <- rep(1,np+1)
  for (j in seq(2,nres*3,3)) {
    af <- 10^(pars[j+2]/20)
    if (pars[j] > 0) {
      s <- s + af * formant(pars[j],pars[j+1],np,maxf)
      #cat(paste0('pole: af=',af,'; f=',pars[j],'; b=',pars[j+1],'\n'))
    } else {
      z <- z * af / formant(pars[j],pars[j+1],np,maxf)
      #cat(paste0('zero: af=',af,'; f=',pars[j],'; b=',pars[j+1],'\n'))
    }
  }
  s*z
}


Bio1<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-2.235282155+(2.3733*(log(DAP)))) # bs-T de alvarez et al. (en preparacion)
Bio2<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.544182155+(2.3733*(log(DAP)))) # bh-T de alvarez et al. (en preparacion)
Bio3<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.908382155+(2.3733*(log(DAP)))) # bp-T de alvarez et al. (en preparacion)
Bio4<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.865582155+(2.3733*(log(DAP)))) # bh-PM de alvarez et al. (en preparacion)
Bio5<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.662982155+(2.3733*(log(DAP)))) # bh-MB de alvarez et al. (en preparacion)
Bio6<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-2.616382155+(2.3733*(log(DAP)))) # bh-M de alvarez et al. (en preparacion)

CargarIndividuos<-function(y){
tryCatch({
Individuos<-read.csv(y,enc="latin1")
return (list(FALSE,Individuos))
}, error = function(ex) {
print("No se pudo cargar el archivo de individuos")
return (TRUE)
})
}

CargarParcelas<-function(x){
tryCatch({
Parcela<-read.csv(x,enc="latin1")
return (list(FALSE,Parcela))
}, error = function(ex) {
print("No se pudo cargar el archivo de parcelas")
return (TRUE)
})
}

organizarInfo<-function(i,p){
tryCatch({
base1<-merge(i,p)
base1a<-subset(base1,DAP>=10)
base2<-subset(base1a,Familia!="Arecaceae")
str(base2)
summary(base2)
return (list(FALSE,base2,base1))
}, error = function(ex) {
print("Error en el analisis de la informacion de los archivos")
return(TRUE)
})
}

CalculaBiomasa<-function(x){
 tryCatch({
  EcuacionesAlometricas<-c('Bio1','Bio2','Bio3','Bio4','Bio5','Bio6')
  Biomasa<-get(EcuacionesAlometricas[as.integer(x[["Ecuacion"]])])(as.numeric(x[["Dens"]]),
  as.numeric(x[["DAP"]]),
  as.numeric(x[["Alt"]]),
  as.numeric(x[["AB"]]))
  return(Biomasa)
  }, error = function(ex) {
print("No se pudo realizar el calculo de la Biomasa")
})
}

calcularBiomasaCarbono<-function(base2){
tryCatch({
base2$BiomasaKg<-apply(base2,1,CalculaBiomasa)
ParcelasBiomasa<-aggregate(base2$BiomasaKg/((base2$Area*10000)/10),list(Plot=base2[,"Plot"]),sum,na.rm=TRUE)
#base3<-merge(Parcela,ParcelasBiomasa)
base3<-merge(base1,ParcelasBiomasa)
base3$Biomasa<-base3$x
base3$Carbono<-base3$Biomasa*0.5
base4<-subset(base3,select=c(Plot,FID,DAP,Familia,Area,Bosque,Ecuacion,Biomasa,Carbono))
return(list(FALSE,base4,ParcelasBiomasa))
}, error = function(ex) {
print("Error al realizar el calculo de la biomasa y el carbono")
return (TRUE)
})
}

cargarExtremeValues<-function(){
tryCatch({
  library(extremevalues)
  return(FALSE)
}, error = function(ex) {
  return(TRUE)
})
}

Atipicos<-function(p,x,y)
{
tryCatch({
base3<-merge(p,x)
ParcelaBiomasa<-subset(y,select=c(Plot,Area,Bosque,Biomasa))
lognormal<-getOutliersII(ParcelaBiomasa$Biomasa,distribution="lognormal")
ParcelaSinOuts<-ParcelaBiomasa[-c(lognormal$iRight,lognormal$iLeft),]
return(list(FALSE,ParcelaBiomasa,ParcelaSinOuts))
	}, error = function(ex) {
print("Error realizando el calculo de los datos Atipicos");
return (TRUE)
})
}

var.wtd.mean.cochran <- function(x,w,na.rm=TRUE)
{
  if (na.rm){
  x<-x[!is.na(w)]
  w<-w[!is.na(w)]
  }
	n = length(w)
	xWbar = weighted.mean(x,w)
	wbar = mean(w)
	out = n/((n-1)*sum(w)^2)*(sum((w*x-wbar*xWbar)^2)-2*xWbar*sum((w- wbar)*(w*x-wbar*xWbar))+xWbar^2*sum((w-wbar)^2))
	return (out)
}

AtipicosTodos<-function(ParcelaBiomasa){
tryCatch({
varzas<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque,Area),var))
desv.estand<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque),sd))
ns1<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque),length))
ponderaciones<-(1/varzas)/apply((1/varzas),1,sum,na.rm=TRUE)
apply(ponderaciones,1,sum,na.rm=TRUE)
medias1<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque,Area),mean))
medias2<-apply(medias1*ponderaciones,1,sum,na.rm=TRUE)
medias3<-with(ParcelaBiomasa,tapply(Biomasa,Bosque,mean))
sec1<-1:nrow(medias1)
var.wtd.media<-function(i,medias,varianzas,na.rm=TRUE){
   var.wtd.mean.cochran(medias1[i,],1/varianzas[i,],na.rm=TRUE)
   }
r1<-sapply(sec1,var.wtd.media,medias1,varzas)

SalidaTodos<-data.frame(ns=ns1,
                  media_w=medias2,desv.estand_w=sqrt(r1),
                  CV_w=sqrt(r1)/medias2*100,
                  IC_w=1.96*sqrt(r1))
return (list(FALSE,SalidaTodos))
}, error = function(ex) {
print("No se pudo realizar el analisis de los Valores Atipicos")
return (TRUE)
})
}

AtipicosSin<-function(ParcelaSinOuts){
tryCatch({
varzas<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque,Area),var))
desv.estand<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque),sd))
ns1<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque),length))
ponderaciones<-(1/varzas)/apply((1/varzas),1,sum,na.rm=TRUE)
apply(ponderaciones,1,sum,na.rm=TRUE)
medias1<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque,Area),mean))
medias2<-apply(medias1*ponderaciones,1,sum,na.rm=TRUE)
medias3<-with(ParcelaSinOuts,tapply(Biomasa,Bosque,mean))
sec1<-1:nrow(medias1)
var.wtd.media<-function(i,medias,varianzas,na.rm=TRUE){
   var.wtd.mean.cochran(medias1[i,],1/varianzas[i,],na.rm=TRUE)
   }
r1<-sapply(sec1,var.wtd.media,medias1,varzas)

SalidaSinOuts<-data.frame(ns=ns1,
                  media_w=medias2,desv.estand_w=sqrt(r1),
                  CV_w=sqrt(r1)/medias2*100,
                  IC_w=1.96*sqrt(r1))
return (list(FALSE,SalidaSinOuts))
}, error = function(ex) {
print("No se pudo realizar el analisis de los Valores Atipicos")
return (TRUE)
})
}


2 + 2
10/3

v = c(1, 4, 5, 3, 7)
v <- c(1, 4, 5, 3, 7)
class(v)
sum(v)
mean(v)
length(v)
max(v)
v[1]
v[3:5]
v[-(2:3)]
v^2
exp(v)
v[v >= 3]
sum(v >= 3)
sum(v >= 3)/2

n = 10
k = 5
sqrt(n)
log(n)
exp(-k)
factorial(n)
choose(n,k)
sample(n)
sample(n,replace=TRUE)
sample(4, 3, replace=TRUE, prob=c(0.1,0.2,0.3,0.4)) #samples three numbers between 1 and 4, with replacement, and with probabilities given by (0.1,0.2,0.3,0.4)
replicate(5,c(1:3))
prod(c(2, 4, 5))

x = c(1:10)
y = x*x
plot(x, y, type="l")


#' Multivariate normal mixture conditional likelihood model
#'
#' Gibbs sampling from the multivariate normal mixture conditional likelihood
#' model.
#'
#' @param y_train factor. Categorical response in the train data.
#' @param s_train matrix. Probabilistic predictions of candidate models for
#' train data, binded by columns.
#' @param s_test matrix. Probabilistic predictions of candidate models for test
#' data, binded by columns.
#' @param n_c numeric. Number of classes of the response.
#' @param n_s numeric. Number of candidate models.
#' @param iter numeric. Number of iterations for Gibbs sampling.
#' @param n_g numeric. Number of mixtures at the beginning of Gibbs sampling.
#' Redundant mixtures will collapse during sampling.
#' @param invalog logical. If TRUE, transform s_train and s_test with the
#' inverse logistic transformation. Defaults to TRUE.
#' @param prior_s2 numeric. Prior on the diagonal of the inverse-Wishart scale
#' matrix for covariance matrices.
#' @param prior_mu numeric. Prior on the means of latent multivariate normal
#' distributions.
#' @param prior_nu numeric. Prior on the inverse-Wishart degrees of freedom for
#' covariance matrices.
#'
#' @return Matrix with posterior means of probabilistic predictions for each
#' test observation. The number of columns is n_c and the number of rows is the
#' same as nrow(s_test).
#'
#' @examples
#' set.seed(1)
#' n <- 1000
#' t <- sample(1:2, n, replace = T)
#' M1 <- vector(mode = "numeric", length = n)
#' M2 <- vector(mode = "numeric", length = n)
#'
#' nt1 <- sum(t == 1)
#' nt2 <- n - nt1
#'
#' # Candidate model predictions
#' # M1: systematic error
#' # M2: random
#' M1[t == 1] <- rbeta(nt1, 1, 2)
#' M2[t == 1] <- rbeta(nt1, 2, 2)
#' M1[t == 2] <- rbeta(nt2, 2, 1)
#' M2[t == 2] <- rbeta(nt2, 1, 1)
#'
#' p         <- matrix(c(M1, 1-M1, M2, 1-M2), ncol = 4)
#' train_ind <- 1:500
#' test_ind  <- 501:1000
#'
#' t_train <- t[train_ind]
#' t_test  <- t[test_ind]
#' p_train <- p[train_ind, ]
#' p_test  <- p[test_ind, ]
#'
#' MM_fit <- model_MM(t_train, p_train, p_test, n_c = 2, n_s = 2)
#'
#'
#' @references Pirs, G. and Strumbelj, E. (2019). Bayesian Combination of
#' Probabilistic Classifiers using Multivariate Normal Mixtures. Journal of
#' Machine Learning Research, 20, 51-1.
#'
#' @export
model_MM <- function (y_train, s_train, s_test, n_c, n_s,
                            iter       = 100,
                            n_g        = 15,
                            invalog    = T,
                            regularize = F,
                            # priors
                            prior_s2   = 100,
                            prior_mu   = 0,
                            prior_nu   = 2 + (n_c - 1) * n_s
) {
  library(mvtnorm)
  library(MASS)

  invalog_transform <- function (x, n_s, n_c) {
    for (i in 1:n_s) {
      lo <- (i-1)*n_c + 1
      hi <- (i-1)*n_c + n_c
      x[,lo:hi] <- x[,lo:hi] + runif(nrow(x[,lo:hi]) * ncol(x[,lo:hi]), 0.00,0.001)
      x[,lo:hi] <- x[,lo:hi] / rowSums(x[,lo:hi])

      for (j in 1:n_c) {
        x[ ,(i-1)*n_c + j] <- log(x[ ,(i-1)*n_c + j] / x[ ,(i-1)*n_c+n_c])
      }
    }
    x[,(1:ncol(x) %% n_c) != 0]
  }

  vec_prod  <- function(vec) {return(vec %*% t(vec))}

  to_matrix <- function(vec) {return(matrix(vec,
                                            ncol = sqrt(length(vec)),
                                            byrow = TRUE))}

  sum_na    <- function (my_vec) {return (sum(is.na(my_vec)))}
  if (invalog) {
    t_train <- invalog_transform(s_train, n_s, n_c)
    t_test  <- invalog_transform(s_test, n_s, n_c)
  } else {
    x <- seq(1, ncol(s_train), n_c)
    t_train <- s_train[,-x]
    t_test  <- s_test[,-x]
  }
  t_all   <- rbind(t_train, t_test)

  collapsed <- array(F, dim = c(n_c, n_g))

  # priors ----
  nu_0       <- prior_nu
  Sigma_0    <- diag(prior_s2, ncol(t_train))
  S_0        <- diag(prior_s2, ncol(t_train))
  mu_0       <- rep(prior_mu, ncol(t_train))
  invSigma_0 <- solve(Sigma_0) # Prepare the inverse of the prior.

  # parameters ----
  par_y_test <- array(NA, dim = c(iter+1, nrow(t_test)))
  par_p_test <- array(NA, dim = c(iter+1, nrow(t_test), n_c))
  par_predict<- array(NA, dim = c(iter+1, nrow(t_test), n_c))
  par_group  <- array(NA, dim = c(iter+1, nrow(t_test) + nrow(t_train)))
  par_mu     <- array(NA, dim = c(iter+1, n_c, n_g, ncol(t_train)))
  par_invSigma  <- array(NA, dim = c(iter+1, n_c, n_g, ncol(t_train), ncol(t_train)))

  # assignment of starting values ----
  par_y_test[1,] <- sample(1:n_c, nrow(t_test), rep = T)
  par_group[1,]  <- sample(1:n_g, nrow(t_test) + nrow(t_train), rep = T)

  par_mu[1,,,] <- 0
  for (j in 1:n_c) {
    for (k in 1:n_g) {
      par_invSigma[1,j,k,,] <- diag(ncol(t_train))
    }
  }

  COMPLETE_DATA <- F

  # main loop ----
  for (i in 2:(iter + 1)) {
    cat(i, " ")

    y_all <- c(y_train, par_y_test[i-1,])
    # mu and Sigma ----
    for (j in 1:n_c) {
      # collapse groups
      for (k in n_g:1) {

        if (COMPLETE_DATA) {
          if (sum(par_group[i-1,] == k & y_all == j) <= 1) {
            collapsed[j,k] <- T
          }
        } else {
          if (sum(par_group[i-1,1:length(y_train)][y_train == j] == k) <= 1) {
            collapsed[j,k] <- T
          }
        }
      }

      # sample new params
      for (k in 1:n_g) if (!collapsed[j,k]) {

        # get data for this class and this group
        if (COMPLETE_DATA) {
          tmp_t_all <- t_all[y_all == j & par_group[i - 1, ] == k,]
        } else {
          tmp_t_all <- t_train[y_train == j & par_group[i-1,1:length(y_train)] == k,]
        }

        n_j       <- nrow(tmp_t_all)

        # Get values from the previous iteration.
        invSigma_j <- par_invSigma[i-1,j,k,,]
        mu_j     <- par_mu[i-1,j,k,]
        Sigma_n  <- solve(invSigma_0 + n_j*invSigma_j)
        umean    <- colMeans(tmp_t_all)

        mu_n     <- Sigma_n %*% (invSigma_0 %*% mu_0 +
                                   n_j * invSigma_j %*% umean)
        mu_j     <- mvrnorm(1, mu_n, Sigma_n)
        nu_n     <- nu_0 + n_j
        mu_mat   <- matrix(rep(mu_j, n_j), ncol = length(mu_j), byrow=TRUE)
        ecm      <- t(as.matrix(tmp_t_all - mu_mat))
        ecm      <- apply(ecm, 2, vec_prod)
        ecm      <- rowSums(ecm)
        ecm      <- matrix(ecm, ncol = length(mu_j), byrow = TRUE)
        S_n      <- S_0 + ecm
        invSigma_j <- rWishart(1, nu_n, solve(S_n))[,,1]

        # Insert new values into the current iteration.

        par_mu[i,j,k,]     <- mu_j
        par_invSigma[i,j,k,,] <- invSigma_j
      }
    }

    # groups ----
    par_group[i,] <- par_group[i-1,]
    group_all <- par_group[i,1:length(y_train)]
    g_probs <- array(0, dim = c(nrow(t_train), n_g))
    for (j in 1:n_c) {
      idxs      <- y_train == j
      tmp_t_all <- t_train[idxs,]
      for (k in 1:n_g) if (!collapsed[j,k]) {
        mu     <- par_mu[i,j,k,]
        Sigma  <- solve(par_invSigma[i,j,k,,])
        g_probs[idxs,k] <- dmvnorm(tmp_t_all, mean = mu, sigma = Sigma)
      }
    }

    g_probs <- g_probs / rowSums(g_probs)
    par_group[i,1:length(y_train)] <- apply(g_probs, 1, function(x){sample(1:n_g, 1, prob = x)})

    get_pred <- function(t_test, y_all, n_c, n_g, collapsed, par_mu, par_invSigma, group_all, lambda = rep(0, ncol(t_test))) {
      pred <- array(0, dim = c(nrow(t_test), n_c, n_g))
      for (j in 1:n_c) {
        for (k in 1:n_g) if (!collapsed[j,k]) {
          mu     <- par_mu[i,j,k,]
          Sigma  <- solve(par_invSigma[i,j,k,,])  + diag(lambda)

          pred[,j,k] <- dmvnorm(t_test, mean = mu, sigma = Sigma) * sum(group_all == k & y_all == j)
        }
      }

      pred <- sweep(pred, 1, apply(pred, 1, sum), FUN="/")
    }
    pred <- get_pred(t_test, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group[i,1:length(y_train)])
    tmp  <- apply(pred, 1, function(x){sample(1:(n_c * n_g), 1, prob = c(x))})
    par_y_test[i,] <- (tmp - 1) %% n_c + 1
    par_group[i,(length(y_train) + 1):length(par_group[i,])] <- floor((tmp - 1) / n_c) + 1

    # regularize
    fn_optim <- function(x, t_train, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group) {
      pred <- get_pred(t_train, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group, lambda = x)
      pred <-  apply(pred, c(1,2), sum)
      p_star <- pred[cbind(1:nrow(pred), y_train)]
      -mean(log(p_star))
    }

    if (regularize) {
      lambda <- rep(0, ncol(t_train))
      idx    <- sample(1:length(y_train), 100, rep = T)
      lambda_max <- 100000
      res <- optim(lambda, fn = fn_optim,
                   lower = rep(0, length(lambda)),
                   upper = rep(lambda_max, length(lambda)),
                   method = "L-BFGS-B", #control = list(trace = 1),
                   t_train = t_train[idx,], y_train = y_train[idx], n_c = n_c,
                   n_g = n_g, collapsed = collapsed, par_mu = par_mu, par_invSigma = par_invSigma, par_group = par_group[i,1:length(y_train)][idx])

      pred <- get_pred(t_test, y_train, n_c, n_g, collapsed, par_mu, par_invSigma, par_group[i,1:length(y_train)], lambda = res$par)
      par_predict[i,,] <- apply(pred, c(1,2), sum)

    } else {
      par_predict[i,,] <- apply(pred, c(1,2), sum)
    }
  }
  cat("\n")

  return(pred = apply(par_predict[-1,,], c(2,3), mean))
}


#	functions to calculate paleoflow depth from preserved cross-sets.
#	Eric Barefoot
#	Nov 2017
#
#	largely taken from work by Suzanne Leclair, Chris Paola and methods in a review paper by Bradley and Venditti

#	first step is to relate the cross-set (xset) thickness to dune height (H)

#	require packages

# require(stats4)

#' Dune height calculation from cross-set thicknesses
#'
#' \code{xset2H} takes measured cross-set thicknesses (\code{y}) and converts it to dune heights (H).
#'
#' @param y 	A vector of measured cross-set thicknesses in meters.
#' @param mode	Takes two values: \code{simple} and \code{pdfFit}. \code{simple} uses a simple approximation to determine the beta value in Leclair's equation relating x-sets to dune heights. \code{pdfFit} uses a more complicated procedure, fitting a PDF from Paola  + Borgman to get the beta value. \code{pdfFit} is better suited when there are adequate data to estimate the distribution.
#' @param output 	Takes two values: \code{vanilla} and \code{rich}. \code{vanilla} only returns the estimated value of \code{H}, or dune height. \code{rich} returns \code{H}, as well as \code{beta} and either \code{startVal} which is the inital guess of a for the MLE algorithm in \code{pdfFit}, or a span of \code{H} values giving a reasonable range of one particular assumption.
#' @return Either a single numeric if \code{output = vanilla}, or a list if \code{output = rich}.
#' @export

xset2H = function(y, mode = 'simple', output = 'vanilla') {

	#	function takes two modes: 'simple' and 'pdfFit'
	#	y is a vector of cross-set thicknesses -- MUST BE IN METERS

	y = y * 1000 # 	convert to millimeters

	#	gives output in meters

	n = length(y)

	#	first a function to estimate the average dune height via fitting a PDF of x-set thicknesses to find the right parameters
	pdfFit = function(y) {

		#	define the probability density function from Paola and Borgman
		pfun = function(a,s) {
			p = a * exp(-a*s) * (exp(-a*s) + a * s - 1) / (1 - exp(-a*s))^2
			return(p)
		}

		#	construct a likelihood function which takes data as an external argument and the parameter as the internal argument.
		loglikely = function(data) {
			function(a) {
				R = R = pfun(a, data)
				-sum(log(R))
			}
		}

		#	construct likelihood function for these data.
		LL = loglikely(y)

		#	default starting a value for fitting
		#	and error handling sequence for finding an inital guess value for that works and doesnt crash the MLE.
		worked = FALSE
		startVal = 1
		try(stop(''), silent = T)
		j = 1
		while (!worked) {

			try_MLE = try(coef(mle(minuslogl = LL, start = list(a = startVal))), silent = T)

			if (class(try_MLE) == 'try-error' & j < 1000) {

				options(warn = -1)
				msg = as.character(try_MLE)

				if (grepl('initial value', msg)) {
					startVal = startVal / 2
					j = j + 1
#					message(paste(startVal))
				} else {
					stop('Something else happened, its real bad')
				}

			} else {

				worked = TRUE

			}
		}

		#	estimate parameter using MLE function
		a = coef(mle(minuslogl = LL, start = list(a = startVal)))

		#	get beta a la Leclair et al. 0.9 is for dune height/scour correction
		beta = 0.9/a

		#	get dune height from beta from Leclair et al. two ways.
#		H = 2.22 * beta ^ 1.32
		H = 5.3 * beta + 0.001 * beta ^ 2

		list(H = as.numeric(H) / 1000, beta = as.numeric(beta), startVal = startVal)
	}

	#	Here, a simpler function using only the empirical estimations made by Leclair et al.
	simple = function(y) {
		sm = mean(y, na.rm = T) #	find average set thickness
		hsd_tssd = seq(from = 0.7, to = 1.1, by = 0.1) #	find ratio of scour deviation to height deviation. supposedly an average of 0.9, but ranges randomly from 0.7 to 1.1 this function spits out a range.
		beta = sm / (1.64493 / hsd_tssd) #	use that to calculate beta
#		beta = sm / 1.8

#		H = 2.22 * beta ^ 1.32
		H = 5.3 * beta + 0.001 * beta ^ 2 #	use same equation as in pdfFit to get the average height

		list(H = mean(H) / 1000, beta = as.numeric(beta), vecH = H / 1000)
	}

	#	offer some recommendations to the user.
	if(n >= 25 & mode == 'simple') {

		message('this dataset may benefit from running a more complicated PDF based function.')

		H = simple(y)

	} else if (n < 25 & mode == 'simple' ) {

		H = simple(y)

	} else if (n < 25 & mode == 'pdfFit') {

		message('this dataset is small, and may benefit from running a less complicated empirical.')

		H = pdfFit(y)

	} else if (n >= 25 & mode == 'pdfFit') {

		H = pdfFit(y)

	}

	switch(output ,
		   vanilla = return(H$H),
		   rich = return(H)
		  )
}

#' Paleo-depth calculation from dune height
#'
#' \code{H2h} takes estimated dune heights (H) and calculates a flow depth.
#'
#' @param H 	A vector of measured cross-set thicknesses in meters.
#' @param CL	A pre-specified confidence level. If you pick a low confidence (50\%), the range in estimated flow depth will be smaller.
#' @param output 	Takes two values: \code{vanilla} and \code{rich}. \code{vanilla} only returns the estimated value of \code{h}. \code{rich} returns \code{h}, as well as \code{CI}, the confidence interval around the \code{h} estimate.
#' @return Either a single numeric if \code{output = vanilla}, or a list if \code{output = rich}.
#' @export

#	second step is to relate the dune height to the flow depth, following Bradley and Venditti

H2h = function(H, CL = 50, output = 'vanilla') {

	#	H is the height of a dune in meters.
	#	or if H is a vector, it is a set of dune heights
	#	CL is the confidence level in percent

	#	confidence ranges

	CR = data.frame(CL = c(50, 80, 90, 95), upper = c(10.1, 14.6, 23.9, 29.5), lower = c(4.4, 3.1, 2.8, 2.7))

	Cind = which.min(abs(CR$CL - CL)) # match closest one from the table

	h = 6.7 * H	#	using the median parameter from Bradley and Venditti

	CI = list(upper = H * CR$upper[Cind], lower = H * CR$lower[Cind]) # and based on Confidence Level, assign bounds of confidence

	returnval = switch(output ,
					   vanilla = return(h),
					   rich = return(list(h = h, CI = CI))
					  )
}

#	and now a function that combines both into one function, so you can go straight from xsets to flow depth with no extra frills, or depth

#' Paleo-depth calculation from cross-set thicknesses
#'
#' \code{xset2depthSimple} uses the simplest implementation of both \code{xset2H} and \code{H2h}. It uses the vanilla options of each one and spits out an estimate of paleo-depth based on the defaults. Look in the code for the other functions to see what those defaults are.
#' @param y 	A vector of measured cross-set thicknesses in meters.
#' @return The paleo-depth estimate in meters.
#' @export

xset2depthSimple = function(y) {

	#	y is a vector of thicknesses of xsets in meters

	H = xset2H(y)

	h = H2h(H)

	return(h)

}


#' @title Calculate probability based on zero inflated generalized Dirichlet-multinomial distribution
#'
#' @description
#' This function estimates parameters from zero inflated generalized Dirichlet-multinomial distribution, and test the pro.
#' @param Y Count table of microbiome
#' @param Xc design matrices for probability of absence model. The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param Xa design matrices for mean model.  The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param Xb design matrices for dispersion model. The first column should contain "1" for the intercept. For intercept only model, the three matrices are simply contain vectors of 1.
#' @param c0 c0: initial values for regression coefficients "c" organized in a matrix (dim: K x d, K+1 is the #taxa (i.e. K+1 = ncol(Y)), d is the number of columns in the corresponding design matrix)
#' @param alpha0: initial values for regression coefficients "alpha" organized in a matrix (dim: K x d)
#' @param beta0: initial values for regression coefficients "beta" organized in a matrix (dim: K x d)
#' @param tol: convergence tolerance
#' @param max.iter: maximum number of iterations

#' @return A vector containning the probablity of multinomial distribution
#' @export
#' @examples
####estimate probability of of absent matrix, mean and dispersion matrix from Y based on ZIGDM model
###Test_result <- ZIGDM.EM.PAR2(Y=Y, Xc=Xc, Xa=Xa, Xb=Xb, c0=c0, alpha0=alpha0, beta0=beta0, tol=tol, max.iter=max.iter)
#### using probability of of absent matrix to random generate present and absent value

ZIGDM_prob <- function(Test_result, row) {
 ####row is Xc[1,]
  Delta <- Bernoulli(c.est = Test_result$c.est, row = row)
  #### based on Delta, generate Z, row2 is Xa[1,], row3 is Xb[1,]. since Xc[1,]=Xa[1,]=Xb[1,],row is used for all
  Z_value <- Zvalue_Generator(Delta = Delta, Test_result = Test_result, row2 = row, row3 = row)
  #### based on Z, generate p vector for multinomial

  MultinomialP <- multinormial_P(Z=Z_value)
  MultinomialP[length(MultinomialP)+1] <- 1- sum(MultinomialP)  #### add the K+1 taxa back

  return (MultinomialP)

  #probability = apply(Y,1,dmultinom, prob = MultinomialP)

  #return (probability)
}


# ----------------------------------------
#  App Title: Chaos Game -- 2 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

library(shiny)
library(shinyBS)
library(shape)

###################################################################
# Triangle
###################################################################

tri.gen <- function(wt){
  	weight <- wt

		len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=3)

		loci[1,] <- c(1,0,0)
		loci[2,] <- c(2,0.5,sqrt(3)/2)
		loci[3,] <- c(3,1,0)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>2/3)]<- 3
		vertices[which(1/3<vertices & vertices<=2/3)]<- 2
		vertices[which(vertices<=1/3)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

		coords[1,] <- c(runif(1),runif(1)*sqrt(3)/2)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
	    x <- x.new
	    y <- y.new
		}
    return(list(loci,vertices,coords))
}

###################################################################
# Square
###################################################################

sqr.gen <- function(wt){

    weight <- wt

		len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=8)

		loci[1,] <- c(1,0.0,0.0)
		loci[2,] <- c(2,0.5,0.0)
		loci[3,] <- c(3,1.0,0.0)
  	loci[4,] <- c(4,1.0,0.5)
  	loci[5,] <- c(5,1.0,1.0)
  	loci[6,] <- c(6,0.5,1.0)
  	loci[7,] <- c(7,0.0,1.0)
  	loci[8,] <- c(8,0.0,0.5)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>7/8)]<- 8
  	vertices[which(6/8<vertices & vertices<=7/8)]<- 7
  	vertices[which(5/8<vertices & vertices<=6/8)]<- 6
  	vertices[which(4/8<vertices & vertices<=5/8)]<- 5
  	vertices[which(3/8<vertices & vertices<=4/8)]<- 4
  	vertices[which(2/8<vertices & vertices<=3/8)]<- 3
		vertices[which(1/8<vertices & vertices<=2/8)]<- 2
		vertices[which(vertices<=1/8)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1),runif(1))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

###################################################################
# Pentagon
###################################################################

pent.gen <- function(wt){

    weight <- wt

  	len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=5)

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

		loci[1,] <- c(1,0,1)
		loci[2,] <- c(2,s1,c1)
		loci[3,] <- c(3,s2,-c2)
  	loci[4,] <- c(4,-s2,-c2)
  	loci[5,] <- c(5,-s1,c1)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>4/5)]<- 5
  	vertices[which(3/5<vertices & vertices<=4/5)]<- 4
  	vertices[which(2/5<vertices & vertices<=3/5)]<- 3
		vertices[which(1/5<vertices & vertices<=2/5)]<- 2
		vertices[which(vertices<=1/5)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1,-s1,s1),runif(1,-c2,1))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

###################################################################
# Hexagon
###################################################################

hex.gen <- function(wt){

    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=3,nrow=6)

    alpha <- 0.5
    beta  <- sqrt(3)/2

		loci[1,] <- c(1,0,2*alpha)
		loci[2,] <- c(2,beta,alpha)
		loci[3,] <- c(3,beta,-alpha)
  	loci[4,] <- c(4,0,-2*alpha)
  	loci[5,] <- c(5,-beta,-alpha)
    loci[6,] <- c(6,-beta,alpha)

    # vertices contains all random vertex points
    vertices <- runif(len)
		vertices[which(vertices>5/6)]<- 6
    vertices[which(4/6<vertices & vertices<=5/6)]<- 5
  	vertices[which(3/6<vertices & vertices<=4/6)]<- 4
  	vertices[which(2/6<vertices & vertices<=3/6)]<- 3
		vertices[which(1/6<vertices & vertices<=2/6)]<- 2
		vertices[which(vertices<=1/6)]<- 1

		coords <- matrix(NA,ncol=2,nrow=(len+1))
		colnames(coords)<-c("x","y") #needed for ggvis

    # randomly selected initial point in field of view
		coords[1,] <- c(runif(1,-beta,beta),runif(1,-2*alpha,2*alpha))

  	for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      x.new <- (weight)*x + (1-weight)*coords[i,1]
	    y.new <- (weight)*y + (1-weight)*coords[i,2]
	    coords[row,]<-c(x.new,y.new)
		}

    return(list(loci,vertices,coords))
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

output$my.init <- renderUI({
  input$shape
    sliderInput(inputId = "init",
      "Number of points (n):",
      min = 1,
      max = 100,
      step = 1,
      value = 1,
      animate=animationOptions(interval = 1000))
  })

output$my.extend <- renderUI({
  input$shape
    sliderInput("extend",
      "Number of points (n):",
      min = 100,
      max = 1000,
      step = 25,
      value = 100,
      animate=animationOptions(interval = 400))
  })

output$my.pts <- renderUI({
  input$shape
    sliderInput("pts",
      "Number of points (n):",
      min = 1000,
      max = 50000,
      step = 1000,
      value = 1000,
      animate=animationOptions(interval = 200))
    })

  updateButton(session, "gen", style = "primary", size = "default", disabled = FALSE)

  all.list <- reactive({
    if (input$shape == "tri") {
      return(tri.gen(input$dist.tri*(input$gen>-1)))
      }
    if (input$shape == "sqr") {
      return(sqr.gen(input$dist.sqr*(input$gen>-1)))
      }
    if (input$shape == "pent") {
      return(pent.gen(input$dist.pent*(input$gen>-1)))
      }
    if (input$shape == "hex") {
      return(hex.gen(input$dist.hex*(input$gen>-1)))
      }
    })

##################################
# initPlot                       #
##################################

  output$initPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:INIT             #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (!is.null(input$init)) {
      if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0.5 & coords[1,2]<=sqrt(3)/4) {
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0.5 & coords[1,2]>sqrt(3)/4) {
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0.5 & coords[1,2]>sqrt(3)/4) {
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0.5 & coords[1,2]<=sqrt(3)/4) {
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }
    }

    #############################
    # Square:INIT               #
    #############################
    if (input$shape == "sqr") {

          par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0.5 & coords[1,2]<=0.5) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0.5 & coords[1,2]>0.5) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0.5 & coords[1,2]>0.5) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0.5 & coords[1,2]<=0.5) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }

    #############################
    # Pentagon:INIT             #
    #############################
    if (input$shape == "pent") {

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0 & coords[1,2]<=0) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0 & coords[1,2]>0) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0 & coords[1,2]>0) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0 & coords[1,2]<=0) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }

    #############################
    # Hexagon:INIT              #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")

    if (input$init==1) {
      points(coords[1,1],coords[1,2],pch=20,cex=3,col="blue")

      if (coords[1,1]>=0 & coords[1,2]<=0) { # LOWER RIGHT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]>=0 & coords[1,2]>0) {  # UPPER RIGHT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=2)
      }
      if (coords[1,1]<0 & coords[1,2]>0) {   # UPPER LEFT
        text(coords[1,1],coords[1,2]-0.04,"Random Starting Point",col="blue",pos=4)
      }
      if (coords[1,1]<0 & coords[1,2]<=0) {  # LOWER LEFT
        text(coords[1,1],coords[1,2]+0.04,"Random Starting Point",col="blue",pos=4)
      }
    }
    }
    ##################################################################################
    ### APPLIED TO ALL

    if (!is.null(input$init)) {
      if (input$init!=1) {
    points(coords[1:input$init-1,1],coords[1:input$init-1,2],pch=20,cex=1,col="blue")

    points(coords[input$init-1,1],coords[input$init-1,2],pch=20,cex=2.75,col="blue")
    points(coords[input$init,1],coords[input$init,2],pch=21,cex=3,col="blue",bg="white")
    points(coords[input$init,1],coords[input$init,2],pch=20,cex=2.75,col="blue")

    x0 <- coords[input$init-1,1]
    y0 <- coords[input$init-1,2]
    x1 <- coords[input$init,1]
    y1 <- coords[input$init,2]

    Arrows((.6*x0+.4*x1),(.6*y0+.4*y1),(.4*x0+.6*x1),(.4*y0+.6*y1),col="blue",lwd=2)

    v.x <- loci[loci[,1]==vertices[input$init-1],2]
    v.y <- loci[loci[,1]==vertices[input$init-1],3]

    points(v.x,v.y,pch=1,cex=4,lwd=2)
    points(v.x,v.y,pch=1,cex=3,lwd=2)
    }
        }

    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # initPlot's renderPlot

##################################
# extendPlot                     #
##################################
  output$extendPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:EXTEND           #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Square:EXTEND             #
    #############################
    if (input$shape == "sqr") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Pentagon:EXTEND           #
    #############################
    if (input$shape == "pent") {

    c1 <- 0.25*(sqrt(5)-1)
    c2 <- 0.25*(sqrt(5)+1)
    s1 <- 0.25*(sqrt(10+2*sqrt(5)))
    s2 <- 0.25*(sqrt(10-2*sqrt(5)))

    par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Hexagon:EXTEND            #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    ############################################################################
    ### APPLIED TO ALL
    if (!is.null(input$extend)) {
    if (input$extend!=0) {
    points(coords[1:input$extend,1],coords[1:input$extend,2],pch=20,cex=1,col="blue")
    }
    }

    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # extendPlot's renderPlot

##################################
# compPlot                       #
##################################
  output$compPlot <- renderPlot({

    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    #############################
    # Triangle:COMPLETE         #
    #############################
    if (input$shape == "tri") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,sqrt(3)/2),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Square:COMPLETE           #
    #############################
    if (input$shape == "sqr") {

        par(mar=c(0.5,0.5,0.5,0.5))
    plot(0,0,xlim=c(0,1),ylim=c(0,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Pentagon:COMPLETE         #
    #############################
    if (input$shape == "pent") {

      c1 <- 0.25*(sqrt(5)-1)
      c2 <- 0.25*(sqrt(5)+1)
      s1 <- 0.25*(sqrt(10+2*sqrt(5)))
      s2 <- 0.25*(sqrt(10-2*sqrt(5)))

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-s1,s1),ylim=c(-c2,1),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    #############################
    # Hexagon:COMPLETE          #
    #############################
    if (input$shape == "hex") {

      alpha <- 0.5
      beta  <- sqrt(3)/2

      par(mar=c(0.5,0.5,0.5,0.5))
      plot(0,0,xlim=c(-beta,beta),ylim=c(-2*alpha,2*alpha),col=0,
            yaxt="n",xaxt="n",xlab="",ylab="",bty="n")
    }

    ##############################################################################
    ### APPLIED TO ALL
    if (!is.null(input$pts)) {
      if (input$pts!=0) {
    points(coords[1:input$pts,1],coords[1:input$pts,2],pch=".",cex=2.5,col="blue")
      }
    }
    points(loci[,2],loci[,3],pch=20,cex=2,col="red")

  }) # compPlot's renderPlot

})


#Let's build a dataset : height of 10 sorgho and poacee sample in 3 environmental conditions (A, B, C)
A=c(rep("sorgho" , 10) , rep("poacee" , 10) )
B=rnorm(20,10,4)
C=rnorm(20,8,3)
D=rnorm(20,5,4)
data=data.frame(A,B,C,D)
colnames(data)=c("specie","cond_A","cond_B","cond_C")

#Let's calculate the average value for each condition and each specie with the *aggregate* function
bilan=aggregate(cbind(cond_A,cond_B,cond_C)~specie , data=data , mean)
rownames(bilan)=bilan[,1]
bilan=as.matrix(bilan[,-1])

#Then it is easy to make a classical barplot :
lim=1.2*max(bilan)
ze_barplot = barplot(bilan , beside=T , legend.text=T , col=c("blue" , "skyblue") , ylim=c(0,lim))

#I becomes a bit more tricky when we want to add the error bar representing the confidence interval.
#First I create a smell function that takes...in entry
error.bar <- function(x, y, upper, lower=upper, length=0.1,...){
  arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...)
}

#Then I calculate the standard deviation for each specie and condition :
stdev=aggregate(cbind(cond_A,cond_B,cond_C)~specie , data=data , sd)
rownames(stdev)=stdev[,1]
stdev=as.matrix(stdev[,-1]) * 1.96 / 10

I am ready to add the error bar on the plot using my "error bar" function !
png("#4_barplot_with_IC.png" ,  width = 480, height = 480)
ze_barplot = barplot(bilan , beside=T , legend.text=T ,
                  col=c("blue" , "skyblue") , ylim=c(0,lim) , ylab="height")
error.bar(ze_barplot,bilan, stdev)
dev.off()


#' @export
#' @title ellipse.2d
#' @description This function calculates a 2D kernel density then plot highest density regions with contour().
#' @param \code{x}
#' @param \code{y}
#' @param \code{pv} the density of the region to be outlined - defaults to 95 percent (i.e. 0.05)
#' @param \code{sc} a scaling factor? defaults to 50
#' @references \url{https://stat.ethz.ch/pipermail/r-help/2000-March/005973.html}
#' @family  plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
ellipse.2d = function( x, y, pv=0.05, sc=50 ) {
  library(KernSmooth)
  xr = range( x, na.rm=T)
  yr = range( y, na.rm=T)
  dx = (xr[2] - xr[1] ) / sc
  dy = (yr[2] - yr[1] ) / sc
  z = bkde2D(cbind(x,y), bandwidth=c(dx,dy))
  zsort <- sort(z$fhat)
  p <- cumsum(zsort)/sum(zsort)
  contour(z$x1, z$x2, z$fhat, levels=min(zsort[p>=pv]), add=T, labels="", drawlabels=F )
  # points(x,y, pch=20)
}


  ## Avoid printing to unwarranted accuracy
  od <- options(digits = 5)
  x <- 0:10
  y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)

  ## Easy one-dimensional MLE:
  nLL <- function(lambda) -sum(stats::dpois(y, lambda, log = TRUE))
  fit0 <- mle(nLL, start = list(lambda = 5), nobs = NROW(y))
  # For 1D, this is preferable:
  fit1 <- mle(nLL, start = list(lambda = 5), nobs = NROW(y),
              method = "Brent", lower = 1, upper = 20)
  stopifnot(nobs(fit0) == length(y))

  ## This needs a constrained parameter space: most methods will accept NA
  ll <- function(ymax = 15, xhalf = 6) {
    if(ymax > 0 && xhalf > 0)
      -sum(stats::dpois(y, lambda = ymax/(1+x/xhalf), log = TRUE))
    else NA
  }
  (fit <- mle(ll, nobs = length(y)))
  mle(ll, fixed = list(xhalf = 6))
  ## alternative using bounds on optimization
  ll2 <- function(ymax = 15, xhalf = 6)
    -sum(stats::dpois(y, lambda = ymax/(1+x/xhalf), log = TRUE))
  mle(ll2, method = "L-BFGS-B", lower = rep(0, 2))

  AIC(fit)
  BIC(fit)

  summary(fit)
  logLik(fit)
  vcov(fit)
  plot(profile(fit), absVal = FALSE)
  confint(fit)

  ## Use bounded optimization
  ## The lower bounds are really > 0,
  ## but we use >=0 to stress-test profiling
  (fit2 <- mle(ll, method = "L-BFGS-B", lower = c(0, 0)))
  plot(profile(fit2), absVal = FALSE)

  ## a better parametrization:
  ll3 <- function(lymax = log(15), lxhalf = log(6))
    -sum(stats::dpois(y, lambda = exp(lymax)/(1+x/exp(lxhalf)), log = TRUE))
  (fit3 <- mle(ll3))
  plot(profile(fit3), absVal = FALSE)
  exp(confint(fit3))

  options(od)


#Dimensionality reduction
#次元削減

#参考
#https://www.slideshare.net/mikayoshimura50/150905-wacode-2nd
#http://d.hatena.ne.jp/hoxo_m/20120313/p1
#https://blog.albert2005.co.jp/2014/12/11/%E9%AB%98%E6%AC%A1%E5%85%83%E3%83%87%E3%83%BC%E3%82%BF%E3%81%AE%E5%8F%AF%E8%A6%96%E5%8C%96%E3%81%AE%E6%89%8B%E6%B3%95%E3%82%92swiss-roll%E3%82%92%E4%BE%8B%E3%81%AB%E8%A6%8B%E3%81%A6%E3%81%BF%E3%82%88/

dr <- function(formula, data, normalize = TRUE, unique = TRUE,
               methods = c("pca", "kpca" ,"mds", "tsne", "lle", "som", "diffmap"),
               kpca.par = list(kernel = "rbfdot", sigma = 0.1),
               mds.par = list(k = 2),
               tsne.par = list(dims = 2, initial_dims = 50, perplexity = 30, theta = 0.5),
               lle.par = list(m = 2, k = 5, reg = 2, p = 0.5),
               som.par = list(xdim = 5, ydim = 6),
               diffmap.par = list(neigen = NULL, t = 0, maxdim = 50, delta=10^-5))
  {

  #kpca.par はsigma,degree, scale, offset,orderも指定できる。
  #tsne.parのdimsは3以下がよい。

  #入力をチェック---
  if(is.null(formula)){stop("formula is null.")}
  if(is.null(data)){stop("data is null.")}

  #データを準備---
  ret <- list() #戻り値
  ret$parameter$formula <- formula
  ret$parameter$normalize <- normalize
  ret$parameter$unique <- unique

  #解析用データ
  if(length(formula) == 3){
    data.original <- model.matrix(object = formula[-2], data = data)[,-1] #解析用データ。[,-1]で切片を除く。
  }else{
    data.original <- model.matrix(object = formula, data = data)[,-1] #解析用データ。[,-1]で切片を除く。
  }

  #ユニークなデータを抜粋
  #https://qiita.com/weda_654/items/97c8dbba9f8198845537
  u.no <- !duplicated(data.original)
  data.original <- data.original[u.no,]

  #目的変数がある場合の処理
  if(length(formula) == 3){
    y.formula  <- as.formula(paste0(as.character(formula[2]), "~+0"))
    y.data <- model.frame(y.formula, data)[u.no,1]
    ret$y <- y.data
    formula[2] <- NULL #目的変数を削除
  }else{
    ret$y <- NULL
  }

  #説明変数の項目名を抜粋
  ret$parameter$names  <- names(data.original[1, ])

  #規格化。data.maが解析用の元データのマトリクス
  if(normalize){
    data.mean <- apply(data.original, 2, mean)
    data.sd <- apply(data.original, 2, sd)
    #規格化。もうちょっとスマートなのがある気がする…
    data.ma <- t(apply(data.original,1,function(x){(x - data.mean)/data.sd}))
  }else{
    data.mean <- NULL
    data.sd <- NULL
    data.ma <- data.original
  }
  ret$parameter$data.mean <- data.mean
  ret$parameter$data.sd <- data.sd

  #変換
  data.df <- data.frame(data.ma) #データフレームに変換
  data.di <- dist(data.ma) #dist classの距離に変換

  #ここから解析本体-----------------------------------------------

  #PCA
  #(数値のみしか使用できない。)
  if(!is.na(match("pca", methods))){
    cat("\n[Principal Components Analysis] \n")
    ret$pca <- prcomp(~., data = data.df,
                      scale = normalize, center = normalize,
                      retx = TRUE)
  }

  #kernel PCA
  if(!is.na(match("kpca", methods))){
    cat("\n[Kernel Principal Components Analysis] \n")
    #kpcaに渡すデータを編集。
    kpca.kernel <- kpca.par$kernel
    kpca.par$kernel <- NULL

    #kpca本体
    ret$kpca <- kpca(x = ~., data = data.df,
                     kernel = kpca.kernel, kpar = kpca.par)
  }

  #MDS
  if(!is.na(match("mds", methods))){
    cat("\n[Classical Multidimensional Scaling]\n")
    ret$mds <- cmdscale(d = as.matrix(data.di), k = mds.par$k)
  }

  #t-SNE
  #https://blog.albert2005.co.jp/2015/12/02/tsne/
  #注意点として、t-SNE で圧縮する次元は、 2・3 次元が推奨されています
  if(!is.na(match("tsne", methods))){
    cat("\n[t-Distributed Stochastic Neighbor Embedding]\n")
    ret$tsne <- Rtsne(data.df,
                      dims = tsne.par$dims, initial_dims = tsne.par$initial_dims,
                      perplexity = tsne.par$perplexity, theta = tsne.par$theta)
  }

  #LLE
  #m,kは再考の必要あり。
  if(!is.na(match("lle", methods))){
    cat("\n[Locally linear embedding]\n")
    ret$lle <- lle(data.ma, m = lle.par$m,
                   k = lle.par$k,
                   reg = lle.par$reg, p = lle.par$p)
  }

  #SOM
  #その他のパラメータもあったほうがいい？
  if(!is.na(match("som", methods))){
    cat("\n[Self-Organizing Map]\n")
    ret$som <- som(data.df, xdim=som.par$xdim, ydim=som.par$ydim)
  }

  #diffusion map
  if(!is.na(match("diffmap", methods))){
    cat("\n[Diffusion Map]\n")
    ret$diffmap <- diffuse(data.di,
                           neigen = diffmap.par$neigen,
                           t = diffmap.par$t, maxdim = diffmap.par$maxdim,
                           delta = diffmap.par$delta)
  }

  #戻り値
  class(ret) <- "dr"
  return(ret)
}

predict.dr <- function(result, data){
  data.original <- model.matrix(object = result$parameter$formula, data = data)[,-1]

  #モデルで使用した説明変数と、新データで作った説明変数が一致するか確認。
  #カテゴリカル変数まわりでエラーが起きる気がする。
  if(!setequal(result$parameter$names, names(data.original[1, ]))){
    stop("Explanatory variable is different from model.")
  }

  #規格化。data.maが解析用の元データのマトリクス
  if(result$parameter$normalize){
    #規格化。もうちょっとスマートなのがある気がする…
    data.ma <- t(apply(data.original,1,
                       function(x){(x - result$parameter$data.mean)/result$parameter$data.sd}))
  }else{
    data.ma <- data.original
  }

  #変換
  data.df <- data.frame(data.ma) #データフレームに変換

  res <- list()

  res$pca <- predict(result$pca, data.df)
  res$kpca <- predict(result$kpca, data.df)

  #res$tsne <- predict(result$tsne, data.df)
  #https://stackoverflow.com/questions/43377941/t-sne-predictions-in-r
  #t-SNEでpredictできないみたい。
  #res$lle <- predict(result$lle, data.ma)
  #res$som <- predict(result$som, data.df)
}

plot.dr <- function(result, cex = 1){
  if(!is.null(result$y)){
    if(is.factor(result$y)){
      col_p <- rainbow(length(unique(result$y)))
      plot_bg <- col_p[unclass(result$y)]
    }else{
      rank_y <- round(rank(result$y))
      plot_bg <- heat.colors(length(result$y))[rank_y]
    }
  }else{
    plot_bg <- NULL; col_p <- NULL
  }

  chk_hit <- FALSE
  hit_ret <- function(chk_hit){
    if(chk_hit){
      cat("Hit <Return> to see next plot: \n")
      readline()
    }
  }

  plot_dr <- function(x, y, main, xlab, ylab){
    hit_ret(chk_hit)
    #https://www1.doshisha.ac.jp/~mjin/R/Chap_07/07.html
    plot(x, y, main = main, xlab = xlab, ylab = ylab, type = "p", pch = 21, cex = cex, bg = plot_bg)

  }

  if(!is.null(result$pca)){
    plot_dr(x = result$pca$x[,1], y = result$pca$x[,2],
            main = "Principal Components Analysis", xlab = "PC1", ylab = "PC2")
    chk_hit <- TRUE
  }

  if(!is.null(result$kpca)){
    plot_dr(x = result$kpca@pcv[,1], y = result$kpca@pcv[,2],
            main = "Kernel Principal Components Analysis",
            xlab = "K-PC1", ylab = "K-PC2")
    chk_hit <- TRUE
  }

  if(!is.null(result$mds)){
    plot_dr(x = result$mds[,1], y = result$mds[,2],
            main = "Classical Multidimensional Scaling", xlab = "Dimension 1", ylab = "Dimension 2")
    chk_hit <- TRUE
  }

  if(!is.null(result$tsne)){
    plot_dr(x = result$tsne$Y[,1], y = result$tsne$Y[,2],
            main = "t-Distributed Stochastic Neighbor Embedding", xlab = " ", ylab = " ")
    chk_hit <- TRUE
  }

  if(!is.null(result$lle)){
    plot_dr(x = result$lle$Y[,1], y = result$lle$Y[,2],
            main = "Locally linear embedding main function", xlab = " ", ylab = " ")
    chk_hit <- TRUE
  }

  if(!is.null(result$som)){
    plot_dr(x = result$som$visual$x, y = result$som$visual$y,
            main = "Self-Organizing Map", xlab = "x", ylab = "y")
    chk_hit <- TRUE
  }

  if(!is.null(result$diffmap)){
    plot_dr(x = result$diffmap$X[,1], y = result$diffmap$X[,2],
            main = "diffusion map", xlab = " ", ylab = " ")
    chk_hit <- TRUE
  }

}


### fimd4.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 7mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

library("mice")
library("lattice")

### Chapter 4 Multivariate missing data

### Section 4.1 Missing data patterns

### define data sets pattern1-pattern4 with four patterns
data <- matrix(sample(1:100,4*8*3,replace=TRUE),nrow=8*4,
                dimnames=list(NULL,c("A","B","C")))
data <- as.data.frame(data)
data[c(31:32),"A"] <- NA
data[c(15:16,22:24,30:32),"B"] <- NA
data[c(6:8,12:16,17:21,27:29),"C"] <- NA
mdpat <- cbind(expand.grid(rec = 8:1, pat = 1:4, var = 1:3), r=as.numeric(as.vector(is.na(data))))
pattern1 <- data[1:8,]
pattern2 <- data[9:16,]
pattern3 <- data[17:24,]
pattern4 <- data[25:32,]

### Figure 4.1
types <-  c("Univariate","Monotone","File matching","General")
tp41 <- levelplot(r~var+rec|as.factor(pat), data=mdpat,
          as.table=TRUE, aspect="iso",
          shrink=c(0.9),
          col.regions = mdc(1:2),
          colorkey=FALSE,
          scales=list(draw=FALSE),
          xlab="", ylab="",
          between = list(x=1,y=0),
          strip = strip.custom(bg = "grey95", style = 1,
            factor.levels = types))
print(tp41)

md.pattern(pattern4)
p <- md.pairs(pattern4)
p

### proportion of usable cases
p$mr/(p$mr+p$mm)

### outbound statistics
p$rm/(p$rm+p$rr)

### Figure 4.2
par(mfrow=c(2,2))
fluxplot(pattern1, main="", xlim=c(-0.1,1.1), ylim=c(-0.1,1.1))
text(x=0.5,y=1,label="Univariate")
fluxplot(pattern2, main="", xlim=c(-0.1,1.1), ylim=c(-0.1,1.1))
text(x=0.5,y=1,label="Monotone")
fluxplot(pattern3, main="", xlim=c(-0.1,1.1), ylim=c(-0.1,1.1))
text(x=0.5,y=1,label="File matching")
fluxplot(pattern4, main="", xlim=c(-0.1,1.1), ylim=c(-0.1,1.1))
text(x=0.5,y=1,label="General")

### calculate pobs, influx, outflux of general pattern
flux(pattern4)[,1:3]

### section 4.3 Monotone data imputation
### monotone data imputation on three columns
data <- nhanes2[,1:3]
md.pattern(data)
imp <- mice(data, visit="monotone", maxit=1, m=2)

### Numerical example, approximate two-step
ini <- mice(nhanes2, maxit=0)
pred <- ini$pred
pred["bmi","chl"] <- 0
pred["hyp",c("chl","bmi")] <- 0
imp <- mice(nhanes2, vis="monotone", pred=pred, maxit=1, m=2)

### Section 4.5 Fully Conditional Specification

### Example of slow convergence
generate <- function(n = c(1000, 4500, 4500, 0),
                     cor = matrix(c(1, 0.9, 0.9, 0.9, 1, 0.7, 0.9, 0.7, 1), nrow = 3)) {
  require(MASS)
  nt <- sum(n)
  cs <- cumsum(n)
  data <- mvrnorm(nt, mu = rep(0,3), Sigma = cor)
  dimnames(data) <- list(1:nt, c("X", "Y1", "Y2"))
  if (n[2] > 0) data[(cs[1]+1):cs[2],"Y1"] <- NA
  if (n[3] > 0) data[(cs[2]+1):cs[3],"Y2"] <- NA
  if (n[4] > 0) data[(cs[3]+1):cs[4],c("Y1","Y2")] <- NA
  return(data)
}

impute <- function(data, m = 5, method="norm", print=FALSE, maxit = 10, ...) {
  statistic <- matrix(NA, nrow=maxit, ncol=m)
  for (iter in 1:maxit) {
    if (iter==1) imp <- mice(data, m = m, method = method, print=print, maxit = 1, ...)
    else imp <- mice.mids(imp, maxit=1, print=print, ...)
    statistic[iter,] <- unlist(with(imp, cor(Y1,Y2))$analyses)
  }
  return(list(imp=imp, statistic=statistic))
}

simulate <- function(ns=matrix(c(1000,500,250,100,50,0,
                               rep(c(4500,4750,4875,4950,4975,5000),2),
                       rep(0,6)), nrow=6), m = 5, maxit=10,
                       seed=1, ...) {
  if (!missing(seed)) set.seed(seed)
  s <- cbind(rep(1:nrow(ns), each=maxit*m),
             apply(ns, 2, rep, each=maxit*m),
             rep(1:maxit,each=m), 1:m, NA)
  colnames(s) <- c("k","n111","n101","n110","n100","iteration","m","rY1Y2")
  for (k in 1:nrow(ns)){
    data <- generate(ns[k,], ...)
    r <- impute(data, m=m, maxit=maxit, ...)
    s[s[,"k"]==k,"rY1Y2"] <- t(r$statistic)
  }
  return(data.frame(s))
}

### perform simulation - TIME CONSUMING (10 minutes)
slow.demo <- simulate(maxit=150, seed=62771)

### Figure 4.3
labels <- c("90% missing", "95% missing", "97.5% missing",
            "99% missing", "99.5% missing", "100% missing")
tp43 <- xyplot(rY1Y2~iteration|as.factor(k), group=m,
       data = slow.demo, layout=c(3,2),
       type="l", as.table = TRUE,
       ylab = "Correlation between Y1 and Y2",
       xlab = "Iteration", col=mdc(3),
       scales=list(y=list(alternating=1, tck=c(1,0))),
       strip = strip.custom(bg="grey95", style=1,
         factor.levels=labels))
print(tp43)

### Section 4.6.3 Illustration

## boys data: select subset
select <- with(boys, age>=8 & age<=21.0)

### version with all numeric data for jm and pmm
djm <- boys[select,-4]
djm$gen <- as.integer(djm$gen)
djm$phb <- as.integer(djm$phb)
djm$reg <- as.integer(djm$reg)

### version with categorical variables for fcs
dfcs <- boys[select,-4]

### impute according to joint multivariate normal
jm.10 <- mice(djm, method="norm", seed=93005, m=10)

### impute according to predictive mean matching
pmm.10 <- mice(djm, seed=71332,m=10)

### impute according to proportional odds model
fcs.10 <- mice(dfcs, seed=81420, m=10)

### Figure 4.4
tp44 <- xyplot(jm.10, gen~age|.imp, subset=as.integer(.imp)<7,
       xlab="Age", ylab="Genital stage")
print(tp44)

### Figure 4.5
tp45 <- xyplot(fcs.10, gen~age|.imp, subset=as.integer(.imp)<7,
       xlab="Age", ylab="Genital stage")
print(tp45)

### Figure 4.6 is too complex, and will not be given here


#' @title calcResistanceShipPwr
#'
#' @description Calculate ship power (kW) for resistance-based power models.
#'
#' @param Rtot Total ship resistance (vector of numericals, kN) (see
#' \code{\link{calcKristTotalRes}} or \code{\link{calcHMTotalRes}})
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'  \code{\link{calcSpeedUnitConversion}})
#' @param hullEff Hull efficiency (vector of numericals, dimensionless) (see
#' \code{\link{calcHullEff}})
#' @param openWaterEff Open water efficiency (vector of numericals,
#' dimensionless) (see \code{\link{calcOpenWaterEff}})
#' @param totalInstalledPwr Total installed main engine power (vector of
#' numericals, kW) (maximum
#' continuous rated power)
#' @param shaftEff Shaft efficiency (dimensionless). Default = 0.98.
#'  Ratio of power delivered to the propeller and the brake power delivered by
#'  the engine. Can supply either a vector of numericals, a single
#'  number, or rely on the default
#' @param relRotationEff Relative rotational efficiency (dimensionless).
#'  Default = 1. Accounts for effect of rotational flow of water around propeller.
#'  Can supply either a vector of numericals, a single number, or rely on the default
#' @param pwrUpperBoundPercent Percent of total installed power at which
#' required power is capped (1 indicates required power cannot exceed
#' \code{totalInstalledPwr}). Can supply either a vector of numericals, a single
#'  number, or rely on the default
#' @param pwrLowerBoundPercent Percent of total installed power to act as lower
#' bound for required power (0.02 indicates required power cannot go below 2\%
#' of \code{totalInstalledPwr}). Can supply either a vector of numericals, a
#' single number, or rely on the default
#'
#' @return power (vector of numericals, kW)
#'
#' @details
#' This function is called by both Holtrop & Mennen (\code{\link{calcHMPwr}})
#' and Kristensen (\code{\link{calcKristPwr}}) power calculations, where each
#' uses has its own total resistance calculation (\code{\link{calcHMTotalRes}}
#' and \code{\link{calcKristTotalRes}}).
#'
#' Assumptions for shaft efficiency and relative rotational efficiency are based
#' on MAN.
#'
#' @references
#'
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#' @seealso
#' \itemize{
#' \item \code{\link{calcKristTotalRes}}
#' \item \code{\link{calcHMTotalRes}}
#' \item \code{\link{calcSpeedUnitConversion}}
#' \item \code{\link{calcHullEff}}
#' \item \code{\link{calcOpenWaterEff}}
#' \item \code{\link{calcHMPwr}}
#' \item \code{\link{calcKristPwr}}
#' }
#'
#' @examples
#' calcResistanceShipPwr(398.487,10.8, 1.191176, 0.721239,9363, shaftEff=0.98,relRotationEff=1)
#'
#' @export

calcResistanceShipPwr <- function(Rtot,shipSpeed, hullEff, openWaterEff,totalInstalledPwr,
                                  shaftEff=0.98,relRotationEff=1, pwrUpperBoundPercent=1, pwrLowerBoundPercent=0.02){

  power <-ifelse(shipSpeed==0,
                 0,
                 pmin(pwrUpperBoundPercent*totalInstalledPwr,
    pmax(pwrLowerBoundPercent*totalInstalledPwr,
         ((Rtot*shipSpeed)/
            (hullEff*openWaterEff*shaftEff*relRotationEff))
    )
  )
  )

  return(power)

}


####################################################################################################
# 4. faza: Napredna analiza podatkov
####################################################################################################
#NAVODILA:
#-sestavite predikcijski model za napovedovanje:
#   za prihodnost, kako je neka vrednost odvisna od drugih, morda uporabite kako metodo iz strojnega učenja, ...
#-na podlagi modela naključno modelirate nove podatke (npr. napovedovanje gibanja delnic),
#-s pomočjo razvrščanja določite skupine s podobnimi lastnostmi,
#-s pomočjo gručenja izločite osamelce (in morda tako izboljšate model), ali pa za različne
# skupine podatkov naredite različne modele.

#-Kot rezultat te faze lahko sestavite tudi aplikacijo v ogrodju Shiny (za boljšo oceno).
#-Vaš program bo narisal enega ali več grafov (lahko tudi zemljevidov),
#ki jih boste nato vključili v poročilo skupaj z opisom vaše analize in njenimi zaključki.

#---------------------------------------------------------------------------------------------------
#PLAN/KAJ ME ZANIMA:
#-predikcijski model za napovedovanje kdo bo zmagal na olimpijskih igrah 2021 skupinske
#-(predikcijski model za napovedovanje verjetne izbire tekmovalk, ki bodo zastopale Rusijo)
#-novi podatki: kakšne bodo ocene na OI za dino, arino in linoy
#-grupiranje E/D (induvidualne) in skupinske
#-s pomočjo razvrščanja določimo skupine tekmovalk ki so bolj spretne z rekvizitom in tiste ki imajo boljšo tehniko s telesom
#-Grupiranje po rekvizitih - kateter jim je boljši induv (in skupinsko)
#-s pomočjo gručenja izločite osamelce - soldatova, kaylen, (lala) zaradi BD (in morda tako izboljšate model), ali pa za različne
# skupine podatkov naredite različne modele.
#-----------------------------------------------------------------------------------------------------

#require(ggplot2) #geom_smooth, geom_segment - ravne črte med toččkami
#require(dplyr)
#library(NbClust) #Za določanje skupin: NbClust
#require(ggdendro) #za dendrograme: ggdendrogram, dendro_data (izvoz podatkov v obliko dalahko delamo z ggplot), segment za povezave v dendrogramu,
                  #theme_dendro
#require(ggrepel) #za overlapping

#============================================================================================
#1. KATERA DRŽAVA BO ZMAGALA NA OLIMPIJSKIH IGRAH V SKUPINSKIH SESTAVAH
#============================================================================================
#View(skupinske)

#----------------------------------------------------------------
#graf-za lažje predstavljanje podatkov
#----------------------------------------------------------------
ggplot(skupinske, aes(x = D, y = E, col = tekma)) +
  geom_point()

#---------------------------------------------------------------
# MODEL
#--------------------------------------------------------------
#lm{stats} - koliko je stolpec D odvisen od E
model_skupinske_obroci_kiji <- lm(E ~ D, data=skupinske%>%filter(rekvizit == "3 obroči + 4 kiji"))
model_skupinske_zoge <- lm(E ~ D, data=skupinske%>%filter(rekvizit == "5 žog"))

#------------------------------------------------------------------
# IZRIS LINEARNEGA MODELA
#------------------------------------------------------------------
ggplot(skupinske, aes(x = D, y = E)) +
  geom_point() +
  facet_grid(.~rekvizit)+
  geom_smooth(method=lm, formula=y~x) #ggplot2

#-----------------------------------------------------------------
# PREDIKCIJA. Kakšna bo E ko bodo D dvignile na 32, 35
#-----------------------------------------------------------------
novDskupinske <- data.frame(D=c(32, 35))
#predict {stats}
predict(model_skupinske_obroci_kiji, novDskupinske) #5.315866 4.698013
predict(model_skupinske_zoge, novDskupinske) #8.735773 9.121857

#tabela s stolpcem D in E
napovedEskupinske_obroci_kiji <- novDskupinske %>% mutate(E=predict(model_skupinske_obroci_kiji, .))
napovedEskupinske_zoge <- novDskupinske %>% mutate(E=predict(model_skupinske_zoge, .))

#napovedE_tabela_skupinske <- napovedEskupinske %>%
#  mutate(drzava = "napoved", tekma = 2021, rekvizit = c("3 obroči + 4 kiji", "5 žog"), Pen.= 0.00, koncna_ocena = c(7.518193+32, 7.536600+35) )

#napovedEskupinske_obroci_kiji %>% View
#napovedEskupinske_zoge %>% View
#napovedE_tabela_skupinske %>% view

#skupinske_predikcija_napoved <- rbind(napovedE_tabela_skupinske, skupinske)
#skupinske_predikcija_napoved #%>% view

########################################################################
#----------------
# izris napovedi
#----------------
predikcija_skupinske_obroci_kiji <- ggplot(skupinske%>%filter(rekvizit == "3 obroči + 4 kiji"), aes(x = D, y = E)) +
  geom_point(shape=1) +
  geom_smooth(method=lm, formula=y~x, fullrange = TRUE) +
  geom_point(data=napovedEskupinske_obroci_kiji, aes(x=D, y=E), color='red', size=3)+
  labs(title = "PREDIKCIJA OCENE E NA OLIMPIJSKIH IGRAH 2021 ZA SKUPINSKE SESTAVE
  V SESTAVI S KOMBINIRANIM REKVIZITOM" )+
  theme_bw()+ #brez sivega ozadja
  theme(legend.position = "none", plot.title = element_text(hjust=0.5))#naslovna na sredini

print(predikcija_skupinske_obroci_kiji)

predikcija_skupinske_zoge <- ggplot(skupinske%>%filter(rekvizit == "5 žog"), aes(x = D, y = E)) +
  geom_point(shape=1) +
  geom_smooth(method=lm, formula=y~x, fullrange = TRUE) +
  geom_point(data=napovedEskupinske_zoge, aes(x=D, y=E), color='red', size=3)+
  labs(title = "PREDIKCIJA OCENE E NA OLIMPIJSKIH IGRAH 2021 ZA SKUPINSKE SESTAVE
  V SESTAVI Z ŽOGAMI" )+
  theme_bw()+ #brez sivega ozadja
  theme(legend.position = "none", plot.title = element_text(hjust=0.5))#naslovna na sredini

print(predikcija_skupinske_zoge)

#==============================================================================
#2. GRUPIRANJE GLEDE NA E IN GLEDE NA D ZA SKUPINSKE SESTAVE
#==============================================================================

risba_skupinske <- skupinske %>%
  ggplot(aes(x=D, y=E, col=drzava, shape=rekvizit))+
  geom_point()+
  theme_minimal()+
  facet_grid(.~tekma)+
  #---------------------------------------------------------
  #oštevilčimo pikice
  #---------------------------------------------------------
  geom_text(
    data=skupinske %>% mutate(n = row_number()),
    aes(label=drzava),
    size=2,
    color='black',
    nudge_x = 0.03,
    nudge_y = 0.03
  )+
  theme_minimal()
print(risba_skupinske)

#KOMENTAR:izgleda kot da bi lahko pogrupirali skupaj v Bakuju:
#Rus, Bul, Jap, Blr

#---------------------------------------------------------------
#STANDARDIZACIJA MATRIKE
#---------------------------------------------------------------
data_skupinske <- skupinske %>%
  select(E,D) %>%
  as.matrix() %>%
  scale() #{base} naredi standardizacijo

#View(data_skupinske)

#----------------------------------------------------------------
#HIERARHIČNO RAZVRŠČANJE
#----------------------------------------------------------------
razdalje_skupinske <- dist(as.matrix(data_skupinske)) #{stats} na i,j tem mestu je razdalja med i-to in j-to vrstico
model_skupinske <- hclust(razdalje_skupinske) #model hierarhičnega razvrščanja; {stats}

#malo pregledamo
#----------------------------------------------------------------
## Dobimo opis postopka razvrščanja
#names(model_skupinske)

# Algoritem za razvrščanje: ward.D, ward.D2, single,
# complete, average, mcquitty, median, centroid
# Lahko podamo kot parameter
#model_skupinske$method

# Tip metrike: pridobljen iz matrike različnosti
# Npr. za D <- dist(X, method="manhattan") bi dobili "manhattan"
#model_skupinske$dist.method

# Opis zaporedja združevanja skupin
#model_skupinske$merge %>% View

# Višine, ko je prišlo do združevanja
#model_skupinske$height

# Preureditev elementov, da bomo lahko lepo izrisali dendrogram
#model_skupinske$order

# Poimenovanja podatkovnih enot.
#model_skupinske$labels

# Opisni klic funkcije, ki je sprožila izračun
#model_skupinske$call

#---------------------------------------------------------
#DENDROGRAM - le vmesen graf
#----------------------------------------------------------
#1. način izrisa dendrograma
#plot(model_skupinske, hang=-1,  cex=0.3, main="skupinske")

#2. način: S pomočjo paketa `ggdendro`
#require(ggdendro)

dendrogram_skupinske <- ggdendrogram(model_skupinske, labels=TRUE) +
  theme(axis.text.y = element_blank())

print(dendrogram_skupinske)

#----------------------------------------------------------------------
# Pridobitev podatkov za izris z ggplot
#----------------------------------------------------------------------
#iz ggdendro uporabimo dendro_data() za izvozi podatke v objekt na katerem lahko uporabljamo ggplot
ddata_skupinske <- dendro_data(model_skupinske, type = "rectangle")
#View(ddata_skupinske)
#names(ddata_skupinske) #"segments"    "labels"      "leaf_labels" "class"

#segment(ddata_skupinske) %>% View #povezave v dendrografu

#-----------------------------------------------------------
#dendrogram brez napisov držav - nepotrebno
#-----------------------------------------------------------
ggplot(segment(ddata_skupinske)) + #segment iz ggdendro za povezave v dendrogramu
  geom_segment(aes(x = x, y = y, xend = xend, yend = yend)) + #ggplot2- ravnačrta med dvema točkama
  #coord_flip() +
  #scale_y_reverse(expand = c(0.2, 0)) +
  theme_dendro() #ggdendro

#################################################
#------------------------------------------------
#dodamo še napise
#-------------------------------------------------
#v tabelo labels dodamo še dva stolpca label in drzava
ddata_skupinske$labels$label <- paste(skupinske$drzava[model_skupinske$order], ddata_skupinske$labels$label %>% as.character)
ddata_skupinske$labels$drzava <- skupinske$drzava[model_skupinske$order]

dendrogg_skupinske <- ggplot(segment(ddata_skupinske)) +
  geom_segment(aes(x = x, y = y, xend = xend, yend = yend), size=1) +  #size debelina črt
  labs( title = "DENDROGRAM DRŽAV GLEDE NA OCENO E IN D")+
  theme(plot.title = element_text(hjust=0.5))+
  coord_flip()  +
  scale_y_reverse(expand = c(0.5, 0)) +
  geom_text(
    data=ddata_skupinske$labels,
    aes(x=x, y=y, label=label, colour=drzava), hjust=0, size=3.5, nudge_y = 0.03, show.legend = FALSE) + #size pisava držav
  theme(axis.line.y=element_blank(),
        axis.ticks.y=element_blank(),
        axis.text.y=element_blank(),
        axis.title.y=element_blank(),
        axis.title.x = element_blank(),
        axis.ticks.x=element_blank(),
        axis.text.x=element_blank(),
        panel.background=element_rect(fill="white"),
        panel.grid=element_blank())
print(dendrogg_skupinske)
#dendrogg + ggsave("dendrogg.pdf", device="pdf")
#iz grafa se zdi da je najbolje razvrstiti v 3 skupine Elbow method

#-------------------------------------------------------
# šTEVILO SKUPIN- RAZVRSTITEV GLEDE NA REZ DENDROGRAMA
#-------------------------------------------------------
# 3 skupine
#-------------------------------
# določanje skupin
#--------------------------------
p3 <- cutree(model_skupinske, k=3) #{stats}
#p3   #1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 2 3 3 3 3 2 2
    #po vrstnem redu iz tabele skupinske nam pove v katero skupino gre posamezna država

#----------------------------------------------------------------------
skupinske$drzava <- recode(skupinske$drzava  #dplyr
                          ,'Bulgaria' = 'BUL'
                          ,'Israel' = 'ISR'
                          ,'Italy' = 'ITA'
                          ,'Japan' = 'JPN'
                          ,'Russia' = 'RUS'
                          ,'Ukraine' = 'UKR'
                          ,'Belarus' = 'BLR'
                          ,'Azerbaijan' = 'AZE'
                          ,'Turkey' ='TUR'
                          ,'China' = 'CHN'
                          ,'France' = 'FRA'
                          ,'Estonia' = 'EST'
                          )

#----------------------------------
#pikice pobarvane v barvah skupine
#-----------------------------------
grupiranje_skupinske3 <- skupinske %>%
  ggplot(aes(x=D, y=E, col=p3, shape = tekma)) +
  guides(color = FALSE)+ #legende za barvo ne potrebujem
  geom_point() +
  geom_text_repel( #iz ggrepel, da se ne prekrivajo imena
    aes(label=drzava),
    size=3,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )+
  labs( title = "GRUPIRANJE DRŽAV GLEDE NA OCENO E IN D")+
  scale_y_continuous(breaks=c(6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5))+
  theme_minimal()+
  theme(plot.title = element_text(hjust=0.5))

print(grupiranje_skupinske3)
  #+ ggsave("risba2.pdf", device="pdf")

#KOMENTAR:
#1. SKUPINA: D med 18.2 in 21.1, E med 7.35 in 8.75
#Bul baku oba rek, Jap baku oba rek, Ita baku kiji+obroč, Blr baku kiji+obroč, Rus baku oba rek,
# china baku oba rek, Azerb baku kiji+obroči samo eni finali, Isr oba rek
#2. SKUPINA: D med 18.5 in 21.6 E 5.7 in 6.8
#ita baku kiksane žoge, Bel baku kiksane žoge, UKr baku kiksane žoge samo to v finalih, Est kijev, Fra kijev, Tur kijev
#3. SKUPINA: D med 23.00 in 27.1 in E 6.25 in 8.25
#Ukr kijev oba, Israel kijev obe, Est kijev žoge , Azer kijev oba, Fra kiji+obroč, tur kiji+obroč

#============================================================================================================
#3. GRUPIRANJE GLEDE NA BD/AD INDUVIDUALNE SESTAVE
#============================================================================================================
#s pomočjo razvrščanja določimo skupine tekmovalk, ki so bolj spretne z rekvizitom
#in tiste ki imajo boljšo tehniko s telesom.

risba_ind <- wcg %>%
  ggplot(aes(x=DA, y=DB, col=tekmovalka, shape=rekvizit))+
  geom_point()+
  theme_minimal()+
  facet_grid(.~tekma)+
  #---------------------------------------------------------
#oštevilčimo pikice
#---------------------------------------------------------
#geom_text(
#  data=wcg %>% mutate(n = row_number()),
#  aes(label=tekmovalka),
#  size=2,
#  color='black',
#  nudge_x = 0.03,
#  nudge_y = 0.03
#)+
  theme_minimal()
print(risba_ind)

#opazimo da Vlada izstopa z višjim DB in da pri DA ni takega izstopanja

#---------------------------------------------------------------
#STANDARDIZACIJA MATRIKE
#---------------------------------------------------------------
data_ind <- wcg %>%
  select(DB,DA) %>%
  as.matrix() %>%
  scale() #{base} naredi standardizacijo

#View(data_ind)

#----------------------------------------------------------------
#RAZVRŠČANJE
#----------------------------------------------------------------
razdalje_ind <- dist(as.matrix(data_ind)) #{stats} na i,j tem mestu je razdalja med i-to in j-to vrstico
model_ind <- hclust(razdalje_ind) #{stats} model

#----------------------------------------------------------------------
# Pridobitev podatkov za izris z ggplot
#----------------------------------------------------------------------
ddata_ind <- dendro_data(model_ind, type = "rectangle")

#------------------------------------------------
#dodamo še napise
#-------------------------------------------------
#v tabelo labels dodamo še dva stolpca label in drzava
ddata_ind$labels$label <- paste(wcg$tekmovalka[model_ind$order], ddata_ind$labels$label %>% as.character)
ddata_ind$labels$tekmovalka <- wcg$tekmovalka[model_ind$order]

###########################################################
dendrogg_ind <- ggplot(segment(ddata_ind)) +
  geom_segment(aes(x = x, y = y, xend = xend, yend = yend), size=0.01) +  #size debelina črt
  coord_flip()  +
  scale_y_reverse(expand = c(0.5, 0)) +
  labs(title = "DENDROGRAM GRUPIRANJA INDUVIDUALNIH
  TEKMOVALK GLEDE NA DB IN DA")+
  geom_text(data=ddata_ind$labels,
    aes(x=x, y=y, label=label, colour=tekmovalka), hjust=0, size=1.5, nudge_y = 0.03, show.legend = FALSE) + #size pisava tekmovalk
  theme(axis.line.y=element_blank(),
        axis.ticks.y=element_blank(),
        axis.text.y=element_blank(),
        axis.title.y=element_blank(),
        axis.title.x = element_blank(),
        axis.ticks.x=element_blank(),
        axis.text.x=element_blank(),
        #legend.key = element_blank(),
        panel.background=element_rect(fill="white"),
        panel.grid=element_blank(),
        plot.title = element_text(hjust=0.5))
print(dendrogg_ind)

#--------------------------------------------
#DOLOČANJE ŠTEVILA SKUPIN
#--------------------------------------------
#library(NbClust)
#-----------------------------------------------------------------
# euclidean
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "complete") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "ward.D") #priporoča 5
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "ward.D2") #priporoča 3
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "single") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "average") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "euclidean",
        min.nc = 2, max.nc = 15, method = "kmeans") #priporoča 5
#-----------------------------------------------------------------
#manhattan
#----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "complete") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "ward.D") #priporoča 5
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "ward.D2") #priporoča 4
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "single") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "average") #priporoča 2
#-----------------------------------------------------------------
NbClust(data = data_ind, distance = "manhattan",
        min.nc = 2, max.nc = 15, method = "kmeans") #priporoča 5

#-----------------------------------------------------------------
#poskusimo 2, 3, 4, 5 skupin
#-----------------------------------------------------------------
p2ind <- cutree(model_ind, k=2)
p3ind <- cutree(model_ind, k=3)
p4ind <- cutree(model_ind, k=4)
p5ind <- cutree(model_ind, k=5)

#----------------------------------------------------------------
#1) graf če delimo na dve skupini - izloči MINAGAWA Kaho (rip njen trak :|)
#--------------------------------------------------------------
grupiranje_ind2 <- wcg %>%
  ggplot(aes(x=DA, y=DB, col=p2ind)) +
  geom_point() +
  geom_text(
    aes(label=drzava),
    size=2,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )#+
#theme_minimal()

#print(grupiranje_ind2)

#################################################################
#----------------------------------------------------------------
#2) graf če delimo na tri skupine
#--------------------------------------------------------------
grupiranje_ind3 <- wcg %>%
  ggplot(aes(x=DA, y=DB, col=p3ind, shape = tekma)) +
  geom_point() +
  geom_text_repel( #da se napisi ne prekrivajo
    aes(label=drzava),
    size=2,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )+
theme_minimal()

print(grupiranje_ind3)

#KOMENTAR:
#1. SKUPINA: minagawa z kiksano vajo
#2. SKUPINA:
#3. SKUPINA:

#----------------------------------------------------------------
#3) graf če delimo na štiri skupine
#--------------------------------------------------------------
grupiranje_ind4 <- wcg %>%
  ggplot(aes(x=DA, y=DB, col=p4ind, shape = tekma)) +
  geom_point() +
  geom_text(
    aes(label=drzava),
    size=2,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )#+
#theme_minimal()

print(grupiranje_ind4)

#################################################################
#----------------------------------------------------------------
#4) graf če delimo na pet skupin
#--------------------------------------------------------------
grupiranje_ind5 <- wcg %>%
  ggplot(aes(x=DA, y=DB, col=p5ind, shape = tekma)) +
  geom_point() +
  guides(color = FALSE)+ #legende za barvo ne potrebujem
  geom_text_repel(
    aes(label=drzava),
    size=2,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )+
  theme_minimal()+
  labs(title = "GRUPIRANJE DRŽAV PO VREDNOSTI
       DB IN DA INDUVIDUALNIH SESTAV")+
  theme(plot.title = element_text(hjust=0.5))

print(grupiranje_ind5)

#==========================================================================
#4. GRUPIRANJE PO REKVIZITIH - KATER JIM JE BOLJŠI
#==========================================================================
#View(induvidualne_finali)
#-------------------------------------------------------------------------
#PRIPRAVA PODATKOV
#-------------------------------------------------------------------------
#View(ecg)

#za vsak rekvizit bomo zapisali katero mesto je zasedla tekmovalka, potem bomo za vsako tekmovalko izbrali najvišjo uvrstitev
induvidualne_rekviziti <- ecg %>% #da ne pokvarimo podatkov
  group_by(rekvizit) %>% #morda ne bo potrebno
  mutate(mesto=as.numeric(c(1:25))) #%>% #ker imamo podatke že urejene

#view(induvidualne_rekviziti)

#-----------------------------
#mediane za posamezen rekvizit
#-----------------------------
#skupna mediana
#induvidualne_rekviziti %>%group_by(rekvizit) %>% median(.,induvidualne_rekviziti$koncna_ocena) #21.5

#mediana po rekvizitih
medians <- induvidualne_rekviziti %>%
  group_by(rekvizit) %>%
  summarize(median = median(koncna_ocena, na.rm = T)) #na.rm - odstrani na vrednosti
#summarize izračuna eno vrednost za vsak rekvizit: ball 21.65, clubs	21.75, hoop 21.00, ribbon	19.30
#View(medians) #tabela z dvema stolpcamain 4 vrsticam: rekvizit median

#------
#graf
#------
ggplot(induvidualne_rekviziti, aes(tekmovalka, koncna_ocena) ) +
  facet_grid(.~rekvizit)+
  geom_point() +
  geom_hline(yintercept = 21.5, color = "blue") + #nastavljena na medijani
  labs( x = "tekmovalke", y = "končna ocena",
        title = "GRAF KONČNIH OCEN GLEDE NA REKVIZIT" )+
  geom_text(
    aes(label=tekmovalka),
    size=2,
    color='black',
    nudge_x = 0.05,
    nudge_y = 0.05
  )

#KOMENTAR: zdi se da bi pri vsakem rekvizitu lahko tekmovalke razdelili na tri skupine
# 1.sk: nad mediano za posamezen rekvizit, 2.sk: pod mediano, 3.sk: jovana markovic, bih hana

#---------------------------------------------------------------------------------
#METODA VODITELJEV
#---------------------------------------------------------------------------------

# Izbrati moramo število voditeljev
# k = 3

data_rekviziti <- ecg %>%
  select(koncna_ocena) %>%
  as.matrix() %>%
  scale()

#----------------------------------------------------------------------------------
modelK_rekviziti <- kmeans(data_rekviziti, 3) #{stats}

# Razporeditev v skupine
modelK_rekviziti$cluster
#[1] 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3
#[42] 3 1 1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 2 2 3 3 3 3 3 3 3
#[83] 3 3 3 3 3 1 1 1 1 1 1 1 1 1 1 1 2 2

# Končni centri
#modelK_rekviziti$centers

# Vsota kvadratov vseh razdalj
#modelK_rekviziti$totss #99

# Vsote kvadratov razdaj do centrov za posamezne skupine
#modelK_rekviziti$withinss #5.975027 2.111021 7.690559

# sum(modelK$withinss)
#modelK_rekviziti$tot.withinss

# totss - tot.withinss
#modelK_rekvizit$betweenss

# Število točk v vsaki skupini
#modelK_rekviziti$size #34  6 60

# Število iteracij algoritma
#modelK_rekviziti$iter
#-----------------------------------------------------------------------------------

###############################################################
#--------------------------------------------------------------
# KONČNI GRAF SKUPIN PO REKVIZITIH
#--------------------------------------------------------------
#require('ggrepel') #za overlapping

ecg$tekmovalka <- recode(ecg$tekmovalka
                                #KAJ JE = V KAJ ŽELIMO SPREMENITI
                               ,"ASHRAM Linoy" =  "ASHRAM"
                               ,"ZELIKMAN Nicol" = "ZELIKMAN"
                               ,"KALEYN Boryana" = "KALEYN"
                               ,"SALOS Anastasiia" = "SALOS"
                               ,"NIKOLCHENKO Vlada" = "NIKOLCHENKO"
                               ,"HARNASKO Alina" = "HARNASKO"
                               ,"TASEVA Katrin" = "TASEVA"
                               ,"JALILOVA Arzu" = "JALILOVA"
                               ,"VERDES Andreea" = "VERDES"
                               ,"MELESHCHUK Yeva" = "MELESHCHUK"
                               ,"STOJANOV Rejchl" = "STOJANOV"
                               ,"POLSTJANAJA Jelizaveta" = "POLSTJANAJA"
                               ,"AGHAMIROVA Zohra" = "AGHAMIROVA"
                               ,"PIGNICZKI Fanni" = "PIGNICZKI"
                               ,"VEDENEEVA Ekaterina" = "VEDENEEVA"
                               ,"BOGDANOVA Viktoria" = "BOGDANOVA"
                               ,"ICHIM Sonia" = "ICHIM"
                               ,"GUZ Anastasia" = "GUZ"
                               ,"STEPANKOVA Denisa" = "STEPANKOVA"
                               ,"SOSTAKAITE Fausta" = "SOSTAKAITE"
                               ,"TUNCEL Kamelya" = "TUNCEL"
                               ,"SMIRNOVA Elena" = "SMIRNOVA"
                               ,"SAMBOL Lana" = "SAMBOL"
                               ,"MARKOVIC Jovana" = "MARKOVIC"
                               ,"KAHRIMAN Hana" = "KAHRIMAN")

grupiranje_rekviziti <- ecg %>%
  mutate(skupina=modelK_rekviziti$cluster) %>%
  ggplot(aes(x=tekmovalka, y=koncna_ocena, col=skupina)) +
  facet_grid(.~rekvizit)+
  geom_point()+
 labs( y = "končna ocena",
      title = "SKUPINE INDIVIDUALNIH TEKMOVALK ZA VSAK REKVIZIT")+
  geom_text_repel(  #dodamo imena tekmovalk, ki se ne prekrivajo
    aes(label=tekmovalka),
    size=1.5,
    color='black',
    min.segment.length = 0, #črtica do vsake pikice
    #box.padding = 0.05,
    #nudge_x = 0.05,
    #nudge_y = 0.5
  )+
  scale_y_continuous(breaks=c(2.5, 5, 7.5, 10, 12.5, 15, 17.5, 20, 22.5, 25))+
  theme_bw()+ #brez sivega ozadja
  theme(legend.position = "none" #brez legende
        ,axis.ticks.x = element_blank() #brez črtic na x osi
        ,axis.text.x = element_blank() #brez value na x osi
        ,axis.title.x = element_blank()
        ,axis.text.y = element_text(size = 6)
        ,panel.grid.major = element_blank() #navpične črte
        ,panel.grid.minor = element_blank() #vodoravne črte
        #,strip.background = element_blank() #ozadje pri ball clubs...
        #,panel.border = element_blank()
        ,plot.title = element_text(hjust=0.5)#naslovna sredini

  )

print(grupiranje_rekviziti)

#KOMENTAR: skupine po rekvizitih
#ŽOGA:
#     1.SK: Harnasko, Kaleyn, Ashram, Salos,
#     2.SK:
#     3.SK:
#KIJI:
#OBROČ:
#TRAK:

#==========================================================================================
#5. KAKŠNE BODO OCENE NA OI
#==========================================================================================
#gledamo dvig ocen skozi čas
#---------------------------
#izbrane tekmovalke-na vseh treh tekmah
izbrane <- c("ASHRAM Linoy" ,"ZELIKMAN Nicol","NIKOLCHENKO Vlada","KALEYN Boryana"
             ,"SALOS Anastasiia")
induvidualne_predikcija <- induvidualne_finali %>%
  mutate(tekma = recode(induvidualne_finali$tekma
                                   ,"2018 Sofia" = "2018" #KAJ JE = V KAJ ŽELIMO SPREMENITI
                                   ,"2019 Baku" = "2019"
                                   ,"2020 Kijev" = "2020")) %>%
  subset(tekmovalka %in% izbrane)

#View(induvidualne_predikcija)

#----------------------------------------------------------------
#graf
#----------------------------------------------------------------
ggplot(induvidualne_predikcija, aes(x = D, y = E, col = tekma)) +
  geom_point()

#---------------------------------------------------------------
# MODEL
#--------------------------------------------------------------
model_ind <- lm(E ~ D, data=induvidualne_predikcija)

# Koeficienti premic
#model_ind$coefficients #(Intercept)6.7351068           D 0.1283348

# Residuali (razlike do premice)
#model_ind$residuals

# Dodatne statistike modela
#s <- summary(model_ind) #iz residualov in koeficientov poračuna vrednosti

# Npr. R^2 https://en.wikipedia.org/wiki/Coefficient_of_determination
#s$r.squared

# Pregled nekaterih statistik modela
#require(ggfortify)
#autoplot(model)

#------------------------------------------------------------------
# IZRIS LINEARNEGA MODELA
#------------------------------------------------------------------
ggplot(induvidualne_predikcija, aes(x = D, y = E)) +
  geom_point() +
  facet_grid(.~rekvizit)+
  geom_smooth(method=lm, formula=y~x)

#-----------------------------------------------------------------
# PREDIKCIJA. Kakšna bo E ko bodo D dvignile na 17, 17.5
#-----------------------------------------------------------------
novD <- data.frame(D=c(17.5, 18))
predict(model_ind, novD) #8.980967 9.045134
napovedE <- novD %>% mutate(E=predict(model_ind, .))

napovedE_tabela <- napovedE %>%
  mutate(tekmovalka="napoved", drzava = "napoved", tekma = 2021, rekvizit = "napoved", Pen.= 0.00, koncna_ocena = c(8.980967+17.5, 9.045134+18) )

#napovedE %>% View
#napovedE_tabela %>% view

induvidualne_predikcija_napoved <- rbind(napovedE_tabela, induvidualne_predikcija)

#----------------
# izris napovedi
#----------------
predikcija_graf_ind <- ggplot(induvidualne_predikcija_napoved, aes(x = D, y = E)) +
  geom_point(shape=1) +
  geom_smooth(method=lm, formula=y~x) +
  geom_point(data=napovedE, aes(x=D, y=E), color='red', size=3)+
  labs( title = "PREDIKCIJA POVPREČNE OCENE E ZA INDIVIDUALNE SESTAVE
        NA OLIMPIJSKIH IGRAH 2021" )+
  theme_bw()+ #brez sivega ozadja
  theme(legend.position = "none" #brez legende
        ,plot.title = element_text(hjust=0.5)#naslovna na sredini

  )

print(predikcija_graf_ind)


# from: http://www.psych.ualberta.ca/~phurd/cruft/g.test.r
#
# Log-likelihood tests of independence & goodness of fit
# Does Williams' and Yates' correction
# does Monte Carlo simulation of p-values, via gtestsim.c
#
# G & q calculation from Sokal & Rohlf (1995) Biometry 3rd ed.
# TOI Yates' correction taken from Mike Camann's 2x2 G-test fn.
# GOF Yates' correction as described in Zar (2000)
# more stuff taken from ctest's chisq.test()
#
# ToDo:
# 1) Beautify
# 2) Add warnings for violations
# 3) Make appropriate corrections happen by default
#
# V3.3 Pete Hurd Sept 29 2001. phurd@ualberta.ca

g.test <- function(x, y = NULL, correct="none",
  p = rep(1/length(x), length(x)), simulate.p.value = FALSE, B = 2000)
{
  DNAME <- deparse(substitute(x))
  if (is.data.frame(x)) x <- as.matrix(x)
  if (is.matrix(x)) {
    if (min(dim(x)) == 1)
      x <- as.vector(x)
  }
  if (!is.matrix(x) && !is.null(y)) {
    if (length(x) != length(y))
      stop("x and y must have the same length")
    DNAME <- paste(DNAME, "and", deparse(substitute(y)))
    OK <- complete.cases(x, y)
    x <- as.factor(x[OK])
    y <- as.factor(y[OK])
    if ((nlevels(x) < 2) || (nlevels(y) < 2))
      stop("x and y must have at least 2 levels")
    x <- table(x, y)
  }
  if (any(x < 0) || any(is.na(x)))
    stop("all entries of x must be nonnegative and finite")
  if ((n <- sum(x)) == 0)
    stop("at least one entry of x must be positive")
  #If x is matrix, do test of independence
  if (is.matrix(x)) {
    #Test of Independence
    nrows<-nrow(x)
    ncols<-ncol(x)
    if (correct=="yates"){ # Do Yates' correction?
      if(dim(x)[1]!=2 || dim(x)[2]!=2) # check for 2x2 matrix
        stop("Yates' correction requires a 2 x 2 matrix")
      if((x[1,1]*x[2,2])-(x[1,2]*x[2,1]) > 0)
        {
          x[1,1] <- x[1,1] - 0.5
          x[2,2] <- x[2,2] - 0.5
          x[1,2] <- x[1,2] + 0.5
          x[2,1] <- x[2,1] + 0.5
        }
      else
        {
          x[1,1] <- x[1,1] + 0.5
          x[2,2] <- x[2,2] + 0.5
          x[1,2] <- x[1,2] - 0.5
          x[2,1] <- x[2,1] - 0.5
        }
    }

    sr <- apply(x,1,sum)
    sc <- apply(x,2,sum)
    E <- outer(sr,sc, "*")/n
    # are we doing a monte-carlo?
    # no monte carlo GOF?
    if (simulate.p.value){
      METHOD <- paste("Log likelihood ratio (G-test) test of independence\n\t with simulated p-value based on", B, "replicates")
      tmp <- .C("gtestsim", as.integer(nrows), as.integer(ncols),
                as.integer(sr), as.integer(sc), as.integer(n), as.integer(B),
                as.double(E), integer(nrows * ncols), double(n+1),
                integer(ncols), results=double(B), PACKAGE= "ctest")
      g <- 0
      for (i in 1:nrows){
        for (j in 1:ncols){
          if (x[i,j] != 0) g <- g + x[i,j] * log(x[i,j]/E[i,j])
        }
      }
      STATISTIC <- G <- 2 * g
      PARAMETER <- NA
      PVAL <- sum(tmp$results >= STATISTIC)/B
    }
    else {
      # no monte-carlo
      # calculate G
      g <- 0
      for (i in 1:nrows){
        for (j in 1:ncols){
          if (x[i,j] != 0) g <- g + x[i,j] * log(x[i,j]/E[i,j])
        }
      }
      q <- 1
      if (correct=="williams"){ # Do Williams' correction
        row.tot <- col.tot <- 0
        for (i in 1:nrows){ row.tot <- row.tot + 1/(sum(x[i,])) }
        for (j in 1:ncols){ col.tot <- col.tot + 1/(sum(x[,j])) }
        q <- 1+ ((n*row.tot-1)*(n*col.tot-1))/(6*n*(ncols-1)*(nrows-1))
      }
      STATISTIC <- G <- 2 * g / q
      PARAMETER <- (nrow(x)-1)*(ncol(x)-1)
      PVAL <- 1-pchisq(STATISTIC,df=PARAMETER)
      if(correct=="none")
        METHOD <- "Log likelihood ratio (G-test) test of independence without correction"
      if(correct=="williams")
        METHOD <- "Log likelihood ratio (G-test) test of independence with Williams' correction"
      if(correct=="yates")
        METHOD <- "Log likelihood ratio (G-test) test of independence with Yates' correction"
    }
  }
  else {
    # x is not a matrix, so we do Goodness of Fit
    METHOD <- "Log likelihood ratio (G-test) goodness of fit test"
    if (length(x) == 1)
      stop("x must at least have 2 elements")
    if (length(x) != length(p))
      stop("x and p must have the same number of elements")
    E <- n * p

    if (correct=="yates"){ # Do Yates' correction
      if(length(x)!=2)
        stop("Yates' correction requires 2 data values")
      if ( (x[1]-E[1]) > 0.25) {
        x[1] <- x[1]-0.5
        x[2] <- x[2]+0.5
      }
      else if ( (E[1]-x[1]) > 0.25){
        x[1] <- x[1]+0.5
        x[2] <- x[2]-0.5
      }
    }
    names(E) <- names(x)
    g <- 0
    for (i in 1:length(x)){
      if (x[i] != 0) g <- g + x[i] * log(x[i]/E[i])
    }
    q <- 1
    if (correct=="williams"){ # Do Williams' correction
      q <- 1+(length(x)+1)/(6*n)
    }
    STATISTIC <- G <- 2*g/q
    PARAMETER <- length(x) - 1
    PVAL <- pchisq(STATISTIC, PARAMETER, lower = FALSE)
  }
  names(STATISTIC) <- "Log likelihood ratio statistic (G)"
  names(PARAMETER) <- "X-squared df"
  names(PVAL) <- "p.value"
  structure(list(statistic=STATISTIC,parameter=PARAMETER,p.value=PVAL,
            method=METHOD,data.name=DNAME, observed=x, expected=E),
            class="htest")
}