# Load relevant packages
library(tidyr)
library(dplyr)
library(readr)
library(ggplot2)
library(cluster)
library(factoextra)

# Read in the dataset
degrees <- read_csv("datasets/degrees-that-pay-back.csv", col_names=c("College.Major",
                                                                      "Starting.Median.Salary",
                                                                      "Mid.Career.Median.Salary",
                                                                      "Career.Percent.Growth",
                                                                      "Percentile.10",
                                                                      "Percentile.25",
                                                                      "Percentile.75",
                                                                      "Percentile.90"), skip=1)

# Display the first few rows and a summary of the data frame
degrees[1,]
summary(degrees)

# These packages need to be loaded in the first @tests cell.
library(testthat)
library(IRkernel.testthat)

sol_degrees <- read_csv('datasets/degrees-that-pay-back.csv', col_names=c('College.Major',
                    'Starting.Median.Salary','Mid.Career.Median.Salary','Career.Percent.Growth',
                    'Percentile.10','Percentile.25','Percentile.75','Percentile.90'), skip=1)

# Clean up the data
degrees_clean <- degrees %>%
    mutate_at(vars(-College.Major), function(x) as.numeric(gsub("[\\$,]","",x))) %>%
    mutate(Career.Percent.Growth = Career.Percent.Growth/100)

str(degrees_clean)

sol_degrees_clean <- sol_degrees %>%
    mutate_at(vars(Starting.Median.Salary:Percentile.90),
              function(x) as.numeric(gsub("[\\$,]","",x))) %>%
    mutate(Career.Percent.Growth = Career.Percent.Growth/100)

# Select and scale the relevant features and store as k_means_data
k_means_data <- degrees_clean %>%
    select(Starting.Median.Salary, Mid.Career.Median.Salary,
           Percentile.10, Percentile.90) %>%
    scale()

# Run the fviz_nbclust function with our selected data and method "wss"
elbow_method <- fviz_nbclust(k_means_data, FUNcluster = kmeans, method = "wss")

# View the plot
elbow_method

sol_k_means_data <- sol_degrees_clean %>%
    select(Starting.Median.Salary, Mid.Career.Median.Salary,
           Percentile.10, Percentile.90) %>%
    scale()

sol_elbow <- fviz_nbclust(sol_k_means_data, kmeans, method = "wss")

# Run the fviz_nbclust function with the method "silhouette"
silhouette_method <- fviz_nbclust(k_means_data,
                                  FUNcluster = kmeans, method = "silhouette")

# View the plot
silhouette_method

sol_silhouette <- fviz_nbclust(sol_k_means_data, kmeans, method = "silhouette")

# Use the clusGap function to apply the Gap Statistic Method
gap_stat <- clusGap(k_means_data, FUN = kmeans, nstart = 25, K.max = 10, B = 50)

# Use the fviz_gap_stat function to vizualize the results
gap_stat_method <- fviz_gap_stat(gap_stat)

# View the plot
gap_stat_method

sol_gap_stat <- clusGap(sol_k_means_data, FUN = kmeans, nstart = 25,
                    K.max = 10, B = 50)

sol_gap_stat_method <- fviz_gap_stat(sol_gap_stat)

# Set a random seed
set.seed(1988)

# Set k equal to the optimal number of clusters
num_clusters <- 3

# Run the k-means algorithm
k_means <- kmeans(k_means_data, centers = num_clusters,
                  iter.max = 15, nstart = 25)

# Label the clusters of degrees_clean
degrees_labeled <- degrees_clean %>%
    mutate(clusters = k_means$cluster)

str(degrees_labeled)

set.seed(111)
sol_k_means <- kmeans(sol_k_means_data, 3, iter.max = 15, nstart = 25)

# Add back the cluster labels to degrees
sol_degrees_labeled <- sol_degrees_clean %>%
    mutate(clusters = sol_k_means$cluster)

# Graph the clusters by Starting and Mid Career Median Salaries
career_growth <- ggplot(degrees_labeled, aes(Starting.Median.Salary,
                                             Mid.Career.Median.Salary,
                                            color = factor(clusters))) +
geom_point() +
xlab("Starting.Median.Salary") +
ylab("Mid.Career.Median.Salary") +
ggtitle("Starting Median Salary vs. Mid Career Median Salary") +
scale_x_continuous(labels = scales::dollar) +
scale_y_continuous(labels = scales::dollar)

# View the plot
career_growth

sol_career_growth <- ggplot(sol_degrees_labeled, aes(x=Starting.Median.Salary,y=Mid.Career.Median.Salary,
    color=factor(clusters))) +
    geom_point(alpha=4/5,size=6) +
    scale_x_continuous(labels = scales::dollar) +
    scale_y_continuous(labels = scales::dollar) +
    xlab('Starting Median Salary') +
    ylab('Mid Career Median Salary') +
    scale_color_manual(name="Clusters",values=c("#EC2C73","#29AEC7",
                    "#FFDD30")) +
    ggtitle('Clusters by Starting vs. Mid Career Median Salaries')

# Use the gather function to reshape degrees and
# use mutate() to reorder the new percentile column
degrees_perc <- degrees_labeled %>%
    select(College.Major,Percentile.10, Percentile.25, Mid.Career.Median.Salary,
           Percentile.75, Percentile.90, clusters) %>%
    gather(key = "percentile", value = "salary", -c(College.Major, clusters)) %>%
    mutate(percentile = factor(percentile, levels = c("Percentile.10", "Percentile.25", "Mid.Career.Median.Salary",
           "Percentile.75", "Percentile.90")))

str(degrees_perc)

sol_degrees_perc <- sol_degrees_labeled %>%
    select(College.Major, Percentile.10, Percentile.25,
           Mid.Career.Median.Salary, Percentile.75,
           Percentile.90, clusters) %>%
    gather(key=percentile, value=salary, -c(College.Major, clusters)) %>%
    mutate(percentile=factor(percentile,levels=c('Percentile.10','Percentile.25',
            'Mid.Career.Median.Salary','Percentile.75','Percentile.90')))

# Graph the majors of Cluster 1 by percentile
cluster_1 <- degrees_perc %>%
               filter(clusters == 1) %>%
               ggplot(aes(x = percentile, y = salary,
                          group = College.Major, color = College.Major)) +
               geom_point() +
               geom_line() +
               ggtitle("Cluster 1: The Liberal Arts") +
               theme(axis.text.x = element_text(size = 7, angle = 25))

# View the plot
cluster_1

sol_cluster_1 <- ggplot(sol_degrees_perc[sol_degrees_perc$clusters==1,], aes(x=percentile,y=salary,
                    group=College.Major, color=College.Major, order=salary)) +
                    geom_point() +
                    geom_line() +
                    ggtitle('Cluster 1:  The Liberal Arts') +
                    theme(axis.text.x = element_text(size=7, angle=25))

# Modify the previous plot to display Cluster 2
cluster_2 <- degrees_perc %>%
               filter(clusters == 2) %>%
               ggplot(aes(x = percentile, y = salary,
                          group = College.Major, color = College.Major)) +
               geom_point() +
               geom_line() +
               ggtitle("Cluster 2: The Goldilocks") +
               theme(axis.text.x = element_text(size = 7, angle = 25))

# View the plot
cluster_2

sol_cluster_2 <- ggplot(sol_degrees_perc[sol_degrees_perc$clusters==2,], aes(x=percentile,y=salary,
                    group=College.Major, color=College.Major, order=salary)) +
                    geom_point() +
                    geom_line() +
                    ggtitle('Cluster 2:  The Goldilocks') +
                    theme(axis.text.x = element_text(size=7, angle=25))

# Modify the previous plot to display Cluster 3
cluster_3 <- degrees_perc %>%
               filter(clusters == 3) %>%
               ggplot(aes(x = percentile, y = salary,
                          group = College.Major, color = College.Major)) +
               geom_point() +
               geom_line() +
               ggtitle("Cluster 3: The Over Achievers") +
               theme(axis.text.x = element_text(size = 7, angle = 25))

# View the plot
cluster_3

sol_cluster_3 <- ggplot(sol_degrees_perc[sol_degrees_perc$clusters==3,], aes(x=percentile,y=salary,
                    group=College.Major, color=College.Major, order=salary)) +
                    geom_point() +
                    geom_line() +
                    ggtitle('Cluster 2:  The Over Achievers') +
                    theme(axis.text.x = element_text(size=7, angle=25))

# Sort degrees by Career.Percent.Growth
degrees_labeled %>%
  select(College.Major, Career.Percent.Growth) %>%
  arrange(desc(Career.Percent.Growth)) %>%
  head(2)

# Identify the two majors tied for highest career growth potential
highest_career_growth <- c('Math','Philosophy')


alpha=0.05
q.alpha=qtukey(1-alpha,3,15)
n=10
sw2=10.28 # calculated in 14.10
W=q.alpha*(sqrt(sw2/n))
W
sample_means=c(25.1,23.5,37.8)
# by ordering sample mean from lowest to highest , we rank display panels by 2 1 3
# if diffrence between means > W then we declare them to be significantly different from each other


#===============================================================
# Find k-Almost-primes
# R implementation
#===============================================================
#---------------------------------------------------------------
# Function for prime factorization from Rosetta Code
#---------------------------------------------------------------

findfactors <- function(n) {
  d <- c()
  div <- 2; nxt <- 3; rest <- n
  while( rest != 1 ) {
    while( rest%%div == 0 ) {
      d <- c(d, div)
      rest <- floor(rest / div)
    }
    div <- nxt
    nxt <- nxt + 2
  }
  d
}

#---------------------------------------------------------------
# Find k-Almost-primes
#---------------------------------------------------------------

almost_primes <- function(n = 10, k = 5) {

  # Set up matrix for storing of the results

  res <- matrix(NA, nrow = k, ncol = n)
  rownames(res) <- paste("k = ", 1:k, sep = "")
  colnames(res) <- rep("", n)

  # Loop over k

  for (i in 1:k) {

    tmp <- 1

    while (any(is.na(res[i, ]))) { # Keep looping if there are still missing entries in the result-matrix
      if (length(findfactors(tmp)) == i) { # Check number of factors
        res[i, which.max(is.na(res[i, ]))] <- tmp
      }
      tmp <- tmp + 1
    }
  }
  print(res)
}


#' @export
#' @title correlationMatrix
#' @description couldn't accurately describe
#' @param \code{X}
#' @param \code{dfr} degrees of freedom
#' @param \code{meth.}
#' @return \code{}
#' @note X is the matrix of values with each column representing a single variable.  The upper triangle of the resulting matrix is p-values and lower is cor test value
#' @family statistical
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
correlationMatrix <- function(X, dfr = nrow(X) - 2,meth.=c("pearson", "kendall", "spearman")) {
			 R <- round(cor(X,method=meth.),digits=4)
				 above <- row(R) < col(R)
				 r2 <- R[above]^2
				 Fstat <- r2 * dfr / (1 - r2)
				 R[above] <- 1 - pf(Fstat, 1, dfr)
				 if( any(R[above]==0)) {
				R[above][which(R[above]==0)]<-0.0001
	 		 }
			 R
			}


theMatrix <- matrix(1:9, nrow = 3)
theMatrix

#sum up columns
apply(theMatrix, MARGIN=2, sum)
colSums(theMatrix)
#sum up rows
apply(theMatrix, MARGIN=1, sum)
rowSums(theMatrix)

theMatrix[2,1] <- NA
theMatrix
apply(theMatrix, 1, sum)
apply(theMatrix, 2, sum)

#remove NAs
apply(theMatrix, 1, sum, na.rm = TRUE)
apply(theMatrix, 2, sum, na.rm = TRUE)

#lapply is versatile!
theList <- list(A=matrix(1:9, nrow=3), B=1:5, C=matrix(1:4,2), D=2)
theList
lapply(theList, sum) #returns a list
sapply(theList, sum) #tries to return a vector

theNames <- c("Jared", "Deb", "Paul")
lapply(theNames, nchar)
sapply(theNames, nchar)

