library(MASS)
#num_states <- 4

error_bound <- 0.001

state_log_lik <- function(dat, mu, cov_mat, cov_mat_inv,cov_mat_det, N, num_var){
  #dat is a matrix of dimension num_var X N
  #mu is a vector with num_var elements
  #cov_mat is the covanriance matrix with dim num_var X num_var, its determinant is cov_mat_det,
  #its inverse is cov_mat_inv
  # returns a vector 1 x N of log-likelihoods
  diff <- dat - matrix(rep(mu, N), nrow = num_var, ncol = N)
  return (diag(-0.5 * t(diff) %*% cov_mat_inv %*% diff) - 0.5 * num_var * log(2 * pi) - 0.5 *log(abs(cov_mat_det)))
}

EM <- function (test_data, num_states){
  #format of test_data: dim X T X N matrix, N = number of days in training data,
  # T = number of steps in a day, dim = number of parameters to consider for each state
  #format of prob matrix for each time: m x T x N matrix, m is the number of possible states
  #Prob. matrix initialized so that each state has equal prob.
  N = dim(test_data)[3]
  Tnum = dim(test_data)[2]
  num_var = dim(test_data)[1]
  P = array(rep(1 / num_states, num_states * N * Tnum), c(num_states, Tnum, N))

  #transition prob. matrix is m x m matrix, initialized such that each state goes to itself with prob ~1.
  #   A = matrix(0, num_states, num_states)
  #   for (i in 1: num_states){
  #     for (j in 1 : num_states){
  #         if (i == j) A[i,j] = 0.9
  #         else A[i,j] = (1 - 0.9)/(num_states - 1)
  #     }
  #   }
  A = matrix(1/num_states, nrow = num_states, ncol = num_states)

  #mu is initialized to the mid points of test_data, all var initialized to std of test_data
  #covariance initialized to 0
  qt0 <- seq(0, 1, length.out = num_states + 1)
  qt <- (qt0[1:num_states] + qt0[2:(num_states+1)]) / 2

  mu <- matrix(0, nrow = num_var, ncol = num_states)
  cov_mat <- array(0, c(num_var, num_var, num_states))
  for (i in 1:num_var){
    mu[i,] = quantile(as.vector(test_data[i,,]), qt)
    cov_mat[i,i,] = rep(var(as.vector(test_data[i,,])), num_states)
  }

  max_iter_num = 500
  for (i in 1:max_iter_num){
    old_mu <- mu
    old_cov_mat <- cov_mat
    old_A <- A

    log_alpha = calc_forward(num_states, N, Tnum, num_var, A, mu, cov_mat, test_data)
    log_beta = calc_backward(num_states, N, Tnum, num_var, A, mu, cov_mat, test_data)
    P <- calc_P(num_states, N, Tnum, log_alpha, log_beta)
    mu = update_mu(num_states, num_var, P, test_data)
    cov_mat = update_cov_mat(num_states, num_var, N, Tnum, P, test_data, mu)
    A = update_A(num_states, N, Tnum, num_var, P, log_alpha, log_beta, A, mu, cov_mat, test_data)

    diff_mu <- sum(abs(old_mu - mu)) / sum(abs(old_mu))
    diff_cov_mat <- sum(abs(old_cov_mat - cov_mat)) / sum(abs(old_cov_mat))
    diff_A <- sum(abs(old_A - A)) / sum(abs(old_A))
    if (diff_mu < error_bound && diff_cov_mat < error_bound && diff_A < error_bound){
      break
    }
  }
  data_A <- data.frame(A)
  data_mu <- data.frame(mu)
  data_cov_mat <- data.frame(cov_mat)

  params <- list(data_A, data_mu, data_cov_mat)
  names(params) <- c('A', 'mu', 'covariance matrix')

  return(params)
}

calc_forward <- function(num_states, N, Tnum, num_var, A, mu, cov_mat, test_data){

  log_alpha <- array(0, c(num_states, Tnum, N))
  #get the initial prob
  for (s in 1:num_states){
    cov_mat_inv <- solve(cov_mat[,,s])
    cov_mat_det <- det(cov_mat[,,s])
    log_alpha[s, 1, ] = state_log_lik(test_data[,1,], mu[,s], cov_mat[,,s], cov_mat_inv,cov_mat_det, N, num_var)
  }

  if (Tnum > 1){
    for (t in 2:Tnum){
      temp1 <- matrix(0, nrow = num_states, ncol = N)
      for (s in 1:num_states){
        cov_mat_inv <- solve(cov_mat[,,s])
        cov_mat_det <- det(cov_mat[,,s])
        temp1[s,] <- state_log_lik(test_data[,t,], mu[,s], cov_mat[,,s], cov_mat_inv,cov_mat_det, N, num_var)
      }
      log_diff <- exp(log_alpha[, t-1, ] - matrix(apply(matrix(log_alpha[, t-1, ], nrow = num_states, ncol = N), 2, max), nrow = num_states, ncol = N, byrow = TRUE))
      log_alpha[, t, ] <- t(log(t(log_diff) %*% A)) +
        matrix(apply(matrix(log_alpha[, t-1, ], nrow = num_states, ncol = N), 2, max), nrow = num_states, ncol = N, byrow = TRUE) +
        temp1

    }
  }

  return (log_alpha)
}

calc_backward <- function(num_states, N, Tnum, num_var, A, mu, cov_mat, test_data){
  log_beta <- array(0, c(num_states, Tnum, N))
  log_beta[, Tnum, ] <- 0
  for (t in (Tnum - 1) : 1){
    log_diff <- exp(log_beta[, t+1, ] - matrix(apply(log_beta[, t+1, ], 2, max), nrow = num_states, ncol = N, byrow = TRUE))
    temp1 <- matrix(0, nrow = num_states, ncol = N)
    for (s in 1:num_states){
      cov_mat_inv <- solve(cov_mat[,,s])
      cov_mat_det <- det(cov_mat[,,s])
      temp1[s,] <- state_log_lik(test_data[,t+1,], mu[,s], cov_mat[,,s], cov_mat_inv,cov_mat_det, N, num_var)
    }

    log_beta[, t, ] <- log(A %*% exp(log_diff * temp1)) +
      matrix(apply(log_beta[, t+1, ], 2, max), nrow = num_states, ncol = N, byrow = TRUE)
  }
  return (log_beta[,1:Tnum,])
}

calc_P <- function(num_states, N, Tnum, log_alpha, log_beta){
  temp <- log_alpha + log_beta
  temp2 <- array(0, c(num_states, Tnum, N))
  P <- array(0, c(num_states, Tnum, N))
  for (t in 1: Tnum){
    temp2[,t,] = exp(temp[,t,] - matrix(apply(temp[,t,], 2, max), nrow = num_states, ncol = N, byrow = TRUE))
    P[,t,] <- temp2[,t,] / matrix(colSums(temp2[,t,]), nrow = num_states,ncol = N, byrow = TRUE)
  }
  return (P)
}

update_A <- function(num_states, N, Tnum, num_var, P, log_alpha, log_beta, A, mu, cov_mat, test_data){
  conditional_tp <- array(0, c(N, (Tnum - 1), num_states, num_states))
  for (n in 1:N){
    for(t in 1:(Tnum - 1)){
      temp_a <- matrix(rep(log_alpha[, t, n], num_states), ncol = num_states, nrow = num_states)
      temp_log_lik <- matrix(0, nrow = num_states, ncol = 1)
      for (s in 1:num_states){
        cov_mat_inv <- solve(cov_mat[,,s])
        cov_mat_det <- det(cov_mat[,,s])
        temp_log_lik[s,] <- state_log_lik(test_data[,t+1,n], mu[,s], cov_mat[,,s], cov_mat_inv,cov_mat_det, 1, num_var)
      }
      temp_b <- log_beta[,t+1,n] + temp_log_lik
      temp_bb <- matrix(t(temp_b), nrow = num_states, ncol = num_states, byrow = TRUE)
      temp_c <- temp_a + temp_bb + log(A)
      temp_c = exp(temp_c - temp_c[which.max(temp_c)])
      conditional_tp[n,t,,] <- temp_c / sum(temp_c)
    }
  }
  new_A <- matrix(0, nrow = num_states, ncol = num_states)
  for (i in 1:num_states){
    for (j in 1:num_states){
      new_A[i,j] <- sum(conditional_tp[,,i,j])/sum(conditional_tp[,,i,])
    }
  }
  return (new_A)
}

