# analysis.r
# A3 Source Code File
#
# ------------------------------------------------------------------------------
#
# Eric Large
# INFO 201 AF
# 2022-02-17
#
# ------------------------------------------------------------------------------
#
# Libraries
library("tidyverse")
library("usmap")
#
# ------------------------------------------------------------------------------
#
# Loading in the `incarceration_trends.csv` data frame
df <- read.csv("https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv",
  header = TRUE, stringsAsFactors = FALSE
)
View(df)
#
# ------------------------------------------------------------------------------
#
# Summary Information (5 statistics calculated from data set)
#
## 1. As of the most recent year, Which county has the highest population of
##    incarcerated Black people in prison (black_prison_pop)?
df_2 <- df %>%
  select(county_name, year, black_prison_pop, total_prison_pop) %>%
  replace_na(list(black_prison_pop = 0)) %>%
  replace_na(list(total_prison_pop = 0))

county_highest_pop <- df_2 %>%
  filter(black_prison_pop > 0) %>%
  filter(year == max(year)) %>%
  filter(black_prison_pop == max(black_prison_pop)) %>%
  pull(county_name)

# Returns "Los Angeles County"

## 2. In Los Angeles County, what is the ratio of incarcerated Black people (black_prison_pop)
##    to the total incarcerated population in prison (total_prison_pop)?
total_black_prison_pop <- df_2 %>%
  filter(black_prison_pop > 0) %>%
  filter(year == max(year)) %>%
  filter(black_prison_pop == max(black_prison_pop)) %>%
  pull(black_prison_pop)

# Returns 15,853 incarcerated Black people

total_prison_pop <- df_2 %>%
  filter(grepl("Los Angeles County", county_name)) %>%
  filter(total_prison_pop > 0) %>%
  filter(year == max(year)) %>%
  pull(total_prison_pop)

# Returns 42,940 incarcerated people

ratio_black_total_pop <- (total_black_prison_pop / total_prison_pop)

# Returns 0.369 or ~37%

### Data Wrangling for Chart2
black_pop <- df_2 %>%
  filter(black_prison_pop > 0) %>%
  group_by(year) %>%
  summarize(mean(black_prison_pop))

total_pop <- df_2 %>%
  filter(total_prison_pop > 0) %>%
  group_by(year) %>%
  summarize(mean(total_prison_pop))

prison_pop <- left_join(total_pop, black_pop, by = "year")

colnames(prison_pop) <- c("year", "avg_total_pop", "avg_black_pop")

## 3. According to the most recent year, how many Black people were sent to
##    prison in Los Angeles County (black_prison_adm) as compared to the total number
##    of admitted prisoners (total_prison_adm), regardless of race? (ratio)

# Creating data frame with prison admission information
df_3 <- df %>%
  select(county_name, year, black_prison_adm, total_prison_adm) %>%
  replace_na(list(black_prison_adm = 0)) %>%
  replace_na(list(total_prison_adm = 0))

# Black prison admissions in Los Angeles County
total_black_prison_adm <- df_3 %>%
  filter(grepl("Los Angeles County", county_name)) %>%
  filter(black_prison_adm > 0) %>%
  filter(year == max(year)) %>%
  filter(black_prison_adm == max(black_prison_adm)) %>%
  pull(black_prison_adm)

# Returns 3,188 admissions of Black people into prison

# Total prison admissions in Los Angeles County
total_prison_adm <- df_3 %>%
  filter(grepl("Los Angeles County", county_name)) %>%
  filter(total_prison_adm > 0) %>%
  filter(year == max(year)) %>%
  filter(total_prison_adm == max(total_prison_adm)) %>%
  pull(total_prison_adm)

# Returns 9,957 total admissions into prison

# Ratio of Black prison admissions to total prison admissions for Los Angeles
# County in the most recent year
ratio_black_total_adm <- (total_black_prison_adm / total_prison_adm)

# Returns 0.32 or ~32% of all admitted prisoners in Los Angeles County were Black

## 4. How have the average admissions of incarcerated Black people in prison
##    (black_prison_adm) changed since data collection on the variable began in 1970?
yearly_black_avg_adm <- df_3 %>%
  filter(black_prison_adm > 0) %>%
  group_by(year) %>%
  summarize(mean(black_prison_adm))

colnames(yearly_black_avg_adm) <- c("Year", "Avg_Admissions")

## 5. Average Yearly Admissions for Black and White Males

# Creating data frame with variables of interest
df_4 <- df %>%
  select(year, county_name, black_male_prison_adm, white_male_prison_adm) %>%
  replace_na(list(black_male_prison_adm = 0)) %>%
  replace_na(list(white_male_prison_adm = 0))

b_a_m <- df_4 %>%
  filter(black_male_prison_adm > 0) %>%
  group_by(year) %>%
  summarize(mean(black_male_prison_adm))

w_a_m <- df_4 %>%
  filter(white_male_prison_adm > 0) %>%
  group_by(year) %>%
  summarize(mean(white_male_prison_adm))

male_racial_avg <- left_join(b_a_m, w_a_m, by = "year")

colnames(male_racial_avg) <- c("year", "black_male_adm", "white_male_adm")

# ------------------------------------------------------------------------------
# Chart of average Black & WHite male admissions over time (1970-2016):
theme_set(theme_bw())

# plot
chart1 <- ggplot(male_racial_avg, aes(x = year)) +
  geom_line(aes(y = black_male_adm, col = "Black Males")) +
  geom_line(aes(y = white_male_adm, col = "White Males")) +
  labs(
    title = "Yearly Average Male Prison Admissions",
    subtitle = "Average Number of Male Prison Admissions Across All U.S. Counties",
    caption = "Source: Vera Institute",
    y = "# of Admissions"
  ) +
  scale_color_manual(
    name = "",
    values = c("Black Males" = "#00ba38", "White Males" = "#f8766d")
  ) +
  theme(panel.grid.minor = element_blank())

#
# ------------------------------------------------------------------------------
# Chart comparing Black prison population to the total prison population:
chart2 <- ggplot(prison_pop) +
  geom_point(
    mapping = aes(x = avg_total_pop, y = avg_black_pop),
    color = "red",
    alpha = .3
  ) +
  labs(
    subtitle = "Average Black & Total Prison Population Across All Counties",
    y = "Black Population",
    x = "Total Population",
    title = "Total Prison Population v.s. Black Prison Population",
    caption = "Source: Vera Institute"
  )

#
# ------------------------------------------------------------------------------
# Map of Black prison incarceration rates in U.S. (by state):
## dplyr data wrangling
pop_map <- df %>%
  select(year, county_name, state, black_prison_pop) %>%
  replace_na(list(black_prison_pop = 0))

black_pop_map <- pop_map %>%
  filter(black_prison_pop > 0) %>%
  filter(year == max(year)) %>%
  group_by(state) %>%
  summarize(mean(black_prison_pop))

colnames(black_pop_map) <- c("state", "avg_black_pop")

map <- plot_usmap(data = black_pop_map, values = "avg_black_pop", color = "red") +
  scale_fill_continuous(
    low = "white", high = "red", name = "Imprisoned Black Population (2016)",
    label = scales::comma
  ) + theme(legend.position = "right") +
  labs(
    title = "Imprisoned Black Population Across the U.S.",
    subtitle = "2016 Averages by State",
    caption = "Source: Vera Institute"
  )

#
# ------------------------------------------------------------------------------


# Aula 2 - Geração de amostra

install.packages("ggplot2")
#   Instanciar o ggplot na memoria.
library(ggplot2)

# Entrada e saida de dados
# write.csv(d.file="d.csv") # Saida de csv
# d1 <- read.csv("d.csv") # Entrada de dados atravéz do csv

# Example de lógica
#if(mA1 != mA2){
#  teste <- mA1+ mA2
#}

# Tabela de dados diamonds -> DataFrame
d <- diamonds
# +++++ Valores reais
# Calcular media
mean(d$price)
# Calcular Tendencia central (Mediana)
median(d$price)
# Baseado nos dados apresentandos,
# è bem provavel que temos valores outlier
# Desvio padrao
sd(d$price)

# Geração de amostra
# ==== Amostra 01
a1 <- d[1:3000,]
# ==== Amostra 02
a2 <- d[3001:6000,]
# ==== Dados Amostra 01
mA1 <- mean(a1$price)
median(a1$price)
sd(a1$price)
# ==== Dados Amostra 02
mA2 <- mean(a2$price)
median(a2$price)
sd(a2$price)

# Gerar numeros rondom
sample(10)

# Definicao de semente de aleatoriedade
# Exemplo: Semente é o 3
# Para forçar a repetição de uma sequencia
# Tomar cuidado com a caracteristica fisica do pc
set.seed(4)
sample(3)

set.seed(34)
va <- sample(53940)
d[1:2]
d[2:1,]

# Geracao de amostra aleatoria
a3 <- d[va[1:3000],]
mean(a3$price)
median(a3$price)
sd(a3$price)

# Histograma
hist(d$price)

# Visualizacao de 4 graficos
par(mfrow=c(2,2))
par(mfrow=c(1,1))
# Comparativo de distribuicao
hist(d$price)
hist(a1$price)
hist(a2$price)
hist(a3$price)

# Descriao de uma amostra
summary(d)
summary(a3)

# Boxplot
boxplot(d$price)
boxplot(d$price~d$cut)
boxplot(d$price~d$color)

#grafico de dispersão = scaterplot
m <- mtcars
# mpg = milhas por galão
plot(m$mpg~m$wt)

#Coef correlação linear
# (pearson)
cor(m$mpg, m$wt)
#r package correaltional graphics

# Excericio
install.packages("swirl")
library("swirl")
rm(list=ls())
ls()
swirl()


library(tidyverse)
library(devtools)
load_all()

contingency <- function(maf, prop, odds_ratio, eps=1e-15)
{
	a <- odds_ratio-1
	b <- (maf+prop)*(1-odds_ratio)-1
	c_ <- odds_ratio*maf*prop

	if (abs(a) < eps)
	{
		z <- -c_ / b
	} else {
		d <- b^2 - 4*a*c_
		if (d < eps*eps)
		{
			s <- 0
		} else {
			s <- c(-1,1)
		}
		z <- (-b + s*sqrt(max(0, d))) / (2*a)
	}
	y <- vapply(z, function(a) zapsmall(matrix(c(a, prop-a, maf-a, 1+a-maf-prop), 2, 2)), matrix(0.0, 2, 2))
	i <- apply(y, 3, function(u) all(u >= 0))
	return(y[,,i])
}

