# Assignment 4 - PCA

This document does a PCA (Principal component analysis) on the Heart Failure Prediction dataset

# Let us load libraries and data

```{r results='hide', message=FALSE, warning=FALSE}
# clear environment
rm(list = ls())

# defining libraries

library(ggplot2)
library(dplyr)
library(PerformanceAnalytics)
library(data.table)
library(sqldf)
library(nortest)
library(tidyverse)
library(MASS)
library(rpart)
library(class)
library(ISLR)
library(scales)
library(ClustOfVar)
library(GGally)
library(reticulate)
library(ggthemes)
library(RColorBrewer)
library(gridExtra)
library(kableExtra)
library(Hmisc)
library(corrplot)
library(energy)
library(nnet)
library(Hotelling)
library(car)
library(devtools)
library(ggbiplot)
library(factoextra)
library(rgl)
library(FactoMineR)

```

```{r}
# reading data
data <- read.csv('/Users/mac/Downloads/heart_failure_clinical_records_dataset.csv')
str(data)
```

\
We check to see if we have categorical variables \
However we see all our variables are numeric \
Even the categorical ones are binary and already have 1/0 as values \

# Let's quickly revise our correlation plot
```{r}
# Correlation plot
M<-cor(data)
head(round(M,2))
corrplot(M, method="color")
```
\
Since most of the correlations are low (Pearson's r < 0.25) ),
we don't particularly see a need for PCA \
                                        We use PCA to reduce the dimensionality of the dataset as
                                        PCA accomplishes this by capturing the variance in the dataset.
                                        It get the components such that the are in the direction of the highest variance. \
                                        We also saw from EDA in last exercise that our VIF was quite low
                                        indicating absence of multi-collinearity. \
                                        So, reducing dimensionality may lead to loss of variance for our project.
                                        However, for exposition, we will try PCA and analyse results \

                                        # Let us perform PCA on our dataset

                                        ```{r}
                                        pca <- prcomp(data[,1:12],scale=TRUE)
                                        summary(pca)
                                        ```
                                        \
                                        Here, we see that we need 8 components to get cumulative proportion of
                                        variance equivalent to 0.78. \
                                        For convention, we would consider as many components as required
                                        to get in the range of 0.75-0.95 \
                                        Let us then consider 10 components (Cum prop. ~90%) instead of 12 reducing our dimensions
                                        from 12 to 10 \

                                        # Let's plot the Scree diagrams
                                        ```{r}
                                        plot(pca, type="lines", main = "Scree diagram")
                                        fviz_eig(pca)
                                        ```

                                        # We can also see a cumulative plot
                                        ```{r}
                                        std_dev <- pca$sdev
                                        pr_var <- std_dev^2
                                        prop_varex <- pr_var/sum(pr_var)
                                        plot(cumsum(prop_varex), xlab = "Principal Component",
                                             ylab = "Cumulative Proportion of Variance Explained",
                                             type = "b")
                                        ```
                                        \
                                        Both of the above plots (variance and cum. variance) show  that we need atleast 10 components for 90% variance
                                        and since we don't see a taper down in graph of cum. variance or a steep decline in scree diagram, we can note that this isnt ideal. \

# Plotting PCA

```{r}
# bi-plot which will use PC1 and PC2
ggbiplot(pca)
```
\
Here, we can tell that ejection_fraction, diabetes, platelets all
contribute to PC1 with higher values in these features moving the samples
to the right \
Similarly we can tell that age, serum_creatinine contributes more towards PC2 \
In PC1, we can see sex, smoking towards negative side of PC1 \
In PC2, we can time towards negative side of PC2 \

```{r}
# We can also tell which patients are similar to one other
# by adding rownames
# Let's use each row as a patient identifier, then,

                                        ggbiplot(pca, labels=rownames(data))
                                        ```
                                        \
                                        This tells us that patient IDs-16,32,56 are similar as they cluster together
                                        This would ideally be helpful with more meaningful identifiers \

                                        # Let's also look at contribution by variables
                                        ```{r}
                                        fviz_pca_var(pca,
                                                     col.var = "contrib", # Color by contributions to the PC
                                                     gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
                                                     repel = TRUE     # Avoid text overlapping
                                        )
                                        ```
                                        \
                                        We see that age, sex, smoking contribute more to PC1 and PC2
                                        so we can try and visualize this in more detail by bi-plots with these groups. \

                                        # Let's plot the bi-plot with gender
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        A clear indicator that males indicated by 1 have more breadth
                                        in PC1 as opposed to Females indicated by 0 which are more
                                        narrow along with that we see +ve indication for females
                                        along PC1 and negative for males \

                                        # Let's plot the bi-plot with smoking
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$smoking)
                                        ```
                                        \
                                        A clear indicator that smokers indicated by 1 have less breadth
                                        in PC1 as opposed to non-smokers indicated by 0 which are more
                                        wider and to the positive side along with that we see +ve
                                        indication for non-smokers for PC1 and negative for smokers \

                                        # We will create an age range variable and do the same as well
                                        ```{r}
                                        data$age_tr[data$age < 50 & data$age >= 40]="40-50"
                                        data$age_tr[data$age < 60 & data$age >= 50]="50-60"
                                        data$age_tr[data$age < 70 & data$age >= 60]="60-70"
                                        data$age_tr[data$age < 80 & data$age >= 70]="70-80"
                                        data$age_tr[data$age < 90 & data$age >= 80]="80-90"
                                        data$age_tr[data$age < 100 & data$age >= 90]="90-100"
                                        ```

                                        # And then plot the same result with
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, labels=rownames(data), groups=data$age_tr)
                                        ```
                                        \
                                        Not much indication here other than higher age groups
                                        tend to be more spread out in PC2 \

                                        # We can also look at PC3 and PC4
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE,choices=c(3,4), labels=rownames(data))
                                        ```
                                        \
                                        serum_creatinine, diabetes more towards PC3 \
                                        Platelets, creatinine_phosphokinase, and high bp more towards PC4 \

                                        # By gender
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE,choices=c(3,4), labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        We note even spread in PC3, PC4 for gender \

                                        # By smoking
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE,choices=c(3,4), labels=rownames(data), groups=data$sex)
                                        ```
                                        \
                                        We note even spread in PC3, PC4 for smoking \

                                        # By age groups
                                        ```{r}
                                        ggbiplot(pca,ellipse=TRUE, var.axes=FALSE, choices=c(3,4), labels=rownames(data), groups=data$age_tr)

                                        ```
                                        \
                                        We note age group 40-50 with most spread in PC4 \

                                        \newpage

                                        # Let us do a visualizations to see how much of each variable is present in each component
                                        ### We use factoextra and factominer for this ###

                                        ```{r}
                                        pca_viz <- PCA(data[,1:12], graph = FALSE,ncp =12)
                                        var <- get_pca_var(pca_viz)

                                        # We can now use the contrib function to get contribution of each variable
                                        # to the PCs
                                        var$contrib

                                        ```

                                        # Let's plot this -
                                        ```{r}
                                        corrplot(var$contrib, is.corr=FALSE, method="pie")
                                        ```

                                        ### Key Observations ###

                                        1. Sex and Smoking are dominant in PC1 \
                                        2. Age and time are dominant in PC2 \
                                        3. Serum_Sodium is dominant in PC3 \
                                        4. Platelets and creatinine_phosphokinase are dominant in PC4 \
                                        5. creatinine_phosphokinase is dominant in PC5 \
                                        6. Platelets and ejection_fraction are dominant in PC6 \
                                        7. Anaemia is dominant in PC7 \
                                        8. Diabetes is dominant in PC8 \
                                        9. Age is dominant in PC9 \
                                        10. Serum_Sodium, Serum_creatinine is dominant in PC10 \
                                        11. Time, anaemia is dominant in PC11 \
                                        12. Sex and smoking are dominant in PC12 \

                                        ### Note ###
                                        \
                                        We don't see a good combination of variables in any component and