update_mu <- function(num_states, num_var, P, test_data){
  new_mu <- matrix(0, nrow = num_var, ncol = num_states)
  for (v in 1: num_var){
    for (i in 1: num_states){
      new_mu[v,i] <- sum(P[i,,] * test_data[v,,]) / sum(P[i,,])
    }
  }
  return(new_mu)
}

update_cov_mat <- function(num_states, num_var, N, Tnum, P, test_data, mu){
  new_cov_mat <- array(0, c(num_var, num_var, num_states))
  for(s in 1: num_states){
    for (i in 1:num_var){
      for (j in 1:num_var){
        new_cov_mat[i,j,s] <- sum((test_data[i,,] - mu[i,s]) * (test_data[j,,] - mu[j,s]) * P[s,,]) * N * Tnum / ((Tnum * N - 1) * sum(P[s,,]))
      }
    }
  }
  return(new_cov_mat)
}


# Sub-pixel confusion–uncertainty matrix
# Implementation following https://doi.org/10.1016/j.rse.2007.07.017

# Comparator function
Comparator = function(s_k, r_l, A=MIN, D=PROD_D, scale=FALSE)
{
    # If we have a data.frame, convert into a matrix
    if (is.data.frame(s_k))
        s_k = as.matrix(s_k)
    if (is.data.frame(r_l))
        r_l = as.matrix(r_l)

    stopifnot(is.numeric(s_k))
    stopifnot(is.numeric(r_l))
    stopifnot(!is.null(A) || !is.null(D))

    if (!is.null(A))
        A = match.fun(A)
    if (!is.null(D))
        D = match.fun(D)

    # If s_k and r_l are matrices/data.frames, we sum them all
    # If not, make it a matrix anyway to make the same code handle it
    if (is.vector(s_k))
        s_k = t(as.matrix(s_k))
    if (is.vector(r_l))
        r_l = t(as.matrix(r_l))

    stopifnot(all(dim(s_k) == dim(r_l)))

    CumulativeResult = matrix(0, ncol(s_k), ncol(r_l))
    for (n in 1:nrow(s_k))
    {
        s_nk = s_k[n,]
        r_nl = r_l[n,]

        K = length(s_nk)

        # Overestimation and underestimation
        sp_nk = s_nk - r_nl; sp_nk[sp_nk<0] = 0
        rp_nl = r_nl - s_nk; rp_nl[rp_nl<0] = 0

        Result = matrix(NA, K, K) #p_nkl
        for (k in 1:K)
        {
            for (l in 1:K)
            {
                if (k == l) { # Diagonal
                    if (!is.null(A))
                        Result[k,l] = A(s_nk[k], r_nl[l])
                    else
                        Result[k,l] = D(sp_nk, rp_nl, k, l)
                } else {
                    if (!is.null(D))
                        Result[k,l] = D(sp_nk, rp_nl, k, l)
                    else
                        Result[k,l] = A(s_nk[k], r_nl[l])
                }
            }
        }
        CumulativeResult = CumulativeResult + Result
    }
    rownames(CumulativeResult) = colnames(s_k)
    colnames(CumulativeResult) = colnames(r_l)
    if (scale)
        CumulativeResult = CumulativeResult / nrow(s_k)

    return(CumulativeResult)
}

# Agreement operators
# MIN is literally the function min
# PROD is literally the function "*"

SI = function(s_nk, r_nl)
{
    1 - abs(s_nk - r_nl)/(s_nk + r_nl)
}

LEAST = function(s_nk, r_nl)
{
    max(s_nk + r_nl - 1, 0)
}

# l is "should be attributed to...", k is "but was guessed as"
PROD_D = function(sp_nk, rp_nl, k, l)
{
    sp_nk[k] * rp_nl[l] / sum(rp_nl)
}

MIN_D = function(sp_nk, rp_nl, k, l)
{
    min(sp_nk[k], rp_nl[l])
}

LEAST_D = function(sp_nk, rp_nl, k, l)
{
    max(sp_nk[k]+rp_nl[l]-sum(rp_nl), 0)
}

# Function for calculating a confusion matrix
SCM = function(predicted, observed, agreement=min, disagreement="SCM", scale=FALSE, accuracy=FALSE, totals=FALSE, plot=FALSE)
{
    # Aliases; TODO: remove/rename
    s_nk = predicted
    r_nl = observed

    # Sanity checks: the input must be 0-1 range and add up to 100%
    stopifnot(all(r_nl >= 0-options()$ts.eps))
    stopifnot(all(r_nl <= 1+options()$ts.eps))
    stopifnot(all(s_nk >= 0-options()$ts.eps))
    stopifnot(all(s_nk <= 1+options()$ts.eps))
    if (is.vector(s_nk))
        stopifnot(all(round(sum(s_nk), 6) == 1))
    else
        stopifnot(all(round(rowSums(s_nk), 6) == 1))
    if (is.vector(r_nl))
        stopifnot(all(round(sum(r_nl), 6) == 1))
    else
        stopifnot(all(round(rowSums(r_nl), 6) == 1))

    if (is.character(disagreement) && disagreement == "SCM") # Mean of MIN_D and LEAST_D + confusion
    {
        p_min = Comparator(s_nk, r_nl, A=agreement, D=MIN_D, scale=scale)
        p_least = Comparator(s_nk, r_nl, A=agreement, D=LEAST_D, scale=scale)
        P_kl = (p_min + p_least)/2
        U_kl = (p_min - p_least)/2
    } else {
        P_kl = Comparator(s_nk, r_nl, A=agreement, D=disagreement, scale=scale)
        U_kl = matrix(0, nrow=nrow(P_kl), ncol=ncol(P_kl), dimnames=dimnames(P_kl)) # No uncertainties for other types; U is a zero matrix
    }

    scm = structure(list(P=P_kl, U=U_kl, agreement=as.character(substitute(agreement)), disagreement=as.character(substitute(disagreement))), class="scm")

    if (plot)
        plot(scm)

    if (accuracy || totals)
        scm = accuracy.scm(scm)

    if (totals)
        scm = totals.scm(scm)

    return(scm)
}

plot.scm = function(scm, ...)
{
    if (requireNamespace("lattice", quietly = TRUE) && requireNamespace("gridExtra", quietly = TRUE))
    {
        P_plot = lattice::levelplot(t(scm$P), xlab="Observed", ylab="Predicted", sub="Centre values", ...)
        U_plot = lattice::levelplot(t(scm$U), xlab="Observed", ylab="Predicted", sub="Uncertainty", ...)
        gridExtra::grid.arrange(P_plot, U_plot, ncol=2)
    } else {
        stop("Unable to plot due to missing lattice or gridExtra packages")
    }
}