allele_frequency <- function(g)
{
	(sum(g == 1) + 2 * sum(g == 2) / (2 * sum(!is.na(g)))
}

var_cc <- function(proportion, prevalence)
{
	tval <- qnorm(prevalence, lower.tail=FALSE)
	zval <- dnorm(tval)
	i <- zval / prevalence
	lambda <- (proportion - prevalence) / (1 - prevalence)
	vp <- 1 + i * lambda * (tval - i * lambda)
	return(vp)
}

get_population_allele_frequency <- function(maf, prop, odds_ratio, prevalence)
{
	co <- contingency(maf, prop, odds_ratio)
	af_controls <- co[1,2] / (co[1,2] + co[2,2])
	af_cases <- co[1,1] / (co[1,1] + co[2,1])
	af <- af_controls * (1 - prevalence) + af_cases * prevalence
	return(af)
}

lor_to_rsq <- function(b, af, ncase, ncontrol, prevalence)
{
	af <- get_population_allele_frequency(af, ncase / (ncase + ncontrol), exp(b), prevalence)
	vg <- b^2 * af * (1-af)
	return(vg / (vg + pi^2/3) / 0.58)
}

func.Vg <- function (PA,RR1,RR2,K) {
	Paa = (1-PA)^2
	PAa = 2*PA*(1-PA)
	PAA = PA^2
	muaa=0
	faa= K/(Paa + PAa*RR1 + PAA*RR2)
	fAa= RR1*faa
	fAA= RR2*faa
	T = qnorm(1-faa)
	muAa = T-qnorm(1-fAa)
	muAA = T-qnorm(1-fAA)
	mean.all= PAa*muAa+ PAA*muAA
	Vg= Paa*(muaa-mean.all)^2 + PAa*(muAa-mean.all)^2+ PAA*(muAA-mean.all)^2
	actual.Vg =  Vg/(1+Vg)
	VR = 1-actual.Vg
	actual.T = Paa*sqrt(VR)*qnorm(1-faa) + PAa*sqrt(VR)*qnorm(1-fAa) + PAA*sqrt(VR)*qnorm(1-fAA)
	actual.muaa = actual.T - sqrt(VR) * qnorm(1-faa)
	actual.muAa = actual.T - sqrt(VR) * qnorm(1-fAa)
	actual.muAA = actual.T - sqrt(VR) * qnorm(1-fAA)

	res <- list(Vg=actual.Vg,muaa=actual.muaa, muAa = actual.muAa, muAA=actual.muAA)
	res
}

param <- data_frame(
	va = runif(100, 0.001, 0.05),
	n = 100000,
	prevalence = runif(100, 0.01, 0.1),
	proportion = runif(100, 0.2, 0.8),
	maf = runif(100, 0.05, 0.5),
	rsq1 = NA,
	rsq2 = NA,
	paf = NA,
	pval = NA
)

for(i in 1:nrow(param))
{
	message(i)
	va <- param$va[i]
	maf <- param$maf[i]
	prevalence <- 0.1
	nid <- param$n[i]
	proportion <- param$proportion[i]
	g <- make_geno(nid, 1, maf)
	x <- make_phen(sqrt(va), g)
	bin <- y_to_binary(x, prevalence=prevalence)
	asc <- ascertain_samples(bin, proportion)
	ga <- g[asc, ]
	xa <- x[asc]
	bina <- bin[asc]
	a <- fast_assoc(xa, ga)
	mod <- summary(glm(bina ~ ga, family="binomial"))
	eff <- coefficients(mod)[2,1]
	pval <- coefficients(mod)[2,4]
	param$rsq1[i] <- lor_to_rsq(eff, allele_frequency(ga), sum(bina==1), sum(bina==0), prevalence)
	param$paf[i] <- get_population_allele_frequency(allele_frequency(ga), sum(bina==1) / length(bina), exp(eff), prevalence)
	param$pval[i] <- pval
	param$rsq2[i] <- func.Vg(allele_frequency(ga), exp(eff), exp(eff)^2, prevalence)$Vg
	param$rsq3[i] <- func.Vg(param$paf[i], exp(eff), exp(eff)^2, prevalence)$Vg
}

plot(rsq1 ~ va, param)
abline(lm(rsq1 ~ va, param))
points(rsq2 ~ va, param, col="red")
abline(lm(rsq2 ~ va, param), col="red")
points(rsq3 ~ va, param, col="blue")
abline(lm(rsq3 ~ va, param), col="blue")

summary(lm(rsq1 ~ va + prevalence + proportion + maf, param))
summary(lm(rsq2 ~ va + prevalence + proportion + maf, param))

plot(rsq1 ~ rsq2, param)

plot(-log10(param$pval))

ggplot(param, aes(x=va, y=rsq1)) +
geom_point(aes(colour=-log10(pval))
)
get_population_allele_frequency()

paf <- get_population_allele_frequency(allele_frequency(ga), sum(bina==1) / length(bina), exp(eff), prevalence)
pvg <- eff^2 * paf * (1-paf)
saf <- allele_frequency(ga)
svg <- eff^2 * saf * (1-saf)
pvg / (pvg + pi^2/3)
svg / (svg + pi^2/3)

summary(lm(rsq ~ va, param))

vg <- eff^2 * 2 * allele_frequency(g) * (1 - allele_frequency(g))
vg / (vg + pi^2/3)

vg <- eff^2 * 2 * allele_frequency(ga) * (1 - allele_frequency(ga))
vg / (vg + pi^2/3)

co <- contingency(allele_frequency(ga), sum(bina==1)/length(bina), exp(eff))
allele_frequency(ga)
sum(co[1,])
co
sum(co[,1])

allele_frequency(g[bin==0])

contingency(0.1, 0.2, exp(coefficients(mod)[2]))

freq <- sum(ga) / (2 * length(ga))

rsq <- mod$coefficients[2]^2 * freq * (1 - freq) * 2 / var_cc(0.1, 0.9)
rsq

	h2l

mod <- lm(xa ~ ga)
rsq <- mod$coefficients[2]^2 * freq * (1 - freq) * 2 / var_cc(0.8, 0.9)
rsq

summary(lm(x ~ g))
summary(glm(bin ~ g, family="binomial"))
var_cc(prevalence, prevalence)

res <- array(0, 50)
proportion <- seq(0.1, 0.9, length.out=50)
for(i in 1:50)
{
	message(i)
	va <- 0.1
	maf <- 0.5
	prevalence <- 0.1
	nid <- 100000

	g <- make_geno(nid, 1, maf)
	x <- make_phen(sqrt(va), g)

	d <- risk_simulation(g, eff=0.1, prevalence=0.1, prop_discovered=1)
	bin <- d$disease

	asc <- ascertain_samples(bin, proportion[i])
	ga <- g[asc, ]
	bina <- bin[asc]
	mod <- glm(bina ~ ga, family="binomial")
	res[i] <- mod$coefficients[2]
}

plot(res ~ proportion)
summary(glm(bin ~ g, family="binomial"))

summary(glm(bin ~ g, family="binomial"))

0.9 * 0.1
table(bin)
var(bin)


# Working directory is where this script is at.
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)
source("TDA_Finance.R")

# Load required packages
library(quantmod)   # for getSymbols
library(TDA)        # for ripsDiag
library(PKNCA)      # for pk.calc.auc.all

#import an one dimension time series as an xts object.
#Here we use Bitcoin data from the specified dates
getSymbols.yahoo("BTC-USD", env = parent.frame(),from="2016-02-23", to="2018-02-06", warnings = FALSE)
data <- `BTC-USD`[,4]

#This calculates the norm of the data in one line.
#
#Implicitly, this is using the default values for parameters:
# - embedding dim = 4
# - scaling is "log" which means that we will take the log of the data
# - max_scale is defaulted to zero, which leads to estimating max_scale
#   using the find_diam function.
# - K_max = 10
# - window = 50
# - returns = TRUE means that we will take log-returns of the price
#   time series before processing it through the TDA pipeline.
#   Note that when returns = TRUE, the scaling parameter has no effect.
#
#Thus, this is equivalent to:
# norm_data <-
# analyze_1d(data, dim=4, scaling_method="log", max_scale=0,
# K_max=10, window=50, returns = TRUE)
norm_data <- analyze_1d(data, returns = TRUE)

#Here we plot the norm
# plot(norm_data, type = 'l')

output(norm_data, "BTC.zoo")


# https://www.youtube.com/playlist?list=PLUl4u3cNGP63oMNUHXqIUcrkS2PivhN3k
# https://youtu.be/Xa2jPbURTjQ?t=2220

x1 <- c(0,1,0,0)
x2 <- c(0,0,1,0)
x3 <- c(0,0,0,1)
x4 <- c(1,0,0,0)
rbind(x1, x2,x3,x4)
rbind(x1, x2,x3,x4) -> x
is.matrix(x)

y <- c(1,2,3,4)
y %*% x
# so discrete fourier transform is a rotation?


setwd("*path of the working directory*")

mydata <- read.csv("*path and name of the csv file for import*")

attach(mydata)

names(mydata)

head(mydata)

# 1) Number of Applications by Organization
mydata$time = ifelse(mydata$Intake == 5, 1, 0) #creating new vector indicating if this was the 5th intake
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0) #attending the webinar is our treatment
mydata$did = mydata$time * mydata$treated
didreg = lm( Applications ~ treated + time + did, data = mydata)
summary(didreg)

# 1)b) Number of Applications by Organization (with subsetting)
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
didreg = lm( Applications ~ treated + time + did, data = subset(mydata, Intake.5.Applications>0))
summary(didreg)

# 2) Number of Applications by Organization
#   (not accounting for multiple applications by the same organization)
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$outcome = ifelse(mydata$Applications == 0, 0, 1)
didreg = lm( outcome ~ treated + time + did, data = mydata)
summary(didreg)

# 3) Successful Applications by Organization
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
didreg = lm( Approved ~ treated + time + did, data = subset(mydata, Intake.5.Applications>0))
summary(didreg)

# 4) Declined Applications by Organization
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
didreg = lm( Declined ~ treated + time + did, data = subset(mydata, Intake.5.Applications>0))
summary(didreg)

# 5) Success Rate by Organization
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$successrate = Approved/(Approved+Declined)
didreg = lm( successrate ~ treated + time + did, data = subset(mydata, Intake.5.Applications>0))
summary(didreg)

# 5)b) Success Rate by Organization (without subsetting)
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$successrate = Approved/(Approved+Declined)
didreg = lm( successrate ~ treated + time + did, data = mydata)
summary(didreg)

# 6) Success Rate by Organization with Urban interactions
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$successrate = Approved/(Approved+Declined)
didreg = lm( successrate ~ treated + time + did + Urban + Urban*treated + Urban*time + Urban*did, data = subset(mydata, Intake.5.Applications>0))
summary(didreg)

# 6)b) Success Rate by Organization with Urban interactions(without subsetting)
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$successrate = Approved/(Approved+Declined)
didreg = lm( successrate ~ treated + time + did + Urban + Urban*treated + Urban*time + Urban*did, data = mydata)
summary(didreg)

# 7)Success Rate by Organization with binary Approvals and Rejections (without subsetting)
mydata$time = ifelse(mydata$Intake == 5, 1, 0)
mydata$treated = ifelse(mydata$Attended.Webinar == "Yes", 1, 0)
mydata$did = mydata$time * mydata$treated
mydata$successrate = A/(A+B)
didreg = lm( successrate ~ treated + time + did, data = mydata)
summary(didreg)


# LEARNING R
# BY DR4G0N5
# https://github.com/Malam-X/
# BELAJAR BAHASA PROGRAMMING R + OUTPUTNYA
# PART 1

# 1
# R DATA SCIENCE FOR BEGINNERS

2 * 2
# [1] 4

2 + 2
# [1] 4

2 / 2
# [1] 1

2 %% 2
# [1] 0

print('Hello World!')
# [1] Hello World!

cat('Hello World!', '\n')
# Hello World!

main <- factor(c("satu", "dua", "tiga"))
main
# [1] satu dua tiga
# Levels: dua satu tiga

main <- factor("satu", "dua", "tiga")
main
# [1] <NA>
# Levels: tiga

main <- 1:3
names(main) <- LETTERS[1:3]
main
# A B C
# 1 2 3

(x <- factor(LETTERS[1:3]))
# [1] A B C
# Levels: A B C

(x <- factor(LETTERS[1:3], levels = rev(LETTERS[1:3])))
# [1] A B C
# Levels: C B A

main <- function(x) {
    ifelse(x %% 2 == 0, x**2, x**3)
}
main(5)

# DATA FRAME

main <- data.frame(a = 1:3, b = letters[1:3])
main
#   a b
# 1 1 a
# 2 2 b
# 3 3 c

main <- data.frame(a = 1:3, b = letters[1:3], stringsAsFactors = FALSE)
main
#   a b
# 1 1 a
# 2 2 b
# 3 3 c

main[1,1]
# [1] 1

main[1,]
#   a b
# 1 1 a

main[,"a"]
# 1 2 3

main$b
# [1] 1 2 3
# [1] "a" "b" "c"

xx <- c(1,NA,2)
sum(xx, na.rm = TRUE)
# [1] 3

sum(xx)
# [1] NA

# IF ELSE

x = 1
if (x < 5) {
    print('1')
} else if (x > 5) {
    print('2')
} else {
    print('3')
}
# [1] "1"

# Loops

for (T in 1:3) {
    print(T)
}
# [1] 1
# [1] 2
# [1] 3

x <- c("SATU", "DUA", "TIGA")
for (M in seq_along(x)) {
    print(M)
    print(x[M])
}
# [1] 1
# [1] "SATU"
# [1] 2
# [1] "DUA"
# [1] 3
# [1] "TIGA"

for (.main_loop in 1:10) {
    if (.main_loop %% 4 == 0) {
        next
    }
    if (.main_loop > 4) {
        break
    }
    print(.main_loop)
}
# [1] 1
# [1] 2
# [1] 3

.loops <- 1
while (.loops < 4) {
    print(.loops)
    .loops <- .loops + 1
}
# [1] 1
# [1] 2
# [1] 3

.loops. <- 1
repeat {
    print(.loops.)
    .loops. <- .loops. + 1
    if (.loops. > 3)
        break
}
# [1] 1
# [1] 2
# [1] 3

# FUNCTIONS
# var <- function(arguments) { statements }

main <- function(x) {
    print(x)
}
main('Hello World!')
# [1] "Hello World!"
# [1] 1000

.main <- function(x, y) {
    print(paste(x, "+", y, "=", x + y))
    x + y
}
.main(5, 10)
# [1] "5 + 10 = 15"
# [1] 15

main <- function(x, y) {
    if (y == 0) {
        return(NA)
    } else {
        x / y
    }
}
main(10, 6)
# [1] 1.666667

main(10, 0)
# [1] NA


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

StocSIRstan <- function(y, pars, T, steps, berrvec, bveclim) {

	out <- matrix(NA, nrow = (T+1), ncol = 4)

	R0 <- pars[['R0']]
	r <- pars[['r']]
	N <- pars[['N']]
	eta <- pars[['eta']]
	berr <- pars[['berr']]

	S <- y[['S']]
	I <- y[['I']]
	R <- y[['R']]

	B0 <- R0 * r / N
	B <- B0

	out[1,] <- c(S,I,R,B)

	h <- 1 / steps

	for ( i in 1:(T*steps) ) {

	    if (i <= bveclim) {
		    B <- exp( log(B) + eta*(log(B0) - log(B)) + berrvec[i])
	    } else {
	        B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr))
	    }

		BSI <- B*S*I
		rI <- r*I

		dS <- -BSI
		dI <- BSI - rI
		dR <- rI

		S <- S + h*dS
		I <- I + h*dI
		R <- R + h*dR

		if (i %% steps == 0)
			out[i/steps+1,] <- c(S,I,R,B)

	}

	return(out)

}


##################  Clustering   #################
setwd(.WD)
source("functions.r")

n <- nrow(dat)
p <- ncol(dat)