#mapply for multiple lists
firstList <- list(A=matrix(1:16, 4), B=matrix(1:16, 2), C=1:5)
secondList <- list(A=matrix(1:16,4), B=matrix(1:16,8), C=15:1)
firstList
secondList

mapply(identical, firstList, secondList)

simplefunc <- function(x,y)
 {
   NROW(x) + NROW(y)
}

mapply(simplefunc, firstList, secondList)

#perform group summaries with the aggregate function
library(ggplot2)
data(diamonds)
head(diamonds)
mean(diamonds$price)
#calculation by field(s)
aggregate(price ~ cut, diamonds, mean)
aggregate(price ~ cut + color, diamonds, mean)
aggregate(cbind(price, carat) ~ cut + color, diamonds, mean)

#group operations with plyr
#calculating OBP
require(plyr)
head(baseball)
#treating nulls
baseball$sf[baseball$year < 1954] <- 0
any(is.na(baseball$sf))
baseball$hbp[is.na(baseball$hbp)] <- 0
any(is.na(baseball$hbp))

#only looking at at least 50 at bats (ab)
baseball <- baseball[baseball$ab >= 50,]

baseball$OBP <- with(baseball, (h + bb + hbp) / (ab + bb + hbp + sf))
tail(baseball)
#creating an obp function
obp <- function(data)
{
  c(OBP = with(data, sum(h + bb + hbp) / sum(ab + bb + hbp + sf)))
}
#split, apply, combine paradigm
careerOBP <- ddply(baseball, .variables="id", obp)
careerOBP <- careerOBP[order(careerOBP$OBP, decreasing=TRUE),]
head(careerOBP)
theList <- list(A=matrix(1:9, 3), B=1:5, C=matrix(1:4, 2), D=2)
theList
lapply(theList, sum)
sapply(theList, sum)

head(diamonds)
aggregate(price ~ cut, diamonds, each(mean,median))

numcolwise(sum, na.rm = TRUE)(diamonds)
sapply(diamonds[, sapply(diamonds, is.numeric)], sum)

#combine datasets
sport <- c("Hockey", "Baseball", "Football")
league <- c("NHL", "MLB", "NFL")
trophy <- c("Stanley Cup", "Comissioner's Trophy", "Vince Lombardi Trophy")
sports1 <- cbind(sport, league, trophy)
sports1
sports2 <- data.frame(sport=c("Basketball", "Golf"),
                      league=c("NBA", "PGA"),
                      trophy=c("Larry O'Brien Championship Trophy", "Wanamaker Trophy"))
sports2
sports <- rbind(sports1, sports2)
sports

#join datasets
head(countries)
head(codes)
countryMerged <- merge(x=codes, y=countries, by.x="Country.name", by.y="Country")
require(plyr) #in plyr column names have to have the same name
codes <- rename(codes, c(Country.name="Country"))
countryJoined <- join(x=codes, y=countries, by="Country")

#switch storage paradigms
#moving from wide to long, long to wide
require(reshape2)
head(airquality)
airMelt <- melt(airquality, id=c("Month", "Day"),
                value.name ="Value", variable.name ="metric")
head(airMelt)

airCast <- dcast(airMelt, Month + Day ~ metric, value.var="Value")
airCast <- airCast[, c("Ozone", "Solar.R", "Wind", "Temp", "Month", "Day")]
head(airCast)

#tidyr
library(tidyr)
library(magrittr)

head(airquality)
airGather <- airquality %>% gather(Metric, Value, -c(Month, Day))
head(airGather)
tail(airGather)
airSpread <- airGather %>% spread(Metric, Value)
head(airSpread)


## LASSO BAYESIANO
rm(list =ls())
##load("hiv.rda")
##204 binary attributes and 704 observations
library(monomvn)
data(diabetes)
attach(diabetes)
## Ordinary Least Squares regression
reg.ols <- regress(x, y)
## Lasso regression
reg.las <- regress(x, y, method="lasso")
## Bayesian Lasso regression. T: N�m de Muestras a Posteriori
## thin: number of MCMC samples to skip before a sample is collected (via thinning)
reg.blas <- blasso(x, y, T= 2000, thin = 50)
## summarize the beta (regression coefficients) estimates
plot(reg.blas, burnin=200)
points(drop(reg.las$b), col=2, pch=20)
points(drop(reg.ols$b), col=3, pch=18)
legend("topleft", c("blasso-map", "lasso", "lsr"), col=c(2,2,3), pch=c(21,20,18))
## plot the size of different models visited
plot(reg.blas, burnin=200, which="m")
## get the summary
s <- summary(reg.blas, burnin=200)
s$coef
## Residual Variance
s$s2
## calculate the probability that each beta coef != zero
s$bn0
## A summary of the model order
s$m
## Lambda
s$lambda2

### BOOTSTRAP
par(mfrow=c(1,1))
library(glmnet)
require(boot)
##X <- model.matrix(y~.,data=diabetes)
cv.out=cv.glmnet(x,y,alpha=1)
plot(cv.out)
bestlam=cv.out$lambda.min
bestlam
fit1=glmnet(x,y)
coef(fit1,s=bestlam) # extract coefficients at a single value of lambda
## Funci�n que extrae los coeficientes de LASSO dado el mejor lambda de VC
## Muestra de bootstrap
sample(1:10, size = 10, replace = T)
set.seed(44)
B <- 1000
betas <- matrix(0,B,11)
lambdas <- rep(0, B)
n.x <- nrow(x)
for (i in 1:B){
  mi.muestra <- sample(nrow(x), size = n.x, replace = T)
  x.b <- x[mi.muestra,]
  y.b <- y[mi.muestra]
  cv.out=cv.glmnet(x.b,y.b,alpha=1)
  fit1=glmnet(x.b,y.b,alpha=1)
  coefs <-coef(fit1,s=cv.out$lambda.min)
  betas[i,] <- coefs[,1]
  lambdas[i] <- cv.out$lambda.min
}
boxplot(betas)
abline(h=0, col = "green", pch =20)
media.betas <- apply(betas, 2, mean)
points(drop(media.betas), col=3, pch=18)
sd.betas <- apply(betas, 2, sd)
limite.inferior <- apply(betas, 2, quantile, probs =0.025, na.rm = FALSE)
limite.superior <- apply(betas, 2, quantile, probs =0.975, na.rm = FALSE)
intervalo.percentil = cbind(limite.inferior,limite.superior)
rownames(intervalo.percentil) <- rownames(coefs)
intervalo.percentil
mean(lambdas)


library(glmnet)
library(corrplot)
library(MASS)
library(psych)
library(polycor)
library(readr)

loan <- read_csv("C:/.../lending_club_loans_Cleaned.csv",
           col_types = cols(int_rate = col_number(),
           revol_util = col_number()))
View(loan)

#More Data Cleaning
loan = subset(loan, purpose != 'other')
loan = subset(loan, loan$annual_inc<6000000)

#Shorter names for the boxplots graphs and new variables
loan$purpose[loan$purpose=='credit_card'] <- "crca"
loan$purpose[loan$purpose=='small_business'] <- "smb"
loan$purpose[loan$purpose=='debt_consolidation'] <- "dbtc"
loan$purpose[loan$purpose=='home_improvement'] <- "hmim"
loan$purpose[loan$purpose=='major_purchase'] <- "mapu"
loan$purpose[loan$purpose=='medical'] <- "med"
loan$purpose[loan$purpose=='moving'] <- "mov"
loan$purpose[loan$purpose=='vacation'] <- "vac"
loan$purpose[loan$purpose=='educational'] <- "edu"
loan$purpose[loan$purpose=='renewable_energy'] <- "reen"
loan$log_annual_inc = log(loan$annual_inc/1000)
loan$log_annual_inc = ifelse(log(loan$annual_inc/1000) < 0, 0, log(loan$annual_inc/1000))
loan$fico = (loan$fico_range_low + loan$fico_range_high) / 2
loan$amnt1000 = loan$loan_amnt/1000
loan$sqrt_amnt = sqrt(loan$loan_amnt/1000)
loan$log_fico = log(loan$fico)

#Histograms
hist(loan$loan_amnt)
hist(loan$sqrt_amnt)
hist(loan$annual_inc)
hist(loan$log_annual_inc)
hist(loan$fico)
hist(loan$log_fico)

#Boxplot, Quartiles and Anova for different variables and purpose
BoxPlotAnova <- function(df, predictor_col, cat_col, pred_col_name, cat_col_name)
  { aggregate(df[[predictor_col]], by=list(Category=df[[cat_col]]), na.rm = TRUE, FUN=quantile)
    boxplot(df[[predictor_col]]  ~ df[[cat_col]], main="", xlab=cat_col_name, ylab=pred_col_name)
    anova= lm(df[[predictor_col]] ~ 0+factor(df[[cat_col]]))
    summary(anova)
    int_anova = round(confint(anova),2)
    row.names(int_anova) <- levels(factor(df[[cat_col]]))
    print(int_anova)
    return(int_anova)
}

a1 = BoxPlotAnova(loan, 'amnt1000', 'purpose', "Loan amount (Thousands of $)", "Purpose")
a2 = BoxPlotAnova(loan, 'sqrt_amnt', 'purpose', "Sqrt. Loan amount", "Purpose")
a3 = BoxPlotAnova(loan, 'int_rate', 'purpose', "Interest Rate", "Purpose")
a4 = BoxPlotAnova(loan, 'log_annual_inc', 'purpose', "Log Annual Income", "Purpose")
a5 = BoxPlotAnova(loan, 'annual_inc', 'purpose', "Annual Income", "Purpose")
a6 = BoxPlotAnova(loan, 'fico', 'purpose', "FICO", "Purpose")

#Loan Dataframe
loandf = as.data.frame(loan)
loandf$grade = as.factor(loandf$grade)
loandf$term = as.factor(loandf$term)
loandf$home_ownership = as.factor(loandf$home_ownership)
loandf$purpose = as.factor(loandf$purpose)
loandf$annual_inc = as.integer(loandf$annual_inc)

#MODELLING TO KNOW MAIN PREDICTORS
fit = lm(int_rate ~ sqrt_amnt + term + emp_length + factor(home_ownership) + verification_status + factor(purpose) + log_fico + dti + revol_bal + revol_util + log_annual_inc, data=loan)
summary(fit)

fitp = lm(int_rate ~ factor(purpose), data=loan)
summary(fitp)

fitf = lm(int_rate ~ fico + amnt1000, data=loan)
summary(fitf)

fitficoamnt1 = lm(int_rate ~ log_fico + sqrt_amnt, data=loan)
summary(fitficoamnt1)

fitficoamnt2 = lm(int_rate ~ fico + amnt1000, data=loan)
summary(fitficoamnt2)

#######################
######### MDS #########
#######################

# Normalizing and merging Interest Rate, Loan Amount and FICO score by purpose category
ratea = as.matrix(a3)
rateamed = (ratea[,1]+ratea[,2]) / 2
rateaval = (rateamed - mean(rateamed)) / sd(rateamed)
print(cbind(ratea, rateaval))

ficoa = as.matrix(a6)
ficoamed = (fitoa[,1]+fitoa[,2]) / 2
ficoaval = (fitoamed - mean(fitoamed)) / sd(ficoamed)
ficoStdz = round((ficoamed - mean(ficoamed)) / sd(ficoamed),2)
print(cbind(ficoa, ficoStdz))

amnt1000a = as.matrix(a3)
amnt1000amed = (amnt1000a[,1]+amnt1000a[,2]) / 2
amnt1000aval = (amnt1000amed - mean(amnt1000amed)) / sd(amnt1000amed)
amnt1000stdz = round((amnt1000amed - mean(amnt1000amed)) / sd(amnt1000amed),2)
print(cbind(amnt1000a, amnt1000stdz))

#MDS columns (FICO + Loan Amount)
mdscols = cbind(amnt1000aval, ficoaval)
fplusa = ficoaval+amnt1000aval
feuca = (ficoaval^2 +amnt1000aval^2)^(1/2)
rplusf = ficoaval+rateaval
mdscols = cbind(mdscols, fplusa, feuca, rplusf)
print(mdscols)