# Function for adding "total" columns/rows to the SCM
totals.scm = function(scm)
{
    stopifnot(class(scm) == "scm")

    if (is.null(scm[["P_row_totals"]]))
    {
        warning("Passed an SCM without calculating accuracy metrics. This will be done for you.")
        scm = accuracy.scm(scm)
    }

    P_kp = rowSums(scm$P)
    P_pl = colSums(scm$P)
    P_pp = sum(scm$P)

    U_kp = rowSums(scm$U)
    U_pl = colSums(scm$U)
    U_pp = sum(scm$U)

    # Add total rows/columns: with uncertainty
    P_FullMatrix = cbind(scm$P, total=scm$P_row_totals)
    P_FullMatrix = rbind(P_FullMatrix, total=c(scm$P_col_totals, scm$P_total))

    U_FullMatrix = cbind(scm$U, total=scm$U_row_totals)
    U_FullMatrix = rbind(U_FullMatrix, total=c(scm$U_col_totals, scm$U_total))

    # Add user/producer accuracy
    P_FullMatrix = cbind(P_FullMatrix, user.acc=c(scm$P_user_accuracy, NA))
    P_FullMatrix = rbind(P_FullMatrix, prod.acc=c(scm$P_producer_accuracy, NA, scm$P_overall_accuracy))

    U_FullMatrix = cbind(U_FullMatrix, user.acc=c(scm$U_user_accuracy, NA))
    U_FullMatrix = rbind(U_FullMatrix, prod.acc=c(scm$U_producer_accuracy, NA, scm$U_overall_accuracy))

    scm$P = P_FullMatrix
    scm$U = U_FullMatrix
    return(scm)
}

# Add accuracy metrics to an scm object
accuracy.scm = function(scm)
{
    stopifnot(class(scm) == "scm")

    P_kp = rowSums(scm$P)
    P_pl = colSums(scm$P)
    P_pp = sum(scm$P)

    U_kp = rowSums(scm$U)
    U_pl = colSums(scm$U)
    U_pp = sum(scm$U)

    P_OA_s = (P_pp*sum(diag(scm$P))) / (P_pp^2 - U_pp^2)
    U_OA_s = (U_pp*sum(diag(scm$P))) / (P_pp^2 - U_pp^2)

    P_UA_s = (diag(scm$P)*P_kp) / (P_kp^2 - U_kp^2) # Problems when we have uncertainty == prediction, division by 0
    U_UA_s = (diag(scm$P)*U_kp) / (P_kp^2 - U_kp^2) # In which case the diagonals are 0, so it's 0 by definition
    P_UA_s[is.nan(P_UA_s)] = 0
    U_UA_s[is.nan(U_UA_s)] = 0

    P_PA_s = (diag(scm$P)*P_pl) / (P_pl^2 - U_pl^2)
    U_PA_s = (diag(scm$P)*U_pl) / (P_pl^2 - U_pl^2)
    P_PA_s[is.nan(P_PA_s)] = 0
    U_PA_s[is.nan(U_PA_s)] = 0

    # Kappa coefficient
    # Expected proportion of agreement (i.e. when using the monkey method)
    P_e = sum(((P_pp^2 + U_pp^2)*(P_pl*P_kp + U_pl*U_kp) - 2 * P_pp*U_pp*(U_pl*P_kp + P_pl*U_kp)) / (P_pp^2-U_pp^2)^2)
    U_e = sum((2 * P_pp*U_pp*(P_pl*P_kp + U_pl*U_kp) - (P_pp^2 + U_pp^2)*(U_pl*P_kp + P_pl*U_kp)) / (P_pp^2-U_pp^2)^2)

    Sign = (1-P_OA_s-U_OA_s)*(1-P_e-U_e)
    P_Kappa_s = ((P_OA_s-P_e) * (1-P_e) - (sign(Sign)*U_OA_s+U_e) * U_e)/((1-P_e)^2-U_e^2)
    U_Kappa_s = ((sign(Sign)*(1-P_OA_s)*U_e + (1-P_e)*U_OA_s)/((1-P_e)^2-U_e^2))

    scm[["P_row_totals"]] = P_kp
    scm[["P_col_totals"]] = P_pl
    scm[["P_total"]] = P_pp
    scm[["U_row_totals"]] = U_kp
    scm[["U_col_totals"]] = U_pl
    scm[["U_total"]] = U_pp
    scm[["P_overall_accuracy"]] = P_OA_s
    scm[["U_overall_accuracy"]] = U_OA_s
    scm[["P_user_accuracy"]] = P_UA_s
    scm[["U_user_accuracy"]] = U_UA_s
    scm[["P_producer_accuracy"]] = P_PA_s
    scm[["U_producer_accuracy"]] = U_PA_s
    scm[["P_user_accuracy"]] = P_UA_s
    scm[["P_kappa"]] = P_Kappa_s
    scm[["U_kappa"]] = U_Kappa_s

    return(scm)
}

# Examples moved to:
#' @example subpixel-confusion-matrix-examples.r
# Note that they will need to be split per function


#' punto medio
#' Calcula el punto que se encuentra entre 2 puntos
#'
#' @param a vector
#' @param b vector
#'
#' @return vector
#'
#' @export
#'
#' @examples
#' puntoMedio(c(1,1),c(2,2))
puntoMedio <- function(a,b){
  x <- vector("numeric",2)
  x[1] <- (a[1]+b[1])/2
  x[2] <- (a[2]+b[2])/2
  x
}


multiplyUncertainties <- function(opinions,l){
  pd = NULL
  for(j in setdiff(opinions$Label,l)){
    if(is.null(pd))
      pd = opinions[opinions$Label==j,]$Uncertainty
    else
      pd = pd * opinions[opinions$Label==j,]$Uncertainty
  }
  return(pd)
}

multiSourceWeightedFusion <- function(opinions){
  if(nrow(opinions)==1)
    return(data.frame(Label="fused",Belief = opinions$Belief, Disbelief = opinions$Disbelief, Uncertainty=opinions$Uncertainty, Apriori = opinions$Apriori))
  sm <- 0
  for(l in opinions$Label){
    el = opinions[opinions$Label==l,]$Belief * (1-opinions[opinions$Label==l,]$Uncertainty)
    pd = multiplyUncertainties(opinions,l)
    sm = sm + (el * pd)
  }
  dsm <- 0

  for(l in opinions$Label){
    pd = multiplyUncertainties(opinions,l)
    dsm = dsm + pd
  }
  pd = NULL
  for(l in opinions$Label){
    if(is.null(pd))
      pd = opinions[opinions$Label==l,]$Uncertainty
    else
      pd = pd * opinions[opinions$Label==l,]$Uncertainty
  }

  apriori = NULL
  nominator = 0
  for(l in opinions$Label){
    nominator = nominator + (opinions[opinions$Label==l,]$Apriori * (1-opinions[opinions$Label==l,]$Uncertainty))
  }
  denominator = nrow(opinions) - sum(opinions$Uncertainty )
  apriori = nominator / denominator

  belief = (sm / (dsm - nrow(opinions) * pd))

  uncertainty = ((nrow(opinions)-sum(opinions$Uncertainty))*pd)/(dsm- nrow(opinions) * pd)
  disbelief= 1-(belief + uncertainty)
  return(data.frame(Label="fused",Belief = belief, Disbelief = disbelief, Uncertainty=uncertainty, Apriori = apriori))
}

#Subtraction - compute the difference between two subjective opinions

subtract <- function(opinionA, opinionB){
  aprioriA = 0.5
  aprioriB = 0.5
  if(!is.null(opinionA$Apriori))
    aprioriA = opinionA$Apriori
  if(!is.null(opinionB$Apriori))
    aprioriB = opinionB$Apriori
  belief = max((opinionA$Belief - opinionB$Belief),0)
  disbelief = (aprioriA * (opinionA$Disbelief + opinionB$Belief) - aprioriB * (1 + opinionB$Belief - opinionA$Belief - opinionB$Uncertainty))/(aprioriA-aprioriB)
  uncertainty = ((aprioriA*opinionA$Uncertainty)-(aprioriB*opinionB$Uncertainty))/(aprioriA-aprioriB)
  apriori = aprioriA - aprioriB
  return(data.frame(Belief = belief, Disbelief = disbelief, Uncertainty = uncertainty, Apriori = apriori))
}