.stay <- "y"
while(.stay == "y")
{
cat(" ################  Clustering analysis  #################### \n")
cat(" 1. Hierachical Clustering \n")
cat(" 2. Partitioning Clustering \n")
cat(" 3. Fuzzy Clustering \n")
cat(" 4. Model-based Clustering \n")
cat(" 5. Exit\n")
.choice <- .scanf(1,c(1:5))

if(.choice == 5) .stay <- "n"
else {

if(.choice == 1 || .choice == 2){

cat(" Which distance measure do you want to adopt?\n")
cat(" 1.euclidean \n 2.maximum \n 3.manhattan \n 4.canberra \n",
   "5.binary \n 6.minkowski \n 7.gower\n 8.bary-curtis\n")# 8.bray\n 9.kulczynski\n 10.morisita \n 11.horn\n 12.binomial\n 13.jaccard\n 14.mountford\n 15.raup\n")
.distind <- .scanf(1,c(1:8))
.distlist <- c("euclidean", "maximum", "manhattan", "canberra",  "binary", "minkowski", "gower")#, "bray")#, "kulczynski", "morisita", "horn", "binomial", "jaccard", "mountford", "raup")
if (.distind == 6) {
cat(" Choose the power of minkowski distance:\n")
.Minp <- scan("",integer(0),nlines=1,quiet=T)
.d <- dist(dat, method = .distlist[.distind], p = .Minp)
}
else if(.distind == 7) .d <- as.dist(as.matrix(daisy(dat, metric = 'gower')))
else if(.distind == 8) .d <- bcdist(dat)
else .d <- dist(dat, method = .distlist[.distind])
}

if(.choice == 1){
##################   Hierarchical clustering #############################
.hstay <- 1
while(.hstay == 1){
cat(" Which hierarchical clustering algorithm do you want to implement?\n")
cat(" 1.ward \n 2.single \n 3.complete \n 4.average\n") # \n 5.mcquitty\n 6.median\n 7.centroid\n")
.method <- .scanf(1,c(1:4))
.methodlist <- c("ward", "single", "complete", "average")#, "mcquitty", "median", "centroid")
.hcl <- hclust(.d, method = .methodlist[.method])
.hcl$labels <- .sites
.hopt <- 1
 while(.hopt == 1){
  cat("#################   Hierarchical Clustering  ###################\n")
  cat("1. Dendrogram for the clustering results\n")
  cat("2. Principle Coordinates Plot for the clustering results\n")
  cat("3. Choose another methods for Hierarchical clustering\n")
  cat("4. Exit\n")
  .hans <- .scanf(1,c(1:4))
  if(.hans == 4) {.hstay <- 0; .hopt <- 0}
  if(.hans == 3) .hopt <- 0
  if(.hans == 1){
    .stayh <- "y"; .par0(); par(las=3, cex.axis=.7, font.axis=8)
    while(.stayh == "y"){
    plot(.hcl,hang=-1,xlab=paste('method = ',
             .methodlist[.method]),ylab='',sub='',main='Dendrogram')
    .CC <- round(cor(.d,cophenetic(.hcl)),3)
    legend('topright', legend= paste("cophenetic coeff. =",
                      as.character(.CC)),cex=.8,text.col= 'blue',
                                             inset=.01, bg="gray90")
    cat("How many clusters do you want to specify in the dendrogram?\n")
    .clnum <- .scanf(1,c(1:n))
    rect.hclust(.hcl, .clnum, border='red')
    .sumCluster(dat,cutree(.hcl,.clnum),.sites)
    cat("Do you want to specify another number of clusters? y/n\n")
    .stayh <- .scanf(2)
                         }
    .par0()
                 }
if(.hans == 2){
   .clpc <- "y"
   while(.clpc == "y"){
   cat(" How many clusters do you want to specify in the principle component coordinates?\n")
   .clpcnum <- .scanf(1,c(1:n)); .hgrp <- cutree(.hcl,k=.clpcnum)
   .sumCluster(dat,.hgrp,.sites)
   .clpc <- .PCplot(dat, .hgrp, .colGrou, .ugrou)
                       }
              }
          }
      }
}

if(.choice == 2){
#################   partitioning clustering  ###################
.kopt <- 1;
while(.kopt == 1){
cat("#################   Partitioning Clustering  ###################\n")
cat("1. I want to specify a number of clusters\n")
cat("2. I want to use the number of clusters estimated\n")
cat("3. Exit\n")
.ans <- .scanf(1,c(1:3))
if(.ans == 3) .kopt <- 0
if(.ans == 1){
   .wss <- numeric(15) #number of clusters from 1 to 15
   .wss[1] <- (nrow(dat)-1)*sum(apply(dat,2,var))
   for (i in 2:15) {
        .tmpfit <- pam(.d, i, diss = T, cluster.only=T)
        .wss[i] <- .WB(dat,.tmpfit)[1]
       }
  .kcl <- "y"; dev.new()
   while(.kcl == "y"){
   par(lab = c(10,8,7), las = 3, cex = 1.1)
   plot(c(1:15),.wss[1:15],type='b',xlab='Number of clusters',ylab='within groups sum of squares(wss)')
   cat("To have a good choice, try different numbers to see whether it greatly reduces the WSS\n")
   cat("Please try a number of clusters\n")
   .kclnum <- .scanf(1,c(2:15))
   .percen_redu <- round(100*(1-.wss[.kclnum]/.wss[1]),3)
   sprintf("The percentage reduction of wss for %d is %.2f%%", .kclnum, .percen_redu)
   .par0(); legend(.wss[.kclnum],paste(.percen_redu,"%, rope ",
             round(.wss[.kclnum]-.wss[.kclnum-1],3)), bty='n', cex=.7)
   abline(h=.wss[.kclnum],lty=2) ; abline(v=.kclnum,lty=3)
   cat("Do you want to try another number of clusters? y/n\n")
   .kcl <- .scanf(2)
                  }
   cat("Finally determine the number of clusters:\n")
   .kncl <- .scanf(1,c(1:p))
   .kgrp <- pam(.d, .kncl, diss=T)$clustering
   .sumCluster(dat,.kgrp,.sites)
            }

if(.ans == 2){
## estimated by optimum average silhouette width
.par0()
.pamfit <- pamk(dat,2:15)
.pamfitk <- .pamfit$nc; .pamfitobj <- .pamfit$pamobject
#plot(silhouette(pam(.d,.pamfitk, diss=T)))
sprintf("The optimal number of cluster is %d", .pamfitk)
.kgrp <- .pamfitobj$clustering
.read()
.sumCluster(dat,.kgrp,.sites)
}

cat("Principle Coordinate plot of clustering results:\n")
cat("\n Please press Enter key to continue...\n")
readline()
.stayk <- .PCplot(dat, .kgrp, .colGrou, .ugrou)
if(.stayk == "n") .kopt <- 0
  }
}

if(.choice == 4){
.Vcluster(dat, method=1)
}

else if(.choice == 3){
################   fuzzy cluster ##############################
.Vcluster(dat, method=2)
    }

 }

}


=begin
[((<index|URL:index.html>))]
= Algebra::JordanForm
((*(Jordan Matrix)*))

This class expresses the Jordan canonical matrix.

== File Name:
* ((|jordan-form.rb|))

== SuperClass:

* ((|Object|))

== Included Modules

none.

== Associated Functions:

--- Algebra::MatrixAlgebra#jordan_form
    Returns the Jordan matrix of ((|self|)).

--- Algebra::MatrixAlgebra#jordan_form_info
    Same as ((<Algebra::JordanForm.decompose>))(self).

== Class Methods:

--- ::new(array)
    Returns a instance of ((<JordanForm>)).
    ((|array|)) is the array of the pair of (({[diagonal component, size]})).
    To get the matrix expression, apply ((<to_matrix>)) for the upper
    triaglular matrix or ((<to_matrix_l>)) for the lower.

    Exampe:
      j = Algebra::JordanForm.new([[2, 3], [-1, 2]])
      j.to_matrix.display #=>
      #  2,   1,   0,   0,   0
      #  0,   2,   1,   0,   0
      #  0,   0,   2,   0,   0
      #  0,   0,   0,  -1,   1
      #  0,   0,   0,   0,  -1

--- ::construct(elem_divs, facts, field, pfield)
    abbreviate.

--- ::decompose(m)
    Returns the array:

      [jm, tL, sR, field, modulus]

    where ((|jm|)) is the Jordan matrix of ((|m|)),
    ((|tL|)) and ((|sR|)) are the left and right deformation matrix
    from ((|m|)) to((|jm|)),
    ((|field|)) is the mimimal decompostion field to Jordan decompose and
    ((|modulus|)) is the polynomials to the algebraic extention.
    ((({tL * sR == the identity matrix})))

    Example:
      m = Algebra.SquareMatrix(Rational, a.size)[
       [-1, 1, 2, -1],
       [-5, 3, 4, -2],
       [3, -1, 0, 1],
       [5, -2, -2, 0]
      ]
      jf, p, q, field, modulus = Algebra::JordanForm.decompose(m)
      jf.display; puts #=>
      #  2,   0,   0,   0
      #  0,   a,   0,   0
      #  0,   0,   b,   0
      #  0,   0,   0, -b - a

      p modulus #=> [a^3 + 3a - 1, b^2 + ab + a^2 + 3]

      print "P =\n"; p.display; puts
      print "P^-1 =\n"; q.display; puts

      m = m.convert_to(field)
      p jf == p * m * q #=> true

== Methods:

--- to_matrix(ring)
    Returns the upper triangular Jordan matrix over ((|ring|)).

    Example:
      j = Algebra::JordanForm.new([[2, 3], [-1, 2]])
      j.to_matrix(Integer).display #=>
      #  2,   1,   0,   0,   0
      #  0,   2,   1,   0,   0
      #  0,   0,   2,   0,   0
      #  0,   0,   0,  -1,   1
      #  0,   0,   0,   0,  -1

--- to_matrix_r(ring)
    Same as ((<to_matrix>)).

--- to_matrix_l(ring)
    Returns the lower triangular Jordan matrix over ((|ring|)).

=end


\name{generate_ER}
\alias{generate_ER}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Simulating networks from the Erdos-Renyi model}
\description{
  This function generates networks from the \enc{Erdős–Rényi}{Erdos-Renyi} model. In this model, the preferential attachment function is a constant function, i.e. \eqn{A_k = 1}, and node fitnesses are all equal to \eqn{1}. It is a wrapper of the more powerful function \code{\link{generate_net}}.
}
\usage{
  generate_ER(N              = 1000,
              num_seed       = 2   ,
              multiple_node  = 1   ,
              m              = 1)
}

%- maybe also 'usage' for other objects documented here.
\arguments{
\item{N}{
 Integer. Total number of nodes in the network (including the nodes in the seed graph). Default value is \code{1000}.
 }
\item{num_seed}{
 Integer. The number of nodes of the seed graph (the initial state of the network). The seed graph is a cycle. Default value is \code{2}.
}
\item{multiple_node}{
  Positive integer. The number of new nodes at each time-step. Default value is \code{1}.
}
\item{m}{
 Positive integer. The number of edges of each new node. Default value is \code{1}.
}
}

