# Bibliotecas
library(dplyr)
library(ggmap)
library(ggplot2)
library(gridExtra)
library(maps)
library(mapdata)
library(reshape2)
library(stringr)
library(treemap)

# Conjunto de dados
loan_data <- read.csv("./datasets/loan.csv", sep = ",")

dim(loan_data)

# Distribui��o das vari�veis de empr�stimo
par(mfrow = c(1, 3))

hist(loan_data$loan_amnt,
     main = "Loan Amount Requested by Borrower",
     xlab = "Amount",
     ylab = "Probabilities",
     col = "red",
     prob = TRUE)

lines(density(loan_data$loan_amnt, adjust=2), col="black", lty = "dotted")

hist(loan_data$funded_amnt,
     main = "Amount Funded by Lending Club",
     xlab = "Amount",
     ylab = "Probabilities",
     col = "orange",
     prob = TRUE)

lines(density(loan_data$funded_amnt, adjust=2), col="black", lty = "dotted")

hist(loan_data$funded_amnt_inv,
     main = "Total Committed by Investors",
     xlab = "Amount",
     ylab = "Probabilities",
     col = "blue",
     prob = TRUE)

lines(density(loan_data$funded_amnt_inv, adjust=2), col="black", lty = "dotted")

# Gr�ficos univariados e an�lise
loan_data$issue_month <- factor(str_sub(loan_data$issue_d, 1, 3))

loan_data$issue_year <- strtoi(str_sub(loan_data$issue_d, start = -4))

amount_volume <- loan_data %>%
        select(loan_amnt, issue_month, issue_year) %>%
        group_by(issue_year, issue_month) %>%
        arrange(issue_year, issue_month) %>%
        summarise(count = n(), sum_amount = sum(loan_amnt)) %>%
        mutate(date = paste(issue_month, issue_year, sep = "-"))

ggplot(data = amount_volume, aes(x = reorder(date, issue_year), y = sum_amount, group = 1)) +
        geom_line(color = "red") +
        scale_x_discrete(breaks = c("Jul-2007", "Jul-2008", "Jul-2009",
                                    "Jul-2010", "Jul-2011", "Jul-2012",
                                    "Jul-2013", "Jul-2014", "Jul-2015"),
                         labels = c("2007", "2008", "2009", "2010", "2011", "2012", "2013", "2014", "2015")) +
        labs(title = "Loan Amount", x = "Issue Date", y = "Amount ($)")

ggplot(data = amount_volume, aes(x = reorder(date, issue_year), y = count, group = 1)) +
        geom_smooth(method = lm, formula = y ~ splines::bs(x, 3), se = FALSE, color = "black", size = 1.2) +
        geom_line(color = "blue") +
        scale_x_discrete(breaks = c("Jul-2007", "Jul-2008", "Jul-2009",
                                    "Jul-2010", "Jul-2011", "Jul-2012",
                                    "Jul-2013", "Jul-2014", "Jul-2015"),
                         labels = c("2007", "2008", "2009", "2010", "2011", "2012", "2013", "2014", "2015")) +
        labs(title = "Loan Volume", x = "Issue Date", y = "Volume")

gtvy <- loan_data %>% select(issue_year, grade, term)
gtvy <- gtvy[complete.cases(gtvy),]
gtvy <- gtvy[!gtvy$issue_year == 2016,]

graphic_gtvy <- ggplot(gtvy, aes(x = issue_year))
graphic_gtvy + geom_bar(aes(fill = grade)) +
        facet_grid( ~ term) +
        labs(title = 'Loan Volume by Year', x = 'Issued Year', y = 'Volume') +
        theme_bw()

ggplot(data = amount_volume, aes(x = reorder(date, issue_year), y = (sum_amount / count), group = 1)) +
        geom_smooth(method = lm, formula = y ~ splines::bs(x, 3), se = FALSE, color = "red", linetype = "dashed", size = 1.2) +
        geom_point(color = "black") +
        scale_x_discrete(breaks = c("Jul-2007", "Jul-2008", "Jul-2009",
                                    "Jul-2010", "Jul-2011", "Jul-2012",
                                    "Jul-2013", "Jul-2014", "Jul-2015"),
                         labels = c("2007", "2008", "2009", "2010", "2011", "2012", "2013", "2014", "2015")) +
        labs(title = "Average Loan", x = "Issue Date", y = "Average Amount ($)")

ggplot(data = loan_data, aes(x = loan_data$grade)) +
        geom_bar(fill = "black") +
        labs(title = "Loans' Grades", x = "Grade", y = "Frequency")

ggplot(loan_data, aes(x = loan_data$sub_grade)) +
        geom_bar(fill = "black") +
        labs(title = "Loan's Subgrades", x = "Subgrade", y = "Frequency")

ggplot(data = loan_data, aes(x = loan_status)) +
        geom_bar(fill = "black") +
        scale_x_discrete(limits = c("Current", "Fully Paid", "Charged Off",
                                    "Late (31-120 days)", "Issued", "In Grace Period",
                                    "Late (16-30 days)", "Default"),
                         labels = c("Current", "Fully\nPaid", "Charged\nOff",
                                    "Late\n(31-120 days)", "Issued", "In Grace\nPeriod",
                                    "Late\n(16-30 days)", "Default")) +
        labs(title = "Loan's Status", x = "Status", y = "Count")

ggplot(data = loan_data, aes(x = loan_status)) +
        geom_bar(aes(y = (..count..) / sum(..count..)), fill = "black") +
        geom_text(aes(y = ((..count..)/sum(..count..)), label = scales::percent((..count..)/sum(..count..))), stat = "count", vjust = -0.25) +
        scale_x_discrete(limits = c("Current", "Fully Paid", "Charged Off",
                                    "Late (31-120 days)", "Issued", "In Grace Period",
                                    "Late (16-30 days)", "Default"),
                         labels = c("Current", "Fully\nPaid", "Charged\nOff",
                                    "Late\n(31-120 days)", "Issued", "In Grace\nPeriod",
                                    "Late\n(16-30 days)", "Default")) +
        labs(title = "Loan's Status", x = "Status", y = "Percentage") +
        scale_y_continuous(labels = scales::percent)

summary(loan_data$loan_status)

ggplot(data = loan_data, aes(int_rate)) +
        geom_histogram(fill = "black") +
        geom_vline(xintercept = median(loan_data$int_rate), color = "red") +
        geom_vline(xintercept = mean(loan_data$int_rate), color = "yellow") +
        labs(x = "Interest Rate (%)", y = "Volume")

summary(loan_data$int_rate)

intRateAboveTwenty = sum(loan_data$int_rate >= 20.0)
percentageInTotal = intRateAboveTwenty / sum(loan_data$int_rate >= 0.0)

cat("Loans with the Interest Rate above or equal 20.0%:", intRateAboveTwenty, "\n")

cat("Percentage in total (%):", percentageInTotal * 100, "\n")

ggplot(data = loan_data, aes(loan_amnt)) +
        geom_histogram(fill = "black") +
        labs(x = "Loan Amount ($)", y = "Volume") +
        geom_vline(xintercept = median(loan_data$loan_amnt), color = "red") +
        geom_vline(xintercept = mean(loan_data$loan_amnt), color = "yellow")

summary(loan_data$loan_amnt)

cat("Median:", median(loan_data$loan_amnt), "\n")
cat("Mean:", mean(loan_data$loan_amnt), "\n")

# Gr�ficos multivariados e an�lise
states <- map_data("state")
state_pop <- read.csv("./datasets/census-state-populations.csv")
colnames(state_pop) <- c("addr_state", "population")
state_data <- loan_data %>%
        select(addr_state, loan_amnt) %>%
        group_by(addr_state) %>%
        summarise(count = n(), total = sum(loan_amnt))
state_data$addr_state <- state.name[match(state_data$addr_state, state.abb)]
state_data <- merge(state_data, state_pop, by = "addr_state")
state_data$addr_state <- tolower(state_data$addr_state)
colnames(state_data) <- c("region", "count", "total", "population")
state_data <- inner_join(states, state_data, by = "region")

ditch_the_axes <- theme(
        axis.text = element_blank(),
        axis.line = element_blank(),
        axis.ticks = element_blank(),
        panel.border = element_blank(),
        panel.grid = element_blank(),
        axis.title = element_blank())

ggplot(data = state_data) +
        geom_polygon(aes(x = long, y = lat, fill = total, group = group),
                     color = "white") +
        coord_fixed(1.3) +
        theme_bw() +
        ditch_the_axes +

        scale_fill_distiller("Total Loans ($)", trans = "reverse")

ggplot(data = state_data) +
        geom_polygon(aes(x = long, y = lat, fill = total / population, group = group),
                     color = "white") +
        coord_fixed(1.3) +
        theme_bw() +
        ditch_the_axes +
        scale_fill_distiller("Total Loans � Population", trans = "reverse")

ggplot(data = loan_data, aes(x = term, y = int_rate)) +
        geom_boxplot() +
        labs(x = "Term", y = "Interest Rate (%)")

ggplot(data = loan_data, aes(x = term, y = loan_amnt)) +
        geom_boxplot() +
        labs(x = "Term", y = "Loan Amount ($)")

purposes <- loan_data %>% select(purpose, loan_amnt) %>% na.omit() %>% group_by(purpose) %>%
        dplyr::summarise(volume = n(), average_amnt = sum(as.numeric(loan_amnt), rm.na = TRUE)/ n())

purposes <- purposes[!purposes$purpose == '',]
treemap(purposes,
        index = 'purpose',
        vSize = 'volume',
        vColor = 'average_amnt',
        range = c(6000, 16000),
        type = 'manual',
        palette = c('yellow', 'green', 'orange', 'orange2', 'firebrick'),
        algorithm = 'pivotSize',
        sortID = '-size',
        title = 'Purposes of Loans',
        title.legend = 'Average Amount',
        fontsize.labels = 12,
        fontsize.legend = 10,
        fontface.labels = 1,
        position.legend = 'bottom',
        force.print.labels = T,
        border.col = 'white')

tig <- select(loan_data, int_rate, sub_grade, grade, term, issue_year)

graphic_tig <- ggplot(tig, aes(grade, int_rate))
graphic_tig +
        geom_boxplot(outlier.size = 0.5, color = 'black') +
        facet_grid(term ~ issue_year) +
        labs(title = 'Interest Rate Distribution by Grade', x = 'Grade', y = 'Interest Rate (%)') +
        theme_bw()

tisub <- mutate(tig, term = ifelse(term == ' 36 months', '36', '60'))

tisub_abcd <- filter(tisub, grade %in% c('A', 'B', 'C', 'D'))
tisub_efg <- filter(tisub, grade %in% c('E', 'F', 'G'))

graphic_tisub_abcd <- ggplot(tisub_abcd, aes(term, int_rate))

graphic_tisub_abcd +
        geom_boxplot(outlier.size = 0.5, aes(color = term)) +
        guides(color = F) +
        facet_wrap(~ sub_grade, nrow = 1) +
        labs(title = 'Interest Rate Distribution by Term of Grades A, B, C and D', x = 'Term', y = 'Interest Rate (%)') +
        theme_bw()

graphic_tisub_efg <- ggplot(tisub_efg, aes(term, int_rate))

graphic_tisub_efg +
        geom_boxplot(outlier.size = 0.5, aes(color = term)) +
        guides(color = F) +
        facet_wrap(~ sub_grade, nrow = 1) +
        labs(title = 'Interest Rate Distribution by Term of Grades E, F and G', x = 'Term', y = 'Interest Rate (%)') +
        theme_bw()

loan_status_count <- loan_data %>%
        select(loan_status) %>%
        group_by(loan_status) %>%
        summarise(count = n()) %>%
        mutate(percentage = count / sum(count))

ggplot(data = loan_status_count, aes(x = loan_status, y = count)) +
        geom_bar(stat="identity", aes(fill = loan_status)) +
        scale_x_discrete(limits = c("Current", "Fully Paid", "Charged Off",
                                    "Late (31-120 days)", "Issued", "In Grace Period",
                                    "Late (16-30 days)", "Default"),
                         labels = c("Current", "Fully\nPaid", "Charged\nOff",
                                    "Late\n(31-120 days)", "Issued", "In Grace\nPeriod",
                                    "Late\n(16-30 days)", "Default")) +
        scale_y_continuous(breaks = seq(0, 600000, 100000),
                           labels = c("0", "100000", "200000", "300000", "400000", "500000", "600000")) +
        labs(title = "Loan's Status", x = "Status", y = "Number of Loans") +
        guides(fill = FALSE) +
        geom_text(aes(label = scales::percent(percentage), y = percentage ), stat= "identity", vjust = -0.75)

ggplot(data = loan_data, aes(x = term, y = int_rate)) +
        geom_boxplot() +
        labs(title = "Term's Interest Rate", x = "Term", y = "Interest Rate (%)")

purposes <- loan_data %>% select(purpose, loan_amnt) %>% na.omit() %>% group_by(purpose) %>%
        dplyr::summarise(volume = n(), average_amnt = sum(as.numeric(loan_amnt), rm.na = TRUE)/ n())

purposes <- purposes[!purposes$purpose == '',]
treemap(purposes,
        index = 'purpose',
        vSize = 'volume',
        vColor = 'average_amnt',
        range = c(6000, 16000),
        type = 'manual',
        palette = c('yellow', 'green', 'orange', 'orange2', 'firebrick'),
        algorithm = 'pivotSize',
        sortID = '-size',
        title = 'Purposes of Loans',
        title.legend = 'Average Amount',
        fontsize.labels = 12,
        fontsize.legend = 10,
        fontface.labels = 1,
        position.legend = 'bottom',
        force.print.labels = T,
        border.col = 'white')


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

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


REBOL [
	Title:    "Red/System IEEE-754 library"
	Author:   "Nenad Rakocevic"
	File: 	  %IEEE-754.r
	Tabs:	 4
	Rights:   "Copyright (C) 2000-2011-2015 Eric Long,-2018 Red Foundation. All rights reserved."
	License:  "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt"
	Comment:  {
		64-bit split/to-native functions from http://www.nwlink.com/~ecotope1/reb/decimal.r
		Added 32-bit support, compacted a bit the existing code.
	}
]