#Compute the projected probability from a Subjective Opinion.

projectedProbability <- function(apriori, belief, uncertainty){
  probability  = belief + (apriori * uncertainty)
  return(probability)
}

#Computes the beta-distribution that corresponds to a given subjective opinion [@josang2016subjective,@duan2016representation].

computeBeta <- function(opinion){
  if(opinion$Disbelief == 0){
    opinion$Uncertainty = opinion$Uncertainty - 0.00001
    opinion$Disbelief = 1 - (opinion$Uncertainty + opinion$Belief)
  }
  r = ((opinion$Belief * 2) / opinion$Uncertainty) + 1
  s = ((opinion$Disbelief * 2)  / opinion$Uncertainty) + 1

  distribution = dbeta(x=seq(0,1,length=100),shape1=r, shape2=s)
  bDist <- data.frame(x=seq(0,1,length=100),y=distribution)
  bDist$Label=rep(opinion$Label,100)
  return(bDist)
}

#Plot the barycentric triangle for a given opinion [@josang2016subjective].

plotTriangle <- function(opinion, withLines){
  triangle <- data.frame(x=c(0,1,0.5,0),y=c(0,0,0.5,0))
  coords <- data.frame(x=c(0,0.25,1,0.75,0,0.5,0.5),y=c(0,0.25,0,0.25,0,0,0.5))
  apriori <- data.frame(x=c(0.5,opinion$Apriori),y=c(0.5,0))

  aX = 0
  aY = 0
  bX = 1 * opinion$Belief
  bY = 0
  cX = 0.5 * opinion$Uncertainty
  cY = cX
  pX = aX + bX + cX
  pY = aY + bY + cY

  proj <- projectedProbability(opinion$Apriori, opinion$Belief, opinion$Uncertainty)

  projected <- data.frame(x=c(pX,proj),y=c(pY,0))

  p <- ggplot(triangle,aes(x=x,y=y, size=1))+geom_path(aes(size=0.5))
  if(withLines){
    p <- p + geom_path(data=coords,size=0.25,linetype = "dashed") + geom_path(data=apriori,size=0.25,colour='red') + #geom_text(aes(size=0.8),x=opinion$Apriori,y=-.015,label="Apriori", colour='red') +  #geom_text(aes(size=0.8), x=opinion$Apriori,y=0.015,label=round(opinion$Apriori,2),colour='red') +
      geom_path(data=projected,size=0.25, colour="blue")
    #+ geom_text(aes(size=0.8),x=proj,y=-.015,label="Projected", colour='blue') + geom_text(aes(size=0.8), x=proj,y=0.015,label=round(proj,2),colour='blue')
  }
  p <- p + geom_point(aes(size=1, x=pX,y=pY), shape=8,colour="blue")+ geom_text(aes(size=0.8),label=opinion$Label,x=0,y=0.5,colour="blue", fontface = "bold",hjust=0,vjust=1) + theme(legend.position = "none",axis.title.x=element_blank(),axis.title.y=element_blank(),axis.text.y=element_blank(),axis.text.x=element_blank()) + geom_text(aes(size=0.8),label="Disbelief",x=0,y=-0.015, fontface = "bold",hjust=0) + geom_text(aes(size=0.8),label="Belief",x=1,y=-0.015, fontface = "bold",hjust=1) + geom_text(aes(size=0.8),label="Uncertainty",x=0.5,y=0.502, fontface = "bold",hjust=0) #+ geom_text(aes(size=0.5),label=paste0("(",round(opinion$Belief,2),",",round(opinion$Disbelief,2),",",round(opinion$Uncertainty,2),")"),x=pX,y=pY+0.02, colour='blue')
  return(p)
}

#Plot a time-line - changes in opinion as a series of arrows in a barycentric triangle.

getCoord <- function(opinion){
  aX = 0
  aY = 0
  bX = 1 * opinion$Belief
  bY = 0
  cX = 0.5 * opinion$Uncertainty
  cY = cX
  pX = aX + bX + cX
  pY = aY + bY + cY
  return(data.frame(x=pX, y=pY))
}

plotTimeTriangle <- function(opinions){
  triangle <- data.frame(x=c(0,1,0.5,0),y=c(0,0,0.5,0))
  coords <- data.frame(x=c(0,0.25,1,0.75,0,0.5,0.5),y=c(0,0.25,0,0.25,0,0,0.5))

  xv <- c()
  yv <- c()

  for(i in 1:nrow(opinions)){
    o <- getCoord(opinions[i,])
    xv <- c(xv,o$x)
    yv <- c(yv,o$y)
  }

  route <- data.frame(x=xv,y=yv)

  colours <- seq(1,nrow(opinions))

  p <- ggplot(triangle,aes(x=x,y=y, size=1))+geom_path(aes(size=0.5)) + geom_path(data=coords,size=0.25,linetype = "dashed")  + theme(legend.position = "none",axis.title.x=element_blank(),axis.title.y=element_blank(),axis.text.y=element_blank(),axis.text.x=element_blank()) + geom_text(aes(size=0.8),label="Disbelief",x=0,y=-0.015, fontface = "bold",hjust=0) + geom_text(aes(size=0.8),label="Belief",x=1,y=-0.015, fontface = "bold",hjust=1) + geom_text(aes(size=0.8),label="Uncertainty",x=0.5,y=0.502, fontface = "bold",hjust=0) + geom_path(data=route,aes(colour=colours), size=0.25)
  return(p)
}

computeTriangles <- function(beliefs){
  triangles <- list()
  local({
    for(i in 1:(nrow(beliefs))){
      triangles[[i]] <<- plotTriangle(beliefs[i,], FALSE)
    }
    return(triangles)
  })
}

computeDistributions <- function(beliefs){
  betas <- data.frame()
  local({
    for(i in 1:(nrow(beliefs))){
      if(nrow(betas)==0){
        betas <- computeBeta(beliefs[i,])
      }
      else{
        betas <- rbind(betas,computeBeta(beliefs[i,]))
      }
    }
    return(betas)
  })
}

#For a given set of beliefs, plot a row of barycentric triangles, coupled with a set of distributions
#If rows is 1, everything should be laid out horizontally. If it's 2, everything should be vertical.

soPlot <- function(beliefs, rows, min, max){
  betas <- computeDistributions(beliefs)
  triangles <- computeTriangles(beliefs)

  axisSequence <- round(seq(min,max,length.out=7),2)

  separateDistributions <- ggplot(betas) + geom_line(aes(x=x,y=y,colour=Label))+ ylab("Probability Mass")+
    theme(axis.text.x = element_text(size=8,angle = 315),axis.title.x = element_text(size=8),
          axis.text.y = element_text(size=8),axis.title.y = element_text(size=8),legend.text = element_text(size=8),legend.title = element_blank())+
    xlab("Effect size") +  scale_x_continuous(breaks=seq(0,1,length.out=7),labels=c(paste("\u2264",min),axisSequence[2:6],paste("\u2265",max)))

  separateTriangles <- ggarrange(plotlist=triangles, ncol=length(triangles))
  final <- NULL
  if(rows == 1){
    final <- ggarrange(separateTriangles,separateDistributions,ncol=2, nrow=1, widths=c(2,4))
  }
  else{
    final <- ggarrange(separateDistributions,separateTriangles,ncol=1, nrow=2,heights=c(2,1))
  }
  return(final)
}

