# Support Vector Machine (SVM) classification for machine learning.
#
# SVM is a binary classifier. The objective of the SVM is to find the best
# separating hyperplane in vector space which is also referred to as the
# decision boundary. And it decides what separating hyperplane is the 'best'
# because the distance from it and the associating data it is separating is the
# greatest at the plane in question.

# Importing the data set
dataset = read.csv('Social_Network_Ads.csv')
dataset = dataset[, 3:5]

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
set.seed(123) # choose random number, only same number for debugging
split = sample.split(dataset$Purchased, SplitRatio = 0.75)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Feature scaling, normalize scale is important. Especially on algorithms
# involving euclidian distance. Two main feature scaling formulas are:
# Standardisation: x_stand = (x-mean(x))/(standard_deviation(x))
# Normalisation: x_norm = (x-min(x))/(max(x)-min(x))
training_set[, 1:2] = scale(training_set[, 1:2])
test_set[, 1:2] = scale(test_set[, 1:2])

# Fitting the Classifier Model to the training_set
# install.packages('e1071')
# library(e1071)
classifier = svm(formula = Purchased ~ ., data = training_set,
                 type = 'C-classification', kernel = 'linear')

# Predict the test_set results by using the classifier
y_pred = predict(classifier, newdata = test_set[-3])

# Making the Confusion Matrix
cm = table(test_set[, 3], y_pred)

# Plot the training_set results
# install.packages('ElemStatLearn')
# library(ElemStatLearn)
set = training_set
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(classifier, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set>0.5, 1, 0)
plot(set[, -3],
     main = 'SVM Classifier (Training set)',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))

# Plot the test_set results
# install.packages('ElemStatLearn')
# library(ElemStatLearn)
set = test_set
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(classifier, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set>0.5, 1, 0)
plot(set[, -3],
     main = 'SVM Classifier (testing set)',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))


# A task
foo <- function()
{
   for(i in 1:10)
   {
      mat <- matrix(rnorm(1e6), nrow=1e3)
      mat^-0.5
   }
}
# Time the task
timer <- system.time(foo())
# Extract the processing time
timer["user.self"]


mydata = read.csv(url('https://raw.githubusercontent.com/nfl-football-ops/Big-Data-Bowl/master/Data/games.csv'))
mydata$result_new<-ifelse(mydata$HomeScore>mydata$VisitorScore,1,0)
summary(mydata$result_new)
mylogit1 = glm(result_new~1, family=binomial, data=mydata)
summary(mylogit1)

#mydata$sunnyyes<-ifelse(mydata$GameWeather=='Sunny',1,0)
mydata$sunnyyes <- sapply(mydata$GameWeather, function(x) ifelse(length(grep("sunny",x,ignore.case=TRUE))>0, 1, 0))
mylogit1 = glm(result_new~1, family=binomial, data=mydata)
summary(mylogit1)

mylogit12 = lmer(scorediff~1+(1| stadium_new ) ,  data=mydata)
summary(mylogit12)

mydata$scorediff<-mydata$HomeScore-mydata$VisitorScore
lm_results<-lm(mydata$scorediff~mydata$sunnyyes)
summary(lm_results)

mydata$stadium_new<- sapply(mydata$StadiumType, function(x) ifelse(length(grep("indoor",x,ignore.case=TRUE))>0, 1, 0))
library(lme4)
summary(lmer ( scorediff ~ sunnyyes + ( sunnyyes| StadiumType ) , data= mydata ))


#' Simulate variable based on the influences of other variables
#'
#' I need a function that takes some variables, and an effect size for each of them, and this creates a new variable where y = Xb + e, where X is the matrix of independent variables, b is their effect sizes, and e is a noise term. By default it's easier if b relates to the variance explained by each vector in X, and e has variance of 1 - sum(b).
#'
#' @param effs An array of effect sizes that the variables in indep have on the variable that you are simulating
#' @param indep A matrix of variables, rows = Samples and columns = variables that have an influence on the variable that you are simulating
#' @param vy What variance the output should have. Default = 1, meaning effs relate to the signed rsq of the influence of the indep variables on the outcome
#' @param vx What variance the indep variables should have. Default is to set to 1, meaning that the effects are the signed variance explained
#' @param my mean value of y to be output
#'
#' @export
#' @return Vector of y values
make_phen <- function(effs, indep, vy=1, vx=rep(1, length(effs)), my=0)
{
	if(is.null(dim(indep))) indep <- cbind(indep)
	stopifnot(ncol(indep) == length(effs))
	stopifnot(length(vx) == length(effs))
	cors <- effs * vx / sqrt(vx) / sqrt(vy)
	sc <- sum(cors^2)
	if(sc >= 1)
	{
		print(sc)
		stop("effects explain more than 100% of variance")
	}
	cors <- c(cors, sqrt(1-sum(cors^2)))
	indep <- t(t(scale(cbind(indep, stats::rnorm(nrow(indep))))) * cors * c(vx, 1))
	y <- drop(scale(rowSums(indep)) * sqrt(vy)) + my
	return(y)
}

#' Create genotype matrix
#'
#' @param nid Number of samples
#' @param nsnp Number of SNPs
#' @param af Allele frequency of all SNPs (all SNPs have the same allele frequency)
#'
#' @export
#' @return Matrix of genotypes, rows = individuals, columns = snps
make_geno <- function(nid, nsnp, af)
{
	return(matrix(rbinom(nid * nsnp, 2, af), nid, nsnp))
}

#' Get vector of effects that explain some amount of variance
#'
#' @param nsnp Number of SNPs
#' @param totvar Total variance explained by all SNPs
#' @param sqrt Output effect sizes in terms of standard deviations. Default=TRUE
#' @param mua Constant term to be added to effects. Default = 0
#'
#' @export
#' @return Vector of effects
choose_effects <- function(nsnp, totvar, sqrt=TRUE, mua=0)
{
	eff <- stats::rnorm(nsnp)
	eff <- sign(eff) * eff^2
	aeff <- abs(eff)
	sc <- sum(aeff) / totvar
	out <- eff / sc
	if(sqrt)
	{
		out <- sqrt(abs(out)) * sign(out)
	}
	return(out + mua)
}

#' Convert continuous trait to binary
#'
#' @param y Phenotype vector
#' @param prevalence Disease prevalence. Default = NULL
#' @param threshold Disease threshold Default = NULL
#'
#' @export
#' @return Vector of binary trait
y_to_binary <- function(y, prevalence=NULL, threshold=NULL)
{
	if(is.null(prevalence) & is.null(threshold)) stop("Prevalence or threshold needs to be non-null")
	if(!is.null(prevalence))
	{
		d <- y
		t <- quantile(d, 1-prevalence)
		d[y >= t] <- 1
		d[y < t] <- 0
		return(d)
	}
	if(!is.null(threshold))
	{
		d <- y
		d[y >= threshold] <- 1
		d[y < threshold] <- 0
		return(d)
	}
}

#' Ascertain some proportion of cases and controls from binary phenotype
#'
#' @param d Vector of 1/0
#' @param prop_cases Proportion of 1s to retain
#'
#' @export
#' @return Array of IDs
ascertain_samples <- function(d, prop_cases)
{
	d <- d[!is.na(d)]
	d <- d[d %in% c(0,1)]
	x1 <- sum(d==1)
	x0 <- sum(d==0)
	exp_cases <- x1
	exp_controls <- (x1 - prop_cases * x1) / prop_cases
	if(round(exp_controls) > x0)
	{
		exp_controls <- x0
		exp_cases <- (x0 - (1 - prop_cases) * x0) / (1 - prop_cases)
	}
	i0 <- which(d == 0)
	i0 <- sample(i0, exp_controls, replace=FALSE)
	i1 <- which(d == 1)
	i1 <- sample(i1, exp_cases, replace=FALSE)

	return(sort(c(i0, i1)))
}


n <- 4
coeffSigma <- 1/5

prX1 <- 1-pnorm(coeffSigma)

risposta1 <- prX1 ^ n

risposta2 <- 1-pnorm(sqrt(n)*coeffSigma);

print(risposta1)

print(risposta2)


# http://www.jason-french.com/blog/2014/07/26/recursion-in-r/

#!/usr/bin/env Rscript
# Author:  Jason A. French

quickSort <- function(vect) {
  # Args:
  #  vect: Numeric Vector

  # Stop if vector has length of 1
  if (length(vect) <= 1) {
      return(vect)
  }
  # Pick an element from the vector
  element <- vect[1]
  partition <- vect[-1]
  # Reorder vector so that integers less than element
  # come before, and all integers greater come after.
  v1 <- partition[partition < element]
  v2 <- partition[partition >= element]
  # Recursively apply steps to smaller vectors.
  v1 <- quickSort(v1)
  v2 <- quickSort(v2)
  return(c(v1, element, v2))
}

quickSort(c(4, 65, 2, -31, 0, 99, 83, 782, 1))


LISP Interpreter Run

[[[[ Omega in the limit from below! ]]]]

define (all-bit-strings-of-size k)
    if = 0 k '(())
    (extend-by-one-bit (all-bit-strings-of-size - k 1))

define      all-bit-strings-of-size
value       (lambda (k) (if (= 0 k) (' (())) (extend-by-one-bi
            t (all-bit-strings-of-size (- k 1)))))

define (extend-by-one-bit x)
    if atom x nil
    cons append car x '(0)
    cons append car x '(1)
    (extend-by-one-bit cdr x)

define      extend-by-one-bit
value       (lambda (x) (if (atom x) nil (cons (append (car x)
             (' (0))) (cons (append (car x) (' (1))) (extend-b
            y-one-bit (cdr x))))))

define (count-halt p)
    if atom p 0
    +
    if = success car try t 'eval read-exp car p
       1 0
    (count-halt cdr p)