PC12 is redundant as PC1 and gives same information \

# Let us now combine the pca with dataset
```{r}
data_pca <- cbind(data,pca$x)
```
\
The new dataset now has 26 variables with PC1-PC12 added \

# Now Let us check the means by death events
```{r}
meansPC <- aggregate(data_pca[,15:26],by=list(DEATH_EVENT=data$DEATH_EVENT),mean)
meansPC
```
# Let us check stddev by death events
```{r}
sdsPC <- aggregate(data_pca[,15:26],by=list(DEATH_EVENT=data$DEATH_EVENT),sd)
sdsPC
```
\
We notice a clear difference in means (note the different signs) however not much in std. deviation \
This may indicate that PCs aren't doing a good job in
                                        segregating the death events from non-death events \

                                        # Let us perform t-tests
                                        ```{r}
                                        t.test(PC1~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC2~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC3~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC4~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC5~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC6~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC7~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC8~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC9~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC10~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC11~data_pca$DEATH_EVENT,data=data_pca)
                                        t.test(PC12~data_pca$DEATH_EVENT,data=data_pca)
                                        ```
                                        \
                                        We notice signifcant results in PC2, PC3, PC4, and PC11 at alpha=0.5 \

                                        # Let us also perform F-ratio tests
                                        ```{r}
                                        var.test(PC1~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC2~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC3~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC4~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC5~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC6~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC7~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC8~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC9~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC10~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC11~data_pca$DEATH_EVENT,data=data_pca)
                                        var.test(PC12~data_pca$DEATH_EVENT,data=data_pca)
                                        ```
                                        \
                                        We notice signifcant results in PC2, PC4, PC5, PC6, PC8, PC9, and PC10 \

                                        # Plotting the scores for the first and second components
                                        ```{r}
                                        plot(data_pca$PC1, data_pca$PC2,
                                             pch=ifelse(data_pca$DEATH_EVENT == "1",1,16),xlab="PC1", ylab="PC2",col="dark blue",
                                             main="Heart disease patient against values for PC1 & PC2")
                                        abline(h=0)
                                        abline(v=0)
                                        legend("bottomleft", legend=c("Death_Event=1","Death_Event=0") ,col="dark blue", pch=c(1,16))

                                        ```
                                        \
                                        We do note that survivors seem to be closer to average than those who died \
                                        Also recall the definition of PC1 and PC2 - \
                                        PC1 was sex, smoking dominant \
                                        PC2 was age, time dominant \
                                        This also tells us that non-survivors were on the extremes of ages and follow-up
                                        period\

                                        # PCA - prediction

                                        # We can try a prediction with pca by splitting our data into train and test and finding the PCs on train and validating on test data

                                        ```{r}
                                        data <- read.csv('/Users/mac/Downloads/heart_failure_clinical_records_dataset.csv')
                                        # Split data into 2 parts for pca training (75%) and prediction (25%)
                                        set.seed(1)
                                        samp <- sample(nrow(data), nrow(data)*0.75)
                                        data.train <- data[samp,]
                                        data.valid <- data[-samp,]
                                        dim(data.train)
                                        dim(data.valid)
                                        ```
                                        \
                                        We split our data into 224 rows, and 75 rows into sets of train and valid.\

                                        # conduct PCA on training dataset
                                        ```{r}
                                        pca <- prcomp(data.train[,1:12], retx=TRUE, center=TRUE, scale=TRUE)
                                        expl.var <- round(pca$sdev^2/sum(pca$sdev^2)*100) # percent explained variance
                                        expl.var
                                        ```
                                        \
                                        The explained variance in components is same as before \

                                        # prediction of PCs for validation dataset
                                        ```{r}
                                        pred <- predict(pca, newdata=data.valid[,1:12])
                                        head(pred,5)
                                        ```
                                        \
                                        We print the first 5 rows to see the predicted values in our validation set. \

                                        # Let us take first 10 components that explain 90% variance in data and do the same

                                        ```{r}
                                        train.data <- data.frame(DEATH_EVENT=data.train$DEATH_EVENT, pca$x)
                                        train.data <- train.data[,1:11]

                                        test.data <- predict(pca, newdata = data.valid)
                                        test.data <- as.data.frame(test.data)
                                        test.data <- test.data[,1:10]
                                        head(test.data,5)
                                        ```
                                        \
                                        This finally gives us the test data with PC1-10 \
                                        Our final conclusion however remains the same that PCA isn't ideal