IEEE-754: context [

	specials: [
		single [
			#INF	#{7F800000}
			#INF-	#{FF800000}
			#NaN	#{7F200000}							;-- Quiet NaN
			#0-		#{80000000}
		]
		double [
			#INF	#{7FF0000000000000}
			#INF-	#{FFF0000000000000}
			#NaN	#{7FF8000000000000}					;-- Quiet NaN
			#0-		#{8000000000000000}
		]
	]

	split64: func [
		"Returns block containing three components of double floating point value"
		n [number!] /local sign exp frac
	][
		sign: either negative? n [n: negate n 1][0]

		either zero? n [exp: frac: 0][
			either zero? 1024 - exp: to integer! log-2 n [
				exp: 1023
			][
				if positive? (2 ** exp) - n [exp: exp - 1]
			]
			frac: n / (2 ** exp)

			either positive? exp: exp + 1023 [
				frac: frac - 1         					;-- drop the first bit for normals
				frac: frac * (2 ** 52) 					;-- make the remaining fraction an
														;-- "integer"
			][
				frac: 2 ** (51 + exp) * frac  			;-- denormals
				exp: 0
			]
		]
		reduce [sign exp frac]
	]

	to-binary64: func [
		"convert a numerical value into native binary format"
		n  [number! issue!]
		/rev     "reverse binary output"
		/local out sign exp frac
	][
		either issue? n [
			out: copy select specials/double next n
		][
			set [sign exp frac] split64 n
			out: make binary! 8
			loop 6 [
				insert out to char! byte: frac // 256
				frac: frac - byte / 256
			]
			insert out to char! exp // 16 * 16  + frac
			insert out to char! exp / 16 + (128 * sign)
		]
		either rev [copy reverse out][out]
	]

	split32: func [
		"Returns block containing three components of single floating point value"
		n [number!] /local sign exp frac
	][
		sign: either negative? n [n: negate n 1][0]

		either zero? n [exp: frac: 0][
			either zero? 128 - exp: to integer! log-2 n [
				exp: 127
			][
				if positive? (2 ** exp) - n [exp: exp - 1]
			]
			frac: n / (2 ** exp)

			either positive? exp: exp + 127 [
				frac: frac - 1
				frac: frac * (2 ** 23) 					;-- make the remaining fraction an "integer"
			][
				frac: 2 ** (22 + exp) * frac  			;-- denormals
				exp: 0
			]
			frac: to integer! frac + .5
		]
		reduce [sign exp frac]
	]

	to-binary32: func [
		"convert a numerical value into native binary format"
		n  [number! issue!]
		/rev     "reverse binary output"
		/local out sign exp frac
	][
		either issue? n [
			out: copy select specials/single next n
		][
			set [sign exp frac] split32 n
			out: make binary! 4
			loop 2 [
				insert out to char! byte: frac // 256
				frac: frac - byte / 256
			]
			insert out to char! exp * 128 // 256  + frac
			insert out to char! exp / 2 + (128 * sign)
		]
		either rev [copy reverse out][out]
	]
]


# Chapter 9 Lab: Support Vector Machines

# Support Vector Classifier

set.seed(1)
x=matrix(rnorm(20*2), ncol=2)
y=c(rep(-1,10), rep(1,10))
x[y==1,]=x[y==1,] + 1
plot(x, col=(3-y))
dat=data.frame(x=x, y=as.factor(y))
library(e1071)
svmfit=svm(y~., data=dat, kernel="linear", cost=10,scale=FALSE)
plot(svmfit, dat)
svmfit$index
summary(svmfit)
svmfit=svm(y~., data=dat, kernel="linear", cost=0.1,scale=FALSE)
plot(svmfit, dat)
svmfit$index
set.seed(1)
tune.out=tune(svm,y~.,data=dat,kernel="linear",ranges=list(cost=c(0.001, 0.01, 0.1, 1,5,10,100)))
summary(tune.out)
bestmod=tune.out$best.model
summary(bestmod)
xtest=matrix(rnorm(20*2), ncol=2)
ytest=sample(c(-1,1), 20, rep=TRUE)
xtest[ytest==1,]=xtest[ytest==1,] + 1
testdat=data.frame(x=xtest, y=as.factor(ytest))
ypred=predict(bestmod,testdat)
table(predict=ypred, truth=testdat$y)
svmfit=svm(y~., data=dat, kernel="linear", cost=.01,scale=FALSE)
ypred=predict(svmfit,testdat)
table(predict=ypred, truth=testdat$y)
x[y==1,]=x[y==1,]+0.5
plot(x, col=(y+5)/2, pch=19)
dat=data.frame(x=x,y=as.factor(y))
svmfit=svm(y~., data=dat, kernel="linear", cost=1e5)
summary(svmfit)
plot(svmfit, dat)
svmfit=svm(y~., data=dat, kernel="linear", cost=1)
summary(svmfit)
plot(svmfit,dat)

# Support Vector Machine

set.seed(1)
x=matrix(rnorm(200*2), ncol=2)
x[1:100,]=x[1:100,]+2
x[101:150,]=x[101:150,]-2
y=c(rep(1,150),rep(2,50))
dat=data.frame(x=x,y=as.factor(y))
plot(x, col=y)
train=sample(200,100)
svmfit=svm(y~., data=dat[train,], kernel="radial",  gamma=1, cost=1)
plot(svmfit, dat[train,])
summary(svmfit)
svmfit=svm(y~., data=dat[train,], kernel="radial",gamma=1,cost=1e5)
plot(svmfit,dat[train,])
set.seed(1)
tune.out=tune(svm, y~., data=dat[train,], kernel="radial", ranges=list(cost=c(0.1,1,10,100,1000),gamma=c(0.5,1,2,3,4)))
summary(tune.out)
table(true=dat[-train,"y"], pred=predict(tune.out$best.model,newdata=dat[-train,]))

# ROC Curves

library(ROCR)
rocplot=function(pred, truth, ...){
   predob = prediction(pred, truth)
   perf = performance(predob, "tpr", "fpr")
   plot(perf,...)}
svmfit.opt=svm(y~., data=dat[train,], kernel="radial",gamma=2, cost=1,decision.values=T)
fitted=attributes(predict(svmfit.opt,dat[train,],decision.values=TRUE))$decision.values
par(mfrow=c(1,2))
rocplot(fitted,dat[train,"y"],main="Training Data")
svmfit.flex=svm(y~., data=dat[train,], kernel="radial",gamma=50, cost=1, decision.values=T)
fitted=attributes(predict(svmfit.flex,dat[train,],decision.values=T))$decision.values
rocplot(fitted,dat[train,"y"],add=T,col="red")
fitted=attributes(predict(svmfit.opt,dat[-train,],decision.values=T))$decision.values
rocplot(fitted,dat[-train,"y"],main="Test Data")
fitted=attributes(predict(svmfit.flex,dat[-train,],decision.values=T))$decision.values
rocplot(fitted,dat[-train,"y"],add=T,col="red")

# SVM with Multiple Classes

set.seed(1)
x=rbind(x, matrix(rnorm(50*2), ncol=2))
y=c(y, rep(0,50))
x[y==0,2]=x[y==0,2]+2
dat=data.frame(x=x, y=as.factor(y))
par(mfrow=c(1,1))
plot(x,col=(y+1))
svmfit=svm(y~., data=dat, kernel="radial", cost=10, gamma=1)
plot(svmfit, dat)

# Application to Gene Expression Data

library(ISLR)
names(Khan)
dim(Khan$xtrain)
dim(Khan$xtest)
length(Khan$ytrain)
length(Khan$ytest)
table(Khan$ytrain)
table(Khan$ytest)
dat=data.frame(x=Khan$xtrain, y=as.factor(Khan$ytrain))
out=svm(y~., data=dat, kernel="linear",cost=10)
summary(out)
table(out$fitted, dat$y)
dat.te=data.frame(x=Khan$xtest, y=as.factor(Khan$ytest))
pred.te=predict(out, newdata=dat.te)
table(pred.te, dat.te$y)


# Assignment 1 is an exploratory data analysis with the
# objective to determine plausible reasons why the original
# study was not successful in predicting age based on physical
# characteristics. This assignment is the precursor for the
# following assignment.

# Load libraries
require(tidyverse)
require(Hmisc)
require(plyr)
require(readr)
require(gridExtra)
require(knitr)

# Preliminaries: Load data
# This data file is derived from a study of abalones in Tasmania.

# (a) Reading the files into R
mydata <- read_csv("C:/Users/sgran/Desktop/DataAnalysis1/abalones.csv")

# (b) Check "mydata" using str().
# (1036 observations of 8 variables should be noted.)
str(mydata)

# Clean names and factors
mydata$SEX <- as.factor(mydata$SEX)
mydata$SEX <- revalue(mydata$SEX, c("F"="Female", "I"="Infant", "M"="Male"))
mydata$CLASS <- as.factor(mydata$CLASS)

# (c) Calculate two new variables: VOLUME and RATIO
mydata <- mydata %>%
  mutate(VOLUME = LENGTH * DIAM * HEIGHT,
         RATIO = SHUCK / VOLUME)
attach(mydata)

# Create subsets by gender
mydata_f <- mydata[mydata$SEX == "Female", ]
mydata_i <- mydata[mydata$SEX == "Infant", ]
mydata_m <- mydata[mydata$SEX == "Male", ]

# (1)(a) Use summary() to obtain and present descriptive statistics
# from mydata
summary(mydata)

ggplot(mydata, aes(x = RINGS, y = SEX, color = CLASS)) +
  geom_jitter(size = 2) +
  theme_bw()

ggplot(mydata, aes(x = LENGTH, y = DIAM, color = SEX, size = HEIGHT)) +
  geom_point(shape = 1) +
  theme_bw()

ggplot(mydata, aes(x = RATIO, y = VOLUME, color = SEX)) +
  geom_point() +
  geom_hline(yintercept = median(mydata_f$VOLUME), color = "indianred") +
  geom_hline(yintercept = median(mydata_i$VOLUME), color = "forestgreen") +
  geom_hline(yintercept = median(mydata_m$VOLUME), color = "steelblue") +
  facet_grid(.~SEX) +
  theme_bw()

# (1)(b) Generate a table of counts using SEX and CLASS.
sex_class_tbl <- mydata %>%
  select(SEX, CLASS) %>%
  table() %>%
  addmargins()
print(sex_class_tbl)

# Also, present a barplot of these data.
sex_class_tbl[(1:3), (1:5)] %>%
  barplot(main = "Comparison of Age and Class Proportions",
          ylab = "Frequency",
          ylim = c(0, 160),
          xlab = "Gender Distribution by Class",
          beside = TRUE,
          col = c('indianred', 'forestgreen', 'midnightblue'),
          legend.text = c('Female', 'Infant', 'Male'),
          args.legend = list(x = 'topright'))

mydata %>%
  ggplot(aes(CLASS, color=SEX)) +
  geom_freqpoly(aes(group=SEX), stat="count", size=2) +
  theme_bw()

# (1)(c) Select a simple random sample of 200 observations from
# "mydata" and identify this sample as "work".
set.seed(123)

work <- mydata %>%
  sample_n(size = 200, replace = FALSE)
plot(work[, 2:6], col = "steelblue")

# (2)(a) Use "mydata" to plot WHOLE versus VOLUME.
work2 <- mydata %>%
  select(WHOLE, VOLUME)
plot(x = work2$VOLUME, xlab = 'Volume',
     y = work2$WHOLE, ylab = 'Whole weight',
     main = 'Whole weight, as a function of Volume',
     col = 'goldenrod')

# (2)(b) Use "mydata" to plot SHUCK versus WHOLE
work3 <- mydata %>%
  select(SHUCK, WHOLE) %>%
  mutate(RATIO = SHUCK / WHOLE) %>%
  arrange(desc(RATIO))

ratio <- max(work3["RATIO"])

plot(x = work3$WHOLE, xlab = "Whole weight",
     y = work3$SHUCK, ylab = "Shuck weight",
     main = 'Shuck weight, as a function of Whole weight',
     col = 'forestgreen')
abline(a = 0, b = ratio, lty = 2)

# (3)(a) Use "mydata" to present a display showing histograms,
# boxplots and Q-Q plots of RATIO differentiated by sex.

par(mfrow = c(3, 3))

hist(mydata_f$RATIO, xlim = c(0, 0.35), ylim = c(0, 120),
     main = "Female Ratio", xlab ="", col = "indianred")

hist(mydata_i$RATIO, xlim = c(0, 0.35), ylim = c(0, 120),
     main = "Infant Ratio", xlab ="", col = "lightgreen")

hist(mydata_m$RATIO, xlim = c(0, 0.35), ylim = c(0, 120),
     main = "Male Ratio", xlab ="", col = "steelblue")

f_out <- boxplot(mydata_f$RATIO, ylim = c(0, 0.35),
                 main = "Female Ratio", col = "indianred")$out

i_out <- boxplot(mydata_i$RATIO, ylim = c(0, 0.35),
                 main = "Infant Ratio", col = "lightgreen")$out

m_out <- boxplot(mydata_m$RATIO, ylim = c(0, 0.35),
                 main = "Male Ratio", col = "steelblue")$out

qqnorm(mydata_f$RATIO, ylim = c(0, 0.35), main = "Female Ratio",
       col = "indianred")
qqline(mydata_f$RATIO)

qqnorm(mydata_i$RATIO, ylim = c(0, 0.35), main = "Infant Ratio",
       col = "lightgreen")
qqline(mydata_i$RATIO)

qqnorm(mydata_m$RATIO, ylim = c(0, 0.35), main = "Male Ratio",
       col = "steelblue")
qqline(mydata_m$RATIO)

par(mfrow = c(1, 1))

ggplot(mydata, aes(x = RATIO, y = SEX, color = SEX)) +
  geom_jitter() +
  theme_bw()

# (3)(b) Using the boxplots, identify and describe the abalones that are outliers.
out <- rbind(mydata_f %>% filter(RATIO %in% f_out),
             mydata_i %>% filter(RATIO %in% i_out),
             mydata_m %>% filter(RATIO %in% m_out))

