#' Marginal function for use in fit.vine.copula: empirical distribution function
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param reflect_bounds If true, reflect samples across bounds to improve the estimate near the boundaries.
#' @export
fit.marginal.ecdf <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), reflect_bounds = T) {
    marginal <- list()
    marginal$type <- "ecdf"

    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal$ecdfs <- apply(x, 2, ecdf)
    marginal$varnames <- colnames(x)
    marginal$x <- x
    marginal$x_reflected <- list()
    marginal$correction_factor <- rep(1, ncol(x))
    for (i in 1:ncol(x)) {
        marginal$x_reflected[[i]] <- x[, i]
        if (reflect_bounds) {
            if (bounds[i, 1] != -Inf) {
                reflected <- bounds[i, 1] - (x[, i] - bounds[i, 1])
                marginal$x_reflected[[i]] <- c(marginal$x_reflected[[i]], reflected)
                marginal$correction_factor[i] <- marginal$correction_factor[i] + 1
            }
            if (bounds[i, 2] != Inf) {
                reflected <- bounds[i, 2] + (bounds[i, 2] - x[, i])
                marginal$x_reflected[[i]] <- c(marginal$x_reflected[[i]], reflected)
                marginal$correction_factor[i] <- marginal$correction_factor[i] + 1
            }
        }
    }

    marginal$bw <- rep(NA, ncol(x))
    for (i in 1:ncol(x)) {
        hmax <- 10 * sd(marginal$x_reflected[[i]])
        marginal$bw[i] <- bw.SJ(marginal$x_reflected[[i]], lower = 1e-6 * hmax, upper = hmax)
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Marginal function for use in fit.vine.copula: single parametric distribution
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
fit.marginal.parametric <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x)))) {
    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal <- list()
    marginal$type <- "parametric"
    marginal$dists <- list()
    fitctrl <- list(maxit = 1000)
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] >= bounds[i, 2]) {
            stop("Upper bound must be strictly higher than lower bound")
        }

        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> beta
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- 0
            marginal$dists[[i]]$max <- 1
            dfit <- MASS::fitdistr(x[, i], dbeta, list(shape1 = 1, shape2 = 1), control = fitctrl)
            marginal$dists[[i]]$shape1 <- as.numeric(dfit$estimate["shape1"])
            marginal$dists[[i]]$shape2 <- as.numeric(dfit$estimate["shape2"])
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> gamma
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "gamma"
            rescale <- 1 / mean(x[, i])
            dfit <- MASS::fitdistr(x[, i], dgamma, list(shape = 2, scale = 1), control = fitctrl)
            dfit <- MASS::fitdistr(x[, i] * rescale, dgamma, list(shape = 2, scale = 1), control = fitctrl)
            marginal$dists[[i]]$shape <- as.numeric(dfit$estimate["shape"])
            marginal$dists[[i]]$scale <- as.numeric(dfit$estimate["scale"]) / rescale
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> normal
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "normal"
            marginal$dists[[i]]$mu <- mean(x[, i])
            marginal$dists[[i]]$sigma <- sd(x[, i])
        } else {
            # [a,b] -> scaled beta
            a <- bounds[i, 1];
            b <- bounds[i, 2];
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- a
            marginal$dists[[i]]$max <- b
            dfit <- MASS::fitdistr((x[, i] - a) / (b - a), dbeta, list(shape1 = 1, shape2 = 1), control = fitctrl)
            marginal$dists[[i]]$shape1 <- as.numeric(dfit$estimate["shape1"])
            marginal$dists[[i]]$shape2 <- as.numeric(dfit$estimate["shape2"])
        }

        marginal$dists[[i]]$name <- colnames(x)[i]
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Marginal function for use in fit.vine.copula: mixture of parametric distributions
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
fit.marginal.mixture <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x)))) {
    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal <- list()
    marginal$type <- "mixture"
    marginal$dists <- list()
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] >= bounds[i, 2]) {
            stop("Upper bound must be strictly higher than lower bound")
        }

        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> beta
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- 0
            marginal$dists[[i]]$max <- 1

            d <- data.frame(y = x[, i])
            cf <- coef(lm(qlogis(y) ~ 1, data = d))
            m <- betareg::betamix(y ~ 1 | 1, data = d, k = 1:3, control = betareg::betareg.control(start = list(mean = 0, precision = 1)), FLXcontrol = list(tolerance = 0.01), which = "AIC")
            k <- m$flexmix@k
            if (k == 1) {
                mu <- plogis(coef(m)[1])
                phi <- exp(coef(m)[2])
                marginal$dists[[i]]$p <- 1
            } else {
                mu <- plogis(coef(m)[, 1])
                phi <- exp(coef(m)[, 2])
                marginal$dists[[i]]$p <- m$flexmix@prior
            }
            marginal$dists[[i]]$a <- mu * phi
            marginal$dists[[i]]$b <- (1 - mu) * phi
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> gamma
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "gamma"

            rescale <- 1 / mean(x[, i])
            rescaled <- x[, i] * rescale
            ms <- list()
            AIC <- rep(NA, 3)
            for (k in 1:3) {
                ms[[k]] <- mixtools::gammamixEM(rescaled, k = k, epsilon = 0.01)
                AIC[k] <- 2 * k - 2 * ms[[k]]$loglik
            }
            k <- which.min(AIC)
            m <- ms[[k]]

            marginal$dists[[i]]$p <- m$lambda
            marginal$dists[[i]]$shape <- m$gamma.pars[1,]
            marginal$dists[[i]]$scale <- m$gamma.pars[2,] / rescale
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> normal
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "normal"

            ms <- list()
            AIC <- rep(NA, 3)
            ms[[1]] <- list()
            ms[[1]]$lambda <- 1
            ms[[1]]$mu <- mean(x[, i])
            ms[[1]]$sigma <- sd(x[, i])
            AIC[1] <- log(nrow(x)) * 2 - 2 * sum(dnorm(x[, i], ms[[1]]$mu, ms[[1]]$sigma, log = T))
            for (k in 2:3) {
                capture.output(return_value <- try(ms[[k]] <- mixtools::normalmixEM(x[, i], k = k, epsilon = 0.01, arbmean = T, arbvar = T)))
                if (inherits(return_value, "try-error")) {
                    AIC[k] <- NA
                } else {
                    AIC[k] <- 2 * k - 2 * ms[[k]]$loglik
                }
            }
            k <- which.min(AIC)
            m <- ms[[k]]

            marginal$dists[[i]]$p <- m$lambda
            marginal$dists[[i]]$mu <- m$mu
            marginal$dists[[i]]$sigma <- m$sigma
        } else {
            # [a,b] -> scaled beta
            a <- bounds[i, 1];
            b <- bounds[i, 2];
            marginal$dists[[i]] <- list()
            marginal$dists[[i]]$type <- "beta"
            marginal$dists[[i]]$min <- a
            marginal$dists[[i]]$max <- b

            d <- data.frame(y = (x[, i] - a) / (b - a))
            m <- betareg::betamix(y ~ 1, data = d, k = 1:3, FLXcontrol = list(tolerance = 0.01), which = "AIC")

            k <- m$flexmix@k
            if (k == 1) {
              mu <- plogis(coef(m)[1])
              phi <- exp(coef(m)[2])
                marginal$dists[[i]]$p <- 1
            } else {
                mu <- plogis(coef(m)[, 1])
                phi <- exp(coef(m)[, 2])
                marginal$dists[[i]]$p <- m$flexmix@prior
            }
            marginal$dists[[i]]$a <- mu * phi
            marginal$dists[[i]]$b <- (1 - mu) * phi
        }

        marginal$dists[[i]]$name <- colnames(x)[i]
    }

    return(structure(marginal, class = "mvd.marginal"))
}

.fit.pareto.tail <- function(x, u, fixed_beta = NA) {
    exceedances <- x[x > u]
    excess <- exceedances - u
    Nu <- length(excess)
    xbar <- mean(excess)

    result <- list()
    if (is.na(fixed_beta)) {
        s2 <- var(excess)
        xi0 <- -0.5 * (((xbar * xbar) / s2) - 1)
        beta0 <- 0.5 * xbar * (((xbar * xbar) / s2) + 1)
        theta <- c(xi0, beta0)

        negloglik1 <- function(theta, tmp) {
            xi <- theta[1]
            beta <- theta[2]
            cond1 <- beta <= 0
            cond2 <- (xi <= 0) && (max(tmp) > (-beta / xi))
            if (cond1 || cond2) {
                f <- 1e+06
            } else {
                y <- logb(1 + (xi * tmp) / beta)
                y <- y / xi
                f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
            }
            f
        }

        fit <- optim(theta, negloglik1, lower = c(0, 0), upper = c(Inf, Inf), tmp = excess, method = "L-BFGS-B")
        result$xi <- fit$par[1]
        result$beta <- fit$par[2]
    } else {
        s2 <- var(excess)
        xi0 <- -0.5 * (((xbar * xbar) / s2) - 1)

        negloglik2 <- function(xi, tmp, beta) {
            cond1 <- beta <= 0
            cond2 <- (xi <= 0) && (max(tmp) > (-beta / xi))
            if (cond1 || cond2) {
                f <- 1e+06
            } else {
                y <- logb(1 + (xi * tmp) / beta)
                y <- y / xi
                f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
            }
            f
        }

        fit <- optimize(negloglik2, lower = 0, upper = 1000, tmp = excess, beta = fixed_beta)
        result$xi <- fit$minimum
        result$beta <- fixed_beta
    }

    return(result)
}

.pareto.cdf <- function(x, u, xi, beta) {
    z <- (x - u) / beta
    return(1 - (1 + xi * z) ^ (-1/xi))
}

.pareto.pdf <- function(x, u, xi, beta, log = T) {
    z <- (x - u) / beta
    if (log) {
        p <- log(1 / beta) - (1 / xi + 1) * log(1 + xi * z)
    } else {
        p <- (1 / beta) * (1 + xi * z) ^ (-1 / xi - 1)
    }
    return(p)
}

# Marginal function for use in fit.vine.copula: empirical distribution function with pareto tails
.pareto.quantile <- function(x, u, xi, beta) {
    return(u + beta * ((1.0 - x) ^ (-xi) - 1.0) / xi);
}

