library(pracma)

# data will be a mtrix where the rows are individual time series
# (assumes all time series same length, this could be relaxed in the future)

dewdrop <- function(data, E, theta, stepsAhead) {

    # construct library
    #tseries <- as.matrix(data)
    liblen  <- dim(data)[2] - E + 1 - stepsAhead
    libnum  <- dim(data)[1]
    lib     <- matrix(NA, libnum*liblen, E)
    preds 	<- matrix(NA, libnum*liblen, stepsAhead)

    ## make library and predictions array (flattened)

    libctr <- 1
    for (lidx in 1:libnum) {
    	tseries <- data[lidx,]
	    for (i in 1:liblen) {
	    	lstart <- i
	    	lstop  <- lstart + E - 1
	    	lib[libctr,] <- tseries[lstart:lstop]
	    	pstart <- lstop + 1
	    	pstop  <- pstart + stepsAhead - 1
	    	preds[libctr,] <- tseries[pstart:pstop]
	    	libctr <- libctr + 1
	    }
	}

	predictees  <- matrix(NA, libnum, E)

    # predict from the last index
	tslen <- dim(data)[2]
    for (lidx in 1:libnum) {
    	tseries <- data[lidx,]
	    predictees[lidx,] <- data[lidx,(tslen-E+1):(tslen)]
	}

	## predictions matrix

	predictions <- matrix(NA, libnum, stepsAhead)

    # for each prediction index (number of steps ahead)
	for (preidx in 1:libnum) {

		predictee <- predictees[preidx,]

	    for(i in 1:stepsAhead) {

	        # set up weight calculation
	        predmat <- repmat(predictee, liblen*libnum, 1)
	        #print(dim(predmat))
	        #print(dim(lib))
	        distances <- sqrt( rowSums( abs(lib - predmat)^2 ) )
	        meanDist <- mean(distances)

	        # calculate weights
	        weights <- exp( - (theta * distances) / meanDist )

	        # construct A, B

	        predvec <- preds[,i]

	        A <- cbind( rep(1.0, liblen*libnum), lib ) * repmat(as.matrix(weights), 1, E+1)
	        B <- as.matrix(predvec * weights)

	        # solve system for C

	        Asvd <- svd(A)
	        C <- Asvd$v %*% diag(1/Asvd$d) %*% t(Asvd$u) %*% B

	        # get prediction

	        predsum <- sum(C * c(1,predictee))

	        # save

	        predictions[preidx,i] <- predsum

	    }

	}

    return(predictions)

}


pca_basic = function(cm=NULL, indat=NULL, rotate="none",  nfactors=2, ev_template=NULL, save_fn=NULL, ...) {
  # see https://stats.stackexchange.com/questions/59213/how-to-compute-varimax-rotated-principal-components-in-r

  pca_results = NULL

  if (is.null(cm)) {
    if( !is.null(save_fn)) {
      if (file.exists(save_fn)) load( save_fn)
      return(pca_results)
    }
  }

  varnames = colnames(indat)
    if (!all(varnames %in% rownames(cm) ))  {
      message( "corelation matrix, cm does not have all the variables in varnames")
      message( setdiff(rownames(cm), varnames) )
      stop()
    }

   cm = cm [varnames,]
   cm = cm [,varnames]

  s = svd( cm ) # usually svd is done on the indat data matrix but here we use it on the cor/covar matrix  so essentially eignanalysis
  eigenvalues = s$d
  eigenvectors = s$v

  pcnames = paste("PC", 1:length(eigenvalues), sep="")

  names(eigenvalues) = pcnames

  for ( kk in 1:length(eigenvalues) ) {
    if (!is.null(ev_template)) {
      if ( cor( eigenvectors[,kk], ev_template[,kk] )  < 0 ) eigenvectors[,kk] = -1 * eigenvectors[,kk]
    } else {
      gg = abs(eigenvectors[,kk])
      uu = which.max( gg  )
      if ( eigenvectors[uu,kk] < 0 ) eigenvectors[,kk] = -1 * eigenvectors[,kk]  # force max value to be positive
    }
  }
  rownames(eigenvectors) = varnames
  colnames(eigenvectors) = pcnames

  stdev = sqrt( eigenvalues )
	loadings = eigenvectors %*% diag( c(stdev)  ) # Loadings are eigenvectors scaled by the square roots of the respective eigenvalues
  colnames(loadings) = pcnames

  if (0) {
    # older method:
    matrix.multiply = function (x, y, nfac=2){
        ndat = dim(x)[1]
        z = matrix(0, nrow=ndat, ncol = nfac)
        for (j in 1:nfac) {
          for (i in 1:ndat) {
            z[i,j] = sum ( x[i,] * t(y[,j]), na.rm=T )
          }
        }
        return (z)
    }

    scores = matrix.multiply (m, s$v)  # i.e., b %*% s$v  .. force a multiplication ignoring NAs
    # m[which(!is.finite(m))] = 0
    # scores = m %*% s$v  # i.e., b %*% s$v  .. force a multiplication ignoring NAs

  }

  scores = indat %*% t(pracma::pinv(loadings ))  # again, scaled by eigenvectors ( unscaled scores give "distance biplots" )
  colnames(scores) = pcnames

  total_variance = length(eigenvalues)  # note forcing this to be for scaled and standardized matrices .. ie. .. not for covariance

  pca_results = list(
    cm = cm,
    indat = indat,
    rotate=rotate,
    eigenvalues=	eigenvalues,
    eigenvectors=	eigenvectors,
    loadings=loadings,
    scores= scores,
    variance = eigenvalues,
    variance_percent = round(eigenvalues  / total_variance * 100, 2) ,
    total_variance = total_variance
  )

	if (rotate!="none")  {  #
	  if (rotate=="varimax") rot = varimax( loadings[,1:nfactors], ... )  #  normalize=FALSE, eps=1e-14)
	  if (rotate=="promax")  rot = promax(  loadings[,1:nfactors], ... )  #  normalize=FALSE, eps=1e-14)

    rotated_scores =  indat  %*% t(pracma::pinv(rot$loadings))
    colnames( rotated_scores ) = paste( "RC", 1:nfactors, sep="" )
    # rotated_scores_alt = scores[,1:nfactors] %*% rot$rotmat # testing: should be the same as rotated_scores
    pca_results$rotated_loadings = rot$loadings
    colnames(pca_results$rotated_loadings) = paste( "RC", 1:nfactors, sep="" )
    pca_results$rotated_scores = rotated_scores
    pca_results$rotated_variance = colSums(rot$loadings^2)
    pca_results$rotated_variance_percent = round( pca_results$rotated_variance /  total_variance * 100, 2)
    pca_results$rotation = rot$rotmat
    pca_results$rotation_id = rotate
	}

  if ( !is.null(save_fn)) save( pca_results, file=save_fn, compress=TRUE )

	return(  pca_results )
}


## GIFs inspired by https://crumplab.github.io/statistics/gifs.html
## libraries
library(ggplot2)
library(dplyr)
library(magick)
library(gganimate)
## some packages only available via github
## devtools::install_github("thomasp85/transformr")
library(transformr)

########################################
## One-sample
########################################
## simulate data (back story is av weight of bags of dog food, H0: mu = 5kg)
dog <- data.frame(type = "Food",
                  weight = rnorm(100,5,1),
                  reps = rep(1:10,each = 10))
means_df <- dog %>%
    group_by(reps,type) %>%
    summarize(means = mean(weight),
              sem = sd(weight)/sqrt(length(weight)))
stats_df <- dog %>%
    group_by(reps) %>%
    summarize(ts = t.test(weight,mu = 5)$statistic)