out[c("SEX", "CLASS", "VOLUME", "RATIO")]

ggplot(out, aes(x = RATIO, y = CLASS, color = SEX)) +
  geom_jitter(size = 3) +
  theme_bw()

# (4)(a) With "mydata," display two separate sets of side-by-side
# boxplots for VOLUME and WHOLE differentiated by CLASS

grid.arrange(
  ggplot(mydata, aes(x = factor(CLASS), y = VOLUME, group = CLASS)) +
    geom_boxplot(aes(color = CLASS)) +
    labs(x = "Class", y = "Volume") +
    theme_bw(),
  ggplot(mydata, aes(x = factor(CLASS), y = WHOLE, group = CLASS)) +
    geom_boxplot(aes(color = CLASS)) +
    labs(x = "Class", y = "Whole") +
    theme_bw(),
  ggplot(mydata, aes(x = RINGS, y = VOLUME, color = SEX)) +
    geom_point() +
    labs(x = "Rings", y = "Volume") +
    theme_bw(),
  ggplot(mydata, aes(x = RINGS, y = WHOLE, color = SEX)) +
    geom_point() +
    labs(x = "Rings", y = "Whole") +
    theme_bw(),
  nrow = 2, top = "Compare Volume and Whole Weight"
)

# (5)(a) Use aggregate() with "mydata" to compute the mean values of
# VOLUME, SHUCK and RATIO for each combination of SEX and CLASS.
myagg <- aggregate(mydata[c('VOLUME', 'SHUCK', 'RATIO')],
                   by = list(SEX, CLASS), FUN = 'mean')

matrix(myagg$VOLUME, nrow = 3,
       dimnames = list(unique(myagg$Group.1),
                       unique(myagg$Group.2)))

matrix(myagg$SHUCK, nrow = 3,
       dimnames = list(unique(myagg$Group.1),
                              unique(myagg$Group.2)))

matrix(myagg$RATIO, nrow = 3,
       dimnames = list(unique(myagg$Group.1),
                       unique(myagg$Group.2)))

# (5)(b) Present three graphs
out <- aggregate(RATIO ~ SEX + CLASS, data = mydata, FUN = 'mean')
ggplot(data = out, aes(x = CLASS, y = RATIO, group = SEX, color = SEX)) +
  geom_line() +
  theme_bw() +
  geom_point(size = 4) +
  ggtitle("Plot of Mean RATIO versus CLASS for Three Sexes")

out <- aggregate(VOLUME ~ SEX + CLASS, data = mydata, FUN = 'mean')
ggplot(data = out, aes(x = CLASS, y = VOLUME, group = SEX, color = SEX)) +
  geom_line() +
  theme_bw() +
  geom_point(size = 4) +
  ggtitle("Plot of Mean VOLUME versus CLASS for Three Sexes")

out <- aggregate(SHUCK ~ SEX + CLASS, data = mydata, FUN = 'mean')
ggplot(data = out, aes(x = CLASS, y = SHUCK, group = SEX, color = SEX)) +
  geom_line() +
  theme_bw() +
  geom_point(size = 4) +
  ggtitle("Plot of Mean SHUCK versus CLASS for Three Sexes")


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 08

rm(list = ls())

observed <- c(38, 55, 54, 41, 62)

(k <- length(observed))
# 5

(n <- sum(observed))
# 250

(expected <- n * 1 / k )
# 50

(Q <- sum((observed - expected) ^ 2 / expected))
# 8.2

(pvalue <- 1 - pchisq(Q, df = k - 1))
# 0.0845206445489823


## Get a sequence of 6 random sorted numbers
# sort(sample(1:60,6))

base_test = c(1,2,3,4,5,6) # sort(sample(1:60,6))
base_test
v2 = c(1,2,4,5,6,7) # sort(sample(1:60,6))
v2

## combinations are stored in columns. Each matrix has 15 columns with 4 numbers
matrix_1 = combn(base_test, 4)
matrix_2 = combn(v2, 4)

## Convert each metrix to a list of list
combinations_1 = c(split(matrix_1, col(matrix_1)))
combinations_2 = c(split(matrix_2, col(matrix_2)))

result = intersect(combinations_1,combinations_2)
result
length(result)

# Reduce(intersect, list(a,b,c))


# Prediction efficiency in two ways
prediction_accuracy <- function(predicted, empirical) {
    # Parameters:
    #   predicted   matrix of predicted interactions
    #   empirical   matrix of empirical interactions

    #   Output      vector of a, b, c, d, and TSS
    #       a       number of links predicted (1) and observed (1)
    #       b       number predicted (1) but not observed (0)
    #       c       number predicted absent (0) but observed (1)
    #       d       number of predicted absent (0) and observed absent (0)
    #       TSS     TSS = (ad-bc)/[(a+c)(b+d)]
    #                   "[...] quantifies the proportion of prediction success relative to false predictions
    #                   and returns values ranging between 1 (perfect predictions) and 1 (inverted forecast)
    #                   (Allouche, Tsoar & Kadmon 2006)." Gravel et al. 2013
    #       ScoreY1 Fraction of 1 correctly predicted a / (a + c)
    #       ScoreY0 Fraction of 0 correctly predicted d / (b + d)
    #       FSS     FSS = ScoreY1 + ScoreY0 / sum(a, b, c, d)^2

    if(identical(colnames(predicted), colnames(empirical)) == FALSE ||
        identical(rownames(predicted), rownames(empirical)) == FALSE ||
        identical(dim(predicted), dim(empirical)) == FALSE) {
            print('matrices need to have same dimensions and row and column names')
            break
    }

    efficiency <- numeric(8)
    names(efficiency) <- c('a','b','c','d','TSS','ScoreY1','ScoreY0','FSS')

    for(i in 1:ncol(predicted)){
        for(j in 1:nrow(predicted)) {
            if(predicted[i,j] == 1 && empirical[i,j] == 1) {
                efficiency[1] <- efficiency[1] + 1
            } else if(predicted[i,j] == 1 && empirical[i,j] == 0) {
                efficiency[2] <- efficiency[2] + 1
            } else if(predicted[i,j] == 0 && empirical[i,j] == 1) {
                efficiency[3] <- efficiency[3] + 1
            } else if(predicted[i,j] == 0 && empirical[i,j] == 0) {
                efficiency[4] <- efficiency[4] + 1
            }
        }
    }

    a <- efficiency[1]
    b <- efficiency[2]
    c <- efficiency[3]
    d <- efficiency[4]

    efficiency[5] <- ((a * d) - (b * c)) / ((a + c) * (b + d))  # TSS
    efficiency[6] <- a / (a + c)                                # ScoreY1
    efficiency[7] <- d / (b + d)                                # ScoreY0
    efficiency[8] <- (a + d) / sum(a, b, c, d)    # FSS

    return(efficiency)
}


def.par <- par(no.readonly = TRUE) # layout前の環境を保存
lns <- function(x) lcm(x * par("csi") * 2.54)
layout(rbind(c(1,1,1,1),
             c(2,3,4,5),
             c(6,7,8,9)),
       height = c(1,1,1),
       width = c(1,1,1,1))
## layout の確認
## layout.show(3)
## box("outer", lty = "dotted")
f <- function(x) {
  if (all(Im(z <- zapsmall(x))==0)) as.numeric(z) else x
}
par(mar=c(2,1,2,.5))
an <- function(n){ifelse(n!=0,
                         (1i)^(n+1)/(2*pi*n)*((-1)^n-1),
                         1/2)}
n <- -8:8
plot(n,sapply(n,an),type="h",col="blue",lwd=2,xlab="",ylab="",xaxt="n",yaxt="n")
axis(1,at=n,labels=n)
x <- seq(-1.5,1.5,length=20*6+1)
y <- rep(an(0),length=length(x))
for(k in 1:8){
  plot(x,y,type="l",lwd=2,col="orange",xlab="",ylab="",xaxt="n",yaxt="n",
       main=paste0("|n|<",k))
  axis(1,at=-1:1,labels=c(expression(-pi),0,expression(pi)))
  y <- f(y + an(k)*exp(pi*k*1i*x) + an(-k)*exp(-pi*k*1i*x))
}
par(def.par)


rm(list=ls())

file.or.pval  <- commandArgs()[4]
file.L95.U95  <- commandArgs()[5]
t <- read.table(file=file.or.pval,header=T,stringsAsFactor=F,colClasses="numeric")
q = qchisq(t$P, df=1, ncp=0, lower.tail=FALSE, log.p=FALSE)
# returns string w/o leading and trailing whitespace
#L95 = format( gsub("^\\s+", "", t$OR**(1-1.96/sqrt(q))), digits=4, scientific=FALSE)
#U95 = format( gsub("^\\s+", "", t$OR**(1+1.96/sqrt(q))), digits=4, scientific=FALSE)
L95 = format( t$OR**(1-1.96/sqrt(q)), digits=4, scientific=FALSE)
U95 = format( t$OR**(1+1.96/sqrt(q)), digits=4, scientific=FALSE)
#L95 = format( gsub("[[:blank:]]", "", t$OR**(1-1.96/sqrt(q)), fixed=TRUE), digits=4, scientific=FALSE)
#U95 = format( gsub("[[:blank:]]", "", t$OR**(1+1.96/sqrt(q)), fixed=TRUE), digits=4, scientific=FALSE)
#L95 = format( gsub("\\s+$", "", L95_tmp), digits=4, scientific=FALSE)
#U95 = format( gsub("\\s+$", "", U95_tmp), digits=4, scientific=FALSE)
####trimws(L95, "l")()
####trimws(U95, "l")()
head(L95)
head(U95)
####L95 = math.exp(math.log(oddsratio) - 1.96*se)
####U95 = math.exp(math.log(oddsratio) + 1.96*se)
results <- cbind(as.matrix(L95), as.matrix(U95))
colnames(results) <- c("L95", "U95")
write.table(results, file=file.L95.U95, quote=F, sep="\t", row.names=F, col.names=T, append=F)


#@reemuru
#data mining
#k-means clustering

#intialize library for kmeans clustering and elbow method
library(NbClust)
library(factoextra)

#set the working directory
setwd("./k-means/")

#reproducible output
set.seed(1234)

#load sensor readings file with headers in the first row
sensors<-read.csv(file = "sensor_readings_24.csv", header = TRUE, sep = ",")

#summary stats
summary(sensors)

#dataset structure
str(sensors)

#Class variable distribution
plot(sensors$Class)

#create correlation matrix with heatmap
cormat <- round(cor(sensors[1:24]),2)
head(cormat)
library(reshape2)
melted_cormat <- melt(cormat)
head(melted_cormat)
library(ggplot2)
ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill=value)) +
  geom_tile()

#copy the dataset
sensors2<-sensors
#remove the class variable
sensors2$Class<-NULL

#scale the dataset
sensors2[1:24]<-scale(sensors2[1:24])

#store the model with 4 clusters
kc<-kmeans(sensors2, 4, iter.max = 40)

#print the model output
print(kc)

#between sum of squares
kc$betweenss

#compare the model with the classes
table(sensors$Class, kc$cluster)

#model variations
#K-means method with k=2
kc<-kmeans(sensors2, 2, iter.max = 20)
kc
kc$betweenss
#K-means method with k=3
kc<-kmeans(sensors2, 3, iter.max = 30)
kc
kc$betweenss
#K-means method with k=5
kc<-kmeans(sensors2, 5, iter.max = 50)
kc
kc$betweenss

#minimum within cluster sum of squares with 3 clusters

#model refinement
#the object is only moving clockwise therefore slight turns should be removed
#subset for no slight turns and re-factor
modsensors <- subset(sensors, sensors$Class!="Slight-Left-Turn")
modsensors <- subset(modsensors, modsensors$Class!="Slight-Right-Turn")
modsensors$Class<-factor(modsensors$Class)

#verify dataset structure
str(modsensors)

#copy the modified dataset
modsensors2<-modsensors

#remove class from copied dataset
modsensors2$Class<-NULL

#scale the dataset
modsensors2[1:24]<-scale(modsensors2[1:24])

#K-means method with k= 2
kc<-kmeans(modsensors2, 2, iter.max = 20)

#cross-tabulation
table(modsensors$Class, kc$cluster)

#dataviz
#verify cluster selection with the elbow method, within groups sum of squares
fviz_nbclust(modsensors2, kmeans, method = "wss") +
  geom_vline(xintercept = 2, linetype = 2)+
  labs(subtitle = "Elbow method")

clusplot(modsensors2, kc$cluster, color=TRUE, shade=TRUE, labels=2, lines=0)

#higher dimensional plot
#dataviz
library(rgl)
newkc <- data.frame(modsensors2, K=kc$cluster)#Include the number of cluster in the data set
pcdf <- princomp(modsensors2,cor=T,score=T)
summary(pcdf)#Compute the validity of each component/dimension
plot3d(pcdf$scores, col=newkc$K)#Create a 3D plot


=begin
[((<index-ja|URL:index-ja.html>))]
= AlgebraicEqation
((*(代数方程式のためのユーティリティー)*))

方程式と体のためのファイル

== ファイル名:
* ((|algebraic-equation.rb|))

== モジュールメソッド:

--- minimal_polynomial(element, poly1[, poly2[, poly3...]])
    (({poly1, poly2, poly3...})) を法とした、((|element|)) の最小多項式
    を求めます。

    例: ルート2 + ルート3 + ルート5 の最小多項式を求める。
      PQ = MPolynomial(Rational)
      a, b, c = PQ.vars("abc")
      p AlgebraicEquation.minimal_polynomial(a + b + c, a**2-2, b**2-3, c**2-5)

      #=> x^8 - 40x^6 + 352x^4 - 960x^2 + 576

--- symmetric_product

=end


#' Function to calculate carry
#'
#' @param price - price of bond
#' @param yield - yield of bond
#' @param numberOfDays - number of days to calculate carry
#' @param financingRate - financing rate
#' @param maturity -maturity of bond
#' @param name - name of bond
#'
#' @return returns list of couponIncome, financingCharge, carry, name, maturity
#'
#' @examples
#'
#'
#'
carry <- function(price,yield,numberOfDays,financingRate,maturity,name){
  couponIncome <-yield*numberOfDays/365

  financingCharge <- price*financingRate * numberOfDays/365
  ret <- list()
  ret$couponIncome <- couponIncome
  ret$financingCharge <- financingCharge

  ret$carry <- couponIncome - financingCharge
  ret$name <- name
  ret$maturity <- maturity
  return(ret)
}