define      count-halt
value       (lambda (p) (if (atom p) 0 (+ (if (= success (car
            (try t (' (eval (read-exp))) (car p)))) 1 0) (coun
            t-halt (cdr p)))))

define (omega t) cons (count-halt (all-bit-strings-of-size t))
                 cons /
                 cons ^ 2 t
                      nil

define      omega
value       (lambda (t) (cons (count-halt (all-bit-strings-of-
            size t)) (cons / (cons (^ 2 t) nil))))

(omega 0)

expression  (omega 0)
value       (0 / 1)

(omega 1)

expression  (omega 1)
value       (0 / 2)

(omega 2)

expression  (omega 2)
value       (0 / 4)

(omega 3)

expression  (omega 3)
value       (0 / 8)

(omega 8)

expression  (omega 8)
value       (1 / 256)

End of LISP Run

Elapsed time is 0 seconds.


sqldf(
  "select avg(Sepal_Length) as Sepal_Length_Mean, avg(Sepal_Width) as Sepal_Width_Mean
  ,avg(Petal_Length) as Petal_Length_Mean,avg(Petal_Width) as Petal_Width_Mean from iris"
)
print(c(mean(iris$Sepal_Length),mean(iris$Sepal_Width),mean(iris$Petal_Length),mean(iris$Petal_Width)))

R Community/R DaraManipulation Assignments/Assignment2.r


#aula 7
#Clusterização - KMeans
m <- mtcars
plot(m$mpg~m$wt + m$cyl)

#clusterização
set.seed(33)
k<-kmeans(m[,c("mpg","wt")], 4)

plot(m$mpg~m$wt, col=k$cluster, pch=k$cluster)

k$cluster

m$wt_2 <- m$wt*6
k<-kmeans(m[,c("mpg","wt_2")], 4)
plot(m$mpg~m$wt, col=k$cluster, pch=k$cluster)
summary(lm(mpg~wt+as.factor(k$cluster),data=m))

#Mais algoritmos
#ctree

install.packages("e1071")
library("e1071")

treino <- read.csv("train.csv")
teste <-read.csv("test.csv")
t <- read.csv("train.csv")
set.seed(62)
va<-sample(891)
treino<-t[1:600,]
teste <- t[601:891,]
mod<-ctree(Survived~Sex+Pclass+Age+Embarked,data=treino)
p<-predict(mod, newdata=teste)
pred<-ifelse(p<=.401,0,1)
cm <- table(pred,teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall

install.packages("e1071")
library(e1071)

treino <- read.csv("train.csv")
teste <-read.csv("test.csv")
t <- read.csv("train.csv")
# TRATAMENTO DOS DADOS
t[is.na(t$Age),]$Age<-mean(t[!is.na(t$Age),]$Age)
#regressãologistica

set.seed(33)
va<-sample(891)
treino<-t[1:600,]
teste <- t[601:891,]
mod <- glm(Survived~Sex+Pclass+Age,data=treino,family=binomial())
p<-predict(mod, newdata=teste)
pred<-ifelse(p<.5,0,1)
cm <- table(pred,teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall

#randomforest
install.packages("randomForest")
library(randomForest)

t <- read.csv("train.csv")
# TRATAMENTO DOS DADOS
t[is.na(t$Age),]$Age<-mean(t[!is.na(t$Age),]$Age)
#regressãologistica
t$Survived_F<-as.factor(t$Survived)

set.seed(33)
va<-sample(891)
treino<-t[1:600,]
teste <- t[601:891,]
mod <- randomForest(Survived_F~Sex+Pclass+Age,data=treino)
p<-predict(mod, newdata=teste)
#pred<-ifelse(p<.5,0,1)
cm <- table(p,teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall

#svm
install.packages("e1071")
library(e1071)

t <- read.csv("train.csv")
# TRATAMENTO DOS DADOS
t[is.na(t$Age),]$Age<-mean(t[!is.na(t$Age),]$Age)
t$Survived_F<-as.factor(t$Survived)

set.seed(33)
va<-sample(891)
treino<-t[1:600,]
teste <- t[601:891,]
mod <- svm(Survived_F~Sex+Pclass+Age,data=treino)
p<-predict(mod, newdata=teste)
#pred<-ifelse(p<.5,0,1)
cm <- table(p,teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall


# 2-way

rmf.light=read.csv("rmf.light.ini.size.Parameters.csv", header=T, row.names=1)

#Slope
rmf.light.High=rmf.light[2,2]+rmf.light[5,2]*2.97
-0.3265209
rmf.light.Low=rmf.light[2,2]+rmf.light[5,2]*-2.69
0.0298893

#Intercept
rmf.light.High=rmf.light[1,2]+rmf.light[3,2]*2.97
-2.09879
rmf.light.Low=rmf.light[1,2]+rmf.light[3,2]*-2.69
-2.630887

#Plots
plot(exp(final.data$log.rmf), final.data$log.rgr, type="n", xlab="Root Mass Fraction", ylab="Relative Growth Rate", ylim=c(-3,3))
abline(-2.09879,-0.3265209, col="black", lwd=4)
abline(-2.630887,0.0298893, col="blue", lwd=4)
legend("topright", legend=c("Light","High", "Low"),
col=c("NA","black", "blue"), lty=1, lwd=4)

dotchart(rmf.light[2:5,2], labels=rmf.light[2:5,7], xlim=c(-.2,.2), cex=1.5)
abline(v=0, lty=2)
lines(x=c(rmf.light[2,4], rmf.light[2,6]), y=c(1,1), lwd=2)
lines(x=c(rmf.light[3,4], rmf.light[3,6]), y=c(2,2), lwd=2)
lines(x=c(rmf.light[4,4], rmf.light[4,6]), y=c(3,3), lwd=2)
lines(x=c(rmf.light[5,4], rmf.light[5,6]), y=c(4,4), lwd=2)
points(x=rmf.light[2,2], y=1, pch=19)
points(x=rmf.light[3,2], y=2, pch=19)
points(x=rmf.light[4,2], y=3, pch=19)
points(x=rmf.light[5,2], y=4, pch=19)

results <- readRDS("rmf.light.ini.size.jags_results.RData")
rmf.light.results=do.call(rbind,results) # combine output from 6 MCMC chains
rmf.light.sample.df=rmf.light.results[,c(2,5)] # extract columns of parameters needed

rmf.light.Low=rmf.light[2,2]+rmf.light[5,2]*-2.69
0.0298893

rmf.light.slopes=matrix(data=NA, nrow=1559, ncol=1000)

for(i in 1:1000){
row.sample=rmf.light.sample.df[sample(nrow(rmf.light.sample.df), 1),]
rmf.light.output=row.sample[1]+row.sample[2]*final.data$log.light
rmf.light.slopes[,i]=rmf.light.output
}

# regression to get slope and intercept value for plotting

rmf.light.mean=rmf.light[2,2]+rmf.light[5,2]*final.data$log.light

rmf.light.mean.lm=lm(rmf.light.mean~final.data$log.light)

lm.1000=matrix(data=NA, ncol=2, nrow=1000)

for(i in 1:1000){
lin.mod=lm(rmf.light.slopes[,i]~final.data$log.light)
lm.1000[i,1]=lin.mod$coefficients[1] # intercept
lm.1000[i,2]=lin.mod$coefficients[2] # slope
}
# Determine CIs for intercept and slope distributions

quant.intercept=quantile(lm.1000[,1], probs=c(0.025, 0.975))
quant.slope=quantile(lm.1000[,2], probs=c(0.025, 0.975))

CI = -0.1099652 -0.0152051

plot((final.data$log.rmf*final.data$log.light),lma.rmf.light.mean, type="n")
abline(-0.07649, 0.05305, col="black") # mean value
abline(-0.13564211,0.01492716, col="gray") # lower limit
abline(-0.01790535,0.09167430, col="gray") # upper limit


library(vcd)
library(entropy)
library(parmigene)

templates = read.csv('/Users/jcgood/gitrepos/desmeme/EntropyTables.txt', header=TRUE, row.names=1)

violability = table(templates$violability)
names(dimnames(violability)) <- list('violability')
Hviolability = entropy(violability)

conditioning = table(templates$conditioning)
names(dimnames(conditioning)) <- list('conditioning')
Hconditioning = entropy(conditioning)

exceptionality = table(templates$exceptionality)
names(dimnames(exceptionality)) <- list('exceptionality')
Hexceptionality = entropy(exceptionality)

reparability = table(templates$reparability)
names(dimnames(reparability)) <- list('reparability')
Hreparability = entropy(reparability)

foundation = table(templates$foundation)
names(dimnames(foundation)) <- list('foundation')
Hfoundation = entropy(foundation)

stricture = table(templates$stricture)
names(dimnames(stricture)) <- list('stricture')
Hstricture = entropy(stricture)

relations = table(templates$relations)
names(dimnames(relations)) <- list('relations')
Hrelations = entropy(relations)

constituent = table(templates$constituent)
names(dimnames(constituent)) <- list('constituent')
Hconstituent = entropy(constituent)

count = table(templates$count)
names(dimnames(count)) <- list('count')
Hcount = entropy(count)

violabilityviolabilityMI = 0

violabilityconditioning = table(templates$violability,templates$conditioning)
names(dimnames(violabilityconditioning)) <- list('violability','conditioning')
violabilityconditioningMI = mi.shrink(violabilityconditioning)

violabilityexceptionality = table(templates$violability,templates$exceptionality)
names(dimnames(violabilityexceptionality)) <- list('violability','exceptionality')
violabilityexceptionalityMI = mi.shrink(violabilityexceptionality)

violabilityreparability = table(templates$violability,templates$reparability)
names(dimnames(violabilityreparability)) <- list('violability','reparability')
violabilityreparabilityMI = mi.shrink(violabilityreparability)

violabilityfoundation = table(templates$violability,templates$foundation)
names(dimnames(violabilityfoundation)) <- list('violability','foundation')
violabilityfoundationMI = mi.shrink(violabilityfoundation)

violabilitystricture = table(templates$violability,templates$stricture)
names(dimnames(violabilitystricture)) <- list('violability','stricture')
violabilitystrictureMI = mi.shrink(violabilitystricture)

violabilityrelations = table(templates$violability,templates$relations)
names(dimnames(violabilityrelations)) <- list('violability','relations')
violabilityrelationsMI = mi.shrink(violabilityrelations)

violabilityconstituent = table(templates$violability,templates$constituent)
names(dimnames(violabilityconstituent)) <- list('violability','constituent')
violabilityconstituentMI = mi.shrink(violabilityconstituent)

violabilitycount = table(templates$violability,templates$count)
names(dimnames(violabilitycount)) <- list('violability','count')
violabilitycountMI = mi.shrink(violabilitycount)

conditioningviolability = violabilityconditioning
conditioningviolabilityMI = violabilityconditioningMI

conditioningconditioningMI = 0

conditioningexceptionality = table(templates$conditioning,templates$exceptionality)
names(dimnames(conditioningexceptionality)) <- list('conditioning','exceptionality')
conditioningexceptionalityMI = mi.shrink(conditioningexceptionality)

conditioningreparability = table(templates$conditioning,templates$reparability)
names(dimnames(conditioningreparability)) <- list('conditioning','reparability')
conditioningreparabilityMI = mi.shrink(conditioningreparability)

conditioningfoundation = table(templates$conditioning,templates$foundation)
names(dimnames(conditioningfoundation)) <- list('conditioning','foundation')
conditioningfoundationMI = mi.shrink(conditioningfoundation)

conditioningstricture = table(templates$conditioning,templates$stricture)
names(dimnames(conditioningstricture)) <- list('conditioning','stricture')
conditioningstrictureMI = mi.shrink(conditioningstricture)

conditioningrelations = table(templates$conditioning,templates$relations)
names(dimnames(conditioningrelations)) <- list('conditioning','relations')
conditioningrelationsMI = mi.shrink(conditioningrelations)

conditioningconstituent = table(templates$conditioning,templates$constituent)
names(dimnames(conditioningconstituent)) <- list('conditioning','constituent')
conditioningconstituentMI = mi.shrink(conditioningconstituent)

conditioningcount = table(templates$conditioning,templates$count)
names(dimnames(conditioningcount)) <- list('conditioning','count')
conditioningcountMI = mi.shrink(conditioningcount)

exceptionalityviolability = violabilityexceptionality
exceptionalityviolabilityMI = violabilityexceptionalityMI

exceptionalityconditioning = conditioningexceptionality
exceptionalityconditioningMI = conditioningexceptionalityMI

exceptionalityexceptionalityMI = 0

exceptionalityreparability = table(templates$exceptionality,templates$reparability)
names(dimnames(exceptionalityreparability)) <- list('exceptionality','reparability')
exceptionalityreparabilityMI = mi.shrink(exceptionalityreparability)

exceptionalityfoundation = table(templates$exceptionality,templates$foundation)
names(dimnames(exceptionalityfoundation)) <- list('exceptionality','foundation')
exceptionalityfoundationMI = mi.shrink(exceptionalityfoundation)

exceptionalitystricture = table(templates$exceptionality,templates$stricture)
names(dimnames(exceptionalitystricture)) <- list('exceptionality','stricture')
exceptionalitystrictureMI = mi.shrink(exceptionalitystricture)

exceptionalityrelations = table(templates$exceptionality,templates$relations)
names(dimnames(exceptionalityrelations)) <- list('exceptionality','relations')
exceptionalityrelationsMI = mi.shrink(exceptionalityrelations)

exceptionalityconstituent = table(templates$exceptionality,templates$constituent)
names(dimnames(exceptionalityconstituent)) <- list('exceptionality','constituent')
exceptionalityconstituentMI = mi.shrink(exceptionalityconstituent)

exceptionalitycount = table(templates$exceptionality,templates$count)
names(dimnames(exceptionalitycount)) <- list('exceptionality','count')
exceptionalitycountMI = mi.shrink(exceptionalitycount)

reparabilityviolability = violabilityreparability
reparabilityviolabilityMI = violabilityreparabilityMI

reparabilityconditioning = conditioningreparability
reparabilityconditioningMI = conditioningreparabilityMI

reparabilityexceptionality = exceptionalityreparability
reparabilityexceptionalityMI = exceptionalityreparabilityMI

reparabilityreparabilityMI = 0

reparabilityfoundation = table(templates$reparability,templates$foundation)
names(dimnames(reparabilityfoundation)) <- list('reparability','foundation')
reparabilityfoundationMI = mi.shrink(reparabilityfoundation)

reparabilitystricture = table(templates$reparability,templates$stricture)
names(dimnames(reparabilitystricture)) <- list('reparability','stricture')
reparabilitystrictureMI = mi.shrink(reparabilitystricture)

reparabilityrelations = table(templates$reparability,templates$relations)
names(dimnames(reparabilityrelations)) <- list('reparability','relations')
reparabilityrelationsMI = mi.shrink(reparabilityrelations)

reparabilityconstituent = table(templates$reparability,templates$constituent)
names(dimnames(reparabilityconstituent)) <- list('reparability','constituent')
reparabilityconstituentMI = mi.shrink(reparabilityconstituent)

reparabilitycount = table(templates$reparability,templates$count)
names(dimnames(reparabilitycount)) <- list('reparability','count')
reparabilitycountMI = mi.shrink(reparabilitycount)

foundationviolability = violabilityfoundation
foundationviolabilityMI = violabilityfoundationMI

foundationconditioning = conditioningfoundation
foundationconditioningMI = conditioningfoundationMI

foundationexceptionality = exceptionalityfoundation
foundationexceptionalityMI = exceptionalityfoundationMI

foundationreparability = reparabilityfoundation
foundationreparabilityMI = reparabilityfoundationMI

foundationfoundationMI = 0

foundationstricture = table(templates$foundation,templates$stricture)
names(dimnames(foundationstricture)) <- list('foundation','stricture')
foundationstrictureMI = mi.shrink(foundationstricture)

foundationrelations = table(templates$foundation,templates$relations)
names(dimnames(foundationrelations)) <- list('foundation','relations')
foundationrelationsMI = mi.shrink(foundationrelations)

foundationconstituent = table(templates$foundation,templates$constituent)
names(dimnames(foundationconstituent)) <- list('foundation','constituent')
foundationconstituentMI = mi.shrink(foundationconstituent)

foundationcount = table(templates$foundation,templates$count)
names(dimnames(foundationcount)) <- list('foundation','count')
foundationcountMI = mi.shrink(foundationcount)

strictureviolability = violabilitystricture
strictureviolabilityMI = violabilitystrictureMI

strictureconditioning = conditioningstricture
strictureconditioningMI = conditioningstrictureMI

strictureexceptionality = exceptionalitystricture
strictureexceptionalityMI = exceptionalitystrictureMI

stricturereparability = reparabilitystricture
stricturereparabilityMI = reparabilitystrictureMI

stricturefoundation = foundationstricture
stricturefoundationMI = foundationstrictureMI

stricturestrictureMI = 0

stricturerelations = table(templates$stricture,templates$relations)
names(dimnames(stricturerelations)) <- list('stricture','relations')
stricturerelationsMI = mi.shrink(stricturerelations)

strictureconstituent = table(templates$stricture,templates$constituent)
names(dimnames(strictureconstituent)) <- list('stricture','constituent')
strictureconstituentMI = mi.shrink(strictureconstituent)

stricturecount = table(templates$stricture,templates$count)
names(dimnames(stricturecount)) <- list('stricture','count')
stricturecountMI = mi.shrink(stricturecount)

relationsviolability = violabilityrelations
relationsviolabilityMI = violabilityrelationsMI

relationsconditioning = conditioningrelations
relationsconditioningMI = conditioningrelationsMI

relationsexceptionality = exceptionalityrelations
relationsexceptionalityMI = exceptionalityrelationsMI

relationsreparability = reparabilityrelations
relationsreparabilityMI = reparabilityrelationsMI

relationsfoundation = foundationrelations
relationsfoundationMI = foundationrelationsMI

relationsstricture = stricturerelations
relationsstrictureMI = stricturerelationsMI

relationsrelationsMI = 0

relationsconstituent = table(templates$relations,templates$constituent)
names(dimnames(relationsconstituent)) <- list('relations','constituent')
relationsconstituentMI = mi.shrink(relationsconstituent)

relationscount = table(templates$relations,templates$count)
names(dimnames(relationscount)) <- list('relations','count')
relationscountMI = mi.shrink(relationscount)

constituentviolability = violabilityconstituent
constituentviolabilityMI = violabilityconstituentMI

constituentconditioning = conditioningconstituent
constituentconditioningMI = conditioningconstituentMI

constituentexceptionality = exceptionalityconstituent
constituentexceptionalityMI = exceptionalityconstituentMI

constituentreparability = reparabilityconstituent
constituentreparabilityMI = reparabilityconstituentMI

constituentfoundation = foundationconstituent
constituentfoundationMI = foundationconstituentMI

constituentstricture = strictureconstituent
constituentstrictureMI = strictureconstituentMI

constituentrelations = relationsconstituent
constituentrelationsMI = relationsconstituentMI

constituentconstituentMI = 0

constituentcount = table(templates$constituent,templates$count)
names(dimnames(constituentcount)) <- list('constituent','count')
constituentcountMI = mi.shrink(constituentcount)

countviolability = violabilitycount
countviolabilityMI = violabilitycountMI

countconditioning = conditioningcount
countconditioningMI = conditioningcountMI

countexceptionality = exceptionalitycount
countexceptionalityMI = exceptionalitycountMI

countreparability = reparabilitycount
countreparabilityMI = reparabilitycountMI

countfoundation = foundationcount
countfoundationMI = foundationcountMI

countstricture = stricturecount
countstrictureMI = stricturecountMI

countrelations = relationscount
countrelationsMI = relationscountMI

countconstituent = constituentcount
countconstituentMI = constituentcountMI

countcountMI = 0

Pviolabilityviolability = violabilityviolabilityMI[1] / Hviolability
Pviolabilityviolability = violabilityviolabilityMI[1] / Hviolability

Pviolabilityconditioning = violabilityconditioningMI[1] / Hviolability
Pconditioningviolability = violabilityconditioningMI[1] / Hconditioning

Pviolabilityexceptionality = violabilityexceptionalityMI[1] / Hviolability
Pexceptionalityviolability = violabilityexceptionalityMI[1] / Hexceptionality

Pviolabilityreparability = violabilityreparabilityMI[1] / Hviolability
Preparabilityviolability = violabilityreparabilityMI[1] / Hreparability

Pviolabilityfoundation = violabilityfoundationMI[1] / Hviolability
Pfoundationviolability = violabilityfoundationMI[1] / Hfoundation

Pviolabilitystricture = violabilitystrictureMI[1] / Hviolability
Pstrictureviolability = violabilitystrictureMI[1] / Hstricture

Pviolabilityrelations = violabilityrelationsMI[1] / Hviolability
Prelationsviolability = violabilityrelationsMI[1] / Hrelations

Pviolabilityconstituent = violabilityconstituentMI[1] / Hviolability
Pconstituentviolability = violabilityconstituentMI[1] / Hconstituent

Pviolabilitycount = violabilitycountMI[1] / Hviolability
Pcountviolability = violabilitycountMI[1] / Hcount

Pconditioningviolability = conditioningviolabilityMI[1] / Hconditioning
Pviolabilityconditioning = conditioningviolabilityMI[1] / Hviolability

Pconditioningconditioning = conditioningconditioningMI[1] / Hconditioning
Pconditioningconditioning = conditioningconditioningMI[1] / Hconditioning

Pconditioningexceptionality = conditioningexceptionalityMI[1] / Hconditioning
Pexceptionalityconditioning = conditioningexceptionalityMI[1] / Hexceptionality

Pconditioningreparability = conditioningreparabilityMI[1] / Hconditioning
Preparabilityconditioning = conditioningreparabilityMI[1] / Hreparability

Pconditioningfoundation = conditioningfoundationMI[1] / Hconditioning
Pfoundationconditioning = conditioningfoundationMI[1] / Hfoundation

Pconditioningstricture = conditioningstrictureMI[1] / Hconditioning
Pstrictureconditioning = conditioningstrictureMI[1] / Hstricture

Pconditioningrelations = conditioningrelationsMI[1] / Hconditioning
Prelationsconditioning = conditioningrelationsMI[1] / Hrelations

Pconditioningconstituent = conditioningconstituentMI[1] / Hconditioning
Pconstituentconditioning = conditioningconstituentMI[1] / Hconstituent

Pconditioningcount = conditioningcountMI[1] / Hconditioning
Pcountconditioning = conditioningcountMI[1] / Hcount

Pexceptionalityviolability = exceptionalityviolabilityMI[1] / Hexceptionality
Pviolabilityexceptionality = exceptionalityviolabilityMI[1] / Hviolability

Pexceptionalityconditioning = exceptionalityconditioningMI[1] / Hexceptionality
Pconditioningexceptionality = exceptionalityconditioningMI[1] / Hconditioning

Pexceptionalityexceptionality = exceptionalityexceptionalityMI[1] / Hexceptionality
Pexceptionalityexceptionality = exceptionalityexceptionalityMI[1] / Hexceptionality

Pexceptionalityreparability = exceptionalityreparabilityMI[1] / Hexceptionality
Preparabilityexceptionality = exceptionalityreparabilityMI[1] / Hreparability

Pexceptionalityfoundation = exceptionalityfoundationMI[1] / Hexceptionality
Pfoundationexceptionality = exceptionalityfoundationMI[1] / Hfoundation

Pexceptionalitystricture = exceptionalitystrictureMI[1] / Hexceptionality
Pstrictureexceptionality = exceptionalitystrictureMI[1] / Hstricture

Pexceptionalityrelations = exceptionalityrelationsMI[1] / Hexceptionality
Prelationsexceptionality = exceptionalityrelationsMI[1] / Hrelations

Pexceptionalityconstituent = exceptionalityconstituentMI[1] / Hexceptionality
Pconstituentexceptionality = exceptionalityconstituentMI[1] / Hconstituent

Pexceptionalitycount = exceptionalitycountMI[1] / Hexceptionality
Pcountexceptionality = exceptionalitycountMI[1] / Hcount

Preparabilityviolability = reparabilityviolabilityMI[1] / Hreparability
Pviolabilityreparability = reparabilityviolabilityMI[1] / Hviolability

Preparabilityconditioning = reparabilityconditioningMI[1] / Hreparability
Pconditioningreparability = reparabilityconditioningMI[1] / Hconditioning

Preparabilityexceptionality = reparabilityexceptionalityMI[1] / Hreparability
Pexceptionalityreparability = reparabilityexceptionalityMI[1] / Hexceptionality

Preparabilityreparability = reparabilityreparabilityMI[1] / Hreparability
Preparabilityreparability = reparabilityreparabilityMI[1] / Hreparability

Preparabilityfoundation = reparabilityfoundationMI[1] / Hreparability
Pfoundationreparability = reparabilityfoundationMI[1] / Hfoundation

Preparabilitystricture = reparabilitystrictureMI[1] / Hreparability
Pstricturereparability = reparabilitystrictureMI[1] / Hstricture

Preparabilityrelations = reparabilityrelationsMI[1] / Hreparability
Prelationsreparability = reparabilityrelationsMI[1] / Hrelations

Preparabilityconstituent = reparabilityconstituentMI[1] / Hreparability
Pconstituentreparability = reparabilityconstituentMI[1] / Hconstituent

Preparabilitycount = reparabilitycountMI[1] / Hreparability
Pcountreparability = reparabilitycountMI[1] / Hcount

Pfoundationviolability = foundationviolabilityMI[1] / Hfoundation
Pviolabilityfoundation = foundationviolabilityMI[1] / Hviolability

Pfoundationconditioning = foundationconditioningMI[1] / Hfoundation
Pconditioningfoundation = foundationconditioningMI[1] / Hconditioning

Pfoundationexceptionality = foundationexceptionalityMI[1] / Hfoundation
Pexceptionalityfoundation = foundationexceptionalityMI[1] / Hexceptionality

Pfoundationreparability = foundationreparabilityMI[1] / Hfoundation
Preparabilityfoundation = foundationreparabilityMI[1] / Hreparability

Pfoundationfoundation = foundationfoundationMI[1] / Hfoundation
Pfoundationfoundation = foundationfoundationMI[1] / Hfoundation

Pfoundationstricture = foundationstrictureMI[1] / Hfoundation
Pstricturefoundation = foundationstrictureMI[1] / Hstricture

Pfoundationrelations = foundationrelationsMI[1] / Hfoundation
Prelationsfoundation = foundationrelationsMI[1] / Hrelations

Pfoundationconstituent = foundationconstituentMI[1] / Hfoundation
Pconstituentfoundation = foundationconstituentMI[1] / Hconstituent

Pfoundationcount = foundationcountMI[1] / Hfoundation
Pcountfoundation = foundationcountMI[1] / Hcount

Pstrictureviolability = strictureviolabilityMI[1] / Hstricture
Pviolabilitystricture = strictureviolabilityMI[1] / Hviolability

Pstrictureconditioning = strictureconditioningMI[1] / Hstricture
Pconditioningstricture = strictureconditioningMI[1] / Hconditioning

Pstrictureexceptionality = strictureexceptionalityMI[1] / Hstricture
Pexceptionalitystricture = strictureexceptionalityMI[1] / Hexceptionality

Pstricturereparability = stricturereparabilityMI[1] / Hstricture
Preparabilitystricture = stricturereparabilityMI[1] / Hreparability

Pstricturefoundation = stricturefoundationMI[1] / Hstricture
Pfoundationstricture = stricturefoundationMI[1] / Hfoundation

Pstricturestricture = stricturestrictureMI[1] / Hstricture
Pstricturestricture = stricturestrictureMI[1] / Hstricture

Pstricturerelations = stricturerelationsMI[1] / Hstricture
Prelationsstricture = stricturerelationsMI[1] / Hrelations

Pstrictureconstituent = strictureconstituentMI[1] / Hstricture
Pconstituentstricture = strictureconstituentMI[1] / Hconstituent

Pstricturecount = stricturecountMI[1] / Hstricture
Pcountstricture = stricturecountMI[1] / Hcount

Prelationsviolability = relationsviolabilityMI[1] / Hrelations
Pviolabilityrelations = relationsviolabilityMI[1] / Hviolability

Prelationsconditioning = relationsconditioningMI[1] / Hrelations
Pconditioningrelations = relationsconditioningMI[1] / Hconditioning

Prelationsexceptionality = relationsexceptionalityMI[1] / Hrelations
Pexceptionalityrelations = relationsexceptionalityMI[1] / Hexceptionality

Prelationsreparability = relationsreparabilityMI[1] / Hrelations
Preparabilityrelations = relationsreparabilityMI[1] / Hreparability

Prelationsfoundation = relationsfoundationMI[1] / Hrelations
Pfoundationrelations = relationsfoundationMI[1] / Hfoundation

Prelationsstricture = relationsstrictureMI[1] / Hrelations
Pstricturerelations = relationsstrictureMI[1] / Hstricture

Prelationsrelations = relationsrelationsMI[1] / Hrelations
Prelationsrelations = relationsrelationsMI[1] / Hrelations

Prelationsconstituent = relationsconstituentMI[1] / Hrelations
Pconstituentrelations = relationsconstituentMI[1] / Hconstituent

Prelationscount = relationscountMI[1] / Hrelations
Pcountrelations = relationscountMI[1] / Hcount

Pconstituentviolability = constituentviolabilityMI[1] / Hconstituent
Pviolabilityconstituent = constituentviolabilityMI[1] / Hviolability

Pconstituentconditioning = constituentconditioningMI[1] / Hconstituent
Pconditioningconstituent = constituentconditioningMI[1] / Hconditioning

Pconstituentexceptionality = constituentexceptionalityMI[1] / Hconstituent
Pexceptionalityconstituent = constituentexceptionalityMI[1] / Hexceptionality

Pconstituentreparability = constituentreparabilityMI[1] / Hconstituent
Preparabilityconstituent = constituentreparabilityMI[1] / Hreparability

Pconstituentfoundation = constituentfoundationMI[1] / Hconstituent
Pfoundationconstituent = constituentfoundationMI[1] / Hfoundation

Pconstituentstricture = constituentstrictureMI[1] / Hconstituent
Pstrictureconstituent = constituentstrictureMI[1] / Hstricture

Pconstituentrelations = constituentrelationsMI[1] / Hconstituent
Prelationsconstituent = constituentrelationsMI[1] / Hrelations

Pconstituentconstituent = constituentconstituentMI[1] / Hconstituent
Pconstituentconstituent = constituentconstituentMI[1] / Hconstituent

Pconstituentcount = constituentcountMI[1] / Hconstituent
Pcountconstituent = constituentcountMI[1] / Hcount

Pcountviolability = countviolabilityMI[1] / Hcount
Pviolabilitycount = countviolabilityMI[1] / Hviolability

Pcountconditioning = countconditioningMI[1] / Hcount
Pconditioningcount = countconditioningMI[1] / Hconditioning

Pcountexceptionality = countexceptionalityMI[1] / Hcount
Pexceptionalitycount = countexceptionalityMI[1] / Hexceptionality

Pcountreparability = countreparabilityMI[1] / Hcount
Preparabilitycount = countreparabilityMI[1] / Hreparability

Pcountfoundation = countfoundationMI[1] / Hcount
Pfoundationcount = countfoundationMI[1] / Hfoundation

Pcountstricture = countstrictureMI[1] / Hcount
Pstricturecount = countstrictureMI[1] / Hstricture

Pcountrelations = countrelationsMI[1] / Hcount
Prelationscount = countrelationsMI[1] / Hrelations

Pcountconstituent = countconstituentMI[1] / Hcount
Pconstituentcount = countconstituentMI[1] / Hconstituent

Pcountcount = countcountMI[1] / Hcount
Pcountcount = countcountMI[1] / Hcount

violabilityRow = c(violabilityviolabilityMI, violabilityconditioningMI, violabilityexceptionalityMI, violabilityreparabilityMI, violabilityfoundationMI, violabilitystrictureMI, violabilityrelationsMI, violabilityconstituentMI, violabilitycountMI)
conditioningRow = c(conditioningviolabilityMI, conditioningconditioningMI, conditioningexceptionalityMI, conditioningreparabilityMI, conditioningfoundationMI, conditioningstrictureMI, conditioningrelationsMI, conditioningconstituentMI, conditioningcountMI)
exceptionalityRow = c(exceptionalityviolabilityMI, exceptionalityconditioningMI, exceptionalityexceptionalityMI, exceptionalityreparabilityMI, exceptionalityfoundationMI, exceptionalitystrictureMI, exceptionalityrelationsMI, exceptionalityconstituentMI, exceptionalitycountMI)
reparabilityRow = c(reparabilityviolabilityMI, reparabilityconditioningMI, reparabilityexceptionalityMI, reparabilityreparabilityMI, reparabilityfoundationMI, reparabilitystrictureMI, reparabilityrelationsMI, reparabilityconstituentMI, reparabilitycountMI)
foundationRow = c(foundationviolabilityMI, foundationconditioningMI, foundationexceptionalityMI, foundationreparabilityMI, foundationfoundationMI, foundationstrictureMI, foundationrelationsMI, foundationconstituentMI, foundationcountMI)
strictureRow = c(strictureviolabilityMI, strictureconditioningMI, strictureexceptionalityMI, stricturereparabilityMI, stricturefoundationMI, stricturestrictureMI, stricturerelationsMI, strictureconstituentMI, stricturecountMI)
relationsRow = c(relationsviolabilityMI, relationsconditioningMI, relationsexceptionalityMI, relationsreparabilityMI, relationsfoundationMI, relationsstrictureMI, relationsrelationsMI, relationsconstituentMI, relationscountMI)
constituentRow = c(constituentviolabilityMI, constituentconditioningMI, constituentexceptionalityMI, constituentreparabilityMI, constituentfoundationMI, constituentstrictureMI, constituentrelationsMI, constituentconstituentMI, constituentcountMI)
countRow = c(countviolabilityMI, countconditioningMI, countexceptionalityMI, countreparabilityMI, countfoundationMI, countstrictureMI, countrelationsMI, countconstituentMI, countcountMI)

miTemplates = rbind(violabilityRow, conditioningRow, exceptionalityRow, reparabilityRow, foundationRow, strictureRow, relationsRow, constituentRow, countRow)
colnames(miTemplates) = c("violabilityCol", "conditioningCol", "exceptionalityCol", "reparabilityCol", "foundationCol", "strictureCol", "relationsCol", "constituentCol", "countCol")

miReduced = aracne.a(miTemplates, .05)

mosaic(countreparability, shade=TRUE)
assoc(countreparability, shade=TRUE)


#--------Reference Point helper functions-------

#-------Spawners per recruit -----------------------------
s.per.recr<-function(nages,fec.age,mat.age,M.age, F.mult, sel.age, spawn.time ) {

  spr=0.0
  cum.survive=1.0
  z=0.0
  for (i in 1:(nages-1)  ) {
    z=M.age[i] + F.mult*sel.age[i]
    z.ts=(M.age[i]+F.mult*sel.age[i])*spawn.time
    spr=spr+cum.survive*fec.age[i]*mat.age[i]*exp(-z.ts)
    cum.survive=cum.survive*exp(-z )

  }

  z= M.age[nages] + F.mult*sel.age[nages]
  z.ts=(M.age[nages]+F.mult*sel.age[nages])*spawn.time
  spr=spr + fec.age[nages]*mat.age[nages]*cum.survive*exp(-z.ts)/( 1- exp(-z ) )

  return(spr)

}

#-------Yield per recruit -----------------------------
ypr<-function(nages, wgt.age, M.age, F.mult, sel.age ) {

  yield=0.0
  cum.survive=1.0
  z=0.0

  for (i in 1:(nages-1)  ) {
    z=M.age[i] + F.mult*sel.age[i]
    yield=yield + wgt.age[i]*F.mult*sel.age[i]*(1-exp(-z) )*cum.survive/z
    cum.survive=cum.survive*exp(-z)
  }

  z= M.age[nages] + F.mult*sel.age[nages]
  yield=yield + wgt.age[nages]*F.mult*sel.age[nages]*cum.survive/z

  return(yield)

}

#-------Equilibrium SSB ------------------------
ssb.eq<-function(recr.par, R0.BH, spr, spr0, is.steepness=T ) {

  if (is.steepness==T)  alpha.BH <- 4*recr.par/(1-recr.par)
  if (is.steepness==F)  alpha.BH <- recr.par
  sprF=spr/spr0

  ssb=spr0*R0.BH*(sprF*alpha.BH - 1.0)/(alpha.BH-1.0)

  return(ssb)

}
#------Beverton-Holt alpha-----------------------
bev.holt.alpha<-function(S,R0,recr.par,spr0, is.steepness=T){

  if (is.steepness==T)  alpha.BH <- 4*recr.par/(1-recr.par)
  if (is.steepness==F)  alpha.BH <- recr.par

  y=rep(0,length(S))
  y=R0*S*alpha.BH/(R0*spr0 +(alpha.BH-1.0)*S)
  return(y)

}


source("llr.r")

n = 1000
p = 0.01
n1 = 100
n2 = 10000
z = data.frame(
    k1 = 1:5,
    k2 = as.numeric(gl(200, 25, n))-1,
    llr = rep(0, n),
    chi2 = rep(0, n)
)

x2 = function(data) {
    total = sum(data)
    m = dim(data)[1]
    n = dim(data)[2]
    p.row = rowSums(data) / total
    p.col = colSums(data) / total
    expected = matrix(p.row, nrow=m, ncol=n, byrow=F) * matrix(p.col, nrow=m, ncol=n, byrow=T)
    expected = total * expected
    sum((data-expected)^2/expected)
}

for (i in 1:n) {
    table = matrix(c(z$k1[i], n1 - z$k1[i], z$k2[i], n2 - z$k2[i]), nrow=2)
    z$llr[i] = llr(table)
    z$chi2[i] = x2(table)
}

pdf('fig3.pdf', width=5, height=6)
par(mar=c(4,5,1,1))
plot(chi2 ~ llr, z, cex=0.5, xlim=c(0,47), ylim=c(0,500),ylab=NA, xlab=NA, yaxt='n')
mtext(expression(-2 ~ log ~ lambda), side=1, line=3, las=1, cex=1.3)
mtext(expression(chi^2), side=2, line=3, las=2, cex=1.3)
axis(2, at=seq(0,500,by=100), las=2)
dev.off()


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Black-Litterman model Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Black-Litterman model Functions
###############################################################################
# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# note (5)
#
#' @export
bl.compute.risk.aversion <- function(bench, risk.free = 0)
{
	# The implied risk aversion coefficient can be estimated by dividing
	# the expected excess return by the variance of the portfolio
	lambda = mean(coredata(bench) - coredata(risk.free)) / var(coredata(bench))
	return( as.double(lambda) )
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (2)
#
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# formulas (1)
#
# use reverse optimization to compute the vector of equilibrium returns
#' @export
bl.compute.eqret <- function
(
	risk.aversion, 	# Risk Aversion
	cov, 			# Covariance matrix
	cap.weight, 	# Market Capitalization Weights
	risk.free = 0	# Rsik Free Interest Rate
)
{
	return( risk.aversion * cov %*% as.vector(cap.weight) +  as.double(risk.free))
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (8), (9), (10)
# compute the posterior estimate of the returns and covariance
#' @export
bl.compute.posterior <- function
(
	mu, 		# Equilibrium returns
	cov, 		# Covariance matrix
	pmat=NULL, 	# Views pick matrix
	qmat=NULL, 	# View mean vector
	tau=0.025, 	# Measure of uncertainty of the prior estimate of the mean returns
	confidences=NULL  # Confidence of each view
)
{
	out = list()

	if( !is.null(pmat) ) {
		if( is.null(confidences) ) {
		# The Black-Litterman Model In Detail by Jay Walters
		# Assume that the variance of the views will be proportional to the variance of the asset
		# returns, just as the variance of the prior distribution is. He and Litterman (1999)
		# This specification of the variance, or uncertainty, of the views essentially equally weights the investor's
		# views and the market equilibrium weights. By including tau in the expression, the final solution becomes
		# independent of tau as well.

		# contactenate 1 and remove first row, col ([-1,-1]) to work properly with single view
		omega = diag(c(1,diag(tau * pmat %*% cov %*% t(pmat))))[-1,-1]
		} else {
		omega = diag(c(1,confidences))[-1,-1]
		}

		temp = solve(solve(tau * cov) + t(pmat) %*% solve(omega) %*% pmat)

		out$cov = cov + temp

		out$expected.return = temp %*% (solve(tau * cov) %*% mu + t(pmat) %*% solve(omega) %*% qmat)
	} else {	# no views
		temp = tau * cov

		out$cov = cov + temp

		out$expected.return = temp %*% (solve(tau * cov) %*% mu )

	}
	return(out)
}

# He & Litterman: The intuition Behind Black- Litterman Model Portfolios
# formulas (13)
#
# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL
# formulas (2)
#
# compute the portfolio weights for the optimal portfolio on the unconstrained efficient frontier
#' @export
bl.compute.optimal <- function(risk.aversion, mu, cov)
{
	return( (1/risk.aversion) * solve(cov) %*% mu )
}

aa.black.litterman.examples <- function()
{
	# He & Litterman: The intuition Behind Black- Litterman Model Portfolios.

	data =
 '1,0.4880,0.4780,0.5150,0.4390,0.5120,0.4910
 0.4880,1,0.6640,0.6550,0.3100,0.6080,0.7790
 0.4780,0.6640,1,0.8610,0.3550,0.7830,0.6680
 0.5150,0.6550,0.8610,1,0.3540,0.7770,0.6530
 0.4390,0.3100,0.3550,0.3540,1,0.4050,0.3060
 0.5120,0.6080,0.7830,0.7770,0.4050,1,0.6520
 0.4910,0.7790,0.6680,0.6530,0.3060,0.6520,1'

	Corrmat = matrix( as.double(spl( gsub('\n', ',', data), ',')),
				nrow = len(spl(data, '\n')), byrow=TRUE)

	RiskAversion = 2.5

	stdevs = c(16.0, 20.3, 24.8, 27.1, 21.0,  20.0, 18.7)/100

	MktWeight = c(1.6, 2.2, 5.2, 5.5, 11.6, 12.4, 61.5)/100

	tau = 0.05

	Covmat = Corrmat * (stdevs %*% t(stdevs))

	EqRiskPrem = RiskAversion * Covmat %*% MktWeight
EqRiskPrem = bl.compute.eqret(RiskAversion, Covmat, MktWeight)

	AssetNames = c('Australia','Canada','France','Germany','Japan','UK','USA')

	Table2 = cbind(AssetNames, round(cbind(stdevs, MktWeight, EqRiskPrem) * 100,1))
		colnames(Table2) = c('Assets','Std Dev','Weq','PI')
		Table2

	#View1 is The German Equity Market Will Outperform the rest of European Markets by 5% a year.
	P = matrix(c(0, 0, -29.5, 100, 0, -70.5, 0)/100, nrow=1)
	Q = 5/100

	Omega = diag(c(1,diag(tau * P %*% Covmat %*% t(P))))[-1,-1]

	PostCov = solve(solve(tau*Covmat) + (t(P) %*% solve(Omega) %*% P))

	SigmaP = Covmat + PostCov

	ExpRet = PostCov %*% (solve(tau * Covmat) %*% EqRiskPrem + t(P) %*% solve(Omega) %*% Q)

post = bl.compute.posterior(EqRiskPrem, Covmat, P, Q, tau)
	ExpRet = post$expected.return
	SigmaP = post$cov

	OptimalWeights = (1/RiskAversion) * solve(SigmaP) %*% ExpRet
OptimalWeights = bl.compute.optimal(RiskAversion, ExpRet, SigmaP)

	Tab4Col4 = OptimalWeights - (MktWeight)/(1+tau)

	Table4 = cbind(AssetNames, round(cbind(t(P), ExpRet, OptimalWeights, round(Tab4Col4 * 1000)/1000)*100,1))
		colnames(Table4) = c('Assets', 'P', 'MU', 'W','W - Weq/1+tau')
		Table4

	# example from Thomas M. Idzorek's paper "A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL"
	x =
	c(0.001005,0.001328,-0.000579,-0.000675,0.000121,0.000128,-0.000445,-0.000437 ,
     0.001328,0.007277,-0.001307,-0.000610,-0.002237,-0.000989,0.001442,-0.001535 ,
     -0.000579,-0.001307,0.059852,0.027588,0.063497,0.023036,0.032967,0.048039 ,
    -0.000675,-0.000610,0.027588,0.029609,0.026572,0.021465,0.020697,0.029854 ,
     0.000121,-0.002237,0.063497,0.026572,0.102488,0.042744,0.039943,0.065994 ,
     0.000128,-0.000989,0.023036,0.021465,0.042744,0.032056,0.019881,0.032235 ,
    -0.000445,0.001442,0.032967,0.020697,0.039943,0.019881,0.028355,0.035064 ,
    -0.000437,-0.001535,0.048039,0.029854,0.065994,0.032235,0.035064,0.079958 )

    varCov <- matrix(x, ncol = 8, nrow = 8)
    mu <- c(0.08, 0.67,6.41, 4.08, 7.43, 3.70, 4.80, 6.60) / 100
    pick <- matrix(0, ncol = 8, nrow = 3, dimnames = list(NULL, letters[1:8]))
    pick[1,7] <- 1
    pick[2,1] <- -1; pick[2,2] <- 1
    pick[3, 3:6] <- c(0.9, -0.9, .1, -.1)

post = bl.compute.posterior(mu, varCov, pick, c(0.0525, 0.0025, 0.02), tau = 0.025)

	library(BLCOP)
    confidences <- 1 / c(0.000709, 0.000141, 0.000866)
    myViews <- BLViews(pick, c(0.0525, 0.0025, 0.02), confidences, letters[1:8])
    myPosterior <- posteriorEst(myViews, tau = 0.025, mu, varCov )
    myPosterior

 myPosterior@posteriorMean - post$expected.return
 myPosterior@posteriorCovar - post$cov

}


## functions

Down_Sample_Counts <- function (expr_vector, prob)
    {
        down_sample <- function(x, prob.=prob) {
            return(unlist(lapply(x, function(y) {
                rbinom(1, y, prob.)
            })))
        }
        down_sampled_df <- apply(as.data.frame(expr_vector), 2, down_sample)
        down_sampled_df = data.frame(down_sampled_df)
        row.names(down_sampled_df) = rownames(expr_vector)
        return(down_sampled_df)
    }

prob.range = c(0.001, 0.002, 0.004, 0.008, 0.01, 0.02, 0.04, 0.08, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1)

Downsampling.curve <- function(exprV, prob.range){
    res_matrix <- data.frame(matrix(ncol = length(prob.range), nrow = dim(res_matrix)[1]))
    i = 0
    for (prob in prob.range) {
        i = i + 1
        res_matrix[, i] = Down_Sample_Counts(exprV, prob)
        colnames(res_matrix) <- prob.range
        }
    return(res_matrix)
    }

Compute_features_matrix <- function(rawcounts, prob.range){
    Features.matrix = data.frame(matrix(ncol = dim(rawcounts)[2], nrow = length(prob.range)))
    i = 0
    for (label in colnames(rawcounts)) {
        i = i + 1
        Features.matrix[, i] = colSums(Downsampling.curve(rawcounts[, i], prob.range) != 0)
        # or >= 5, etc
        colnames(Features.matrix) = colnames(rawcounts)
        if (i == 1) {
            plot(prob.range, Features.matrix[, i], type="l")
            } else {
            lines(prob.range, Features.matrix[, i])
        }
    }
    return(Features.matrix)
}

Visualise_features_matrix <- function(features_matrix, prob.range, Quality_Treshold=20000) {
    i = 0
    max = max(tail(features_matrix, 1))
    Vmaxs = unlist(features_matrix[2,]/.002)
    colors = ifelse(Vmaxs<Quality_Treshold, "red", "black")
    for (label in features_matrix) {
        i = i + 1
        if (i == 1) {
            plot(prob.range, features_matrix[, i], type="l", ylim=c(0,max), col=colors[i])
            } else {
            lines(prob.range, features_matrix[, i], col=colors[i])
        }
    }
    return(Vmaxs)
}

## main

CountArray = read.delim("raw_counts.tab", header=T)
rownames(CountArray) = CountArray[,1]
CountArray = CountArray[,-1]
mymatrix = Compute_features_matrix(CountArray, prob.range)
vmaxs = Visualise_features_matrix(mymatrix, prob.range)


AvgGenderDiffPreferencesPCA <- function(dat) {
  # This function takes a data table with the coefficients of the linear model
  # for each country as an input and returns a data table having two columns:
  # one is the principal component analysis of the 6 preferences using the
  # gender coefficient as main variable, and the other is the associated country

  dt_pca <- data.table()

  for (C in unique(dat$country)) {
    # Create a transposed data table on country level
    dt_tmp <- as.data.table(t(dat[country == C, .(gender)]))
    # Set new names to identify the preferences
    setnames(dt_tmp, old = names(dt_tmp), new = unique(dat$preference))
    # Add the country information
    dt_tmp[, country := C]

    dt_pca <- rbind(dt_pca, dt_tmp)
  }
  # Create a data table with the correct slope as in the article (aestethic only)
  dt_pca_pos <- dt_pca[, .(country,
                           Trust                  = trust,
                           Altruism               = altruism,
                           `Positive Reciprocity` = posrecip,
                           `Negative Reciprocity` = negrecip * - 1,
                           `Risk Taking`          = risktaking * - 1,
                           Patience               = patience * - 1)]

  # Perform the principal component analysis
  pca <- prcomp(dt_pca_pos[, -1], scale. = F)

  # Create a data table with the first component of the PCA and the country
  # names to be returned by the function
  return(data.table(avgGenderDiff = pca$x[, 1],
                    country       = dt_pca_pos$country))
}


robot <- function(f, x, y) {
  if (x == 3 && y == 3) {
    return(1)
  }
  ret <- 0
  if (x > 0 && !((x-1 + 4*y) %in% f)) {
    ret = ret + robot(append(f, x-1 + 4*y), x-1, y)
  }
  if (y > 0 && !((x + 4*(y-1)) %in% f)) {
    ret = ret + robot(append(f, x + 4*(y-1)), x, y-1)
  }
  if (x < 3 && !((x+1 + 4*y) %in% f)) {
    ret = ret + robot(append(f, x+1 + 4*y), x+1, y)
  }
  if (y < 3 && !((x + 4*(y+1)) %in% f)) {
    ret = ret + robot(append(f, x + 4*(y+1)), x, y+1)
  }
  ret
}

cat(robot(c(0), 0, 0), sep="\n")


library(quantmod)

stock <- get(getSymbols('1227.TW'))
stock <- to.weekly(stock)
chartSeries(stock['2020'],
            up.col='red', dn.col='green' # chinese convention
           )
addSMA()
addSMA(3, col='white')
addEMA(5, col='blue')

View(BBands(Cl(stock)))
addBBands()
addRSI()
addMACD()

#class(stock)
#time(stock)
#class(time(stock))

#SMA5 <- runMean(Cl(stock), n=5)
#View(cbind(SMA5, Cl(stock)))

#SMA(Cl(stock), n=5)


#setwd("~/rolling_speed")

get_rates <- function(data_set){
  rates <- NULL
  start <- NULL
  for(i in 1:ncol(data_set)){
    x = seq(0, nrow(data_set) - 1, by = 1)
    y = data_set[,i]
    mod = lm(y ~ x)
    rates[i] <- mod[[1]][2]
    start[i] <- mod[[1]][1]
  }
  return(data.frame(rates,start))
}

rspeed0 <- data.frame(t(read.csv("rolling_speed2.5.csv", header = FALSE)))
row.names(rspeed0) <- NULL

rspeed1 <- data.frame(t(read.csv("rolling_speed5.csv", header = FALSE)))
row.names(rspeed1) <- NULL

rspeed2 <- data.frame(t(read.csv("rolling_speed7.5.csv", header = FALSE)))
row.names(rspeed2) <- NULL

rspeed3 <- data.frame(t(read.csv("rolling_speed10.csv", header = FALSE)))
row.names(rspeed3) <- NULL

rspeed4 <- data.frame(t(read.csv("rolling_speed12.5.csv", header = FALSE)))
row.names(rspeed4) <- NULL

rspeed5 <- data.frame(t(read.csv("rolling_speed15.csv", header = FALSE)))
row.names(rspeed5) <- NULL

rspeed6 <- data.frame(t(read.csv("rolling_speed17.5.csv", header = FALSE)))
row.names(rspeed6) <- NULL

rspeed7 <- data.frame(t(read.csv("rolling_speed20.csv", header = FALSE)))
row.names(rspeed7) <- NULL

matplot(rspeed1,type="l",xlab = "iterations",ylab = "environmental quality",main="Depletion: Rolling",ylim=c(1500,3700))

rates_025<- get_rates(rspeed0)
rates_050<- get_rates(rspeed1)
rates_075<- get_rates(rspeed2)
rates_100<- get_rates(rspeed3)
rates_125<- get_rates(rspeed4)
rates_150<- get_rates(rspeed5)
rates_175<- get_rates(rspeed6)
rates_200<- get_rates(rspeed7)

boxplot(rates_025$rates,rates_050$rates,rates_075$rates,rates_100$rates,rates_125$rates,rates_150$rates,rates_175$rates,rates_200$rates,xlab="speed",ylab="rate of depletion")

shapiro.test(rates_025$rates)
shapiro.test(rates_050$rates)
shapiro.test(rates_075$rates)
shapiro.test(rates_100$rates)
shapiro.test(rates_125$rates)
shapiro.test(rates_150$rates)
shapiro.test(rates_175$rates)
shapiro.test(rates_200$rates)

r_rate_list <- c(rates_025$rates,rates_050$rates,rates_075$rates,rates_100$rates,rates_125$rates,rates_150$rates,rates_175$rates,rates_200$rates)
r_speed_list <- rep(seq(2.5,20,by=2.5),each=30)

boxplot(r_rate_list ~ r_speed_list,xlab="speed",ylab="depletion rate",ylim=c(-1,-0),main="Rolling behaviour")
bartlett.test(r_rate_list~r_speed_list)
kruskal.test(r_rate_list~r_speed_list)


quantidadeDeDivisores <- function(n) {
  c = 0
  for(i in 1:n) {
    if(n%%i == 0) {
      c = c + 1
    }
  }
  return(c)
}


library(randomForest)

load("data/credit_ch1_train_test.RData")

# Establish a list of possible values for mtry, nodesize and sampsize
mtry <- seq(4, ncol(credit_train) * 0.8, 2)
nodesize <- seq(3, 8, 2)
sampsize <- nrow(credit_train) * c(0.7, 0.8)

# Create a data frame containing all combinations
hyper_grid <- expand.grid(mtry = mtry, nodesize = nodesize, sampsize = sampsize)

# Create an empty vector to store OOB error values
oob_err <- c()

# Write a loop over the rows of hyper_grid to train the grid of models
for (i in 1:nrow(hyper_grid)) {

    # Train a Random Forest model
    model <- randomForest(formula = default ~ .,
                          data = credit_train,
                          mtry = hyper_grid$mtry[i],
                          nodesize = hyper_grid$nodesize[i],
                          sampsize = hyper_grid$sampsize[i])

    # Store OOB error for the model
    oob_err[i] <- model$err.rate[nrow(model$err.rate), "OOB"]
}

# Identify optimal set of hyperparmeters based on OOB error
opt_i <- which.min(oob_err)
print(hyper_grid[opt_i,])


x <- c(2,43,27,96,18)
sort(x)

name <- c("Mandi", "Amy", "Nicole", "Olivia")
distance <- c(0.8, 3.1, 2.8, 4.0)
time <- c(10,30,40,50)
time <- (time / 60)
Mandispeed <- (0.8 / 0.166 )
amyspeed <- (3.1 / 0.500)
nicolespeed <- (2.8 / 0.666)
oliviaspeed <- (4.0 / 0.833)


devtools::load_all()
library(ppclp) # Huanchen's package
library(princurve) # Hastie's package
library(splines)
library(splines2)
library(tidyverse) # required by ppclp

#Load spect data into R from the package ppclp
data("spectExample")
y <- cbind(spectExample$x, spectExample$y, spectExample$z)
y <- y[1:100, ]

# Create time storage
time.table <- matrix(ncol = 5, nrow = 3)

# Compute the principal curve
ptm <- proc.time() # Start the clock!
fitlength <- f_ppslp(y, s_k = 200, maxit = 1e4, thresh = 1e-3,
    lambda_s = 1e6, lambda_l = 5, plot_update = F
    )
time.table[1, ] <- proc.time() - ptm # Stop the clock

# HuanChen's method
ptm <- proc.time() # Start the clock!
tmpCurve <- ppclp3D(y[, 1], y[, 2], y[, 3],
            spectExample$xFix, spectExample$yFix, spectExample$zFix)

time.table[2, ] <- proc.time() - ptm # Stop the clock

# Hastie's method
ptm <- proc.time() # Start the clock!
fit <- principal_curve(y, thresh = 1e-3, maxit = 100)
time.table[3, ] <- proc.time() - ptm # Stop the clock

save(time.table, fitlength, tmpCurve, fit, file = "colon.RData")


library(BIBtests, quietly=TRUE)

CHECK <- function(test, truth) stopifnot(all.equal(test, truth))
TESTING <- function(what) cat(paste0(what, ": "))
OK <- function() cat("ok!\n")

set.seed(1234)
m = 10
n = 5
x = matrix(rnorm(m*n), m, n)
x = cov(x)

cat("# LAPACK\n")

TESTING("invert")
test = bib_invert(x)
truth = solve(x)
CHECK(test, truth)
OK()

cat("\n")


#INDEXING

library(dslabs)
library(tidyverse)
data (murders)

murder_rate <- murders$total/murders$population*100000

index <- murder_rate <= 0.71
#if we return index, it will show true and false values

murders$state[index]
#this will return each satate with true values of a murder_rate

sum(index)
#we can sum logical vectors to count TRUE ones. TRUE = 1, FASLSE = 0.
#sum(index) will return 5

#lets try another example: We want to move to mountains with rate <=1
safe <- murder_rate <= 1
west <- murders$region == "West"

index <- safe & west

murders$state[index]


plotfitcold <- function(df,xx,yy,byvar,xlimspec=NULL,ylimspec=NULL,bg="grey90",outputfile=NULL) {
    ## create scatter plot with linear regression line and 95% confidence lines
    ## xx and yy are variables within dataframe df
    ## color datapoints by DISCRETE variable byvar  <-- This is the distinction from plotfitcol
    ## required inputs: df, xx, yy, byvar
    ## example usage: plotfitcold(df,hsub_in,power_ratio_fb,TS_ID)                        # to write to screen
    ##                plotfitcold(df,hsub_in,power_ratio_fb,TS_ID,outputfile="trend.jpg") # to write to jpg file
    ##                plotfitcold(df,hsub_in,power_ratio_fb,TS_ID,ncol=4)                 # 4 colors for byvar

    ## uncomment following breakpoit to enter debugger when source in rstudio
    ## browser()
    ## source main program then use F10 to step through after break point

    xlabel  <- deparse(substitute(xx))
    ylabel  <- deparse(substitute(yy))
    bylabel <- deparse(substitute(byvar))
    xx    <- eval(substitute(xx),df)    # need to recognize name passed into function as xx
    yy    <- eval(substitute(yy),df)
    byvar <- eval(substitute(byvar),df)

    ## debug
    ##xlabel <- deparse("gnom")
    ##ylabel <- deparse("average_g_ts")
    ##bylabel <- deparse("TS_ID")
    ##xx    <- eval(substitute(gnom),df)    ## need to recognize name passed into function as xx
    ##yy    <- eval(substitute(average_g_ts),df)
    ##byvar <- eval(substitute(TS_ID),df)

    ## create dataframe with parameters to be plotted
    newdf <- data.frame(xx,yy,byvar)

    ## perform regression
    fit       <- lm(yy~xx,data=newdf)
    intercept <- fit$coefficients[[1]]
    slope     <- fit$coefficients[[2]]
    eq = paste0("y = ", signif(intercept,4), "* x + ", signif(slope,4))

    ## determine x and y range for plot
    xmin <- min(newdf$xx,na.rm=TRUE)
    xmax <- max(newdf$xx,na.rm=TRUE)
    xmax_plot <- xmax + (xmax-xmin)*0.2  # did this to make room for a legend
    ymin <- min(newdf$yy,na.rm=TRUE)
    ymax <- max(newdf$yy,na.rm=TRUE)
    if (missing(xlimspec)) { xlimspec <- c(xmin,xmax_plot) }
    if (missing(ylimspec)) { ylimspec <- c(ymin,ymax) }
    if (!missing(outputfile)) jpeg(filename=outputfile)

    ## add color definition for each point using byvar
    ##cols <- c("blue","red")                         # define colors
    ##cols <- brewer.pal(11,"Spectral")             # Spectral color pallette has ncol=11 colors
    ##cols <- c("black","blue","green","grey","orange","red")
    ##cols <- c("black","blue","darkorchid2","darkturquoise","darkgreen","green","deeppink","magenta","red")
    ##cols <- c("black","darkturquoise","pink","red")
    ##pal  <- colorRampPalette(cols)                  # define color pallette
    cols <- data.frame(byvar=unique(c(as.character(newdf$byvar))))
    ncol <- nrow(cols)
    pal <- rainbow(ncol)
    ## library(scales) # needed for show_col
    ## show_col(pal)
    cols$color <- pal
    newdf <- merge(newdf, cols, by="byvar")

    ## create plot of points
    par(bg=bg)  # changes background of plot to specified color
    plot(newdf$xx,newdf$yy,xlim=xlimspec,ylim=ylimspec,
         xlab=xlabel,ylab=ylabel,main=eq,
         col=newdf$color)

    ## add fit to plot
    new.xx <- seq(min(newdf$xx,na.rm=TRUE),max(newdf$xx,na.rm=TRUE),len=100)
    fit    <- lm(yy~xx,data=newdf)
    pred   <- predict(fit, new=data.frame(xx=new.xx), interval="conf", level=1-0.05)
    lines(new.xx,pred[,"fit"],lwd=2)
    lines(new.xx,pred[,"lwr"],lty=3)
    lines(new.xx,pred[,"upr"],lty=3)

    ## add legend
    legendcolor <- unique(newdf$color)
    legendlabel <- unique(newdf$byvar)
    ##legend("right",title=bylabel,col=pal(ncol), pch=19,legend=round(legendlabel))
    ##legend("bottomright",title=bylabel,col=newdf$byvar, pch=19,legend=legendlabel)
    legend("bottomright", title=bylabel, col=legendcolor, pch=19, legend=legendlabel)

    ## four output file
    if (!missing(outputfile)) dev.off()

    ## print results of fit
    estbound(fit)

    ## return variables for debugging
    return(list( newdf=newdf, cols=cols, legendcolor=legendcolor, legendlabel=legendlabel, fit=fit))
}
## example: plotfitcold(df,gnom,average_g_ts,TS_ID,bg="white")
##          plotfitcold(mtcars, disp, mpg, byvar=cyl)


#we may create vectors of class numeric or character with the concatenate function
#c stands stands for concantenate btw
codes <- c(380,124,818)
country <- c("Italy","Canada","Egypy")

#we can also name the element of a numeric vector
#note that the two lines of code below have the same result
 codes <- c(Italy= 380, Canada= 124, Egypt= 818)
 codes <- c("Italy" = 380, "Canada" = 124, "Egypt" = 818)

#we can also name the elements of a numeric vector using the names() function
codes <- c(380, 124, 818)
country <- c("Italy", "Canada", "Egypt")
names(codes) <- country

# using square brackets is useful for subsetting to access specific elements of qa vector
codes[2]
codes[c(1,3)]
codes[1:2]

#If the entries of a vector are named, they may be accessed by referring to their name
codes["Canada"]
codes[c("Egypt", "Italy")]


x <- c(5,5,5,13,7,11,11,9,8,9)
y <- c(11,8,4,5,9,5,10,5,4,10)

# Separado
boxplot(x, main="Conjunto X")
boxplot(y, main="Conjunto Y")


#' Iterator that generates all permutations of an iterable object.
#'
#' Constructs an iterator generates all permutations of an iterable object. By
#' default, full-length permutations are generated. If \code{m} is specified,
#' successive \code{m} length permutations are instead generated.
#'
#' The implementation is loosely based on that of Python's itertools.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param object vector
#' @param m length of permutations. By default, full-length permutations are
#' generated.
#' @return iterator that generates all permutations of \code{object}
#'
#' @examples
#' it <- ipermutations(1:3)
#'
#' iterators::nextElem(it) # c(1, 2, 3)
#' iterators::nextElem(it) # c(1, 3, 2)
#' iterators::nextElem(it) # c(3, 1, 2)
#' iterators::nextElem(it) # c(3, 2, 1)
#' iterators::nextElem(it) # c(2, 3, 1)
#' iterators::nextElem(it) # c(2, 1, 3)
#'
#' it2 <- ipermutations(letters[1:4])
#' # 24 = 4! permutations of the letters a, b, c, and d
#' as.list(it2)
#'
ipermutations <- function(object, m=NULL) {
  object <- as.vector(object)
  n <- length(object)

  # By default, m == n for full-length permutations.
  if (is.null(m)) {
    m <- n
  } else {
    m <- as.integer(m)
  }

  # Traverses through the Cartesian product of indices
  # Skips any cases where the indices are not unique
  # The unique indices generate the permutations
  # This approach is similar to how Python's itertools works
  replicate_n <- replicate(n=m, seq_len(n), simplify=FALSE)
  iter_product <- do.call(itertools2::iproduct, replicate_n)

  nextElem <- function() {
    repeat {
      indices <- unique(iterators::nextElem(iter_product))
      if (length(indices) == m) {
        return(object[unlist(indices)])
      }
    }
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


# Plotting regression results
library(ggplot2)
x_grid = seq(min(dataset$indep), max(dataset$indep), 0.1)
ggplot() +
    geom_point(aes(x = dataset$indep, y = dataset$dep),
               colour = 'red') +
    geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level = x_grid))),
              colour = 'blue') +
    ggtitle('Title') +
    xlab('x variable') +
    ylab('y variable')

# For SVM :)
clf = svm(Purchased ~ .,
          data = train,
          kernel = 'radial',
          type = 'C-classification')
plot(clf, data = train)

# Plotting two variable classification
library('ElemStatLearn')
set = train
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(clf, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set > 0.5, 1, 0)
plot(set[, -3],
     main = 'Logistic Regression (Training set)',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))

# Cluster plot
clusplot(X,
         kmeans$cluster,
         lines = 0,
         shade = TRUE,
         color = TRUE,
         labels = 2,
         plotchar = FALSE,
         span = TRUE,
         main = paste('Clusters of customers'),
         xlab = 'Annual Income',
         ylab = 'Spending Score')


temperatures = data.frame(
    fahrenheit = c(5,14,23,32,41,50),
    celsius = c(-15,-10,-5,0,5,10)
)
model = lm(fahrenheit ~ celsius, data = temperatures)
print(model)


library(stats)
library(float, quietly=TRUE)
library(rbenchmark)
set.seed(1234)

reps = 5
cols <- c("test", "replications", "elapsed", "relative")

m = 7500
n = 500
x = matrix(rnorm(m*n), m, n)
s = fl(x)

pca_spm = function(x)
{
  p = svd(scale(x, TRUE, FALSE), nu=0)
  p$d = p$d / max(1, sqrt(nrow(x) - 1))
  names(p) = c("sdev", "rotation")

  p
}

pca = function(x) prcomp(x, retx=FALSE)

benchmark(pca_spm(x), pca_spm(s), pca(x), replications=reps, columns=cols)


##' Estimate minimum specificity of the antigen test used for mass testing in
##' Slovakia
##'
##' @importFrom dplyr select filter rowwise mutate group_by summarise ungroup
##' @importFrom tibble tibble
##' @importFrom tidyr pivot_longer separate pivot_wider expand_grid nest unnest
##' @importFrom purrr map
##' @export
##' @param cutoff probability cut-off, i.e. x if minimal specificty is to be
##' estabilshed with probability >= x
estimate_min_specificity <- function(cutoff = 0.95) {
  ms.tst %>%
    select(county, attendance_1, attendance_2, attendance_3,
           positive_1, positive_2, positive_3) %>%
    pivot_longer(-county) %>%
    separate("name", c("name", "round"),"_") %>%
    pivot_wider() %>%
    filter(!is.na(attendance)) -> dta

  N <- 100
  samples <- 100

  spec <- dta %>%
    expand_grid(specificity = seq(99.7/100, 99.9995/100, length.out = N)) %>%
    ## probability of seeing positives given specificty is at most x
    ## (where at the maximum all positives are false positives)
    mutate(p = 1 - pbeta(1 - specificity, positive + 1,
                         attendance - positive + 1)) %>%
    group_by(specificity) %>%
    ## overall probability that specificity is at most x
    summarise(probability = prod(p), .groups = "drop") %>%
    ungroup() %>%
    ## get probability that specificity is at least x
    filter(probability < 1 - cutoff) %>%
    summarise(min_spec = max(specificity)) %>%
    .$min_spec

  return(spec)
}


source('hmm.r')

M = 3

mu_ref <- c(4, 4.5, 4.25)
sigma_mu_ref <- c(0.25, 0.35, 0.3)

eta_ref <- c(150000, 60000, 100000)
sigma_eta_ref <- c(50000, 20000, 25000)

A_ref <-matrix(c(0.3, 0.2, 0.5, 0.3, 0.3, 0.4, 0.15, 0.2, 0.65), nrow = M, ncol = M, byrow = TRUE)

N = 140
T = 40

p_increment <- matrix(0, ncol = T, nrow = N)
volume <- matrix(0, ncol = T, nrow = N)

for (n in 1:N){
  state_prob <- c(0.3, 0.3, 0.4)
  for (t in 1:T){
    state <- rmultinom(1, 1, state_prob)
    mu <- mu_ref[state == 1]
    sigma_mu <- sigma_mu_ref[state == 1]
    eta <- eta_ref[state == 1]
    sigma_eta <- sigma_eta_ref[state == 1]

    p_increment[n,t] = rnorm(1, mean = mu, sd = sigma_mu)
    volume[n,t] = rnorm(1, mean = eta, sd=sigma_eta)

    state_prob = t(state) %*% A_ref

  }
}

system.time({estimate <- EM(p_increment, volume, M)})


# Assessing R2 shrinkage using 10-Fold Cross-Validation

fit <- lm(y ~ x1 + x2 + x3, data = mydata)

library(bootstrap)
# define functions
theta.fit <- function(x, y) {
    lsfit(x, y)
}
theta.predict <- function(fit, x) {
    cbind(1, x) %*% fit$coef
}

# matrix of predictors
X <- as.matrix(mydata[c("x1", "x2", "x3")])
# vector of predicted values
y <- as.matrix(mydata[c("y")])

results <- crossval(X, y, theta.fit, theta.predict, ngroup = 10)
cor(y, fit$fitted.values)^2  # raw R2
cor(y, results$cv.fit)^2  # cross-validated R2


# A simple 2-layer neural network uses Perceptron as the activation function.
#
#          x - Descriptive features, multi-column table later converted to mxn matrix
#          y - Target feature, single column table later converted to 1D matrix
# yhat_train - zero matrix of same dimensions as y
#         w1 - first weight matrix with number of rows matching column
#              number of x and w1 column number equal to the number of nodes.
#              Initialized with unseeded random variable between 0 and 1
#         w2 - second weight matrix, 1D array with number of rows matching
#              node number
#              Initialized with unseeded random variable between 0 and 1
#         h1 - layer 1 of the heural network. Same number of rows as input
#              and column number equal to the number of nodes. Initialized with
#              zeros for all elements
#        dw1 - first weight gradient, dimensions match w1. Initialized with
#              zeros for all elements
#        dw2 - first weight gradient, dimensions match w2. Initialized with
#              zeros for all elements

perceptron <- function(input, output, n){
  nnclass <- setClass(
    "neural_net",
    slots = c(
      x = "matrix",
      y = "matrix",
      yhat_train = "matrix",
      w1 ="matrix",
      w2 ="matrix",
      h1 ="matrix",
      dw1 ="matrix",
      dw2 ="matrix"
    )
  )

  neural_net <- nnclass(
    x = as.matrix(input),
    y = as.matrix(output),
    yhat_train = matrix(0L,
                        nrow = dim(as.matrix(output))[1],
                        ncol = dim(as.matrix(output))[2]),
    w1 = matrix(runif(ncol(input)*n, 0, 1), nrow = ncol(input), ncol = n),
    w2 = matrix(runif(n, 0, 1), nrow = n, ncol=1),
    h1 = matrix(0L, nrow = nrow(input), ncol = n),
    dw1 = matrix(0L, nrow = ncol(input), ncol = n),
    dw2 = matrix(0L, nrow = n, ncol = 1)
  )

  setGeneric("feedforward", function(neural_net)
    standardGeneric("feedforward"))

  setGeneric("backprop", function(neural_net)
    standardGeneric("backprop"))

  # Feedfoward method updates h1 and yhat_train matrices
  setMethod(f = "feedforward", signature = "neural_net",
            function(neural_net){
              neural_net@h1 <- activation(dot(neural_net@x, neural_net@w1))
              neural_net@yhat_train <- activation(dot(neural_net@h1, neural_net@w2))
              return(neural_net)
            })

  # Backprop method updates weights and weight gradient matrices
  setMethod(f = "backprop", signature = "neural_net",
            function(neural_net){
              neural_net@dw1 <- dot(t(neural_net@x),
                                    dot(2*(neural_net@y - neural_net@yhat_train) *
                                    activation_der(neural_net@yhat_train), t(neural_net@w2)) *
                                    activation_der(neural_net@h1))
              neural_net@dw2 <- dot(t(neural_net@h1),
                                    2*(neural_net@y-neural_net@yhat_train) *
                                    activation_der(neural_net@yhat_train))
              neural_net@w1 = neural_net@w1 + neural_net@dw1
              neural_net@w2 = neural_net@w2 + neural_net@dw2
              return(neural_net)
            })

  return(neural_net)
}

# functions

dot <- function(a, b){
  c <- a %*% b
  return(c)
}

# sigmoid function
activation <- function(z){
  sigmoid <- 1/ (1 + exp(-z))
  return(sigmoid)
}

# Derivative of sigmoid function
activation_der <- function(z){
  sigmoid_der <- (activation(z)) * (1 - activation(z))
  return(sigmoid_der)
}

# Threshold function with binay output of 0 or 1 based on a threshold value f
# Kept separate from neural network classes as this can be used on test and train data
threshold <- function(yhat_thresh, f){
  yhat_thresh <- as.matrix(yhat_thresh)
  for(i in 1:nrow(yhat_thresh)){
    if (yhat_thresh[i,] < f){
      yhat_thresh[i,] <- 0L
    } else {
      yhat_thresh[i,] <- 1L
    }
  }
  return(yhat_thresh)
}

result <- function(result_x, result_w1, result_w2){
  result_x = as.matrix(result_x)
  result_h1 <- activation(dot(result_x, result_w1))
  yhat_test <- activation(dot(result_h1, result_w2))
  return(yhat_test)
}


#' @export
#' @title convert.degdec2degmin
#' @description This function converts decimals to degree and minute notation
#' @param \code{x} = dataframe to be handled, with lat and lon colnames
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @examples
#' test=as.data.frame(cbind(42.5,55.255))
#' colnames(test)=c("lat","lon")
#' convert.degdec2degmin(test)
#' lat    lon
#' 1 42.3 55.153
#' (55.153 is 55deg 15.3min)
#' @family coordinate converters
#' @export
  convert.degdec2degmin = function (x) {
    x$lat = trunc(x$lat) + round(((x$lat - trunc(x$lat))/100) * 60, 6)
    x$lon = trunc(x$lon) + round(((x$lon - trunc(x$lon))/100) * 60, 6)
    return (x)
  }


 ZTGSEN Example Program Results

 Reordered Schur matrix A
                    1                 2                 3                 4
 1  ( 4.6904, 2.3452) (-2.1563, 0.1192) ( 1.9599,-0.5174) ( 1.8091,-1.2060)
 2  ( 0.0000, 0.0000) ( 2.0084,-1.0042) ( 0.9161,-0.2762) ( 1.8574,-0.5326)
 3  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 1.6985, 1.6985) ( 0.1270, 0.7231)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 6.0000,-2.0000)

 Reordered Schur matrix B
                    1                 2                 3                 4
 1  ( 2.3452, 0.0000) (-0.6181, 1.8237) ( 0.9290, 0.5409) ( 2.7136,-1.5076)
 2  ( 0.0000, 0.0000) ( 1.0042, 0.0000) ( 1.2251,-1.1857) ( 1.8541,-0.2929)
 3  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.8492, 0.0000) ( 0.1435, 0.9053)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 0.0000, 0.0000) ( 2.0000, 0.0000)

 Basis of left deflating invariant subspace
                    1                 2
 1  ( 0.9045, 0.3015) (-0.0033,-0.2397)
 2  ( 0.3015, 0.0000) ( 0.2497, 0.7157)
 3  ( 0.0000, 0.0000) ( 0.0549, 0.6042)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000)

 Basis of right deflating invariant subspace
                    1                 2
 1  ( 0.7071, 0.0000) (-0.5607, 0.0000)
 2  ( 0.7071, 0.0000) ( 0.5607, 0.0000)
 3  ( 0.0000, 0.0000) ( 0.0552, 0.6067)
 4  ( 0.0000, 0.0000) ( 0.0000, 0.0000)

 Norm estimate of projection onto left  eigenspace for selected cluster
   8.90E+00

 Norm estimate of projection onto right eigenspace for selected cluster
   7.02E+00

 F-norm based upper bound on Difu
   2.18E-01

 F-norm based upper bound on Difl
   2.62E-01


 DTPQRT Example Program Results

 solution(s) for n rows
             1          2
 1      1.5179    -1.5850
 2      1.8629     0.5531
 3     -1.4608     1.3485
 4      0.0398     2.9619

 Least squares solution(s) for all rows
             1          2
 1      1.5339    -1.5753
 2      1.8707     0.5559
 3     -1.5241     1.3119
 4      0.0392     2.9585

 Square root(s) of the residual sum(s) of squares
        2.22E-02   1.38E-02


bhuffman <- function (pvecin) {
    # Remove all zeros from vec - no code is needed for them
    pvec=pvecin[which(pvecin>0)];

    # Make couple of checks
    if (class(pvec) != "numeric") stop("Input must be numeric");
    if (length(pvec) < 2) stop("Numbers of positive elements must be 2 or more");

    # Recursion stop condition if the number of rows exactly 2
    if (length(pvec) == 2) return(c("0","1"));

    # Compress low probabilities values and call again. Use last min
    min1loc <- length(pvec)-which.min(rev(pvec))+1;
    min1 <- pvec[min1loc];
    pvec <- pvec[-min1loc];
    # min2loc <- which.min(pvec);
    min2loc <- length(pvec)-which.min(rev(pvec))+1;
    min2 <- pvec[min2loc];
    pvec <- pvec[-min2loc];
    pvec <- append(pvec,min1+min2);

    code <- bhuffman(pvec);

    # Get the last entry code, remove it and add split it back to previous entries
    min1code <- paste0(tail(code,n=1),"0");
    min2code <- paste0(tail(code,n=1),"1");
    # Remove last entry and add this code to the min1, min2 locations
    code <- code[-length(code)];
    # Add back the new codes
    code <- append(code,min2code,min2loc-1);
    code <- append(code,min1code,min1loc-1);

    return(code);
}

r = 0

executeTask <- function(i) {

    	p=c("space"=6, "a"=3, "c"=1, "d"=1, "e"=3, "f"=2, "g"=1, "h"=1, "i"=3, "l"=1, "m"=2, "n"=3, "o"=2, "p"=1, "s"=2, "t"=1)
   	bhuffman(p/sum(p))
	return(i+1)
}

for ( i in 0:1000000 ) {
	r = executeTask(i+r)
}


#' Percent Change Without Div by 0 Error
#'
#' Calculates the percent change of two numbers or vectors, if prior = 0 then percent change is 100%
#'
#' @param prior A numeric object
#' @param current A numeric object
#' @param format If TRUE (default) then output is converted to a percentage with formattable, otherwise proportion
#' @param ... Any arguments passed to formattable::percent, most likely digits
#'
#' @export
#'
#' @examples
#' pct_change(0, 1) returns 100.00%
#' pct_change(2, 3, format = F) returns 0.5
#'

pct_change <- function(prior, current, format = T, ...){

  out <- ifelse(prior == 0, sign(current), (current/prior) - 1)

  if(format == T){
    formattable::percent(out, ...)
  }else{
      out}

}


#
# Don't complain; just work harder! Dan Stanford
#
# Our responsibility is to do what we can, learn what we can, improve the solutions, and pass them on. RF
#
# @author: me@andreagirardi.it
# @since: Wed Jan  8 19:11:27 CET 2020
# @project: RExercises
# @module: Data Frame lesson
# @desc:
#
#

# Recreate the following dataframe by creating vectors and using the data.frame function:

> Age <- c(22, 25, 26)
> Weight <- c(150, 165, 120
> Sex <- c('M', 'M', 'F')
> df <- data.frame(Age, Weight, Sex)
> df
  Age Weight Sex
1  22    150   M
2  25    165   M
3  26    120   F

> row.names(df) <- c('Sam', 'Frank', 'Amy')
> df
      Age Weight Sex
Sam    22    150   M
Frank  25    165   M
Amy    26    120   F

# Alternative
df <- data.frame(row.names = c('Sam', 'Frank', 'Amy'), Age, Weight, Sex)

# Check if it is a data frame
> is.data.frame(df)
[1] TRUE

# Ex 3: Use as.data.frame() to convert a matrix into a dataframe:
# In [3]:
> mat <- matrix(1:25,nrow = 5)

> dfm <- data.frame(mat)

> dfm
  X1 X2 X3 X4 X5
1  1  6 11 16 21
2  2  7 12 17 22
3  3  8 13 18 23
4  4  9 14 19 24
5  5 10 15 20 25

> colnames(dfm) <- c('V1', 'V2', 'V3', 'V4', 'V5')

> dfm
  V1 V2 V3 V4 V5
1  1  6 11 16 21
2  2  7 12 17 22
3  3  8 13 18 23
4  4  9 14 19 24
5  5 10 15 20 25

# Alternative
> as.data.frame(mat)
  V1 V2 V3 V4 V5
1  1  6 11 16 21
2  2  7 12 17 22
3  3  8 13 18 23
4  4  9 14 19 24
5  5 10 15 20 25

# Ex 5: Display the first 6 rows of df
> dfc <- mtcars
> dfc[1:6, ]
                   mpg cyl disp  hp drat    wt  qsec vs am gear carb
Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

# Ex 6: What is the average mpg value for all the cars?
> mean(dfc$mpg)
[1] 20.09062

# Ex 7: Select the rows where all cars have 6 cylinders (cyl column)
> subset(dfc, subset = cyl == 6)
                mpg cyl  disp  hp drat    wt  qsec vs am gear carb
Mazda RX4      21.0   6 160.0 110 3.90 2.620 16.46  0  1    4    4
Mazda RX4 Wag  21.0   6 160.0 110 3.90 2.875 17.02  0  1    4    4
Hornet 4 Drive 21.4   6 258.0 110 3.08 3.215 19.44  1  0    3    1
Valiant        18.1   6 225.0 105 2.76 3.460 20.22  1  0    3    1
Merc 280       19.2   6 167.6 123 3.92 3.440 18.30  1  0    4    4
Merc 280C      17.8   6 167.6 123 3.92 3.440 18.90  1  0    4    4
Ferrari Dino   19.7   6 145.0 175 3.62 2.770 15.50  0  1    5    6

# Ex 8: Select the columns am,gear, and carb.
> dfc[, c('am', 'gear', 'carb')]
                    am gear carb
Mazda RX4            1    4    4
Mazda RX4 Wag        1    4    4
Datsun 710           1    4    1
Hornet 4 Drive       0    3    1
Hornet Sportabout    0    3    2
Valiant              0    3    1
Duster 360           0    3    4
Merc 240D            0    4    2
Merc 230             0    4    2
Merc 280             0    4    4
Merc 280C            0    4    4
Merc 450SE           0    3    3
Merc 450SL           0    3    3
Merc 450SLC          0    3    3
Cadillac Fleetwood   0    3    4
Lincoln Continental  0    3    4
Chrysler Imperial    0    3    4
Fiat 128             1    4    1
Honda Civic          1    4    2
Toyota Corolla       1    4    1
Toyota Corona        0    3    1
Dodge Challenger     0    3    2
AMC Javelin          0    3    2
Camaro Z28           0    3    4
Pontiac Firebird     0    3    2
Fiat X1-9            1    4    1
Porsche 914-2        1    5    2
Lotus Europa         1    5    2
Ford Pantera L       1    5    4
Ferrari Dino         1    5    6
Maserati Bora        1    5    8
Volvo 142E           1    4    2

# Ex 9: Create a new column called performance, which is calculated by hp/wt.
> dfc$performance <- dfc$hp / dfc$wt

# Ex 10: Your performance column will have several decimal place precision. Figure out how to use round() (check help(round)) to reduce this accuracy to only 2 decimal places.
> dfc$performance <- round(dfc$performance, 2)

# Ex 10: What is the average mpg for cars that have more than 100 hp AND a wt value of more than 2.5.
> mean(dfc[dfc$hp > 100 & dfc$wt >= 2.5, c('mpg')])
[1] 16.86364

#Alternative
> mean(subset(dfc, hp > 100 & wt > 2.5)$mpg)
[1] 16.86364

# Ex 11: What is the mpg of the Hornet Sportabout?
> dfc['Hornet Sportabout',]$mpg
[1] 18.7


source('hmm_v2.r')
library(MASS)

M = 3
dim_num = 2

avg_1_ref <- c(4, 4.5, 4.25)
avg_2_ref <- c(150000, 60000, 100000)

std_1_ref <- c(0.25,0.35,0.3)
std_2_ref <- c(50000, 20000, 25000)

mu_ref <- matrix(c(avg_1_ref, avg_2_ref), nrow = dim_num, ncol = M, byrow = TRUE)
std_ref <- matrix(c(std_1_ref, std_2_ref), nrow = dim_num, ncol = M, byrow = TRUE)
cov_ref <- array(0, dim = c(dim_num,dim_num,M))

for (s in 1:M){
  for (i in 1:dim_num){
    for (j in i:dim_num){
      if (i == j){
        cov_ref[i,j,s] = std_ref[i,s]^2
      }
      else{
        cov_ref[i,j,s] = std_ref[i,s] * std_ref[j,s] * runif(1,min = -1, max = 1)
        cov_ref[j,i,s] = cov_ref[i,j,s]
      }
    }
  }
}

A_ref <-matrix(c(0.3, 0.2, 0.5, 0.3, 0.3, 0.4, 0.15, 0.2, 0.65), nrow = M, ncol = M, byrow = TRUE)

N = 140
T = 40

test_data <- array(0, dim = c(dim_num, T, N))

p_increment <- matrix(0, ncol = T, nrow = N)
volume <- matrix(0, ncol = T, nrow = N)

for (n in 1:N){
  state_prob <- c(0.3, 0.3, 0.4)
  for (t in 1:T){
    state <- rmultinom(1, 1, state_prob)
    mu <- mu_ref[,state == 1]
    cov_m <- cov_ref[,,state == 1]

    test_data[,t,n] = mvrnorm(1, mu = mu, Sigma = cov_m)

    state_prob = t(state) %*% A_ref

  }
}

system.time({estimate <- EM(test_data, M)})


# load track popularity data
track_pop <- read.csv("C:/your_path/track_pop.csv", quote="")

# Shapiro-Wilk test for normality
apply(track_pop, 2, shapiro.test)

# all p-values are way smaller than 0.05
# Ho that data are normally distributed is rejected

# import tidyr to reshape data (dropped NA)
library(tidyr)
track_long <- gather(track_pop, "category", "popularity", na.rm = TRUE)

# import car to conduct Brown-Forsythe test for equal variance
# Brown-Forsythe is more robust than Levene's test for non-normally distributed data
library(car)
leveneTest(track_long$popularity, track_long$category)

# p-value is way smaller than 0.05
# Ho of equal variance is rejected

# Kruskal-Wallis test for non-normally distributed data of unequal variance
kruskal.test(track_pop)

# p-value is way smaller than 0.05
# Ho that all groups having same median ranks is rejected

# import library for post-hoc: Dunn's test for identifying groups with different median
library(FSA)
dunnTest(track_long$popularity, track_long$category, method = 'bh')

# p-values of pair no.4 to 9 are way smaller than 0.05
# Ho that groups in each of those pairs having the same median is rejected

# load album popularity data
album_pop <- read.csv("C:/your_path/album_pop.csv", quote="")

# Shapiro-Wilk test for normality
apply(album_pop, 2, shapiro.test)

# all p-values are way smaller than 0.05
# Ho that data are normally distributed is rejected

# tidyr to reshape data (dropped NA)
album_long <- gather(album_pop, "category", "popularity", na.rm = TRUE)

# Brown-Forsythe test for equal variance
leveneTest(album_long$popularity, album_long$category)

# p-value is way smaller than 0.05
# Ho of equal variance is rejected

# Kruskal-Wallis test for unequal variance for non-normally distributed data
kruskal.test(album_pop)

# p-value is way smaller than 0.05
# Ho that all groups having same median ranks is rejected

# Post-hoc: Dunn's test for identifying groups with different median
dunnTest(album_long$popularity, album_long$category, method = 'bh')

# p-values of pair no.4 to 9 are way smaller than 0.05
# Ho that groups in each of those pairs having the same median is rejected

# load artist popularity data
artist_pop <- read.csv("C:/your_path/artist_pop.csv", quote="")

# Shapiro-Wilk test for normality
apply(artist_pop, 2, shapiro.test)

# p-values of artists competing in Latin Jazz Album and
# Large Jazz Ensemble Album categories are smaller than 0.05
# Ho that data are normally distributed is rejected
# Data of other groups are not normally distributed

# tidyr to reshape data (dropped NA)
artist_long <- gather(artist_pop, "category", "popularity", na.rm = TRUE)

# Brown-Forsythe test for equal variance
leveneTest(artist_long$popularity, artist_long$category)

# p-value is larger than 0.05
# Ho of equal variance is accepted

# Kruskal-Wallis test also works for data of equal variance
kruskal.test(artist_pop)

# p-value is way smaller than 0.05
# Ho that all groups having same median ranks is rejected

# Post-hoc: Dunn's test
# for identifying groups with different median
dunnTest(artist_long$popularity, artist_long$category, method = 'bh')

# p-values of pair no.4 to 9 are way smaller than 0.05
# Ho that groups in each of those pairs having the same median is rejected