for modeling purpose in our project \

### This concludes our analysis of PCA in our dataset


##Umbrales=group
##Imagen=raster
##Banda=number 1
##Mascara= output raster
##ImagenUmbral= output raster
##showplots
rango <- range(na.omit(c(Imagen[[Banda]][]))) #Encontrar el rango de los datos
#levels <- 100 #Definir el número de niveles posibles
breaks <- seq(rango[1], rango[2], length.out = 100 + 1) #Número de "breaks" basado en niveles y rangos
h <- hist.default(na.omit(c(Imagen[[Banda]][])), breaks = breaks, plot = FALSE) #Crear histograma de datos
counts <- as.double(h$counts) #Observaciones por nivel
mids <- as.double(h$mids) #Media por break
len <- length(counts) #Número total de observaciones
w1 <- cumsum(counts) #Suma acumulada
w2 <- w1[len] + counts - w1 #
cm <- counts * mids
m1 <- cumsum(cm)
m2 <- m1[len] + cm - m1
var <- w1 * w2 * (m2/w2 - m1/w1)^2
maxi <- which(var == max(var, na.rm = TRUE))
otsu <- (mids[maxi[1]] + mids[maxi[length(maxi)]])/2

print(otsu)

hist(as.matrix(na.omit(Imagen[[Banda]])),
     xlab=names(Imagen[[Banda]]),
     ylab="Frecuencia",
     col="red",
main=paste("Distribución ",
           names(Imagen[[Banda]]),
           sep=""))