g <- read.csv('/home/max/Documents/github/Fun/AI/coursera/PublicHeatlh/r_scripts/dataset.csv', sep=',', header=TRUE)

head(g)

g$fruit_veg = g$fruit + g$veg
g$five_a_day = ifelse(g$fruit_veg >= 5, 1, 0)

# Conduct chi2 test
chisq.test(x=g$fruit_veg, y=g$cancer)
chisq.test(x=g$five_a_day, y=g$cancer)

# Conduct independent-samples t-test
## x predicts y and where both x and y are continuous
t.test(g$age, g$bmi)
## same, but x is binary
t.test(g$bmi~g$cancer)

t.test(g$age~g$cancer)
t.test(g$age~g$cancer, var.equal=TRUE)   # two-sided t-test

# compare the proportion who are overweight by cancer
g$is_overweight = ifelse(g$bmi > 25, 1, 0)
chisq.test(x=g$is_overweight, y=g$cancer)
table(g$is_overweight)
chisq.test(x = g$is_overweight, y = g$cancer)


return(switch(kernel,
                      gaussian = 1/(2*sqrt(pi)),
                      rectangular = sqrt(3)/6,
                      triangular = sqrt(6)/9,
                      epanechnikov = 3/(5*sqrt(5)),
                      biweight = 5*sqrt(7)/49,
                      cosine = 3/4*sqrt(1/3 - 2/pi^2),
                      optcosine = sqrt(1-8/pi^2)*pi^2/16
                      ))


source("Gaussian_data.r")
###
get_c_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  ans <- lgamma(alpha_n)-lgamma(alpha0)
  ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
  ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
  return(ans)
}
#
c_a0 <- function(x) {
  get_c_a0_gaussian(
    y0 = y_0,
    n0 = N_0,
    alpha0 = alpha_0,
    beta0 = beta_0,
    m0 = mu_0,
    k0 = kappa_0,
    a_0 = x
  )
}
c_a0 <- Vectorize(c_a0)

constant_data <- read.csv("../data/Gaussian_logCA0.csv")

library(mgcv)
fit.gam <- gam(lc_a0 ~ s(a0), data = constant_data)

K <- 1E4
pred_a0s <- seq(0, max(constant_data$a0), length.out = K)

a0_grid <- data.frame(a0 = pred_a0s, lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))

curve(c_a0, 0, 5, xlab = expression(a[0]), ylab = expression(log(c(a[0]))), lwd = 3, lty = 2)
points(a0_grid$a0, a0_grid$lc_pred)

get_approx_lc <- function(x, grid){
  y <- grid[, 1]
  i <- which.min(abs(x-y))
  if(i != 1){
    x1 <- grid[i, 1]
    x2 <- grid[i + 1, 1]
    y1 <- grid[i, 2]
    y2 <- grid[i + 1, 2]
    ans <- y1 + (y2-y1) * (x-x1)/(x2-x1)
  }else{
    ans <- grid[i, 2]
  }
  return(ans)
}
app_f <- function(x) get_approx_lc(x, grid = a0_grid)
app_f <- Vectorize(app_f)

curve(c_a0, 0, 5, xlab = expression(a[0]), ylab = expression(log(c(a[0]))), lwd = 3, lty = 2)
curve(app_f, 0, 5, lwd = 3, col = 2, add = TRUE)
lines(a0_grid$a0, a0_grid$lc_pred, lwd = 2, lty = 2, col = 3)

curve(c_a0, 0, 5, xlab = expression(a[0]),
      ylab = expression(log(c(a[0]))), xlim = c(0, 1), ylim = c(-600, 10) , lwd = 3, lty = 2)
curve(app_f, 0, 5, lwd = 3, col = 2, add = TRUE)
lines(a0_grid$a0, a0_grid$lc_pred, lwd = 2, lty = 2, col = 3)


## ----load packages----------------------------------------------------------
library(tidyverse)
library(ggthemes)
library(maps)
library(scales)
library(RColorBrewer)
library(gridExtra)
library(viridis)
library(nullabor)
library(splitstackshape)
library(plotly)
library(forecast)
library(readxl)
# remotes::install_github("wmurphyrd/fiftystater")
library(fiftystater)

## ----lineup 1, fig.height=8, fig.width=8---------------------------------
# Make a lineup of the mtcars data, 20 plots, one is the data,
# and the others are null plots. Which one is different?
set.seed(20190709)
ggplot(lineup(null_permute('mpg'), mtcars), aes(mpg, wt)) +
  geom_point() +
  facet_wrap(~ .sample)

## ----lineup 2, fig.height=6----------------------------------------------
# Assessing model fit, using a lineup of residual plots, 19 are nulls, and one is the
# residual plot. Is there structure in the residual plot that identifies it as having
# less than random variation. Nulls are generated by `rotating` residuals after model fit.
tips <- read_csv("http://www.ggobi.org/book/data/tips.csv")
x <- lm(tip ~ totbill, data = tips)
tips.reg <- data.frame(tips, .resid = residuals(x), .fitted = fitted(x))
ggplot(lineup(null_lm(tip ~ totbill, method = 'rotate'), tips.reg)) +
  geom_point(aes(x = totbill, y = .resid)) +
  facet_wrap(~ .sample)

## ----lineup 3, fig.height=6----------------------------------------------
# Assessing time series model fit using simulation to produce null plots.
data(aud)
l <- lineup(null_ts("rate", auto.arima), aud)
ggplot(l, aes(x=date, y=rate)) + geom_line() +
  facet_wrap(~.sample, scales="free_y") +
  theme(axis.text = element_blank()) +
  xlab("") + ylab("")

## ----lets talk TB, echo=FALSE--------------------------------------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, new_sp_m04:new_sp_fu) %>%
  gather(stuff, count, new_sp_m04:new_sp_fu) %>%
  separate(stuff, c("stuff1", "stuff2", "sexage")) %>%
  select(-stuff1, -stuff2) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  select(-sexage)

# Filter years between 1997 and 2012 due to missings
tb_us <- tb %>%
  filter(country == "United States of America") %>%
  filter(!(age %in% c("04", "014", "514", "u"))) %>%
  filter(year > 1996, year < 2013)

## ----fig.width=10, fig.height=3------------------------------------------
ggplot(tb_us, aes(x = year, y = count, fill = sex)) +
  geom_bar(stat = "identity", position = "fill") +
  facet_grid(~ age) +
  scale_fill_brewer(palette="Dark2")

## ----generate a lineup of three binomial simulations, echo=TRUE----------
# Make expanded rows of categorical variables
# matching the counts of aggregated data.
# sex needs to be converted to 0, 1 to
# match binomial simulations
tb_us_long <- expandRows(tb_us, "count")
tb_us_long <- tb_us_long %>%
  mutate(sex01 = ifelse(sex=="m", 0, 1)) %>%
  select(-sex)

# Generate a lineup of three, randomly choose one of the
# positions to place true data.
# Compute counts again.
pos = sample(1:3, 1)
l <- lineup(null_dist(var="sex01", dist="binom",
                      list(size=1, p=0.5)),
            true=tb_us_long, n=3, pos=pos)
l <- l %>%
  group_by(.sample, year, age) %>%
  dplyr::count(sex01)

## ----plot the lineup, fig.height=8, fig.width=10-------------------------
ggplot(l, aes(x = year, y = n, fill = factor(sex01))) +
  geom_bar(stat = "identity", position = "fill") +
  facet_grid(.sample ~ age) +
  scale_fill_brewer(palette="Dark2") +
  theme(legend.position="none")

## ----a more complicated null, echo=TRUE----------------------------------
# Compute proportion across all data
tbl <- tb_us %>% group_by(sex) %>% summarise(count=sum(count))
tbl
p <- tbl$count[1]/sum(tbl$count)

pos = sample(1:3, 1)
l <- lineup(null_dist(var="sex01", dist="binom",
                      list(size=1, p=p)),
            true=tb_us_long, n=3, pos=pos)
l <- l %>%
  group_by(.sample, year, age) %>%
  dplyr::count(sex01)

## ----fig.height=8, fig.width=10------------------------------------------
ggplot(l, aes(x = year, y = n, fill = factor(sex01))) +
  geom_bar(stat = "identity", position = "fill") +
  facet_grid(.sample ~ age) +
  scale_fill_brewer(palette="Dark2") +
  theme(legend.position="none")

## ----compute pvalue------------------------------------------------------
pvisual(4, 17, m=20)

## ----emake a choropleth map, cho=TRUE------------------------------------
world_map <- map_data("world")
usa <- map_data("usa")
tb_names <- tb %>%
  mutate(region=recode(country,
                       "United States of America"="USA",
                       "United Kingdom"="UK",
                       "Russian Federation"="Russia"))

## ----compute the linear trend in counts, echo=TRUE-----------------------
# This is sophisticated code to compute the linear trend in counts
# for each country.
tb_names_inc <- tb_names %>%
  group_by(region) %>%
  nest() %>%
  mutate(
    model = purrr::map(data, ~ lm(count ~ year, data = .))
) %>%
  unnest(model %>% purrr::map(broom::tidy)) %>%
  select(region, term, estimate) %>%
  spread(term, estimate)

## ----one way to make the map is use geom_map, echo=TRUE------------------
ggplot(tb_names_inc, aes(map_id = region)) +
    geom_map(aes(fill=year), map = world_map, color="grey70", size=0.3, na.rm=TRUE) +
    expand_limits(x = world_map$long, y = world_map$lat) +
    theme_few() +
    scale_fill_viridis("trend") +
    theme(legend.position = "bottom",
         axis.ticks = element_blank(),
         axis.title = element_blank(),
         axis.text =  element_blank()) +
    guides(fill = guide_colorbar(barwidth = 15, barheight = .5))

## ----aother approach is to join the polygon data, echo=TRUE--------------
tb_map <- left_join(world_map, tb_names_inc, by="region")
ggplot(tb_map) +
  geom_polygon(aes(x=long, y=lat, group=group, fill=year)) +
      theme_few() +
    scale_fill_viridis("trend", na.value = "grey70") +
    theme(legend.position = "bottom",
         axis.ticks = element_blank(),
         axis.title = element_blank(),
         axis.text =  element_blank()) +
    guides(fill = guide_colorbar(barwidth = 15, barheight = .5))

## ----make a map lineup, fig.height=6, fig.width=10-----------------------
# Read xlsx spreadsheet on cancer incidence in USA, for a more
# complex lneup example, a lineup of maps
incd <- read_xlsx(here::here("data/IncRate.xlsx"), skip=6, sheet=2) %>%
  filter(!(State %in% c("All U.S. combined", "Kansas"))) %>%
  select(State, `Melanoma of the skin / Both sexes combined`) %>%
  rename(Incidence=`Melanoma of the skin / Both sexes combined`) %>%
  mutate(Incidence = as.numeric(substr(Incidence, 1, 3)))

# State names need to coincide between data sets
incd <- incd %>% mutate(State = tolower(State))

# Choose a position
pos <- 6

# Make lineup of cancenr incidence
incd_lineup <- lineup(null_permute('Incidence'), incd, n=12, pos=pos)

# Join cancer incidence data to map polygons
incd_map <- left_join(fifty_states, filter(incd_lineup, .sample==1),
                      by=c("id"="State"))
for (i in 2:12) {
  x <- left_join(fifty_states, filter(incd_lineup, .sample==i),
                      by=c("id"="State"))
  incd_map <- bind_rows(incd_map, x)
}
# Remove Kansas - it was missing the cancer data
incd_map <- incd_map %>% filter(!is.na(.sample))

# Plot the maps as a lineup
ggplot(incd_map) +
  geom_polygon(aes(x=long, y=lat, fill = Incidence, group=group)) +
  expand_limits(x = incd_map$long, y = incd_map$lat) +
  #coord_map() +
  scale_x_continuous(breaks = NULL) +
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  scale_fill_distiller(palette="YlGn", type="seq", direction=1) +
  theme(legend.position = "none",
        panel.background = element_blank()) +
  facet_wrap(~.sample, ncol=4)


#  James Rekow

firstDeriv = function(y, deltax = 1){

  #  ARGS:  y - numeric vector of y-values
  #         deltax - mesh width of corresponding x-values
  #
  #  RETURNS:  a numeric vector of the same length as y whose elements are the
  #            centered first derivative of y at each interior point, and one-sided
  #            derivatives of y at the endpoints

  N = length(y)
  return((0.5 / deltax) * c(2 * (y[2] - y[1]), (y[3:N] - y[1:(N - 2)]), 2 * (y[N] - y[N - 1])))

} #  end firstDeriv function


x <- c(2, 43, 27, 96, 18)
sort(x)
order(x)
rank(x)
min(x)
which.min(x)
which.max(x)

# Mandi, Amy, Nicole, and Olivia all ran different distances in different time intervals. Their distances (in miles) and times (in minutes) are as follows:

name <- c("Mandi", "Amy", "Nicole", "Olivia")
distance <- c(0.8, 3.1, 2.8, 4.0)
time <- c(10, 30, 40, 50)
timeHour <- time / 60
timeHour
speed <- distance / timeHour
speed


ds_theme_set()

# themes from ggthemes
# theme_economist()    style of the Economist magazine
# theme_fivethirtyeight()    # style of the FiveThirtyEight website

#Putting it all together to assemble the plot

# load libraries
library(tidyverse)
library(ggrepel)
library(ggthemes)
library(dslabs)
data(murders)

# define the intercept
r <- murders %>%
    summarize(rate = sum(total) / sum(population) * 10^6) %>%
    .$rate

# make the plot, combining all elements
murders %>%
    ggplot(aes(population/10^6, total, label = abb)) +
    geom_abline(intercept = log10(r), lty = 2, color = "darkgrey") +
    geom_point(aes(col = region), size = 3) +
    geom_text_repel() +
    scale_x_log10() +
    scale_y_log10() +
    xlab("Population in millions (log scale)") +
    ylab("Total number of murders (log scale)") +
    ggtitle("US Gun Murders in 2010") +
    scale_color_discrete(name = "Region") +
    theme_economist()