\value{
  The output is a \code{PAFit_net} object, which is a List contains the following four fields:
    \item{graph}{a three-column matrix, where each row contains information of one edge, in the form of \code{(from_id, to_id, time_stamp)}. \code{from_id} is the id of the source, \code{to_id} is the id of the destination.}
    \item{type}{a string indicates whether the network is \code{"directed"} or \code{"undirected"}.}
    \item{PA}{a numeric vector contains the true PA function.}
    \item{fitness}{fitness values of nodes in the network. The fitnesses are all equal to \eqn{1}.}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. \enc{Erdös}{Erdos} P. & \enc{Rényi}{Renyi} A.. On random graphs. Publicationes Mathematicae Debrecen. 1959;6:290–297 (\url{http://snap.stanford.edu/class/cs224w-readings/erdos59random.pdf}).
}
\seealso{
For subsequent estimation procedures, see \code{\link{get_statistics}}.

For other functions to generate networks, see \code{\link{generate_net}}, \code{\link{generate_BA}}, \code{\link{generate_BB}} and \code{\link{generate_fit_only}}. }

\examples{
  library("PAFit")
  # generate a network from the ER model with N = 1000 nodes
  net <- generate_ER(N = 1000)
  str(net)
  plot(net)
}

% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
\concept{ER model}


#############################################################################
#File: ggplot2_Introduction_&_Customization.r
#Purpose: Demonstrate how to produce and customize plots using the ggplot
# function in the ggplot2 package. We will create and customize a scatter
# plot, a bar plot, a stacked histogram, and a categorical boxplot.
# We will also plot multiple plots on one panel.
#By: Will Bartsch  -  EPA-MED, Duluth
#Date: 7/16/14
#############################################################################

#Load the necessary packages.
library(ggplot2)
library(plyr)
library(grid)

#Create a data frame to use for the plots.
dat <- data.frame(condition = rep(c("A", "B", "C"), each=30),
			response=rep(c("Yes", "No"), each=15, times=3),
			xvar = 50:139 + rnorm(90,sd=15),
			yvar = 50:139 + rnorm(90,sd=15))

head(dat)
dim(dat)

########################## A scatter plot #############################

# Basic plot using base R
plot(dat$xvar, dat$yvar)

# Basic plot using the 'qplot' function in ggplot2
qplot(dat$xvar, dat$yvar)

# Basic plot using the 'ggplot' function in ggplot2
ggplot(dat, aes(y=yvar, x=xvar)) + geom_point()

# Change the symbols to a solid triangle and color code according to
#	"condition"

# A plot of all the symbols	to find the triangle
plot(1:25, pch=c(1:25))
text(1:25, pos=3, offset=0.4)

# A colorblind friendly palette (create it for later use)
cbbPalette <- c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442",
	"#0072B2", "#D55E00", "#CC79A7")

# Create the plot
sp <- ggplot(dat, aes(y=yvar, x=xvar, color=condition))
sp + geom_point(shape=17)

# Add a title and axis lables
sp + geom_point(shape=17)+
	ggtitle("Data Presentation") + xlab("X") + ylab("Y")

# Same plot with a black and white theme
sp + geom_point(shape=17)+
	ggtitle("Data Presentation") + xlab("X") + ylab("Y") + theme_bw()

# Format the legend
	sp + geom_point(shape=17, size=3)+
	ggtitle("Data Presentation") + xlab("X") + ylab("Y") +
	scale_colour_manual("Group", breaks=c("A", "B", "C"),
	labels=c("Apple", "Banana", "Cherry"), values=cbbPalette) +	# Change the labels and title, change the color palette
	theme(legend.background=element_rect(color="black", fill="gray"), # Make the legend background gray with a black border
		legend.text=element_text(size=16),	#Change label text size
		legend.title=element_text(size=16, face="bold"), #Change title text
		legend.key.size=unit(1, "cm"),	#Change Size of symbol box
		legend.position = c(0.89,0.135))		#Set position

# Format Axis, Labels and Title (Maintain previous formating) and add
# trend lines
	sp + geom_point(shape=17, size=3)+
	ggtitle("Data Presentation") + xlab("X") + ylab("Y") +
	scale_colour_manual("Group", breaks=c("A", "B", "C"),
	labels=c("Apple", "Banana", "Cherry"), values=cbbPalette)+
	theme(legend.background=element_rect(color="black", fill="gray"),
		legend.text=element_text(size=16),
		legend.title=element_text(size=16, face="bold"),
		legend.key.size=unit(1, "cm"),
		legend.position = c(0.895,0.135))+
	theme(axis.title=element_text(size=16),		#Change axis title size
		axis.text=element_text(size=12),		#Change axis label size
		plot.title=element_text(size=20, face="italic"))+	#Change plot title size and make it italic
		xlim(0,175) + ylim(0, 175) +	#Reset the axis ranges
		#scale_y_continuous(limits = c(0,175), expand = c(0,0))+ #Reset the axis ranges and force it to start at 0
		#scale_x_continuous(limits = c(0,175), expand = c(0,0))+ #Reset the axis ranges and force it to start at 0
	geom_smooth(method=lm, fill=NA, size=1)		#Add the linear regression trend lines

############## A bar plot of means with standard error bars #################

# Summarize the data by mean and standard deviation using ddply from
# the plyr package
dat_mean <- ddply(dat, .(condition), summarize, avg=mean(yvar),
	stdev=sd(yvar))

dat_mean$std_error <- dat_mean$stdev/sqrt(30)

# Make a basic plot
bp <- ggplot(dat_mean, aes(y=avg, x=condition))
bp + geom_bar(stat="identity", color="black", fill="black")+
	geom_errorbar(aes(ymin=avg-std_error,
	ymax=avg+std_error), color='red', width=0.5)

# Customize the plot with white background and no grid lines
bp + geom_bar(stat="identity")+ geom_errorbar(aes(ymin=avg-std_error,
	ymax=avg+std_error), color='red', width=0.5, size=1.5) +
	ggtitle("Example\nBar Plot") +
	xlab(expression(paste(italic("Condition")))) +
	ylab(expression(paste("NH"[4]^" +  ",mu,"g/L")))+
	theme(panel.background=element_rect(fill="white"),
		panel.grid=element_blank(),
		panel.border=element_rect(color="black", fill=NA))

##################### A faceted histogram plot ###########################
hp <- ggplot(dat, aes(x=xvar, fill=condition))
hp + geom_histogram(color="black", binwidth=15) +
	facet_grid(condition ~ .) + ggtitle("Results") +
	xlab("X") + ylab("Count") +
	scale_y_continuous(breaks=seq(0, 12, 3))+
	scale_fill_hue("Variable", l=20) #Darken the color scheme and label legend

# If you don't want a legend, use the following line in your script:
	theme(legend.position="none")

#################### Categorical Box Plot ###################
boxp <- ggplot(dat, aes(y=yvar, x=condition, fill=response))
boxp + geom_boxplot() + ggtitle("Was There\nA\nResponse")+
	xlab("Condition") + ylab("Y Variable")

#################### Plotting Multiple Plots on One Panel ###################

# Multiple plot function (from www.cookbook-r.com)
#
# ggplot objects can be passed in ..., or to plotlist
#	(as a list of ggplot objects)
# - cols:   Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#

multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
  require(grid)

  # Make a list from the ... arguments and plotlist
  plots <- c(list(...), plotlist)

  numPlots = length(plots)

  # If layout is NULL, then use 'cols' to determine layout
  if (is.null(layout)) {
    # Make the panel
    # ncol: Number of columns of plots
    # nrow: Number of rows needed, calculated from # of cols
    layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                    ncol = cols, nrow = ceiling(numPlots/cols))
  }

 if (numPlots==1) {
    print(plots[[1]])

  } else {
    # Set up the page
    grid.newpage()
    pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

    # Make each plot, in the correct location
    for (i in 1:numPlots) {
      # Get the i,j matrix positions of the regions that contain this subplot
      matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

      print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                      layout.pos.col = matchidx$col))
    }
  }
}

#Make multiple plots and save them as an object
p1 <- 	ggplot(dat, aes(y=yvar, x=xvar, color=condition)) +
	geom_point(shape=17)

p2 <- ggplot(dat, aes(y=yvar, x=xvar, color=condition)) +
	geom_smooth(method=lm)

p3 <- ggplot(dat_mean, aes(y=avg, x=condition)) +
	geom_bar(stat="identity", color="black", fill="black")+
	geom_errorbar(aes(ymin=avg-1.96*stdev,
	ymax=avg+1.96*stdev), color='red', width=0.5)

p4 <- ggplot(dat, aes(y=yvar, x=condition)) +
	geom_boxplot()

# Plot them
multiplot(p1,p2,p3,p4, cols=2)
multiplot(p1,p2, cols=2)
multiplot(p1,p2, cols=1)
multiplot(p1,p2,p3, layout=matrix(c(1,2,3,3), nrow=2, byrow=TRUE))
multiplot(p1,p2,p3, layout=matrix(c(1,2,1,3), ncol=2, byrow=TRUE))

############################# Resources ################################
#
# Cookbook for R
# Available online and a great resource. Go to the Graphs section:
# www.cookbook-r.com
#
#
# Use R! ggplot2 	-    Springer
#
########################################################################


#!/usr/bin/r
##
## fastLm.r: Benchmarking lm() via RcppArmadillo and directly
##
## Copyright (C)  2010 - 2015  Dirk Eddelbuettel, Romain Francois and Douglas Bates
##
## This file is part of RcppArmadillo.
##
## RcppArmadillo 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 2 of the License, or
## (at your option) any later version.
##
## RcppArmadillo 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 RcppArmadillo.  If not, see <http://www.gnu.org/licenses/>.

library(Rcpp)
library(RcppArmadillo)
library(rbenchmark)

## start from SEXP, most conversions, longest code
src <- '
Rcpp::List fLmSEXP(SEXP Xs, SEXP ys) {
    Rcpp::NumericMatrix Xr(Xs);
    Rcpp::NumericVector yr(ys);
    int n = Xr.nrow(), k = Xr.ncol();
    arma::mat X(Xr.begin(), n, k, false);
    arma::colvec y(yr.begin(), yr.size(), false);
    int df = n - k;

    // fit model y ~ X, extract residuals
    arma::colvec coef = arma::solve(X, y);
    arma::colvec res  = y - X*coef;

    double s2 = std::inner_product(res.begin(), res.end(),
                                   res.begin(), 0.0)/df;
    // std.errors of coefficients
    arma::colvec sderr = arma::sqrt(s2 *
       arma::diagvec(arma::pinv(arma::trans(X)*X)));

    return Rcpp::List::create(Rcpp::Named("coefficients")=coef,
                              Rcpp::Named("stderr")      =sderr,
                              Rcpp::Named("df")          =df);
}
'
cppFunction(code=src, depends="RcppArmadillo")

## start from Rcpp types are early RcppArmadillo examples did
src <- '
Rcpp::List fLmTwoCasts(Rcpp::NumericMatrix Xr, Rcpp::NumericVector yr) {
    int n = Xr.nrow(), k = Xr.ncol();
    arma::mat X(Xr.begin(), n, k, false);
    arma::colvec y(yr.begin(), yr.size(), false);
    int df = n - k;

    // fit model y ~ X, extract residuals
    arma::colvec coef = arma::solve(X, y);
    arma::colvec res  = y - X*coef;

    double s2 = std::inner_product(res.begin(), res.end(),
                                   res.begin(), 0.0)/df;
    // std.errors of coefficients
    arma::colvec sderr = arma::sqrt(s2 *
       arma::diagvec(arma::pinv(arma::trans(X)*X)));

    return Rcpp::List::create(Rcpp::Named("coefficients")=coef,
                              Rcpp::Named("stderr")      =sderr,
                              Rcpp::Named("df")          =df);
}
'
cppFunction(code=src, depends="RcppArmadillo")

## start from Armadillo types
src <- '
Rcpp::List fLmOneCast(arma::mat X, arma::colvec y) {
    int df = X.n_rows - X.n_cols;

    // fit model y ~ X, extract residuals
    arma::colvec coef = arma::solve(X, y);
    arma::colvec res  = y - X*coef;

    double s2 = std::inner_product(res.begin(), res.end(),
                                   res.begin(), 0.0)/df;
    // std.errors of coefficients
    arma::colvec sderr = arma::sqrt(s2 *
       arma::diagvec(arma::pinv(arma::trans(X)*X)));

    return Rcpp::List::create(Rcpp::Named("coefficients")=coef,
                              Rcpp::Named("stderr")      =sderr,
                              Rcpp::Named("df")          =df);
}
'
cppFunction(code=src, depends="RcppArmadillo")

## start from Armadillo types passed as constant references
src <- '
Rcpp::List fLmConstRef(const arma::mat & X, const arma::colvec & y) {
    int df = X.n_rows - X.n_cols;

    // fit model y ~ X, extract residuals
    arma::colvec coef = arma::solve(X, y);
    arma::colvec res  = y - X*coef;

    double s2 = std::inner_product(res.begin(), res.end(),
                                   res.begin(), 0.0)/df;
    // std.errors of coefficients
    arma::colvec sderr = arma::sqrt(s2 *
       arma::diagvec(arma::pinv(arma::trans(X)*X)));

    return Rcpp::List::create(Rcpp::Named("coefficients")=coef,
                              Rcpp::Named("stderr")      =sderr,
                              Rcpp::Named("df")          =df);
}
'
cppFunction(code=src, depends="RcppArmadillo")

fastLmPureDotCall <- function(X, y) {
    .Call("RcppArmadillo_fastLm", X, y, PACKAGE = "RcppArmadillo")
}

y <- log(trees$Volume)
X <- cbind(1, log(trees$Girth))
frm <- formula(log(Volume) ~ log(Girth))

res <- benchmark(fLmOneCast(X, y),             	# inline'd above
                 fLmTwoCasts(X, y),            	# inline'd above
                 fLmConstRef(X, y),            	# inline'd above
                 fLmSEXP(X, y),            	# inline'd above
                 fastLmPure(X, y),              # similar, but with 2 error checks
                 fastLmPureDotCall(X, y),       # now without the 2 error checks
                 fastLm(frm, data=trees),       # using model matrix
                 lm.fit(X, y),                  # R's fast function, no stderr
                 lm(frm, data=trees),           # R's standard function
                 columns = c("test", "replications", "relative",
                             "elapsed", "user.self", "sys.self"),
                 order="relative",
                 replications=5000)

print(res[,1:4])

## second run without formulae approach but larger N
res <- benchmark(fLmOneCast(X, y),             	# inline'd above
                 fLmTwoCasts(X, y),            	# inline'd above
                 fLmSEXP(X, y),            	# inline'd above
                 fLmConstRef(X, y),            	# inline'd above
                 fastLmPure(X, y),              # similar, but with 2 error checks
                 fastLmPureDotCall(X, y),       # now without the 2 error checks
                 lm.fit(X, y),                  # R's fast function, no stderr
                 columns = c("test", "replications", "relative",
                             "elapsed", "user.self", "sys.self"),
                 order="relative",
                 replications=50000)

print(res[,1:4])


gnomesort <- function(x)
{
   i <- 1
   j <- 1
   while(i < length(x))
   {
      if(x[i] <= x[i+1])
      {
         i <- j
         j <- j+1
      } else
      {
         temp <- x[i]
         x[i] <- x[i+1]
         x[i+1]  <- temp
         i <- i - 1
         if(i == 0)
         {
            i <- j
            j <- j+1
         }
      }
   }
   x
}
gnomesort(c(4, 65, 2, -31, 0, 99, 83, 782, 1)) # -31   0   1   2   4  65  83  99 782


# Load the data:
# car braking distances in feet paired with speeds in km/h
# see ?cars for details
data(cars)
# fit a linear regression of distance on speed
m <- lm( dist ~ speed , data=cars )
# estimated coefficients from the model
coef(m)
# plot residuals against speed
plot( resid(m) ~ speed , data=cars )


# [Mengenal Data - Part 1](https://academy.dqlab.id/main/livecode/281/513/2519)
library(readr)

chocolates <-
  read_csv(
    "https://dqlab-dataset.s3-ap-southeast-1.amazonaws.com/chocolates.csv",
    col_types = cols(
      panelist = col_factor(),
      session = col_factor(),
      rank = col_factor(),
      product = col_factor(levels = paste0("choc", 1:6)),
      .default = col_integer()
    )
  )
chocolates

# [Mengenal Data - Part 2: Eksplorasi Struktur Data](https://academy.dqlab.id/main/livecode/281/513/2520)
install.packages("skimr",repos = "http://cran.us.r-project.org")
library(skimr)

skim(chocolates)

# [Mengenal Data - Part 3](https://academy.dqlab.id/main/livecode/281/513/2521)
library(dplyr)