abline(v=otsu,
       col="black",
       lwd=1, lty=2)
box()
grid(lwd=1)

Mascara <- Imagen[[Banda]] >= otsu
ImagenUmbral <- Mascara * Imagen[[Banda]]


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


csv_data<-read.csv("regrex1.csv")
print(csv_data)

png('R_Scatter.png')
plot(x = csv_data$x,
     y = csv_data$y,
     xlab = "x",
     ylab = "y",
     col = "black",
     pch = 4,
     main = "regrex1")
dev.off()
print('Regrex Data')

png('R_linReg.png')
plot(x = csv_data$x,
     y = csv_data$y,
     xlab = "x",
     ylab = "y",
     col = "black",
     pch = 4,
     main = "Regrex Data")

abline(lm(csv_data$y ~ csv_data$x,
          data = csv_data), col = "black")
print('Printing Scatterplot')

print('Done')


#' 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
}


library(mvtnorm)
library(devtools)
library(xtable)
set.seed(12345)
source('../../R/synthdid.R')
source('sim_function.r')
data_lwage <- t(as.matrix(read.csv('data/lwage_cps.csv',header = FALSE)))
# Parameters

rank <- 2

# Outcome model

data_mat <- data_lwage
n <- dim(data_mat)[1]
T <- dim(data_mat)[2]

tw_st_0 <- outer(rowMeans(data_mat),rep(1,T)) +
		outer(rep(1,n),colMeans(data_mat)) - mean(data_mat)

data_mat_dm <- data_mat - tw_st_0
svd_data_mat <- svd(data_mat_dm)
factor_unit <- as.matrix(svd_data_mat$u[,1:rank]*sqrt(n))
factor_time <- as.matrix(svd_data_mat$v[,1:rank]*sqrt(T))
magnitude <- svd_data_mat$d[1:rank]/sqrt(n*T)
L_mat <- factor_unit%*%diag(magnitude, nrow = rank, ncol = rank)%*%t(factor_time)

error_mat <- data_mat_dm - L_mat
tw_st_error <- outer(rowMeans(error_mat),rep(1,T)) +
		outer(rep(1,n),colMeans(error_mat)) - mean(error_mat)
error_mat_dm <-  error_mat-tw_st_error
sigma_mat <- t(error_mat_dm)%*%error_mat_dm/n

tw_st_full <- tw_st_error +tw_st_0

noise_level <- sqrt(norm(sigma_mat, type = '2'))
signal_low_rank <- norm(L_mat, type = 'F')/sqrt(n*T)
signal_fe <- norm(tw_st_full, type = 'F')/sqrt(n*T)
lr_signal_to_noise <- signal_low_rank/noise_level

# Assignment

W_i <- factor_unit[,1]>=quantile(factor_unit[,1],0.7)
n_0 <- n - sum(W_i)
T_0 <- floor(0.7*T)
index_order <- order(W_i)

# Simulation

B <- 100
show.results = function(results) {
    print(results$aggregates)
    synthdid_plot(results$estimates[[1]], facet.vertical=FALSE)
}