#!/usr/bin/env Rscript

# This implementation uses a custom function on a vector rather than a
# loop which is kinda neat, but can be memory consuming.

numslices <- 100000000

args <- commandArgs(trailingOnly=TRUE)

if (length(args)>0) {
  numslices <- strtoi(args)
}

cat("Calculating PI using:\n")
cat(" ", numslices, "slices\n")
cat("  1 process\n")

start <- Sys.time()

# Define our function
y <- function(x) {
  1/(1+(x^2))
}

# Sum our function applied to the slices.
mypi <- (4 * sum(y((1.0/numslices) * (0.5:numslices-0.5))))/numslices

stop <- Sys.time()
elapsed <- stop - start

cat("Obtained value of PI:", mypi, "\n")
cat("Time taken:", elapsed, "seconds\n")


#!/usr/bin/env Rscript

# Author  : Bhishan Poudel
# Date    : Feb 11, 2016
# Program :

# Setting working directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

# Start device driver to save output
#postscript( file = "milkyway.eps", height = 12, width = 8)

# Read magnitudes for Milky Way and M 31 globular clusters
GC1 <- read.table("GlobClus_MWG.dat",
                  header = T)
GC2 <- read.table("GlobClus_M31.dat",
                  header = T)
K1 <- GC1[, 2]
K2 <- GC2[, 2]
cat("summary of K1 \n")
print(summary(K1))
cat("\n summary of K1 \n")
print(summary(K2))

# Three estimates of the distance modulus to M 31
DMmn <- mean(K2) - mean(K1)
print(DMmn)
sigDMmn <- sqrt(var(K1) / length(K1) + var(K2) / length(K2))
print(sigDMmn)
DMmed <- median(K2) - median(K1)
print(DMmed)
sigDMmed <-
    sqrt(mad(K1) ^ 2 / length(K1) + mad(K2) ^ 2 / length(K2))
print(sigDMmed)
wilcox.test(K2, K1, conf.int = T)

# e.d.f., quantile and Q-Q plots for globular cluster magnitudes
plot(
    ecdf(K1),
    cex.points = 0,
    verticals = T,
    xlab = "K (mag)",
    ylab = "e.d.f.",
    main = ""
)
plot(
    ecdf(K2 - 24.90),
    cex.points = 0,
    verticals = T,
    add = T
)
text(-7.5, 0.8, lab = "MWG")
text(-10.5, 0.9, lab = "M 31")
par(mfrow = c(1, 3))
qqplot(
    K1,
    K2 - 24.90,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    xlab = "MWG",
    ylab = "M31 - 24.90",
    main = ""
)
qqnorm(
    K1,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    main = ""
)
qqline(K1, lty = 2, lwd = 1.5)
text(-2.5, -6, pos = 4, cex = 1.3,  'MWG normal QQ plot')
qqnorm(
    K2 - 24.90,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    main = ""
)
qqline(K2 - 24.90, lty = 2, lwd = 1.5)
text(-3, -7.5, pos = 4, cex = 1.3,  'M31 normal QQ plot')
par(mfrow = c(1, 1))

# Plot e.d.f. with confidence bands
#install.packages('sfsmisc')
library('sfsmisc')
ecdf.ksCI(K1, ci.col = 'black')

# Nonparametric tests for normality
#install.packages('nortest')
library(nortest)
print(cvm.test(K1))
print(cvm.test(K2))
print(ad.test(K1))
print(ad.test(K2))

# Turn off device driver
#dev.off()


posterior <- function(point=1, alpha=1, beta=1){
    m <- 27175
    n <- 1

    log(alpha+n) +
    (alpha+n)*log(beta + n*m) -
    (alpha+n+1)*log(beta + n*m + point)
}

x <- seq(1,10000, by=0.1)
y <- exp(posterior(point=x, alpha=1, beta=1))
plot(x, y, pch=19, cex=0.2, type='b')
title(paste('alpha:', alpha, 'beta:', beta))

posterior(point=1613, alpha=7000, beta=1)

alpha <- 10
beta <- 1
nsamples <- 100
x <- rep(NA,nsamples)
for(i in 1:nsamples){
  lam <- rgamma(1, shape=alpha, rate=beta)
  x[i] <- rexp(1, rate=lam)
}


closest.pairs <- function(x, y=NULL, ...){
      # takes two-column object(x,y-values), or creates such an object from x and y values
       if(!is.null(y))  x <- cbind(x, y)

       distances <- dist(x)
        min.dist <- min(distances)
          point.pair <- combn(1:nrow(x), 2)[, which.min(distances)]

     cat("The closest pair is:\n\t",
      sprintf("Point 1: %.3f, %.3f \n\tPoint 2: %.3f, %.3f \n\tDistance: %.3f.\n",
        x[point.pair[1],1], x[point.pair[1],2],
          x[point.pair[2],1], x[point.pair[2],2],
            min.dist),
            sep=""   )
     c( x1=x[point.pair[1],1],y1=x[point.pair[1],2],
        x2=x[point.pair[2],1],y2=x[point.pair[2],2],
        distance=min.dist)
     }


#' Global empirical relation method for paleoslope inversion
#'
#' \code{trampush_slp} calculates the slope of an ancient river, provided you know the flow depth and the grain size of the bed material. Implemented from Trampush et al. (2014)
#' @param Dbed The median grain size of bedload sediments in meters.
#' @param H The paleoflow depth in meters.
#' @return Returns a vector \code{S}, the dimensionless slope.
#' @export

## Inversion for Paleoslope based on Trampush 2014
## Eric Barefoot
## April 2018

# This function provides functionality for computing paleoslope based on a method described by Sheila Trampush in a 2014 paper.

# describe inputs and other stuff needed

# Trampush et al. use a Bayesian approach for paleohydraulic inversion, meaning that the coefficients that they describe for the empirical fit each have a distribution. They provide percentiles for the distribution in their Table 1.
# In this way, we can ascribe ranges for the coefficients, and potentially provide a range of estimates of paleoslope accordingly. I think this means we can have confidence intervals, but I'm not sure about that.
# Initially, the user is allowed to select a percentile, and that percentile will be chosen for each parameter.

# In the future, users should be allowed to vary each parameter individually.

trampush_slp = function(Dbed, H, perc = 50) {

  a0sp = smooth.spline(y = c(-2.14, -2.10, -2.08, -2.05, -2.01), x = c(2.5,25,50,75,97.5))
  a1sp = smooth.spline(y = c(0.222, 0.244, 0.254, 0.266, 0.287), x = c(2.5,25,50,75,97.5))
  a2sp = smooth.spline(y = c(-1.18, -1.12, -1.09, -1.06, -1.00), x = c(2.5,25,50,75,97.5))

  logS = predict(a0sp, x = perc)$y + predict(a1sp, perc)$y * log10(Dbed) + predict(a2sp, perc)$y * log10(H)

  return(S = 10^logS)

}


library(tidyverse)

nobs <- 256^3
table_id_only <- tibble(id = 1:nobs)
table_rgb_full <- mutate(table_id_only,
       red = (id-1)%/%(256^2),
       green = ((id-1)%%(256^2))%/%256,
       blue = ((id-1)%%(256^2))%%256,
       # For the formula below, see https://www.w3.org/TR/WCAG20-TECHS/G17.html
       red_srgb = red / 255,
       green_srgb = green / 255,
       blue_srgb = blue / 255,
       r = ifelse(red_srgb > 0.03928,
                      ((red_srgb + 0.055)/1.055)^2.4,
                      red_srgb / 12.92),
       g = ifelse(green_srgb > 0.03928,
                        ((green_srgb + 0.055)/1.055)^2.4,
                        green_srgb / 12.92),
       b = ifelse(blue_srgb > 0.03928,
                       ((blue_srgb + 0.055)/1.055)^2.4,
                       blue_srgb / 12.92),
       luminance = 0.2126*r + 0.7152*g + 0.0722*b,
       contrast_ratio = round((luminance + 0.05)/0.05, digits = 2),
       # https://en.wikipedia.org/wiki/Hue#Defining_hue_in_terms_of_RGB
       max = ifelse( red >= green & red >= blue, red,
               ifelse( green > red & green >= blue, green, blue)
             ),
       min = ifelse( red <= green & red <= blue, red,
               ifelse( green < red & green <= blue, green, blue)
             ),
       chroma = max - min,
       hue = round(ifelse( chroma == 0, NA,
               ifelse( max == red & min == blue, 60*(green-min)/chroma,
                 ifelse( max == green & min == blue, 60*(2-(red-min)/chroma),
                   ifelse( max == green & min == red, 60*(2+(blue-min)/chroma),
                     ifelse( max == blue & min == red, 60*(4-(green-min)/chroma),
                       ifelse( max == blue & min == green, 60*(4+(red-min)/chroma), 60*(6-(blue-min)/chroma))
                     )
                   )
                 )
               )
             ))
)

table_rgb <- select(table_rgb_full, id, red, green, blue, contrast_ratio, hue, chroma)
write_csv(table_rgb, "rgbColorCodes.csv")


#' Get summary statistics in simple linear regression
#'
#' @param y Vector of dependent variable
#' @param x Vector of independent variable
#'
#' @export
#' @return List
fast_assoc <- function(y, x)
{
	index <- is.finite(y) & is.finite(x)
	n <- sum(index)
	y <- y[index]
	x <- x[index]
	vx <- var(x)
	bhat <- stats::cov(y, x) / vx
	ahat <- mean(y) - bhat * mean(x)
	# fitted <- ahat + x * bhat
	# residuals <- y - fitted
	# SSR <- sum((residuals - mean(residuals))^2)
	# SSF <- sum((fitted - mean(fitted))^2)

	rsq <- (bhat * vx)^2 / (vx * var(y))
	fval <- rsq * (n-2) / (1-rsq)
	tval <- sqrt(fval)
	se <- abs(bhat / tval)

	# Fval <- (SSF) / (SSR/(n-2))
	# pval <- pf(Fval, 1, n-2, lowe=F)
	p <- stats::pf(fval, 1, n-2, lower.tail=FALSE)
	return(list(
		ahat=ahat, bhat=bhat, se=se, fval=fval, pval=p, n=n
	))
}

logistic_assoc <- function(y, x)
{
	mod <- summary(glm(y ~ x, family="binomial"))$coefficients
	n <- sum(is.finite(y) & is.finite(x))

	return(list(
		ahat=mod[1,1],
		bhat=mod[2,1],
		se=mod[2,2],
		fval=mod[2,3]^2,
		pval=mod[2,4],
		n=n
	))
}

#' Perform association of many SNPs against phenotype
#'
#' @param y Vector of phenotypes
#' @param g Matrix of genotypes
#' @param logistic Use logistic regression (much slower)? Default=FALSE
#'
#' @export
#' @return Data frame
gwas <- function(y, g, logistic=FALSE)
{
	out <- matrix(0, ncol(g), 6)
	if(logistic)
	{
		stopifnot(all(y %in% c(0,1)))
		for(i in 1:ncol(g))
		{
			o <- logistic_assoc(y, g[,i])
			out[i, ] <- unlist(o)
		}
	} else {
		for(i in 1:ncol(g))
		{
			o <- fast_assoc(y, g[,i])
			out[i, ] <- unlist(o)
		}
	}

	out <- dplyr::as_tibble(out, .name_repair="minimal")
	names(out) <- names(o)
	out$snp <- 1:ncol(g)
	return(out)
}

#' Get effs for two traits and make dat format
#'
#' @param x Vector of exposure phenotype
#' @param y Vector of outcome phenotype
#' @param g Matrix of genotypes
#' @param xname xname
#' @param yname yname
#'
#' @export
#' @return Data frame
get_effs <- function(x, y, g, xname="X", yname="Y")
{
	gwasx <- gwas(x, g)
	gwasy <- gwas(y, g)
	return(merge_exp_out(gwasx, gwasy, xname, yname))
}


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 07

rm(list = ls())

observed <- c(20, 30, 20, 25, 15, 10)

(k <- length(observed))
# 6

(n <- sum(observed))
# 120

(expected <- n * 1 / k )
# 20

(Q <- sum((observed - expected) ^ 2 / expected))
# 12.5

(pvalue <- 1 - pchisq(Q, df = k - 1))
# 0.0285431233261675


##### Chapter 7: Neural Networks and Support Vector Machines -------------------

##### Part 1: Neural Networks -------------------
## Example: Modeling the Strength of Concrete  ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
concrete <- read.csv("concrete.csv")
str(concrete)

# custom normalization function
normalize <- function(x) {
  return((x - min(x)) / (max(x) - min(x)))
}

# apply normalization to entire data frame
concrete_norm <- as.data.frame(lapply(concrete, normalize))

# confirm that the range is now between zero and one
summary(concrete_norm$strength)

# compared to the original minimum and maximum
summary(concrete$strength)

# create training and test data
concrete_train <- concrete_norm[1:773, ]
concrete_test <- concrete_norm[774:1030, ]

## Step 3: Training a model on the data ----
# train the neuralnet model
library(neuralnet)

# simple ANN with only a single hidden neuron
concrete_model <- neuralnet(formula = strength ~ cement + slag +
                              ash + water + superplastic +
                              coarseagg + fineagg + age,
                              data = concrete_train)

# visualize the network topology
plot(concrete_model)

## Step 4: Evaluating model performance ----
# obtain model results
model_results <- compute(concrete_model, concrete_test[1:8])
# obtain predicted strength values
predicted_strength <- model_results$net.result
# examine the correlation between predicted and actual values
cor(predicted_strength, concrete_test$strength)

## Step 5: Improving model performance ----
# a more complex neural network topology with 5 hidden neurons
concrete_model2 <- neuralnet(strength ~ cement + slag +
                               ash + water + superplastic +
                               coarseagg + fineagg + age,
                               data = concrete_train, hidden = 5)

# plot the network
plot(concrete_model2)

# evaluate the results as we did before
model_results2 <- compute(concrete_model2, concrete_test[1:8])
predicted_strength2 <- model_results2$net.result
cor(predicted_strength2, concrete_test$strength)