#Calculate Distances between categories by Interest Rate, Loan Amount and FICO score
# - Interest Rate
# - FICO score
# - Loan Amount
ratedist = dist(rateaval, method = "minkowski", diag = FALSE, upper = FALSE, p = 2)
print(round(ratedist,2))
ficodist = dist(ficoaval, method = "minkowski", diag = FALSE, upper = FALSE, p = 2)
print(round(ficodist,2))
amnt1000dist = dist(amnt1000aval, method = "minkowski", diag = FALSE, upper = FALSE, p = 2)
print(round(amnt1000dist,2))

# Total distances (composed)
# - Euclidean distance (FICO - Loan Amount)
# - Manhattan distance (FICO - Loan Amount)
# - Euclidean distance (FICO - Int. rate)
# - Manhattan distance (FICO - Int. rate)
distfae = sqrt(ficodist**2 + amnt1000dist**2)
distfam = ficodist + amnt1000dist
distrfe = sqrt(ficodist**2 + ratedist**2)
distrfm = ficodist + ratedist

# Fit MDS and plot
# - Euclidean distance (FICO - Loan Amount)
# - Manhattan distance (FICO - Loan Amount)
# - Euclidean distance (FICO - Int. rate)
# - Manhattan distance (FICO - Int. rate)
fitMDS <- function(distances, numofdim, main_text, Coord1, Coord2)
{ fitmds <- isoMDS(distances, k=numofdim) # k is the number of dim
  fitmds # view results
  x <- fitmds$points[,1]
  y <- fitmds$points[,2]
  plot(x, y, xlab=Coord1, ylab=Coord2,
     main=main_text, type="n")
  text(x, y, labels = row.names(ficoa), cex=.7)
  return(fitmds)
}

fitmds1 = fitMDS(distfae, 2, "Euclidean distance (FICO - Loan Amount) MDS", "Coordinate 1", "Coordinate 2")
fitmds2 = fitMDS(distfam, 2, "Manhattan distance (FICO - Loan Amount) MDS", "Coordinate 1", "Coordinate 2")
fitmds3 = fitMDS(distrfe, 2, "Euclidean distance (FICO - Int. rate) MDS", "Coordinate 1", "Coordinate 2")
fitmds4 = fitMDS(distrfm, 2, "Manhattan distance (FICO - Int. rate) MDS", "Coordinate 1", "Coordinate 2")

#Finding an explanation for the axis
# - Example: Euclidean distance (FICO - Loan Amount) MDS
# - Correlation helps us to know if there is any relationship between the axis
#   and variables of the dataset.
mdspts1 = as.data.frame(fitmds1$points)
mdspoints1 = cbind(mdspts1, fplusa, feuca, rateaval, fitoaval, amnt1000aval)
names(mdspoints1) <- c("edsx", "edsy", "fico+amnt", 'ficoEucAmnt', 'rate','fico', 'amnt')
corrmds1 = corr.test(mdspoints1,adjust="none")
corrmds1
corrplot(cor(mdspoints1), method="ellipse")

###########################################
# REORDERING AND CHANGING NAMES
x <- -fitmds1$points[,1]
y <- -fitmds1$points[,2]
plot(x, y, xlab="Loan Amount + FICO", ylab="Interest rate",
     main="Purpose MDS", type="n")
text(x, y, labels = row.names(fitoa), cex=.7)


model_snowaccumulation <- function (tsmax = 0.0,
         tmax = 0.0,
         trmax = 0.0,
         precip = 0.0){
    #'- Name: SnowAccumulation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snowfall accumulation  calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates the depth of snow cover and recalculate weather data
    #'- inputs:
    #'            * name: tsmax
    #'                          ** description : maximum daily air temperature (tmax) below which all precipitation is assumed to be snow
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 1000
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: tmax
    #'                          ** description : current maximum air temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: trmax
    #'                          ** description : tmax above which all precipitation is assumed to be rain
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: precip
    #'                          ** description : current precipitation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'- outputs:
    #'            * name: Snowaccu
    #'                          ** description : snowfall accumulation
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW/d
    #'                          ** uri :
    fs <- 0.0
    if (tmax < tsmax)
    {
        fs <- 1.0
    }
    if (tmax >= tsmax && tmax <= trmax)
    {
        fs <- (trmax - tmax) / (trmax - tsmax)
    }
    Snowaccu <- fs * precip
    return (list('Snowaccu' = Snowaccu))
}


.b = import('../base')

overlap_normals = function(mu1, sd1, mu2, sd2) {
    min.f1f2 = function(x, mu1, mu2, sd1, sd2) {
        f1 = dnorm(x, mean=mu1, sd=sd1)
        f2 = dnorm(x, mean=mu2, sd=sd2)
        pmin(f1, f2)
    }

    integrate(min.f1f2, -Inf, Inf, mu1=mu1, mu2=mu2, sd1=sd1, sd2=sd2)$value %catch% NA
}

median_test = function(x,y) {
    z = c(x,y)
    g = rep(1:2, c(length(x),length(y)))
    m = median(z)
    fisher.test(z<m,g)$p.value
}

#' Scales a vector setting median=0 and sd=1
#'
#' @param x          The vector
#' @param ref_index  Indices to use to derive median/sd
#' @return           A scaled vector
median_scale = function(x, ref_index=TRUE) {
    ref = x[ref_index]
    (x - median(ref)) / sd(ref)
}


library(Sleuth3)  # Load the Sleuth3 and ggplot2 packages.
library(ggplot2)

names(case0301)
qplot(Treatment,Rainfall,data=case0301,geom="boxplot")

log.rainfall<-log(case0301$Rainfall) # Calculate the log of Rainfall and call it log.rainfall.

qplot(Treatment,log.rainfall,data=case0301,geom="boxplot") # Make a boxplot using the log-transformed response.

summary(case0301$Treatment) # Check to see which group R puts first.
t.test(log.rainfall~Treatment,data=case0301,var.equal=TRUE,alternative="greater")
log.rain.t.test <- t.test(log.rainfall~Treatment,data=case0301,var.equal=TRUE)
exp(0.2408651)
exp(2.0466973)
exp(1.143781)

C.dalli <- read.csv("C_dalli.csv") # The file must be in your working directory.
head(C.dalli)
qplot(as.factor(time_point),pct_cover,data=C.dalli,geom="boxplot")
logit.pct <- with(C.dalli,log(pct_cover)/(100-pct_cover))
qplot(as.factor(time_point),logit.pct,data=C.dalli,geom="boxplot")

head(case0302)
qplot(Veteran,Dioxin,data=case0302,geom="boxplot")

plot(case0302$Dioxin)
identify(case0302$Dioxin)

summary(case0302$Veteran) # Check R's ordering of the groups.
t.test(Dioxin~Veteran,data=case0302,var.equal=TRUE,
       alternative="less")
t.test(Dioxin~Veteran,data=case0302,var.equal=TRUE,
       alternative="less",subset=-646)
t.test(Dioxin~Veteran,data=case0302,var.equal=TRUE,
       alternative="less",subset=-c(646,645))


setwd ("c://R")
Printers=read.csv ("SellingPrinters.csv", header=TRUE,sep=";")
head(Printers)
str(Printers)

plot(Printers$Sold.Items,Printers$Price)

cov(Printers$Sold.Items,Printers$Price)
cor(Printers$Sold.Items,Printers$Price)

CovX_Y=cov(Printers$Sold.Items,Printers$Price)
CovX_Y
SdSoldItems=sd(Printers$Sold.Items)
SdSoldItems
SdPrice=sd(Printers$Price)
SdPrice
CorrCoef=CovX_Y/(SdSoldItems*SdPrice)
CorrCoef

LinMod <- lm( Printers$Price ~ Printers$Sold.Items,data=Printers)
LinMod

summary(LinMod)

abline(LinMod)


# Generates a new board - either a random one, sample blinker or gliders, or user specified.
gen.board <- function(type="random", nrow=3, ncol=3, seeds=NULL)
{
    if(type=="random")
    {
       return(matrix(runif(nrow*ncol) > 0.5, nrow=nrow, ncol=ncol))
    } else if(type=="blinker")
    {
       seeds <- list(c(2,1),c(2,2),c(2,3))
    } else if(type=="glider")
    {
       seeds <- list(c(1,2),c(2,3),c(3,1), c(3,2), c(3,3))
    }
    board <- matrix(FALSE, nrow=nrow, ncol=ncol)
    for(k in seq_along(seeds))
    {
      board[seeds[[k]][1],seeds[[k]][2]] <- TRUE
    }
    board
}

# Returns the number of living neighbours to a location
count.neighbours <- function(x,i,j)
{
   sum(x[max(1,i-1):min(nrow(x),i+1),max(1,j-1):min(ncol(x),j+1)]) - x[i,j]
}

# Implements the rulebase
determine.new.state <- function(board, i, j)
{
   N <- count.neighbours(board,i,j)
   (N == 3 || (N ==2 && board[i,j]))
}

# Generates the next interation of the board from the existing one
evolve <- function(board)
{
   newboard <- board
   for(i in seq_len(nrow(board)))
   {
      for(j in seq_len(ncol(board)))
      {
         newboard[i,j] <- determine.new.state(board,i,j)
      }
   }
   newboard
}

# Plays the game.  By default, the board is shown in a plot window, though output to the console if possible.
game.of.life <- function(board, nsteps=50, timebetweensteps=0.25, graphicaloutput=TRUE)
{
   if(!require(lattice)) stop("lattice package could not be loaded")
   nr <- nrow(board)

   for(i in seq_len(nsteps))
   {
      if(graphicaloutput)
      {
         print(levelplot(t(board[nr:1,]), colorkey=FALSE))
      } else print(board)

      Sys.sleep(timebetweensteps)

      newboard <- evolve(board)

      if(all(newboard==board))
      {
         message("board is static")
         break
      } else if(sum(newboard) < 1)
      {
         message("everything is dead")
         break
      } else board <- newboard
   }
   invisible(board)
}

# Example usage
game.of.life(gen.board("blinker"))
game.of.life(gen.board("glider", 18, 20))
game.of.life(gen.board(, 50, 50))


## Stochastic GRADIENT DESCENT ALGORITHM
stochastic_gd<-function(design_matrix,response,
                        gradient_fn,cost_fn,threshold=0.01,
                        max_pass=1,
                        init_weights=matrix(rep(0,ncol(design_matrix)),ncol=1),
                        learning_rate=0.1){
  theta<-init_weights
  alpha<-learning_rate
  n<-nrow(design_matrix)
  cost<-numeric()
  nrows<-nrow(X)
  for(k in 1:max_pass){
    index<-(1:nrows)[order(runif(nrows))]
    if(!is.null(cost_fn)){
      cost<-c(cost,cost_fn(response,design_matrix%*%theta))
    }
    if(tail(cost,n=1)<threshold){
      break
    }
    for (i in index){
      theta<-theta-alpha*gradient_fn(theta,design_matrix[i,],response[i,])
    }
  }
  list(weights=theta,cost=cost)
}


A <- 0.1

r <- (1:100)

eta <- -1.1

L <- A*r^eta

plot(L~r)

plot(log(L)~log(r))

pl <- data.frame(r,L,logL=log(L))

head(pl)

lm(logL~log(r),data=pl)

# do it with 1000 points
rm(list=ls())

pl <- data.frame(r=seq(1,100,0.1))

pl$L<- 0.4*pl$r^-1.3
pl$logL <-log(pl$L)
pl$logr <-log(pl$r)

lm(logL~logr,data=pl)

cumPowerL <- function(x) {
  sum(pl[pl$r >=x,]$L)

}

pl$cumL <- sapply(pl$r,cumPowerL)

plot(log(cumL)~logr,data=pl)

pl1 <- pl[pl$logr<3,]

lm1 <- lm(log(cumL)~logr,data=pl1)