#Assumes a dataframe with a "Group" column, separating out the different groups of beliefs
groupedBeliefPlot <- function(beliefs, min, max){
  local({
    lowerPlots = list()
    fused = data.frame()
    lengths <- c()
    labels <- c()
    counter <- 1
    if(is.null(beliefs$Group)){
      beliefs$Group <- rep("All", nrow(beliefs))
    }
    for(g in unique(beliefs$Group)){
      subset <- beliefs[beliefs$Group==g,]
      lowerPlots[[counter]] <- soPlot(subset,2,min,max)+theme(panel.border = element_rect(colour = "black", fill=NA, size=1))
      f <- multiSourceWeightedFusion(subset)
      lengths <- c(lengths,nrow(subset))
      labels <- c(labels,g)
      f$Label <- paste("Fused\n",g)
      if(nrow(fused)==0){
        fused <- f
      }
      else{
        fused <- rbind(fused,f)
      }
      counter = counter + 1
    }
    print(fused)
    upperPlot <- soPlot(fused,1,min,max) + border()
    lowerPlot <- ggarrange(plotlist=lowerPlots,nrow=1,ncol=length(lowerPlots),widths=lengths,labels=labels)
    finalPlot <- ggarrange(upperPlot,lowerPlot,ncol=1,nrow=2, heights=c(1,2))
    return(finalPlot)
  })
}


# take input from the user
num = as.integer(7)
factorial = 1
# check is the number is negative, positive or zero
if(num < 0) {
print("Sorry, factorial does not exist for negative numbers")
} else if(num == 0) {
print("The factorial of 0 is 1")
} else {
for(i in 1:num) {
factorial = factorial * i
}
print(paste("The factorial of", num ,"is",factorial))
}


ybar = 105.75          # sample mean
mu0 = 75           # hypothesized value
sigma = 82.429     # population standard deviation
n = 20              # sample size
# test statistic
t = abs((ybar- mu0)/(sigma/sqrt(n)))
 print(t)

# formula based on level of significance
 m=33
 B=1000
p_value= m/B
 print(p_value)
alpha=0.05
# our p value< alpha , therfore
print("we conclude that there is sufficient evidence that the mean cotanine level exceeds 75 in the population of children under CPS supervision")


#Series temporais e analises preditivas - Fernando Amaral

#dados
print(sunspots)
#classe
class(sunspots)
#informacoes
help(sunspots)
#maior e menor valor
max(sunspots)
min(sunspots)
#media, mediana, sumario, comprimento
mean(sunspots)
median(sunspots)
summary(sunspots)
length(sunspots)

#inicio, fim
start(sunspots)
end(sunspots)

#frequencia
frequency(sunspots)

#ciclo
cycle(AirPassengers)

#sub conjunto
sun2 = window(sunspots,1749,c(1763,12))

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/3.1.Estatisticas media, mediana, maximo, minimo, sumarios.r


qmix <- function (p, params, pro = c(.5, .5), expand=.1, dist = "binorm") {
  nr <- 1000000
  XX <- rbinom(n=nr, size=1, prob=pro)
  if(dist == "binorm") {
    sd.s <- 1
    x = rnorm(n=nr, params[1], sd.s)*XX + rnorm(n=nr, params[2], sd.s)*(1-XX)
  } else if(dist == "bibeta") {
    x = rbeta(n=nr, params[[1]][1], params[[1]][2])*XX + rbeta(n=nr, params[[2]][1], params[[2]][2])*(1-XX)
  }
  span <- seq(min(x) - expand * diff(range(x)), max(x) + expand * diff(range(x)), length = nr)
  cdf <- vector(mode = "numeric", length = nr)
  if(dist == "binorm") {
    sd.s <- 1
    cdf = pnorm(span, params[1], sd.s)*pro[1] + pnorm(span, params[2], sd.s)*(1-pro[1])
  } else if(dist == "bibeta") {
    cdf = pbeta(span, params[[1]][1], params[[1]][2])*pro[1] + pbeta(span, params[[2]][1], params[[2]][2])*(1-pro[1])
  }
  quants <- stats::spline(cdf, span, method = "hyman", xout = p)$y
  quants[which(p < 0L | p > 1L)] <- NaN
  quants[which(p == 0L)] <- -Inf
  quants[which(p == 1L)] <- Inf
  if (any(is.nan(quants)))
    warning("Some quantile values could not be calculated. If all 'p's are within [0,1], try reducing the value of 'expand' and try again.")
  return(as.vector(quants))
}

# # # Simulate Case 1 scores from paper
# r.vec <- c(2^seq(1, 13), 3^seq(1, 8), 10, 105, 300, 1500, 15000)
# r.vec <- r.vec[order(r.vec)]/150000
#
# m <- 150000
# pi.0.true <- 1/501
# set.seed(111)
# X <- rbinom(n=m, size=1, prob=pi.0.true)
# mu.mix <- c(1.4, 0)
# sd.mix <- 1
# S <- rnorm(n=m, mu.mix[1], sd.mix)*X + rnorm(n=m, mu.mix[2], sd.mix)*(1-X)
#
# metric = "k"; type = "band"; method = "sup-t"; correction = "JZ";
# conf.level = .95; boot.rep = 100; myseed = 111; mc.rep = 100000;
# simreps = 10; pi.0.true = 1/501;dist = "binorm"; plus2 = T
#
# params <- c(1.4, 0)

# params= params.ls[[i]]; dist = dist.v[i]; pi.0.true = 1/501;
# myseed=567; method = "JZ"; plus2 = correction.v[j];
# simreps = simreps; m = 150000; B = 1000; mc.rep = mc.rep;
# r.vec = r.vec; metric = "k"

# Compare to simulated interval
cov.prob.tab = function(params, pi.0.true, myseed=567, dist = "binorm",
                    simreps = 100, r.vec = c(.01, .1, .5), metric = "k",
                    m = 100, plus = F, method = "JZ", B = 100, mc.rep = 1000000){
  r <- (1:m)/m
  idx <- which(r %in% r.vec)
  r <- r[idx]
  set.seed(myseed)

  if(dist == "binorm" | dist == "bibeta") {
    suppressWarnings(c <- qmix(1-r, params, c(pi.0.true, 1-pi.0.true), expand=.1, dist = dist))
  } else if(dist == "unif") {
    p <- 1-r
    # mixture weights
    w1 <- (1-pi.0.true)
    w2 <- (pi.0.true)
    # knots
    t1 <- w1*(.25/.75)
    t2 <- w1 + w2*((.75-.25)/.75)
    # p <- runif(1000000)
    c <- vector(length = length(p))
    for(j in seq_along(p)) {
      if(p[j] <= 0) {
        c[j] <- 0
      } else if(p[j] > 0 & p[j] <= t1) {
        c[j] <- .75*p[j]/w1
      } else if(p[j] > t1 & p[j] <= t2) {
        c[j] <- .75*p[j] + w2*.25
      } else if(p[j] > t2 & p[j] <= 1) {
        c[j] <- .75*(p[j]-w1)/w2 + .25
      } else if(p[j] == 1) {
          c[j] <- 1L
      }
    }
  }

  if (dist == "binorm") {
    sd.s = 1
    F.plus <- pnorm(c, mean = params[1], sd.s)
  } else if (dist == "bibeta") {
    F.plus <- pbeta(c, params[[1]][1], params[[1]][2])
  } else if (dist == "unif") {
    F.plus <- punif(c, params[[1]][1], params[[1]][2])
  }

  k.true <- vector(length = length(F.plus))
  pi.true <- vector(length = length(F.plus))

  # if k or pi is above 1, then they should actually be slightly below 1
  k.true <- ifelse(k.true > 1, 1 - 1E-10, k.true)
  pi.true <- ifelse(pi.true > 1, 1 - 1E-10, pi.true)

  for (i in 1:length(k.true)) {
    # Account for the case when you have non-overlapping uniforms and you
    # know that pi should be 1
    if (dist == "unif" & c[i] > params[[2]][2]) {
      pi.true[i] <- 1L
      k.true[i] <- r[i]/pi.0.true
    } else {
      k.true[i] <- 1 - F.plus[i]
      pi.true[i] <- k.true[i]*pi.0.true/r[i]
    }
  }
  eff_seeds <- sample(1:2^15, simreps)
  results <- foreach(z = 1:simreps, .export=c("mvrnorm", "PerfCurveBands", "EstLambda")) %dopar% {
    set.seed(eff_seeds[z])
    X = rbinom(n=m, size=1, prob=pi.0.true)
    if(dist == "binorm") {
      S = rnorm(n=m, params[1], sd.s)*X + rnorm(n=m, params[2], sd.s)*(1-X)
    } else if(dist == "bibeta") {
      S = rbeta(n=m, params[[1]][1], params[[1]][2])*X + rbeta(n=m, params[[2]][1], params[[2]][2])*(1-X)
    } else if(dist == "unif") {
      S = runif(n=m, params[[1]][1], params[[1]][2])*X + runif(n=m, params[[2]][1], params[[2]][2])*(1-X)
    }

    PerfCurveBands(S, X, r, metric = "rec", type = ifelse(method == "JZ", "pointwise", "band"), method = method, plus = plus, conf.level = .95,
                   mc.rep = mc.rep, myseed = eff_seeds[z])
  }

  covout <- matrix(NA, nrow=1, ncol=simreps)
  widthout <- matrix(NA, nrow=length(r), ncol=simreps)
  interval.ls <- list()
  params <- matrix(NA, nrow=length(r), ncol=simreps)
  rec.mat <- matrix(NA, nrow=length(r), ncol=simreps)

  for (i in 1:simreps) {
    ind <- vector(length = length(k.true))
    for(j in seq_along(k.true)) {
      ind[j] <- (round(results[[i]]$CI[j, 1], 10) <= k.true[j]) & (round(results[[i]]$CI[j, 2], 10) >= k.true[j])
    }
    covout[i] <- all(ind)
    widthout[, i] <- results[[i]]$CI[, 2] - results[[i]]$CI[, 1]
    interval.ls[[i]] <- results[[i]]$CI
    params[, i] <- k.true
    rec.mat[, i] <- results[[i]]$rec
  }

  return(list(r = r, covout = covout, widthout = widthout, interval.ls = interval.ls, params = params, rec.mat = rec.mat))
}