##### Part 2: Support Vector Machines -------------------
## Example: Optical Character Recognition ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
letters <- read.csv("letterdata.csv")
str(letters)

# divide into training and test data
letters_train <- letters[1:16000, ]
letters_test  <- letters[16001:20000, ]

## Step 3: Training a model on the data ----
# begin by training a simple linear SVM
library(kernlab)
letter_classifier <- ksvm(letter ~ ., data = letters_train,
                          kernel = "vanilladot")

# look at basic information about the model
letter_classifier

## Step 4: Evaluating model performance ----
# predictions on testing dataset
letter_predictions <- predict(letter_classifier, letters_test)

head(letter_predictions)

table(letter_predictions, letters_test$letter)

# look only at agreement vs. non-agreement
# construct a vector of TRUE/FALSE indicating correct/incorrect predictions
agreement <- letter_predictions == letters_test$letter
table(agreement)
prop.table(table(agreement))

## Step 5: Improving model performance ----
letter_classifier_rbf <- ksvm(letter ~ ., data = letters_train, kernel = "rbfdot")
letter_predictions_rbf <- predict(letter_classifier_rbf, letters_test)

agreement_rbf <- letter_predictions_rbf == letters_test$letter
table(agreement_rbf)
prop.table(table(agreement_rbf))


library("boot")
data("urine")

head(urine)

dat = na.omit(urine) # get rid f missing values
dim(dat)

# avoid colinearity if we want to determin which variables relate to response
# colinearity phenomenon in which one predictor variable in a multiple regression model can be linearly predicted from the others with a substantial degree of accuracy.
# must deal wih colinearity, as makes it difficult for statistical inference
# could use linear model that favours values near 0 therefore weak signal on these features
# colinearity only good for predictions
pairs(dat)

# minus mean and div by sd, standardise
X = scale(dat[,-1], center=TRUE, scale=TRUE) # variable selection (only for non categorical)
colMeans(X) # means all close to zero
apply(X, 2, sd) # sd are all 1

# speacial prior to favour coefficients near zero, dobule exponential

library("rjags")

# likelyhood observations come from bermuli distribution inputing a probability
# linear model gives logit of p
# non informative normal prior
# prior for beta terms double expinential prior, with variance 1 (favours values closer to 0)
mod1_string = " model {
    for (i in 1:length(y)) {
        y[i] ~ dbern(p[i])
        logit(p[i]) = int + b[1]*gravity[i] + b[2]*ph[i] + b[3]*osmo[i] + b[4]*cond[i] + b[5]*urea[i] + b[6]*calc[i]
    }
    int ~ dnorm(0.0, 1.0/25.0)
    for (j in 1:6) {
        b[j] ~ ddexp(0.0, sqrt(2.0)) # has variance 1.0
    }
} "

set.seed(92)
head(X)

data_jags = list(y=dat$r, gravity=X[,"gravity"], ph=X[,"ph"], osmo=X[,"osmo"], cond=X[,"cond"], urea=X[,"urea"], calc=X[,"calc"])

params = c("int", "b")

mod1 = jags.model(textConnection(mod1_string), data=data_jags, n.chains=3)
update(mod1, 1e3)

mod1_sim = coda.samples(model=mod1,
                        variable.names=params,
                        n.iter=5e3)
mod1_csim = as.mcmc(do.call(rbind, mod1_sim))

## convergence diagnostics
plot(mod1_sim, ask=TRUE)

gelman.diag(mod1_sim)
autocorr.diag(mod1_sim)
autocorr.plot(mod1_sim)
effectiveSize(mod1_sim)

## calculate DIC
dic1 = dic.samples(mod1, n.iter=1e3)

par(mfrow=c(3,2))
densplot(mod1_csim[,1:6], xlim=c(-3.0,3.0)) # plot posterior distributions of coefficents looking for coefficents that differ from zero, these are strong predictors
colnames(X)

# kept only strong predictors and switched coefficent prior to non informative prior

mod2_string = " model {
    for (i in 1:length(y)) {
        y[i] ~ dbern(p[i])
        logit(p[i]) = int + b[1]*gravity[i] + b[2]*cond[i] + b[3]*calc[i]
    }
    int ~ dnorm(0.0, 1.0/25.0)
    for (j in 1:3) {
        b[j] ~ dnorm(0.0, 1.0/25.0) # has variance 1.0
    }
} "

mod2 = jags.model(textConnection(mod2_string), data=data_jags, n.chains=3)

update(mod2, 1e3)

mod2_sim = coda.samples(model=mod2,
                        variable.names=params,
                        n.iter=5e3)
mod2_csim = as.mcmc(do.call(rbind, mod2_sim))

plot(mod2_sim, ask=TRUE)

gelman.diag(mod2_sim)
autocorr.diag(mod2_sim)
autocorr.plot(mod2_sim)
effectiveSize(mod2_sim)

dic2 = dic.samples(mod2, n.iter=1e3) # do not use dic to choose between priors

summary(mod2_sim)

pm_coef = colMeans(mod2_csim) # as scaled 0 shows average values

1.0 / (1.0 + exp(0.15)) # using posterior mean point estimates

1.0 / (1.0 + exp(0.15 - 1.42*0.0 - -1.36*(-1.0) - 1.88*1.0)) # model was fit to stadardised values. Therefore must sue standardised value to make predictions

pm_Xb = pm_coef["int"] + X[,c(1,4,6)] %*% pm_coef[1:3] # intercept + values of predictors matmul posterior means of coefficients

phat = 1.0 / (1.0 + exp(-pm_Xb))
head(phat)

plot(phat, jitter(dat%r))

tab.05 = table(phat > 0.5, dat$r)
tab.05

sum(diag(tab0.5)) / sum(tab0.5)

tab.03 = table(phat > 0.3, dat$r)
tab.03

sum(diag(tab0.3)) / sum(tab0.3)


# GeneralFunctions.r
#
# Learning about R through writing own functions

# Factorial using recursion

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


# https://www.hackerrank.com/challenges/s10-normal-distribution-1/problem
library("magrittr")
xbar <- 20
stdx <- 2

q1 <- 19.5
q2lower <- 20
q2upper <- 22

a1 <- pnorm(q1, mean = xbar, sd = stdx)
hour20 <- pnorm(q2lower, mean = xbar, sd = stdx)
hour22 <- pnorm(q2upper, mean = xbar, sd = stdx)
a2 <- hour22 - hour20

hour18 <- pnorm(18, mean = xbar, sd = stdx)

sixeight <- hour22 - hour18 #should be about 68% since it's mean +- 1 sd
round(a1, digits = 3) %>% cat("\n")
round(a2, digits = 3) %>% cat()


y1bar=20.04
s1=0.474
n1=10
y2bar=9.99
s2=0.233
n2=16
alpha=0.10
FU=qf(1-alpha/2,15,9)
FL=1/FU
# confidence interval for sigma1/sigma2
left_i=sqrt((s1^2/s2^2)*FL)
right_i=sqrt((s1^2/s2^2)*FU)
print(left_i)
print(right_i)


n <- 4000000 #CLT as n increases mean gets to 0 and sd get's close to 1
x <- rnorm(n, mean=0, sd=1)

mean(x)
sd(x)


# This function samples k indices from 1:n starting with very dense sampling
# (every value) and then getting more and more sparse

#' Sampling for qq plots
#'
#' Returns k indices between 1:max.idx (x) such that -log(x/n) is uniformly
#' distributed. This is useful to reduce overplotting when plotting
#' log-transformed uniform data (such as p-values in a qq plot).
#'
#' @examples
#' n <- 1e5
#' x <- sort(runif(n))
#' thin.idx <- thin(n, 500)
#' par(mfcol=c(1, 2))
#' plot(-log10(1:n/n), -log10(x), ann=FALSE)
#' plot(-log10(thin.idx/n), -log10(x[thin.idx]), ann=FALSE)
#'
#' @export
thin <- function(n, k=2000, max.idx=n) {

  if ( max.idx > n ) max.idx <- n
  if ( max.idx <= k ) return (1:max.idx)

  # Generate k samples between 1 and max.idx
  # such that -log10(x/n) is uniformly distributed
  x <- round(max.idx*exp(-(k:1)/k*log(n)))

  # Ensure each x is unique (Equivalently, diff(x) != 0)
  prev <- 0
  offset <- 0

  for ( i in 1:k ) {
    if ( x[i] + offset == prev ) {
      offset <- offset + 1
    } else if ( x[i] + offset > prev + 1 && offset > 0 ) {
      if ( x[i] > prev ) {
        offset <- 0
      } else {
        offset <- prev + 1 - x[i]
      }
    }
    prev <- x[i] <- x[i] + offset
  }

  x
}

#' Fast QQ plots
#'
#' QQ plots with lots of points can be slow. Since most of the points overlap
#' we don't actually have to plot all of them (and in most cases the output
#' will be identical.)
#'
#' This function will take a value k (default 2000) and sample that many
#' pvalues in an intelligent way such that we don't lose information, then
#' plot the log observed vs expected pvals in a nice way.
#'
#' The optimal value of k depends on the resolution/size of the plot. Very high
#' resolution or very large plots may need larger k to look correct.
#'
#' Additional arguments in ... are passed to plot().
#'
#' @export
fastqq <- function(pvals, k=2000, ...) {

  np <- length(pvals)
  thin.idx <- thin(np, k)

  thin.cint.95 <- qbeta(0.95, thin.idx, np - thin.idx + 1)
  thin.cint.05 <- qbeta(0.05, thin.idx, np - thin.idx + 1)

  thin.logp.exp <- -log10(thin.idx/np)
  thin.logp.obs <- -log10(pvals[order(pvals)[thin.idx]])

  plot(thin.logp.exp, thin.logp.obs, xlab=expression(-log[10](p[expected])), ylab=expression(-log[10](p[observed])), ...)
  abline(0, 1, col='gray', lty=2)
  lines(thin.logp.exp, -log10(thin.cint.95), lty=2, col='red')
  lines(thin.logp.exp, -log10(thin.cint.05), lty=2, col='red')
}

#' @export
thin.qqplot <- function(pvals, thin.idx=NULL, k=2000, ...) {
  warning('This function is deprecated, use fastqq')
  fastqq(pvals, k, ...)
}


garage1=c(17.6,20.2,19.5,11.3,13.0,16.3,15.3,16.2,12.2,14.8,21.3,22.1,16.9,17.6,18.4)
garage2=c(17.3,19.1,18.4,11.5,12.7,15.8,14.9,15.3,12.0,14.2,21.0,21.0,16.1,16.7,17.5)
t.test(garage1,garage2,paired = TRUE)
tvalue=qt(1-0.05,14)
# t>tvale we  reject H0 and conclude that  mean repair estimate for garage I is greater than that for garage II


rm (list=ls())

Fx <- function(x) log(x+2) - sin(x)
F1x <- function(x) (1/(x+2)) + cos(x)
F2x <- function(x) -1/(2 + x)^2 - sin(x)
newton <- function(x0,E) {

	x <- x0
	while (abs(Fx(x)) > E) {

		x <- x - Fx(x)*F1x(x)/(F2x(x)^2 - Fx(x)*F2x(x))
        cat("X=",x,"\t","E=",E,"\n")
	}

}
newton(2,10e-5)


=begin
[((<index|URL:index.html>))]
= algebraic-eqation.rb
((*(Utility for algebraic equations)*))

Library of utiltity for algebraic equations

== File Name:
* ((|algebraic-equation.rb|))

== Methods:

--- Algebra::Polynomial#minimal_decompositon_field([fact0])
    Same as ((<Algebra.PolyDecompose>))(self [,fact0])).

--- Algebra.MinimalPolynomial(element, poly1[, poly2[, poly3...]])
    Returns the mimimal polynmial of ((|element|))
    by the extention (({poly1, poly2, poly3...})).

    Example: Get the mimimal polymial of the square root of 2 + the
    square root of 3 + the square root of 5.
      PQ = MPolynomial(Rational)
      a, b, c = PQ.vars("abc")
      p MinimalPolynomial(a + b + c, a**2-2, b**2-3, c**2-5)
      #=> x^8 - 40x^6 + 352x^4 - 960x^2 + 576

=end


setwd("path to working directory here") ### set working directory

social <- read.csv("social.csv") # load the data
summary(social) ## summary

#### we have four groups to compare (3 treatmnet, 1 control group)
#### would be a lot of work to calculate stuff for each group by hand

#### tapply
tapply(social$primary2006, social$messages, mean) ### applies function to subset by other variable
### calculate the mean of primary2006 (turn out or not) for each group in messages

#### to get the ATE, we compare to control

#### control group turnout
mean(social$primary2006[social$messages == "Control"])

### subtract control group turnout from others

tapply(social$primary2006, social$messages, mean) - mean(social$primary2006[social$messages == "Control"])

### look if groups are similar on other covars
tapply(social$age, social$messages, mean)

## back to slides


library(igraph)
library(ggplot2)

options(max.print=100)

edgeList = read.table("../output/userGraph-1-200000.txt", header=T)

userGraph = graph_from_data_frame(edgeList)

plot(userGraph)

degree_dist_out = degree_distribution(userGraph, mode="out", normalized=FALSE)

degree_dist_out_df = data.frame(degree_dist_out)

plot = ggplot(data=degree_dist_out_df, aes(x=as.numeric(rownames(degree_dist_out_df)), y=degree_dist_out)) + geom_line() + geom_point(shape=4) + xlab("degree") + ylab("probability") + scale_x_log10() + scale_y_log10() + annotation_logticks(sides="bl", scaled=TRUE)

ggsave("degree_dist_out_2.png", plot)

degree_dist_in = degree_distribution(userGraph, mode="in", normalized=FALSE)

degree_dist_in_df = data.frame(degree_dist_in)

plot = ggplot(data=degree_dist_in_df, aes(x=as.numeric(rownames(degree_dist_in_df)), y=degree_dist_in)) + geom_line() + geom_point(shape=4) + xlab("degree") + ylab("probability") + scale_x_log10() + scale_y_log10() + annotation_logticks(sides="bl", scaled=TRUE)