lm0  <- lm(log(cumL)~logr,data=pl)

summary(lm1)

coef(lm1)

summary(lm0)

abline(lm1,col="red")

abline(lm0,col="blue")

# Exercise 4

pl2 <- pl[1:50,]

lm2 <- lm(log(cumL)~logr,data=pl2)

summary(lm2)

coef(lm2)

abline(lm2,col="green")


# Aula 5
m <- mtcars

# gráfico de dispeção
plot(m$mpg~m$wt)
#semente de aleatoriedade
set.seed(33)
va<-sample(32)

treino<- m[va[1:24],]
teste<- m[va[25:32],]
#transformação linear
#hiótese: wt tem comportamento exponecial
# para linearizar ela ustilizaermos log, inversamene resulando em ln
cor(m$mpg, m$mt)
cor(m$mpg, log(m$wt))

# VAr. Caeg Cyl?
plot(m$mpg~m$wt, col=m$cyl)
# variavel cyl como categórica
mod <- lm(mpg~wt+as.factor(cyl),data=treino)

#mod <- lm(mpg~wt, data=treino)
#mod <- lm(mpg~log(wt), data=treino)
#mod <- lm(mpg~poly(wt,2), data=treino)
#mod <- lm(mpg~poly(wt,3), data=treino)

#pegando uma curva (modelo)
#aos pontos de treino

#mod <- lm(mpg~poly(wt,4), data=treino)
mod <- lm(mpg~poly(wt,5), data=treino)
mod <- lm(mpg~poly(wt,6), data=treino)
mod <- lm(mpg~poly(wt,16), data=treino)

# anál. par. regressãosummary(mod)
summary(mod)
p<- predict(mod, newdata=teste)

#previsto x real x erro
#cbind(p, teste$mpg, p-teste$mpg)

sse <- sum((p-teste$mpg)^2)
#sse

## Aula 5.1
  ## classificadores

d <- read.csv("train.csv")

# Probabilidade de sobrevivência no titanic
nrow(d[d$Survived==1,])/891

# Utilizando SQL no R
install.packages("sqldf")
library(sqldf)

sqldf("select Survived, count(*) from d group by Survived")

prop.table(table(d$Survived))
prop.table(table(d$Sex))

#Matrix de contingência
table(d[,c("Survived","Sex")])


library(deSolve)
library(reshape2)
library(ggplot2)

sir_ode <- function(times,init,parms){
  with(as.list(c(parms,init)), {
  # ODEs
  dS <- -beta*S*I
  dI <- beta*S*I-gamma*I
  dR <- gamma*I
  list(c(dS,dI,dR))
  })
}

parms <- c(beta=0.1,gamma=0.05)
init <- c(S=0.99,I=0.01,R=0)
times <- seq(0,200,length.out=2001)
sir_out <- lsoda(init,times,sir_ode,parms)

sir_out_long <- melt(as.data.frame(sir_out),"time")

# Plot
ggplot(sir_out_long, aes(x=time, y=value, colour=variable, group=variable)) +
  geom_line(lwd=2) + xlab("Time") + ylab("Number")


library(ISLR)
data(Auto)
fit <- lm(mpg ~ horsepower, data = Auto)
summary(fit)
predict(fit, data.frame(horsepower = 98), interval = "confidence")
predict(fit, data.frame(horsepower = 98), interval = "prediction")
plot(Auto$horsepower, Auto$mpg, main = "Scatterplot of mpg vs. horsepower", xlab = "horsepower", ylab = "mpg", col = "blue")
abline(fit, col = "red")
par(mfrow = c(2, 2))
plot(fit)
pairs(Auto)
names(Auto)
cor(Auto[1:8])
fit2 <- lm(mpg ~ . - name, data = Auto)
summary(fit2)
par(mfrow = c(2, 2))
plot(fit2)
fit3 <- lm(mpg ~ cylinders * displacement+displacement * weight, data = Auto[, 1:8])
summary(fit3)
par(mfrow = c(2, 2))
plot(log(Auto$horsepower), Auto$mpg)
plot(sqrt(Auto$horsepower), Auto$mpg)
plot((Auto$horsepower)^2, Auto$mpg)
data(Carseats)
fit3 <- lm(Sales ~ Price + Urban + US, data = Carseats)
summary(fit3)
fit4 <- lm(Sales ~ Price + US, data = Carseats)
summary(fit4)
confint(fit4)
par(mfrow = c(2, 2))
plot(fit4)


rm(list=ls())

library('radolc')

#--- testing ADOLC in the bi-variate case

fr <- function(x) {   ## Rosenbrock Banana function
  x1 <- x[1]
  x2 <- x[2]
  y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y }

grr <- function(x) { ## Gradient of 'fr'
  x1 <- x[1]
  x2 <- x[2]
  c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1), 200 * (x2 - x1 * x1))     }

#------------ testing ADOLC in the bivariate case
trace_on(1)
x <- c(adouble(1.0),adouble(2.0))
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

grrADOLC <- function(x) { ## Gradient of 'fr'
  xx <- x
  yy <- c(0.0,0.0)
  gradient(1,2,xx,yy);
  yy     }

#---- comparison of the two gradients

grrADOLC(x=c(1,2))

grr(x=c(1,2))

#---- comparison of the optimization

res0 <- optim(c(1.2,1), fr, method = "L-BFGS-B", control = list(type = 3, trace = 2))

res1 <- optim(c(1.2,1), fr, grr, method = "L-BFGS-B", control = list(type = 3, trace = 2))

res2 <- optim(c(1.2,1), fr, grrADOLC, method = "L-BFGS-B", control = list(type = 3, trace = 2))

print(res0)

print(res1)

print(res2)

#Always detach the package
detach(package:radolc, unload=TRUE)


# bivariate skew-normal copula with parameters rho, ga1, ga2
# such that determinant with these 3 correlation is positive definite
# checks on cdf, pdf and conditional distributions

# Rmat= [1 ga1 ga2; ga1 1 rho; ga2 rho 1 ]
# is correlation matrix of (Z0,Z1,Z2)
# the bivariate skew normal distribution is (Y1,Y2) = [Z1,Z2|Z0>0]
# the conditional distribution is univariate extended skew-normal
# with 4 parameters: xi=location, omega=scale, alpha=ga/sqrt(1-ga^2),
# tau=(negative threshold)

# these functions make use of functions in library(sn) and
# library(CopulaModel)

# param=c(rho,ga1,ga2), constraint is that
# correlation matrix with these parameters should be positive definite
dbskewn=function(y1,y2,param)
{ rho=param[1]; ga1=param[2]; ga2=param[3]
  r2=1-rho^2
  #a1=ga1/sqrt(1-ga1^2)
  #a2=ga2/sqrt(1-ga2^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s/r2)
  be1=(ga1-rho*ga2)/r2
  be2=(ga2-rho*ga1)/r2
  bpdf=2*dbvn2(y1,y2,rho)*pnorm((be1*y1+be2*y2)/s)
  bpdf
}

#============================================================

# compare
library(CopulaModel)
library(sn)

rho=.7; ga1=.5; ga2=.1
rho=.4; ga1=.4; ga2=-.1
rho=.3; ga1=.4; ga2=-.3
a1=ga1/sqrt(1-ga1^2)
a2=ga2/sqrt(1-ga2^2)
mypar=c(rho,ga1,ga2)
y1=.5; y2=2.1
y1=-.5; y2=-1.3
y1=.5; y2=-1.3
out2=dbskewn(y1,y2,mypar)

# sn library
rmat=matrix(c(1,rho,rho,1),2,2)
#alpv=c(a1,a2) # this is not correct
gav=c(ga1,ga2)
tem=solve(rmat,gav)
alpv=tem/sqrt(1-sum(gav*tem))
out=dmsn(c(y1,y2),Omega=rmat,alpha=alpv)
cat(out,out2,"\n")
# Ok matches
# check some identities
tem2=rmat%*%alpv
gv=tem2/sqrt(1+sum(alpv*tem2))
print(c(gv))
print(gav)
print(1-sum(gav*tem))
print(1/(1+sum(alpv*tem2)))
# Ok these match

#============================================================

# skew-normal copula from Azzalini-DallaValle's bivariate skew-normal
# u,v = values or vectors in (0,1)
# param = (rho,ga1,ga2), with -1<rho<1, -1<ga1<1, -1<ga2<1
#  and a constraint 1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho>0

# Output: bivariate skew-normal copula density
dbskewncop=function(u,v,param)
{ rho=param[1]; ga1=param[2]; ga2=param[3]
  r2=1-rho^2
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s/r2)
  be1=(ga1-rho*ga2)/r2
  be2=(ga2-rho*ga1)/r2
  y1=qsn(u,0,1,alpha=a1)
  y2=qsn(v,0,1,alpha=a2)
  bpdf=2*dbvn2(y1,y2,rho)*pnorm((be1*y1+be2*y2)/s)
  denom=dsn(y1,alpha=a1)*dsn(y2,alpha=a2)
  cpdf=bpdf/denom
  cpdf
}

# Output: bivariate skew-normal copula cdf
pbskewncop=function(u,v,param)
{ rho = param[1]; gav = param[2:3]
  rmat=matrix(c(1,rho,rho,1),2,2)
  tem=solve(rmat,gav)
  alpv=tem/sqrt(1-sum(gav*tem))
  ga1=gav[1]; ga2=gav[2]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  cdf=pmsn(c(y1,y2),Omega=rmat,alpha=alpv)
  cdf
}

# pcond21 = P(V<v|U=u) for bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional cdf P(V<v|U=u) of bivariate skew-normal copula
pcondbskewncop21=function(v,u,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om21=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om21
  tau21=a1*y1
  xi21=rho*y1
  a21=(ga2-rho*ga1)/s/om21
  ccdf=psn(y2,xi=xi21,omega=om21,alpha=a21,tau=tau21)
  ccdf
}

# pcond12 = P(U<u|V=v) for bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional cdf P(U<u|V=v) of bivariate skew-normal copula
pcondbskewncop12=function(u,v,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om12=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om12
  tau12=a2*y2
  xi12=rho*y2
  a12=(ga1-rho*ga2)/s/om12
  ccdf=psn(y1,xi=xi12,omega=om12,alpha=a12,tau=tau12)
  ccdf
}

# qcond21 = bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional quantile C_{2|1}^{-1}(p|u)of bivariate skew-normal copula
qcondbskewncop21=function(p,u,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  y1=qsn(u,alpha=a1); #y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om21=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om21
  tau21=a1*y1
  xi21=rho*y1
  a21=(ga2-rho*ga1)/s/om21
  y2=qsn(p,xi=xi21,omega=om21,alpha=a21,tau=tau21)
  v=psn(y2,alpha=a2)
  v
}

# qcond12 = bskewn copula with  y1=qsn(u), y2=qsn(v)
# Output: conditional quantile C_{1|2}^{-1}(p|v)of bivariate skew-normal copula
qcondbskewncop12=function(p,v,param)
{ rho = param[1];
  ga1=param[2]; ga2=param[3]
  a1=ga1/sqrt(1-ga1^2)
  a2=ga2/sqrt(1-ga2^2)
  #y1=qsn(u,alpha=a1);
  y2=qsn(v,alpha=a2)
  # parameters on cond cdf to match univariate extended skew-normal
  om12=sqrt(1-rho^2)
  s=1-ga1^2-ga2^2-rho^2+2*ga1*ga2*rho # should be positive
  s=sqrt(s)/om12
  tau12=a2*y2
  xi12=rho*y2
  a12=(ga1-rho*ga2)/s/om12
  y1=qsn(p,xi=xi12,omega=om12,alpha=a12,tau=tau12)
  u=psn(y1,alpha=a1)
  u
}

#============================================================
# all checks OK