chocolates %>%
  summarise(
    sample = toString(levels(product)),
    n_sample = n_distinct(product),
    n_panelist = n_distinct(panelist)
  )

n_sample <- 6
n_panelist <- 29

# [Mengenal Data - Part 4](https://academy.dqlab.id/main/livecode/281/513/2522)
ncol(chocolates) - 4
atribut_sensoris <- colnames(chocolates[-c(1, 2, 3, 4)])
atribut_sensoris

# [Mengenal Data - Part 5](https://academy.dqlab.id/main/livecode/281/513/2523)
install.packages("skimr",repos = "http://cran.us.r-project.org")
library(skimr)
library(dplyr)

chocolates %>%
  select(atribut_sensoris) %>%
  skim_without_charts()

batas_bawah <- 0
batas_atas <- 10

# [Dari Satu Sisi - Part 1](https://academy.dqlab.id/main/livecode/281/513/2525)
model_bitterness <- aov(bitterness ~ product + panelist +
                          session + panelist:product + panelist:session +
                          product:session + rank, data = chocolates)

model_bitterness

# [Dari Satu Sisi - Part 2](https://academy.dqlab.id/main/livecode/281/513/2526)
anova(model_bitterness)

# [Dari Satu Sisi - Part 3](https://academy.dqlab.id/main/livecode/281/513/2527)
summary.lm(model_bitterness)
-1.74 # dua digit di belakang koma/titik

# [Dari Satu Sisi - Part 6](https://academy.dqlab.id/main/livecode/281/513/2530)
library(FactoMineR)

res_bitterness <- AovSum(model_bitterness)

anova(model_bitterness)

res_bitterness$Ftest

# [Dari Satu sisi - Part 7](https://academy.dqlab.id/main/livecode/281/513/2531)
res_bitterness$Ttest[1:7, 1:2]
c("choc1", "choc4", "choc2", "choc5", "choc6", "choc3")

# [Dari Satu Sisi - Part 8](https://academy.dqlab.id/main/livecode/281/513/2532)
install.packages('agricolae ', repos="http://cran.rstudio.com/")
library(agricolae )

posthoc_bitterness  <- HSD.test(model_bitterness, trt = "product")
posthoc_bitterness$groups

# [Dari Satu Sisi - Part 9](https://academy.dqlab.id/main/livecode/281/513/2533)
install.packages('agricolae', repos="http://cran.rstudio.com/")
library(agricolae)

posthoc_bitterness$groups

plot.group(posthoc_bitterness, variation = "SE")

# [Tak Cukup Satu Sisi - Part 2](https://academy.dqlab.id/main/livecode/281/513/2536)
library(dplyr)
library(corrplot)

chocolates2 <- chocolates %>%
  select(atribut_sensoris) %>%
  cor() %>%
  corrplot(
    type = "upper",
    method = "square",
    diag = FALSE,
    addgrid.col = FALSE,
    order = "FPC",
    tl.col = "gray30",
    tl.srt = 30
  )
chocolates2

# [Tak Cukup Satu Sisi - Part 4](https://academy.dqlab.id/main/livecode/281/513/2538)
chocolates_adjmean <- readRDS("chocolates_adjmean.rds")
chocolates_adjmean
dim(chocolates_adjmean)

# [Tak Cukup Satu Sisi - Part 5](https://academy.dqlab.id/main/livecode/281/513/2539)
library(FactoMineR)

chocolates_pca <- PCA(chocolates_adjmean, graph = FALSE)
names(chocolates_pca)
chocolates_pca$eig

# [Tak Cukup Satu Sisi - Part 6](https://academy.dqlab.id/main/livecode/281/513/2540)
library(factoextra)

fviz_eig(chocolates_pca, choice = "eigenvalue", addlabels = TRUE)
fviz_eig(chocolates_pca, choice = "variance", addlabels = TRUE)

# [Tak Cukup Satu Sisi - Part 7](https://academy.dqlab.id/main/livecode/281/513/2541)
library(factoextra)

fviz_pca_ind(chocolates_pca, repel = TRUE)

# [Tak Cukup Satu Sisi - Part 8](https://academy.dqlab.id/main/livecode/281/513/2542)
library(factoextra)

fviz_pca_ind(chocolates_pca, repel = TRUE)

choc2 <- FALSE
choc3 <- TRUE
choc4 <- FALSE
choc5 <- FALSE
choc6 <- TRUE

# [Tak Cukup Satu Sisi - Part 9](https://academy.dqlab.id/main/livecode/281/513/2543)
library(factoextra)

fviz_pca_var(chocolates_pca, repel = TRUE)

# [Tak Cukup Satu Sisi - Part 10](https://academy.dqlab.id/main/livecode/281/513/2544)
library(factoextra)

fviz_pca_var(chocolates_pca, repel = TRUE)
"sticky"
"crunchy"

# [Tak Cukup Satu Sisi - Part 11](https://academy.dqlab.id/main/livecode/281/513/2545)
library(factoextra)

fviz_pca_biplot(chocolates_pca, repel = TRUE, title = "Peta Persepsi Produk Cokelat Komersial")

# [Pembukaan - Part 1](https://academy.dqlab.id/main/livecode/281/514/2547)
FALSE

# [Pembukaan - Part 2](https://academy.dqlab.id/main/livecode/281/514/2560)
TRUE

# [Konsistensi](https://academy.dqlab.id/main/livecode/281/514/2548)
metode_riset <- TRUE
kolom_panelis <- TRUE
jumlah_panelis <- TRUE
kolom_sampel <- TRUE
nama_sampel <- FALSE
jumlah_sampel <- TRUE
kolom_atribut_sensoris <- TRUE
jumlah_atribut_sensoris <- TRUE
informasi_hedonik <- TRUE
model_statistik <- FALSE

# [Dari Satu Sisi: ala SenseHub - Part 1](https://academy.dqlab.id/main/livecode/281/514/2549)
"Cochran's Q test" <- FALSE
"Analysis of variance" <- TRUE
"Chi-square test" <- FALSE

# [Dari Satu Sisi: ala SenseHub - Part 2](https://academy.dqlab.id/main/livecode/281/514/2550)
"Dotplot" <- FALSE
"Radar Plot" <- TRUE
"Dumbell Plot" <- FALSE
"Spider Plot" <- TRUE

# [Tak Cukup Satu Sisi: ala SenseHub - Part 1](https://academy.dqlab.id/main/livecode/281/514/2551)
5

# [Tak Cukup Satu Sisi: ala SenseHub - Part 2](https://academy.dqlab.id/main/livecode/281/514/2552)
96.4 # tanpa penanda persen (%)

R/Kelas Penerapan/A Walk Into Sensory Science/A Walk Into Sensory Science.r


lm_curve = function(lr,Ms,p,ly,prod,rmin){
  r = 1/lr*(Ms/p - ly*prod)
  r[r < rmin] = rmin
  return(r)
}