ggsave("degree_dist_in_2.png", plot)

transitivity(userGraph, type="global")

length(component_distribution(userGraph, mode="strong"))

#reciprocity(userGraph, mode="ratio")

#coreness(userGraph, mode="all")


name="Outside-China"
N=scan("data.txt");
T=1:length(N);
mi=1-min(N);
model_r2=0;
founders=0;
vr2=mi:1000;
for(i in mi:1000){
	vr2[i-mi+1]=cor(T,log10(N+i))^2;
	if(vr2[i-mi+1]>model_r2){	model_r2=vr2[i-mi+1];	founders=i;	}
}

png("FoundersEstimation.png",width=768,height=512);
plot(mi:1000,vr2,type='l',xlab="Number of Founders", ylab="R2",	main=paste(name," Founders Estimation"),lwd=2);
abline(v=founders,col=2,lwd=2);
legend("topright", paste("Founders=",founders));
dev.off();

png("Log10Trend.png",width=768,height=512);
plot(T,log10(N+founders),pch=20,xlab="Day",ylab=paste("log10( N+",founders," )"), main=paste(name," Log10 Scaled Trend"),lwd=2,cex=2);
abline(lm(log10(N+founders)~T),col=2,lwd=2);
legend("topleft", paste("R2=",sprintf("%.4f",model_r2)));
dev.off();

t=1:(length(T)+7);
n=1:(length(N)+7);
m=lm(log10(N+founders)~T);
a=m$coefficients[2];
b=m$coefficients[1];

for(i in 1:length(t)){
	if(i<=length(T)){ t[i]=T[i]; }
	else{ t[i]=t[i-1]+1; }
	n[i]=10^(a*t[i]+b)-founders;
}
png("InfectionPrediction.png",width=768,height=512);
plot(t,n,type='l',col=2,xlab="Day",ylab="Number of Diagnoses",main=paste(name," Infection Number Prediction"),lwd=2);
points(T,N,pch=20,lwd=2,cex=2);
legend("topleft", paste("tenfold every ",sprintf("%.1f",1/a), " days"));
dev.off();


library(ggplot2); library(dplyr); library(readr)

# Here we will be trying to use PCA for EDA purposes and try to find out the
# most important features aka the features with the most variation

# read in the data

clean <- read_csv('train_cleaned.csv')
my_data <- subset(clean, select = -c(SalePrice, X1))
colnames(my_data)

# splitting the data into test and train

## 75% of the sample size
smp_size <- floor(0.70 * nrow(my_data))

## set the seed to make your partition reproductible
set.seed(123)
train_ind <- sample(seq_len(nrow(my_data)), size = smp_size)

train <- my_data[train_ind, ]
test <- my_data[-train_ind, ]

prin_comp <- prcomp(my_data, scale. = TRUE)

names(prin_comp)

prin_comp$rotation
dim(prin_comp$x)

biplot(prin_comp, scale = 0)

#proportion of variance explained
std_dev <- prin_comp$sdev
pr_var <- std_dev^2

prop_varex <- pr_var/sum(pr_var)
prop_varex[1:20]

#scree plot
plot(prop_varex, xlab = "Principal Component",
       ylab = "Proportion of Variance Explained",
       type = "b", xlim = c(0,10))

#cumulative scree plot
plot(cumsum(prop_varex), xlab = "Principal Component",
       ylab = "Cumulative Proportion of Variance Explained",
       type = "b", xlim = c(0,90))

# Retain the first 90 Principal componenets
eigenvectors <- prin_comp$rotation[, 1:90]
eigenvectors_df <- as.data.frame(eigenvectors)
eigenvectors_df = cbind(features = rownames(eigenvectors_df), eigenvectors_df)
eigenvectors_df$features = as.character(eigenvectors_df$features)

# getting the most important features

imp_featrs <- vector(length = 90, mode = "character")
for (i in 2:90){
  imp_featrs[i] <- eigenvectors_df %>%
    filter(abs(eigenvectors_df[,i]) == max(abs(eigenvectors_df[,i]))) %>%
    select(features)

}

imp_featrs <- unlist(imp_featrs)


#' rexp
#'
#' Generate from a exponential distribution using a gpu.
#'
#' @details
#' We use the cuRAND uniform generator together with the fact that if
#' \eqn{X \sim U(0, 1)} then \eqn{Y = -\lambda^{-1}\log(X) \sim Exp(\lambda)}.
#'
#' @param n
#' The number of values to generate
#' @param rate
#' Parameter for exponential random variables.
#' @param seed
#' Seed for the random number generation.
#' @param type
#' 'double' or 'float'
#'
#' @references
#' Casella, G. and Berger, R.L., 2002. Statistical inference (Vol. 2). Pacific
#' Grove, CA: Duxbury.
#'
#' Rizzo, M.L., 2007. Statistical computing with R. Chapman and Hall/CRC.
#'
#' @useDynLib curand R_curand_rexp
#' @export
rexp = function(n, rate=1, seed=getseed(), type="double")
{
  type = match.arg(tolower(type), c("double", "float"))
  type = ifelse(type == "double", TYPE_DOUBLE, TYPE_FLOAT)

  if (n < 0)
    stop("invalid arguments")
  else if (n == 0)
  {
    if (type == TYPE_DOUBLE)
      return(numeric(0))
    else
      return(float(0))
  }

  n1 = floor(sqrt(n))
  n2 = n - n1*n1

  if (rate < 0 || is.badval(rate))
  {
    warning("NAs produced")
    ret = setnan(n1, n2, type)
  }
  else
    ret = .Call(R_curand_rexp, as.integer(n1), as.integer(n2), as.double(rate), as.integer(seed), type)

  if (type == TYPE_DOUBLE)
    ret
  else
    float32(ret)
}


# Data sources:
#1. US Energy data
#

# Bug fixes
# Complementary log-log - work in progress
# binomialCloglogR = matrix(glm.fit(binomialX, binomialY, family = binomial("cloglog"))$coefficients)
# binomialCloglogCpp = protoSimpleGLM(binomialX, binomialY, "cloglog", "Binomial", FALSE)

# This is an example of where probit fails
# xR = matrix(glm.fit(binomialX, binomialY, family = binomial("probit"))$coefficients)
# xCpp = protoSimpleGLM(binomialX, binomialY, "probit", "Binomial", TRUE)

require(data.table)

setGeneric("%+%", def = function(e1, e2) standardGeneric("%+%"))
setMethod("%+%", signature = c("character", "character"), definition = function(e1, e2) paste0(e1, e2))

path = "/home/chib/code/GLMPrototype/"
Rcpp::sourceCpp(path %+% "cpp/glm.cpp")

# Error functions
absoluteError = function(x1, x2) sqrt(sum((x1 - x2)^2))
relativeError = function(x1, x2) absoluteError(x1, x2)/norm(x1)

# Load the datasets

# Read energy data for testing
energyData = fread(path %+% "data/modelFrame.csv")
# Format the data
energyData[, Year := factor(Year)]
energyData[, Day := factor(Day)]
energyData[, HourFactor := factor(HourFactor)]
energyData[, MonthName := factor(MonthName)]

# Credit fraud data
cfData = fread(path %+% "data/creditfraudModelFrame.csv")
# GPA data
gpaData = fread(path %+% "data/gpaData.csv")
gpaData[, rank := factor(rank)]

# Cars Data
Cars = data.table(mtcars)
Cars[, cyl := factor(cyl)]
Cars[, vs := factor(vs)]
Cars[, am := factor(am)]
Cars[, gear := factor(gear)]
Cars[, carb := factor(carb)]

# Create the model matrices

# For Gamma family with log link
modelFormula1 = formula(paste0("~ ", paste0(c("Year", "Day", "HourFactor",
                       "MonthName", paste0("EnergyLag", 24:47)), collapse = " + ")))
energyX = model.matrix(modelFormula1, data = data.frame(energyData))
energyY = model.matrix(~ EnergyMegaWattHours - 1, data = data.frame(energyData))

# Basic tests for Poisson Model
poissonX = model.matrix(~ Kilometres + Zone + Bonus + Make + Insured, data = faraway::motorins)
poissonY = model.matrix(~ Claims - 1, data = faraway::motorins)

# Basic test for Binomial Model
binomialX = model.matrix(Class ~ ., data = cfData)
binomialY = model.matrix(~ Class - 1, data = cfData)

# GPA Data Model Matrices
gpaX = model.matrix(admit ~ ., data = gpaData)
gpaY = model.matrix(~ admit - 1, data = gpaData)

# Cars data
carsX = model.matrix(mpg ~ ., data = mtcars)
carsY = model.matrix(~ mpg - 1, data = mtcars)

# Credit fraud data
cfData = fread(paste0(dataFolder, "creditfraudModelFrame.csv"))
# Basic test for Binomial Model
creditX = model.matrix(Class ~ ., data = cfData)
creditY = model.matrix(~ Class - 1, data = cfData)

# The GLM Models

# Gamma GLM

# Log link
# Native R GLM
betaR = matrix(glm.fit(energyX, energyY, family = Gamma("log"))$coefficients)
# The C++ version
betaCpp = protoSimpleGLM(energyX, energyY, "log", "Gamma", FALSE)

# Discrepancy between the different coefficients
print(paste0("Absolute Error: ", signif(absoluteError(betaR, betaCpp), 3)))
print(paste0("Relative Error: ", signif(relativeError(betaR, betaCpp), 3)))

# Inverse link
# Native R GLenergyX
print(paste0("Absolute Error: ", signif(absoluteError(gammaInverseR, gammaInverseCpp), 3)))
print(paste0("Relative Error: ", signif(relativeError(gammaInverseR, gammaInverseCpp), 3)))

# Poisson Regression
# Native R GLM
poissonLogR = matrix(glm.fit(poissonX, poissonY, family = poisson("log"))$coefficients)
# The C++ version
poissonLogCpp = protoSimpleGLM(poissonX, poissonY, "log", "Poisson", FALSE)
# Discrepancy
print(paste0("Absolute Error: ", signif(absoluteError(poissonLogR, poissonLogCpp), 3)))
print(paste0("Relative Error: ", signif(relativeError(poissonLogR, poissonLogCpp), 3)))

# Binomial Regression

# Logit link
# R GLM
binomialLogitR = matrix(glm.fit(binomialX, binomialY, family = binomial("logit"))$coefficients)
# The C++ version
binomialLogitCpp = protoSimpleGLM(binomialX, binomialY, "logit", "Binomial", FALSE)
# Discrepancy
print(paste0("Absolute Error: ", signif(absoluteError(poissonLogR, poissonLogCpp), 3)))
print(paste0("Relative Error: ", signif(relativeError(poissonLogR, poissonLogCpp), 3)))

# Probit Link
# R Version
binomialProbitR = matrix(glm.fit(gpaX, gpaY, family = binomial("probit"))$coefficients)
# The C++ version
binomialProbitCpp = protoSimpleGLM(gpaX, gpaY, "probit", "Binomial", FALSE)
# Discrepancy
print(paste0("Absolute Error: ", signif(absoluteError(binomialProbitR, binomialProbitCpp), 3)))
print(paste0("Relative Error: ", signif(relativeError(binomialProbitR, binomialProbitCpp), 3)))

# Power GLM - doesn't return the right coefficients in R!
gammaPowerM2R = matrix(glm.fit(energyX, energyY, family = Gamma(power(-2)))$coefficients)

# Negative binomial
require(MASS)
quineX = model.matrix(~ ., data = quine[quine$Days > 0,])
quineY = model.matrix(~ Days - 1, data = quine[quine$Days > 0,])
negativeBinomialR = matrix(glm.fit(quineX, quineY, family = negative.binomial(2))$coefficients)
negativeBinomialRCars = matrix(glm.fit(carsX, carsY, family = negative.binomial(1.0))$coefficients)

# Cauchit Link with binomial distribution
education = fread(paste0(path, "data/education.csv"), sep = ",")
educationX = model.matrix( ~ age + education + wantsMore, data = education)
educationY = model.matrix(~ cbind(using, notUsing) - 1, data = education)

# Just to see whether our implementation can handle
#    two columns for a binomial distribution
binomialCountTest = glm.fit(educationX, educationY, family = binomial("logit"), control = list(trace = TRUE))$coefficients

cauchitR = glm.fit(educationX, educationY, family = binomial("cauchit"), control = list(trace = TRUE))$coefficients
binomial_probit_link = glm.fit(gpaX, gpaY, family = binomial("probit"))
gaussian_log_link = glm.fit(energyX, energyY, family = gaussian("log"))


#
#  SimpMCMCJpeg.r
#
#  modified from SimpMCMC.r, but output is now jpeg files....
#  -------------------
#
#  SimplMCMC.r
#  January 24,2011
#  This file will generate an MCMC sample of normal data
#   and produce a series of plots for this data
#
#  NOTE: all plot files are saved to directory:
#     "c:/mike workstation/bayescourse9/plots."
#  You may want to change this....
#

# prior
mu0<-66; theta<-4; alp<-1; bet<-25

# data
x<-c(64, 73, 64, 63, 69, 71)
xbar<-mean(x)
n<-length(x)

# starting values
muStart<-20;tauStart<-0.0025;

#  MCMC parameters
nbig<-50000;
set.seed(333); # The purpose of set.seed is to get the same random values

if(T){        # set to true to rerun the MCMC
# Initialize chain
mu<-rep(nbig, 0)
tau<-rep(nbig,0)

mu[1]<-muStart; tau[1]<-tauStart

mu0p<- (theta*mu0+n*xbar)/(theta+n)  # does not change in loop
alpp<-alp+(0.5)*(n+1)                # does not change in loop

tau0p<-rep(nbig,0)
betp<-rep(nbig,0)

for(i in 2:nbig){
	# sample mu
	tau0p[i]<-tau[i-1]*(n+theta)
	mu[i]<-rnorm(1,mean=mu0p,sd=1/sqrt(tau0p[i]))

	# sample tau
	betp[i]<- bet+ 0.5*( sum( (x-mu[i])^2) + theta*(mu[i]-mu0p)^2)
	tau[i]<-rgamma(1,alpp,betp[i])
}
}
#  the following command will give the first 20 values:
 cbind(mu,tau)[1:20,]