# 1. Original design
scale_1 <- 1
scale_2 <- 1
sim_results_orig <- sim_function(L_mat,tw_st_full,index_order,sigma_mat,n_0,T_0,B,scale_1,scale_2)
show.results(sim_results_orig)

# 2. Scaled design

scale_1 <- signal_fe
scale_2 <- lr_signal_to_noise*signal_fe
sim_results_sc <- sim_function(L_mat,tw_st_full,index_order,sigma_mat,n_0,T_0,B,scale_1,scale_2)
show.results(sim_results_sc)
show.results(sim_results_sc) + coord_cartesian(ylim=c(6,6.5))

# 3. Shuffled design

scale_1 <- 1
scale_2 <- 1
sh_index <- index_order[sample(1:n,n)]
sim_results_sh <- sim_function(L_mat,tw_st_full,sh_index,sigma_mat,n_0,T_0,B,scale_1,scale_2)
show.results(sim_results_sh)

# 4. Mixture of the two

scale_1 <- 1
scale_2 <- 1
W_base <- factor_unit[,1]>=quantile(factor_unit[,1],0.5)
W_i_mixed <- rbinom(length(W_base),1,as.numeric(W_base)/2) == 1
index_order_mixed <- order(W_i_mixed)
n_0_new <- n - sum(W_i_mixed)
sim_results_mixed <- sim_function(L_mat,tw_st_full,index_order_mixed,sigma_mat,n_0_new,T_0,B,scale_1,scale_2)
show.results(sim_results_mixed)

# 5. No low rank

scale_1 <- 0
scale_2 <- 1
sim_results_tw <- sim_function(L_mat,tw_st_full,index_order_mixed,sigma_mat,n_0_new,T_0,B,scale_1,scale_2)
show.results(sim_results_tw)

# Tex files

xtable(sim_results_orig$aggregates, type = "latex")
xtable(sim_results_sc$aggregates, type = "latex")
xtable(sim_results_sh$aggregates, type = "latex")
xtable(sim_results_mixed$aggregates, type = "latex")
xtable(sim_results_tw$aggregates, type = "latex")


#' Calculation Standard Errors of Mean
#'
#' @param x numeric vector.
#' @param na.rm logical.
#' Specify whether to calculate without missing values.
#'
#' @importFrom stats na.omit
#' @importFrom stats var
#' @export
#' @examples
#' set.seed(120511)
#' a <- rnorm(100)
#' mean(a)
#' se(a)
se <- function(x, na.rm = FALSE) {
  if (na.rm) {
    x <- na.omit(x)
  }
  sqrt(var(x) / length(x))
}


=begin
[((<index-ja|URL:index-ja.html>))]
= Algebra::LocalizedRing
((*(局所化環クラス)*))

与えられた環を分子・分母にした分数環を構成します。
実際のクラスを生成するには、クラスメソッド ((<::create>))
あるいは関数 ((<Algebra.LocalizedRing>))() を用います。