#' Marginal function for use in fit.vine.copula: ecdf + pareto tail
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param reflect_bounds If true, reflect samples across bounds to improve the estimate near the boundaries.
#' @param pareto_threshold Cumulative probability threshold for the start of the pareto tail
#' @param ecdf_bounds_threshold Use a pareto tail only if the density of the kernel density estimate at the boundary is below this value.
#' @export
fit.marginal.ecdf.pareto <- function(x, bounds = cbind(rep(-Inf, ncol(x)), rep(Inf, ncol(x))), reflect_bounds = T, pareto_threshold = 0.1, ecdf_bounds_threshold = 1e-3) {
    marginal <- list()
    marginal$type <- "ecdf.pareto"

    if (!is.matrix(x)) {
        x <- as.matrix(x)
    }

    marginal$ecdf <- fit.marginal.ecdf(x, bounds, reflect_bounds)

    use.pareto.tail <- matrix(T, ncol(x), 2)
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] != -Inf) {
            dp <- sum(dnorm(bounds[i, 1], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])
            use.pareto.tail[i, 1] <- dp < ecdf_bounds_threshold
        }
        if (bounds[i, 2] != Inf) {
            dp <- sum(dnorm(bounds[i, 2], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])
            use.pareto.tail[i, 2] <- dp < ecdf_bounds_threshold
        }
    }

    for (i in 1:ncol(x)) {
        if (use.pareto.tail[i, 1]) {
            u <- as.numeric(quantile(x[, i], pareto_threshold))

            dp <- sum(dnorm(u, marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])

            marginal$lower.tails[[i]] <- .fit.pareto.tail(-x[, i], - u, pareto_threshold / dp)
            marginal$lower.tails[[i]]$u <- u
            marginal$lower.tails[[i]]$q <- pareto_threshold
            marginal$lower.tails[[i]]$d <- dp
        } else {
            marginal$lower.tails[[i]] <- list()
        }
        if (use.pareto.tail[i, 2]) {
            u <- as.numeric(quantile(x[, i], 1 - pareto_threshold))

            dp <- sum(dnorm(u, marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
            dp <- dp / length(marginal$ecdf$x_reflected[[i]])

            marginal$upper.tails[[i]] <- .fit.pareto.tail(x[, i], u, pareto_threshold / dp)
            marginal$upper.tails[[i]]$u <- u
            marginal$upper.tails[[i]]$q <- pareto_threshold
            marginal$upper.tails[[i]]$d <- dp
        } else {
            marginal$upper.tails[[i]] <- list()
        }
    }

    return(structure(marginal, class = "mvd.marginal"))
}

#' Transform variables to U[0,1] using a fitted marginal function
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @export
mvd.marginal.transform <- function(x, marginal) {
    stopifnot(class(marginal) == "mvd.marginal")

    if (!is.matrix(x)) {
        x <- t(as.matrix(x))
    }
    transformed <- matrix(nrow = nrow(x), ncol = ncol(x))

    if (marginal$type == "ecdf") {
        for (i in 1:ncol(x)) {
            transformed[, i] <- marginal$ecdfs[[i]](x[, i])
        }
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(x)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                is_tail <- x[, i] < marginal$lower.tails[[i]]$u
                transformed[is_tail, i] <- marginal$lower.tails[[i]]$q - marginal$lower.tails[[i]]$q * .pareto.cdf(-x[is_tail, i], - marginal$lower.tails[[i]]$u, marginal$lower.tails[[i]]$xi, marginal$lower.tails[[i]]$beta)
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                is_tail <- x[, i] > marginal$upper.tails[[i]]$u
                transformed[is_tail, i] <- (1 - marginal$upper.tails[[i]]$q) + marginal$upper.tails[[i]]$q * .pareto.cdf(x[is_tail, i], marginal$upper.tails[[i]]$u, marginal$upper.tails[[i]]$xi, marginal$upper.tails[[i]]$beta)
                is_body[is_tail] <- F
            }
            transformed[is_body, i] <- marginal$ecdf$ecdfs[[i]](x[is_body, i])
        }
    } else if (marginal$type == "parametric") {
        for (i in 1:ncol(x)) {
            if (marginal$dists[[i]]$type == "beta") {
                transformed[, i] <- pbeta((x[, i] - marginal$dists[[i]]$min) / (marginal$dists[[i]]$max - marginal$dists[[i]]$min), marginal$dists[[i]]$shape1, marginal$dists[[i]]$shape2)
            } else if (marginal$dists[[i]]$type == "normal") {
                transformed[, i] <- pnorm(x[, i], marginal$dists[[i]]$mu, marginal$dists[[i]]$sigma)
            } else if (marginal$dists[[i]]$type == "gamma") {
                transformed[, i] <- pgamma(x[, i], shape = marginal$dists[[i]]$shape, scale = marginal$dists[[i]]$scale)
            }
        }
    } else if (marginal$type == "mixture") {
        transformed <- matrix(0, nrow(x), ncol(x))
        for (i in 1:ncol(x)) {
            margin <- marginal$dists[[i]]
            if (margin$type == "beta") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pbeta((x[, i] - margin$min) / (margin$max - margin$min), margin$a[j], margin$b[j])
                }
            } else if (marginal$dists[[i]]$type == "normal") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pnorm(x[, i], margin$mu[j], margin$sigma[j])
                }
            } else if (marginal$dists[[i]]$type == "gamma") {
                for (j in 1:length(margin$p)) {
                    transformed[, i] <- transformed[, i] + margin$p[j] * pgamma(x[, i], shape = margin$shape[j], scale = margin$scale[j])
                }
            }
        }
    } else {
        stop("Unknown marginal type")
    }

    return(transformed)
}

#' Reverse transform variables from U[0,1]
#' @param transformed Matrix or vector of transformed samples. For matrices, rows are samples and columns are variables.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @export
reverse.transform.marginals <- function(transformed, marginal) {
    stopifnot(class(marginal) == "mvd.marginal")

    if (!is.matrix(transformed)) {
        transformed <- as.matrix(transformed)
    }
    x <- matrix(nrow = nrow(transformed), ncol = ncol(transformed))

    if (marginal$type == "ecdf") {
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(transformed)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                tail <- marginal$lower.tails[[i]]
                is_tail <- transformed[, i] < tail$q
                x[is_tail, i] <-  -.pareto.quantile(1.0 - (transformed[is_tail, i] / tail$q), - tail$u, tail$xi, tail$beta);
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                tail <- marginal$upper.tails[[i]]
                is_tail <- transformed[, i] > 1.0 - tail$q
                x[is_tail, i] <- .pareto.quantile((transformed[is_tail, i] - (1.0 - tail$q)) / tail$q, tail$u, tail$xi, tail$beta);
                is_body[is_tail] <- F
            }
            x[is_body, i] <- quantile(marginal$ecdf$ecdfs[[i]], transformed[is_body, i], type = 4)
        }
    } else if (marginal$type == "parametric") {
    } else if (marginal$type == "mixture") {
        for (i in 1:ncol(transformed)) {
            margin <- marginal$dists[[i]]
            ix <- sample(length(margin$p), nrow(x), replace = T, prob = margin$p)
            if (margin$type == "beta") {
                x[, i] <- margin$min + qbeta(transformed[, i], margin$a[ix], margin$b[ix]) * (margin$max - margin$min)
            } else if (margin$type == "normal") {
                x[, i] <- qnorm(transformed[, i], margin$mu[ix], margin$sigma[ix])
            } else if (margin$type == "gamma") {
                x[, i] <- qgamma(transformed[, i], shape = margin$shape[ix], scale = margin$scale[ix])
            }
        }
    } else {
        stop("Unknown marginal type")
    }

    return(x)
}

#' Probability density function of a marginal distribution fitted with one of the marginal distribution functions.
#' @param marginal mvd.marginal object obtained from one of the marginal fitting functions.
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param log Whether to return the density in log
#' @export
mvd.marginal.pdf <- function(marginal, x, log = T) {
    stopifnot(class(marginal) == "mvd.marginal")
    stopifnot(log)

    p <- matrix(NA, nrow(x), ncol(x))

    if (marginal$type == "ecdf") {
        stopifnot(ncol(x) == length(marginal$bw))
        for (i in 1:ncol(x)) {
            for (j in 1:nrow(x)) {
                dp <- sum(dnorm(x[j, i], marginal$x_reflected[[i]], marginal$bw[i])) * marginal$correction_factor[i]
                p[j, i] <- log(dp) - log(length(marginal$x_reflected[[i]]))
            }
        }
    } else if (marginal$type == "ecdf.pareto") {
        for (i in 1:ncol(x)) {
            is_body <- rep(T, nrow(x))
            if (length(marginal$lower.tails[[i]]) > 0) {
                is_tail <- x[, i] < marginal$lower.tails[[i]]$u
                p[is_tail, i] <- log(marginal$lower.tails[[i]]$q) + .pareto.pdf(-x[is_tail, i], - marginal$lower.tails[[i]]$u, marginal$lower.tails[[i]]$xi, marginal$lower.tails[[i]]$beta, log = T)
                is_body[is_tail] <- F
            }
            if (length(marginal$upper.tails[[i]]) > 0) {
                is_tail <- x[, i] > marginal$upper.tails[[i]]$u
                p[is_tail, i] <- log(marginal$upper.tails[[i]]$q) + .pareto.pdf(x[is_tail, i], marginal$upper.tails[[i]]$u, marginal$upper.tails[[i]]$xi, marginal$upper.tails[[i]]$beta, log = T)
                is_body[is_tail] <- F
            }
            for (j in which(is_body)) {
                dp <- sum(dnorm(x[j, i], marginal$ecdf$x_reflected[[i]], marginal$ecdf$bw[i])) * marginal$ecdf$correction_factor[i]
                p[j, i] <- log(dp) - log(length(marginal$ecdf$x_reflected[[i]]))
            }
        }
    } else if (marginal$type == "parametric") {
        for (i in 1:ncol(x)) {
            if (marginal$dists[[i]]$type == "beta") {
                a <- marginal$dists[[i]]$min
                b <- marginal$dists[[i]]$max
                p[, i] <- dbeta((x[, i] - a) / (b - a), marginal$dists[[i]]$shape1, marginal$dists[[i]]$shape2, log = T) - log(b - a)
            } else if (marginal$dists[[i]]$type == "normal") {
                p[, i] <- dnorm(x[, i], marginal$dists[[i]]$mu, marginal$dists[[i]]$sd, log = T)
            } else if (marginal$dists[[i]]$type == "gamma") {
                p[, i] <- dgamma(x[, i], shape = marginal$dists[[i]]$shape, scale = marginal$dists[[i]]$scale, log = T)
            }
        }
    } else if (marginal$type == "mixture") {
        for (i in 1:ncol(x)) {
            margin <- marginal$dists[[i]]
            dp <- rep(0, nrow(x))
            if (margin$type == "beta") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dbeta((x[, i] - margin$min) / (margin$max - margin$min), margin$a[j], margin$b[j])
                }
                p[, i] <- log(dp) - log(margin$max - margin$min)
            } else if (margin$type == "normal") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dnorm(x[, i], margin$mu[j], margin$sigma[j])
                }
                p[, i] <- log(dp)
            } else if (margin$type == "gamma") {
                for (j in 1:length(margin$p)) {
                    dp <- dp + margin$p[j] * dgamma(x[, i], shape = margin$shape[j], scale = margin$scale[j])
                }
                p[, i] <- log(dp)
            }
        }
    } else {
        stop("Unknown marginal type")
    }
    return(p)
}

.marginal.correct.p <- function(marginal, x, p, log = T) {
    stopifnot(class(marginal) == "mvd.marginal")
    mp <- mvd.marginal.pdf(marginal, x, log)
    for (i in 1:ncol(x)) {
        p <- p + mp[, i]
    }
    return(p)
}