# The next group of plots will plot the values as the get sampled in time.
#
# Please note, that the below command write the plots to a JPEG  file
# to the directory: ``\verb+c:/mike workstation/bayescourse9/plots+''. If you
# don't have such a directory, then you need to create it or better yet, change
# the directory name in the below commands.

#
#  plots the values as they get sampled in time
#
jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Sd.jpg")

iind1<-seq(1:60)

plot(mu[iind1],tau[iind1],type="n", xlab="mu", ylab="tau")
lines(mu[1:60],tau[1:60],type="b", cex=2)
title(main="First 60 values")

dev.off()
##################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2c.jpg")

plot(mu[2:60],tau[2:60],type="p", xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),
main="First 60 values, dropped first value")

dev.off()

# The next set of commands compares the sampled joint distribution from the
# MCMC method versus sampling the joint distribution using the know joint
# distribution given in the second lecture.  Note, the below code uses the
# function \verb+kde2d(...)+ which requires that the package "MASS" is loaded
# in R.

library(MASS)

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2e.jpg")

contour(kde2d(mu[2:nbig],tau[2:nbig]),
xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),nlevels=19,
main="Joint Distribution: MCMC")

dev.off()

#####
xa1<-4;xb1<-71.797
xmu0<-66.80; xthep<-10
xn<-50000
xgam<-rgamma(xn,xa1,xb1)
xmu<-rnorm(xn,mean=xmu0, sd=1/sqrt(xthep*xgam))
#####

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2f.jpg")

contour(kde2d(xmu,xgam),
xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),nlevels=19,
main="Joint Distribution: IID sample")

dev.off()

# The next group of plots are for the trace plots.  These plots are a simple
# time plot of one of the parameters which is sampled with the MCMC algorithm.
# That is, for a parameter $\theta$, let the m-th step sampled value be
# $\theta^{(m)}$. Then, the plot is simply $m$ versus $\theta^{(m)}$.

##########################################
#
#  trace plots
#
##########################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Ta.jpg")

iind2<-seq(1,200)
plot(iind2,mu[iind2],type="l", xlab="Iteration number", ylab="mu",
cex=1.5,
main="Trace plot for mu")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Tb.jpg")

iind2<-seq(1,200)
iind2a<-seq(6,200)

plot(iind2a,mu[iind2a],type="l", xlab="Iteration number", ylab="mu",
cex=1.5, main="Trace plot for mu, dropping first 5 obs")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Td.jpg")

iind2<-seq(1,200)
iind2a<-seq(6,200)

plot(iind2a,tau[iind2a],type="l", xlab="Iteration number", ylab="tau",
cex=1.5,
main="Trace plot for tau, dropping first 5 obs")

dev.off()

# The following sequence of plots show the estimated density of $\mu$
# calculated from a sample from a MCMC chain, from a sample of the
# independent distribution, and a plot of the true posterior marginal
# distribution.

##########################################
#
#  density plots
#
##########################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dma.jpg")

plot(density(mu[-(1:5)]),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75), main="Estimate mu by MCMC")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dmb.jpg")

plot(density(mu[-(1:5)]),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75), main="Estimate mu by Independent Sampling")
lines(density(xmu),type="l")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dmc.jpg")

plot((dd<-density(mu[-(1:5)])),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75),
main="True density of mu", col=1)

lines(density(xmu),type="l", col=2)
xx<-dd$x
c2<-1/sqrt( xb1/xa1/xthep)
tt<-(xx-xmu0)*c2
ddt<-dt(tt,2*xa1)*c2
lines(xx,ddt,type="l",col=3)

dev.off()

hw2bayes2019/Comp Code Files/Comp Code Files/SimpMCMCJpeg.r


# https://www.r-bloggers.com/rsi2-evaluation/
# Attach packages. You can install packages via:
library(dplyr)
library(quantmod)
library(tibble)
library(TTR)
library(PerformanceAnalytics)

# Pull SPL data from Yahoo! Finance
getSymbols("SPL.AX", from="2007-01-01", to="2018-01-09")
SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA

# Calculate the RSI indicator
rsi <- RSI(Cl(SPL), 2)

# Calculate Close-to-Close returns
ret <- ROC(Cl(SPL))
ret[1] <- 0

# This function gives us some standard summary
# statistics for our trades.
tradeStats <- function(signals, returns) {
# Inputs:
# signals : trading signals
# returns : returns corresponding to signals

# Combine data and convert to data.frame
sysRet <- signals * returns * 100
posRet <- sysRet > 0 # Positive rule returns
negRet <- sysRet < 0 # Negative rule returns
dat <- cbind(signals,posRet*100,sysRet[posRet],sysRet[negRet],1)
dat <- as.data.frame(dat)

# Aggreate data for summary statistics
means <- aggregate(dat[,2:4], by=list(dat[,1]), mean, na.rm=TRUE)
medians <- aggregate(dat[,3:4], by=list(dat[,1]), median, na.rm=TRUE)
sums <- aggregate(dat[,5], by=list(dat[,1]), sum)

colnames(means) <- c("Signal", "Pct Win", "Mean Win", "Mean Loss")
colnames(medians) <- c("Signal", "Median Win", "Median Loss")

colnames(sums) <- c("Signal", "Number Trades")
                     all <- merge(sums,means)
                     all <- merge(all,medians)

                     wl <- cbind(abs(all[,"Mean Win"]/all[,"Mean Loss"]))
                     abs(all[, "Median Win"]/all[,"Median Loss"])
                     colnames(wl) <- c("Mean Win/Loss ","Median Win/Loss")
  all <- cbind(all,wl)
return(all)
}

# This function determines position size and
# enables us to test several ideas with much
# greater speed and flexibility.
rsi2pos <- function(ind, indIncr=5, posIncr=0.25) {
# Inputs:
# ind : indicator vector
# indIncr : indicator value increments/breakpoints
# posIncr : position value increments/breakpoints

# Initialize result vector
size <- rep(0,NROW(ind))

# Long
size <- ifelse(ind < 4*indIncr, (1-posIncr*3), size)
size <- ifelse(ind < 3*indIncr, (1-posIncr*2), size)
size <- ifelse(ind < 2*indIncr, (1-posIncr*1), size)
size <- ifelse(ind < 1*indIncr, (1-posIncr*0), size)

# Short
size <- ifelse(ind > 100-4*indIncr, 3*posIncr-1, size)
size <- ifelse(ind > 100-3*indIncr, 2*posIncr-1, size)
size <- ifelse(ind > 100-2*indIncr, 1*posIncr-1, size)
size <- ifelse(ind > 100-1*indIncr, 0*posIncr-1, size)

# Today’s position (‘size’) is based on today’s
# indicator, but we need to apply today’s position
# to the Close-to-Close return at tomorrow’s close.
size <- lag(size)

# Replace missing signals with no position
# (generally just at beginning of series)
size[is.na(size)] <- 0

# Return results
return(size)
}

# Calculate signals with the ‘rsi2pos()’ function,
# using 5 as the RSI step: 5, 10, 15, 20, 80, 85, 90, 95
# and 0.25 as the size step: 0.25, 0.50, 0.75, 1.00
sig <- rsi2pos(rsi, 5, 0.25)

# Break out the long (up) and short (dn) signals
sigup <- ifelse(sig > 0, sig, 0)
sigdn <- ifelse(sig < 0, sig, 0)

# Calculate rule returns
ret_up <- ret * sigup
# Convert to a tibble
ret_up <- as_data_frame(ret_up)
# Rename Column
colnames(ret_up) <- 'Long System Return'

# Calculate rule returns
ret_dn <- ret * sigdn
# Convert to a tibble
ret_dn <- as_data_frame(ret_dn)
# Rename Column
colnames(ret_dn) <- 'Short System Return'

# Calculate rule returns
ret_all <- ret * sig
# Convert to a tibble
ret_all <- as_data_frame(ret_all)
# Rename Column
colnames(ret_all) <- 'Total System Return'

# Create performance graphs
#png(filename = "20090501_rsi2_performance.png", 720, 720)
charts.PerformanceSummary(cbind(ret_up,ret_dn),methods='none',
main="RSI(2) Performance - RSI steps = 5, Size steps = 0.25")

dev.off()

# Print trade statistics table
cat('nRSI(2) Trade Statistics - RSI steps = 5, Size steps = 0.25n')
print(tradeStats(sig,ret))

# Print drawdown table
cat('nRSI(2) Drawdowns - RSI steps = 5, Size steps = 0.25n')
print(table.Drawdowns(ret_all, top=10))

# Print downside risk table
cat('nRSI(2) Downside Risk - RSI steps = 5, Size steps = 0.25n')
print(table.DownsideRisk(ret_all))

# Calculate signals with the ‘rsi2pos()’ function
# using new RSI and size step values
sig <- rsi2pos(rsi, 10, 0.3)

# Break out the long (up) and short (dn) signals
sigup <- ifelse(sig > 0, sig, 0)
sigdn <- ifelse(sig < 0, sig, 0)

# Calculate rule returns
ret_up <- ret * sigup
colnames(ret_up) <-'Long System Returns'
ret_dn <- ret * sigdn
colnames(ret_dn) <- 'Short System Returns'
ret_all <- ret * sig
colnames(ret_all) <- 'Total System Returns'

# Calculate performance statistics
# png(filename = "20090430_rsi2_performance_updated.png", 720, 720)
charts.PerformanceSummary(cbind(ret_up,ret_dn), methods = 'none',
  main = 'RSI(2) Performance - RSI steps = 1-, Size steps = 0.30')
dev.off()

# Print trade statistics table
cat('nRSI(2) Trade Statistics - RSI steps = 10, Size steps = 0.30n')
print(tradeStats(sig,ret))

# Print drawdown table
cat('nRSI(2) Drawdowns - RSI steps = 10, Size steps = 0.30n')
print(table.Drawdowns(ret_all, top=10))

# Print downside risk table
cat('nRSI(2) Downside Risk - RSI steps = 10, Size steps = 0.30n')
print(table.DownsideRisk(ret_all))


x<-rbeta(5000,5,2)
par(mfrow=c(1,2))
hist(x,col="gray",xlab="Our Randomly Sampled Values", ylab="Frequency of Ocurrence", main="Frequency")
hist(x,freq=FALSE, col="gray",xlab="Our Randomly Sampled Values", ylab="Density", main="Density")
lines(density(x),lty="dotted", lwd=3)


library(sp)
library(raster)

# SpatialPoints
longitude <-c(-116.7, -120.4, -116.7, -113.5, -115.5, -120.8, -119.5, -113.7, -113.7,-110.7)
latitude <-c(45.3, 42.6, 38.9, 42.1, 35.7, 38.9, 36.2, 39, 41.6, 36.9)
lonlat <-cbind(longitude, latitude)
pts <- SpatialPoints(lonlat)
crdref <- CRS('+proj=longlat +datum=WGS84')
pts <- SpatialPoints(lonlat, proj4string=crdref)
precipvalue <- runif(nrow(lonlat), min=0, max=100)
df <-data.frame(ID=1:nrow(lonlat), precip=precipvalue)
ptsdf <- SpatialPointsDataFrame(pts, data=df)
ptsdf
str(ptsdf)
showDefault(ptsdf)
pts

# Spatial Lines and Polygons

lon <- c(-116.8, -114.2, -112.9, -111.9, -114.2, -115.4, -117.7)
lat <- c(41.3, 42.9, 42.4, 39.8, 37.6, 38.3, 37.6)
lonlat <- cbind(lon, lat)
lns <- spLines(lonlat, crs=crdref)
lns

pols <- spPolygons(lonlat, crs=crdref)
pols

plot(pols, axes=TRUE, las=1)
plot(pols, border='blue', col='yellow', lwd=3, add=TRUE)
points(pts, col='red', pch=20, cex=3)

#
r <- raster(ncol=10, nrow=10, xmx=-80, xmn=-150, ymn=20, ymx=60)
values(r) <- runif(ncell(r))
values(r) <- 1:ncell(r)
r
plot(r)

# add polygon and points
lon <- c(-116.8, -114.2, -112.9, -111.9, -114.2, -115.4, -117.7)
lat <- c(41.3, 42.9, 42.4, 39.8, 37.6, 38.3, 37.6)
lonlat <- cbind(lon, lat)
pols <- spPolygons(lonlat, crs='+proj=longlat +datum=WGS84')
points(lonlat, col='red', pch=20, cex=3)
plot(pols, border='blue', lwd=2, add=TRUE)


=begin
  # sample-gaussian-elimination01.rb

  require "algebra"
  M = MatrixAlgebra(Rational, 5, 4)
  a = M.matrix{|i, j| i + j}
  a.display #=>
    #[0, 1, 2, 3]
    #[1, 2, 3, 4]
    #[2, 3, 4, 5]
    #[3, 4, 5, 6]
    #[4, 5, 6, 7]
  a.kernel_basis.each do |v|
    puts "a * #{v} = #{a * v}"
    #=> a * [1, -2, 1, 0] = [0, 0, 0, 0, 0]
    #=> a * [2, -3, 0, 1] = [0, 0, 0, 0, 0]
  end
((<_|CONTENTS>))
=end


library(Sleuth3)
summary(case0802)

case0802.lm <- lm(log(Time)~Voltage,data=case0802)
summary(case0802.lm)

anova(case0802.lm)

head(case0802.lm$residuals)
sum(case0802.lm$residuals^2)

nrow(case0802)-2

case0802.equalmeans<-aov(log(Time)~1,data=case0802)
anova(case0802.equalmeans)

case0802.aov<-aov(log(Time)~Group,data=case0802)
anova(case0802.aov)

1-pf(0.502,5,69)

anova(case0802.lm,case0802.aov)


entropy = function(s)
   {freq = prop.table(table(strsplit(s, '')[1]))
    -sum(freq * log(freq, base = 2))}

print(entropy("1223334444"))   # 1.846439


"%gcd%" <- function(u, v) {ifelse(u %% v != 0, v %gcd% (u%%v), v)}

"%lcm%" <- function(u, v) { abs(u*v)/(u %gcd% v)}

print (50 %lcm% 75)