== ファイル名:
* ((|localized-ring.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

なし

== 関連する関数:

--- Algebra.LocalizedRing(ring)
    ((<::create>))(ring) と同じです。

--- Algebra.RationalFunctionField(ring, obj)
    環 ((|ring|))、変数を表すオブジェクトを ((|obj|)) として有理関数体
    を作ります。クラスメソッド ((|::var|)) で変数を得ることができます。

    例: 有理関数体
      require "algebra/localized-ring"
      require "rational"
      F = Algebra.RationalFunctionField(Rational, "x")
      x = F.var
      p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )
        #=> x^2/(x^4 + x^3 - x - 1)

--- Algebra.MRationalFunctionField(ring, [obj1[, obj2, ...]])
    環 ((|ring|))、変数を表すオブジェクトを ((|obj1|)), ((|obj2|)),... として有理関数体を作ります。クラスメソッド ((|::vars|)) で変数を得ることができます。

    例: 有理関数体
      require "algebra/localized-ring"
      require "rational"
      G = Algebra.MRationalFunctionField(Rational, "x", "y", "z")
      x, y, z = G.vars
      f = (x + z) / (x + y) - z / (x + y)
      p f #=> (x^2 + xy)/(x^2 + 2xy + y^2)
      p f.simplify #=> x/(x + y)

== クラスメソッド:

--- ::create(ring)
    クラス((|ring|))で表現されるを環の元を分子・分母とする分数環
    を作ります。

    この戻り値は Algebra::LocalizedRing クラスのサブクラスです。
    このサブクラスにはクラスメソッドとして ((|::ground|)) が定義され
    ((|ring|)) を返します。

    生成したクラスにはクラスメソッド(({::[]}))が定義され、基礎環の
    元 (({x})) に対して分数環の元 (({x/1})) を返します。

    例: 有理数を作る
      require "localized-ring"
      F = Algebra.LocalizedRing(Integer)
      p F.new(1, 2) + F.new(2, 3) #=> 7/6

    例: 整数上の多項式環の商体
      require "polynomial"
      require "localized-ring"
      P = Algebra.Polynomial(Integer, "x")
      F = Algebra.LocalizedRing(P)
      x = F[P.var]
      p ( 1 / (x**2 - 1) - 1 / (x**3 - 1) )
        #=> (x^3 - x^2)/(x^5 - x^3 - x^2 + 1)

--- ::zero
    零元を返します。

--- ::unity
    単位元を返します。

#--- ::[](num, den = nil)

#--- ::reduce(num, den)

== メソッド:

#--- monomial?; true; end

--- zero?
    零元であるとき真を返します。

--- zero
    零元を返します。

--- unity
    単位元を返します。

--- ==(other)
    等しいとき真を返します。

--- <=>(other)
    大小関係を求めます。

--- +(other)
    和を計算します。

--- -(other)
    差を計算します。

--- *(other)
    積を計算します。

--- **(n)
    ((|n|)) 乗を計算します。

--- /(other)
    商を計算します。

#--- to_s

#--- inspect

#--- hash

=end


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)
  })
}


# Random Forest Regression

# Importing the dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3] # Select the second column "Level" and the third column "Salary" only

# Splitting the data set into the Training set and Test set
#library(caTools)
#set.seed(123)
#split = sample.split(dataset$Profit, SplitRatio = 0.8)
#training_set = subset(dataset, split == TRUE)
#test_set = subset(dataset, split == FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fitting the Random Forest Regression Model to the dataset
install.packages('randomForest')
library(randomForest)
set.seed(1234) # equals to random_state = 0
regressor = randomForest(x = dataset[1],
                         y = dataset$Salary,
                         ntree = 500)# dataset[1] will result in a dataframe, dataset$Salary will result in a vector

# Predicting a new result with Random Forest Regression
y_pred = predict(regressor, data.frame(Level = 6.5)) # make sure the 6.5 value showed in dataframe

# Visualizing the Random Forest Regression results (for higher resolution ans smoother curve)
# Non-linear and Non-continuous Regression Model
# install.packages('ggplot2')
library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.01) # from 1-10 incremented by 0.01

ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level = x_grid))),#transform x_grid vector to a data frame
            color = 'blue') +
  ggtitle('Truth or Bluff (Random Forest Regression)') +
  xlab('Level') +
  ylab('Salary')

Regression/Random Forest/Random Forest Regression Tree.r


library("lattice")

## Example data
x <- seq(1,10, length.out=20)
y <- seq(1,10, length.out=20)
data <- expand.grid(X=x, Y=y)
data$Z <- runif(400, 0, 5)

## Try it out
png("#27_long_matrix_levelplot.png" , width = 480, height = 480)
par(mar=c(3,4,2,2))
levelplot(Z ~ X*Y, data=data  , xlab="X" , col.regions = heat.colors(100)[length(heat.colors(100)):1]   , main="")
dev.off()


# 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))
}


  CW.interval.male = function(instar){
    i = instar - 3
    cw0 = exp(1.917564 + 0.298914*i)
    cw1 = exp(1.917564 + 0.298914*(i+1))
    return( c(cw0, cw1) )
  }


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


stoogesort = function(vect) {
	i = 1
	j = length(vect)
	if(vect[j] < vect[i])  vect[c(j, i)] = vect[c(i, j)]
	if(j - i > 1) {
		t = (j - i + 1) %/% 3
		vect[i:(j - t)] = stoogesort(vect[i:(j - t)])
		vect[(i + t):j] = stoogesort(vect[(i + t):j])
		vect[i:(j - t)] = stoogesort(vect[i:(j - t)])
	}
	vect
}