## Created on Tuesday, February  8, 2022 at 11:11pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2022, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../../tools"
source(file.path(toolsDir, "pipeline-tools.r"))        # For saveDataframe()
source("./2021-11-12-covid-treatments-simple-efficacy-confidence-limits.r")
library("reshape2")                                    # For acast()

##
## Moderna's animal trial of an Omicron-specific COVID-19 vaccine showed "no better
## than original vaccine."
##
## - N = 8 monkeys = 4 control + 4 treatment
## - Original efficacy 80% or so.
##
## Could you, even in principle, tell the difference between 80% efficacy and 100%, with
## only 4 animals in each group?
##
## Summary of study:
##   https://arstechnica.com/science/2022/02/monkey-study-casts-doubt-on-need-for-an-omicron-specific-booster/
## Study itself, says nothing re efficacy but is all about B cells and T cells:
##   https://www.biorxiv.org/content/10.1101/2022.02.03.479037v1
##
## Summary of CDC stuff on efficacy of booster:
##   https://arstechnica.com/science/2022/01/unvaccinated-5x-more-likely-to-get-omicron-than-those-boosted-cdc-reports/
## The CDC MMWR's themselves, quoting booster efficacy vs Omicron:
##   https://www.cdc.gov/mmwr/volumes/71/wr/mm7104e2.htm?s_cid=mm7104e2_w
##   https://www.cdc.gov/mmwr/volumes/71/wr/mm7104e3.htm?s_cid=mm7104e3_w
##

## Efficacy against urgent care with Omicron: 82%
## Efficacy against hospitalization with Omicron: 94%
## Can we tell if ANYTHING in the monkey trial is statistically significantly different from that?
doit <- function(Ntrt = 4, Ncnt = 4, destPath = "./2022-02-09-moderna-monkey-trial.tsv") {
  saveDataframe(dcast(transform(expand.grid(Ktrt = 0 : Ntrt, Kcnt = 0 : Ncnt),
                                Eff = Vectorize(function(Ntrt, Ktrt, Ncnt, Kcnt) {
                                  effs <- 100.0 * efficacyAndCL(Ntrt, Ktrt, Ncnt, Kcnt)
                                  sprintf("%+6.1f%% (%+6.1f%% - %+6.1f%%)",
                                          effs[["Eff"]], effs[["LCL"]], effs[["UCL"]])
                                })(Ntrt, Ktrt, Ncnt, Kcnt)),
                      Kcnt ~ Ktrt, value.var = "Eff"), #
                destPath)                              #
}                                                      #


################################ exon9CNV (the exon9 amplicon); fixed sd for each run
#cm: cluster mean
#cs: cluster std
#pm: cluster membership probability matrix
#cw: cluster weight
CN3.add = 1
cprob <- function(point, m) {
    # dnorm: normal density function (x, mean, and sd)
    sapply(1:m$n, function(i){dnorm(point, m$cm[i], m$cs[i])})
}

estep <- function(m) {
    m$pm <- sapply(m$v, function(x){temp <- cprob(x, m) * m$cw; temp/sum(temp)})
    temp <- apply(m$pm, 1, sum)
    m$cw <- temp/sum(temp)   #cluster weight
    return(m)
}

mstep <- function(m) {
    temp <- m$pm * t(replicate(m$n, m$wt))
    pwt <- apply(temp, 1, sum)
    m$cm <- as.vector(temp %*% m$v / pwt)
    dis <- t(replicate(m$n, m$v)) - replicate(length(m$v), m$cm)
    m$cs <- rep(sqrt(sum(apply(temp *  dis * dis, 1, sum)) / sum(pwt)), m$n)  #cluster sd, 3 class
    return(m)
}

#log likelihood
ll <- function(m) {
    sum(sapply(m$v, function(x){log(sum(cprob(x, m) * m$cw))}))
}

exon9CNV <- function(nn_sub, exon9_idx) {
    do = as.numeric(nn_sub[exon9_idx,])
	THRES.CN4 = median(do)+0.8
	exon.CN4.idx = (do>THRES.CN4+0.2)
	do[do>THRES.CN4] = THRES.CN4

	amplicon.THRES.CN0 = median(do)-2
	do[do<amplicon.THRES.CN0] = amplicon.THRES.CN0

    cm2 <- median(do)
    cm = c(cm2-1, cm2, cm2+exon.CN3.add)
    cs <- c(0.1, 0.1, 0.1) #cluster sd, 3 class
    n <- length(cm) #number of clusters
    cw <- rep(1/n, n) #cluster weight
    pd <- c(cm) # one prior data point

    pw <- rep(1, length(pd)) #prior data point weights

    v <- c(pd, do) #all data points for clustering
    wt <- c(pw, rep(1, length(do))) #weights of all data points
    oll <- -.Machine$double.xmax #likelihood from the previous iteration
    np <- length(pd) #number of prior data points

    m <- list(v=v, n=n, wt=wt, cm=cm, cs=cs, pm=0, cw=cw)
    m <- estep(m)
    nll <- ll(m)
    i <- 1
    while(i < 60 && nll - oll > 0.00001) {
        oll <- nll
        m <- mstep(m)
        m <- estep(m)
        nll <- ll(m)
        i <- i+1
    #    cat("iter=",i,"loglikelihood=",nll,"\n")
    }

    # retrieve call / calculate Phred score
    temp <- sapply(do, function(v){cprob(v,m)})
    call <- apply(temp, 2, which.max)
    # apply(temp, 2, max), maximal density
    temp <- apply(temp, 2, function(v){v/sum(v)})
    # temp is now probability
    temp <- apply(temp, 2, function(v){1-max(v)})
    temp[temp < .Machine$double.xmin] <- .Machine$double.xmin
    Phred <- -10 * log10(temp)
    Phred[Phred>100] <- 100

    ExonOut <- list(call=call, Phred=Phred, m=m, do=do, np=np, exon.CN4.idx=exon.CN4.idx)
    return(ExonOut)
}

######################fit gene level; fixed sd for each amplicon in a run
estepGene <- function(m) {
  m$pm <- apply(m$v, 2, function(x){temp <- cprobGene(x, m) * m$cw; temp/sum(temp)})
  temp <- apply(m$pm, 1, sum)
  m$cw <- temp/sum(temp)   #cluster weight
  return(m)
}

mstepGene <- function(m) {
  temp <- m$pm * t(replicate(m$n, m$wt))
  pwt <- apply(temp, 1, sum)
  m$cm <- apply(temp %*% t(m$v), 2, function(v){v/pwt})
  for(i in 1:m$na) {
    dis <- t(replicate(m$n, m$v[i,])) - replicate(length(m$v[i,]), m$cm[,i])
    m$cs[,i] <- rep(sqrt(sum(apply(temp *  dis * dis, 1, sum)) / sum(pwt)), m$n)   #cluster sd;
  }
  return(m)
}

#log likelihood
llGene <- function(m) {
  sum(apply(m$v, 2, function(x){log(sum(cprobGene(x, m) * m$cw))}))
}

cprobGene <- function(point, m) {
  cprobGenei <- function(point, mu, sd) {
    prod(sapply(1:length(point), function(i){dnorm(point[i], mu[i], sd[i])}))
  }
  sapply(1:m$n, function(i){cprobGenei(point, m$cm[i,], m$cs[i,])})
}

# check individual amplicon
cprobGeneIDX <- function(point, m, idx) {
  cprobGenei <- function(point, mu, sd) {
    sapply(idx, function(i){dnorm(point[i], mu[i], sd[i])})
  }
  sapply(1:m$n, function(i){cprobGenei(point, m$cm[i,], m$cs[i,])})
}

# Voting...

geneCNV <- function(nn_sub, geneamp_idx) {
    do <- as.matrix(nn_sub[geneamp_idx,]) #real data
    na <- length(geneamp_idx) #number of amplicons
    samples <- dim(nn_sub)[2]

    cm2 <- apply(do, 1, median)
    cm = rbind(cm2-1, cm2, cm2+CN3.add)

  	gene.CN4.idx = NULL
    for(d_idx in 1:dim(do)[1]) {
		THRES.CN4 = median(as.numeric(do[d_idx,]))+0.8
		gene.CN4.idx = rbind(gene.CN4.idx, (do[d_idx,]>THRES.CN4+0.2))
	    do[d_idx,do[d_idx,] > THRES.CN4] = THRES.CN4
	}

	# include flooding of CN0 cases for clustering stability
    for(d_idx in 1:dim(do)[1]) {
		amplicon.THRES.CN0 = median(as.numeric(do[d_idx,]))-3
	    do[d_idx,do[d_idx,] < amplicon.THRES.CN0] = amplicon.THRES.CN0
	}

    n <- nrow(cm) #number of clusters
    cs <- matrix(0.1, n, na) #cluster sd;
    cw <- rep(1/n, n) #cluster weight

    pd <- t(cm)
    pw <- rep(1, ncol(pd)) #prior data point weights

    pw <- c(0.1,0.1,0.1)  # put less weight on the prior -> lower confidence when inconsistent

    v <- cbind(pd, do) #all data points for clustering
    wt <- c(pw, rep(1, ncol(do))) #weights of all data points
    oll <- -.Machine$double.xmax #likelihood from the previous iteration
    np <- ncol(pd) #number of prior data points

    m <- list(v=v, n=n, na=na, wt=wt, cm=cm, cs=cs, pm=0, cw=cw)
    m <- estepGene(m)
    nll <- llGene(m)
    i <- 1

    while(i < 60 && nll - oll > 0.00001) {
        oll <- nll
        m <- mstepGene(m)
        m <- estepGene(m)
        nll <- llGene(m)
        i <- i+1
#        cat("iter=",i,"loglikelihood=",nll,"\n")
    }

    temp <- apply(do, 2, function(v){cprobGene(v,m)})
    call.allamplicon <- apply(temp, 2, which.max)

    VOTE = NULL
	tempProb = vector("list",na)
    for(idx in 1:length(geneamp_idx)) {
        tempProb[[idx]] <- apply(do, 2, function(v){cprobGeneIDX(v,m,idx)})
        VOTE = rbind(VOTE, as.numeric(apply(tempProb[[idx]], 2, which.max)))
    }
    VOTE.call = NULL
    for(idx in 1:length(call.allamplicon)) {
        VOT = as.data.frame(table(VOTE[,idx]))
        VOT = VOT[order(VOT$Freq, decreasing=TRUE),]
        VOTE.call = c(VOTE.call, as.numeric(as.character(VOT$Var1[1])))
    }
	# remove at most three amplicons for voting...

	if(length(which(call.allamplicon == VOTE.call)) == samples) {
	    # when Voting over all amplicons is consistent with VOTE over individual amplicons
	    call = VOTE.call
		print(paste("[Use all amplicons for voting]",sep=""))
	} else {
		MisMatch = NULL
	    for(i in 1:na) {   MisMatch = c(MisMatch, length(which(VOTE[i,] != VOTE.call)))  }

    	# exclude the top (at most 3) mismatched amplicons
		ampIDX = 1:na
		MistMatchIDX = which(MisMatch>0)
		if( length(MistMatchIDX) <=4 ) {
		    ampIDX = setdiff(ampIDX, MistMatchIDX)
			print(paste("Exclude inconsistent gene-level amplicons:",MistMatchIDX,sep=""))
		} else {
    		MisMatchTMP = cbind(ampIDX, MisMatch)
	    	MisMatchTMP = MisMatchTMP[order(MisMatchTMP[,2], decreasing=T),]
		    ampIDX = MisMatchTMP[-c(1:4),1]
			print(paste("Exclude inconsistent gene-level amplicons:",MisMatchTMP[1:4,1],sep=""))
		}

    	# use remaining amplicons for calculate posterior probability
		for(a_idx in 1:length(ampIDX)) {
		    if(a_idx==1) {
			    temp=tempProb[[ampIDX[a_idx]]]
			} else {
			    temp=temp*tempProb[[ampIDX[a_idx]]]
			}
		}
		# make new call with less amplicons, and trust it anyway
		call <- apply(temp, 2, which.max)
	}
	temp <- apply(temp, 2, function(v){v/sum(v)})
    # temp is now probability
    temp <- apply(temp, 2, function(v){1-max(v)})
    temp[temp < .Machine$double.xmin] <- .Machine$double.xmin
    Phred <- -10 * log10(temp)
    Phred[Phred>100] <- 100

    GeneOut <- list(call=call, Phred=Phred, m=m, do=do, np=np, na=na, gene.CN4.idx=gene.CN4.idx)
    return(GeneOut)
}