# conditional u given v
chkcopderiv2=function(u,vvec,cpar,bcdf,pcond,bpdf,str=" ",eps=1.e-4)
{ nn=length(vvec)
  cat("\n",str, " with parameter ", cpar,"\n")
  cat("u   v    cdf      numccdf     ccdf\n")
  cat("u   v    ccdf     numpdf      pdf\n")
  for(i in 1:nn)
  { v=vvec[i]
    cdf=bcdf(u,v,cpar)
    cdf2=bcdf(u,v+eps,cpar)
    ccdf=pcond(u,v,cpar)
    #cat(u,v,cdf,(cdf2-cdf)/eps,ccdf,"\n")
    tem=(cdf2-cdf)/eps
    cat(u,v,cdf,tem,ccdf,"\n")
    if(abs(tem-ccdf)>eps*30) cat("*** ccdf roundoff???\n")
    ccdf2=pcond(u+eps,v,cpar)
    pdf=bpdf(u,v,cpar)
    #cat(u,v,ccdf,(ccdf2-ccdf)/eps,pdf,"\n")
    tem=(ccdf2-ccdf)/eps
    cat(u,v,ccdf,tem,pdf,"\n")
    if(abs(tem-pdf)>eps*30) cat("*** dcop roundoff???\n")
  }
  invisible(0)
}

# check of psn\circ qsn is OK,
# check of (psn(y+eps)-psn(y))/eps is OK

#param=c(.7,.5,.5)
#param=c(.7,.7,.1)
#param=c(.5,.0,.1)
#param=c(.1,.1,.1)
param=c(.2,.3,.1)

# compare pcondbskewncop21 and pcondbskewncop12
a=c(.4,.5,.6)
b=c(.1,.7,.8)
for(j in 1:3)
{ out1=pcondbskewncop21(a[j],b[j],param)
  out2=pcondbskewncop12(a[j],b[j],param[c(1,3,2)])
  cat(out1,out2,"\n")
}
# above two should be the same

#u=.3
u=.8
vvec=seq(.4,.9,.1)

#for(v in vvec) chkcopderiv(u,v,param,bcdf=pbskewncop,pcond=pcondbskewncop21,bpdf=dbskewncop,str="bskn",eps=1.e-4)

chkcopderiv(u,vvec,param,bcdf=pbskewncop,pcond=pcondbskewncop21,
  bpdf=dbskewncop)
# OK

chkcopderiv2(u,vvec,param,bcdf=pbskewncop,pcond=pcondbskewncop12,
  bpdf=dbskewncop)
# OK

cat("\ncheck pcond and qcond as functional inverses\n")
uvec=seq(.1,.6,.1)
vvec=seq(.4,.9,.1)
#par.pla=pla.b2cpar(.7)
#chkcopcond(uvec,vvec,par.pla,pcondpla,qcondpla,"pla")
chkcopcond(uvec,vvec,param,pcondbskewncop21,qcondbskewncop21,"bskn")
chkcopcond(uvec,vvec,param,pcondbskewncop12,qcondbskewncop12,"bskn")
# should above two be the same?
chkcopcond(vvec,uvec,param,pcondbskewncop12,qcondbskewncop12,"bskn")

# looks OK


view_list <- function(list) {

  for (item in 1:length(list)) {

    print(head(list[[item]]))

  }
}

#' row-wise centering
#'
#' center the col of matrix x
#' @param x a matrix
#'
#' @keywords norm internal
center_colmeans <- function(x) {
  xcenter <- colMeans(x)
  x - rep(xcenter, rep.int(nrow(x), ncol(x)))
}

#' The 2norm or Frobenius norm function
#'
#'
#' @param x vector or matrix to calculate its 2norm or Frobenius norm
#' @return 2norm or Frobenius norm
#'
#' @keywords norm internal
norm_2 <- function(x) sqrt(sum(x^2))

#' Differencing matrix
#'
#' @param k number of coeficient to be diffed
#' @param m order of differencing
#'
#' @keywords
#'
diff_matrix <- function(k, m) {
  m_diff <- diag(k)
  while (m > 0) {
    m_diff <- diff(m_diff)
    m <- m - 1
  }
  if (is.vector(m_diff)) {
    m_diff <- t(m_diff)
  }
  return(m_diff)
}

#' P-spline basis
#'
#' Construct the $n \times K$ spline matrix using quiv-distant knots
#' $K = k_0 + m$
#'
#' @param x observations for the first covariate
#' @param k0 number of internal knots
#' @param m order of the basis splines
#' @param x_range range of the spline basis,
#'                default to be NULL then use the c(max, min)
#'
#' @import splines
#'
#' @return $n \times K$ spline matrix for the first covariate,
#'
spline_basis <- function(x, k0, m, x_range=NULL) {
  if (is.null(x_range)) {
    x_range <- c(max(x), min(x))
  }

  big <- x_range[1]; small <- x_range[2]
  h <- (big - small) / (k0 + 1)
  v_knots <- seq_len(k0) * h + small
  v_knots <- c(rep(small, m), v_knots, rep(big, m))
  out <- splines::splineDesign(v_knots, x, ord = m)
  return(out)
}


## This is free software and is offered with no warranty whatsoever.

##utility function returns true if n-m is odd

.odd <- function(n,m) {
  if (((n-m)%%2) == 0) {
    FALSE
  } else {
    TRUE
  }
}

##derivative (wrt r) of zernike polynomials
## Iterative version of recurrence relation
## given in Eqn. 13 of Mathworld Zernike article.

drzernike <- function(rho, n, m) {
    if ((n<0) || (m<0) || (n<m) || (.odd(n,m))) stop("Bad argument to drzernike")
    if ((n==0) && (m==0))return(0*rho)
    if (n==m) return(n*rho^(n-1))
    if (m==0) dr <- 0*rho else dr <- m*rho^(m-1)
    for (nn in seq(m+2, n, by=2)) {
        dr <- dr + nn*(rzernike(rho,nn-1,abs(m-1))+rzernike(rho,nn-1,m+1))
    }
    dr
}

### Zernike polynomial

Zernike <- function(rho, theta, n, m, t) {
    sqrt(n+1) * rzernike(rho, n, m) * switch(t, n=1, c=sqrt(2)*cos(m*theta),
	 s=sqrt(2)*sin(m*theta))
}

## make a list of radial and azimuthal indexes in extended Fringe sequence
## from order minorder to maxorder

makezlist <- function(minorder=0, maxorder=14) {
    n <- numeric()
    m <- numeric()
    t <- character(length=0)

    for (order in seq(minorder, maxorder, by=2)) {
        mmax <- order/2
        mtemp <- 0
        if (mmax > 0) {
          mtemp <- c(mtemp, rep(1:mmax, each=2))
        }
        mtemp <- rev(mtemp)
        n <- c(n, order-mtemp)
        m <- c(m, mtemp)
        t <- c(t, rep(c("c", "s"), mmax), "n")
    }
    list(n=n, m=m, t=t)
}

## Augmented Fringe set

zlist.fr <- makezlist(2,12)

## list of ZP indexes in ISO/ANSI sequence

#' Construct list of ZP indexes in ISO/ANSI sequence with sine terms first
#'
#' @param maxorder maximum radial and azimuthal order
#' @return a named list with n=radial indexes, m=azimuthal, and t indicating
#'  trig function to apply
#' @examples
#' zlist.iso <- makezlist.iso(maxorder=6)
#' zlist <- makezlist(0, 6)
makezlist.iso <- function(maxorder=12) {
  n <- numeric(0)
  m <- numeric(0)
  t <- "n"
  for (i in 0:maxorder) {
    n <- c(n, rep(i, i+1))
    m <- c(m, abs(seq(-i, i, by=2)))
    if (i >= 1) {
      t <- c(t, rep("s" , (i+1) %/% 2))
      if (i %% 2 == 0) {
        t <- c(t, "n")
      }
      t <- c(t, rep("c", (i+1) %/% 2))
    }
  }
  list(n=n, m=m, t=t)
}

## Vector of factors from conversion between "normalized" and conventional Zernike definitions

zmult <- function(zlist = makezlist()) {
    mult <- sqrt(zlist$n+1)
    mult[zlist$m > 0] <- sqrt(2)*mult[zlist$m > 0]
    mult
}

## create a matrix of Zernike polynomial values

zpm.arb <- function(rho, theta, phi=0, zlist=makezlist()) {
	zm <- matrix(0, nrow=length(rho), ncol=length(zlist$n))
	for (i in (1:length(zlist$n))) {
		zm[,i] <- Zernike(rho,theta-pi*phi/180, zlist$n[i], zlist$m[i], zlist$t[i])
	}
	colnames(zm) <- colnames(zm, do.NULL=FALSE, prefix="Z")
	zm
}

## a faster Zernike matrix fill

zpm <- function(rho, theta, phi=0, maxorder = 14, nthreads=parallel::detectCores()/2) {
  if (phi != 0) theta <- theta - pi*phi/180
  if (nthreads == 1) {
    zm <- zpmC(rho, theta, maxorder)
  } else {
    RcppParallel::setThreadOptions(numThreads = nthreads)
    zm <- zpmCP(rho, theta, maxorder)
  }
  colnames(zm) <- paste("Z",0:(ncol(zm)-1), sep="")
  zm
}

## fit zernikes to data

fitzernikes <- function(wf, rho, theta, phi=0, maxorder = 14,
                        nthreads=parallel::detectCores()/2, uselm=FALSE, isoseq=FALSE) {
  if (isoseq) {
    theta <- theta - pi * phi/180
    zm <- zpm_cart(x=rho*cos(theta), y=rho*sin(theta), maxorder=maxorder)
  } else {
    zm <- zpm(rho, theta, phi=phi, maxorder=maxorder, nthreads=nthreads)
  }
  zm.names <- colnames(zm)
  if (uselm) {
      fmla <- as.formula(paste("wf ~ -1 + ", paste(zm.names, collapse="+")))
      dataf <- data.frame(cbind(wf, zm))
      fit <- lm(fmla, data=dataf)
  } else {
      fit <- qr.solve(crossprod(zm),crossprod(zm, wf))
  }
  fit
}


library(RUnit)
errMsg <- function(err) print(err)
load('ex4-tests.rda')

# Suppose you are wondering whether your dataset contains duplicated
# variables. However, the dataset is too large to search through by hand (this
# would very likely be the case with microarray data). Implement the function
# "identifyDuplicates" that searches over each pair of variables to determine if
# one is a duplicate of the other. Your function should take the following
# arguments:
#
# <data>: a data frame where the columns correspond to variables and the rows to
# observations
#
# Your function should return:
#
# <duplicate.pairs>: an **unnamed matrix** (check out the documentation for
#   as.matrix and unname) with dimensions num.duplicates x 2 with each row giving
#   both indices of any pair of duplicated variables. Please organize this matrix
#   as follows:
#
#   1) the index in the first column should be the lower of the two for each row
#   2) the indicies in the first column should be arranged in increasing order
#      (this means that the indices in the second column may not be ordered)
#   3) pairs that suggest a variable is a duplicate of itself should not be
#      included
#   4) there should only be one reference to each duplicated pair
#   5)
#
# if there are no duplicated pairs, your function should return the value
# numeric(0)
#
# HINT: you might find the identical, upper.tri/lower.tri, and which (with
# arr.ind=T) functions helpful (though they are not the only ways to do this)

identifyDuplicates <- function(data) {

    # your code here
}

tryCatch(checkEquals(numeric(0), identifyDuplicates(ex4.test1)),
         error=function(err) errMsg(err))
tryCatch(checkIdentical(identify.duplicates.t, identifyDuplicates(ex4.test2)),
         error=function(err) errMsg(err))


require(rms)
require(rpart)
n <- 100
set.seed(1)
x1 <- runif(n)
x2 <- runif(n)
x3 <- runif(n)
y  <- 1*(x1+x2+rnorm(n) > 1)
table(y)
f <- rpart(y ~ x1 + x2 + x3, model=TRUE)
v <- validate(f)
v    # note the poor validation
par(mfrow=c(1,2))
plot(v, legendloc=c(.2,.5))
par(mfrow=c(1,1))