v = sample(21, 20)
k = stoogesort(v)
v
k


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))

)))


roll <- function(die, p){
  dice <- sample(die, 2, replace=TRUE, prob=p)
  dice
}

die <- 1:6
p <- c(1/6, 1/6, 1/6, 1/6, 1/6, 1/6)

roll(die, p)


# 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")
    })
  }
)


#' Plot time in exposed and infectious categories
#'
#' Creates a plot of the time (in days) a person spends in exposed and infectious
#' categories. Uses 1000 draws from a Gamma distribution.
#'
#' @param e.move proportion or probability of progressing through the E
#' category. Must be between 0 and 1.
#' @param i.move proportion or probability of progressing through the I
#' category. Must be between 0 and 1.
#' @param n.e.cats number of exposed sub categories
#' @param n.i.cats number of infectious sub categories
#' @return a density plot of time in the E or I category.
#'
#' @import ggplot2
#' @importFrom ggridges theme_ridges geom_density_ridges
#' @importFrom stats rgamma
#' @importFrom tidyr gather
#' @examples
#' plot_periods(e.move = 0.99, i.move = 0.99, n.e.cats = 6, n.i.cats = 5)
#'
#' @export

plot_periods <- function(e.move, i.move, n.e.cats, n.i.cats){
  if(missing(e.move)==TRUE) warning("missing e.move parameter")
  if(missing(i.move)==TRUE) warning("missing i.move parameter")
  if(missing(n.e.cats)==TRUE) warning("missing n.e.cats parameter")
  if(missing(n.i.cats)==TRUE) warning("missing n.i.cats parameter")

  exposure <- data.frame(exposure = rgamma(1000, n.e.cats, e.move))
  infectious <- data.frame(infectious = rgamma(1000, n.i.cats, i.move))

  #create a wide data.frame
  periods <- data.frame(exposure = exposure, infectious = infectious)

  periods.2 <-  periods %>%
    gather('exposure', 'infectious', key = "parameter", value = "value")

  p <- ggplot(periods.2, aes(x = value, y = parameter)) +
        geom_density_ridges() + theme_ridges() + ylab("") + xlab("days") +
        scale_y_discrete(labels = c("incubation period",
                                "infectious period")) +
    theme_bw(base_size = 16)
  p
}


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

data = read.table('weather.csv', header = TRUE, sep = ',', quote = "",
                  skip = 1, stringsAsFactors = FALSE)

years = data$Year[1:136]
temps = data[1:136, 2:13]

means = rowMeans(temps)

plot(years, means)

# Linear fit.
model = lm(means ~ years)

summary(model)
str(model)


> 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)))


#loading libraries
library (ISLR )
library(caret)
library(dplyr)
library(DAAG)
library(glmnet)

#reading the input file
df <- read.csv("/Users/rajivranjan/Desktop/slump.csv", header=TRUE)
df<-select(df, Cement,Slag,Fly.ash,Water,SP,Coarse.Aggr.,Fine.Aggr.,FLOW.cm.)

#randomly selecting 85 Samples
smp_size <- floor(0.83 * nrow(df))
set.seed(123)
train_ind <- sample(seq_len(nrow(df)), size = smp_size)

#divinding train and test data
train <- df[train_ind, ]
test <- df[-train_ind, ]

#generating the model
Control1<-trainControl(method = "repeatedcv",number = 5,repeats=5)
LmFit2<-train(FLOW.cm. ~ ., data = train, method = "glm",trControl = Control1, metric="Rsquared")
summary(LmFit2)

#using the model to predict the values
PredictedTest2<-predict(LmFit2,test)
ModelTest2<-data.frame(obs = test$FLOW.cm., pred=PredictedTest2)
defaultSummary(ModelTest2)

#calculating the residuals
ResData3<-residuals(LmFit2)
PredictedValues2<-predict(LmFit2)
plot(train$FLOW.cm.,ResData3,xlab="data")
abline(0,0)

#plotting the actual vs predicted chart
plot(test$FLOW.cm.,PredictedTest2,xlab="actual",ylab="predicted",col = "red")