#Reporting <- function(LogFile) {
#	if (!file.exists(LogFile)){    stop(paste("Log File ",LogFile," does not exist.  Please check again.", sep="");    }
#	myLog = read.csv(LogFile, sep="\t")
#}


model_ptq <- function (tTWindowForPTQ = 70.0,
         kl = 0.45,
         listTTShootWindowForPTQ_t1 = c(0.0),
         listPARTTWindowForPTQ_t1 = c(0.0),
         listGAITTWindowForPTQ = c(0.0, 5.2),
         pAR = 0.0,
         deltaTT = 0.0){
    #'- Name: PTQ -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Phyllochron Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Calculate Photothermal Quaotient
    #'- inputs:
    #'            * name: tTWindowForPTQ
    #'                          ** description : Thermal time window in which averages are computed
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 70000.0
    #'                          ** default : 70.0
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: kl
    #'                          ** description : Exctinction Coefficient
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 50.0
    #'                          ** default : 0.45
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: listTTShootWindowForPTQ_t1
    #'                          ** description : List of Daily Shoot thermal time during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0]
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: listPARTTWindowForPTQ_t1
    #'                          ** description : List of Daily PAR during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0]
    #'                          ** unit : MJ m2 d
    #'                          ** uri : some url
    #'            * name: listGAITTWindowForPTQ
    #'                          ** description : List of daily GAI over TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** default : [0.0, 5.2]
    #'                          ** unit : m2 m-2
    #'                          ** uri : some url
    #'            * name: pAR
    #'                          ** description : Daily Photosyntetically Active Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 10000.0
    #'                          ** unit : MJ m² d
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: deltaTT
    #'                          ** description : daily delta TT
    #'                          ** variablecategory : auxiliary
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** default : 0.0
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'- outputs:
    #'            * name: listPARTTWindowForPTQ
    #'                          ** description :  List of Daily PAR during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : MJ m2 d
    #'            * name: listTTShootWindowForPTQ
    #'                          ** description : List of Daily Shoot thermal time during TTWindowForPTQ thermal time period
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : °C d
    #'            * name: ptq
    #'                          ** description : Photothermal Quotient
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : MJ °C-1 d m-2)
    listPARTTWindowForPTQ <- vector()
    listTTShootWindowForPTQ <- vector()
    TTList <- vector()
    PARList <- vector()
    parInt <- 0.0
    for( i in seq(0, length(listTTShootWindowForPTQ_t1)-1, 1)){
        TTList <- c(TTList, listTTShootWindowForPTQ_t1[i+1])
        PARList <- c(PARList, listPARTTWindowForPTQ_t1[i+1])
    }
    TTList <- c(TTList, deltaTT)
    PARList <- c(PARList, pAR)
    SumTT <- sum(TTList)
    count <- 0
    while( SumTT > tTWindowForPTQ){
        SumTT <- SumTT - TTList[count+1]
        count <- count + 1}
    for( i in seq(count, length(TTList)-1, 1)){
        listTTShootWindowForPTQ <- c(listTTShootWindowForPTQ, TTList[i+1])
        listPARTTWindowForPTQ <- c(listPARTTWindowForPTQ, PARList[i+1])
    }
    for( i in seq(0, length(listTTShootWindowForPTQ)-1, 1)){
        parInt <- parInt + (listPARTTWindowForPTQ[i+1] * (1 - exp(-kl * listGAITTWindowForPTQ[i+1])))
    }
    TTShoot <- sum(listTTShootWindowForPTQ)
    ptq <- parInt / TTShoot
    return (list ("listPARTTWindowForPTQ" = listPARTTWindowForPTQ,"listTTShootWindowForPTQ" = listTTShootWindowForPTQ,"ptq" = ptq))
}


euclidean <- function(a, b) sqrt(sum((a - b) ^ 2))

rectKernel <- function(dist) 0.5 * (abs(dist) <= 1)
trKernel <- function(dist) (1 - abs(dist)) * (abs(dist) <= 1)
epKernel = function(dist) (3 / 4) * (1 - dist ^ 2) * (abs(dist) <= 1)
gaussKernel = function(dist) dnorm(dist) * (abs(dist) <= 1)

classify <- function (dset, point, labels, potentials, h, dist = euclidean, kernel = trKernel) {
  #cat(length(labels), dim(dset))
  distances <- apply(dset, 1, dist, point)
  #print(length(distances))

  weights <- potentials * kernel(distances / h)
  #print(length(weights))
  #print(potentials)
  names(weights) <- labels

  # print(potentials)
  # print(kernel(distances / h))
  # print(weights)

  classes <- unique(labels)
  classScores <- sapply(classes, function(class, w) sum(w[names(w) == class]), weights)
  classScores["undefined"] <- 0.000001

  #print(classScores)

  # if (length(unique(classScores)) == 1) {
  #   return(classes[sample(1:length(classes), 1)])
  # }

  #cat("CL RES", classes[which.max(classScores)], classScores, "\n")
  return (names(which.max(classScores)))
}

generateMaps <- function() {
  xs <- seq(from = 0.5, to = 7.5, by = 0.1)
  ys <- seq(from = -1, to = 3.5, by = 0.1)

  colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green", "undefined" = "grey")

  pp <- matrix(c(
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
    c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0)
  ), nrow = 4)
  # print(pp)
  kernels <- c("rectangular" = rectKernel, "triangular" = trKernel, "epachinnikov's" = epKernel, "gaussian" = gaussKernel)

  # par(mfrow = c(length(kernels) / 2, 2), pty="s", mar=c(1,1,1,1))

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("plot-%03d.png", index), width = 1024, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    plot(iris[, 3:4], col = colors[paste(iris$Species)], pch=16, asp=1)
    title(main = paste("Kernel:", kernelName))

    h <- rep(1, 150)
    #print(pp)
    p <- pp[index,]
    #potentials <- potentials(Util.petals, Util.classes, h = h, 5, kernel)

    all <- length(xs) * length(ys)
    progress = 1
    for (i in xs) {
      for (j in ys) {
        cat("\rProcessing point", progress, "of", all)
        progress <- progress + 1
        result <- classify(iris[3:4], c(i, j), paste(iris$Species), p, h, kernel = kernel)
        #print(paste(i, j, result))
        points(i, j, col = colors[result], pch = 21)
      }
    }
    cat("\rDone.                      \n")
    dev.off()
    index <- index + 1
  }
}

generateMaps()

3 - Potential functions method/maps-generation.r


# Load necessary libraries

year <- c(2018:2058)

data <- data.frame(year)
data$lngdppc <- 4.5 + .02*(year-2018)
data$sinv  <- .2
data$ky    <- 3.5
data$phil  <- .75