## From http://stackoverflow.com/questions/37053654   Rohan Adur
set.seed(4)
dat = data.frame(X1 = sample(x = c(1,2,3,4,5), size = 100, replace=TRUE))
dat$t = rexp(100, rate=dat$X1)
dat$t = dat$t / max(dat$t)
dat$e = rbinom(n = 100, size = 1, prob = 1-dat$t )

f = rpart(Surv(t, event = e) ~ X1 , data = dat, model=TRUE,
          control=rpart.control(minsplit=30, cp=0.01))
plot(f); text(f)
v <- validate(f)
v
plot(v, legendloc=c(.6,.2))


 DSTEV Example Program Results

 Eigenvalues
     0.6476  3.5470  8.6578 17.1477
 Eigenvectors
          1       2       3       4
 1   0.9396  0.3388  0.0494  0.0034
 2  -0.3311  0.8628  0.3781  0.0545
 3   0.0853 -0.3648  0.8558  0.3568
 4  -0.0167  0.0879 -0.3497  0.9326

 Error estimate for the eigenvalues
        3.8E-15

 Error estimates for the eigenvectors
        1.3E-15    1.3E-15    7.5E-16    4.5E-16


rsvd.checkargs <- function(x, k, q, retu, retvt)
{
  assert.type(retu, "logical")
  assert.type(retvt, "logical")

  assert.natnum(k)
  if (k > nrow(x))
    comm.stop("'k' must be no greater than nrow(x)")

  assert.natnum(q)

  ### TODO check for NA, NaN, Inf

  invisible(TRUE)
}

#' Random SVD
#'
#' @param x
#' The input data matrix.
#' @param k
#' The number of singular values and/or left/right singular vectors
#' to estimate.
#' @param q
#' An integer exponent, say 1, 2, or 3.  See the paper for details.
#' @param retu
#' Logical; should the left singular vectors ("U") be returned?
#' @param retvt
#' Logical; should the transposed right singular vectors ("VT") be returned?
#'
#' @return
#' A list cotaining the singular values, and, if requested, the
#' left and/or right singular vectors.
#'
#' @references
#' Halko, Martinsson, and Tropp. 2011. Finding structure with
#' randomness: probabilistic algorithms for constructing approximate
#' matrix decompositions. SIAM Review 53 217-288.
#'
#' @author
#' George Ostrouchov and Drew Schmidt
#'
#' @examples
#' \dontrun{
#' x <- matrix(rnorm(30), 10)
#'
#' rsvd(x)
#' }
#'
#' @keywords SVD PCA
#' @name rsvd
#' @rdname rsvd
#' @export
rsvd <- function(x, k=1, q=3, retu=TRUE, retvt=TRUE)
{
  rsvd.checkargs(x=x, k=k, q=q, retu=retu, retvt=retvt)

  if (class(x) != "ddmatrix")
    x <- as.matrix(x)

  k <- as.integer(k)
  q <- as.integer(q)

  ### Stage A from the paper
  n <- ncol(x)

  if (class(x) == "matrix")
    Omega <- matrix(runif(n*2L*k), nrow=n, ncol=2L*k)
  else if (class(x) == "ddmatrix")
    Omega <- ddmatrix("runif", nrow=n, ncol=2L*k, bldim=x@bldim, ICTXT=x@ICTXT)

  Y <- x %*% Omega
  Q <- qr.Q(qr(Y))

  for (i in 1:q)
  {
    Y <- crossprod(x, Q)
    Q <- qr.Q(qr(Y))
    Y <- x %*% Q
    Q <- qr.Q(qr(Y))
  }

  ### Stage B
  B <- crossprod(Q, x)

  if (!retu)
    nu <- 0
  else
    nu <- min(nrow(B), ncol(B))

  if (!retvt)
    nv <- 0
  else
    nv <- min(nrow(B), ncol(B))

  svd.B <- La.svd(x=B, nu=nu, nv=nv)

  d <- svd.B$d
  d <- d[1L:k]

  # Produce u/vt as desired
  if (retu)
  {
    u <- svd.B$u
    u <- Q %*% u

    u <- u[, 1L:k, drop=FALSE]
  }

  if (retvt)
  {
    vt <- svd.B$vt[1L:k, , drop=FALSE]
  }

  # wrangle return
  if (retu)
  {
    if (retvt)
      svd <- list(d=d, u=u, vt=vt)
    else
      svd <- list(d=d, u=u)
  }
  else
  {
    if (retvt)
      svd <- list(d=d, vt=vt)
    else
      svd <- list(d=d)
  }

  return( svd )
}


#!/usr/bin/env Rscript

# Using the mana curve suggested at https://f2k.gg/articles/2387_mtg-arena-introduction-to-the-sealed-deck-format
ideal.mana.curve <- c(
    1,
    2, 2, 2, 2, 2,
    3, 3, 3, 3,
    4, 4, 4, 4,
    5, 5, 5,
    6, 6)

ideal.mana.curve.low <- c(
    2, 2, 2, 2,
    3, 3, 3,
    4, 4, 4, 4,
    5, 5, 5,
    6, 6)

ideal.mana.curve.high <- c(
    1, 1,
    2, 2, 2, 2, 2, 2,
    3, 3, 3, 3, 3,
    4, 4, 4, 4,
    5, 5, 5,
    6, 6)

acceptable.mana.curve <- c(
    1, 1,
    2, 2, 2, 2, 2, 2,
    3, 3, 3,
    4, 4, 4, 4,
    5, 5, 5,
    6, 6,
    7, 7,
    8, 8)

bad.mana.curve <- c(
    1,
    2,
    3,
    4, 4, 4, 4,
    5, 5, 5, 5, 5, 5,
    6, 6,
    7, 7,
    8, 8, 8, 8, 8, 8)

costs <- c(1:8)

#### Plots ####
# Relative Frequency Histogram
hist(ideal.mana.curve, right = FALSE, prob = TRUE,
     main = "Ideal Mana Curve: Relative Frequency")

# Density plot
plot(density(ideal.mana.curve),
     main = "Ideal Mana Curve: Density Plot")

#### Idea: Relative frequency ####

ideal.low.relative.frequency <- table(ideal.mana.curve.low) / length(ideal.mana.curve.low)
ideal.relative.frequency <- table(ideal.mana.curve) / length(ideal.mana.curve)
ideal.high.relative.frequency <- table(ideal.mana.curve.high) / length(ideal.mana.curve.high)
acceptable.relative.frequency <- table(acceptable.mana.curve) / length(acceptable.mana.curve)
bad.relative.frequency <- table(bad.mana.curve) / length(bad.mana.curve)

#### Idea: Cumulative distribution function ####

# Ideal:
#   <= 1 CMC: 5% ± 5%
#   <= 2 CMC: 31% ± 5%
#   <= 3 CMC: 52% ± 5%
#   <= 4 CMC: 73% ± 5%
#   <= 5 CMC: 89% ± 5%

# cumsum(ideal.relative.frequency)
# cumsum(ideal.low.relative.frequency)
# cumsum(ideal.high.relative.frequency)
# cumsum(acceptable.relative.frequency)
# cumsum(bad.relative.frequency)

ecdf(ideal.mana.curve.low)(costs)
ecdf(ideal.mana.curve)(costs)
ecdf(ideal.mana.curve.high)(costs)
ecdf(acceptable.mana.curve)(costs)
ecdf(bad.mana.curve)(costs)

#### Idea: Percentiles ####
# Ideal:
#   16th percentile: 2 ± 1 converted mana cost
#   32th percentile: 2.76 ± 1 converted mana cost
#   48th percentile: 3 ± 1 converted mana cost
#   64th percentile: 4 ± 1 converted mana cost
#   80th percentile: 5 ± 1 converted mana cost
#   96th percentile: 6 ± 1 converted mana cost

# quantiles.of.interest <- c(0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9)
quantiles.of.interest <- c(0.16, 0.32, 0.48, 0.64, 0.80, 0.96)
# quantiles.of.interest <- c(0.20, 0.40, 0.60, 0.80)

# Ideal mana curves
quantile(ideal.mana.curve.low, probs = quantiles.of.interest)
quantile(ideal.mana.curve, probs = quantiles.of.interest)
quantile(ideal.mana.curve.high, probs = quantiles.of.interest)

# Ok mana curves
quantile(acceptable.mana.curve, probs = quantiles.of.interest)

# Bad mana curves
quantile(bad.mana.curve, probs = quantiles.of.interest)

game-logic/Sub-objective 2 scratch notes.r


# Example : 2   Chapter : 8.1     Page No: 414
# Find movements , tensions, elongations of spring
K1<-matrix(c(2,-1,0,-1,2,-1,0,-1,1),ncol=3)
K11<-solve(K1)
f<-c(1,1,1)
u<-K11%*%f
print("Movements are given by mg/c * u and u  is")
print(u)
A<-matrix(c(1,-1,0,0,1,-1,0,0,1),ncol=3)
e<-A%*%u
print("Elongations are given by mg/c * e and e is")
print(e)
y<-solve(t(A))%*%f
print("Tensions are given by mg * y and y is")
print(y)


#' @export
#' @title bufferCircle
#' @description This function buffers a point by a specified radius \code{n}.
#' @param \code{lonlat} = the position to buffer
#' @param \code{radius} = the radius in kilometers to buffer
#' @param \code{npoints} = number of discrete points to create (default is 100)
#' @return data.frame of 101 indivual points of $lat and $lon
#' @examples
#' bufferCircle(c(-64.15,44.75),100)
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export
bufferCircle <- function(lonlat, radius, npoints=100) {
	#//**radius must be in km, this treats the globe as a sphere**

		 Rearth <- 6378.137
	     Dd <- rep(radius / Rearth,npoints+1)

	     Cc <- seq(0, 2*pi, by=2*pi/npoints) #turning direction

	         lata <- lonlat[2] * (pi/180) #convert to radians
	         lona <- lonlat[1] * (pi/180)

	     latb <- asin(cos(Cc) * cos(lata) * sin(Dd) + sin(lata) * cos(Dd))
	     dlon <- atan2(cos(Dd) - sin(lata) * sin(latb), sin(Cc) * sin(Dd) * cos(lata))
	     lonb <- lona - dlon + pi/2

	     lonb[lonb >  pi] <- lonb[lonb >  pi] - 2 * pi
	     lonb[lonb < -pi] <- lonb[lonb < -pi] + 2 * pi

	     latb <- latb * (180 / pi) #back to lat lon
	     lonb <- lonb * (180 / pi)

	     out <- data.frame(lon = lonb, lat = latb)
	     return(out)
     }


# Since R is a vector based language that penalizes for loops, we will avoid
#     for-loops, instead using "apply" statement variants (like "map" in other
#     functional languages).

set.seed(19771025)   # set the seed to set the same results as this code
N <- 10000  # trials
true_answers <- sample(1:3, N, replace=TRUE)

# We can assme that the contestant always choose door 1 without any loss of
#    generality, by equivalence.  That is, we can always relabel the doors
#    to make the user-chosen door into door 1.
# Thus, the host opens door '2' unless door 2 has the prize, in which case
#    the host opens door 3.

host_opens <- 2 + (true_answers == 2)
other_door <- 2 + (true_answers != 2)

## if always switch
summary( other_door == true_answers )
## if we never switch
summary( true_answers == 1)
## if we randomly switch
random_switch <- other_door
random_switch[runif(N) >= .5] <- 1
summary(random_switch == true_answers)

## To go with the exact parameters of the Rosetta challenge, complicating matters....
##  Note that the player may initially choose any of the three doors (not just Door 1),
##     that the host opens a different door revealing a goat (not necessarily Door 3), and
##     that he gives the player a second choice between the two remaining unopened doors.

N <- 10000  #trials
true_answers <- sample(1:3, N, replace=TRUE)
user_choice <- sample(1:3, N, replace=TRUE)
## the host_choice is more complicated
host_chooser <- function(user_prize) {
    # this could be cleaner
    bad_choices <- unique(user_prize)
    # in R, the x[-vector] form implies, choose the indices in x not in vector
    choices <- c(1:3)[-bad_choices]
    # if the first arg to sample is an int, it treats it as the number of choices
    if (length(choices) == 1) {  return(choices)}
    else { return(sample(choices,1))}
}