# -----------------------
# App Title: t-test
# Author: Jimmy Wong
# -----------------------

if (!require("ggplot2"))
  install.packages("ggplot2")

if (!require("shinyBS"))
  install.packages("shinyBS")

shinyUI(fluidPage(
  tags$head(tags$link(rel = "icon", type = "image/x-icon",
                      href = "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

  navbarPage(title="t-test",

             tabPanel("Information of t-test",

                      column(1),
                      column(5,br(),br(),br(),
                        withMathJax(p("This application allows users to perform either a", code("one-sample t-test",style="color:navy"),
                        "or a", code("two-sample t-test",style="color:navy"),".  A one-sample t-test focuses on comparing the average of a
                        single quantitative variable to a hypothesized value, while a two-sample t-test
                        focuses on comparing the difference in averages of a quantitative variable between two groups to a hypothesized value.  In
                        both scenarios, the purpose of the hypothesis test is to determine how likely are the observed results or any more extreme results,
                        under the assumption that the null hypothesis is true. This is known as a", strong("p-value.")),
                        p("In most data analyses, the population mean(s) along with the population standard deviation(s) are unknown.
                          Therefore, the", strong("t-test"), "is used instead of a z-test.  The", strong("t-statistic"), "can be calculated to determine the p-value,
by comparing it to the", strong("t-distribution"), "with a", strong("specified degrees of freedom."), "In this scenario, the sample standard deviation(s) replaces the population standard deviation(s) to yield
                          the", strong("standard error"), "(an estimate of the true standard deviation) of the", strong("sampling distribution.")))),

                      column(5,br(),br(),br(),
                        wellPanel(
                        code("One-sample t-test:",style="color:navy"),
                        p(HTML("

 the parameter of interest is the population mean, μ
"),p(),
                        p("t-statistic = \\(\\frac{\\bar x -\\mu_0}{s_{x}/\\sqrt{n}}\\)"), HTML("
")),br(),
                        code("Two-sample t-test:",style="color:navy"),
                        p(HTML("

 the parameter of interest is the difference between the two population means, μ1-μ2
"),p(),
                        p("t-statistic = \\(\\frac{(\\bar x_1 - \\bar x_2) -(\\mu_1-\\mu_2)}{\\sqrt{\\frac{s_{1}^2}{n_1} + \\frac{s_{2}^2}{n_2}}}\\)"), HTML("
")))),

                      column(1)),

             tabPanel("Data Exploration",
                      tabsetPanel(
                        tabPanel("Sample Data",
                                 fluidRow(
                                   column(3,
                                          wellPanel(
                                            selectInput("sampdat", "Choose a data set:", choices=list("One-sample"=1,"Two-sample"=2), selected=1),
                                            bsPopover(id="sampdat", title="Data set information", content="The one-sample data set is collected from the Old Faithful geyser in Yellowstone National Park, Wyoming, USA.  The variable of interest is the duration of each eruption in minutes.  The two-sample data set is associated with the 1974 Motor Trend US magazine.  The explanatory variable is the type of transmission and the response variable is horsepower.",
                                                      trigger="hover",placement="right"),
                                            checkboxInput("usedata", "Use sample data", TRUE),
                                            bsTooltip("usedata","Remember to uncheck this when not using sample data!","right"),
                                            br(),br(),br(),
                                            div("Shiny app by",
                                                a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                            div("Base R code by",
                                                a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                            div("Shiny source files:",
                                                a(href="https://gist.github.com/calpolystat/48dc47f3ff436aba4b19",
                                                  target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),
                                            div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                                                  "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt"))),
                                   column(9,
                                          conditionalPanel(
                                            condition="input.usedata",
                                            dataTableOutput("data.tab1"))))),

                        tabPanel("Upload Data",
                                 fluidRow(
                                   column(3,
                                          wellPanel(
                                            fileInput("file", "",accept=c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
                                            bsPopover("file","Note", "Remember to select the correct data format after uploading file!  Hover over the Select data format panel for more information.",
                                                      trigger="hover",placement="right"),
                                            tags$hr(),
                                            radioButtons("datformat", strong("Select data format:"), choices=c("1-sample"=1,Stacked=2,Unstacked=3), selected=1),
                                            bsPopover("datformat","Data format", "Select Stacked for 2-sample with explanatory and response variables in two columns.  Select Unstacked with explanatory variable as column names and response variable in two columns",
                                                      trigger="hover",placement="right"),
                                            tags$hr(),
                                            strong("Customize file format:"),
                                            checkboxInput("header", "Header", TRUE),
                                            radioButtons("sep", "Separator:", choices=c(Comma=",",Semicolon=";",Tab="\t"), selected=","),
                                            radioButtons("quote", "Quote", choices=c(None="","Double Quote"='"',"Single Quote"="'"),selected=""),
                                            br(),br(),br(),
                                            div("Shiny app by",
                                                a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                            div("Base R code by",
                                                a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                            div("Shiny source files:",
                                                a(href="https://gist.github.com/calpolystat/48dc47f3ff436aba4b19",
                                                  target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),
                                            div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                                                  "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt"))),
                                   column(9,
                                          conditionalPanel(
                                            condition="input.file!='NULL'",
                                            dataTableOutput("data.tab"))))),

                        tabPanel("Visualize Data",
                                 fluidRow(
                                   column(6,
                                          plotOutput("datagraph")),
                                   column(6,br(),br(),
                                          checkboxInput("displaystats", "Summary statistics", FALSE),
                                          tableOutput("summarystats")))))),

             tabPanel("Hypothesis Test",
                      fluidRow(
                        column(3,
                               wellPanel(
                                 conditionalPanel(
                                   condition="input.datformat==1 && input.sampdat==1",
                                   h4("Hypotheses:"),
                                   uiOutput("hypo1"),
                                   tags$hr(),
                                   numericInput("null1", label="Hypothesized value:", value=0),
                                   selectInput("alt1", "Select a direction for Ha:", choices=list("two-sided","less than","greater than"),selected="two-sided")),
                                 conditionalPanel(
                                   condition="input.datformat!=1 || input.sampdat==2",
                                   h4("Hypotheses:"),
                                   uiOutput("hypo2"),
                                   tags$hr(),
                                   numericInput("null2", label="Hypothesized value:", value=0),
                                   selectInput("alt2", label="Select a direction for Ha:", choices=list("two-sided","less than","greater than"),selected="two-sided")),
                                 sliderInput("alpha", label=HTML("Significance level α:"), value=.05, max=1, min=0, step=.01),
                                 tags$hr(),
                                 actionButton("teststart", strong("Perform t-test")),
                                 bsPopover("teststart","Note","Remember to check the normality condition before performing t-test.",trigger="hover",placement="right"),
                                 br(),br(),br(),
                                 div("Shiny app by",
                                     a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                 div("Base R code by",
                                     a(href="http://www.linkedin.com/in/jimmywong46/",target="_blank","Jimmy Wong"),align="right", style = "font-size: 8pt"),
                                 div("Shiny source files:",
                                     a(href="https://gist.github.com/calpolystat/48dc47f3ff436aba4b19",
                                       target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),
                                 div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                                       "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt"))),

                        column(9,
                               br(),br(),
                               conditionalPanel(
                                 condition="input.teststart>0",
                                 column(7,
                                        plotOutput("tdist"),
                                        bsPopover("tdist","p-value","The p-value is the shaded region. A large p-value indicates to fail to reject Ho and no evidence for Ha.  A small p-value indicates to reject the Ho and evidence for Ha.",
                                                  trigger="hover",placement="left"),br()),
                                 column(5,br(),
                                        strong("Test output:"),
                                        tableOutput("test"),br(),
                                        checkboxInput("showpoint","Point estimate(s):",FALSE),
                                        uiOutput("est"),
                                        checkboxInput("ci","Confidence interval:", FALSE),
                                        tableOutput("citab"),
                                        bsPopover("citab","Confidence interval sample interpretation","We are 95% confident that the true parameter is anywhere between the lower bound to the upper bound.",
                                                  trigger="hover",placement="bottom")))))),

             tabPanel("Normality Condition",
                      column(1),
                      column(4,br(),
                             p(strong("Normality test:"),"The sampling distribution of the sample means or differences in the sample means is 1) Normal if the population(s) is Normal or 2) approximately Normal if the
                               sample size(s) is large enough (at least 30).  In situations with small sample size(s), the approach to access
                               whether the sample data could have came from a Normal distribution is either through a Q-Q plot or a Normality test."),
                             actionButton("normstart", label=strong("Perform normality test")),br(),br(),
                             conditionalPanel(
                               condition="input.normstart>0",
                               wellPanel(
                               strong("Ho: data is from a Normal distribution"),br(),
                               strong("Ha: data is not from a Normal distribution"),br(),br(),
                               em("Shapiro-Wilk Normality Test:"),
                               tableOutput("sw"),
                               bsPopover("sw","Normality test","In a normality test, a large p-value does not provide evidence that the sample data is not from a Normal distribution.",
                                         trigger="hover",placement="bottom")))),
                      column(6,
                             conditionalPanel(
                               condition="input.normstart>0",br(),br(),
                               plotOutput("qqplot"),
                               bsPopover("qqplot","Q-Q plot","In a Q-Q plot, points that resemble a diagonal line with no curvature implies that the sample data could have came from a Normal distribution.",
                                         trigger="hover",placement="left"))),
                      column(1))

)))


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

par2015 = c(55,0.3,15,0.2027349)
quantile = seq(0,230,1)
mu2015 = par2015[1]
sigma = par2015[3]
epsilon = par2015[4]
mu1965 = mu2015 - 50*par2015[2]
t2015 = (1+epsilon*((quantile-mu2015)/sigma))^(-1/epsilon)
pdf2015 = (t2015^(epsilon+1))*exp(-t2015)/sigma
t1965 = (1+epsilon*((quantile-mu1965)/sigma))^(-1/epsilon)
pdf1965 = (t1965^(epsilon+1))*exp(-t1965)/sigma
pdf = data.frame(pdf1965,pdf2015)
pdf(file = "Results/distplot.pdf")
matplot(quantile,pdf,type='l',lwd=2,main= 'Nonstationary GEV distribution', xlab = NA, ylab = 'Density', cex.main = 1.33, cex.lab = 1.33, cex.axis = 1.33)
legend('topright', legend = c('Year 1965', 'Year 2015'),lty = c(1,2), col = c(1,2), cex = 1.33)
dev.off()


library("shiny")
library("ggplot2")
persons <- seq(-3, 3, by = .1)
b <- -3:3
rasch <- function(person, item) {
  exp(person - item)/(1 + exp(person - item))
}
data_r <- matrix(nrow = length(persons), ncol = length(b))
for(i in 1:length(b)){
  data_r[,i] <- rasch(persons, b[i])
}
data_r <- as.data.frame(data_r)
colnames(data_r) <- b

shinyServer(
  function(input, output){
    output$one <- renderPlot({
      qplot(y = data_r[,input$idiff], x = persons, geom = "line") + ylab("Probability of Getting Item Correct") + xlab("Person Ability") + coord_cartesian(ylim = c(0, 1), xlim = c(-3, 3)) + geom_vline(xintercept = as.numeric(input$idiff), colour = "red", linetype = "longdash")
    })
  }
)


> solve24()
8 * (4 - 2 + 1)
> solve24(c(6,7,9,5))
6 + (7 - 5) * 9
> solve24(c(8,8,8,8))
[1] NA
> solve24(goal=49) #different goal value
8 * (4 + 2) + 1
> solve24(goal=52) #no solution
[1] NA
> solve24(ops=c('-', '/')) #restricted set of operators
(8 - 2)/(1/4)


evec = matrix(
  c(			 -0.5,  0.6906786606674509,   0.15153543380548623, 0.5,
			  0.5, -0.15153543380548576,  0.6906786606674498,  0.5,
			 -0.5, -0.6906786606674498,  -0.15153543380548617, 0.5,
			  0.5,  0.15153543380548554, -0.6906786606674503,  0.5),
  nrow=4,ncol=4,byrow=T)

ievc = matrix(
  c(			 -0.5,  0.5, -0.5,  0.5,
			  0.6906786606674505, -0.15153543380548617, -0.6906786606674507,   0.15153543380548645,
			  0.15153543380548568, 0.6906786606674509,  -0.15153543380548584, -0.6906786606674509,
			  0.5,  0.5,  0.5,  0.5),
  nrow=4,ncol=4,byrow=T)

make.expDt = function(t) {
  matrix(
  c(exp(-2*t),                   0,                   0,  0,
            0,  exp(-1*t)*cos(1*t),  exp(-1*t)*sin(1*t),  0,
            0, -exp(-1*t)*sin(1*t),  exp(-1*t)*cos(1*t),  0,
            0,                   0,                   0,  1),
  nrow=4,ncol=4,byrow=T)
}

q.circulant = matrix(
  c(-1,  1,  0,  0,
     0, -1,  1,  0,
     0,  0, -1,  1,
     1,  0,  0, -1),
  nrow=4,ncol=4,byrow=T)

test.1 = evec %*% make.expDt(0.1) %*% ievc # Schur decomposition (method used in BEAGLE)

Evec = eigen(q.circulant)$vectors # Complex eigendecomposition
Ievc = solve(Evec)
make2.expDt = function(t) {
  diag(exp(eigen(q.circulant)$values * t))
}

test.2 = Evec %*% make2.expDt(0.1) %*% Ievc  # Should (and does) equal test.1

out.1 = t(make.expDt(0.1)) %*% t(evec) # Should be intermediate result

out.2 = t(ievc) %*% out.1 # Should (and does) equal t(test.1)


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);

  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b5;
real b6;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

	  mu[n] <- mu[n-1]*exp(u*(b6^2/((mu[n-1]-b5)^2+b6^2))+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.07,0.1);
b5 ~ normal(3000,100000);
b6 ~ normal(3000,100000);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covdi19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.07,b5=3000, b6=3000, sig2=0.01,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

##k=1

pdf(paste("M12_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b5","b6"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M12_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M12_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M12_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M12_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M12_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M12_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2)

dev.off()

#####################################################################################################################################################
######################################      forecast          ###################################

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

P=20
Mu=matrix(,nrow=90000,ncol=P)
X=matrix(,nrow=90000,ncol=P)

lambda_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,1]
u_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,2]
b5_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,3]
b6_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,4]
sig2_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,5]

set.seed(999)

for (r in 1:90000){

Mu[r,1]=y[length(y)]
for (s in 1:(P-1) ){

e=rnorm(1,0,sig2_p[r])

Mu[r,s+1]=Mu[r,s]*exp(u_p[r]*(b6_p[r]^2/((Mu[r,s]-b5_p[r])^2+b6_p[r]^2))+e)

}}

sigob=1000
for (r in 1:90000){
for (s in 1:P ){

X[r,s]=rnorm(1,Mu[r,s], sigob)

}}

Xm=apply(X,2,mean)

X5 <- apply( X , 2 , quantile, probs=0.05 )

X9 <- apply( X , 2 , quantile, probs=0.95 )

Zm=c(y,Xm)
Z5=c(y,X5)
Z9=c(y,X9)

##### read forecast
setwd("./covid19modelrisk/data/covid19_infected")

##  FT=read.csv("COVID-19_confirmed__Germany_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Italy_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Japan_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Spain_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__United Kingdom_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__US_FT.csv")[,2]
FT=read.csv("COVID-19_confirmed_Australia_FT.csv")[,2]

Z_FT=c(y,FT)

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

k=7

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

m=length(Zm)

setwd("./covid19modelrisk/output/forecast")
pdf(paste("M12_",abn[k],"_F.pdf",sep=""), width = 16.5, height = 8.50)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m],Z_FT)),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M12 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
polygon(c(rev(newx), newx), c(rev(Z9[1:m]), Z5[1:m]), col = "grey80", border = NA)

par(new=TRUE)
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m],Z_FT)),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M12 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
lines(newx,Z9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Z5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(Z_FT[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m],Z_FT)),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M12 model for ",name[k],sep=""),pch=19,xaxt = 'n')
legend("topleft", legend=c("Observed data", "Forecasted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)

# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/27","Mar/17","May/05","Jun/25","Aug/06"))   ### GM
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/13","May/09","Jun/29","Aug/06"))   ### IT
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### JP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Feb/01","Mar/20","May/10","Jun/30","Aug/06"))   ### SP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/21","May/09","Jun/29","Aug/06"))   ### UK
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### US
axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/26","Mar/16","May/04","Jun/24","Aug/06"))   ### AU

dev.off()

M=length(FT)

e=FT-Xm
mae=mean(abs(e))
rmse=sqrt(mean(e^2))
############ PR
 p=e/FT
# p1=e1/mean(mo1)
mape=mean(abs(p))
########## QR
md=sum(abs(FT[2:M]-FT[1:(M-1)]))/(M-1)
qj=e/md
mase=mean(abs(qj))

list(mae,rmse,mape,mase)

######   RMSE results        ###############################################################

### Germany
> list(mae,rmse,mape,mase)
[[1]]
[1] 509.454

[[2]]
[1] 621.1698

[[3]]
[1] 0.002233969

[[4]]
[1] 0.4242845

## Italy
> list(mae,rmse,mape,mase)
[[1]]
[1] 9250.797

[[2]]
[1] 10628.97

[[3]]
[1] 0.03603019

[[4]]
[1] 13.74884

## Japan
> list(mae,rmse,mape,mase)
[[1]]
[1] 10380.91

[[2]]
[1] 11466.17

[[3]]
[1] 0.1780064

[[4]]
[1] 10.37272

## Spain
> list(mae,rmse,mape,mase)
[[1]]
[1] 38964.49

[[2]]
[1] 47789.93

[[3]]
[1] 0.1027847

[[4]]
[1] 7.018166

## UK
> list(mae,rmse,mape,mase)
[[1]]
[1] 4733.137

[[2]]
[1] 5370.857

[[3]]
[1] 0.01470337

[[4]]
[1] 4.532514

## US
> list(mae,rmse,mape,mase)
[[1]]
[1] 290955.2

[[2]]
[1] 318595.1

[[3]]
[1] 0.0527834

[[4]]
[1] 6.268938

## AU
> list(mae,rmse,mape,mase)
[[1]]
[1] 2835.194

[[2]]
[1] 3092.975

[[3]]
[1] 0.1182316

[[4]]
[1] 11.6498

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

mean(y)
median(y)

n=length(y)

#################
### remove one b6

u=0.07
b5=3000
b6=3000

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=x[i]*exp(u*(b6^2/((b5-x[i])^2+b6^2)))

}
x=round(x)
x
plot(x,col="red",ylim=c(min(x),max(x)))

plot(y,ylim=c(min(y,x),max(y,x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y,x),max(y,x)))


simpson1<-function(data,type="complement"){
  simpson.diversity<-numeric(ncol(data))
  for(j in 1:ncol(data)){
    soma<-sum(data[,j])
    prop<-data[,j]/soma
    prop2<-prop^2
    D<-sum(prop2)
    if(type=="inverse") (simp<-1/D)
    if(type=="complement") (simp<-1-D)
    simpson.diversity[j]<-simp
  }
  plot.number<-1:ncol(data)
  return(rbind(plot.number,simpson.diversity))
}

###this is a simple example of function in R

####

simpson2<-function(data,type="complement"){
  simpson.diversity<-numeric(ncol(data))
  for(j in 1:ncol(data)){
    soma<-sum(data[,j])
    prop<-data[,j]*(data[,j]-1)
    prop2<-sum(prop)
    D<-prop2/(soma*(soma-1))
    if(type=="inverse") (simp<-1/D)
    if(type=="complement") (simp<-1-D)
    simpson.diversity[j]<-simp
  }
  plot.number<-1:ncol(data)
  return(rbind(plot.number,simpson.diversity))
}


# via Houstonwp
q <- c(0.001,0.002,0.003,0.003,0.004,0.004,0.005,0.007,0.009,0.011)
w <- c(0.05,0.07,0.08,0.10,0.14,0.20,0.20,0.20,0.10,0.04)
P <- 100
S <- 25000
r <- 0.02

base_r_npv <- function(q,w,P,S,r) {
  inforce <- c(1,head(cumprod(1-q-w), -1))
  ncf <- inforce * P - inforce * q * S
  d <- (1/(1+r)) ^ seq_along(ncf)
  sum(ncf * d)
}

base_r_npv(q,w,P,S,r)
#> [1] 50.32483
microbenchmark::microbenchmark(base_r_npv(q,w,P,S,r))

npv_loop <- function(q,w,P,S,r) {
        inforce = 1.0
        result = 0.0
        v = 1 / (1 + r)
        v_t = v
    for (t in 1:length(q)) {
        result <- result + inforce * (P-S*q[t-1]) * v_t
        inforce <- inforce * (1 - (q[t-1] + w[t-1]))
        v_t = v_t * v
    }
    result
}
microbenchmark::microbenchmark(npv_loop(q,w,P,S,r))