a <- ggplot(means_df, aes(x = type, y = means)) +
    geom_bar(stat = "identity") + scale_fill_brewer(palette = "Dark2") +
    geom_point(aes(x = type, y = weight), data = dog, alpha = .25) +
    geom_errorbar(aes(ymin = means - sem, ymax = means + sem), width = .2) +
    theme(axis.title.x=element_blank(),
          axis.ticks.x=element_blank(),
          panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) +
    geom_hline(yintercept = 5, col = "red") +
    xlab("") + ylab("Weight of dog food (kg)") +
    transition_states(
        states = reps,
        transition_length = 2,
        state_length = 1) +
    geom_text(aes(0.5, 7.5,
                  label = paste("Sample mean:", format(round(means, 3),nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')

a_gif <- animate(a, width = 420, height = 420)
anim_save("a.gif")

## t-dist

crit_df <- as.data.frame(apply(stats_df,2,rep,each = 100))
crit_df$ts <- c(sapply(abs(stats_df$ts),
                       function(x) seq(x,5, length.out = 100))) ## xvect of sequences
crit_df$y <- dt(crit_df$ts,df = 18,) ## corresponding t vals
b <- ggplot(stats_df, aes(x = ts))+
    geom_vline(aes(xintercept = ts))+
    geom_line(aes(x=x,y=y),
              data = data.frame(x = seq(-5,5, .1),
                                y = dt(seq(-5,5, .1), df = 18))) +
    theme(panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) +
    ylab("density") +
    xlab("t-statistic") +
    geom_area(data = crit_df,mapping = aes(x = ts,y = y),fill = "grey",alpha = 0.3) +
    geom_area(data = crit_df,mapping = aes(x = -ts,y = y),fill = "grey",alpha = 0.3) +
    transition_states(reps,transition_length = 0,
                      state_length = 1) +
    geom_text(aes(-4, 0.5,label = paste("t-statistic:", format(round(ts, 3), nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    geom_text(aes(-4, 0.475,
                  label = paste("p-value:",
                                format(round(2*pt(abs(ts),df = 18,lower.tail = FALSE), 2),
                                       nsmall = 2))),
              size = 4, hjust = 0, color = "grey") +
    enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')
b_gif <- animate(b, width = 420, height = 420)
anim_save("b.gif")

a_mgif <- image_read("a.gif")
b_mgif <- image_read("b.gif")

## combine into one gif

new_gif <- image_append(c(a_mgif[1], b_mgif[1]))
for(i in 2:100){
    combined <- image_append(c(a_mgif[i], b_mgif[i]))
    new_gif <- c(new_gif, combined)
}

anim_save("one_sample_ttest.gif",new_gif)

########################################
## Independent two sample
########################################
## independant t-test
## simulate data (back story which students spend more time studying?)
A <-rnorm(100,60,10)
B <-rnorm(100,70,10)
DV <- c(A,B)
Student <- rep(c("Medics","Biologists"),each=100)
sims <- rep(rep(1:10,each=10),2)
df <- data.frame(sims, Student, DV)
means_df <- df %>%
               group_by(sims,Student) %>%
               summarize(means=mean(DV),
                         sem = sd(DV)/sqrt(length(DV)))
means_df$lab <- rep(1:2, times = 10)
stats_df <- df %>%
              group_by(sims) %>%
              summarize(ts = t.test(DV~Student,var.equal=TRUE)$statistic)
a <- ggplot(means_df, aes(x=Student,y=means, fill=Student))+
    geom_bar(stat="identity") + scale_fill_brewer(palette = "Dark2") +
    geom_point(data=df,aes(x=Student, y=DV), alpha=.25)+
    geom_errorbar(aes(ymin=means-sem, ymax=means+sem),width=.2) +
    ylab("Number of hours studied") +
    theme(axis.title.x=element_blank(),
          panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) +
    transition_states(
        states = sims,
        transition_length = 2,
        state_length = 1
    ) +
    geom_text(aes(0.5, 90,label = paste("Sample mean Biologists:",
                                        format(round(means[c(sims[c(TRUE,TRUE,FALSE,FALSE)],
                                                             means_df$sims[c(TRUE,TRUE,FALSE,FALSE)] + 10)], 3),
                                               nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    geom_text(aes(0.5, 86,label = paste("Sample mean Medics:", format(round(means[sims*2], 3),
                                                                      nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')
a_gif <- animate(a, width = 420, height = 420)
anim_save("a.gif")

## test statistic distribution
## for p-value shading
crit_df <- as.data.frame(apply(stats_df,2,rep,each = 100))
crit_df$ts <- c(sapply(abs(stats_df$ts), function(x) seq(x,5, length.out = 100))) ## xvect of sequences
crit_df$y <- dt(crit_df$ts,df = 18,) ## corresponding t vals
b <- ggplot(stats_df,aes(x=ts))+
    geom_vline(aes(xintercept=ts))+
    geom_line(data=data.frame(x=seq(-5,5,.1),
                              y=dt(seq(-5,5,.1),df=18)),
              aes(x=x,y=y)) +
    theme(panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) +
    ylab("density")+
    xlab("t-statistic")+
    geom_area(data = crit_df,mapping = aes(x = ts,y = y),fill = "grey",alpha = 0.3) +
    geom_area(data = crit_df,mapping = aes(x = -ts,y = y),fill = "grey",alpha = 0.3) +
    transition_states(sims,transition_length = 0,
        state_length = 1) +
    geom_text(aes(-4, 0.5,label = paste("t-statistic:", format(round(ts, 2), nsmall = 2))),
              size = 4, hjust = 0, color = "black") +
    geom_text(aes(-4, 0.475,label = paste("p-value:", format(round(2*pt(abs(ts),df = 18,lower.tail = FALSE), 2), nsmall = 2))),
              size = 4, hjust = 0, color = "grey") +
    enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')

b_gif<-animate(b, width = 420, height = 420)
anim_save("b.gif")

## combine
d <- image_blank(420*2,420)
the_frame <- d
for(i in 2:100){
  the_frame<-c(the_frame,d)
}

a_mgif<-image_read("a.gif")
b_mgif<-image_read("b.gif")

new_gif<-image_append(c(a_mgif[1], b_mgif[1]))
for(i in 2:100){
  combined <- image_append(c(a_mgif[i], b_mgif[i]))
  new_gif<-c(new_gif,combined)
}
anim_save("ind_two_sample_ttest.gif",new_gif)


attach(mtcars)

plot(wt, mpg, main="Scatterplot Example 1",
     xlab="Car Weight ", ylab="Miles Per Gallon ", pch=19)

plot(wt, mpg, main="Scatterplot Example 2",
     xlab="Car Weight ", ylab="Miles Per Gallon ", pch=19)

abline(lm(mpg~wt), col="red") # regression line (y~x)
lines(lowess(wt,mpg), col="blue") # lowess line (x,y)

pairs(~mpg+disp+drat+wt,data=mtcars,
      main="Simple Scatterplot Matrix")

plot(global_data)
summary(lm(gt~pr))
summary(lowess(gt~pr))

data(iris)
## tune  svm  for classification with RBF-kernel (default in svm),
## using one split for training/validation set
obj <- tune(svm, gt~., data = phone_data_gt,
            ranges = list(gamma = 2^(-1:1), cost = 2^(2:4)),
            tunecontrol = tune.control(sampling = "fix")
)
## alternatively:
## obj <- tune.svm(Species~., data = iris, gamma = 2^(-1:1), cost = 2^(2:4))
summary(obj)
plot(obj)

# tune  knn  using a convenience function; this time with the
## conventional interface and bootstrap sampling:
x <- iris[,-5]
y <- iris[,5]
obj2 <- tune.knn(x, y, k = 1:10, tunecontrol = tune.control(sampling = "boot"))
summary(obj2)
plot(obj2)

library(caret)
model4.gt <- knnreg(phone_data_gt[,2:5], phone_data_gt[,1], k=1)
summary(model4.gt)
model4.gt
predictions <- predict(model4.gt, phone_data_gt[,2:5])
rmse <- sqrt(mean((phone_data_gt$gt - predictions)^2))
print(rmse)

x <- phone_data_gt[,2:5]
y <- phone_data_gt[,1]
obj2 <- tune.knn(x, y, k = 1:10, tunecontrol = tune.control(sampling = "boot"))
summary(obj2)
plot(obj2)

## tune  rpart  for regression, using 10-fold cross validation (default)
data(mtcars)
obj3 <- tune.rpart(mpg~., data = mtcars, minsplit = c(5,10,15))
summary(obj3)
plot(obj3)

## simple error estimation for lm using 10-fold cross validation
tune(lm, mpg~., data = mtcars)

# subset selection example
d <- data.frame(
  state = rep(c('NY', 'CA'), 10),
  year = rep(1:10, 2),
  response= rnorm(20)
)

library(plyr)
# Break up d by state, then fit the specified model to each piece and
# return a list
models <- dlply(d, "state", function(df)
  lm(response ~ year, data = df))

# Apply coef to each model and return a data frame
ldply(models, coef)

# Print the summary of each model
l_ply(models, summary, .print = TRUE)

# All Subsets Regression
library(leaps)
attach(mydata)
leaps<-regsubsets(gt~.,data=phone_data_gt,nbest=10)
# view results
summary(leaps)
plot(leaps)
# plot a table of models showing variables in each model.
# models are ordered by the selection statistic.
plot(leaps,scale="r2")
# plot statistic by subset size
library(car)
subsets(leaps, statistic="rsq")

library(mlbench)
data(Sonar)
str(Sonar[, 1:10])
library(caret)
set.seed(998)
inTraining <- createDataPartition(Sonar$Class, p = .75, list = FALSE)
training <- Sonar[ inTraining,]
testing  <- Sonar[-inTraining,]

gbmGrid <-  expand.grid(interaction.depth = c(1, 5, 9),
                        n.trees = (1:30)*50,
                        shrinkage = 0.1,
                        n.minobsinnode = 20)
gbmGrid2 <-  expand.grid(interaction.depth = c(1, 5, 9))

nrow(gbmGrid)

set.seed(825)
gbmFit2 <- train(Class ~ ., data = training,
                 method = "gbm",
                 trControl = fitControl,
                 verbose = FALSE,
                 ## Now specify the exact models
                 ## to evaluate:
                 tuneGrid = gbmGrid2)
gbmFit2

trellis.par.set(caretTheme())
plot(gbmFit2)

plot(lasso.gt$results$fraction, lasso.gt$results$RMSE,
     ylim=range(c(lasso.gt$results$RMSE-lasso.gt$results$RMSESD, lasso.gt$results$RMSE+lasso.gt$results$RMSESD)),
     pch=19, xlab="Measurements", ylab="Mean +/- SD",
     main="Scatter plot with std.dev error bars"
)
arrows(lasso.gt$results$fraction, avg-sdev, x, avg+sdev, length=0.05, angle=90, code=3)
plot(lasso.gt)
ggplot(lasso.gt)

plotWithBars <- function(model){
  library(ggplot2)

  foo <- model$results
  colnames(foo)[1] <- "params"
  ggplot(foo, aes(x=params, y=RMSE), main="Regression of MPG on Weight",
         xlab="Weight", ylab="Miles per Gallon") +
    geom_errorbar(aes(ymin=RMSE-RMSESD, ymax=RMSE+RMSESD), width=.1) +
    geom_line() +
    geom_point()+ expand_limits(y = 0)+ theme_bw()
}
plotWithBars(knn.gt)

plot(lasso.gt$results$RMSE, avg,
     ylim=range(c(avg-sdev, avg+sdev)),
     pch=19, xlab="Measurements", ylab="Mean +/- SD",
     main="Scatter plot with std.dev error bars"
)

testing <- svm(gt~., phone_data_gt, type="nu-regression")


#' @title orderBalancedTree
#'
#' @description
#' \code{orderBalancedTree} returns the order (number of vertices) of a balanced tree with breadth r and height h.  If the arguments
#' are vectors, the function returns a vector of orders.
#' @param r Branching factor or breadth of the tree, can be scalar or vector
#' @param h Height factor or depth of the tree, can be scalar or vector
#' @keywords graph,network
#' @export
orderBalancedTree <- Vectorize(function(r, h) {
  total <- 0
  hseq <- seq.int(0, h)
  total <- sum(r ^ hseq)
  return(total)
})


#cerner_2tothe5th_2021
# R program to find the factorial value of given set of values using factorial() method
factorialValue <- factorial(c(0, 1, 2, 3, 4, 8))

print(factorialValue)


## 2. Combine Vectors ##

harvard <- c(1,1,1,1,3)
stanford <- c(2,9,3,4,10)
MIT <- c(3,3,2,2,1)
cambridge <- c(4,2,6,13,48)
oxford <- c(5,7,12,9,15)
columbia <- c(6,13,13,12,4)

uni_vector <- c(harvard, stanford, MIT, cambridge, oxford, columbia)

## 3. Creating a Matrix ##

uni_vector <- c(harvard, stanford, MIT, cambridge, oxford, columbia)

uni_matrix <- matrix(uni_vector, nrow=6, ncol=5, byrow = TRUE)
print(uni_matrix)

## 4. Vector & Matrix Data Types ##

columbia_types <- c("columbia",6,13,13,12,4)
type <- class(columbia_types)
print(type)

## 5. Naming Rows And Columns ##

categories <- c("world_rank","quality_of_education","influence","broad_impact","patents")
universities <- c("Harvard","Stanford","MIT","Cambridge","Oxford","Columbia")

rownames(uni_matrix) <- universities
colnames(uni_matrix) <- categories
named_uni_matrix <- uni_matrix
print(named_uni_matrix)

## 6. Finding the dimensions of the matrix ##

tuition <- c(43280,45000,45016,49350,28450,55161)

print(dim(uni_matrix))
print(length(tuition))
equality <-  dim(uni_matrix)[1] == length(tuition)
print(equality)

## 7. Creating new columns and rows ##

tuition <- c(43280,45000,45016,49350,28450,55161)

uni_matrix <- cbind(uni_matrix, tuition)
print(uni_matrix)

## 8. Subsetting And Indexing A Matrix By Element ##

oxford_influence <- uni_matrix["Oxford","influence"]
stanford_impact <- uni_matrix["Stanford","broad_impact"]
cambridge_patents <- uni_matrix["Cambridge","patents"]
MIT_world_rank <- uni_matrix["MIT","world_rank"]

## 9. Subsetting a Matrix by Rows & Columns ##

world_rank <- uni_matrix[,"world_rank"]
columbia <- uni_matrix["Columbia",]
patents <- uni_matrix[,"patents"]

## 10. Sorting a Matrix ##

top_edu <- sort(uni_matrix[,"quality_of_education"])
low_cost <- sort(uni_matrix[,"tuition"])

## 11. Sorting Then Previewing Data ##

top_edu <- sort(uni_matrix[,"quality_of_education"])
low_cost <- sort(uni_matrix[,"tuition"])

top_two_edu <- head(top_edu, 2)
two_low_cost <- head(low_cost, 2)

R Fundamentals/Introduction to Matrices-312.r


## Exercício 10
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181172
## 28 de maio de 2020
##
## Simulação das Camisetas de Sustentare -- Uma Vez
## Todos os dados totalmente inventados
## Similaridade entre esta versão da Sustentare e a verdadeiro é 100% por acaso

library(tidyverse)
library(summarytools)

## Variáveis Básicas (repetido da ex. 9)

publico_ano1 <- 4000 #número total dos alunos/ex-alunos
novo_publico <- 250 #número novo de alunos por ano
custo_ano1 <- 32 #custo da camiseta estampada com logo e nome em reais
inflacao <- .05 #aumento de custos anual (inflação)com
markup <- 1 #fator para adicionar ao custo para determinar preço de venda
#ex. 1 = 100%
desenv_ano1 <- 20000 # cobrança em ano 1 para desenvolver produto, mktg, etc.
anos <- 5L #número de anos para julgar se programa vale a pena
min_prop <- 0.15 # min e max proporções do público que vai comprar
max_prop <- 0.40

# Número de Iterações

n_sims <- 1000

# Repositório dos Resultados
# Guardar vazio

total_camis <- tibble(sim = integer(n_sims),
                      media_prop = double(n_sims),
                      tot_compras = double(n_sims),
                      tot_renda = double(n_sims),
                      tot_lucro = double(n_sims))

# Funcao do Modelo - Simulação Individual

camis_modelo <- function() {
  # colocar as variáveis num tibble

  camis <- tibble(desenv = numeric(length = anos),
                  publico =  numeric(length = anos),
                  custo = numeric(length = anos),
                  preco = numeric(length = anos),
                  compras = numeric(length = anos),
                  renda = numeric(length = anos),
                  lucro = numeric(length = anos))

  # Carregar camis com os valores

   camis$desenv[1] <- desenv_ano1

  ## Outras precisam loop

  for (i in 1:anos) {
    camis$publico[i] <- publico_ano1 + (i - 1) * novo_publico
    camis$custo[i] <- custo_ano1 * (1 + inflacao)^(i-1)
    camis$preco[i] <- camis$custo[i] * (1 + markup)
  }

  # variável probabilística -- qual proporção do público vai comprar
  # aleatórico entre 15% e 40%
  # usar distribuição uniforme -- runif()
  # premissa: que pode comprar mais de uma vez

  prop_compras <- runif(5, min = min_prop, max = max_prop)

  camis <- camis %>%
    mutate(compras = publico * prop_compras,
           renda = compras * preco,
           lucro = renda - desenv - custo * compras)

  # Calcular os Totais

  sum_camis <- camis %>%
    summarise(media_prop = mean(prop_compras),
              tot_compras = sum(compras),
              tot_renda = sum(renda),
              tot_lucro = sum(lucro))

  # Salvar os resultados

  return(sum_camis)
}

## Executar a Simulação

# set.seed() para tudo mundo tem o mesmo resultado

set.seed(42)

# iniciar sum_camis para receber dados da função

sum_camis <- tibble(sim = integer(n_sims),
                    media_prop = double(n_sims),
                    tot_compras = double(n_sims),
                    tot_renda = double(n_sims),
                    tot_lucro = double(n_sims))

# Loop

inicio_loop = Sys.time()

for (n in 1:n_sims){
  sum_camis <- camis_modelo()

  # Carregar resultados

  total_camis$sim[n] = n
  total_camis$media_prop[n] = sum_camis$media_prop
  total_camis$tot_compras[n] = sum_camis$tot_compras
  total_camis$tot_renda[n] = sum_camis$tot_renda
  total_camis$tot_lucro[n] = sum_camis$tot_lucro
}

termino_loop = Sys.time()

print(glue::glue("Tempo de execução = ", round(termino_loop - inicio_loop, 2), " segundos"))

## Analisar Resultados

summarytools::descr(total_camis[, 2:5], stats = c("mean", "sd", "min", "med",
                                           "max", "iqr", "cv"))


#initially I created a function which returns prime factors then I have created another function counts in the factors and #prints the values.

findfactors <- function(num) {
  x <- c()
  p1<- 2
  p2 <- 3
  everyprime <- num
  while( everyprime != 1 ) {
    while( everyprime%%p1 == 0 ) {
      x <- c(x, p1)
      everyprime <- floor(everyprime/ p1)
    }
    p1 <- p2
    p2 <- p2 + 2
  }
  x
}
count_in_factors=function(x){
  primes=findfactors(x)
  x=c(1)
  for (i in 1:length(primes)) {
    x=paste(primes[i],"x",x)
  }
  return(x)
}
count_in_factors(72)


#'@title calcCb
#'
#'@description Calculates the maximum block coefficient (\code{Cb})
#'(dimensionless) based on a ship's maximum displacement and and maximum draft.
#'
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#'@details
#'The block coefficient is the ratio of the vessel's displacement and its
#'volume, defined by its waterline length (\code{lwl}), breadth, and draft:
#'\deqn{Cb=\frac{displacement}{lwl*breadth*draft}}{Cb=displacement/(lwl*breadth*draft)}
#'
#'This function returns the maximum block coefficient (\code{Cb}), which is the
#'ratio of the vessel's maximum displacement and it's maximum volume, defined by
#'its waterline length (\code{lwl}), breadth, and maximum draft:
#'\deqn{Cb=\frac{maxDisplacement}{lwl*breadth*maxDraft}}{Cb=maxDisplacement/(lwl*breadth*maxDraft)}
#'
#'@return \code{Cb} (vector of numericals, dimensionless)
#'
#'@references
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'}
#'
#'@examples
#'calcCb(c(80097.00,52382.04), c(218.75,209.25), c(32.25,32.2), c(13.6,11.5))
#'
#'@export

calcCb<- function(maxDisplacement, lwl, breadth, maxDraft){

  Cb <- pmin(1,
             maxDisplacement/(lwl*breadth*maxDraft)
  )
  return(Cb)

}


# Do growth accounting and prepare figures of results

#########################################################################
# Pull PWT into dataframe
data("pwt9.1") # extract PWT data

#########################################################################
# Accounting calculation
#########################################################################
p <- pwt9.1 # copy dataframe for manipulation
p$lngdppc <- round(log(p$rgdpna) - log(p$pop),digits=2) # create log GDP per capita
p$ky <- round(p$rnna/p$rgdpna,digits=2) # create K/Y ratio
p$acctky <- (.3/(1-.3))*log(p$ky) # just the K/Y part
p$accthc <- log(p$hc) + log(p$emp/p$emp) # just the labor/HC part
p$accttfp <- p$lngdppc - p$acctky - p$accthc # just the TFP part

s <- p # save initial dataset for use later

# Get initial values of TFP, HC, and KY terms from 1960
p <- p[which(p$year>1959),]
p$inittfp <- with(p, accttfp[year == "1960"][match(isocode, isocode[year == "1960"])])
p$inithc <- with(p, accthc[year == "1960"][match(isocode, isocode[year == "1960"])])
p$initky <- with(p, acctky[year == "1960"][match(isocode, isocode[year == "1960"])])

# Calcualte the counterfactual series of GDP p.c. with KY only, TFP only, HC only
p$kyonly <- round(p$inittfp + p$inithc + p$acctky,digits=2)
p$hconly <- round(p$inittfp + p$accthc + p$initky,digits=2)
p$tfponly <- round(p$accttfp + p$inithc + p$initky,digits=2)
p$input <- round(p$inittfp + p$accthc + p$acctky,digits=2)

# Grab data for only specific countries
usa <- p[which(p$isocode %in% c("USA")),]
deu <- p[which(p$isocode %in% c("DEU")),]
kor <- p[which(p$isocode %in% c("KOR")),]
jpn <- p[which(p$isocode %in% c("JPN")),]
chn <- p[which(p$isocode %in% c("CHN")),]

#########################################################################
# Figure for USA and KOR accounting showing CF log GDP per capita
#########################################################################
#,color = I('black'),
#color_discrete_sequence= px.colors.sequential.Plasma_r

fig <- plot_ly(usa, x = ~year, y = ~kyonly, name = 'K/Y only', type = 'scatter',
               mode = 'lines'
               )
fig <- fig %>% add_trace(y = ~hconly, name = 'HC only',mode = 'lines')
fig <- fig %>% add_trace(y = ~tfponly, name = 'Prod only',mode = 'lines')
fig <- fig %>% add_trace(y = ~lngdppc, name = 'Actual GDP p.c.',mode = 'lines')
fig <- layout(fig, title = list(text = 'Accounting for United States', x=0),
               xaxis = list(title = 'Year', tick0=1950, dtick=10),
               yaxis = list (title = 'Log GDP per capita',range=c(9,11)),
               hovermode="x unified")
api_create(fig, filename = "pwt-account-usa")

fig <- plot_ly(kor, x = ~year, y = ~kyonly, name = 'K/Y only', type = 'scatter', mode = 'lines')
fig <- fig %>% add_trace(y = ~hconly, name = 'HC only',mode = 'lines')
fig <- fig %>% add_trace(y = ~tfponly, name = 'Prod only',mode = 'lines')
fig <- fig %>% add_trace(y = ~lngdppc, name = 'Actual GDP p.c.',mode = 'lines')
fig <- layout(fig, title = list(text = 'Accounting for South Korea', x=0),
              xaxis = list(title = 'Year', tick0=1950, dtick=10),
              yaxis = list (title = 'Log GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "pwt-account-kor")

#########################################################################
# Create alternative figure with breakdown of growth rate by 10-year period
#########################################################################

# Get 10-year lags for accounting terms
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.acctky = dplyr::lag(acctky, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.accthc = dplyr::lag(accthc, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.accttfp = dplyr::lag(accttfp, n = 10, default = NA))
s <-
  s %>%
  group_by(isocode) %>%
  mutate(lag10.lngdppc = dplyr::lag(lngdppc, n = 10, default = NA))

# Calculate 10-year growth rate of accounting terms
s$g10.acctky <- round((s$acctky - s$lag10.acctky)/10,digits=4)
s$g10.accthc <- round((s$accthc - s$lag10.accthc)/10,digits=4)
s$g10.accttfp <- round((s$accttfp - s$lag10.accttfp)/10,digits=4)
s$g10.lngdppc <- round((s$lngdppc - s$lag10.lngdppc)/10,digits=4)

comp <- s[which(s$isocode %in% c("USA","CHN","KOR","JPN","DEU","GBR")),]
s <- s[which(s$isocode %in% c("USA")),]

#########################################################################
# Figure for US growth rate breakdown
#########################################################################
fig <- plot_ly(s, x = ~year, y = ~g10.acctky, type = 'bar', name = 'K/Y growth')
fig <- fig %>% add_trace(y = ~g10.accthc, name = 'HC growth')
fig <- fig %>% add_trace(y = ~g10.accttfp, name = 'Prod growth')
fig <- fig %>% layout(yaxis = list(title = '10-year growth contribution'),
                      barmode = 'stack',
                      xaxis = list(title = 'Year', tick0=1960, dtick=10),
                      title = list(text = 'Growth accounting', x=0),
                      hovermode="x unified"
                      )
api_create(fig, filename = "pwt-growth-acct-usa")

#########################################################################
# Figure of growth rate of productivity for set of countries
#########################################################################
fig <- plot_ly(comp, x = ~year, y = ~g10.accttfp, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Productivity growth', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-growth-tfp-comp")

#########################################################################
# Merge OECD R&D data with productivity growth data
#########################################################################
# Pull OECD into dataframe
work <- get_dataset("PERS_FUNC")

# Get log of R&D workers
fte <- work
fte <- fte[which(fte$SECTPERF %in% c("_T")),]
fte <- fte[which(fte$FUNCTION %in% c("RSE")),]
fte <- fte[which(fte$GENDER %in% c("_T")),]
fte <- fte[which(fte$MEASURE %in% c("FTE")),]
fte <- fte[which(fte$COUNTRY %in% c("USA","JPN","KOR","CHN","DEU","GBR")),]
fte$lnrdworker <- log(fte$obsValue)

# Calculate 10-year growth rate of R&D workers
fte <-
  fte %>%
  group_by(COUNTRY) %>%
  mutate(lag10.lnrdworker = dplyr::lag(lnrdworker, n = 10, default = NA))
fte$g10.lnrdworker <- (fte$lnrdworker - fte$lag10.lnrdworker)/10

# Join the R&D worker data to the productivity growth data for set of countries
match <- data.frame(comp$isocode,comp$g10.accttfp,comp$year,comp$pop,comp$accttfp)
colnames(match) <- c("COUNTRY","g10.accttfp","obsTime","pop","accttfp")
match$lnpop <- log(match$pop)
joined <- merge(match,fte,by=c('COUNTRY','obsTime'))

#########################################################################
# Figure for R&D workers and growth in productivity
#########################################################################
pal <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00','#ffff33')
pal <- setNames(pal, c("USA","JPN","KOR","CHN","DEU","GBR"))
fig <- plot_ly(joined, x = ~lnrdworker, y = ~g10.accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
",
                                     "%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D work and prod growth', x=0),
              xaxis = list(title = 'Log R&D FTE workers'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-rd-tfp")

#########################################################################
# Figure for growth in R&D workers and growth in productivity
#########################################################################
fig <- plot_ly(joined, x = ~g10.lnrdworker, y = ~g10.accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D growth and prod growth', x=0),
              xaxis = list(title = '10-year growth rate of R&D FTE'),
              yaxis = list(title = '10-year productivity growth rate'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-rd-gtfp")

#########################################################################
# Figure for level of R&D workers and level of productivity
#########################################################################
fig <- plot_ly(joined, x = ~lnrdworker, y = ~accttfp, color = ~COUNTRY,
               type = 'scatter', mode = 'markers',colors = pal,
               hovertemplate = paste("
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of R&D level and prod level', x=0),
              xaxis = list(title = 'Log R&D FTE'),
              yaxis = list(title = 'Log productivity'),
              hovermode="x unified")
api_create(fig, filename = "pwt-oecd-level-rd")


library(png)
library(animation)

bread <- readPNG("img/original.png")

## bread plot, axes rotating
l.sim <- 30
## pc1 axis
h1 <- seq(360,315,length.out = l.sim)
t1 <- seq(180,135,length.out = l.sim)
## pc2 axis
h2 <- seq(90,45,length.out = l.sim)
t2 <- seq(270,225,length.out = l.sim)
## pc3 axis
## h3 <- seq(45,0,length.out = l.sim)
## t3 <- seq(225,180,length.out = l.sim) ## 3D doesn't show well in plot

ani.options(interval = 0.1)
saveGIF(
    for(i in 1:l.sim){
        par(mar = c(0,0,4,4),xpd = TRUE)
        plot(1, type = "n",axes = FALSE, xlab = "", ylab = "",xlim = c(-1,1), ylim = c(-1,1),asp = 1)
        rasterImage(bread,-0.9,-0.9,0.9,0.9)
        ## pc1 axis
        arrows(sin(t1[i]*pi/180),cos(t1[i]*pi/180),sin(h1[i]*pi/180),cos(h1[i]*pi/180),lwd = 5,length = 0.1)
        text(sin(h1[i]*pi/180),cos(h1[i]*pi/180) + 0.1,"PC 1",cex = 1.25)
        ## pc2 axis
        arrows(sin(t2[i]*pi/180),cos(t2[i]*pi/180),sin(h2[i]*pi/180),cos(h2[i]*pi/180),lwd = 5,length = 0.1)
        text(sin(h2[i]*pi/180) + 0.1,cos(h2[i]*pi/180),"PC 2",cex = 1.25)
        ## pc3 axis
        ## arrows(sin(t3[i]*pi/180),cos(t3[i]*pi/180),sin(h3[i]*pi/180),cos(h3[i]*pi/180),lwd = 5,length = 0.1)
        ## text(sin(h3[i]*pi/180) + 0.1,cos(h3[i]*pi/180) + 0.1,"PC 3",cex = 1.25)
    },movie.name = "pca.gif"
)

## perpendicular plot
## functions needed
## slope and intercept of line that passes through two points
l.eq <- function(c1,c2){
    m = (c2[2] - c1[2])/(c2[1] - c1[1])
    int = c1[2] - m*c1[1]
    return(c(m,int))
}
## slope and intercept of line perpendicular to line and given point
p.eq <- function(p1,m,int){
    m2 = -1*1/m
    int2 = p1[2] - m2*p1[1]
    return(c(m2,int2))
}
## point of intersection between two lines
p.int <- function(m1,int1,m2,int2){
    x = (int2 - int1)/(m1 - m2)
    y = m1*x + int1
    return(c(x,y))
}

## get interception point on line
get.inter <- function(x,m,b){
    perp <- p.eq(x,m,b)
    inter <- p.int(m,b,perp[1],perp[2])
    return(inter)
}
#######

set.seed(4321)
x <- rnorm(100)
y <- -x + rnorm(100, sd = 0.5)
## radius
r <- 3.75
pts <- cbind(x,y) ## data points

## bread data plot
png("bread_data.png")
par(xpd = TRUE)
plot(x,y,,type = "n",axes = FALSE, ylab = "", xlab = "", xlim  = c(-3,3),ylim = c(-3,3))
rasterImage(bread,-4.25,-4.25,4,4)
points(x,y,pch = 20)
dev.off()

## rotating line
h <- c(seq(135,165,length.out = 30),seq(165,135,length.out = 30),
       seq(135,105,length.out = 30),seq(105,135,length.out = 30))
t <- c(seq(315,345,length.out = 30),seq(345,315,length.out = 30),
       seq(315,285,length.out = 30),seq(285,315,length.out = 30))
ani.options(interval = 0.2)
saveGIF(
    for(i in 1:length(h)){
        par(xpd = TRUE)
        plot(x,y,,type = "n",axes = FALSE, ylab = "", xlab = "", xlim  = c(-3,3),ylim = c(-3,3))
        points(x,y,pch = 20)
        arrows(-3,-3,3,-3,length = 0.1, lwd = 5)
        arrows(-3,-3,-3,3,length = 0.1, lwd = 5)
        mtext(side = 1,"Lecture length")
        mtext(side = 2,"Student's attention span")
        ## red line for "best fit" axis
        arrows(r*sin(t[1]*pi/180),r*cos(t[1]*pi/180),r*sin(h[1]*pi/180),r*cos(h[1]*pi/180),lwd = 2,code = 0)
        arrows(r/2*sin(45*pi/180),r/2*cos(45*pi/180),r/2*sin(225*pi/180),r/2*cos(225*pi/180),lwd = 2,code = 0, lty = 2)
        ## end points of line
        pts1 <- c(r*sin(t[i]*pi/180),r*cos(t[i]*pi/180))
        pts2 <- c(r*sin(h[i]*pi/180),r*cos(h[i]*pi/180))
        arrows(pts1[1],pts1[2],pts2[1],pts2[2],lwd = 2,code = 0,col = "lightgrey")
        arrows(r/2*sin((t[i]+90)*pi/180),r/2*cos((t[i]+90)*pi/180),r/2*sin((h[i]+90)*pi/180),r/2*cos((h[i]+90)*pi/180),lwd = 2,
               code = 0, lty = 2,col = "lightgrey")
        ## get equation of new line
        new.line <- l.eq(pts1,pts2)
        inter <- apply(pts,1,get.inter,m = new.line[1], b = new.line[2]) ## all interception points
        arrows(pts[,1],pts[,2],inter[1,],inter[2,],code = 0,col = "blue")
    },movie.name = "perp.gif"
)


#!/usr/bin/Rscript

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

rsurf = function(dim=3) {
    # Generate random vector components.
    x = rnorm(dim)

    # Normalize by the radius.
    r = sqrt(sum(x^2))
    y = x / r

    return(y)
}

rbulk = function(dim=3) {
    # Generate random vector components.
    x = rnorm(dim)

    # Normalize by the radius.
    r = sqrt(sum(x^2))
    x_normalized = x / r

    # Sample a new radius and adjust it for the Jacobian on that dimension.
    r_new = runif(1)^(1/dim)
    y = r_new * x_normalized

    return(y)
}

# Generate points and show them in a sensible fashion.

# 2D Surface.
samples_2d_surf = replicate(100, rsurf(2))
plot(samples_2d_surf[1,], samples_2d_surf[2,])

# 3D Surface.
samples_3d_surf = replicate(2000, rsurf(3))
x = samples_3d_surf[1,]
y = samples_3d_surf[2,]
z = samples_3d_surf[3,]

plot(x, y)

lambda = atan2(y, x)
r = sqrt(x^2 + y^2)
phi = atan2(z, r)

px = 2 * sqrt(2) * cos(phi) * sin(lambda/2) / sqrt(1 + cos(phi) * cos(lambda/2))
py = sqrt(2) * sin(phi) / sqrt(1 + cos(phi) * cos(lambda/2))

plot(px, py)

# 2D Bulk
samples_2d_bulk = replicate(2000, rbulk(2))
plot(samples_2d_bulk[1,], samples_2d_bulk[2,])

# 3D Bulk
samples_3d_bulk = replicate(2000, rbulk(3))
plot(samples_3d_bulk[1,], samples_3d_bulk[2,])


library(dplyr)

data <- read.csv("week2/femaleControlsPopulation.csv") %>% unlist

set.seed(1)

compute_sampling_distribution = function(num_samples, num_trials) {
  sampling_distribution = vector("numeric", num_samples)
  for(i in 1:num_trials) {
    sampling_distribution[i] <- mean(sample(data, num_samples))
  }
  sampling_distribution
}

# Q1
num_trials <- 1000
hist(compute_sampling_distribution(5, num_trials))
hist(compute_sampling_distribution(50, num_trials))

# Q2
sampling_dist_50 <- compute_sampling_distribution(50, num_trials)
mean(sampling_dist_50 <= 25) - mean(sampling_dist_50 <= 23)

# Q3
pnorm(25, 23.9, 0.43) - pnorm(23, 23.9, 0.43)


 # Load the libraries
library (arules)
library (arulesViz)
library (datasets)
data (Groceries) # Load the data set
transDat <- Groceries
transDat <- as (myDataFrame, "transactions") # convert to 'transactions' class
inspect (transDat) # view the observations
length (transDat) # get number of observations
size (transDat) # number of items in each observation
LIST(transDat) # convert 'transactions' to a list, note the LIST in CAPS
frequentItems <- eclat (Groceries, parameter = list(supp = 0.07, maxlen = 15)) # calculates support for frequent items
itemFrequencyPlot (Groceries,topN=10,type="absolute") # plot frequent items
rules <- apriori (Groceries, parameter = list(supp = 0.001, conf = 0.5)) # Min Support as 0.001, confidence as 0.8.
quality(rules) # show the support, lift and confidence for all rules
# Show the top 5 rules, but only 2 digits
options (digits=2)
inspect (rules[1:5])
rules <- sort (rules, by="confidence", decreasing=TRUE) # 'high-confidence' rules.
rules <- apriori (Groceries, parameter = list (supp = 0.001, conf = 0.5, maxlen=3)) # maxlen = 3 limits the elements in a rule to 3
redundant <- which (colSums (is.subset (rules, rules)) > 1) # get redundant rules in vector
rules <- rules[-redundant] # remove redundant rules
rules <- apriori (data=Groceries, parameter=list (supp=0.001,conf = 0.08),
	appearance = list (default="lhs",rhs="whole milk"), control = list (verbose=F)) # get rules that lead to buying 'whole milk'
rules <- apriori (data=Groceries, parameter=list (supp=0.001,conf = 0.15,minlen=2),
	appearance = list (default="rhs",lhs="whole milk"), control = list (verbose=F)) # those who bought 'milk' also bought..
rules <- sort (rules, decreasing=TRUE,by="confidence")
redundant <- which (colSums(is.subset(rules, rules)) > 1) # get redundant rules in vector
rules <- rules[-redundant] # remove redundant rules inspect (rules[1:7])
discretize (x, method="cluster", categories=3) # method can make cuts in equal "intervals", "frequency", "cluster", "fixed"
# Interactive Plot
plot (rules[1:25],method="graph",interactive=TRUE,shading="confidence") # feel free to expand and move around the objects in this plot
plot (rules, measure=c("support", "lift"), shading="confidence")
affinity(transDat) # Calculates affinity - the 'nxn' Jaccard Index affinity matrix
transDat_c <- addComplement(transDat, "Item 1") # Adds "Item 1" to all transactions in transDat
duplicated(rules) # find out if any rule is duplicated


# Program to check if
# the input number is
# prime or not

# take input from the user
num = as.integer(readline(prompt="Enter a number: "))

flag = 0
# prime numbers are greater than 1
if(num > 1) {
    # check for factors
    flag = 1
    for(i in 2:(num-1)) {
        if ((num %% i) == 0) {
            flag = 0
            break
        }
    }
}

if(num == 2)    flag = 1
if(flag == 1) {
    print(paste(num,"is a prime number"))
} else {
    print(paste(num,"is not a prime number"))
}


#Example: Wage data

library(ISLR); library(ggplot2); library(caret);
data(Wage); Wage <- subset(Wage,select=-c(logwage))
summary(Wage)

#Get training/test sets

inTrain <- createDataPartition(y=Wage$wage,
                               p=0.7, list=FALSE)
training <- Wage[inTrain,]; testing <- Wage[-inTrain,]
dim(training); dim(testing)

#Feature plot

featurePlot(x=training[,c("age","education","jobclass")],
            y = training$wage,
            plot="pairs")

#Plot age versus wage

qplot(age,wage,data=training)

#Plot age versus wage colour by jobclass

qplot(age,wage,colour=jobclass,data=training)

#Plot age versus wage colour by education

qplot(age,wage,colour=education,data=training)

#Fit a linear model

#$$ ED_i = b_0 + b_1 age + b_2 I(Jobclass_i="Information") + \sum_{k=1}^4 \gamma_k I(education_i= level k) $$

 modFit<- train(wage ~ age + jobclass + education,
 method = "lm",data=training)
finMod <- modFit$finalModel
print(modFit)

#Education levels: 1 = HS Grad, 2 = Some College, 3 = College Grad, 4 = Advanced Degree

#Diagnostics

plot(finMod,1,pch=19,cex=0.5,col="#00000010")

#Color by variables not used in the model

qplot(finMod$fitted,finMod$residuals,colour=race,data=training)

#Plot by index

plot(finMod$residuals,pch=19)

#Predicted versus truth in test set

pred <- predict(modFit, testing)
qplot(wage,pred,colour=year,data=testing)

# A Way to determine if your analysis worked or not.

#If you want to use all covariates, model fit with all of the variables in the data set.

modFitAll<- train(wage ~ .,data=training,method="lm")
pred <- predict(modFitAll, testing)
qplot(wage,pred,data=testing)

#Often useful in combination with other models

Predicting with Regression Multiple Covariates.r


TernarySearch  <- function(left, right, f, eps=1e-4){
  while(TRUE){
    if (abs(left - right) < eps) return((left + right) / 2)

    leftThird  <- left + (right - left) / 3
    rightThird <- right - (right - left) / 3

    if (f(leftThird) > f(rightThird))
      left <- leftThird
    else
      right <- rightThird
  }

}


#' Interarrival times and arrival times of a poisson process
#'
#' @param rate The rate/intensity of the arrivals in the poisson process
#' @param events The number of events in the process (or \code{NULL} if defining
#'   the cut off point by the time)
#' @param time.running The amount of time for the process to run (or \code{NULL}
#'   if defining the cut off by the number of events)
#' @return An numeric matrix with 2 columns. The first column contains the interarrival
#'   times and the second contains the arrival times.
#' @export
#'
poisson.process = function(rate = 1, events = NULL, time.running = NULL) {
  stopifnot(!all(c(is.null(events), is.null(time.running))))
  stopifnot(rate > 0)
  if(is.null(time.running)) {
    times = rexp(events, rate)
    results = mclapply(seq_len(events), FUN = function(i) c(times[i], sum(times[1:i])))
    return(do.call(rbind,results))
  } else {
    times = rexp(ceiling(time.running*rate), rate)
    results = mclapply(seq_len(length(times)), FUN = function(i) c(times[i], sum(times[1:i])))
    while(results[[length(results)]][2] < time.running) {
      times = rexp(max(c(10,ceiling(time.running*rate*.1))), rate)
      results_sub = mclapply(seq_len(length(times)), FUN = function(i) {
        c(times[i], results[[length(results)]][2]+sum(times[1:i]))
        })
      results = append(results, results_sub)
    }
    results = do.call(rbind,results)
    return(results[results[,2] < time.running,])
  }
}


# Example : 1   Chapter : 10.2     Page No: 502
# Orthogonal Complex vectors
i<-complex(real=0,imaginary=1)
u<-matrix(c(1,i),ncol=1)
ut<-t(u)
#take conjugate of ut
ut[1,2]<-Conj(ut[1,2])
v<-matrix(c(i,1),ncol=1)
print("inner product of u and v is conj(u tanspose )* v is  ")
innerproduct<-ut%*%v
print(innerproduct)
print("As innerproduct is zero , they are orthogonal complex vectors")


 ZGGLSE Example Program Results

 Constrained least squares solution
 ( 1.0874,-1.9621) (-0.7409, 3.7297) ( 1.0874,-1.9621) (-0.7409, 3.7297)

 Square root of the residual sum of squares
   1.59E-01


#' Function to calculate weighted standard deviation
#'
#' Calculates the standard deviation of a weighted sample set
#' while propagating sample weights through the calculation.
#' @param x Vector containing the values in the set
#' @param w Vector containing the weights to each value (in
#' the same order as \code{x}
#' the optimized growth model
#' @param na.rm Should NA values be removed from the set prior
#' to calculation? \code{TRUE/FALSE}
#' @return The standard deviation of the weighted set of \code{x} values
#' @examples
#' # Create dummy data
#' x <- seq(1, 10, 0.5)
#' w <- c(seq(0.1, 1, 0.1), seq(0.9, 0.1, -0.1))
#' SDw <- sd_wt(x, w, na.rm = TRUE) # Run the function
#' @export
sd_wt<-function(x, w, na.rm = FALSE){ # Formula for weighted standard deviation
    if(na.rm == TRUE){ # Remove NA containing x/w pairs
        x<-x[!(is.na(x) | is.na(w))]
        w<-w[!(is.na(x) | is.na(w))]
    }
    mean.wt <- mean(x * w, na.rm = TRUE) / mean(w) # Calculate weighted mean
    stdev <- sqrt(sum(w * (x - mean.wt) ^ 2) / ((length(w) - 1) / length(w) * sum(w)))
    return(stdev)
}


#####################################################################################################################################
#ABCDE model2: Model 2 is the model to be run in order to spin up the models initial states
ABCDE_SCE_CALIBRATE <- function(parameters,P,PE,T,Qobs,calib_num) {

	#parameters = a vector with a,b,c,d
	#P	= a vector with precip time series for current station
	#PE	= a vector with potential evapotranspiration time series for current station
	#P	= a vector with tavg time series for current statio
	#Qobs	= a vector with observed streamflow time series for current station			#Sint = initial soil moisture
	#Gint = initial groundwater storage
	#Aint = initial snow accumulation

	parm <- parameters
	Peff <- array(0,calib_num)   	#snow storage
	ETeff <- array(0,calib_num)   	#snow storage
	A <- array(0,calib_num)   	#snow storage
	W <- array(0,calib_num)   	#available water
	Y <- array(0,calib_num)   	#evapotranspiration opportunity
	S <- array(0,calib_num)  	#soil moisture
	E <- array(0,calib_num)  	#actual evaporation
	G <- array(0,calib_num)  	#groundwater storage
	Qest <- array(0,calib_num)   #estimated runoff
	S[1] <- parm[7]
	G[1] <- parm[8]
	A[1] <- parm[9]

	for (i in 2:calib_num) {
		#Begin snow component
		if (T[i] > parm[6]) {
			mt <- min(parm[5]*(T[i]-parm[6])*A[i-1],A[i-1])
			Peff[i] <- P[i]+mt
			ETeff[i] <- PE[i]
			A[i] <- A[i-1] - mt
		} else {
			mt <- 0
			Peff[i] <- 0
			ETeff[i] <- 0
			A[i] <- A[i-1]+P[i]
		}

		W[i] <- Peff[i] + S[i-1]
		#w1 and w2 are intermediate values used to calculate Y
		w1 <- (W[i]+parm[2])/(2*parm[1])
		w2 <- W[i]*parm[2]/parm[1]
		Y[i] <- w1 - sqrt((w1^2)-w2)
		S[i] <- Y[i]*exp(-1*ETeff[i]/parm[2])
		E[i] <- Y[i]*(1-exp(-1*(ETeff[i]/parm[2])))
		G[i] <- (G[i-1] + parm[3]*round((W[i]-Y[i]),2))/(1+parm[4])
		Qest[i] <- (1-parm[3])*round((W[i]-Y[i]),2)+parm[4]*G[i]
	}
	SSE <- (sum(((Qobs) - (Qest))^2))
	return(SSE)
}
#################################################################################################################


dataDirectory <- "D:/DropBox/Dropbox/@Alex_Tutoriaux/"
data <- read.csv(paste(dataDirectory, 'regression.csv', sep=""), header = TRUE)

plot(data, pch=16)
model <- lm(Y ~ X , data)

# make a prediction for each X
predictedY <- predict(model, data)

# display the predictions
points(data$X, predictedY, col = "blue", pch=4)

# This function will compute the RMSE
rmse <- function(error)
{
  sqrt(mean(error^2))
}

error <- model$residuals  # same as data$Y - predictedY
predictionRMSE <- rmse(error)   # 5.703778


library(tidyr)
library(dplyr)
library(leaps)
library(car) #scatterplot matrix
library(glmnet) # ridge and lasso
library(mgcv) # gam
library(randomForest)

# read dataset
data = read.csv(file = "./pmsm_temperature_data.csv")

# inspect the dataset and display the dimensions
cat("The dataset has", dim(data)[1], "records, each with", dim(data)[2],
    "attributes. The structure is:\n\n")

# inspect the structure of data
str(data)

cat("\n Inspect the first few rows and columns in the dataset:")
# Inspect the first few records
head(data)

cat("\n The statistical summary for each attribute:")
# Statistical summary
summary(data)

# plot each attribuite on histogram
par(mfrow = c(2,2))
for (i in colnames(data)[1:9]){
    hist(data[,i], main = paste0("Histogram of"," ", i))
}

# add min value to each of variables so they can be transformed
data$pm_n = data$pm + 5
data$ambient_n = data$ambient + 5
data$coolant_n = data$coolant + 5
data$u_d_n = data$u_d + 5
data$u_q_n = data$u_q + 5
data$motor_speed_n = data$motor_speed + 5
data$torque_n = data$torque + 5
data$i_d_n = data$i_d + 5
data$i_q_n = data$i_q + 5

# apply log transformation to deal with skewed data
par(mfrow=c(2,2))
hist(log(data$coolant_n))
hist(log(data$u_q_n))
hist(log(data$motor_speed_n))
hist(log(data$i_d_n))

# apply square root transformation
par(mfrow = c(2,2))
hist(sqrt(data$coolant_n))
hist(sqrt(data$u_q_n))
hist(sqrt(data$motor_speed_n))
hist(sqrt(data$i_d_n))

# apply cube root transformation
par(mfrow = c(2,2))
hist((data$coolant_n)^(1/3))
hist((data$u_q_n)^(1/3))
hist((data$motor_speed_n)^(1/3))
hist((data$i_d_n)^(1/3))

# plot each pairs of variables
scatterplotMatrix(~ambient+coolant+u_d+u_q+i_d+i_q+motor_speed+torque+pm, data = data, main = "Scatterplot matrix")

# Correlation Coefficients of each pair
cor(data[1:9])

# plot u_d vs i_q and torque
plot(data$u_d, data$i_q)
plot(data$u_d, data$torque)

par(mfrow = c(2,2))
for (i in colnames(data[1:8])){
    plot(data$pm, data[,i], main = paste0("pm vs", " ", i))
}

# subset data into train and test set
train = data %>% filter(profile_id != 72 & profile_id != 81)
test = data %>% filter(profile_id == 72 | profile_id == 81)

# perform best subset selection
reg_fit = regsubsets(pm~ ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q, data = train)
reg_summary = summary(reg_fit)

par(mfrow = c(1,2))

# Find the maximum adj_r2
adj_r2_max = which.max(reg_summary$adjr2)
# Find the minimum Cp and BIC
cp_min = which.min(reg_summary$cp)
bic_min = which.min(reg_summary$bic)

# plot the measurements for each number of variables and
# show the maximum and minmum on the plots as red points
# RSS
plot(reg_summary$rss, xlab = "Number of Variables", ylab = "RSS", type = "l")

# adjusted R2
plot(reg_summary$adjr2, xlab = "Number of Variables", ylab = "Adjusted RSq", type = "l")
points(adj_r2_max, reg_summary$adjr2[adj_r2_max], col ="red", cex = 2, pch = 20)

# Cp
plot(reg_summary$cp, xlab = "Number of Variables", ylab = "Cp", type = "l")
points(cp_min, reg_summary$cp[cp_min], col = "red", cex = 2, pch = 20)

# BIC
plot(reg_summary$bic, xlab = "Number of Variables", ylab = "BIC", type = "l")
points(bic_min, reg_summary$bic[bic_min], col = "red", cex = 2, pch = 20)

# create model
fit1 = lm(pm~ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q, data = train)
# check for statistics and residual plots
summary(fit1)
plot(fit1)

# adding interaction terms that are highly coorelated
fit2 = lm(pm~ ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q + i_q:torque + u_d:torque + u_d:i_q
               + u_q:motor_speed + motor_speed:i_d, data = train)
# check for statistics and residual plots
summary(fit2)
plot(fit2)

# check the influencial points
train[c(4192,4162,4172),]

# exclude the three rows and include other interactions see if it improves the model
fit3 = lm(pm~ ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q + i_q:torque + u_d:torque + u_d:i_q
               + u_q:motor_speed + motor_speed:i_d, data = train[-c(116,4162,4172,4192,4221,4201),])
# check for statistics and residual plots
summary(fit3)
plot(fit3)

# calculate weighted least squares
weights = 1 / lm(abs(fit1$residuals) ~ fit1$fitted.values)$fitted.values^2
# add log and cube root transformation
fit4 = lm(pm~ ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q + i_q:torque + u_d:torque + u_d:i_q
               + u_q:motor_speed + motor_speed:i_d + log(motor_speed_n) + I((u_q)^(1/3)),
          data = train,
          weights = weights)
# check for statistics and residual plots
summary(fit4)
plot(fit4)

# removed torque and motor speed from fit 4
fit5 = lm(pm~ ambient + coolant + u_d + u_q + i_d + i_q + i_q:torque + u_d:torque + u_d:i_q
               + u_q:motor_speed + motor_speed:i_d + log(motor_speed_n) + I((u_q)^(1/3)),
          data = train,
          weights = weights)
# check for statistics and residual plots
summary(fit5)
plot(fit5)

# include all interactions in the model
fit6 = lm(pm ~ (ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q)^2, data = train)
# apply stepwise selection on fit5
fit6_step = step(fit6)
# print summary
summary(fit6_step)
plot(fit6_step)

# To perform Ridge regression, we need to split predictors and target
train_x = model.matrix(pm~ (ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q)^2, train)[,-1]
train_y = train$pm
test_x = model.matrix(pm~ (ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q)^2, test)[,-1]
test_y = test$pm

# use cross validation to find lamda that minimize MSE
cv_ridge = cv.glmnet(train_x, train_y, alpha = 0)
# plot to visualize MSE vs lamda
plot(cv_ridge)
# show the lamda that minimizes MSE
best_lamda = cv_ridge$lambda.min
best_lamda

# fit a ridge regression model to train set
grid = 10^seq(10, -2, length = 100)
ridge_model = glmnet(train_x, train_y, alpha = 0, lambda = grid , thresh = 1e-12)
# predict on test set with best lamda
ridge_pred = predict(ridge_model, s = best_lamda, newx = test_x)

# use cross validation to find lamda that minimize MSE
cv_lasso = cv.glmnet(train_x, train_y, alpha = 1)
# plot to visualize MSE vs lamda
plot(cv_lasso)
# show the lamda that minimizes MSE
best_lamda_la = cv_lasso$lambda.min
best_lamda_la

# fit a lasso regression model to train set
lasso_model = glmnet(train_x, train_y, alpha =1, lambda = grid , thresh = 1e-12)
# predict on test set with best lamda
lasso_pred = predict(lasso_model, s = best_lamda_la, newx = test_x)

# show the coefficients that is not zero in this lasso regression (show the predictors used)
lasso_coef = predict(lasso_model, type = "coefficients", s = best_lamda)[1:14,]
lasso_coef[lasso_coef != 0]

# Generalized additive model
fit7_gam = gam(pm~ ambient + s(coolant) + s(u_d) + s(u_q) + s(motor_speed) + s(torque) + s(i_d) + s(i_q) + i_q:torque +
              u_d:torque + u_d:i_q
               + u_q:motor_speed + motor_speed:i_d, data = train)
summary(fit7_gam)
plot.gam(fit7_gam)

# fit a randomforest tree
fit_rf = randomForest(pm~ambient + coolant + u_d + u_q + motor_speed + torque + i_d + i_q, data = train,
                      mtry = 1, importance = TRUE)
# show important variables
importance(fit_rf)

# use the RMSE function from the house_price example
RMSE <- function(predicted, target) {
    se <- 0
    for (i in 1:length(predicted)) {
        se <- se + (predicted[i]-target[i])^2
    }
    return (sqrt(se/length(predicted)))
}

# function to produce measurements for model comparision
model.accuracy = function(model){
    pred = predict(get(model), test)
    RMSE = RMSE(pred, test$pm)
    AIC = AIC(get(model))
    R2 = summary(get(model))$r.sq
    Result = data.frame(RMSE,AIC,R2)
    return (Result)
}

# dataframe to store measurements
model_comp = data.frame(RMSE = numeric(),
                         AIC = numeric(),
                         R2 = numeric())
# names of models to compare
models = c("fit1", "fit2", "fit3","fit4","fit5", "fit6_step")

# compute RMSE for each linear model
for (i in models){
    model_comp = rbind(model_comp, model.accuracy(i))
    rownames(model_comp) = 1:nrow(model_comp)
}
model_comp

# compare fit6 with fit2 using anova
anova(fit2,fit6_step,test="F")

cat("RMSE of ridge regression:",RMSE(ridge_pred,test_y),"\n")
cat("RMSE of lasso regression:",RMSE(lasso_pred,test_y))

cat("RMSE of GAM:",RMSE(predict(fit7_gam,test),test$pm),"\n")
cat("AIC of GAM:",AIC(fit7_gam),"\n")
cat("R2 of GAM:",summary(fit7_gam)$r.sq,"\n")

rf_pred = predict(fit_rf, test)
RMSE(rf_pred, test$pm)

Electric Rotor Temperature Prediction/src/code_only.r


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

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

#randomly selecting 85 Samples
smp_size1 <- floor(0.83 * nrow(df1))
set.seed(123)
train_ind1 <- sample(seq_len(nrow(df1)), size = smp_size1)

#divinding train and test data
train1 <- df1[train_ind1, ]
test1 <- df1[-train_ind1, ]

#changing the data set into matrix bcz ridgefit takes only matrix
#selecting all the values except FLOW.cm in x
x1<-model.matrix(FLOW.cm.~.,train1)
y1<-as.matrix(train1$FLOW.cm.)

xtest1<-model.matrix(FLOW.cm.~.,test1)
ytest1<-as.matrix(test1$FLOW.cm.)

#generating the model
RidgeMod <- cv.glmnet(x1, y1, alpha=0, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)

#plotting the log(Lamda) vs the Mean Squared Error of the model
plot(RidgeMod,xvar="lambda",label=TRUE,xlab="log(Lambda) of L2 Ridge regularization")

#Best Lambda
best.lambda1 <- RidgeMod$lambda.min
best.lambda1

#getting the coefficients for the best model
predict(RidgeMod, s=best.lambda1, type="coefficients")

#Plotting the best model
fit1 <- RidgeMod$glmnet.fit
plot(fit1,xlab="L2 Norm",main="Degree of freedom")
plot(RidgeMod)

#using the model to predict the values
y_predicted1 <- predict(RidgeMod, newdata=test1,newx=xtest1,s="lambda.min")
ModelTest3<-data.frame(obs=test1$FLOW.cm., pred = y_predicted1)
ModelTest3 <- rename(ModelTest3, pred = X1)
defaultSummary(ModelTest3)
#plotting the actual vs predicted chart
plot(test1$FLOW.cm.,y_predicted1,xlab="actual",ylab="predicted",col = "red")

#Method 2
Control1<-trainControl(method = "cv",number=5)
ridgeFit <- train(FLOW.cm. ~ ., data = train1,method = 'ridge',preProc = c("center", "scale"),trControl = Control1, metric = "Rsquared")
PredictedTest2<-predict(ridgeFit,newdata = test1)
ModelTest2<-data.frame(obs = test1$FLOW.cm., pred=PredictedTest2)
defaultSummary(ModelTest2)
plot(test1$FLOW.cm.,PredictedTest2,xlab="predicted",ylab="actual",col = "red")
plot(ridgeFit)

#calculating the residuals
ResData<-residuals(ridgeFit)
PredictedValues2<-predict(ridgeFit)
plot(train1$FLOW.cm.,ResData,xlab="data")
abline(0,0)


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

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

#randomly selecting 85 Samples
smp_size2 <- floor(0.83 * nrow(df2))
set.seed(123)
train_ind2 <- sample(seq_len(nrow(df2)), size = smp_size2)

#divinding train and test data
train2 <- df2[train_ind2, ]
test2 <- df2[-train_ind2, ]

#changing the data set into matrix bcz ridgefit takes only matrix
#selecting all the values except FLOW.cm in x
x2<-model.matrix(FLOW.cm.~.,train2)
y2<-as.matrix(train2$FLOW.cm.)

xtest2<-model.matrix(FLOW.cm.~.,test2)
ytest2<-as.matrix(test2$FLOW.cm.)

#generating the model
LassoMod <- cv.glmnet(x2, y2, alpha=1, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)

#plotting the log(Lamda) vs the Mean Squared Error of the model
plot(LassoMod,xvar="lambda",label=TRUE,xlab="log(Lambda) of L1 Lasso regularization")

#Best Lambda
best.lambda2 <- LassoMod$lambda.min
best.lambda2

#getting the coefficients for the best model
predict(LassoMod, s=best.lambda2, type="coefficients")

#Plotting the best model
fit2 <- LassoMod$glmnet.fit
plot(fit2,xlab="L1 Norm",main="Degree of freedom")
plot(LassoMod)

#using the model to predict the values
y_predicted4 <- predict(LassoMod, newdata=test2,newx=xtest2,s="lambda.min")
ModelTest5<-data.frame(obs=test2$FLOW.cm., pred = y_predicted4)
ModelTest5 <- rename(ModelTest5, pred = X1)
defaultSummary(ModelTest5)
plot(test2$FLOW.cm.,y_predicted4,xlab="actual",ylab="predicted",col = "blue")

#Method 2
Control3<-trainControl(method = "cv",number=5)
LassoFit <- train(FLOW.cm. ~ ., data = train2,method = 'ridge',preProc = c("center", "scale"),trControl = Control3, metric = "Rsquared")
PredictedTest4<-predict(LassoFit,newdata = test2)
ModelTest6<-data.frame(obs = test2$FLOW.cm., pred=PredictedTest4)
defaultSummary(ModelTest6)
plot(test2$FLOW.cm.,PredictedTest4,xlab="actual",ylab="predicted",col = "blue")
plot(LassoFit)

#calculating the residuals
ResData2<-residuals(LassoFit)
PredictedValues4<-predict(LassoFit)
plot(train2$FLOW.cm.,ResData2,xlab="data")
abline(0,0)


# Demo from: https://rpubs.com/GourabNath/Loopfunctionapplications

library(R.matlab)
library(plotrix)

k.max = 100

data = t(readMat("output00000000_cells_physicell.mat")$cells)
#data = t(readMat("Physicell/output/output00000000_cells_physicell.mat")$cells)
data <- data[!(data [,6]==2),]
data.c = data[,c(2,3,6)]

WSS. <- sapply(1:k.max, function(i){return(kmeans(data.c, centers = i)$tot.withinss)})

# Plot scree plot
plot(1:k.max, WSS., type="l", xlab = "No. of clusters", ylab = "Total WSS", main = "Scree Plot")

#############################################
#                                           #
#       Generate line plot with time vs.    #
#       WSS for different k                 #
#                                           #
#############################################

# Zero setup variables and load files matching expression
k.min = 8
k.max = 20
files <- list.files(pattern = "cells_physicell.mat$")

#First make matrix with rows being files and columns being WSS for different k
run =  matrix(0, nrow=length(files), ncol=(k.max-k.min + 1) )

# Second populate table
for(i in files) {
  data = t(readMat(i)$cells)
  data <- data[!(data [,6]==2),]
  data.c = data[,c(2,3)]

  WSS. <- sapply(k.min:k.max, function(j){return(kmeans(data.c, centers = j, iter.max=30)$tot.withinss)})

  index = as.integer(substr(i, 7, 14)) + 1

  run[index,] = WSS.
}

# Generate plot
matplot(run, type = c("l"),pch=1, col = rainbow(k.max)[k.min:k.max], xlab = "Output #", ylab = "Total WSS", main = "Model 3 WSS over time for different k")
legend("topleft", legend = k.min:k.max, col=rainbow(k.max)[k.min:k.max], pch=20, ncol = 2) # optional legend

#############################################
#                                           #
#       Generate line plot with time vs.    #
#       % A in each cluster                 #
#                                           #
#############################################

# Zero setup variables and load files matching expression
k.min = 20
k.max = 20
files <- list.files(pattern = "cells_physicell.mat$")

#First make matrix with rows being files and columns being WSS for different k
total_percents =  matrix(0, nrow=length(files), ncol=(k.max-k.min + 1) )

# Second populate table
for(i in files) {
  data = t(readMat(i)$cells)
  data <- data[!(data [,6]==2),]
  data.c = data[,c(2,3)]

  WSS. <- sapply(k.min:k.max, function(j) {
    data.t <- data.frame("cluster"=kmeans(data.c, centers = j, iter.max=30)$cluster, "type"=data[,6], "count"=rep(1, length(data[,1])))
    r = as.data.frame.matrix(xtabs(formula=count~cluster + type, data=data.frame("cluster"=kmeans(data.c, centers = j)$cluster, "type"=data[,6], "count"=rep(1, length(data[,1])))))
    r = 100 * r/rowSums(r)

    return(sum(abs(r[,1] - r[,2])/j))
  })

  index = as.integer(substr(i, 7, 14)) + 1

  total_percents[index,] = WSS.
}

# Generate plot
matplot(total_percents, type = c("l"),pch=1, col = rainbow(k.max)[k.min:k.max], xlab = "Output #", ylab = "% segregated", main = "Model 2 percent segregated over time for k=10:20")
 legend("topleft", legend = k.min:k.max, col=rainbow(k.max)[k.min:k.max], pch=20, ncol = 2) # optional legend


# Chaper 5 Lab: Cross-Validation and the Bootstrap

# This code is quoted from
# http://faculty.marshall.usc.edu/gareth-james/ISL/code.html

# The Validation Set Approach

library(ISLR)
set.seed(1)
train=sample(392,196)
lm.fit=lm(mpg~horsepower,data=Auto,subset=train)
attach(Auto)
mean((mpg-predict(lm.fit,Auto))[-train]^2)
lm.fit2=lm(mpg~poly(horsepower,2),data=Auto,subset=train)
mean((mpg-predict(lm.fit2,Auto))[-train]^2)
lm.fit3=lm(mpg~poly(horsepower,3),data=Auto,subset=train)
mean((mpg-predict(lm.fit3,Auto))[-train]^2)
set.seed(2)
train=sample(392,196)
lm.fit=lm(mpg~horsepower,subset=train)
mean((mpg-predict(lm.fit,Auto))[-train]^2)
lm.fit2=lm(mpg~poly(horsepower,2),data=Auto,subset=train)
mean((mpg-predict(lm.fit2,Auto))[-train]^2)
lm.fit3=lm(mpg~poly(horsepower,3),data=Auto,subset=train)
mean((mpg-predict(lm.fit3,Auto))[-train]^2)

# Leave-One-Out Cross-Validation

glm.fit=glm(mpg~horsepower,data=Auto)
coef(glm.fit)
lm.fit=lm(mpg~horsepower,data=Auto)
coef(lm.fit)
library(boot)
glm.fit=glm(mpg~horsepower,data=Auto)
cv.err=cv.glm(Auto,glm.fit)
cv.err$delta
cv.error=rep(0,5)
for (i in 1:5){
 glm.fit=glm(mpg~poly(horsepower,i),data=Auto)
 cv.error[i]=cv.glm(Auto,glm.fit)$delta[1]
 }
cv.error

# k-Fold Cross-Validation

set.seed(17)
cv.error.10=rep(0,10)
for (i in 1:10){
 glm.fit=glm(mpg~poly(horsepower,i),data=Auto)
 cv.error.10[i]=cv.glm(Auto,glm.fit,K=10)$delta[1]
 }
cv.error.10

# The Bootstrap

alpha.fn=function(data,index){
 X=data$X[index]
 Y=data$Y[index]
 return((var(Y)-cov(X,Y))/(var(X)+var(Y)-2*cov(X,Y)))
 }
alpha.fn(Portfolio,1:100)
set.seed(1)
alpha.fn(Portfolio,sample(100,100,replace=T))
boot(Portfolio,alpha.fn,R=1000)

# Estimating the Accuracy of a Linear Regression Model

boot.fn=function(data,index)
 return(coef(lm(mpg~horsepower,data=data,subset=index)))
boot.fn(Auto,1:392)
set.seed(1)
boot.fn(Auto,sample(392,392,replace=T))
boot.fn(Auto,sample(392,392,replace=T))
boot(Auto,boot.fn,1000)
summary(lm(mpg~horsepower,data=Auto))$coef
boot.fn=function(data,index)
 coefficients(lm(mpg~horsepower+I(horsepower^2),data=data,subset=index))
set.seed(1)
boot(Auto,boot.fn,1000)
summary(lm(mpg~horsepower+I(horsepower^2),data=Auto))$coef


# take input from the user
num = as.integer(readline(prompt="Enter a number: "))
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))
}

x <- 0
if (x < 0) {
print("Negative number")
} else if (x > 0) {
print("Positive number")
} else
print("Zero")

x <- 1:5
for (val in x) {
if (val == 3){
next
}
print(val)
}

x <- 1
repeat {
print(x)
x = x+1
if (x == 6){
break
}
}

`%divisible%` <- function(x,y)
{
if (x%%y ==0) return (TRUE)
else          return (FALSE)
}

switch("length", "color" = "red", "shape" = "square", "length" = 5)
[1] 5

recursive.factorial <- function(x) {
if (x == 0)    return (1)
else           return (x * recursive.factorial(x-1))
}

pow <- function(x, y) {
# function to print x raised to the power y
result <- x^y
print(paste(x,"raised to the power", y, "is", result))
}

A <- read.table("x.data", sep=",",
                col.names=c("year", "my1", "my2"))
nrow(A)                                 # Count the rows in A

summary(A$year)

A$newcol <- A$my1 + A$my2               # Makes a new
newvar <- A$my1 - A$my2                 # Makes a
A$my1 <- NULL                           # Removes
str(A)
summary(A)
library(Hmisc)
contents(A)
describe(A)

set.seed(102)                           # This yields a good illustration.
x <- sample(1:3, 15, replace=TRUE)
education <- factor(x, labels=c("None", "School", "College"))
x <- sample(1:2, 15, replace=TRUE)
gender <- factor(x, labels=c("Male", "Female"))
age <- runif(15, min=20,max=60)

D <- data.frame(age, gender, education)
rm(x,age,gender,education)
print(D)

# Table about education
table(D$education)

# Table about education and gender --
table(D$gender, D$education)
# Joint distribution of education and gender --
table(D$gender, D$education)/nrow(D)

# Add in the marginal distributions also
addmargins(table(D$gender, D$education))
addmargins(table(D$gender, D$education))/nrow(D)

# Generate a good LaTeX table out of it --
library(xtable)
xtable(addmargins(table(D$gender, D$education))/nrow(D),
       digits=c(0,2,2,2,2))

by(D$age, D$gender, mean)
by(D$age, D$gender, sd)
by(D$age, D$gender, summary)

a <- matrix(by(D$age, list(D$gender, D$education), mean), nrow=2)
rownames(a) <- levels(D$gender)
colnames(a) <- levels(D$education)
print(a)
print(xtable(a))

dat <- read.csv(file = "files/dataset-2013-01.csv", header = TRUE)
interim_object <- data.frame(rep(1:100, 10),
                             rep(101:200, 10),
                             rep(201:300, 10))
object.size(interim_object)
rm("interim_object")
ls()
rm(list = ls())

vector1 <- c(5,9,3)
vector2 <- c(10,11,12,13,14,15)
array1 <- array(c(vector1,vector2),dim = c(3,3,2))
vector3 <- c(9,1,0)
vector4 <- c(6,0,11,3,14,1,2,6,9)
array2 <- array(c(vector1,vector2),dim = c(3,3,2))
matrix1 <- array1[,,2]
matrix2 <- array2[,,2]
result <- matrix1+matrix2
print(result)

column.names <- c("COL1","COL2","COL3")
row.names <- c("ROW1","ROW2","ROW3")
matrix.names <- c("Matrix1","Matrix2")
result <- array(c(vector1,vector2),dim = c(3,3,2),dimnames = list(row.names,
   column.names, matrix.names))
print(result[3,,2])
print(result[1,3,1])
print(result[,,2])

# Load the package required to read JSON files.
library("rjson")
result <- fromJSON(file = "input.json")
print(result)

x <- c(151, 174, 138, 186, 128, 136, 179, 163, 152, 131)
y <- c(63, 81, 56, 91, 47, 57, 76, 72, 62, 48)
relation <- lm(y~x)
print(relation)

relation <- lm(y~x)
png(file = "linearregression.png")
plot(y,x,col = "blue",main = "Height & Weight Regression",
abline(lm(x~y)),cex = 1.3,pch = 16,xlab = "Weight in Kg",ylab = "Height in cm")
dev.off()

data <- c("East","West","East","North","North","East","West","West","West","East","North")
print(data)
print(is.factor(data))
factor_data <- factor(data)
print(factor_data)
print(is.factor(factor_data))

v <- c(7,12,28,3,41)

# Give the chart file a name.
png(file = "line_chart_label_colored.jpg")
plot(v,type = "o", col = "red", xlab = "Month", ylab = "Rain fall", main = "Rain fall chart")


x <- c(1,2,3,4,5,6)   # Create ordered collection (vector)
y <- x^2              # Square the elements of x
print(y)              # print (vector) y
mean(y)               # Calculate average (arithmetic mean) of (vector) y; result is scalar
var(y)                # Calculate sample variance
lm_1<- lm(y ~ x)     # Fit a linear regression model "y = f(x)" or "y = B0 + (B1 * x)"
# store the results as lm_1
print(lm_1)           # Print the model from the (linear model object) lm_1


library("ggplot2")
heights <- c(170, 151, 174, 197, 177, 194, 173, 180, 186, 185, 175, 163, 160, 178, 190, 170, 169, 183, 182, 180, 176, 176, 164, 180, 166, 168, 167, 186, 165)

getmode <- function(v) {
   uniqv <- unique(v)
   uniqv[which.max(tabulate(match(v, uniqv)))]
}

result.mean <- mean(heights)
print(result.mean)

result.med <- median(heights)
print(result.med)

result.mode <- getmode(heights)
print(result.mode)

result.var <- sd(heights)
print(result.var)

result.gm_mean <- prod(heights)^(1/(length(heights)))
print(result.gm_mean)

result.hm_mean <- 1/mean(1/heights)
print(result.hm_mean)

hist(heights, plot=TRUE, xlab="Students' heights")

boxplot(heights, xlab="Students' heights", horizontal=TRUE)

n <- length(heights)
p <- (1 : n) / n - 0.5 / n

PP = data.frame(emp=(1:n)/n, theor=pnorm(sort(heights), result.mean, result.var))
ggplot(PP,aes(x=emp, y=theor)) + geom_abline(intercept=0, slope=1, colour="blue") + geom_point() + labs(y="", x="", title="P-P plot")

QQ = data.frame(emp=sort(heights), theor=qnorm((1:n)/n, result.mean, result.var))
QQ_plot <- ggplot(QQ, aes(x = emp, y = theor), colour = "blue")
QQ_plot + geom_abline(intercept=0, slope=1, colour="red") + geom_point() + labs(y="", x="", title="Q-Q plot")


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 1   Chapter : 2.6   Pageno : 96
# LU Factorisation
library(pracma)
A<-matrix(c(2,1,0,1,2,1,0,1,2),ncol=3)
print("LU factorisation of A is")
print(lu(A))
# The answers may vary due to rounding off values


library(signal)

# CIC filter parameters
R <- 5                         # Decimation factor
M <- 1                         # Differential delay
N <- 6                         # Number of stages

Fo <- 0.22                     # Pass band edge

# fir2 parameters
k <- kaiserord(c(Fo, Fo+0.02), c(1, 0), 1/(2^16), 1)
L <- k$n                       # Filter order
Beta <- k$beta                 # Kaiser window parameter

# FIR filter design using fir2
s <- 0.001                     # Step size
fp <- seq(0.0, Fo, by=s)       # Pass band frequency samples
fs <- seq(Fo+0.02, 0.5, by=s)  # Stop band frequency samples
f <- c(fp, fs)*2               # Normalized frequency samples; 0<=f<=1

Mp <- matrix(1, 1, length(fp)) # Pass band response; Mp[1]=1
Mp[-1] <- abs(M*R*sin(pi*fp[-1]/R)/sin(pi*M*fp[-1]))^N
Mf <- c(Mp, matrix(0, 1, length(fs)))

h <- fir2(L, f, Mf, window=kaiser(L+1, Beta))

# Print filter coefficients
paste(as.character(h), collapse=", ")

fh <- freqz(h)

op <- par(mfrow = c(1, 2))

plot(f, Mf, type = "b", ylab = "magnitude", xlab = "Frequency", xlim = c(0, 0.5))
lines(fh$f / pi, abs(fh$h), col = "blue")

plot(f, 20*log10(Mf+1e-5), type = "b", ylab = "dB", xlab = "Frequency", xlim = c(0, 0.5))
lines(fh$f / pi, 20*log10(abs(fh$h)), col = "blue")

par(op)


#=============CREATING MAPS===========================================
#Fish 554, Beautiful Graphics in R.
#Different projections, creating a map of your study site
#By Trevor A. Branch tbranch@uw.edu Jan 2020, with reliance on lecture
#notes from Allan Hicks and Elizabeth Ng.
#Examples from: Eric Anderson, Dawn Barlow, Mike Johns, and more.
#=====================================================================
library(tidyverse)
library(ggmap)
library(ocedata)
library(RgoogleMaps)
library(maps)
library(maptools)
library(mapproj)
library(mapdata)
library(marmap)
library(units)
library(sf)
library(rgeos)

#===========ggplot with geom_polygon==================================
#These examples selected from Eric Anderson
#http://eriqande.github.io/rep-res-web/lectures/making-maps-with-R.html
#=====================================================================
library(tidyverse) #including ggplot2
library(ggmap)     #contains useful mapping data

#Useful options in map_data include usa, state, county,
#world (0? in middle), and world2 (180? in middle)
usa <- map_data('usa')
head(usa)

#the group command explains which polygons belong together, one
#polygon for each island on the map
ggplot(data=usa, aes(x=long, y=lat, group=group)) +
  geom_polygon()

#need to fix the relation between 1deg latitude and 1deg longitude
#at the equator this is 1:1 but nearer the poles it gets very large
ggplot(data=usa, aes(x=long, y=lat, group=group)) +
  geom_polygon() +
  coord_fixed(ratio=1.25) #ratio of longitude to latitude

#1 deg latitude divided by cos(latitude in radians) gives this ratio
#The ratio varies by latitude and maps usually go across many latitudes
#therefore it is necessary to use **projections** to ensure that
#maps are appropriately scaled.
LatitudeDeg <- 47.606  #Seattle
1/cos(LatitudeDeg/180*pi)

LatitudeDeg <- 29.7604  #Houston differs quite a lot
1/cos(LatitudeDeg/180*pi)

#The states data
states <- map_data('state')
head(states)

#color by state
ggplot(data=states, aes(x=long, y=lat, group=group, fill=region)) +
  geom_polygon() + theme_minimal() +
  coord_fixed(ratio=1.25) +  #ratio of longitude to latitude
  theme(legend.position='none') #remove the legend

#nice-ish map of the US showing states
#tidy up lat and long labels, change the transparency
#add some points
states <- map_data('state')
ggplot(data=states, aes(x=long, y=lat, group=group, fill=region)) +
  coord_fixed(ratio=1.25) +  #ratio of longitude to latitude
  theme_minimal() +
  geom_polygon(alpha=0.4, col='white') + #state boundaries
  theme(legend.position='none',
        axis.title = element_blank()) +  #remove the legend
  scale_x_continuous(breaks=seq(-70,-120,-10),  #where to place the values
                     labels=paste0(seq(70,120,10),'W')) +
  scale_y_continuous(breaks=seq(25,50,5),  #where to place the values
                   labels=paste0(seq(25,50,5),'N')) +
  geom_point(aes(x=-122.3321, y= 47.6062), size=2) + #add point
  geom_text(aes(x=-122.3321, y= 47.6062, label='Seattle'),
            nudge_x=4.5, color='gray20', size=4)  #add text

#=============Chloropleth map with geom_polygon=======================
#Unemployment rates in Washington state during 2009 recession
#by county
#Full data set: http://datasets.flowingdata.com/unemployment09.csv
#=====================================================================
library(tidyverse) #including ggplot2
library(ggmap)     #contains useful mapping data
counties <- map_data("county")
WA_county <- subset(counties, region == "washington")
head(WA_county)

unemp <- read_csv('Data\\unemployment09WA.csv')
#change county names to lower case to match map_data names
unemp$subregion <- str_to_lower(unemp$subregion)
head(unemp)

#join the two datasets together
WA_county_unemp <- left_join(x=WA_county, y=unemp, by='subregion')
head(WA_county_unemp)

#use unemployment as the color
ggplot(data=WA_county_unemp, aes(x=long, y=lat, group=group,
                                 fill=Unemployment)) +
  geom_polygon(color='white') + #county outline in white
  theme_minimal() +
  coord_fixed(ratio=1.48)  #ratio of longitude to latitude in Washington

#fix the axes, titles, change the color scales, etc.
ggplot(data=WA_county_unemp, aes(x=long, y=lat, group=group,
                                 fill=Unemployment)) +
  geom_polygon(color='white') + #county outline in white
  theme_minimal() +
  theme(legend.title = element_blank(),
        axis.title = element_blank()) +
  coord_fixed(ratio=1.48) +  #ratio of longitude to latitude in Washington
  labs(title='Unemployment in Washington in 2009 (%)') +
  scale_x_continuous(breaks=seq(-125,-117,2),  #where to place the values
                     labels=paste0(seq(125,117,-2),'W')) +
  scale_y_continuous(breaks=seq(46,49,1),  #where to place the values
                     labels=paste0(seq(46,49,1),'N')) +
  scale_fill_continuous(high = '#132B43', low = '#56B1F7')

#save the file, to ensure result is device-independent
#I always save figures to a subdirectory "Figs"
ggsave('Figs\\WA unemployment class.png', dpi=600, width=9, height=7)

#=====Earthquakes using marmap package with bathymetry/topography=====
#Data and maps showing bathymetry and topography
#Depth/height from the 'ETOPO1' dataset. The marmap package is here:
#Pante E & Simon-Bouhet B (2013) PLoS ONE 8(9): e73051.
#https://journals.plos.org/plosone/article?id=10.1371/journal.pone.0073051
#Code idea: Dawn Barlow.
#Earthquake data downloaded 2/29/2020 from:
#https://earthquake.usgs.gov/earthquakes/search/
#=====================================================================

#installing marmap can take 30-60 seconds
#make sure R is up to date (v 4.0.x) with "version" in console
library(rgdal)  #may need to reinstall
library(raster) #may need to reinstall
library(marmap)
library(tidyverse)

#get the bathymetry from NOAA. Resolution in minutes, default = 4,
#minimum = 1. Smaller = higher resolution and longer times
#keep=TRUE writes downloaded data into a file
bathy <- getNOAA.bathy(lon1=-130, lon2=-118, lat1=40, lat2=50,
            resolution=2, keep=FALSE)

#create a ggplot object appropriate to the bathy data object
map <- autoplot(bathy, geom=c('raster', 'contour'),
                show.legend=FALSE) +     #turn off legend
  scale_fill_etopo() +                   #special colors
  theme(axis.title = element_blank()) +  #remove the axis titles
  scale_x_continuous(breaks=seq(-130,-118, 2),  #where to place the values
                     labels=paste0(seq(130,118, -2),'W'),
                     expand = c(0, 0)) +
  scale_y_continuous(breaks=seq(40,50,2),  #where to place the values
                     labels=paste0(seq(40,50,2),'N'),
                     expand = c(0, 0))
map

#add earthquakes to the map, all >2.5 magnitude in 2019
#40-50N and 118-130W, downloaded from
#https://earthquake.usgs.gov/earthquakes/search/
quakes <- read_csv(file='Data\\PNW earthquakes 2019.csv')
quakes
map + geom_point(data = quakes,
          aes(x=longitude, y=latitude, size=mag),
          shape=21, fill='#00000044', color='black') +
  labs(title='Earthquakes in 2019')
ggsave('Figs\\PNW earthquakes.png', width=8, height=10, dpi=600)

#=================PROJECTIONS ggplot==================================
#Plot of sea surface temperature around Antarctica
#Data and code slightly modified from Mike Johns mjohns@pointblue.org
#Point Blue Conservation Science
#Website: http://www.michaelejohns.com/dataviz
#=====================================================================

library(tidyverse)
#read_csv does not work, so I used read.csv
data.f <- read.csv(file='Data\\SH20190130SST.csv')
tail(data.f) #temp = NA when on land

#colors to use
col.p <- c("#B50012","#E60307","#F6421E","#F67F38","#FEC66E",
           "#FEFDA7","#EEF9CC","#B2DEEB","#6FA8CF","#3C65AB",
           "#2E3E96")

globe <- ggplot() +
  geom_point(data=data.f,
             aes(x=Var1, y=Var2, color=temp),
             shape=16) +

  #NA values for sea surface temperature are on land, hence gray
  scale_color_gradientn(colors=rev(col.p),na.value="grey30") +
  scale_x_continuous(expand = c(1,1)) +

  #orientation = where South Pole is, in latitude & longitude,
  #and then the rotation (mid longitude in degrees of
  #the map). Orthographic projection = earth as seen from
  #infinitely far away, i.e. as a globe.
  coord_map(projection='orthographic',
            orientation=c(-90, -175, 0)) +
  theme_minimal() +
  theme(axis.title=element_blank(),
        axis.text=element_blank() )
globe #this takes some time: around 1-2 minutes on my computer

#gets sent to directory called Figs.
ggsave(filename='Figs\\SH20190130SST test.png', plot=globe,
       width=6, height=6, dpi=300)

#=====================sf package======================================
#powerful package that allows for projections and many GIS functions
#including distance from points and lines, intersections
#and other such things only GIS software contains.
#=====================================================================
library(units)
library(sf)
library(maps)
library(rgeos)

usa <- st_as_sf(x=maps::map('usa', plot = FALSE, fill = TRUE))
ggplot() + geom_sf(data = usa)

laea <- st_crs(x='+proj=laea +lat_0=30 +lon_0=-95') #Lambert equal area
usa <- st_transform(x=usa, crs=laea)
ggplot() + geom_sf(data = usa)

#makes the nc dataset available for North Carolina
demo(nc, ask = FALSE, echo = FALSE)

#what is inside the nc dataset?
nc

#plot chloropleth map for one column (BIR74) in the nc dataset
ggplot() +
  geom_sf(data = nc, aes(fill = BIR74)) + #BIR74 is data column in nc
  scale_y_continuous(breaks = 34:36) +    #latitude tickmarks
  theme_minimal()

#********************ADDITIONAL CODE FOR INTEREST*********************
#not covered in lecture

#===================ggmap using google maps terrain data==============
#for easy maps with terrain, taken from google maps
#From Eric Anderson
#http://eriqande.github.io/rep-res-web/lectures/making-maps-with-R.html
#=====================================================================
library(ggmap)
library(ggplot2)
randomlats <- runif(n=30, min=45, max=49)
randomlons <- runif(n=30, min=-122, max=-118)
randomdata <- data.frame(lats=randomlats, lons=randomlons)
wa_bbox <- make_bbox(data = randomdata, lat = lats, lon = lons)
wa_bbox

# grab terrain map from google
wa_terrain <- get_map(location = wa_bbox, source = 'google',
                      maptype = 'terrain')
ggmap(wa_terrain) +
  geom_point(data=randomdata,
             mapping=aes(x=lons, y=lats),
             color='blue', size=4)


#' Compress lpo using Haar-wavelet transform.
#'
#' The time series is transformed using Haar-wavelet transform,
#' then the near-zero-values will be rounded to zero to an extend
#' and the series will be decoded, creating a new, compressed
#' version of the original series.
#' @param lpo Times series as numeric vector
#' @param level Compression level, from 0 to 1
#' @export
#'
#' @importFrom stats ts quantile
#'
#' @examples
#' set.seed(1)
#' d <- squares(100)
#' lpo <- d[, 1]
#' lpm <- compress.lpo(lpo, 0.9)
#' plot(ts(lpo))
#' lines(ts(lpm), col = "red")

compress.lpo <- function(lpo, level = 0.99) {

  l <- length(lpo)
  lpo <- ts(c(lpo, rep(0, 2^ceiling(log(l, base = 2)) - l)))
  trans <- wavelets::dwt(lpo, filter="haar")
  w.vector.length <- l / 2
  w.vector <- numeric()
  for (i in 1:trans@level) {
    w.vector <- append(abs(trans@W[i][[1]]), w.vector)
  }
  limit <- quantile(w.vector, level)

  for (i in 1:trans@level) {
    trans@W[i][[1]][abs(trans@W[i][[1]]) <= limit] <- 0
  }

  res <- wavelets::idwt(trans)
  res <- res[1:l]
  return (res)
}


library(survival)
library(survminer)
datos <- read.table("D:/Users/alejandro/Desktop/MECI Supervivencia/ADDICTS.txt", header = TRUE, sep = ",")
datos<-datos[,-1]

#% de censuras
sum(datos$Status)/length(datos$Status)

#Supervivencia global con intervalo de confianza
addict.global <- survfit(Surv(Days.survival,Status) ~ 1, type = "kaplan-meier", data =datos)
plot(addict.global, xlab = "Dias hasta la salida de la clinica", ylab = "S(t)", conf.int = TRUE)
ggsurvplot(addict.global,
           pval = TRUE, conf.int = TRUE,
           risk.table = TRUE, # Add risk table
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           palette = c("#E7B800", "#2E9FDF"))

#Riesgo segun clinica
addict.clinic <- survfit(Surv(Days.survival,Status)~Clinic,data = datos)
ggsurvplot(addict.clinic,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Clínica 1", "Clínica 2"),
           fun = "cumhaz",
           palette = c("#E7B800", "#2E9FDF"))

#Riesgo segun la prision
sum(datos$Prison==1)/nrow(datos)

addict.prision <- survfit(Surv(Days.survival,Status)~Prison,data = datos)
ggsurvplot(addict.prision,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Sin Antecedentes", "Con Antecedentes"),
           fun = "cumhaz",
           palette = c("#99ff99","#994d00"))

#Riesgo segun la dosis

DoseLevel<-cut(datos$Dose,c(0,60,100,max(datos$Dose)),labels=c("Baja","Media","Alta"))
DoseLevel<-cut(datos$Dose,c(0,60,max(datos$Dose)),labels=c("Baja","Alta"))

hist(datos$Dose,col="#99ff99")
abline(v=60,col="red")
abline(v=100,col="red")

as.numeric(DoseLevel)
datos<-cbind(datos,DoseLevel)

#Riesgo segun la clinica

#Riesgo segun la dosis
addict.dose <- survfit(Surv(Days.survival,Status)~DoseLevel,data = datos)
ggsurvplot(addict.dose,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Baja","Alta"),
           fun = "cumhaz",
           palette = c("#49c06d","#ee514c"))

DoseLevel<-as.numeric(datos$DoseLevel)-1
datos$DoseLevel<-DoseLevel

#Modelo de Cox

#Sin estratificar

cox.clin <- coxph(Surv(Days.survival,Status) ~ (Clinic+Prison+DoseLevel),data = datos,x = T)
cox.clin

#Test de riesgos proporcionales
testrp <- cox.zph(cox.clin)
testrp

par(mfrow=c(2,2))
plot(testrp)

#Estratificado por clinica
cox.clin.s <- coxph(Surv(Days.survival,Status) ~ strata(Clinic)+Prison+DoseLevel,data = datos,x = T)
cox.clin.s

summary(cox.clin.s)

#Test de riesgos proporcionales
testrp <- cox.zph(cox.clin.s)
testrp

plot(testrp)

#library(MASS)
#stepAIC(cox.clin.si,direction="both",trace=100)

cox.clin.s
par(mfrow=c(1,2))
plot(testrp)
#c("martingale", "deviance", "score", "schoenfeld", "dfbeta", "dfbetas", "scaledsch","partial")

#Estratificado por clinica + interaccion prision con dosis

cox.clin.si <- coxph(Surv(Days.survival,Status) ~ strata(Clinic)+Prison+DoseLevel+Prison*DoseLevel,data = datos,x = T)
cox.clin.si
extractAIC(cox.clin.si)

summary(cox.clin.si)
testrp <- cox.zph(cox.clin.si)
testrp

par(mfrow=c(2,2))
plot(testrp)

Inter<-datos$Prison*datos$DoseLevel

datos<-cbind(datos,Inter)

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

#Supervivencia segun clinica
addict.clinic <- survfit(Surv(Days.survival,Status)~Clinic,data = datos)
ggsurvplot(addict.clinic,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Clínica 1", "Clínica 2"),
           palette = c("#E7B800", "#2E9FDF"))

#Supervivencia segun la prision

addict.prision <- survfit(Surv(Days.survival,Status)~Prison,data = datos)
ggsurvplot(addict.prision,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Sin Antecedentes", "Con Antecedentes"),
           palette = c("#99ff99","#994d00"))

#Supervivenciasegun la dosis

DoseLevel<-cut(datos$Dose,c(0,60,max(datos$Dose)),labels=c("Baja","Alta"))

datos$DoseLevel<-DoseLevel

addict.dose <- survfit(Surv(Days.survival,Status)~DoseLevel,data = datos)
ggsurvplot(addict.dose,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           legend.labs = c("Baja","Alta"),
           palette = c("#49c06d","#ee514c"))

#Supervivencia interaccion
addict.doseinter <- survfit(Surv(Days.survival,Status)~Inter,data = datos)
ggsurvplot(addict.doseinter,
           conf.int = TRUE,
           risk.table.col = "strata", # Change risk table color by groups
           linetype = "strata", # Change line type by groups
           ggtheme = theme_bw(), # Change ggplot2 theme
           palette = c("#994d00","#ee514c"))


library(MASS)
library(BAS)
UScrimeData<-as.data.frame(UScrime)
str(UScrimeData)
summary(UScrimeData)

boxplot(UScrimeData)

UScrimeData[,-2] = log(UScrime[,-2])
boxplot(UScrimeData)

USCrimeBas<- bas.lm(y ~ ., data = UScrimeData,prior = 'BIC', modelprior = uniform())
USCrimeBas

summary(USCrimeBas)

image(USCrimeBas, subset=-1)

par(mar=c(2,2,1,1))
par(mgp=c(1,0.5, 0))
par(mfrow=c(2,2))
plot(USCrimeBas)


n<-50
x<-1:n
y<-x

cleanup()
X11()
par( mfcol=c(2,2))
plot(x,y,type='b',main='True signal')
y1<- 5*y * exp(rnorm(n, mean = 0, sd = 0.15))
y2<- 2*y * exp(rnorm(n, mean = 0, sd = 0.75))

yy<-cbind(y1,y2)

matplot(yy,type='b',main='1) observed')

yy1<-yy/rep(apply(yy,2,mean),each=n)
matplot(yy1,type='b',main='2) standardised to the mean')

yy2<-yy1/rep(apply(yy1,2,sd),each=n)
matplot(yy2,type='b',main='3) standardised to mean and the sd')

lm(yy2[,1]~x)
lm(yy2[,2]~x)


 DGEQP3 Example Program Results

 Tolerance used to estimate the rank of A
        1.00E-02
 Estimated rank of A
        4

 Least squares solution(s)
             1          2
 1      0.9767     4.0159
 2      1.9861     2.9867
 3      0.0000     0.0000
 4      2.9927     2.0032
 5      4.0272     0.9976

 Square root(s) of the residual sum(s) of squares
        2.54E-02   3.65E-02