RMPlot <- function(input,output,values){
    masse = seq(0,input$Mmax,length.out = 100)
    prod = seq(0,input$ymax,length.out = 100)
    to_plot = data.frame(money = masse, revenu = prod)
    fig = plot_ly(to_plot, x = ~money)

    fig = fig %>% add_segments(x = input$Ms, y = 0, xend = input$Ms, yend = 15, type = "scatter", mode = "lines", name = "$$M = M^s$$", color = I("blue"),
                                 hovertemplate = paste("Ms=%{x:.0f}","<extra></extra>"))
    fig = fig %>% add_trace(y = lm_curve(input$lr, masse,values$p,input$ly,values$eq$y, input$rmin), type = "scatter", mode = "lines", name = "$$M^d$$", color = I("red"),
                              hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    fig = fig %>% add_segments(x = 0, y = values$eq$r, xend = input$Mmax, yend = values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

    if(values$shock & !is.na(input$new_value_LM)){
      if(input$shocked_var_LM == "Ms"){
        fig = fig %>% add_segments(x = values$shocked_params_LM["Ms"], y = 0, xend = values$shocked_params_LM["Ms"], yend = 15, type = "scatter", mode = "lines", name = "$$M = M^s$$", color = "rgb(0,20,200)",
                                     hovertemplate = paste("Ms=%{x:.0f}","<extra></extra>"))
        fig = fig %>% add_segments(x = 0, y = values$new_eq$r, xend = input$Mmax, yend = values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                     hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
      } else if(input$shocked_var_LM != "Ms"){
        fig = fig %>% add_trace(y = lm_curve(values$shocked_params_LM["lr"],masse,values$shocked_params_LM["p"]/100,values$shocked_params_LM["ly"],values$shocked_params_LM["ystar"],input$rmin), type = "scatter", mode = "lines", name = "$$M^d$$", color = "rgb(0,200,20)",
                                  hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
        fig = fig %>% add_segments(x = 0, y = values$new_eq$r, xend = input$Mmax, yend = values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                     hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
      }
      new_eq = list(
        x = unname(values$shocked_params_LM["Ms"]),
        y = values$new_eq$r,
        text = paste0("r*=",round(values$new_eq$r,1))
      )
      fig = fig %>% layout(annotations = new_eq)
    } else{
      eq = list(
        x = input$Ms,
        y = values$eq$r,
        text = paste0("r*=",round(values$eq$r,1))
      )
      fig = fig %>% layout(annotations = eq)
    }

    f <- list(
      family = "Courier New, monospace",
      size = 18,
      color = "#7f7f7f"
    )
    money <- list(
      title = "Masse monétaire réelle, M/p",
      titlefont = f
    )
    interest <- list(
      title = "Taux d'intérêt, r",
      titlefont = f
    )
    fig = fig %>% layout(xaxis = money, yaxis = interest)
}

LMPlot <- function(input,output,values){
  masse = seq(0,input$Mmax,length.out = 100)
  prod = seq(0,input$ymax,length.out = 100)
  to_plot = data.frame(money = masse, revenu = prod)

  fig = plot_ly(to_plot, x = ~revenu)
  fig = fig %>% add_trace(y = lm_curve(input$lr, input$Ms, values$p, input$ly, prod, input$rmin), type = "scatter", mode = "lines", name = "$$LM_1$$", color = I("red"),
                            hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(0,values$eq$r,values$eq$y,values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$y,0,values$eq$y,values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  if(values$shock & !is.na(input$new_value_LM)){
    if(input$shocked_var_LM != "ystar"){
      fig = fig %>% add_trace(y = lm_curve(values$shocked_params_LM["lr"],values$shocked_params_LM["Ms"],values$shocked_params_LM["p"],values$shocked_params_LM["ly"],prod,input$rmin), type = "scatter", mode = "lines", name = "$$LM_2$$", color = "rgb(0,200,20)",
                                hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    }
    fig = fig %>% add_segments(0,values$new_eq$r,values$shocked_params_LM["ystar"],values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    fig = fig %>% add_segments(values$shocked_params_LM["ystar"],0,values$shocked_params_LM["ystar"],values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    lm_eq = list(
      x = unname(values$shocked_params_LM["ystar"]),
      y = values$new_eq$r,
      text = paste0("r*=",round(values$new_eq$r,1))
    )
    fig = fig %>% layout(annotations = lm_eq)
  } else{
    is_eq = list(
      x = values$eq$y,
      y = values$eq$r,
      text = paste0("r*=",round(values$eq$r,1))
    )
    fig = fig %>% layout(annotations = is_eq)
  }

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  revenu <- list(
    title = "Revenu, y",
    titlefont = f
  )
  interest <- list(
    title = "Taux d'intérêt, r",
    titlefont = f
  )
  fig = fig %>% layout(xaxis = revenu, yaxis = interest)
}


# packages needed for chapter 1
library(dplyr)
library(tidyr)
library(ggplot2)
library(vioplot)
library(ascii)
library(corrplot)
library(descr)

# Import the datasets needed for chapter 1
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')
dir.create(file.path(PSDS_PATH, 'figures'))

state <- read.csv(file.path(PSDS_PATH, 'data', 'state.csv'))
dfw <- read.csv(file.path(PSDS_PATH, 'data', 'dfw_airline.csv'))
sp500_px <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_px.csv'))
sp500_sym <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_sym.csv'), stringsAsFactors = FALSE)
kc_tax <- read.csv(file.path(PSDS_PATH, 'data', 'kc_tax.csv'))
lc_loans <- read.csv(file.path(PSDS_PATH, 'data', 'lc_loans.csv'))
airline_stats <- read.csv(file.path(PSDS_PATH, 'data', 'airline_stats.csv'), stringsAsFactors = FALSE)
airline_stats$airline <- ordered(airline_stats$airline, levels=c('Alaska', 'American', 'Jet Blue', 'Delta', 'United', 'Southwest'))
## Code to create state table
state_asc <- state
state_asc[["Population"]] <- formatC(state_asc[["Population"]], format="d", digits=0, big.mark=",")
ascii(state_asc[1:8,], digits=c(0, 0,1), align=c("l", "l", "r", "r"), caption="A few rows of the +data.frame state+ of population and murder rate by state.")

## Code snippet 1.1
mean(state[["Population"]])
mean(state[["Population"]], trim=0.1)
median(state[["Population"]])

## Code snippet 1.2
mean(state[["Murder.Rate"]])
library("matrixStats")
weighted.mean(state[["Murder.Rate"]], w=state[["Population"]])

## Code snippet 1.3
sd(state[["Population"]])
IQR(state[["Population"]])
mad(state[["Population"]])

## Code snippet 1.4
quantile(state[["Murder.Rate"]], p=c(.05, .25, .5, .75, .95))

## Code to create PercentileTable
ascii(
  quantile(state[["Murder.Rate"]], p=c(.05, .25, .5, .75, .95)),
  include.rownames=FALSE, include.colnames=TRUE, digits=rep(2,5), align=rep("r", 5),
  caption="Percentiles of murder rate by state.")

## Code snippet 1.5
boxplot(state[["Population"]]/1000000, ylab="Population (millions)")

## Code for Figure 2
png(filename=file.path(PSDS_PATH, "figures", "psds_0102.png"), width = 3, height=4, units='in', res=300)
par(mar=c(0,4,0,0)+.1)
boxplot(state[["Population"]]/1000000, ylab="Population (millions)")
dev.off()

## Code snippet 1.6
breaks <- seq(from=min(state[["Population"]]), to=max(state[["Population"]]), length=11)
pop_freq <- cut(state[["Population"]], breaks=breaks, right=TRUE, include.lowest = TRUE)
state['PopFreq'] <- pop_freq
table(pop_freq)

## Code for FreqTable
state_abb <- state %>%
  arrange(Population) %>%
  group_by(PopFreq) %>%
  summarize(state = paste(Abbreviation, collapse=","), .drop=FALSE) %>%
  complete(PopFreq, fill=list(state='')) %>%
  select(state)

state_abb <- unlist(state_abb)

lower_br <- formatC(breaks[1:10], format="d", digits=0, big.mark=",")
upper_br <- formatC(c(breaks[2:10]-1, breaks[11]), format="d", digits=0, big.mark=",")

pop_table <- data.frame("BinNumber"=1:10,
                        "BinRange"=paste(lower_br, upper_br, sep="-"),
                        "Count"=as.numeric(table(pop_freq)),
                        "States"=state_abb)
ascii(pop_table, include.rownames=FALSE, digits=c(0, 0, 0, 0), align=c("l", "r", "r", "l"),
      caption="A frequency table of population by state.")

## Code snippet 1.7
hist(state[["Population"]], breaks=breaks)

## Code for Figure 3
png(filename=file.path(PSDS_PATH, "figures", "psds_0103.png"),  width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
pop_hist <- hist(state[["Population"]], breaks=breaks,
                 xlab="Population", main="")
dev.off()

## Code snippet 1.8
hist(state[["Murder.Rate"]], freq=FALSE )
lines(density(state[["Murder.Rate"]]), lwd=3, col="blue")

## Code for Figure 4
png(filename=file.path(PSDS_PATH, "figures", "psds_0104.png"),  width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
hist(state[["Murder.Rate"]], freq=FALSE, xlab="Murder Rate (per 100,000)", main="" )
lines(density(state[["Murder.Rate"]]), lwd=3, col="blue")
dev.off()

## Code for AirportDelays
ascii(
  100*as.matrix(dfw/sum(dfw)),
  include.rownames=FALSE, include.colnames=TRUE, digits=rep(2,5), align=rep("r", 5),
  caption="Percentage of delays by cause at Dallas-Ft. Worth airport.")

## Code for figure 5
png(filename=file.path(PSDS_PATH, "figures", "psds_0105.png"),  width = 4, height=4, units='in', res=300)
par(mar=c(4, 4, 0, 1) + .1)
barplot(as.matrix(dfw)/6, cex.axis = 0.8, cex.names = 0.7)
dev.off()

## Code for CorrTable (Table 1.7)
telecom <- sp500_px[, sp500_sym[sp500_sym$sector=="telecommunications_services", 'symbol']]
telecom <- telecom[row.names(telecom)>"2012-07-01", ]
telecom_cor <- cor(telecom)
ascii(telecom_cor, digits=c( 3,3,3,3,3), align=c("l", "r", "r", "r", "r", "r"), caption="Correlation between telecommunication stock returns.",
      include.rownames = TRUE, include.colnames = TRUE)

## Code snippet 1.10
etfs <- sp500_px[row.names(sp500_px)>"2012-07-01",
                 sp500_sym[sp500_sym$sector=="etf", 'symbol']]
corrplot(cor(etfs), method = "ellipse")

## Code for figure 6
png(filename=file.path(PSDS_PATH, "figures", "psds_0106.png"), width = 4, height=4, units='in', res=300)
etfs <- sp500_px[row.names(sp500_px)>"2012-07-01", sp500_sym[sp500_sym$sector=="etf", 'symbol']]
library(corrplot)
corrplot(cor(etfs), method = "ellipse")
dev.off()

## Code snippet 1.11
plot(telecom$T, telecom$VZ, xlab="T", ylab="VZ")

## Code for Figure 7
png(filename=file.path(PSDS_PATH, "figures", "psds_0107.png"),  width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,1)+.1)
plot(telecom$T, telecom$VZ, xlab="T", ylab="VZ", cex=.8)
abline(h=0, v=0, col="grey")
dev.off()

## Code snippet 1.12
kc_tax0 <- subset(kc_tax, TaxAssessedValue < 750000 & SqFtTotLiving>100 &
                  SqFtTotLiving<3500)
nrow(kc_tax0)

## Code snippet 1.13
ggplot(kc_tax0, (aes(x=SqFtTotLiving, y=TaxAssessedValue))) +
  stat_binhex(colour="white") +
  theme_bw() +
  scale_fill_gradient(low="white", high="black") +
  labs(x="Finished Square Feet", y="Tax Assessed Value")

## Code for figure 8
png(filename=file.path(PSDS_PATH, "figures", "psds_0108.png"),  width = 4, height=4, units='in', res=300)
ggplot(kc_tax0, (aes(x=SqFtTotLiving, y=TaxAssessedValue))) +
  stat_binhex(colour="white") +
  theme_bw() +
  scale_fill_gradient(low="white", high="black") +
  labs(x="Finished Square Feet", y="Tax Assessed Value")
dev.off()

## Code snippet 1.14
ggplot(kc_tax0, aes(SqFtTotLiving, TaxAssessedValue)) +
  theme_bw() +
  geom_point( alpha=0.1) +
  geom_density2d(colour="white") +
  labs(x="Finished Square Feet", y="Tax Assessed Value")

## Code for figure 9

png(filename=file.path(PSDS_PATH, "figures", "psds_0109.png"),  width = 4, height=4, units='in', res=300)
ggplot(kc_tax0, aes(SqFtTotLiving, TaxAssessedValue)) +
  theme_bw() +
  geom_point(colour="blue", alpha=0.1) +
  geom_density2d(colour="white") +
  labs(x="Finished Square Feet", y="Tax Assessed Value")
dev.off()

## Code snippet 1.15

## Code for CrossTabs
x_tab <- CrossTable(lc_loans$grade, lc_loans$status,
                    prop.c=FALSE, prop.chisq=FALSE, prop.t=FALSE)

tots <- cbind(row.names(x_tab$tab), format(cbind(x_tab$tab, x_tab$rs)))
props <- cbind("", format(cbind(x_tab$prop.row, x_tab$rs/x_tab$gt), digits=1))
c_tot <- c("Total", format(c(x_tab$cs, x_tab$gt)))

asc_tab <- matrix(nrow=nrow(tots)*2+1, ncol=ncol(tots))
colnames(asc_tab) <- c("Grade", colnames(x_tab$tab), "Total")
idx <- seq(1, nrow(asc_tab)-1, by=2)
asc_tab[idx,] <- tots
asc_tab[idx+1,] <- props
asc_tab[nrow(asc_tab), ] <- c_tot

ascii(asc_tab,  align=c("l", "r", "r", "r", "r"), include.rownames = FALSE, include.colnames = TRUE)

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

## Code snippet 1.16
boxplot(pct_carrier_delay ~ airline, data=airline_stats, ylim=c(0,50))

## Code for figure 10
png(filename=file.path(PSDS_PATH, "figures", "psds_0110.png"), width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
boxplot(pct_carrier_delay ~ airline, data=airline_stats, ylim=c(0,50), cex.axis=.6,
        ylab="Daily % of Delayed Flights")

dev.off()

## Code snippet 1.17

ggplot(data=airline_stats, aes(airline, pct_carrier_delay))  +
  ylim(0, 50) +
  geom_violin() +
  labs(x="", y="Daily % of Delayed Flights")

## Code for figure 11
png(filename=file.path(PSDS_PATH, "figures", "psds_0111.png"), width = 4, height=4, units='in', res=300)

ggplot(data=airline_stats, aes(airline, pct_carrier_delay)) +
  ylim(0, 50) +
  geom_violin(draw_quantiles = c(.25, .5, .75), linetype=2) +
  geom_violin(fill=NA, size=1.1) +
  theme_bw() +
  labs(x="", y="% of Delayed Flights")

dev.off()

## Code snippet 1.18

ggplot(subset(kc_tax0, ZipCode %in% c(98188, 98105, 98108, 98126)),
         aes(x=SqFtTotLiving, y=TaxAssessedValue)) +
  stat_binhex(colour="white") +
  theme_bw() +
  scale_fill_gradient( low="white", high="black") +
  labs(x="Finished Square Feet", y="Tax Assessed Value") +
  facet_wrap("ZipCode")

## Code for figure 12
png(filename=file.path(PSDS_PATH, "figures", "psds_0112.png"), width = 5, height=4, units='in', res=300)

ggplot(subset(kc_tax0, ZipCode %in% c(98188, 98105, 98108, 98126)),
       aes(x=SqFtTotLiving, y=TaxAssessedValue)) +
  stat_binhex(colour="white") +
  theme_bw() +
  scale_fill_gradient( low="gray95", high="blue") +
  labs(x="Finished Square Feet", y="Tax Assessed Value") +
  facet_wrap("ZipCode")
dev.off()


# Read data from CSV file
df = read.csv('data.csv')

marks <<- c(df$Mark)

# Create check function to get the vector of grade of corresponding marks

check <- function(mark) {
  if (mark>100){
    return(NULL)
  }
  else if (mark>=80){
    return(4.00)
  }
  else if (mark>=75){
    return(3.75)
  }
  else if (mark>=70){
    return(3.50)
  }
  else if (mark>=65){
    return(3.25)
  }
  else if (mark>=60){
    return(3.00)
  }
  else if (mark>=55){
    return(2.75)
  }
  else if (mark>=50){
    return(2.50)
  }
  else if (mark>=45){
    return(2.25)
  }
  else if (mark>=40){
    return(2.00)
  }
  else if (mark<40){
    return(0.00)
  }
  else {
    return(NULL)
  }
}

# Now Get the vector of grades from the given marks and store them in 'res'
res <- c()

for (i in 1:length(marks)){
  res <- c(res, check(marks[i]))
}

# Compute the CGPA
cgpa = sum(df$Credit*res)/sum(df$Credit)

# Print individual subjectwise result
print("-----------------------------------------------------------")
print(paste(df$Course, '(',marks,')' ,'->', res))
print("-----------------------------------------------------------")
# Print CGPA
print(paste('Your earned CGPA is', '->' ,round(cgpa, digits = 2)))
print("-----------------------------------------------------------")


par(mfrow=c(2,2))
data = read.table("run.txt", header=TRUE)
before = data[,1]
after = data[,2]
soft_d_before = before[1:12]
soft_d_after = after[1:12]
energy_d_before = before[13:24]
energy_d_after = after[13:24]
drink_type = data[,3]

#Q1
min(before);mean(before);max(before);median(before)
min(after);mean(after);max(after);median(after)

plot(data)

hist(before, freq=FALSE); lines(density(before), col="red",lwd=2)
hist(after, freq=FALSE); lines(density(after), col="red", lwd=2)

#Q2
#test difference in speed before and after soft drink
t.test(soft_d_before, soft_d_after, paired=TRUE)

#test difference in speed before and after energy drink
t.test(energy_d_before, energy_d_after, paired=TRUE)

#Q3
 #computing differences
 diffarr = numeric(length(before))
 for(i in 1:length(before)){
   diffarr[i] = abs(after[i]-before[i])
 }

 drinkframe=data.frame(difference=diffarr, variety=factor(data[,3]))

 drinkaov = lm(difference~variety,data=drinkframe)
 anova(drinkaov)
 summary(drinkaov)
 confint(drinkaov)
 #p has a low value,

 #N.B. not sure if I understood correctly but there is no need for code here. Just reasoning.

 #Q4
 #There would be no need for the softdrinks, which would give us a bigger sample size for energy drinks.

 #Q5
 #Yes the objection is similar as the participants should not have been split, but rather all of them should have drank the energy drink and an and
 # then drank the soft drink and ran, so that you can compare time differences for the same person since different people might simply have different running speed.
 #Furthermore, maybe the initial run (without drinking energy drinks or softdrinks) could have been removed since this would mean that the participants might be too tired for the 3rd run.

 #Q6
 #N.B. I'm not sure what the is meant by assumed distribution. I went through the notes and I'm quite sure that a permutation test is required
 #In order to change the vector values to residuals we can apply a linear regression model on the vector
 qqnorm(residuals(drinkaov)); qqline(residuals(drinkaov))


#!/usr/bin/Rscript
# MIT License, John Williams, github @jaw-analytics
# takes 2 args, weight in kg, and calories consumed that day
# assumes user has R v.3.2.0 or greater installed and is on a unix/linux system
# usage  ./weight_log.r 90 2000, where 90 is weight and 2000 is kcal consumed
args <- commandArgs(TRUE)

day <- format(Sys.Date(), "%m/%d")
# calculate BMR via Mifflin-St Jeor Equations:
#Mifflin, M. D., S. T. St Jeor, L. A. Hill, B. J. Scott, S. A. Daugherty, and Y. O. Koh. 1990. “A New Predictive Equation for Resting Energy Expenditure in Healthy Individuals.” The American Journal of Clinical Nutrition 51 (2): 241–47.

# m = mass in kg
# h = height in cm
# a = age in years
# g = gender, (-161 if female, +5 if male)
m <- as.numeric(args[1])
# change h to be your height in cm
h <- 171
# change a to your age in years
a <- 31
# change g to 5 if male, -161 if female
g <- 5
BMR <- (10.0*m + 6.25*h - 5.0*a + g)
BMI <- m/(1.71^2)
# log estimate of calories consumed
kcal <- as.numeric(args[2])

# log caloric balance for day
balance <- kcal - BMR
# write weight to log
cat(sprintf("%s\t%2.1f\t%2.2f\t%4.f\t%4.f\t%4.f\n", day, m, BMI, BMR, kcal, balance), file="log.txt", append=TRUE, sep="\t")
# read current log
log <- read.table(file="log.txt", header=TRUE, sep="\t")
#
#
#
#
# CREATE TIME SERIES
library(ggplot2)
library(forecast)
ts_weight <- ts(log$Weight_kg)
ts_bmi <- ts(log$BMI)
ts_balance <- ts(log$Kcal_Deficit)
ts_weight <- HoltWinters(ts_weight, beta=F,gamma=F)
ts_bmi <- HoltWinters(ts_bmi, beta=F, gamma=F)
ts_balance <- HoltWinters(ts_balance, beta=F, gamma=F)
# creates forecast. Days are set to (h=5), that can be changed for a longer forecast. If it is changed, correct the 'main' title in the plots below to reflect this.
weight_forecast <- forecast.HoltWinters(ts_weight, h=5)
bmi_forecast <- forecast.HoltWinters(ts_bmi, h=5)
balance_forecast <- forecast.HoltWinters(ts_balance, h=5)
# plot forecasts as weight_plots.svg
svg("weight_plots.svg")
par(mfrow=c(3,1))
plot.forecast(weight_forecast, main="5 Day Weight Forecast", xlab="Day", ylab="Weight (kg)")
plot.forecast(bmi_forecast, main="5 Day BMI Forecast", xlab="Day", ylab="BMI")
plot.forecast(balance_forecast, main="5 Day Caloric Deficit Forecast", xlab="Day", ylab="Energy Deficit (kcal)")
dev.off()


number_tests <- 10000 #Number of trials to average over
number_samples <- seq(5,75,5) #Variety of sample sizes stored in a vector
critical_r <- vector("numeric", length(number_samples)) #Vector to store the critical r value for each sample size
for(i in 1:length(number_samples))
{
  r_vals <- vector("numeric", number_tests)
  for(j in 1:number_tests)
  {
    qqp <- qqnorm(rnorm(number_samples[i]), plot.it = FALSE) #Generate a random sample of size number_samples[i] with rnorm; qqnorm does not plot QQ plot here, but returns a list containing two vectors (sample values and theoretical values)
    r_vals[j] <- cor(qqp$x,qqp$y) #Find the correlation coefficient between sample and theoretical values
  }
  sorted_r_vals <- sort(r_vals) #Sort the correlation coefficients (r) obtained from each trial in ascending order
  critical_r[i] <- sorted_r_vals[(number_tests*0.01) + 1] #Pick the correlation coefficient (r) just higher than the worst (lowest) 1% of values
}
critical_r #Vector of critical r values for each sample size
plot(number_samples, critical_r)


#' @title st_err
#' @description Calculates the standard error
#' @param x  The default value is \code{NULL}.
#' @family util
#' @author  Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @export
st_err <- function(x = NULL) {
  stats::sd(x)/sqrt(length(x))
}


#' Title Partial Least Square Regression
#'
#' @param x matrix
#' @param y vector
#'
#' @return just loadings
#' @import stats
#' @export
#'

PLSR1 <- function(x,y){
  # 用5折交叉验证的方法确定偏最小二乘回归主成分的个数
  # 然后用全体x、y求解对应的w*
  # PLSR1
  x <- scale(x)
  y <- scale(y)
  pis <- round(length(y)/5)
  a <- vector(length = 6)
  a[1] <- 1
  for (i in 1:5){
    a[i+1] <- i*pis
  }
  a[6] <- length(y)
  k <- length(x[1,])
  rmse <- vector(length = k)
  rmse[is.na(rmse)] <- 0
  for (i in 1:5){
    xx <- x[-c((a[i]):(a[i+1]-1)),]
    xtest <- x[c((a[i]):(a[i+1]-1)),]
    yy <- y[-c((a[i]):(a[i+1]-1))]
    ytest <- y[c((a[i]):(a[i+1]-1))]
    ypre <- vector(length = length(ytest))
    ypre[is.na(ypre)] <- 0
    w <- matrix(nrow = k,ncol = k)
    r <- vector(length = k)
    p <- matrix(nrow = k,ncol = k)
    for (j in 1:k){
      xp <- xx
      yp <- yy
      mat <- t(xp)%*%yp%*%t(yp)%*%xp
      en <- eigen(mat)
      w[,j] <- as.numeric(en$vec[,1])
      t <- xp%*%w[,j]
      p[,j] <- (t(xp)%*%t)/sum(t^2)
      r[j] <- t(yp)%*%t/sum(t^2)
      xx <- xp-t%*%t(p[,j])
      yy <- yp-t*(r[j])
    }
    for (e in 1:k){
      if (e==1){
        y_hat <- xtest%*%(w[,c(1:1)]*r[1])
        rmse[e] <- rmse[e] + mean(abs((ytest-y_hat)/ytest))
      }
      if (e>1){
        y_hat <- xtest%*%(w[,c(1:e)]%*%(r[c(1:e)]))
        rmse[e] <- rmse[e] + mean(abs((ytest-y_hat)/ytest))
      }
    }
  }
  rmse <- rmse/5
  or <- which.min(rmse)
  ww <- matrix(nrow = k,ncol = or)
  pp <- matrix(nrow = k,ncol = or)
  rr <- vector(length = or)
  for (d in 1:or){
    mat <- t(x)%*%y%*%t(y)%*%x
    en <- eigen(mat)
    ww[,d] <- as.numeric(en$vec[,1])
    t <- x%*%ww[,d]
    pp[,d] <- (t(x)%*%t)/sum(t^2)
    rr[d] <- t(y)%*%t/sum(t^2)
    x <- x-t%*%t(pp[,d])
    y <- y-t*(rr[d])
  }
  loadings <- ww%*%solve(t(pp)%*%ww)
  return(list(rmse,loadings))
}


#############################################################
# Random Everything - Testing What is Really Important
# Date Started:  09/28/2020
# jake.stoetzner@gmail.com
# Goal:  Is it possible to simply manage trades with profit targets, trailing stops and stop losses?
#############################################################

#<---------------- Coin Flip Stock -------------------->
set.seed(123)

# - normal distribution of positive or negative
p.sample.signal <- c(-1,1)
p.prob <- 0.5 #percent of times
p.periods <- 200 #number of periods

coin.flips <- sample(p.sample.signal,
                size = p.periods,
                replace = TRUE,
                prob = c(p.prob, 1 - p.prob))

# - lognormal distribution of returns
p.mean.log <- 0
p.sd.log <- .005
coin.returns <- rlnorm(n=p.periods,
                  meanlog = p.mean.log,
                  sdlog = p.sd.log)

# - position
coin.position <- (coin.returns-1)*coin.flips

#<---------------- Test 1: Random Entry/Random Exit for Coin-Flip Stock -------------------->
fn.coin.flip <- function(
                  p.prob = 0.5,
                  p.periods = 200,
                  p.mean.log = 0,
                  p.sd.log = .005)
    {
    a <- sample(c(-1,1),p.periods,replace = TRUE, prob = c(p.prob, 1 - p.prob))
    b <- rlnorm(p.periods, p.mean.log, p.sd.log)
    c <- (b-1)*a
    return(c)
  }

fn.final.coin.flip <- function(){
  a <- sum(fn.coin.flip(),na.rm = T)
  return(a)
}

# - find the final value of the coin flip stock 100,000 times
mc.coin.flip <- replicate(100000, fn.final.coin.flip())

# - output a summary of the monte carlo simulation and a histogram
round(summary(mc.coin.flip),5)
#     Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# -0.30376 -0.04810 -0.00009 -0.00001  0.04829  0.29403

hist(mc.coin.flip,breaks = 100)

#<---------------- Test 2: Random Entry/Stop-Loss or Profit Target Exit for Coin-Flip Stock -------------------->
fn.fixed.stop.fixed.pt <- function(weight, price, tstart, tend, pstop, pprofit) {
  index = tstart : tend
  if(weight > 0){
    temp = price[ index ] < (1 - pstop) * price[ tstart ]

    # profit target
    temp = temp | price[ index ] > (1 + pprofit) * price[ tstart ]

  } else{

    temp = price[ index ] > (1 + pstop) * price[ tstart ]

    # profit target
    temp = temp | price[ index ] < (1 - pprofit) * price[ tstart ]
  }
}

fn.fixed.stop.fixed.pt.coin.flip <- function(
                            start.value = 100,
                            p.periods = 200,
                            positive.percent.stop = .01,
                            p.prob = .5,
                            p.profit = .02)
  {
  a <- fn.coin.flip(p.prob)           # - vector of returns at p.prob
  b <- cumprod(c(start.value, a + 1)) # - vector of stock prices based on those returns
  c <- first(which(fn.fixed.stop.fixed.pt(1, b, 1, p.periods, positive.percent.stop, p.profit))) # - find the index of the first instance where the trail stop fires
  c.1 <- ifelse(is.na(c) == TRUE, p.periods, c)
  d <- b[c.1] # - return the value of the index
  e <- d/start.value-1 # - exit over entry
  return(e)
}

mc.fixed.stop.fixed.pt.coin.flip <- replicate(100000,fn.fixed.stop.fixed.pt.coin.flip())
round(summary(mc.fixed.stop.fixed.pt.coin.flip),5)
#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# -0.02965 -0.01296 -0.01085 -0.00010  0.02122  0.03993
hist(mc.fixed.stop.fixed.pt.coin.flip)

#<---------------- est 3: Random Entry/Trailing Stop (%) Exit for Coin-Flip Stock -------------------->
# ----- trailing stop: exit trade once price falls below % from max price since start of trade
fn.trailing.stop.long <- function(weight = 1, price, tstart, tend, positive.percent.stop) {
    index = tstart : tend
    if(weight > 0)
        price[ index ] < (1 - positive.percent.stop) * cummax(price[ index ])
    else
        price[ index ] > (1 + positive.percent.stop) * cummin(price[ index ])
}

fn.trail.stop.coin.flip <- function(
                            start.value = 100,
                            p.periods = 200,
                            positive.percent.stop = .01,
                            p.prob = .5,
                            p.mean.log = 0,
                            p.sd.log = .005)
  {
  a <- fn.coin.flip(p.prob) # - vector of returns at p.prob
  b <- cumprod(c(start.value, a + 1)) # - vector of stock prices based on those returns
  c <- first(which(fn.trailing.stop.long(1, b, 1, p.periods,positive.percent.stop ))) # - find the index of the first instance where the trail stop fires
  c.1 <- ifelse(is.na(c) == TRUE, p.periods, c)
  d <- b[c.1] # - return the value of the index
  e <- d/start.value-1 # - exit minus entry
  return(e)
}

mc.trail.stop.coin.flip <- replicate(100000,fn.trail.stop.coin.flip())
round(summary(mc.trail.stop.coin.flip),5)
# Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# -0.27392 -0.04873 -0.00243 -0.00015  0.04605  0.40692
hist(mc.trail.stop.coin.flip,breaks = 100)

#- "loose" 5% trailing stop
mc.trail.stop.coin.flip.5 <- replicate(100000,fn.trail.stop.coin.flip(positive.percent.stop = .05))
round(summary(mc.trail.stop.coin.flip.5),5)

# Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# -0.27392 -0.04873 -0.00243 -0.00015  0.04605  0.40692
hist(mc.trail.stop.coin.flip.5,breaks = 100)

#<---------------- Test 4: Random Entry/Trailing Stop (%) or Profit-Target(%) Exit for Coin-Flip Stock -------------------->
fn.trailing.stop.profit.target <- function(weight, price, tstart, tend, positive.percent.stop, p.profit) {
		index = tstart : tend
		if(weight > 0) {
			temp = price[ index ] < (1 - positive.percent.stop) * cummax(price[ index ])

			# profit target
			temp = temp | price[ index ] > (1 + p.profit) * price[ tstart ]
		} else {
			temp = price[ index ] > (1 + positive.percent.stop) * cummin(price[ index ])

			# profit target
			temp = temp | price[ index ] < (1 - p.profit) * price[ tstart ]
		}
		return( temp )
	}

fn.trail.stop.prof.targ.coin.flip <- function(
                            start.value = 100,
                            p.periods = 200,
                            positive.percent.stop = .01,
                            p.prob = .5,
                            p.profit = .02)
  {
  a <- fn.coin.flip(p.prob) # - vector of returns at p.prob
  b <- cumprod(c(start.value, a + 1)) # - vector of stock prices based on those returns
  c <- first(which(fn.trailing.stop.profit.target(1, b, 1, p.periods,positive.percent.stop, p.profit))) # - find the index of the first instance where the trail stop fires
  c.1 <- ifelse(is.na(c) == TRUE, p.periods, c)
  d <- b[c.1] # - return the value of the index
  e <- d/start.value-1 # - exit minus entry
  return(e)
}

mc.trail.stop.prof.targ.coin.flip <- replicate(100000,fn.trail.stop.prof.targ.coin.flip())
round(summary(mc.trail.stop.prof.targ.coin.flip),5)
#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
#-0.02863 -0.01087 -0.00501 -0.00001  0.00669  0.04056
hist(mc.trail.stop.prof.targ.coin.flip,breaks = 100)

#<---------------- Skewing the Coin Flip in Your Favor -------------------->
mc.trail.stop.coin.flip.skew <- replicate(100000,fn.trail.stop.coin.flip(p.prob = .47))
round(summary(mc.trail.stop.coin.flip.skew),5)

#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
#
-0.26530 -0.04847 -0.00219  0.00035  0.04635  0.33444
sum(unlist(mc.trail.stop.coin.flip.skew))
# [1] 34.67538

#<---------------- Testing on Actual Stock Data -------------------->
library(BatchGetSymbols)

# set dates
first.date <- Sys.Date() - 360
last.date <- Sys.Date()
freq.data <- 'daily'

# set tickers
df.SP500 <- GetSP500Stocks()
tickers <- df.SP500$Tickers

l.out <- BatchGetSymbols(tickers = tickers,
                         first.date = first.date,
                         last.date = last.date)

l.out.grouped <- l.out$df.tickers %>% group_by(ticker)

#<---------------- Test #1: Random Entry/Random Exit for Actual Stock Data -------------------->
fn.rand.exit.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 100,
                                    same.ticker = TRUE)
                                    {
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index
  b <- round(runif(1, min = a, max = length(data$price.open))) # - random exit index after entry
  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock data changes
  d <- min(c,max.periods)
  e <- ifelse(same.ticker == TRUE,
        ifelse(data$ticker[a] == data$ticker[b], # - if ticker is the same for both
          sum(data$ret.closing.prices[a:b], na.rm = T), # - sum of all returns
          sum(data$ret.closing.prices[a:(a+d)], na.rm = T)
        ),
        sum(data$ret.closing.prices[a:b], na.rm = T)
      )
  return(e)
}

mc.rand.exit.actual.data <- replicate(100000,fn.rand.exit.actual.data())

round(summary(mc.rand.exit.actual.data),5)
#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
#-1.64571 -0.09913  0.00626  0.01088  0.13075  1.59938

# - add in a custom function that plots a uniform distribution over the actual histogram
fn.uniform.hist <- function(data,
                    breaks, xlab = "Percent Return", main = "Frequency of Returns")
    {
  h <- hist(data, breaks = breaks, density = breaks, col = "gray", xlab = xlab, main = main)
  xfit <- seq(min(data), max(data), length = breaks)
  yfit <- dnorm(xfit, mean = mean(data), sd = sd(data))
  yfit <- yfit * diff(h$mids[1:2]) * length(data)
  lines(xfit, yfit, col = "black", lwd = 2)
}

mc.rand.exit.actual.data.10 <- replicate(10000,fn.rand.exit.actual.data(max.periods = 10))

round(summary(mc.rand.exit.actual.data.10),5)
#     Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# -1.09355 -0.02947  0.01046  0.00505  0.05168  0.68247

fn.uniform.hist(mc.rand.exit.actual.data.10, breaks = 200, xlab = "Percent Return", main = "Frequency of Returns - Actual Data | Random Exit | Max Hold 10")

#<---------------- Test #2: Random Entry/ Stop-Loss (%) or Profit-Target (%) Exit for Actual Stock Data -------------------->
fn.fixed.stop.fixed.pt.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 1000,
                                    same.ticker = TRUE,
                                    positive.percent.stop = .025,
                                    p.profit = .05){
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index

  b <- length(data$price.open) # - end of the data vector

  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock ticker changes as measured from the random entry

  d <- min(c,max.periods, na.rm = T) # - return length lesser of stock ticker change OR max hold periods

  a.1 <- first(which(fn.fixed.stop.fixed.pt(1, data$price.open, a, (a+d), positive.percent.stop, p.profit ))) # - return index of where stop loss or profit target fired, as measured from random entry to lesser of stock ticker change OR max hold periods

  a.2 <- min((a + a.1), min((a+d), b),na.rm = T) # - min exit index from entry (trail.stop, change of ticker, max.periods, full length of vector)

  #e <- data$price.open[[a.2]]/data$price.open[[a]]-1

  e <- sum(data$ret.closing.prices[a:a.2], na.rm = T) # - sum of all returns

  return(e)
}

# - mc analysis with max.periods at 1000, stop at 2.5% and profit target at 5%
mc.fixed.stop.fixed.pt.actual.data <- replicate(10000,fn.fixed.stop.fixed.pt.actual.data())

round(summary(mc.trail.stop.actual.data),5)

fn.uniform.hist(mc.fixed.stop.fixed.pt.actual.data, breaks = 200, xlab = "Percent Return", main = "Frequency of Returns - Actual Data | Stop Loss and Profit Target")fn.fixed.stop.fixed.pt.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 1000,
                                    same.ticker = TRUE,
                                    positive.percent.stop = .025,
                                    p.profit = .05){
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index

  b <- length(data$price.open) # - end of the data vector

  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock ticker changes as measured from the random entry

  d <- min(c,max.periods, na.rm = T) # - return length lesser of stock ticker change OR max hold periods

  a.1 <- first(which(fn.fixed.stop.fixed.pt(1, data$price.open, a, (a+d), positive.percent.stop, p.profit ))) # - return index of where stop loss or profit target fired, as measured from random entry to lesser of stock ticker change OR max hold periods

  a.2 <- min((a + a.1), min((a+d), b),na.rm = T) # - min exit index from entry (trail.stop, change of ticker, max.periods, full length of vector)

  #e <- data$price.open[[a.2]]/data$price.open[[a]]-1

  e <- sum(data$ret.closing.prices[a:a.2], na.rm = T) # - sum of all returns

  return(e)
}

# - mc analysis with max.periods at 1000, stop at 2.5% and profit target at 5%
mc.fixed.stop.fixed.pt.actual.data <- replicate(10000,fn.fixed.stop.fixed.pt.actual.data())

round(summary(mc.trail.stop.actual.data),5)

fn.uniform.hist(mc.fixed.stop.fixed.pt.actual.data, breaks = 200, xlab = "Percent Return", main = "Frequency of Returns - Actual Data | Stop Loss and Profit Target")fn.fixed.stop.fixed.pt.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 1000,
                                    same.ticker = TRUE,
                                    positive.percent.stop = .025,
                                    p.profit = .05){
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index

  b <- length(data$price.open) # - end of the data vector

  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock ticker changes as measured from the random entry

  d <- min(c,max.periods, na.rm = T) # - return length lesser of stock ticker change OR max hold periods

  a.1 <- first(which(fn.fixed.stop.fixed.pt(1, data$price.open, a, (a+d), positive.percent.stop, p.profit ))) # - return index of where stop loss or profit target fired, as measured from random entry to lesser of stock ticker change OR max hold periods

  a.2 <- min((a + a.1), min((a+d), b),na.rm = T) # - min exit index from entry (trail.stop, change of ticker, max.periods, full length of vector)

  #e <- data$price.open[[a.2]]/data$price.open[[a]]-1

  e <- sum(data$ret.closing.prices[a:a.2], na.rm = T) # - sum of all returns

  return(e)
}

# - mc analysis with max.periods at 1000, stop at 2.5% and profit target at 5%
mc.fixed.stop.fixed.pt.actual.data <- replicate(10000,fn.fixed.stop.fixed.pt.actual.data())

round(summary(mc.trail.stop.actual.data),5)

fn.uniform.hist(mc.fixed.stop.fixed.pt.actual.data, breaks = 200, xlab = "Percent Return", main = "Frequency of Returns - Actual Data | Stop Loss and Profit Target")

#<---------------- Test #3: Random Entry/Trailing Stop Exit on Actual Stock Data -------------------->
fn.trail.stop.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 1000,
                                    same.ticker = TRUE,
                                    positive.percent.stop = .1){
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index

  b <- length(data$price.open) # - end of the vector

  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock ticker changes as measured from the random entry

  d <- min(c,max.periods, na.rm = T)

  a.1 <- first(which(fn.trailing.stop.long(1, data$price.open, a, (a+d), positive.percent.stop ))) # - find the index of the first instance where the trail stop fires a measured from rand entry to lesser of where stock ticker changes or the max hold period

  a.2 <- min((a + a.1), min((a+d), b),na.rm = T) # - min exit index (trail.stop, change of ticker, max.periods, full length)

  #e <- data$price.open[[a.2]]/data$price.open[[a]]-1

  e <- sum(data$ret.closing.prices[a:a.2], na.rm = T) # - sum of all returns

  return(e)
}

# - mc analysis 100k runs - with max.periods at 100 and positive.percent stop at 5%
# - to compare with mc.random.exit.actual.data
mc.trail.stop.actual.data.comp <- replicate(100000,fn.trail.stop.actual.data(max.periods = 100, positive.percent.stop = .05))

round(summary(mc.trail.stop.actual.data.comp),5)
#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
#-0.90035 -0.05301 -0.01184 -0.00114  0.04277  0.88775

#<---------------- Test #4: Random Entry/Trailing Stop (%) or Profit-Target (%) Exit on Actual Stock Data -------------------->
fn.trail.stop.profit.target.actual.data <- function(data = l.out$df.tickers,
                                    max.periods = 1000,
                                    same.ticker = TRUE,
                                    positive.percent.stop = .025,
                                    p.profit = .05){
  a <- round(runif(1, min = 1, max = length(data$price.open))) # - random entry index

  b <- length(data$price.open) # - end of the vector

  c <- first(which(data$ticker[a:b] != lag(data$ticker[a:b],1))) # - where stock ticker changes as measured from the random entry

  d <- min(c,max.periods, na.rm = T)

  a.1 <- first(which(fn.trailing.stop.profit.target(1, data$price.open, a, (a+d), positive.percent.stop, p.stop ))) # - find the index of the first instance where the trail stop fires a measured from rand entry to lesser of where stock ticker changes or the max hold period

  a.2 <- min((a + a.1), min((a+d), b),na.rm = T) # - min exit index (trail.stop, change of ticker, max.periods, full length)

  #e <- data$price.open[[a.2]]/data$price.open[[a]]-1

  e <- sum(data$ret.closing.prices[a:a.2], na.rm = T) # - sum of all returns

  return(e)
}

# - mc analysis 100k runs - with max.periods at 100, positive.percent stop at 2.5% and profit target at 5%
# - to compare with mc.random.exit.actual.data
mc.trail.stop.profit.target.actual.data <- replicate(100000,fn.trail.stop.profit.target.actual.data(max.periods = 100))

# round(summary(mc.trail.stop.profit.target.actual.data),5)
#    Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
#-0.80554 -0.02529  0.00801  0.00185  0.03080  0.82386

#<---------------- Momentum, Mean Reversion, Runs and Random-Walk Theory -------------------->
# - set values for an up day equal to 1, down day to -1 and a flat day to 0
a <- ifelse(l.out$df.tickers$ret.closing.prices > 0, 1, ifelse(l.out$df.tickers$ret.closing.prices < 0, -1, 0))

# - replace all NA values with 0
a[is.na(a)] <- 0

# - count the streaks of up days, down days and zero days for all of the data
b <- rle(a)

# - return a summary of the runs of up days
summary(b$lengths[b$values == 1])
#   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#  1.000   1.000   1.000   2.009   3.000  17.000

# - return a summary of the runs of down days
summary(b$lengths[b$values == -1])
#   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#  1.000   1.000   1.000   1.835   2.000  12.000

# - total runs - positive
length(b$lengths[b$values == 1])
# [1] 31835
length(b$lengths[b$values == -1])
# [1] 31818

pos.runs <- unlist(lapply(1:17, function(x)(length(b$lengths[b$values == 1 & b$lengths == x])/length(b$lengths))))

neg.runs <- unlist(lapply(1:17, function(x)(length(b$lengths[b$values == -1 & b$lengths == x])/length(b$lengths))))

tot.runs <- unlist(lapply(1:17, function(x)(length(b$lengths[b$lengths == x])/length(b$lengths))))

run.table <- cbind(
  "Run Length" = c(1:17),
  "Pos Runs - Count as % of All Runs" = round(pos.runs*100,2),
  "Neg Runs - Count as % of All Runs" = round(neg.runs*100,2),
  "Both Pos & Neg Runs - Count as % of All Runs" = round(tot.runs*100,2)
  )

library(knitr)
kable(run.table)

# - find actual number of observations (removing 0 values)
n <- length(a[a != 0])

# - expected runs from random walk
exp.runs <- n/2

# - actual runs (removing 0 values)
actual.runs <- length(b$lengths[b$value != 0])

# - sd of runs and critical value
sd.exp.runs <- sqrt(n)/2
critical.value <- 1.64*sd.exp.runs

# - solve for the critical value lower limit
lower.value <- exp.runs - critical.value

> lower.value
[1] 60893.66
> actual.runs
[1] 63653

#<---------------- Test #1: Random Entry/Random Exit for Actual Stock Data -------------------->
mc.random.exit.skew <- replicate(100000, sum(fn.coin.flip(p.mean.log = 0.01), na.rm = T))
summary(mc.random.exit.skew)
      Min.    1st Qu.     Median       Mean    3rd Qu.       Max.
-0.7214696 -0.1073840 -0.0003747 -0.0004084  0.1074432  0.7032947

mc.trail.stop.coin.flip.skew.2 <- replicate(100000, fn.trail.stop.coin.flip(p.mean.log = .01, positive.percent.stop = .1))
summary(mc.trail.stop.coin.flip.skew.2)
      Min.    1st Qu.     Median       Mean    3rd Qu.       Max.
-0.1132679 -0.0552802 -0.0035014  0.0003675  0.0467034  0.3221581
#<---------------- Test #1: Random Entry/Random Exit for Actual Stock Data -------------------->