host_choice <- apply( X=cbind(true_answers,user_choice), FUN=host_chooser,MARGIN=1)
not_door <- function(x){ return( (1:3)[-x]) }  # we could also define this
                                                # directly at the FUN argument following
other_door  <- apply( X = cbind(user_choice,host_choice), FUN=not_door, MARGIN=1)

## if always switch
summary( other_door == true_answers )
## if we never switch
summary( true_answers == user_choice)
## if we randomly switch
random_switch <- user_choice
change <- runif(N) >= .5
random_switch[change] <- other_door[change]
summary(random_switch == true_answers)


#loading the data
df = as.matrix(read.table('/home/smith/Downloads/nci.data.txt', header = FALSE , sep = "", dec = "."))
df2 = as.matrix(read.table('/home/smith/Downloads/label.txt', header = FALSE , sep = "", dec = "."))
scaled_data = scale(t(df))
r =nrow(scaled_data)
c = nrow(scaled_data)
#computing the pairwise differences
pair_diff = matrix(Inf ,nrow = r , ncol= c)
for (i in 1:r){
    for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2))
        }
    }
}
upper_tri = upper.tri(pair_diff)
pair_diff[upper_tri] = Inf   #making the reapeated distances infinity

cluster_matrix = matrix(ncol =nrow(scaled_data), nrow = nrow(scaled_data))
cluster_matrix[,1] = 1:64  #cluster matrix has all the cluster assignments from n to 1 cluster
sl_pair_diff = pair_diff
branch_length = vector(length = r-1)
#This for loop find the cluster assignments for single-linkage
for(m in 2:r){
    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(sl_pair_diff)
    r_min = which(sl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(sl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    while(cluster_matrix[c_min,m] == cluster_matrix[r_min,m]){
        sl_pair_diff[r_min,c_min] = Inf
        min_diff = min(sl_pair_diff)
        r_min = which(sl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
        c_min = which(sl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    }
    branch_length[m-1] = min_diff
    sl_pair_diff[r_min,c_min] = Inf
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))

}
sl_cluster_matrix = cluster_matrix
print(sl_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Compllete Linkage
# computing pair-wise distance again, this time using NaN value for unneeded redundancies
pair_diff = matrix(NaN ,nrow = r , ncol= c)
for (i in 1:r){
    for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2))
        }
    }
}
cluster_matrix = matrix(ncol =nrow(scaled_data), nrow = nrow(scaled_data))
cluster_matrix[,1] = 1:64
branch_length = vector(length = r-1)
cl_pair_diff = pair_diff
#This for loop find the cluster assignments for complete-linkage
for (m in 2:r){
    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = cluster_labels[,1]
    for(l in 1:length(already_clustered)){
        for(k in 1:length(already_clustered)){
            if(l!=k){
               cluster_value_1 = which(cluster_matrix[,m-1]==already_clustered[l])
               cluster_value_2 = which(cluster_matrix[,m-1]==already_clustered[k])
               comp_var =c(cluster_value_1,cluster_value_2)
               temp = max(cl_pair_diff[comp_var,comp_var], na.rm =TRUE)
               index = which(pair_diff ==temp,arr.ind =TRUE)
               cl_pair_diff[comp_var,comp_var] = NaN
               cl_pair_diff[index[1],index[2]]= temp
            }
        }
    }

    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(cl_pair_diff, na.rm =TRUE)
    r_min = which(cl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(cl_pair_diff == min_diff, arr.ind =TRUE)[1,2]
    branch_length[m-1] = min_diff
    cl_pair_diff[r_min,c_min] = NaN
    cl_pair_diff[c_min,r_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))

}
cl_cluster_matrix = cluster_matrix
print(cl_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Average Linkage

branch_length = vector(length = r-1)
cl_pair_diff = pair_diff
#This is an optional step of making redundant values zero,however, the loop already take cares of these values
upper_tri = upper.tri(cl_pair_diff)
cl_pair_diff[upper_tri] = NaN
#This for loop find the cluster assignments for average-linkage
for (m in 2:r){
    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = cluster_labels[,1]
    for(l in 1:length(already_clustered)){
        for(k in 1:length(already_clustered)){
            if(l!=k){
               cluster_value_1 = which(cluster_matrix[,m-1]==already_clustered[l])
               cluster_value_2 = which(cluster_matrix[,m-1]==already_clustered[k])
               cl_pair_diff[cluster_value_1,cluster_value_1] =NaN
               cl_pair_diff[cluster_value_2,cluster_value_2] =NaN
               comp_var =c(cluster_value_1,cluster_value_2)
               temp = (sum(cl_pair_diff[comp_var,comp_var], na.rm =TRUE))/(length(cluster_value_1)*length(cluster_value_2))
               #temp = temp/(length(cluster_value_1)*length(cluster_value_2))
               cl_pair_diff[comp_var,comp_var] = NaN
               cl_pair_diff[cluster_value_1,cluster_value_2] = temp
            }
        }
    }
    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(cl_pair_diff, na.rm =TRUE)
    r_min = which(cl_pair_diff ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(cl_pair_diff == min_diff, arr.ind =TRUE)[1,2]

    branch_length[m-1] = min_diff
    cl_pair_diff[r_min,c_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))
}
al_cluster_matrix = cluster_matrix
print(al_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#The next part is for implementaion of Centroid Linkage
#function to calculate distance
mydist<- function(scaled_data){
    r =nrow(scaled_data)
    c = nrow(scaled_data)
    pair_diff = matrix(NaN ,nrow = r , ncol= c)
    for (i in 1:r){
     for (j in 1:c){
        if(i!=j){
            pair_diff[i,j] = sqrt(sum((scaled_data[i,] - scaled_data[j,])^2 ,na.rm=TRUE))
        }
    }
}
    return(pair_diff)
}

#Next for loop find the cluster assignments for centroid-linkage
centroid_data = scaled_data
nullified = matrix(FALSE,r,c)  #This boolean matrix will keep track of the distances already used
for (m in 2:r){
    all_distance = mydist(centroid_data)
    diag(all_distance)= NaN
    upper_tri = upper.tri(all_distance)
    all_distance[upper_tri] = NaN
    all_distance[nullified] = NaN

    cluster_matrix[,m] = cluster_matrix[,m-1]
    min_diff = min(all_distance, na.rm = TRUE)
    r_min = which(all_distance ==min_diff , arr.ind =TRUE)[1,1]
    c_min = which(all_distance == min_diff, arr.ind =TRUE)[1,2]

    while(cluster_matrix[c_min,m] == cluster_matrix[r_min,m]){
        all_distance[r_min,c_min] = NaN
        min_diff = min(all_distance, na.rm = TRUE)
        r_min = which(all_distance == min_diff , arr.ind =TRUE)[1,1]
        c_min = which(all_distance == min_diff, arr.ind =TRUE)[1,2]
    }
    branch_length[m-1] = min_diff
    all_distance[r_min,c_min] = NaN
    cluster_matrix[,m][cluster_matrix[,m] == cluster_matrix[r_min,m]] = cluster_matrix[c_min,m]
    cluster_matrix[,m] = as.numeric(factor(cluster_matrix[,m]))
    nullified = is.nan(all_distance)

    cluster_labels = as.data.frame(table(cluster_matrix[,m-1]))
    already_clustered = as.numeric(as.matrix(cluster_labels[,1][cluster_labels[,2]>1]))

    for(l in 1:length(already_clustered)){
        cluster_value = which(cluster_matrix[,m-1]==already_clustered[l])
        if(length(cluster_value)>1)
        {
        total = colSums(scaled_data[cluster_value,])
        temp = total/length(cluster_value)
        centroid_data[cluster_value,] = temp
        }

    }

}

cent_cluster_matrix = cluster_matrix
print(cent_cluster_matrix)  #This is all cluster assignments at each level
print(branch_length)   #This is the height at each of N-1 steps

#applying K-means to our dataset
km_out = kmeans(scaled_data , 3 , nstart = 20)
table(df2 , km_out$cluster)

km_out = kmeans(scaled_data , 4 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 5 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 6 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 7 , nstart = 20)
table(df2 , km_out$cluster)
km_out = kmeans(scaled_data , 15 , nstart = 20)
table(df2 , km_out$cluster)

#comparing complete linkage and K-means both with clusters = 5
km_out = kmeans(scaled_data , 4, nstart = 20)
km_cluster = km_out$cluster
hc_cluster = cl_cluster_matrix[,61]
table(km_cluster, hc_cluster)


#' Calculate Standard Error of Mean
#'
#' @param x a numerical vector
#' @param na.rm a logical value whether we remove N/A value
#'
#' @return a numeric which is a statndard error of mean
#'
#' @importFrom stats na.omit
#' @importFrom stats var
#'
#' @export
#+
se <- function(x, na.rm = FALSE) {

  # na.rm = TRUE, we remove NA using na.omit()
  if (na.rm) x <- na.omit(x)

  # calculate and return se
  sqrt(var(x) / length(x))
}

#' Summary table of variables
#'
#' @description This is alternative method of `summary()`
#'     for countable or continuous vairbales.
#'     Since this function returns a data frame,
#'     you can pass some output format function (e.g. `kable`) easily.
#'
#' @param data a `data.frame` object.
#' @param vars a character vector of variables.
#' @param stat a character vector of statisics.
#'     "mean" is an average, "se" is its standard errors,
#'     "sd" is a standard error, "min" is minimum, "max" is maximum,
#'     "q25" is a first quantile, "median" is median, "q75" is a third quantile.
#'     "sum" is a sum of variable, and "N" is sample size.
#'
#' @return an object whose class is `data.frame`
#'
#' @importFrom dplyr summarize_at
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom tidyr pivot_longer
#' @importFrom tidyselect everything
#' @importFrom magrittr %>%
#'
#' @export
#+
statvars <- function(
    data, vars,
    stat = c(
        "mean", "se", "sd", "min", "q25", "median", "q75", "max", "sum", "N"
    )
) {

  tab <- data %>%
    summarize_at(
      vars,
      list(
        mean = ~mean(., na.rm = TRUE),
        se = ~se(., na.rm = TRUE),
        sd = ~sd(., na.rm = TRUE),
        min = ~min(., na.rm = TRUE),
        q25 = ~quantile(., prob = .25, na.rm = TRUE),
        median = ~median(., na.rm = TRUE),
        q75 = ~quantile(., prob = .75, na.rm = TRUE),
        max = ~max(., na.rm = TRUE),
        sum = ~sum(., na.rm = TRUE),
        N = ~sum(!is.na(.))
      )
    )

    if (length(vars) == 1) {

        tab <- tab %>%
          mutate(vars = vars) %>%
          select(c("vars", stat))

    } else {

        pattern <- "(.*)_(mean|se|sd|min|q25|median|q75|max|sum|N)"

        tab <- tab %>%
          pivot_longer(
            everything(),
            names_to = c("vars", ".value"),
            names_pattern = pattern
          ) %>%
          select(c("vars", stat))

    }

    return(tab)

}


# Preliminaries
#-------------------------------------------------
#install.packages('perm')
library(perm)
rm(list = ls())

# Fisher
#-------------------------------------------------

#permutations in a matrix
perms <- chooseMatrix(8, 4)
#observed values in treated [0,1,0,0,0,1,1,1]
A <- matrix(c(0.462, 0.731, 0.571, 0.923, 0.333, 0.750, 0.893, 0.692), nrow=8, ncol=1, byrow=TRUE)
treatment_avg <- (1/4)*perms%*%A
control_avg <- (1/4)*(1-perms)%*%A
test_statistic <- abs(treatment_avg-control_avg)
rownumber <- apply(apply(perms, 1,
                         function(x) (x == c(0, 1, 0, 0, 0, 1, 1, 1))),
                   2, sum)
rownumber <- (rownumber == 8)
observed_test <- test_statistic[rownumber == TRUE]

#number of test statistics greater or equal the statistic observed
larger_than_observed <- (test_statistic >= observed_test)
sum(larger_than_observed)

df <- data.frame(perms, control_avg, treatment_avg, test_statistic)

# Fisher, large number (simulation by random instead of permutation)
#-------------------------------------------------
simul_stat <- as.vector(NULL)
schools <- read.csv('teachers_final.csv')
set.seed(1001)
for(i in 1:1000) {
  print(i)
  schools$rand <- runif(100,min=0,max=1)
  schools$treatment_rand <- as.numeric(rank(schools$rand)<=49)
  schools$control_rand = 1-schools$treatment_rand
  simul_stat <-append(simul_stat,
            sum(schools$treatment_rand*schools$open)/sum(schools$treatment_rand)
            - sum(schools$control_rand*schools$open)/sum(schools$control_rand))
}

schools$control = 1-schools$treatment
actual_stat <- sum(schools$treatment*schools$open)/sum(schools$treatment) - sum(schools$control*schools$open)/sum(schools$control)
sum(abs(simul_stat) >= actual_stat)/NROW(simul_stat)
#the result it's near to zero, so we need Neyman's

# Neyman
#---------------------------------------------------
#Printing the ATE
ate <- actual_stat
ate

control_mean <- sum(schools$control*schools$open)/sum(schools$control)
treatment_mean <- sum(schools$treatment*schools$open)/sum(schools$treatment)

#sample variances for treatment and control
s_c <- (1/(sum(schools$control)-1))*sum(((schools$open-control_mean)*schools$control)^2)
s_t <- (1/(sum(schools$treatment)-1))*sum(((schools$open-treatment_mean)*schools$treatment)^2)

#formula to get neyman variance
Vneyman <- (s_c/sum(schools$control) + s_t/sum(schools$treatment))
print(sqrt(Vneyman))

#t-statistic
print(actual_stat/sqrt(Vneyman))
t_stat <- actual_stat/sqrt(Vneyman)

#p-value
print(2 * (1 - pnorm(t_stat))) #near to zero

#confident interval for 95%
print(actual_stat-1.96*sqrt(Vneyman))
print(actual_stat+1.96*sqrt(Vneyman))

### Plotting Kernel Regression ###
# (using np, ggplot doesn't have kernel regression)
#install.packages('np')
library(np)
bw_004 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 0.04)
plot(bw_004)
bw_0001 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 0.001)
plot(bw_0001)
bw_1 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 1)
plot(bw_1)
bw_20 = npreg(xdat=schools$open, ydat=schools$pctpostwritten, bws = 20)
plot(bw_20)