fig <- plot_ly(data, x = ~year, y = ~lngdppc, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita',range=c(4,5.5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-lngdppc")

fig <- plot_ly(data, x = ~year, y = ~sinv, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital formation/GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of I/Y',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-sinv")

fig <- plot_ly(data, x = ~year, y = ~phil, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP labor share of costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of W/(W+RK)',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-phil")

fig <- plot_ly(data, x = ~year, y = ~ky, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of K/Y',range=c(1,5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-ky")

year <- c(2018:2058)
dA <- data.frame(year)
noise <- rnorm(41)
dA$lngdppc <- 4.5 + .02*(year-2018) + .02*noise
dA$sinv  <- .8 + .03*noise - .01*(year-2018)
dA$ky    <- 5 + .1*noise - .05*(year-2018)
dA$phil  <- .6 + .03*noise
dA$id <- "A"

dB <- data.frame(year)
noise <- rnorm(41)
dB$lngdppc <- 5.3 + .0005*(year-2018)+ .02*noise
dB$sinv  <- .2 + .02*noise
dB$ky    <- 2 + .1*noise + .1*(year-2018)
dB$phil  <- .75 + .03*noise
dB$id <- "B"

dC <- data.frame(year)
noise <- rnorm(41)
dC$lngdppc <- 4 + .04*(year-2018)+ .02*noise
dC$sinv  <- .2 + .03*noise + .01*(year-2018)
dC$ky    <- 2.5 + .1*noise
dC$phil  <- .8 + .03*noise
dC$id <- "C"

dall <- rbind(dA,dB)
dall <- rbind(dall,dC)

fig <- plot_ly(dall, x = ~year, y = ~lngdppc, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-lny")

fig <- plot_ly(dall, x = ~year, y = ~sinv, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Gross capital formation share', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Gross capital formation share of GDP', range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-sinv")

fig <- plot_ly(dall, x = ~year, y = ~ky, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio',range=c(1,6)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-ky")

fig <- plot_ly(dall, x = ~year, y = ~phil, linetype = ~id, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Labor share of costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Labor share of costs',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-phil")

year <- c(0:40)
dA <- data.frame(year)
dA$f <- exp(-.1*dA$year)-exp(-.1*(dA$year-1))
dA$lngdppc <- 4.5 + .02*year
dA$g <- .02
dA$id <- "A"
dA$gid <- "C"

dB <- data.frame(year)
dB$f <- exp(-.1*dB$year)-exp(-.1*(dB$year-1))
dB$lngdppc <- 4.5*exp(-.1*dB$year) + 5*(1-exp(-.1*dB$year)) + .02*year
dB$g <- 4.5*dB$f + 5*(-1*dB$f) + .02
dB$id <- "B"
dB$gid <- "B"

dC <- data.frame(year)
dC$f <- exp(-.1*dC$year)-exp(-.1*(dC$year-1))
dC$lngdppc <- 4.5*exp(-.1*dC$year) + 4*(1-exp(-.1*dC$year)) + .02*year
dC$g <- 4.5*dC$f + 4*(-1*dC$f) + .02
dC$id <- "C"
dC$gid <- "D"

dD <- data.frame(year)
dD$f <- exp(-.1*dD$year)-exp(-.1*(dD$year-1))
dD$lngdppc <- 5.5*exp(-.1*dD$year) + 4.5*(1-exp(-.1*dD$year)) + .02*year
dD$g <- 5.5*dD$f + 4.5*(-1*dD$f) + .02
dD$id <- "D"
dD$gid <- "E"

dE <- data.frame(year)
dE$f <- exp(-.1*dE$year)-exp(-.1*(dE$year-1))
dE$lngdppc <- 3.5*exp(-.1*dE$year) + 4.5*(1-exp(-.1*dE$year)) + .02*year
dE$g <- 3.5*dE$f + 4.5*(-1*dE$f) + .02
dE$id <- "E"
dE$gid <- "A"

dall <- rbind(dA,dB)
dall <- rbind(dall,dC)
dall <- rbind(dall,dD)
dall <- rbind(dall,dE)

fig <- plot_ly(dall, x = ~year, y = ~lngdppc, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-bgp-choices")

dall <- rbind(dA,dE)
dall <- rbind(dall,dD)
fig <- plot_ly(dall, x = ~year, y = ~g, linetype = ~gid, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Growth rate of GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Growth rate of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "test-gy-choices")

year <- c(0:200)
dA <- data.frame(year)
dA$R <- 2*(1+.02)^year
dA$A <- ((1-.02)^year)*1*dA$R + (1- (1-.02)^year)*(.01/.02)*dA$R
dA$lnA <- log(dA$A)
dA$id <- "A"

dB <- data.frame(year)
dB$R <- 2*(1+.01)^year
dB$A <- ((1-.01)^year)*1*dB$R + (1- (1-.01)^year)*(.01/.01)*dB$R
dB$lnA <- log(dB$A)
dB$id <- "B"
dall <- rbind(dA,dB)

dC <- data.frame(year)
dC$R <- 2*(1+.001)^year
dC$A <- ((1-.001)^year)*1*dC$R + (1- (1-.001)^year)*(.01/.001)*dC$R
dC$lnA <- log(dC$A)
dC$id <- "C"
dall <- rbind(dall,dC)

dD <- data.frame(year)
dD$R <- 2*(1+.01)^year
dD$A <- ((1-.01)^year)*1*dD$R + (1- (1-.01)^year)*(.02/.01)*dD$R
dD$lnA <- log(dD$A)
dD$id <- "D"
dall <- rbind(dall,dD)

dE <- data.frame(year)
dE$R <- 2*(1+.01)^year
dE$A <- ((1-.01)^year)*1*dE$R + (1- (1-.01)^year)*(.005/.01)*dE$R
dE$lnA <- log(dE$A)
dE$id <- "E"
dall <- rbind(dall,dE)

fig <- plot_ly(dall, x = ~year, y = ~lnA, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log Productivity (A)', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of productivity (A)'),
              hovermode="x unified")
api_create(fig, filename = "test-logA-choices")

year <- c(0:50)
dA <- data.frame(year)
dA$R <- 12*(1+.01)^year
dA$lnR <- log(dA$R)
dA$id <- "A"

dB <- data.frame(year)
dB$R <- 8*(1-.01)^year
dB$lnR <- log(dB$R)
dB$id <- "B"
dall <- rbind(dA,dB)

dC <- data.frame(year)
dC$R <- 20*(1-.03)^year
dC$lnR <- log(dC$R)
dC$id <- "C"
dall <- rbind(dall,dC)

fig <- plot_ly(dall, x = ~year, y = ~lnR, linetype = ~id, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Resources per capita (X/L)', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of resources per capita (X/L)'),
              hovermode="x unified")
api_create(fig, filename = "test-logXL-choices")


#' C2F
#'
#' Convert temperature from Celsius degree to Fahrenheit degree.
#'
#' @param numeric C Temperature in Celsius degrees.
#' @return numeric  Temperature in Fahrenheit degrees.
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  Temperature
#'
#' @export
#'
#'
#'
#'

C2F<-function(t)
{
  return (t * 1.8+ 32.0);
}


#############
# R script to #
# run simulation #
# of community tightness #
# an community distance metric #
##################################

# load libraries
library(ade4)
library(ggplot2)
library(gridExtra)
library(Matrix)

# now expand with positive or negative correlation
n_obs <- 53
n_col1 <- 10
n_col2 <- 10
n_col3 <- 10
n_col4 <- 10

# very tight communities
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 5, 1),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
diag(M) <- 1
# turn into PD
M_pd <- nearPD(M, corr = TRUE)$mat
M_pm <- melt(as.matrix(M_pd))
M_pm$type <- "tight"
M_pm$value[M_pm$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "tight - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd

# now with loose communities
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 1, 6),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
diag(M) <- 1
# turn into PD
M_pd <- nearPD(M, corr = TRUE)$mat
# to plot the correlation matrix
M_pm2 <- melt(as.matrix(M_pd))
M_pm2$type <- "loose"
M_pm2$value[M_pm2$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "loose - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd2

# now tight within but loose across
M <- matrix(rbeta(n_col1 * n_col2 * n_col3 * n_col4, 1, 6),
            ncol = n_col1 + n_col2 + n_col3 + n_col4,
            nrow = n_col1 + n_col2 + n_col3 + n_col4)
gdata::lowerTriangle(M) <- gdata::upperTriangle(M, byrow=TRUE)
M <- M * ifelse(runif(length(M)) < 0.5, -1, 1) # add randomly negative corr
# go through the different within community corr
gdata::lowerTriangle(M[1:10, 1:10]) <- rbeta(45, 5, 1)
M[1:10, 1:10] <- M[1:10, 1:10] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[1:10, 1:10]) <- gdata::lowerTriangle(M[1:10, 1:10], byrow = TRUE)
gdata::lowerTriangle(M[11:20, 11:20]) <- rbeta(45, 5, 1)
M[11:20, 11:20] <- M[11:20, 11:20] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[11:20, 11:20]) <- gdata::lowerTriangle(M[11:20, 11:20], byrow = TRUE)
gdata::lowerTriangle(M[21:30, 21:30]) <- rbeta(45, 5, 1)
M[21:30, 21:30] <- M[21:30, 21:30] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[21:30, 21:30]) <- gdata::lowerTriangle(M[21:30, 21:30], byrow = TRUE)
gdata::lowerTriangle(M[31:40, 31:40]) <- rbeta(45, 5, 1)
M[31:40, 31:40] <- M[31:40, 31:40] * ifelse(runif(100) < 0.5, -1, 1)
gdata::upperTriangle(M[31:40, 31:40]) <- gdata::lowerTriangle(M[31:40, 31:40], byrow = TRUE)
diag(M) <- 1

M_pd <- nearPD(M, corr = TRUE)$mat
# to plot the correlation matrix
M_pm3 <- melt(as.matrix(M_pd))
M_pm3$type <- "tight within\nloose between"
M_pm3$value[M_pm3$value == 1] <- NA

# Cholesky decomposition
L = chol(M_pd)
nvars = dim(L)[1]
r = t(L) %*% matrix(rnorm((n_col1 + n_col2 + n_col3 + n_col4)*n_obs),
                    nrow=n_col1+n_col2+n_col3+n_col4,
                    ncol=n_obs)
r = t(r)

comm1 <- as.matrix(r)[,1:n_col1]
comm2 <- as.matrix(r)[,(n_col1 + 1):(n_col1 + n_col2)]
comm3 <- as.matrix(r)[,(n_col1 + n_col2 + 1):(n_col1 + n_col2 + n_col3)]
comm4 <- as.matrix(r)[,(n_col1 + n_col2 + n_col3 + 1):(n_col1 + n_col2 + n_col3 + n_col4)]

# run mcoa
d1 <- dudi.pca(comm1, scannf = FALSE)
d2 <- dudi.pca(comm2, scannf = FALSE)
d3 <- dudi.pca(comm3, scannf = FALSE)
d4 <- dudi.pca(comm4, scannf = FALSE)

ktt <- ktab.list.dudi(list(d1, d2, d3, d4))

mm <- mcoa(ktt, scannf = FALSE, nf = 2)

# get the dist for each plots
vhb_xy <- mm$Tl1
vhb_xy$id_plot <- rep(1:53, 4)
vhb_xy$ref_x <- mm$SynVar[rep(1:53, 4),1]
vhb_xy$ref_y <- mm$SynVar[rep(1:53, 4),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy$type <- "tight within\nloose between - w. negative"
vhb_xy %>%
  group_by(type, id_plot) %>%
  summarise(d = sum(d)) -> vhb_dd3

# a plot comparing the correlation
M_a <- rbind(M_pm, M_pm2, M_pm3)
gg_1 <- ggplot(M_a, aes(x=Var1, y = Var2, fill = value)) +
  geom_raster() +
  facet_wrap(~ type) +
  scale_fill_gradient2(low = "red", high = "blue") +
  labs(x = "", y = "",
       title = "Simulated correlation structure between 4 communities") +
  theme(axis.text = element_blank(), axis.ticks = element_blank(),
        panel.background = element_blank())

# a plot comparing the d-metric
vhb_a <- rbind(vhb_dd, vhb_dd2, vhb_dd3)
gg_2 <- ggplot(vhb_a, aes(x=type, y=d))+
  geom_jitter(width = 0.1, alpha = 0.3, size = 0.5) +
  stat_summary(fun.data = "mean_cl_boot", color = "red") +
  labs(x = "Type of correlation structure",
       y = "Community distance index",
       title = "Effect of correlation structure between communities\non community distance index")
# nice!

gg_a <- grid.arrange(gg_1, gg_2, nrow = 2)
ggsave("~/PostDoc_Ghent/Synthesis_3/figures/simulation_res_wneg.png", gg_a,
       width = 8, height = 9, units = "in")


physics.precalculated.earth.mass = (5.98e+24)
physics.precalculated.earth.radius = physics.convert.to.meters(6378)
physics.precalculated.earth.density = physics.density.calculate(physics.precalculated.earth.mass, physics.volume.calculate.sphere(physics.precalculated.earth.radius))
physics.precalculated.earth.gravity = physics.gravity.calculate.acceleration(physics.precalculated.earth.mass, physics.precalculated.earth.radius)

physics.precalculated.mercury.mass = (3.30e+23)
physics.precalculated.mercury.radius = physics.convert.to.meters(2439)
physics.precalculated.mercury.density = physics.density.calculate(physics.precalculated.mercury.mass, physics.volume.calculate.sphere(physics.precalculated.mercury.radius))
physics.precalculated.mercury.gravity = physics.gravity.calculate.acceleration(physics.precalculated.mercury.mass, physics.precalculated.mercury.radius)


model_vernalizationprogress <- function (dayLength = 12.3037621834005,
         deltaTT = 20.3429985011972,
         cumulTT = 112.330110409888,
         leafNumber_t1 = 0.0,
         calendarMoments_t1 = c('Sowing'),
         calendarDates_t1 = c('2007/3/21'),
         calendarCumuls_t1 = c(0.0),
         minTvern = 0.0,
         intTvern = 11.0,
         vAI = 0.015,
         vBEE = 0.01,
         minDL = 8.0,
         maxDL = 15.0,
         maxTvern = 23.0,
         pNini = 4.0,
         aMXLFNO = 24.0,
         vernaprog_t1 = 0.5517254187376879,
         currentdate = '2007/3/27',
         isVernalizable = 1,
         minFinalNumber_t1 = 5.5){
    #'- Name: VernalizationProgress -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: VernalizationProgress Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Calculate progress (VernaProg) towards vernalization, but there
    #'        			is no vernalization below minTvern
    #'        			and above maxTvern . The maximum value of VernaProg is 1.
    #'        			Progress towards full vernalization is a linear function of shoot
    #'        			temperature (soil temperature until leaf # reach MaxLeafSoil and then
    #'        			 canopy temperature)
    #'
    #'- inputs:
    #'            * name: dayLength
    #'                          ** description : day length
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 12.3037621834005
    #'                          ** unit : mm2 m-2
    #'                          ** inputtype : variable
    #'            * name: deltaTT
    #'                          ** description : difference cumul TT between j and j-1 day
    #'                          ** variablecategory : auxiliary
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 100
    #'                          ** default : 20.3429985011972
    #'                          ** unit : °C d
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at currentdate
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 112.330110409888
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: leafNumber_t1
    #'                          ** description : Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 0
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'            * name: calendarMoments_t1
    #'                          ** description : List containing appearance of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** default : ['Sowing']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarDates_t1
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** default : ['2007/3/21']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarCumuls_t1
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: minTvern
    #'                          ** description : Minimum temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default : 0.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: intTvern
    #'                          ** description : Intermediate temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default :  11.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: vAI
    #'                          ** description : Response of vernalization rate to temperature
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default :  0.015
    #'                          ** unit : d-1 °C-1
    #'                          ** inputtype : parameter
    #'            * name: vBEE
    #'                          ** description : Vernalization rate at 0°C
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.01
    #'                          ** unit : d-1
    #'                          ** inputtype : parameter
    #'            * name: minDL
    #'                          ** description : Threshold daylength below which it does influence vernalization rate
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 12
    #'                          ** max : 24
    #'                          ** default : 8.0
    #'                          ** unit : h
    #'                          ** inputtype : parameter
    #'            * name: maxDL
    #'                          ** description : Saturating photoperiod above which final leaf number is not influenced by daylength
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** default : 15.0
    #'                          ** unit : h
    #'                          ** inputtype : parameter
    #'            * name: maxTvern
    #'                          ** description : Maximum temperature for vernalization to occur
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : -20
    #'                          ** max : 60
    #'                          ** default :  23.0
    #'                          ** unit : °C
    #'                          ** inputtype : parameter
    #'            * name: pNini
    #'                          ** description : Number of primorida in the apex at emergence
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** default : 4.0
    #'                          ** unit : primordia
    #'                          ** inputtype : parameter
    #'            * name: aMXLFNO
    #'                          ** description : Absolute maximum leaf number
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 24.0
    #'                          ** unit : leaf
    #'                          ** inputtype : parameter
    #'            * name: vernaprog_t1
    #'                          ** description : progression on a 0  to 1 scale of the vernalization
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default :  0.5517254187376879
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: currentdate
    #'                          ** description : current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DATE
    #'                          ** default : 2007/3/27
    #'                          ** inputtype : variable
    #'                          ** unit :
    #'            * name: isVernalizable
    #'                          ** description : true if the plant is vernalizable
    #'                          ** parametercategory : species
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : parameter
    #'            * name: minFinalNumber_t1
    #'                          ** description : minimum final leaf number
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 5.5
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'- outputs:
    #'            * name: vernaprog
    #'                          ** description : progression on a 0  to 1 scale of the vernalization
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit :
    #'            * name: minFinalNumber
    #'                          ** description : minimum final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : leaf
    #'            * name: calendarMoments
    #'                          ** description : List containing appearance of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** unit :
    #'            * name: calendarDates
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** unit :
    #'            * name: calendarCumuls
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit :
    calendarMoments <- vector()
    calendarDates <- vector()
    calendarCumuls <- vector()
    calendarMoments <- calendarMoments_t1
    calendarCumuls <- calendarCumuls_t1
    calendarDates <- calendarDates_t1
    minFinalNumber <- minFinalNumber_t1
    vernaprog <- vernaprog_t1
    if (isVernalizable == 1 && vernaprog_t1 < 1.0)
    {
        tt <- deltaTT
        if (tt >= minTvern && tt <= intTvern)
        {
            vernaprog <- vernaprog_t1 + (vAI * tt) + vBEE
        }
        else
        {
            vernaprog <- vernaprog_t1
        }
        if (tt > intTvern)
        {
            maxVernaProg <- vAI * intTvern + vBEE
            dLverna <- max(minDL, min(maxDL, dayLength))
            vernaprog <- vernaprog + max(0.0, maxVernaProg * (1.0 + ((intTvern - tt) / (maxTvern - intTvern) * ((dLverna - minDL) / (maxDL - minDL)))))
        }
        primordno <- 2.0 * leafNumber_t1 + pNini
        minLeafNumber <- minFinalNumber_t1
        if (vernaprog >= 1.0 || primordno >= aMXLFNO)
        {
            minFinalNumber <- max(primordno, minFinalNumber_t1)
            calendarMoments <- c(calendarMoments, 'EndVernalisation')
            calendarCumuls <- c(calendarCumuls, cumulTT)
            calendarDates <- c(calendarDates, currentdate)
            vernaprog <- max(1.0, vernaprog)
        }
        else
        {
            potlfno <- aMXLFNO - ((aMXLFNO - minLeafNumber) * vernaprog)
            if (primordno >= potlfno)
            {
                minFinalNumber <- max((potlfno + primordno) / 2.0, minFinalNumber_t1)
                vernaprog <- max(1.0, vernaprog)
                calendarMoments <- c(calendarMoments, 'EndVernalisation')
                calendarCumuls <- c(calendarCumuls, cumulTT)
                calendarDates <- c(calendarDates, currentdate)
            }
        }
    }
    return (list ("vernaprog" = vernaprog,"minFinalNumber" = minFinalNumber,"calendarMoments" = calendarMoments,"calendarDates" = calendarDates,"calendarCumuls" = calendarCumuls))
}


solve_nocopy <- function(problemsize)
{
  N <- problemsize

  ### Don't want to divide by 0 if someone submits a tiny problem
  for (power in 0:6)
  {
    if (power == 6)
      stop("Your computer is from the future!")

    ordmag <- 10^power

    A <- matrix(rnorm(N*N), N, N)
    B <- matrix(rnorm(N*N), N, 1L)

    time <- mean(replicate(ordmag,
      system.time( X <- .Call(R_solve_nocopy, A, B) )[3])
    )

    rm(A);rm(B);invisible(gc())

    if (time > 1e-8) break
  }

  nops <- 2/3*N*N*N + 2*N*N
  flops <- nops / as.numeric(time)

  return(flops)
}

#' Linpack Benchmark
#'
#' The Linpack benchmark is the standard performance benchmark
#' for numerical computing.  Research institutions, governments,
#' and companies with very large computing resources "compete" to
#' build machines that will perform the best on the benchmark.
#' Results of this competition are released twice a year, in
#' June and in November, at the ISC and SC conferences, respectively.
#' Although it is generally understood that Linpack no longer
#' adequately measures the performance capabilities of a system
#' on real problems, it has remained an important measurement
#' all the same.  One of the most attractive things
#' about the Linpack benchmark is its host of historical data,
#' which dates back all the way to 1993.
#'
#' If you are even somewhat serious about using this as a test of
#' the host system's capabilities, I would strongly encourage you
#' to run this exclusively; that is, shut down all other
#' resource-intensive applications (web browsers, system updates,
#' antivirus, whatever).  If a lot of your ram is used up by
#' other utilities and the benchmarker has to swap them to disk,
#' the performance will degrade by several orders of magnitude.
#'
#' @param nmin
#' Minimum problem size.
#' @param nmax
#' Maximum problem size.  Value should either be an integer greater
#' than \code{nmin} or it should be the string "choose".  In the
#' former case, the supplied value will be the largest value
#' considered.  In the latter case, the largest problem size will
#' be 2/3 of max system ram.
#' @param by
#' How to get from nmin to nmax.  Value should either be a numeric
#' value greater than 0, or it should be the string "doubling".  In
#' the former case, \code{seq.int()} is used, while in the latter,
#' values starting with nmin will be doubled until nmax is
#' reached/surpassed.
#' @param warn
#' Logical; this controls the printing of a warning that I very
#' seriously want you to read.  Set \code{warnme=FALSE} to disable
#' after you have read it.
#' @param verbose
#' Logical; determines whether or not intermediate results should
#' be printed.
#'
#' @return
#' The return is a list (formally an S3 'linpack' object), containing:
#' \tabular{ll}{
#'    R.max \tab The max
#' }
#'
#' @references \url{http://www.top500.org/project/linpack/}
#'
#' @name linpack
#' @rdname linpack
#' @export
linpack <- function(nmin=1000, nmax="choose", by="doubling", warn=TRUE, verbose=TRUE)
{
  msg <- "
                    /!\\ Please read me /!\\\n
  Running this without very efficient BLAS (e.g., MKL, OpenBLAS, ...)
  is a waste of time and will not give you a good sense of the
  performance of your machine.  You are encouraged to investigate
  using OpenBLAS, or Revolution R Open.\n
  If you don't know which BLAS you're using, they're not efficient!\n"

  assert_type(warn, "logical")
  if (warn) cat(msg)
  assert_type(verbose, "logical")

  ### Checks
  assert_type(nmin, "int")
  assert_val(nmin > 0)
  N.bottom <- nmin

  if (is.character(nmax))
  {
    nmax <- match.arg(tolower(nmax), "choose")
    N.top <- as.integer(howmany(Sys.meminfo()$totalram/1.5))[1L]
    assert_val(N.top > 0, "Unable to determine max system ram")
  }
  else
  {
    assert_type(nmax, "int")
    assert_val(nmax > 0)
    assert_val(nmin <= nmax, "No valid test cases selsected:  nmin > nmax")

    N.top <- nmax
  }

  if (is.character(by))
  {
    by <- match.arg(tolower(by), "doubling")
    Ns <- a2b_int_doubling(N.bottom, N.top)
  }
  else
  {
    assert_type(by, "numeric")
    assert_val(by > 0)
    Ns <- round(seq.int(from=N.bottom, to=N.top, by=by))
  }

  ### benchmark
  R.max <- 0
  N.max <- 0

  if (verbose) cat("\n   N      R.max\n")

  for (N in Ns)
  {
    if (verbose) cat(N)

    test <- solve_nocopy(problemsize=N)

    if (test > R.max)
    {
      R.max <- test
      N.max <- N
    }

    if (verbose)
      cat("   ", R.max, "\n")

    N <- N*2L
  }

  if (verbose) cat("\n")

  R.max <- flops(R.max)
  R.peak <- cpu_clock()$peak

  ret <- list(R.max=R.max, N.max=N.max, R.peak=R.peak)
  class(ret) <- "linpack"

  return(ret)
}

#' @export
summary.linpack <- function(object, ..., digits=3)
{
  Pct <- unflop(object$R.max) / unflop(object$R.peak) * 100

  ret <- list(Pct=Pct)

  maxlen <- max(sapply(names(ret), nchar))
  names <- gsub(names(ret), pattern="_", replacement=" ")
  names <- title_case(names)
  spacenames <- simplify2array(lapply(names, function(str) paste0(str, ":", paste0(rep(" ", maxlen-nchar(str)), collapse=""))))

  cat(paste(spacenames, sapply(ret, round, digits=digits), sep=" ", collapse="\n"), "\n")

  return(invisible(ret))
}

#' Prints linpack objects
#'
#' @param x
#' A linpack object to print.
#' @param ...
#' Extra arguments (ignored).
#' @param digits
#' Number of digits to print.
#'
#' @name print-linpack
#' @rdname print-linpack
#' @method print linpack
#' @export
print.linpack <- function(x, ..., digits=3)
{
  maxlen <- max(sapply(names(x), nchar))
  names <- gsub(names(x), pattern="_", replacement=" ")
  names <- title_case(names)
  spacenames <- simplify2array(lapply(names, function(str) paste0(str, ":", paste0(rep(" ", maxlen-nchar(str)), collapse=""))))

  printfun <- function(x, digits)
  {
    if (class(x) == "flops")
      capture.output(print(x, digits=digits))
    else
      round(x, digits=digits)
  }

  cat(paste(spacenames, sapply(x, printfun, digits=digits), sep=" ", collapse="\n"), "\n")
  invisible()
}

#' Subsets linpack outputs.
#'
#' @param x
#' linpack object.
#' @param i
#' Index.
#'
#' @name subset-linpack
#' @rdname subset-linpack
#' @method [ linpack
#' @export
"[.linpack" <- function(x, i)
{
  class(x) <- NULL
  ret <- x[i]
  if (length(ret) > 0)
    class(ret) <- "linpack"
  else
    return(numeric(0))

  return(ret)
}


# These have been taken from the EnvStats library (https://cran.r-project.org/web/packages/EnvStats/index.html)

#' @export
#' @keywords internal
#' @importFrom stats pgamma
pgammaAlt = function (q, mean, cv = 1, lower.tail = TRUE, log.p = FALSE)
{
    shape <- cv^-2
    scale <- mean/shape
    stats::pgamma(q = q, shape = shape, scale = scale, lower.tail = lower.tail,
        log.p = log.p)
}

#' @export
#' @keywords internal
#' @importFrom stats dgamma
dgammaAlt = function (x, mean, cv = 1, log = FALSE)
{
    shape <- cv^-2
    scale <- mean/shape
    stats::dgamma(x = x, shape = shape, scale = scale, log = log)
}

#' @export
#' @keywords internal
#' @importFrom stats rgamma
rgammaAlt = function (n, mean, cv = 1)
{
    shape <- cv^-2
    scale <- mean/shape
    stats::rgamma(n = n, shape = shape, scale = scale)
}


# 4. faza: Analiza podatkov

library(GGally)
library(mgcv)
#podatki <- obcine %>% transmute(obcina, povrsina, gostota,
#                                gostota.naselij=naselja/povrsina) %>%
#  left_join(povprecja, by="obcina")
#row.names(podatki) <- podatki$obcina
#podatki$obcina <- NULL

# Število skupin
#n <- 5
#skupine <- hclust(dist(scale(podatki))) %>% cutree(n)

#napoved za naprej letalski promet v odvisnosti od železniškega (uvoz, blago)
lbuvoz <- letalski_blagovni_promet %>% filter( tovor == 'uvoz') %>% rename(letalski = tone)
zbuvoz <- zelezniski_blagovni_promet %>% filter( tovor == 'uvoz') %>% rename(zelezniski = tone)
e <- inner_join(lbuvoz, zbuvoz)[, -c(2)]

g <- ggplot(e, aes(x=letalski, y= zelezniski))+ xlim(500, 1100) + geom_point() +
  geom_smooth(method="loess", se= FALSE,
              fullrange= TRUE, color = 'red') +
  geom_smooth(method = 'lm', formula = y ~ x +I(x^2),
               se = FALSE, fullrange=TRUE, color= 'green')+
  ggtitle('Uvoz blaga letalskega prometa v odvisnosti od železniškega')+
  ylab('železniški')

#napoved za naprej letalski promet v odvisnosti od zeležniškega (uvoz, ljudi)
lpuvoz <- letalski_potniski_promet %>% filter( tovor == 'uvoz') %>% rename(letalski = potniki)
zpuvoz <- zelezniski_potniski_promet %>% filter( tovor == 'uvoz') %>% rename(zelezniski = potniki)
e2 <- inner_join(lpuvoz, zpuvoz)[, -c(2)]

g2 <- ggplot(e2, aes(x=letalski, y= zelezniski))+ xlim(3000, 9000) + geom_point() +
  geom_smooth(method="loess", se= FALSE,
              fullrange= TRUE, color = 'red') +
  geom_smooth(method = 'lm', formula = y ~ x +I(x^2),
              se = FALSE, fullrange=TRUE, color= 'blue')+
  ggtitle('Uvoz potnikov letalskega prometa v odvisnosti od železniškega')+
  ylab('železniški')

#napoved kako se bo spreminjal cestni blagovni promet uvoz

cestni_blagovni_promet$tone <- cestni_blagovni_promet$tone / 1000
cuvoz <- cestni_blagovni_promet %>%  filter(tovor == 'uvoz') %>% rename(cestni = tone)
prilagajanje <- lm(data = cuvoz, cestni~I(leto^2) +leto + 0)
gg <- data.frame(leto = seq(2010, 2020, 1))
napoved <- mutate(gg, cestni=predict(prilagajanje, gg))

graf_regresije_uvoz <- ggplot(cuvoz, aes(x=leto, y=cestni))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'blue')+
  geom_point(data = napoved, aes(x= leto, y=cestni), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2010, 2020, 2)) +
  ggtitle('Napoved rasti uvoza cestnega blagovnega prometa v Sloveniji')+
  ylab('cestni promet v tonah (1000)')

#napoved kako se spreminja cestni blagovni promet izvoz

cizvoz <- cestni_blagovni_promet %>%  filter(tovor == 'izvoz') %>% rename(cestni = tone)
prilagajanje2 <- lm(data = cizvoz, cestni~I(leto^2) +leto + 0)
gg2 <- data.frame(leto = seq(2010, 2020, 1))
napoved2 <- mutate(gg2, cestni=predict(prilagajanje2, gg2))

graf_regresije_izvoz <- ggplot(cizvoz, aes(x=leto, y=cestni))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'green')+
  geom_point(data = napoved2, aes(x= leto, y=cestni), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2010, 2020, 2))+
  ggtitle('Napoved rasti izvoza cestnega blagovnega prometa v Sloveniji')+
  ylab('cestni promet v tonah (1000)')


#' Seasonality Tests for The ATAforecasting
#'
#' @description This function is a class of seasonality tests using  \code{corrgram_test} from ATAforecasting package, \code{ndiffs} and \code{nsdiffs} functions from forecast package.
#' Also, this function is modified version of \code{ndiffs} and \code{nsdiffs} written by Hyndman et al. \code{forecast} package.
#' Please review manual and vignette documents of latest \code{forecast} package. According to \code{forecast} package,
#' \code{ndiffs} and \code{nsdiffs} functions to estimate the number of differences required to make a given time series stationary.
#' \code{ndiffs} uses unit root tests to determine the number of differences required for time series to be made trend stationary. Several different tests are available:
#' \itemize{
#' 	\item {uroot.test = 'kpss'}			: the KPSS test is used with the null hypothesis that \code{x} has a stationary root against a unit-root alternative. Then the test returns the least number of differences required to pass the test at the level \code{uroot.alpha}.
#' 	\item {uroot.test = 'adf'}			: the Augmented Dickey-Fuller test is used.
#' 	\item {uroot.test = 'pp'}			: the Phillips-Perron test is used. In both of these cases, the null hypothesis is that \code{x} has a unit root against a stationary root alternative. Then the test returns the least number of differences required to fail the test at the level \code{uroot.alpha}.
#' }
#' \code{nsdiffs} uses seasonal unit root tests to determine the number of seasonal differences required for time series to be made stationary. Several different tests are available:
#' \itemize{
#' 	\item {suroot.test = 'seas'}		: a measure of seasonal strength is used, where differencing is selected if the seasonal strength (Wang, Smith & Hyndman, 2006) exceeds 0.64 (based on minimizing MASE when forecasting using auto.arima on M3 and M4 data).
#' 	\item {suroot.test = 'ch'}			: the Canova-Hansen (1995) test is used (with null hypothesis of deterministic seasonality)
#' 	\item {suroot.test = 'hegy'}		: the Hylleberg, Engle, Granger & Yoo (1990) test is used.
#' 	\item {suroot.test = 'ocsb'}		: the Osborn-Chui-Smith-Birchenhall (1988) test is used (with null hypothesis that a seasonal unit root exists).
#' 	\item {suroot.test = 'correlogram'}	: this function is written based on M4 Competition Seasonality Test.
#' }
#'
#' @param input The data.
#' @param ppy Frequency of the data.
#' @param attr_set Assign from \code{ATA.SeasAttr} function. Attributes set for unit root, seasonality tests.
#'
#' @return \code{TRUE} if the serie has seasonality. Otherwise, \code{FALSE}.
#'
#' @author Ali Sabri Taylan and Hanife Taylan Selamlar
#'
#' @seealso \code{forecast}, \code{urca}, \code{tseries}, \code{uroot}, \code{stlplus}, \code{stR},
#' \code{\link[stats]{stl}}, \code{\link[stats]{decompose}}, \code{tbats}, \code{seasadj}.
#'
#' @keywords ata ADF Canova-Hansen correlogram HEGY KPSS Phillips-Perron OCSB seasonal unit-root
#'
#' @references
#'
#' #'\insertRef{dickey1979}{ATAforecasting}
#'
#' #'\insertRef{said1984}{ATAforecasting}
#'
#' #'\insertRef{dhf1984}{ATAforecasting}
#'
#' #'\insertRef{phillips1988}{ATAforecasting}
#'
#' #'\insertRef{ocsb1988}{ATAforecasting}
#'
#' #'\insertRef{hegy1990}{ATAforecasting}
#'
#' #'\insertRef{kpss1992}{ATAforecasting}
#'
#' #'\insertRef{ch1995}{ATAforecasting}
#'
#' #'\insertRef{seas2006}{ATAforecasting}
#'
#'
#' @importFrom forecast ndiffs nsdiffs
#' @importFrom Rdpack reprompt
#'
#' @export
#'
ATA.Seasonality <- function(input, ppy, attr_set)
{
  if (max(ppy)==1){
    test_seasonal <- FALSE
  }else {
    test <- attr_set$suroot.test
    if (test=="correlogram"){
      test_seasonal <- corrgram_test(input, ppy, attr_set)
    }else {
      if (length(ppy)>1){
        if (attr_set$multi.period=="max"){
          ppy <- max(ppy)
        }else {
          ppy <- min(ppy)
        }
      }
      if (attr_set$suroot.uroot==TRUE){
        uroot.test <- attr_set$uroot.test
        uroot.type <- attr_set$uroot.type
        uroot.alpha <- attr_set$uroot.alpha
        uroot.pkg <- attr_set$uroot.pkg
        uroot.maxd <- attr_set$uroot.maxd
        #Used to determine whether a time series is stationary (trend)
        if (uroot.pkg=="urca") {
          d <- forecast::ndiffs(input, alpha=uroot.alpha, test=uroot.test, type=uroot.type, max.d=uroot.maxd)
        }else {
          d <- ndiffs_tseries(input, alpha=uroot.alpha, test=uroot.test, max.d=uroot.maxd)
        }
        if (d > 0){
          input <- diff(input, differences=d, lag=1)
        }
      }
      suroot.alpha <- attr_set$suroot.alpha
      suroot.maxD <- attr_set$suroot.maxD
      suroot.m <- attr_set$suroot.m
      if (!is.null(attr_set$suroot.m)){
        D <- forecast::nsdiffs(input, alpha=suroot.alpha, m=suroot.m, test=test, max.D=suroot.maxD)
      }else {
        D <- forecast::nsdiffs(input, alpha=suroot.alpha, test=test, max.D=suroot.maxD)
      }
      test_seasonal <- ifelse(D==0, FALSE, TRUE)
    }
  }
}

#' @importFrom forecast ndiffs nsdiffs
#' @importFrom stats acf
corrgram_test <- function(input, ppy, attr_set)
{
  if (max(ppy)==1){
    test_seasonal <- FALSE
  }else {
    corrgram.tcrit <- attr_set$corrgram.tcrit
    uroot.test <- attr_set$uroot.test
    uroot.type <- attr_set$uroot.type
    uroot.alpha <- attr_set$uroot.alpha
    uroot.pkg <- attr_set$uroot.pkg
    uroot.maxd <- attr_set$uroot.maxd
    if (length(ppy) > 1){
      if (attr_set$multi.period=="max"){
        ppy <- max(ppy)
      }else {
        ppy <- min(ppy)
      }
    }
    #Used to determine whether a time series is stationary (trend)
    if (uroot.pkg=="urca") {
      d <- forecast::ndiffs(input, alpha=uroot.alpha, test=uroot.test, type=uroot.type, max.d=uroot.maxd)
    }else {
      d <- ndiffs_tseries(input, alpha=uroot.alpha, test=uroot.test, max.d=uroot.maxd)
    }
    if (d > 0){
      input <- diff(input, differences=d, lag=1)
    }
    #Used to determine whether a time series is seasonal
    if (length(input) < 3 * ppy){
      test_seasonal <- FALSE
    }else {
      if (stats::acf(input, plot = FALSE)$acf[1] == 1){
        xacf <- stats::acf(input, plot = FALSE)$acf[-1, 1, 1]
      }else {
        xacf <- stats::acf(input, plot = FALSE)$acf
      }
      clim <- corrgram.tcrit / sqrt(length(input)) * sqrt(cumsum(c(1, 2 * xacf^2)))
      test_seasonal <- (abs(xacf[ppy]) > clim[ppy])
      if (is.na(test_seasonal) == TRUE){
        test_seasonal <- FALSE
      }
    }
  }
  return(test_seasonal)
}

#' @importFrom stats acf na.omit
#' @importFrom forecast is.constant
#' @importFrom tseries adf.test kpss.test pp.test
ndiffs_tseries <- function(x, alpha = 0.05, test = c("kpss","adf","pp"), max.d=2)
{
  #ndiffs function using tseries package
  test <- match.arg(test)
  x <- c(na.omit(c(x)))
  d <- 0

  if(is.constant(x))
    return(d)

  if(test == "kpss")
    suppressWarnings(dodiff <- tseries::kpss.test(x)$p.value < alpha)
  else if(test == "adf")
    suppressWarnings(dodiff <- tseries::adf.test(x)$p.value > alpha)
  else if(test == "pp")
    suppressWarnings(dodiff <- tseries::pp.test(x)$p.value > alpha)
  else
    stop("This shouldn't happen")
  if(is.na(dodiff))
  {
    return(d)
  }
  while(dodiff & d < max.d)
  {
    d <- d+1
    x <- diff(x)
    if(is.constant(x))
      return(d)
    if(test == "kpss")
      suppressWarnings(dodiff <- tseries::kpss.test(x)$p.value < alpha)
    else if(test == "adf")
      suppressWarnings(dodiff <- tseries::adf.test(x)$p.value > alpha)
    else if(test == "pp")
      suppressWarnings(dodiff <- tseries::pp.test(x)$p.value > alpha)
    else
      stop("This shouldn't happen")
    if(is.na(dodiff))
      return(d-1)
  }
  return(d)
}


=begin
[((<index|URL:index.html>))]
= Exercise

== CONTENTS

* ((<Finite Sets>))
  * ((<Sets>))
  * ((<Maps>))
  * ((<Groups>))
* ((<Calculation of polynomials>))
* ((<Calculation of multi-variate polynomials>))
* ((<Calculation of multi-variate polynomials (2)>))
* ((<Remainder of the division of a polynomial by polynomials>))
* ((<Groebner basis>))
* ((<Prime field>))
* ((<Algebraic field>))
  * ((<This can be done as following>))
* ((<Quotient fields>))
  * ((<By taking the quotient field of the ring of Integer, rational numbers are obtained.>))
  * ((<Rational function field>))
  * ((<Rational function field over the algebraic extension field>))
  * ((<Algebraic function field>))
* ((<Linear Algebra>))
  * ((<Linear equations>))
  * ((<Diagonalization of Square Matrix>))
  * ((<Elementary Divisors of Matrix>))
  * ((<Jordan Canonical Form of Matrix>))
  * ((<The proofs of the theorem of Cayley-Hamilton>))
* ((<The expression of Groebner basis by original generators>))
* ((<The quotients and the remainder by arbitrary basis>))
* ((<Factorization>))
  * ((<Factorization of Integer coefficient polynomial>))
  * ((<Factorization of Zp coefficient polynomial>))
  * ((<Factorization over the algebraic extension of Rational>))
  * ((<Factorization over the algebraic extension of the algebraic extension of Rational>))
  * ((<Factorization of x^4 + 10x^2 + 1>))
  * ((<Factorization of Integer or Rational coefficient multi-variate polynomial>))
  * ((<Factorization of Zp coefficient multi-variate polynomial>))
* ((<Algebraic Equations>))
  * ((<Minimal Polynomial>))
  * ((<Minimal Splitting Field>))
  * ((<Galois Group of polynomials>))
* ((<Geometry>))
  * ((<Existance of a barycenter>))
  * ((<Existance of a circumcenter>))
  * ((<Existance of a orthocenter>))
  * ((<4 triangles>))
* ((<Analysis>))
  * ((<Lagrange Multiplier>))

== Finite Sets

=== Sets

<<< sample-set01.rb.v.rd

=== Maps

<<< sample-map01.rb.v.rd

=== Groups

<<< sample-group01.rb.v.rd

== Calculation of polynomials

<<< sample-polynomial01.rb.v.rd

== Calculation of multi-variate polynomials

<<< sample-polynomial02.rb.v.rd

== Calculation of multi-variate polynomials (2)

<<< sample-m-polynomial01.rb.v.rd

== Remainder of the division of a polynomial by polynomials

<<< sample-divmod01.rb.v.rd

== Groebner basis

<<< sample-groebner01.rb.v.rd

== Prime field

<<< sample-primefield01.rb.v.rd

== Algebraic field

<<< sample-algebraicfield01.rb.v.rd

=== This can be done as following

<<< sample-algebraicfield02.rb.v.rd

=== Calculation of roots

<<< sample-algebraic-root01.rb.v.rd

== Quotient fields

=== By taking the quotient field of the ring of Integer, rational numbers are obtained.

<<< sample-quotientfield01.rb.v.rd

=== Rational function field

<<< sample-quotientfield02.rb.v.rd

=== Rational function field over the algebraic extension field

<<< sample-quotientfield03.rb.v.rd

=== Algebraic function field

<<< sample-quotientfield04.rb.v.rd

== Linear Algebra

=== Linear equations

<<< sample-gaussian-elimination01.rb.v.rd

=== Diagonalization of Square Matrix

<<< sample-diagonalization01.rb.v.rd

=== Elementary Divisors of Matrix

<<< sample-elementary-divisor01.rb.v.rd

=== Jordan Canonical Form of Matrix

<<< sample-jordan-form01.rb.v.rd

=== The proofs of the theorem of Cayley-Hamilton

<<< sample-cayleyhamilton01.rb.v.rd

== The expression of Groebner basis by original generators

<<< sample-groebner02.rb.v.rd

== The quotients and the remainder by arbitrary basis

<<< sample-groebner03.rb.v.rd

== Factorization

=== Factorization of Integer coefficient polynomial

<<< sample-factorize01.rb.v.rd

=== Factorization of Zp coefficient polynomial

<<< sample-factorize02.rb.v.rd

=== Factorization over the algebraic extension of Rational

<<< sample-factorize03.rb.v.rd

=== Factorization over the algebraic extension of the algebraic extension of Rational

<<< sample-factorize04.rb.v.rd

=== Factorization of x^4 + 10x^2 + 1

<<< sample-factorize05.rb.v.rd

=== Factorization of Integer or Rational coefficient multi-variate polynomial

<<< sample-m-factorize01.rb.v.rd

=== Factorization of Zp coefficient multi-variate polynomial

<<< sample-m-factorize02.rb.v.rd

== Algebraic Equations

=== Minimal Polynomial

<<< sample-algebraic-equation01.rb.v.rd

=== Minimal Splitting Field

<<< sample-splitting-field01.rb.v.rd

=== Galois Group of polynomials

<<< sample-galois-group01.rb.v.rd

== Geometry
=== Existance of a barycenter

<<< sample-geometry01.rb.v.rd

=== Existance of a circumcenter

<<< sample-geometry02.rb.v.rd

#=== Existance of a incenter

#<<< sample-geometry03.rb.v.rd

=== Existance of a orthocenter

<<< sample-geometry04.rb.v.rd

=== 4 triangles
see ((<URL:http://www1.odn.ne.jp/drinkcat/topic/column/quest/quest_2/quest_2.html>)) Question 3.

<<< sample-geometry07.rb.v.rd

== Analysis
=== Lagrange Multiplier
<<< sample-lagrange-multiplier01.rb.v.rd

=end