### Plotting CDFs to know FSD ###
#CDF: cumulative density function
#FSD: first stochastic dominate
library(tidyverse)

#Incorrect way
cdf_treatment = ecdf(schools$treatment*schools$teacherscore)
cdf_control = ecdf(schools$control*schools$teacherscore)
#plot(cdf_treatment, col='blue')
plot.ecdf(schools$treatment*schools$teacherscore, col='blue')
lines(cdf_control, col='red')

#Correct way
schools$group[schools$treatment==1] <-"T"
schools$group[schools$treatment==0] <-"C"
ggplot(schools, aes(pctpostwritten,colour = group)) + stat_ecdf()


# Moving (rolling) averages: SMA, WMA, EMA in R

install.packages("quantmod") # instalujemy biblioteke
library(quantmod) # uruchamiamy ^ biblioteke

# przyklad 1 dla Idea Bank SA

start <- as.Date("2019-01-01") # data, od ktorej pobieramy dane; YYYY-MM-DD
end <- as.Date("2019-05-01") # data, do ktorej pobieramy dane; YYYY-MM-DD

getSymbols("IDA.WA", src = "yahoo", from = start, to = end) # pobieramy dane nt. Idea Bank SA z Yahoo Finance (symbol w Yahoo Finance: IDA.WA; https://is.gd/Q82Ck2); wartosci w PLN

head(IDA.WA) # sprawdzamy czy zaciagnelismy dobre dane

candleChart(IDA.WA, up.col = "green", dn.col = "red", theme = "white", name = "Idea Bank SA") # rysujemy wykres swiecowy
addSMA(n = 14, col = "blue") # rysujemy SMA z ostatnich 14 dni, kolor linii niebieski
addWMA(n = 14, col = "black") # rysujemy WMA z ostatnich 14 dni, kolor linii czarny
addEMA(n = 14, col = "orange") # rysujemy EMA z ostatnich 14 dni, kolor linii pomaranczowy

SMA(IDA.WA[,-c(1,2,3,5,6)], n = 14) # obliczenie SMA; wykluczamy wszystkie kolumny oprocz tej z danymi, ktore nas interesuja tj. 4: IDA.WA.Close

# przyklad 2 dla IBM

start <- as.Date("2009-01-01")
end <- as.Date("2019-01-01")

getSymbols("IBM", src = "yahoo", from = start, to = end) # wartosci w USD

candleChart(IBM, up.col = "green", dn.col = "red", theme = "white")
addSMA(n = 90, col = "blue") # rysujemy SMA z ostatnich 90 dni
addWMA(n = 90, col = "black")
addEMA(n = 90, col = "orange")

EMA(IBM[,-c(1,2,3,5,6)], n = 90) # EMA z ostatnich 90 dni


# GLAJENJE ČASOVNIH VRST
# Finančni praktikum 2020/21
# Mitja Mandić

#PRVA NALOGA

#uvoz in obdelava podatkov
platina <- read.csv("cetrta_naloga/platina20.csv")

platina_zakljuceni <- platina$Close

platina_zakljuceni <- gsub(",", "", platina_zakljuceni)
platina_zakljuceni <- gsub("\\$", "", platina_zakljuceni)

#podatki do sredine maja 2020

dolzina <- 129

platina_zakljuceni <- as.numeric(rev(platina_zakljuceni[1:dolzina]))

graf_platina <- ts.plot(platina_zakljuceni, ylab = "Cena")
title("Platina")

#DRUGA NALOGA

#druga a
G <- function(vrsta, k) {

  glajene_vr <- c()
  #seštevamo delne vsote časovne vrste in jih delimo s k
  for (i in k:length(vrsta)) {
    glajene_vr[i] <- (1/k) * sum(vrsta[(i-k+1):i])
  }

  return(ts(glajene_vr))
}

#glajenje reda 7, k = 7

glajena.7 <- G(platina_zakljuceni, 7)

naslednji_dan <- glajena[length(glajena)]

ts.plot(platina_zakljuceni,glajena.7, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 7")

#druga d

#standardna kvadratična napaka
MSE.7 <- sum((platina_zakljuceni[8:dolzina-1]-glajena.7[8:dolzina-1]) ^ 2) / (dolzina - 7)

#postopek ponovljen še za reda k = 14 in k = 30
#k = 14
glajena.14 <- G(platina_zakljuceni,14)

ts.plot(platina_zakljuceni, glajena.14, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 14")
glajena.14.graf <- recordPlot

MSE.14 <- sum((platina_zakljuceni[15:dolzina-1]-glajena.14[15:dolzina-1]) ^ 2) / (dolzina - 14)

#k = 30
glajena.30 <- G(platina_zakljuceni,30)

ts.plot(platina_zakljuceni, glajena.30, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 30")
glajena.30.graf <- recordPlot()

MSE.30 <- sum((platina_zakljuceni[31:dolzina-1]-glajena.14[31:dolzina-1]) ^ 2) / (dolzina - 31)

par(mfrow = c(2,2))
ts.plot(platina_zakljuceni,glajena.7, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 7")
ts.plot(platina_zakljuceni, glajena.14, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 14")
ts.plot(platina_zakljuceni, glajena.30, ylab = "Cena", col = c("black", "red"))
title("Glajenje reda 30")

#TRETJA NALOGA

#eksponentno glajenje

EG <- function(vrsta, alpha){
  l <- c()
  #začetna vrednost se ujema s prvo vrednostjo iz časovne vrste
  l[1] <- vrsta[1]
  for (i in 2:length(vrsta)){
    #rekurzivna formula za računanje naprej
    l[i] <- alpha * vrsta[i] + (1-alpha) * l[i-1]
  }
  return(ts(l))
}

#izbral sem vrednost 0.2, izračunal eksponentno glajeno vrsto.
EG.02 <- EG(platina_zakljuceni, 0.2)

ts.plot(EG.02, platina_zakljuceni, col = c("red", "black"), ylab = "Cena")
title("Eskponentno glajenje")


int2str <- function(x, b) {
	if(x==0) return("0")
	if(x<0) return(paste0("-", base(-x,b)))

	map <- c(as.character(0:9), letters)
	res <- ""
	while (x>0) {
		res <- c(map[x %% b + 1], res)
		x <- x %/% b
	}
	return(paste(res, collapse=""))
}

str2int <- function(s, b) {
	map <- c(as.character(0:9), letters)
	s <- strsplit(s,"")[[1]]
	res <- sapply(s, function(x) which(map==x))
	res <- as.vector((res-1) %*% b^((length(res)-1):0))
	return(res)
}

## example: convert 255 to hex (ff):
int2str(255, 16)

## example: convert "1a" in base 16 to integer (26):
str2int("1a", 16)


library(dplyr)
library(ggplot2)
library(ggrepel)

refres <- read.csv("full_res_ref8.csv")

tylm<-lm(formula=percYes~percTurnout, data=refres, weights=refres$Electorate)

summary(tylm)

refres$lmpred <- predict(tylm)
pval <- round(summary(tylm)$coefficients[2,4], digits=3)
rsq <- round(summary(tylm)$r.squared, digits=4)

(p= ggplot(refres, aes(x=percTurnout, y=percYes, label=Constituency, fill=Verdict))+
    geom_line(aes(y=lmpred), colour="blue",size=2, alpha=0.3, linetype=2)+
    geom_point(aes(size=Total_poll), shape=21)+
    geom_text_repel(direction='y', size=3)+
    scale_size_continuous(name="Votes cast")+
    theme_minimal()+
    xlab("Turnout (%)")+
    ylab("Yes vote (%)")+
    scale_fill_manual(values=c("red3", "forest green"))+
    ggtitle("Turnout and Yes votes are correlated", subtitle="Ireland's 8th amendment referendum \ngraphling.org")+
    annotate("text", x=73, y=50, label=paste0("R-squared: ",   rsq,
                                              "\np-value: ", pval) ))

ggsave("turnoutvsvote.png", plot=p, device="png", height=8, width=10,dpi=300)


## Table 11.5, DeGroot (4th ed.)
boiling.pt <- read.csv(file = "dados_ponto_fervura.csv")
head(boiling.pt)

## Ajustando o modelo
linmod <- lm(pressao ~ pt_fervura, data = boiling.pt)
summary(linmod)

### plotting code taken from https://rstudio-pubs-static.s3.amazonaws.com/71339_d0b8346f41314979bc394448c5d60d86.html
temp_var <- predict(linmod, interval = "prediction")
new_df <- cbind(boiling.pt, temp_var)

library(ggplot2)
p0 <- ggplot(new_df, aes(pt_fervura, pressao))+
  geom_point() +
  scale_x_continuous("Ponto de fervura da água (ºF)") +
  scale_y_continuous("Pressão atmosférica (inHG)")  +
  theme_bw(base_size = 16)
p0

p1 <- p0 +
  geom_line(aes(y = lwr), color = "red", linetype = "dashed")+
  geom_line(aes(y = upr), color = "red", linetype = "dashed")+
  geom_smooth(method=lm, se = TRUE) +
  theme_bw(base_size = 16)

p1


# Example : 3   Chapter : 4.1     Page No: 197
# Rows of given matrix are perpendicular to the vector in nullspace
A<-matrix(c(1,5,3,2,4,7),nrow=2)
x<-c(1,1,-1)
for(i in 1:nrow(A)){
  dot_product<-sum(A[i,]*x)
  if(dot_product==0){
    print(paste("Row ",i,"is perpendicular to x"))
  }
}