#' Best modeling subset
#'
#' This function attempts to optimize a subset of variables for modeling based on given criteria with a genetic algorithm.  The use case is intended for situations where stepwise variable selection is either not likely to result in the best model or is impractical.
#'
#' @param dv A vector or matrix of dependent variable(s) for the model.
#' @param ivs A matrix containing the indepdendent variables on which the model is to be based.
#' @param buildModel A function which actually creates the model such as lm().
#' @param fitnessMetric A function taking the model built by buildModel and returns a numeric value specifying a model's fitness -- e.g. the model's variance, R^2, or AUC.  In Darwinian terms, metric will be used to determine the "fitness" of the model to survive and procreate.
#' @param likelihoodFn A function which takes the fitness metrics created by fitnessMetric and provides the probability of that fitness metric being selected for the next generation.  The two likelihood functions invLog() and squared() are examples provided to choose smaller and larger values, respectively.
#' @param minimize_fitness_metric This parameter specifies whether the fitness metric is to be minimized (TRUE) or maximized (FALSE).
#' @param n_generations The maximum number of generations to run the simulation.
#' @param n_genes The number of independent "organisms" to create in every generation for crossover or breeding.
#' @param mutation_rate The percentage chance for every variable to be flipped after crossover.  Higher values give higher volatility between generations and vice versa.
#' @param elitism_rate The rate at which best performers are to be kept, in order to prevent regression between generations.  The top elitism_rate percent will be preserved unchanged.
#' @param VERBOSE This parameter will provide output as to the progress.  The default, FALSE, will output none.
#' @param ... Any parameters needed to be passed to the given buildModel function can be added here.
#'
#' @return The function returns a vector containing the columns of the independent variables to use in the best subset found.
#'
#' @examples
#' modelSigma <- function(fitted_model) {
#'     summary(fitted_model)$sigma
#' }
#'
#' # Minimize the error variance of a linear model for given data
#' min_subset <- bestSubset(my_response, my_data, buildModel=lm,
#'                          fitnessMetric=modelSigma, likelihoodFn=invLog,
#'                          n_generations=250, n_genes=50, mutation_rate=0.005)
#'
#' # Take only the columns specified by bestSubset()
#' selected_data <- my_data[, min_subset]
#' best_model <- lm(dv ~ ., data=selected_data)
#'
#' @export
bestSubset <- function(dv, ivs, buildModel, fitnessMetric, likelihoodFn,
                       minimize_fitness_metric=T, n_generations=100,
                       n_genes=50, mutation_rate=0.01, elitism_rate=0.01,
                       VERBOSE=FALSE, ...) {

  init_generation <- generateInitGeneration(buildModel, fitnessMetric, n_genes,
                                            dv, ivs, ...)
  genes <- init_generation[['genes']]
  fitness_metrics <- init_generation[['fitness_metrics']]

  # TODO -- check gradients to stop automatically
  for (i in seq(1, n_generations)) {
    genes <- selectGenes(genes, likelihoodFn, fitness_metrics,
                         minimize_fitness_metric, mutation_rate,
                         elitism_rate)
    fitness_metrics <- geneMetrics(buildModel, fitnessMetric, genes, dv, ivs, ...)

    if (VERBOSE) print(paste0("Generation ", i, " done."))
  }

  best_subset_index <- if (minimize_fitness_metric) which.min(fitness_metrics)
                       else which.max(fitness_metrics)
  best_subset_cols <- which(genes[best_subset_index, ] == 1)

  best_subset_cols
}

generateInitGeneration <- function(buildModel, fitnessMetric, n_genes, dv, ivs, ...) {

  generateGene <- function() {
    rbinom(p, 1, 0.5)
  }

  p <- ncol(ivs)
  genes <- generateGene()

  for (i in seq(2, n_genes)) {
    genes <- rbind(genes, generateGene())
  }

  fitness_metrics <- geneMetrics(buildModel, fitnessMetric, genes, dv, ivs, ...)

  list(genes=genes, fitness_metrics=fitness_metrics)
}

geneMetrics <- function(buildModel, fitnessMetric, genes, dv, ivs, ...) {
  gene_row_iter <- seq(1, nrow(genes))

  foreach(gene_row_index=gene_row_iter,
          .combine=c, .inorder=TRUE) %dopar% {
    used_variables <- genes[gene_row_index, ]
    fitness(dv, ivs, buildModel, fitnessMetric, used_variables, ...)
  }
}

selectGenes <- function(genes, likelihoodFn, fitness_metrics,
                        minimize_fitness_metric, mutation_rate,
                        elitism_rate) {

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

  n_elites <- ceiling(n * elitism_rate)

  new_genes <- if (n_elites > 0) {
                   order_decreasing <- if (minimize_fitness_metric) FALSE
                                       else TRUE
                   elite_rows <- head(order(fitness_metrics,
                                            decreasing=order_decreasing),
                                      n=n_elites)
                   genes[elite_rows, ]
                 }
                 else NULL

  selection_probabilities <- selectionProbabilities(likelihoodFn,
                                                    fitness_metrics)

  for (i in seq(n_elites + 1, n)) {
    parent_indexes <- sample(seq(1, n), 2, replace=T,
                             prob=selection_probabilities)
    offspring <- crossover(genes[parent_indexes[1], ],
                           genes[parent_indexes[2], ],
                           mutation_rate)
    new_genes <- if (is.null(new_genes)) offspring
                 else rbind(new_genes, offspring)
  }

  new_genes
}

selectionProbabilities <- function(likelihoodFn, fitness_metrics) {
  likelihoods <- likelihoodFn(fitness_metrics)
  total_likelihoods <- sum(likelihoods)
  selection_probabilities <- likelihoods / total_likelihoods

  selection_probabilities
}

crossover <- function(father, mother, mutation_rate) {
  p <- length(father)
  parents <- list(father, mother)

  offspring <- sapply(
    seq(1, p),
    function(i) {
      donor_selection <- rbinom(1, 1, 0.5) + 1
      parents[[donor_selection]][i]
    }
  )

  mutation_vector <- rbinom(p, 1, mutation_rate)
  offspring <- (offspring + mutation_vector) %% 2

  offspring
}

fitness <- function(dv, ivs, buildModel, fitnessMetric, used_variables, ...) {

  used_ivs <- subset(ivs, select=which(used_variables == 1))

  no_chosen_variables <- sum(used_variables) == 0
  fitted_model <-
    if (no_chosen_variables) {
      buildModel(dv ~ 1, ...)
    }
    else {
      buildModel(dv ~ ., data=used_ivs, ...)
    }

  fitnessMetric(fitted_model)
}

#' Inverse log likelihood function
#'
#' The inverse log function is for use as the "likelihoodFn" in bestSubset().  It will be greatest with smaller input values and is useful for minimizing model descriptive statistics such as error variance or prediction error. NOTE: minimize_fitness_metric in bestSubset() should be set to TRUE (the default) when using this likelihood function.
#'
#' @param fitness_metrics These metrics will be provided automatically by the fitnessMetric parameter in bestSubset()
#'
#' @return The function returns a vector with the inverse log of the given vector.
#'
#' @examples
#' See help for bestSubset()
#'
#' @export
invLog <- function(fitness_metrics) {
  1 / log(fitness_metrics)
}

#' Squared likelihood function
#'
#' The squared function is for use as the "likelihoodFn" in bestSubset().  It will be greatest with larger input values and is useful for maximizing model descriptive statistics such as AUC, area under the ROC curve, or R^2. NOTE: minimize_fitness_metric in bestSubset() should be set to FALSE when using this likelihood function.
#'
#' @param fitness_metrics These metrics will be provided automatically by the fitnessMetric parameter in bestSubset()
#'
#' @return The function returns a vector with the squared values of the given vector.
#'
#' @examples
#' See help for bestSubset()
#'
#' @export
squared <- function(fitness_metrics) {
  fitness_metrics ^ 2
}


mean mean<- 15.28
var <- 9.07

domanda1_a <- 13.92
domanda1_b <- 16.19
domanda2 <- 10.87
domanda3 <- 12.85

sd <- sqrt(var)
x <- seq(mean-5, mean+5, length.out = 100)

risposta1 <- pnorm(mean = mean, sd = sd, q = c(domanda1_a,domanda1_b))
risposta2 <- pnorm(mean = mean, sd = sd, q = domanda2)
risposta3 <- c(pnorm(mean = mean, sd = sd, q = -domanda3),
               pnorm(mean = mean, sd = sd, q = domanda3))

plot(x, dnorm(mean = mean, sd = sd, x = x), type="l")
print(risposta1[2]-risposta1[1])
print(risposta2)
print( risposta3[1] + (1-risposta3[2]))


suppressMessages(library(craze))

x = matrix(as.double(1:30), 10)
y = matrix(as.double(1:9), 3)

x_fml = fmlmat(x)
y_fml = fmlmat(y)

test = as.matrix(x_fml %*% y_fml)
truth = x %*% y
stopifnot(all.equal(test, truth))


# Function that returns the Proba-V tile number when given a set of coordinates
ProbaVTileID = function(point)
{
    # X00Y00 is -180.0005, -170.0005,  65.0005,  75.0005  (xmin, xmax, ymin, ymax)
    # X12Y13 is  -60.0005,  -50.0005, -64.9995, -54.9995
    # X17Y03 is  -10.0005,   -0.0005,  35.0005,  45.0005
    # X18Y04 is   -0.0005,    9.9995,  25.0005,  35.0005
    # X18Y06 is   -0.0005,    9.9995,   5.0005,  15.0005
    # X18Y07 is   -0.0005,    9.9995,  -4.9995,   5.0005
    # X35Y12 is  169.9995,  179.9995, -54.9995, -44.9995
    # Point 0,0 is at X18Y07

    # xmin: -180.0005 + 10 * X
    # xmax: xmin + 10
    # ymin:   65.0005 - 10 * Y
    # ymax: ymin + 10

    # Inversion: (180.0005 + xmin)/10 = X
    XID = as.integer((180.0005 + point$x)/10)
    # Inversion:  (75.0005 - ymin)/10 = Y
    YID = as.integer((75.0005 - point$y)/10)

    return(sprintf("X%02dY%02d", XID, YID))
}

# Africa is from X16Y03 to X23Y10


x <- 2
y <- 3
print(x+y)
install.packages("swirL")
install.packages("swirl")
install.packages("rafalib")
install.packages("downloader")
library(rafalib)
library(downloader)
getwd()
ls
setwd("~/repos/RLifeSciences")
savehistory("~/repos/RLifeSciences/worklog3.r")
ls
library(devtools)
install_github("genomicsclass/GSE5859Subset")
library(GSE5859Subset)
data(GSE5859Subset) # Loads the three tables
dim(geneExpression)
dim(SampleInfo)
dim(sampleInfo)
head(sampleInfo)
sampleInfo$group
match(sampleInfo$filename,colnames(geneExpression))
dim(geneAnnotation)
head(geneAnnotation)
head(match(geneAnnotation$PROBEID,rownames(geneExpression)))
2*(1-pnorm(Z))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv"))
read.csv("femaleControlsPopulation.csv")
set.seed(1)
population = unlist(read.csv("femaleControlsPopulation.csv"))
N <- 12
B <- 10000
pvals <- replicate(B,{})
pvals <- replicate(B,{
control = sample(population,N)
treatment = sample(population,N)
t.test(treatment,control)$p.val
})
hist(pvals)
# Thousands of Tests
g <- sampleInfo$group
g
e <- geneExpression[25,]
library(rafalib)
mypar(1,2)
qqnorm(e[g==1])
qqline(e[g==1])
qqnorm(w[g==0])
qqnorm(e[g==0])
qqline(e[g==0])
t.test(e[g==1],e[g==0])$p.value
myttest <- function(x)
t.test(x[g==1],x[g==0],var.equal=TRUE)$p.value
pvals <- apply(geneExpression,1,myttest)
sum(pvals<0.05)
# performing 8000 ttest on data where the null hypothesis is true
set.seed(1)
m <- nrow(geneExpression)
n <- ncol(geneExpression)
randomData <- matrix(rnorm(n*m),m,n)
nullpvals <- aplly(randomData,1,mytest)
nullpvals <- apply(randomData,1,mytest)
nullpvals <- apply(randomData,1,myttest)
sum(nullpvals<0.05)
# More efficient ttest implementation
install_bioc("genefilter")
install_bioc("genefilter")
# Procedures
# response to Multiple Testing Problem
# Define a Procedure then estimate or Control an informative Error Rate
# Guarantee an error rate below a predefined value
# Procedures have flexibility through parameters and cutoffs that let us control specificity and sensitivity
# Error rates
sum(pvals<0.05)
set.seed(1)
population = unlist(read.csv("femaleControlPopulation.csv"))
population = unlist(read.csv("femaleControlsPopulation.csv"))
alpha <- 0.05
N <- 12
m <- 10000
pvals <- replicate(m,{
control = sample(population,N)
treatment = sample(population,N)
t.test(treatment,control)$p.value})
sum(pvals<0.05)
alpha <- 0.05
N <- 12
m <- 10000
p0 <- 0.90 #10% of diests work, 90% don't
m0 <- m*p0
m1 <- m-m0
nullHypothesis <- c(rep(TRUE,m0),rep(FALSE,m1))
delta  <- 3
set.seed(1)
calls <- sapply(1:m, function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment+ delta
ifelse(t.test(treatment,control)$p.value < alpha, "Called Significant", "Not Called Significant")})
null_hypothesis <- factor(nullHypothesis, levels=c("TRUE","FALSE"))
table(null_hypothesis,calls)
B <- 10 ##number of simulations
VandS <- replicate(B,{
calls <- sapply(1:m, function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.val < alpha})
cat("V =",sum(nullHypothesis & calls), "S =",sum(!nullHypothesis & calls), "\n")
c(sum(nullHypothesis & calls), sum(!nullHypothesis & calls))
})
## this is used to motivate the Family Wise Error Rate
## Leading to
# The Bonferroni Correction
B <- 10000
minpval <- replicate(B,min(runif(10000,0,1))<0.01)
mean(minpval>=1)
set.seed(1)
pvals <- sapply(1:m,function(i){
control <- sample(population,N)
treatment <- sample(population,N)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.value})
sum(pvals < 0.05/10000)
# False Discovery Rate
savehistory("~/repos/RLifeSciences/worklog3.r")
head(population)
population <- unlist(read.csv("femaleControlsPopulation.csv"))
set.seed(1)
pvals <- sapply(1:m, function(i){
control  <- sample(population,6)
treatment <- sample(population,6)
if(!nullHypothesis[i]) treatment <- treatment + delta
t.test(treatment,control)$p.value
})
m <- 10000
N <- 12
p0 <- 0.90
m0 <- m*p0
m1 <- m-m0
delta <- 3
nullHypothesis <- c(rep(TRUE,m0), rep(FALSE,m1))
set.seed(1)
pvals <- sapply ( 1 : m , function ( i ){
control <- sample ( population , 6 )
treatment <- sample ( population , 6 )
if ( ! nullHypothesis [ i ]) treatment <- treatment + delta
t.test ( treatment , control ) $ p.value
})
sum(pvals < 0.05/10000)
library(genefilter) ##rowtests is here
library(rafalib)
install.packages(genefilter)
source("https://bioconductor.org/biocLite.R")
biocLite("genefilter")
library(genefilter)
set.seed(1)
## Define groups to be used with rowttests
g <- factor( c(rep(0,N),rep(1,N)) )
B <- 1000 # number of simulations
Qs <- replicate(B,{
## matrix with control data (rows are tests, columns are mice)
controls <- matrix(sample(population, N*m, replace=TRUE),nrow=m)
## matrix with control data (rows are tests, columns are mice)
treatments <- matrix(sample(population, N*m, replace=TRUE),nrow=m)
## add effect to 10% of them
treatments[which(!nullHypothesis),] <- treatments[which(!nullHypothesis),]+delta
## combine to form one matrix
dat <- cbind(controls,treatments)
calls <- rowttests(dat,g)$p.value < alpha
R=sum(calls)
Q=ifelse(R>0,sum(nullHypothesis & calls)/R,0)
return(Q)
})
savehistory("~/repos/RLifeSciences/worklog3.r")
library(rafalib)
mypar(1,1)
hist(Qs) ## Q is a random variable, this is its distribution
FDR=mean(Qs)
print(FDR)
set.seed(1)
savehistory("~/repos/RLifeSciences/worklog3.r")
controls <- matrix(sample(population, N*m, replace=TRUE), nrow=m)
treatments <- matrix(sample(population,N*m,replace=TRUE),nrow=m)
treatments[which(!nullHypotesis),] <- treatments[which(!nullHypothesis),]+delta
treatments[which(!nullHypothesis),] <- treatments[which(!nullHypothesis),]+delta
dat <- cbind(controls,treatments)
pvals <- rowtests(dat,g)$p.value
h <- hist(pvals,breaks=seq(0,1,0.05))
polygon(c(0,0.05,0.05,0),c(0,0,h$counts[1],h$counts[1]),col="grey")
abline(h=m0/20)
# The grey bar on left represents cases with p-values less than 0.05. The horizontal line is the level of false positives.
h <- hist(pvals,breaks=seq(0,1,0.01))
polygon(c(0,0.01,0.01,0),c(0,0,h$counts[1],h$counts[1]),col="grey")
abline(h=m0/100)
# Benjamini-Hochberg
alpha <- 0.05
1 = seq(along=pvals)
i = seq(along=pvals)
mypar(1,2)
plot(i,sort(pvals))
abline(0,i/m*alpha)
##close-up
plot(i[1:15],sort(pvals)[1:15],main="Close-up")
abline(0,i/m*alpha)
save.image("~/repos/RLifeSciences/worklog3.r.RData")
k <- max(which(sort(pvals) < 1/m*alpha) )
k <- max(which(sort(pvals) < i/m*alpha) )
cutoff <- sort(pvals)[k]
cat("k =", k,"p-value cutoff=",cutoff)
fdr <- p.adjust(pvals, method="fdr")
mypar(1,1)
plot(pvals,fdr,log="xy")
abline(h=alpha,v=cutoff)
# Monte-carlo simulation to confirm FDR is below .05
alpha <- 0.05
B <- 1000 ## number of simulations
res <- replicate(B,{
controls <- matrix(sample(population,N*m,replace=TRUE),nrow=m)
treatments <- matrix(sample(population, N*m, replace=TRUE),nrow=m)
treatments[which(!nullHypothesis),] <- treatments[which(!nullHypothesis),]+delta
dat <- cbind(controls,treatments)
pvals <- rowtests(dat,g)$p.value
##then the FDR
calls <- p.adjust(pvals,method="fdr") < alpha
R=sum(calls)
Q=ifelse(R>0,sum(nullHypothesis & calls)/R,0)
return(c(R,Q))
})
Qs <- res[2,]
mypar(1,1)
hist(Qs)
FDR=mean(Qs)
print(FDR)
Rs <- res[1,]
mean(Rs==0)*100
p.adjust.methods
?p.adjust
# Direct approach to FDR and q-values (Storey)
hist(pvals,breaks=seq(0,1,0.05),freq=FALSE)
lambda = 0.1
pi0=sum(pvals> lambda) / ((1-lambda)*m)
abline(h=pi0)
print(pi0)
library(qvalue)
install.packages(qvalue)
install_bioc(qvalue)
source("https://bioconductor.org/biocLite.R")
biocLite("qvalue")
library(qvalue)
res <- qvalue(pvals)
qvals <- res$qvalues
plot(pvals,qvals)
res$pi0
savehistory("~/repos/RLifeSciences/worklog3.r.RData")
library(genefilter)
## Exploratory Data Analysis with High Throughput Data
source("https://bioconductor.org/biocLite.R")
biocLite("genefilter")
biocLite("genefilter")
library(genefilter)
biocLite()
library(genefilter)
biocLite("genefilter")
biocLite("genefilter")
install.packages("XML")
library(GSE5859Subset)
biocLite("genefilter")
library(genefilter)
data(GSE5859Subset)
g <- facter(sampleInfo$group)
g <- factor(sampleInfo$group)
results <- rowtests(geneExpression,g)
results <- rowttests(geneExpression,g)
pvals <- results$p.value
# then generate p-values from a dataset where we know the null value is true
m <- nrow(geneExpression)
n <- ncol(geneExpression)
randomData <- matrix(rnorm(n*m),m,n)
nullpvals <- rowttests(randomData,g)$p.value
# Volcano plots!
plot(results$dm,-log10(results$p.value), xlab="Effect size", ylab="- log (base 10) p-values")
# P-Value histogram
library(rafalib)
mypar(1,2)
hist(nullpvals,ylim=c(0,1400))
hist(pvals,ylim=c(0,1400))
permg <- sample(g)
permresults <- rowttests(geneExpression,permg)
hist(permresults$p.value)
# Data boxplots and histograms
library(Biobase)
library(GSE5859)
install.packages("GSE5859")
data(GSE5859)
ge <- exprs(e) ##ge for gene expression
ge[,49]/log2(exp(1)) ## immitate error
mypar(1,1)
boxplot(ge,range=0,names=1:ncol(e),col=ifelse(1:ncol(ge)==49,1,2))
qs <- t(apply(ge,2,quantile,prob=c(0.05,0.025,0.5,0.75,0.95)))
matplot(qs,type="l",lty=1)
# kaboxplot!
# also smoothed histograms
mypar(1,1)
shist(ge,unit=0.5)
# MA-plot or Bland-Almond plot
x <- ge[,1]
y <- ge[,2]
mypar(1,2)
plot(x,y)
plot((x+y)/2,x-y)
sd(y-x)
savehistory("~/repos/RLifeSciences/worklog4.r")


# Generate data; example taken from documentation of multiESS function of mcmcse package

## Load libraries

library(mAr)

## Set seed and hyper-parameters

# set.seed(100) # Used for generating chains01.csv
# set.seed(200) # Used for generating chains02.csv
# set.seed(300) # Used for generating chains03.csv
# set.seed(400) # Used for generating chains04.csv

p <- 3
n <- 1e3
omega <- 5*diag(1,p)

## Make correlation matrix var(1) model

foo <- matrix(rnorm(p^2), nrow = p)
foo <- foo %*% t(foo)
phi <- foo / (max(eigen(foo)$values) + 1)

## Simulate output

out <- as.matrix(mAr.sim(rep(0,p), phi, omega, N = n))

## Store output

write.table(out, file="chain.csv", sep=",", row.names=FALSE, col.names=FALSE)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Wrap a 1d ribbon of panels into 2d
#==============================================================================
# Title          : Plots by class ggplot2.r
# Description    : Wrap a 1d ribbon of panels into 2d.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180425
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on
#                  http://ggplot2.tidyverse.org/reference/facet_wrap.html
#                  http://ggplot2.tidyverse.org/reference/mpg.html
#                  https://bit.ly/2r4Kuqm
#                  https://bit.ly/2HOMnBF
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
if(!require("ggplot2")) install.packages("ggplot2")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)

#==============================================================================
# Examples
#==============================================================================

# Example 1
mpg2 <- subset(mpg, cyl != 5 & drv %in% c("4", "f") & class != "2seater")

plot1 <- ggplot(mpg2, aes(cty, hwy)) +
  geom_abline() +
  geom_jitter(width = 0.1, height = 0.1)

plot2 <- ggplot(mpg2, aes(cty, hwy)) +
  geom_abline() +
  geom_jitter(width = 0.1, height = 0.1)
plot2 + facet_wrap(~cyl)

plot3 <- ggplot(mpg2, aes(cty, hwy)) +
  geom_abline() +
  geom_jitter(width = 0.1, height = 0.1)
plot3 + facet_wrap(~cyl, scales = "free")

mpg2$model <- reorder(mpg2$model, mpg2$cty)
mpg2$manufacturer <- reorder(mpg2$manufacturer, -mpg2$cty)
ggplot(mpg2, aes(cty, model)) +
  geom_point() +
  facet_grid(manufacturer ~ ., scales = "free", space = "free") +
  theme(strip.text.y = element_text(angle = 0))

# Example 2
df <- data.frame(
  x = rnorm(120, c(0, 2, 4)),
  y = rnorm(120, c(1, 2, 1)),
  z = letters[1:3]
)

ggplot(df, aes(x, y)) +
  geom_point(aes(colour = z))

ggplot(df, aes(x, y)) +
  geom_point(aes(colour = z)) +
  facet_wrap(~z)

df2 <- dplyr::select(df, -z)

ggplot(df, aes(x, y)) +
  geom_point(data = df2, colour = "grey70") +
  geom_point(aes(colour = z)) +
  facet_wrap(~z)

base <- ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  geom_smooth()

# Full dataset
base
# Scaling to 5--7 throws away data outside that range
base + scale_x_continuous(limits = c(5, 7))
# Zooming to 5--7 keeps all the data but only shows some of it
base + coord_cartesian(xlim = c(5, 7))

#==============================================================================
# In a easier way...
#==============================================================================
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~class)

ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~cyl)

# Control the number of rows and columns with nrow and ncol
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~class, nrow = 4)

# facet by multiple variables
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~ cyl + drv)

# Or use a character vector:
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(c("cyl", "drv"))

# Use the `labeller` option to control how labels are printed:
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(c("cyl", "drv"), labeller = "label_both")

# To change the order in which the panels appear, change the levels
# of the underlying factor.
mpg$class2 <- reorder(mpg$class, mpg$displ)
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~class2)

# By default, the same scales are used for all panels. You can allow
# scales to vary across the panels with the `scales` argument.
# Free scales make it easier to see patterns within each panel, but
# harder to compare across panels.
ggplot(mpg, aes(displ, hwy)) +
  geom_point() +
  facet_wrap(~class, scales = "free")

# To repeat the same data in every panel, simply construct a data frame
# that does not contain the facetting variable.
ggplot(mpg, aes(displ, hwy)) +
  geom_point(data = transform(mpg, class = NULL), colour = "grey85") +
  geom_point() +
  facet_wrap(~class)

# Use `strip.position` to display the facet labels at the side of your
# choice. Setting it to `bottom` makes it act as a subtitle for the axis.
# This is typically used with free scales and a theme without boxes around
# strip labels.
ggplot(economics_long, aes(date, value)) +
  geom_line() +
  facet_wrap(~variable, scales = "free_y", nrow = 2, strip.position = "bottom") +
  theme(strip.background = element_blank(), strip.placement = "outside")

Graphical_Visualization/Plots by class ggplot2.r


#!/usr/bin/Rscript

################################################################################
#           Fundamentos de la Ciencia de Datos - 78106 - R-PL1                 #
#                               Grupo 4 - P1                                   #
#   Authors:                                                                   #
#   - David Emanuel Craciunescu                                                #
#   - Laura Pérez Medeiro                                                      #
#                                                                              #
################################################################################

################################################################################
#                       IMPORTS AND DEPENDENCY CHECKS                          #
################################################################################

library(docopt)
library(foreign)
library(tools)
library(splus2R)

# list_of_packages[!(list_of_packages %in% installed.packages()[, "Package"])]

################################################################################
#                               CALCULATIONS                                   #
################################################################################

# 1. Calculate absolute and relative satellite radius frequencies.

## 1.1. Absolute frequencies.
absoluteFreq    <- function(set) {table(set)}
cumAbsoluteFreq <- function(set) {cumsum(absoluteFreq(set))}

## 1.2. Relative frequencies.
   relativeFreq <- function(set) {table(set) / length(set)}
cumRelativeFreq <- function(set) {cumsum(relativeFreq(set))}

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

# 2. Arithmetic mean.
arithmeticMean <- function(set, usrTrim = 0) (mean(set, trim = usrTrim))

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

# 3. Measures of dispersion.

# The following page was used as a reference for this section.
# http://iridl.ldeo.columbia.edu/dochelp/StatTutorial/Dispersion/index.html#Intro

## 3.1. Range.
          range <- function(set) {max(set) - min(set)}

## 3.2. Standard Deviation.
   stdDeviation <- function(set)
{
   sd(set) * (sqrt((length(set) - 1) / length(set)))
}

## 3.3. Variance.
       variance <- function(set) {var(set) * (length(set) - 1 / length(set))}

## 3.4. Root Mean Square.
    rootMeanSqr <- function(set) {sqrt(mean(set ^ 2))}

## 3.5. Root Mean Square Anomaly.
  rootMeanSqrAn <- function(set) {sqrt(sum(set - mean(set)) ^ 2) / length(set)}

## 3.6. Interquartile Range.
interQuartRange <- function(set) {IQR(set)}

## 3.7. Median Absolute Deviation.
medAbsDeviation <- function(set) {mad(set)}

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

# 4. Measures of order.

## 4.1. Median.
getMedian    <- function(set) {median(set)}

## 4.2. Mode.
getMode      <- function(set)
{
    uniqueVal <- unique(set)
    uniqueVal[which.max(tabulate(match(set, uniqueVal)))]
}

## 4.2. Quartiles.
getQuartiles <- function(set) {quantile(set)}

## 4.3. 54th Quantile.
getQuantiles <- function(set, range = 0) {quantile(set, probs = range)}

################################################################################
#                                 INTERFACE                                    #
################################################################################

'
sStats 1.1, a simple statistical analyzer

Usage:
    sstats freq (--abs | --cum_abs | --rel | --cum_rel) (--path=PATH --var=VAR)
    sstats mean (--path=PATH --var=VAR)
    sstats disp (--iq | --mad | --rng | --rms | --rmsa | --std | --vari) (--path=PATH --var=VAR)
    sstats ord (--med | --mod | --qnt=QUANT | --qrt) (--path=PATH --var=VAR)
    sstats -a | --authors
    sstats -h | --help
    sstats -l | --license
    sstats --version

Options:
    -a --authors        Show authors of the program.
    -h --help           Show this screen.
    -l --license        Show license information.
    --version           Show version information.

Commands:
    freq - frequency analyzer
    --abs               Absolute frequency
    --cum_abs           Cumulative absolute frequency
    --rel               Relative frequency
    --cum_rel           Cumulative relative frequency

    mean                Arithmetic mean

    disp - dispersion measures
    --iq                Interquartile range
    --mad               Median absolute deviation
    --rng               Range
    --rms               Root mean square
    --rmsa              Root mean square anomaly
    --std               Standard deviation
    --vari              Variance

    ord - ordering measures
    --med               Median
    --mod               Mode
    --qnt=QUANT         Quantile
    --qrt               Quartile

Input:
    Only processes .txt and .sav files.
' -> docString

args <- docopt(docString, version = 'sStats 1.1')

################################################################################
#                               PARSE INPUT                                    #
################################################################################

if (args $ authors) {
    cat("Proudly developed by @craciunescu and @laurapm\n")

} else if (args $ license) {
    cat(readLines("../LICENSE"), fill = T)

} else {

    # Process input file | Check for supported extension
    ext <- lowerCase(file_ext(file.path(args$path)))

    if (ext == "txt") {
        dataset <- read.table(args$path)
    } else if (ext == "sav") {
        dataset <- read.spss(args$path, to.data.frame = T)
    } else {
        print("The input file cannot be processed")
    }

    # R does not accept direct variable reference to dataset column.

    column <- args$var
    data <- c(dataset[column][!is.na(dataset[column])])

    ############################################################################
    #                               COMMANDS                                   #
    ############################################################################

    # Frequencies.
    if (args $ freq) {

        if (args $ abs) {
            cat("Absolute frequency of data")
            absoluteFreq(data)

        } else if (args $ cum_abs) {
            cat("Cumulative absolute frequency\n")
            cumAbsoluteFreq(data)

        } else if (args $ rel) {
            cat("Relative frequency of data")
            relativeFreq(data)

        } else if (args $ cum_rel) {
            cat("Cumulative relative frequency of data")
            cumRelativeFreq(data)

        } else {
            cat("Unsupported behavior for FREQ command")
            print(docString)
        }

    # Means.
    } else if (args $ mean) {
        cat("Arithmetic mean =", arithmeticMean(data), "\n")

    # Dispersion.
    } else if (args $ disp) {
        if (args $ iq) {
            cat("Interquartile Range =", interQuartRange(data), "\n")

        } else if (args $ mad) {
            cat("Median Absolute Deviation =", medAbsDeviation(data), "\n")

        } else if (args $ rng) {
            cat("Range =", range(data), "\n")

        } else if (args $ rms) {
            cat("Root mean square =", rootMeanSqr(data), "\n")

        } else if (args $ rmsa) {
            cat("Root mean square anomaly =", rootMeanSqrAn(data), "\n")

        } else if (args $ std) {
            cat("Standard deviation =", stdDeviation(data), "\n")

        } else if (args $ vari) {
            cat("Variance =", variance(data), "\n")

        } else {
            cat("Unsupported behavior for DISP command")
            cat(docString)
        }

    # Ordering.
    } else if (args $ ord) {
        if (args $ med) {
            cat("Median =", getMedian(data), "\n")

        } else if (args $ mod) {
            cat("Mode =", getMode(data), "\n")

        } else if (!is.null(args$qnt)) {

            quant <- as.numeric(args$qnt)

            if ((quant > 0) && (quant <= 1))
            {
                cat("Quantile", quant*100, "% =" , getQuantiles(data, quant), "\n")
            } else {
                cat("Unsupported Quantile Value\n")
                cat("--qnt=[0-1]\n")
            }

        } else if (args$qrt) {
            cat("Quartiles\n")
            getQuartiles(data)

        } else {
            cat("Unsupported behavior for ORD command")
            cat(docString)
        }

    # Unsupported behavior.
    } else {
        cat("An unidentified error has occurred")
        cat("Please report bugs to github.com/craciunescu/sstats")
        cat("\n")
        cat(docString)
    }
}


data = UCBAdmissions
str(data)
summary(data)

TotalAdmit=apply(data, c(1, 2), sum)

barplot(TotalAdmit,legend = rownames(TotalAdmit),cex.axis=0.6,cex.lab=0.6,cex.names=0.6,cex=0.6)

ODTotal=TotalAdmit[1,1]*TotalAdmit[2,2]/(TotalAdmit[1,2]*TotalAdmit[2,1])
chisq.test(TotalAdmit,correct=FALSE)
data

odds.ratio=function(x,addtocounts=0){
  x=x+addtocounts
  (x[1,1]*x[2,2])/(x[1,2]*x[2,1])
}
OD<-round(apply(data,1,odds.ratio),2);OD

AdmitRates<-round(prop.table(margin.table(UCBAdmissions,c(1,3)),2),2)

par(mfrow=c(2,3))
for (i in 1:6)
  barplot(data[,,i],legend.text=FALSE,main=paste("Dept",LETTERS[i],sep=" "))

DeptResults <- prop.table(data,c(2,3))
DeptResults
DeptResults[1,,]

FirstTwoColumn<-matrix(data,ncol=2,byrow=TRUE,dimnames=list(NULL,c("Admitted","Rejected")))
Gender<-rep(c("Male","Female"),6)
Dept<-rep(c("A","B","C","D","E","F"),each=2)
data1 <- data.frame(FirstTwoColumn,Gender,Dept)

MLogit1=glm(cbind(Admitted,Rejected)~Gender+Dept,family=binomial(link=logit),data=data1)
#             contrasts=list(Dept=contr.treatment(6,base=6,contrasts=TRUE)))
summary(MLogit1)

MLogit2=glm(cbind(Admitted,Rejected)~Gender+Dept,family=binomial(link=logit),data=data1,subset = (Dept != "A"))
summary(MLogit2)

MLogit3=glm(cbind(Admitted,Rejected)~Dept,family=binomial(link=logit),data=data1,subset = (Dept != "A"))
summary(MLogit3)


# book: Design and Analysis of Experiments with R
# review: the theory is a mess, but can be used as a guide for which packages to use for specific plans

set.seed(42)

f = factor(rep(c(35, 40, 45), each = 4))
f

# randomize
f1 = sample(f, 12)
f1

# numbers of observations
e = 1:12
e

plan = data.frame(loaf = e, time = f1)
plan

getwd()
setwd("/home/tony/source/design-of-experiments")
write.csv(plan, file = 'plan.csv', row.names = FALSE)

bread = read.csv("plan.csv")
bread

height = c(9.75, 8.75, 4.5, 6.5, 6.5, 5.0, 10.5, 5.5, 6.5, 9.5, 8.25, 6.75)
bread = data.frame(loaf = plan$loaf, time = plan$time, height = height)
bread

install.packages('daewr')
library(daewr)

model1 = lm(height ~ time, data = bread)
summary(model1)

# - 1 removes the free coefficient
model2 = lm(height ~ time - 1, data = bread)
summary(model2)

install.packages('gmodels')
library(gmodels)

# compare 35 to 40 minutes
fit.contrast(model1, "time", c(1, -1, 0))
# the same fit.contrast won't work on model2, because it is missing its free coefficient

# build ANOVA table
model3 = aov(height ~ time, data = bread)
summary(model3)

plot(model3, which = 1)
plot(model3, which = 2) # qq-plot

library(MASS)
bc = boxcox(model3)
lambda = bc$x[which.max(bc$y)]
lambda

# when you have observations close to being outliers, you can normalize (transform) the data
breadtr = transform(bread, heighttr = height ^ lambda)
breadtr

model4 = aov(heighttr ~ time, data = breadtr)
summary(model4) # the p-value is smaller for model4 than for model3
summary(model3)

# the probability distributions in the plots are hardly influenced by transformations
plot(model4, which = 2)

# use this plot to see if the order of the observations made in time has a functional dependence
# it is possible to have a time series
plot(residuals(model4) ~ loaf, data = bread)

model3tukey = TukeyHSD(model3, ordered = T)
model3tukey

contr.poly(3)
contrasts(bread$time)

install.packages('agricolae')
library(agricolae)

# Newman-Koils test
print(SNK.test(model3, 'time', group = FALSE))

install.packages('multcomp')
library(multcomp)

contrd = glht(model3, linfct = mcp(treat = 'Dunnet'), alternative = 'greater')
summary(contrd)


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('val')

## ----cdf-ecdf,echo=FALSE,cap='Empirical and population cumulative distribution function'----
set.seed(6)
x <- rnorm(30, 100, 20)
xs <- seq(50, 150, length=150)
cdf <- pnorm(xs, 100, 20)
plot(xs, cdf, type='l', ylim=c(0,1),
     xlab=expression(x),
     ylab=expression(paste("Prob[", X <= x, "]")))
lines(ecdf(x), cex=.5)

## ----boot,echo=FALSE,h=3,w=6,ps=9,mfrow=c(1,2),cap='Estimating properties of sample median using the bootstrap'----
options(digits=3)
y <- c(2,5,6,7,8,9,10,11,12,13,14,19,20,21)
y <- c(1,5,6,7,8,9)
set.seed(17)
n <- length(y)
n2 <- n/2
n21 <- n2+1
B <- 400
M <- double(B)
plot(0, 0, xlim=c(0,B), ylim=c(3,9),
     xlab="Bootstrap Samples Used",
     ylab="Mean and 0.1, 0.9 Quantiles", type="n")
for(i in 1:B) {
  s <- sample(1:n, n, replace=T)
  x <- sort(y[s])
  m <- .5*(x[n2]+x[n21])
  M[i] <- m
  if(i <= 20) {
    w <- as.character(x)
    cat(w, "& &", sprintf('%.1f',m),
        if(i < 20) "\\\\\n" else "\\\\ \\hline\n",
        file='~/doc/rms/validate/tab.tex', append=i > 1)
  }
  points(i, mean(M[1:i]), pch=46)
  if(i>=10)	{
    q <- quantile(M[1:i], c(.1,.9))
    points(i, q[1], pch=46, col='blue')
    points(i, q[2], pch=46, col='blue')
  }
}
hist(M, nclass=length(unique(M)), xlab="", main="")

## ----bootrank,cache=TRUE,cap='Bootstrap percentile 0.95 confidence limits for ranks of predictors in an OLS model.  Ranking is on the basis of partial $\\chi^2$ minus d.f.  Point estimates are original ranks',scap='Bootstrap confidence limits for ranks of predictors'----
# Use the plot method for anova, with pl=FALSE to suppress
# actual plotting of chi-square - d.f. for each bootstrap
# repetition.  Rank the negative of the adjusted chi-squares
# so that a rank of 1 is assigned to the highest.  It is
# important to tell plot.anova.rms not to sort the results,
# or every bootstrap replication would have ranks of 1,2,3,
# ... for the partial test statistics.
require(rms)
n <- 300
set.seed(1)
d <- data.frame(x1=runif(n), x2=runif(n),  x3=runif(n),
   x4=runif(n), x5=runif(n), x6=runif(n),  x7=runif(n),
   x8=runif(n), x9=runif(n), x10=runif(n), x11=runif(n),
   x12=runif(n))
d$y <- with(d, 1*x1 + 2*x2 + 3*x3 +  4*x4  + 5*x5 + 6*x6 +
               7*x7 + 8*x8 + 9*x9 + 10*x10 + 11*x11 +
              12*x12 + 9*rnorm(n))

f <- ols(y ~ x1+x2+x3+x4+x5+x6+x7+x8+x9+x10+x11+x12, data=d)
B <- 1000
ranks <- matrix(NA, nrow=B, ncol=12)
rankvars <- function(fit)
  rank(plot(anova(fit), sort='none', pl=FALSE))
Rank <- rankvars(f)
for(i in 1:B) {
  j <- sample(1:n, n, TRUE)
  bootfit <- update(f, data=d, subset=j)
  ranks[i,] <- rankvars(bootfit)
  }
lim <- t(apply(ranks, 2, quantile, probs=c(.025,.975)))
predictor <- factor(names(Rank), names(Rank))
w <- data.frame(predictor, Rank, lower=lim[,1], upper=lim[,2])
require(ggplot2)
ggplot(w, aes(x=predictor, y=Rank)) + geom_point() +
  coord_flip() + scale_y_continuous(breaks=1:12) +
  geom_errorbar(aes(ymin=lim[,1], ymax=lim[,2]), width=0)

## ----eval=FALSE---------------------------------------------------------------
## require(rms)
## set.seed(1)  # so can reproduce results
##
## n    <- 200	        # Size of training sample
## reps <- 200	        # Simulations
## npop <- 50000       # Size of validation gold standard sample
## methods <- c('Boot 40','Boot 200','632a 40','632a 200',
##              '632b 40','632b 200','10-fold x 4','4-fold x 10',
##              '10-fold x 20','4-fold x 50')
## R <- expand.grid(sim    = 1:reps,
##                  p      = c(15,30),
##                  method = methods)
## R$Dxy <- R$Intercept <- R$Slope <- R$D <- R$U <- R$Q <-
##   R$repmeth <- R$B <- NA
## R$n <- n
##
## ## Function to do r overall reps of B resamples, averaging to
## ## get estimates similar to as if r*B resamples were done
##
## val <- function(fit, method, B, r) {
##   contains <- function(m) length(grep(m, method)) > 0
##   meth <- if(contains('Boot')) 'boot' else
##           if(contains('fold')) 'crossvalidation' else
##           if(contains('632')) '.632'
##   z <- 0
##   for(i in 1:r) z <- z + validate(fit, method=meth, B=B)[
##           c("Dxy","Intercept","Slope","D","U","Q"),
##           'index.corrected']
##   z/r
## }

## ----eval=FALSE---------------------------------------------------------------
## for(p in c(15, 30)) {
##
##   ## For each p create the true betas, the design matrix,
##   ## and realizations of binary y in the gold standard
##   ## large sample
##   Beta <- rep(.5, p)  # True betas
##   X    <- matrix(runif(npop*p), nrow=npop) - 0.5
##   LX   <- matxv(X, Beta)
##   Y    <- ifelse(runif(npop) <= plogis(LX), 1, 0)
##
##   ## For each simulation create the data matrix and
##   ## realizations of y
##   for(j in 1:reps) {
##
##     ## Make training sample
##     x <- matrix(runif(n*p), nrow=n) - 0.5
##     L <- matxv(x, Beta)
##     y <- ifelse(runif(n) <= plogis(L), 1, 0)
##     f <- lrm(y ~ x, x=TRUE, y=TRUE)
##     beta <- f$coef
##     forecast <- matxv(X, beta)
##     ## Validate in population
##     v <- val.prob(logit=forecast, y=Y, pl=FALSE)[
##                     c("Dxy","Intercept","Slope","D","U","Q")]
##
##     for(method in methods) {
##       repmeth <- 1
##       if(method %in% c('Boot 40','632a 40','632b 40'))
##         B <- 40
##       if(method %in% c('Boot 200','632a 200','632b 200'))
##         B <- 200
##       if(method == '10-fold x 4') {
##         B <- 10
##         repmeth <- 4
##       }
##       if(method == '4-fold x 10') {
##         B <- 4
##         repmeth <- 10
##       }
##       if(method == '10-fold x 20') {
##         B <- 10
##         repmeth <- 20
##       }
##       if(method == '4-fold x 50') {
##         B <- 4
##         repmeth <- 50
##       }
##
##       z <-  val(f, method, B, repmeth)
##       k <- which(R$sim == j & R$p == p & R$method == method)
##       if(length(k) != 1) stop('program logic error')
##       R[k, names(z)] <- z - v
##       R[k, c('B','repmeth')] <- c(B=B, repmeth=repmeth)
##     } # end over methods
##   } # end over reps
## } # end over p

## ----eval=FALSE---------------------------------------------------------------
## statnames <- names(R)[6:11]
## w <- reshape(R, direction='long', varying=list(statnames),
##              v.names='x', timevar='stat', times=statnames)
## w$p <- paste('p', w$p, sep='=')
## require(lattice)
## s <- with(w, summarize(abs(x), llist(p, method, stat),
##                        smean.cl.boot,stat.name='mae'))
## Dotplot(method ~ Cbind(mae, Lower, Upper) | stat*p, data=s,
##         xlab='Mean |error|')
## s <- with(w, summarize(x^2, llist(p, method, stat),
##                        smean.cl.boot, stat.name='mse'))
## Dotplot(method ~ Cbind(sqrt(mse), sqrt(Lower), sqrt(Upper)) |
##         stat*p, data=s,
##         xlab=expression(sqrt(MSE)))


is.happy <- function(n)
{
   stopifnot(is.numeric(n) && length(n)==1)
   getdigits <- function(n)
   {
      as.integer(unlist(strsplit(as.character(n), "")))
   }
   digits <- getdigits(n)
   previous <- c()
   repeat
   {
      sumsq <- sum(digits^2, na.rm=TRUE)
      if(sumsq==1L)
      {
         happy <- TRUE
         break
      } else if(sumsq %in% previous)
      {
         happy <- FALSE
         attr(happy, "cycle") <- previous
         break
      } else
      {
         previous <- c(previous, sumsq)
         digits <- getdigits(sumsq)
      }
   }
   happy
}


WORLD <- read.csv('WORLD.CSV')
row.names(WORLD) <- WORLD$COUNTRY
str(WORLD)
head(WORLD)

WORLD_CLEAN <- na.omit(WORLD[, c(3, 5:16, 18)]) #c(3:16, 18)
str(WORLD_CLEAN)
head(WORLD_CLEAN)

library(factoextra)
library(cluster)
WORLD_PAM <- pam(scale(WORLD_CLEAN), 5) #WORLD_CLEAN[, -1]), 5)
fviz_cluster(WORLD_PAM)

WORLD_CLEAN$CL = WORLD_PAM$clustering
WORLD_PCOMP <- prcomp(scale(WORLD_CLEAN))
plot(WORLD_PCOMP)
biplot(WORLD_PCOMP, cex = 0.5)

WORLD_PRED <- predict(WORLD_PCOMP)
plot(WORLD_PRED, col = WORLD_CLEAN$CL)

library('corrplot')
corrplot(cor(data.frame(WORLD_PRED[,1:2], WORLD_CLEAN)), method = 'number')


##
## What predicts being a zhu household?
##
## Supplementary Table 4
##
source("init.r")

library(tidyverse)
library(broom)
library(readr)
library(wesanderson)

d.zhu = hh %>%
  dplyr::select(HH, zhubo1, NumAdults, NumChildren, WealthRank, Sex, Age) %>%
  distinct() %>%
  na.omit() %>%
  mutate(zhubo1 = factor(zhubo1))

# make males the reference category
d.zhu$Sex = relevel(d.zhu$Sex, ref="m")

# fit model
zhu.logit = glm(zhubo1 ~ NumAdults + NumChildren + WealthRank + Sex + Age,
                data=d.zhu, family=binomial(link = "logit"))

# summarise model and save raw parameter estimates
glance(zhu.logit)

tidy(zhu.logit) %>%
  bind_cols(confint_tidy(zhu.logit)) %>%
  write_csv(file.path(results.dir, "predicting zhu label - log-odds.csv"))

# save marginal effects
library(margins)
zhu.logit.margin = margins(zhu.logit, type="response")

summary(zhu.logit.margin) %>%
  write_csv(file.path(results.dir, "predicting zhu label - marginal effects.csv"))

# how many observations?
nrow(d.zhu)

# predicted probabilities of being labelled, based on wealth and sex of household head
d.zhu.pred = expand.grid(
  WealthRank = 1:6,
  Sex = factor(c("m", "f")),
  NumAdults = mean(d.zhu$NumAdults),
  NumChildren = mean(d.zhu$NumChildren),
  Age = mean(d.zhu$Age)
)

# plot predictions
augment(zhu.logit, newdata=d.zhu.pred, type.predict="response", conf.int=T) %>%
  mutate(lwr = .fitted - 1.96*.se.fit, upr = .fitted + 1.96*.se.fit) %>%   # calculate CIs

  ggplot(aes(x=WealthRank, y=.fitted)) +
  geom_ribbon(aes(ymin=lwr, ymax=upr, fill=Sex), alpha=0.3) +
  geom_line(aes(colour=Sex)) +

  scale_color_manual(values = wes_palette("Cavalcanti")) +
  scale_fill_manual(values = wes_palette("Cavalcanti")) +

  ylab("Probability of being labelled") +
  xlab("Wealth rank") +
  theme_classic() +
  theme(legend.position="none")

ggsave(file.path(plots.dir, "predicted zhu labels by sex and wealth rank.png"), height=10, width=10, units="cm")
# ggsave(file.path(plots.dir, "predicted zhu labels by sex and wealth rank.pdf"), height=10, width=10, units="cm")

logistic regression predicting zhu houses.r


## 2. Introduction To The Data ##

library(tidyverse)
student_scores <- read_csv("scores.csv")

## 3. Preparing Our Function ##

library(tidyverse)
percent_string <- "74%"
format_score <- function(score) {
  fmt_string <- str_replace(score, "%", "")
  num <- as.numeric(fmt_string)

  return(num)
}

converted_string <- format_score(percent_string)

## 4. The map Function ##

library(tidyverse)
input_scores <- c("83%", "29%", "76%")

format_score <- function(score) {
  fmt_string <- str_replace(score, "%", "")
  num <- as.numeric(fmt_string)

  return(num)
}
output_scores <- map(input_scores, format_score)
third_element <- output_scores[[3]]

## 5. Creating New Columns With map ##

library(tidyverse)
student_scores <- read_csv("scores.csv")
format_score <- function(score) {
  fmt_string <- str_replace(score, "%", "")
  num <- as.numeric(fmt_string)

  return(num)
}

student_scores <- student_scores %>%
  mutate(
    new_writing_score = unlist(map(writing_score, format_score))
  )
student_scores <- student_scores %>%
  mutate(
    new_math_score = unlist(map(math_score, format_score)),
    new_science_score = unlist(map(science_score, format_score))
  )

## 6. Two Input Variation of map ##

input_score <- 50
add_extra_credit <- function(score, note) {
  if (note == "None") {
      points_to_add <- 0
  } else if (note == "Low") {
      points_to_add <- 1
  } else {
      points_to_add <- 5
  }

  return(score + points_to_add)
}

no_extra_credit_score <- add_extra_credit(input_score, "None")
low_extra_credit_score <- add_extra_credit(input_score, "Low")
high_extra_credit_score <- add_extra_credit(input_score, "High")

## 7. Two Input Variation of map ##

library(tidyverse)
student_scores <- read_csv("scores.csv")

format_score <- function(score) {
  fmt_string <- str_replace(score, "%", "")
  num <- as.numeric(fmt_string)

  return(num)
}

student_scores <- student_scores %>%
  mutate(
    new_writing_score = unlist(map(writing_score, format_score)),
    new_math_score = unlist(map(math_score, format_score)),
    new_science_score = unlist(map(science_score, format_score))
  )

add_extra_credit <- function(score, note) {
  if (note == "None") {
      points_to_add <- 0
  } else if (note == "Low") {
      points_to_add <- 1
  } else {
      points_to_add <- 5
  }

  return(score + points_to_add)
}
student_scores <- student_scores %>%
  mutate(
    adjusted_math_score = map2(new_math_score, math_extra_credit, add_extra_credit)
  )

## 9. Lists As Inputs ##

library(tidyverse)
input_list <- list(
  1:10,
  11:20,
  21:30,
  31:40,
  41:50
)
averages <- map(input_list, mean)

## 10. Vectorizing Summaries ##

high_scores_by_student <- student_scores %>%
  group_by(names) %>%
  summarize(
    highest_writing = max(new_writing_score),
    highest_math = max(modified_math_score),
    highest_science = max(new_science_score)
  )

Data Analyst in R/Step 1 - Introduction to R/4. Specialized Data Processing in R Strings and Dates/3. The Map Function in R.r


xm = function(m,n=100) {(n-sqrt(n^2  - 4 *m * n))/2/n}

pdf(width=5, height=4, file='fig1.pdf')
x = seq(0,30,0.01)
par(mar=c(2,4,1,1))
plot(c(),c(),xlim=c(0,33),ylim=c(0,0.19),yaxt='n',xaxt='n',ylab=NA, xlab=NA)

axis(1,at=c(0,10,20,30), labels=c("0.00", "10.00", "20.00", "30.00"))
axis(2,at=seq(0,0.18,by=0.02),las=2)
n = 10000
for (m in c(5,10,20)){
    p = m / n
    lines(x,dnorm(x,m=m,s=sqrt(n * p * (1-p))), lwd=2)
    lines(0:30,dbinom(0:30,size=n, prob=m/n), lwd=2, col='black', lty=2)
}
legend(17, 0.18, lty=c(1,2), legend=c("Normal", "Binomial"))
dev.off()


library(ggplot2)

DV ~IV # one-way

DV ~ IV1 + IV2 # Two-way

DV ~ IV1:IV2 # Two-way interaction

DV ~ IV1 + IV2 + IV1:IV2 # Main effects + interaction

DV ~ IV1 * IV2 # The same: Main effects + interaction

DV ~ IV1 + IV2 + IV3 + IV1:IV2

DV ~ (IV1 + IV2 + IV3)^2 # main effect and all possible  interaction

DV ~ IV1 + Error(subject/IV1) # repeated measures

mydata <- read.csv("shops.csv")
getwd()
str(mydata)

boxplot(price ~ origin, data=mydata)

ggplot(mydata, aes(x = origin, y = price))+
  geom_boxplot()

fit <- aov(price ~ origin, data= mydata)
summary(fit)

# TWO-way ANOVA

fit1 <- aov(price ~ origin + store, mydata)
summary(fit1)
model.tables(fit, "means")

fit3 <- aov(price ~ origin + store + origin:store, data=mydata)
summary(fit3)

fit4 <- aov(price ~ origin * store, data = mydata)
summary(fit4)

# trouble №1
View(npk)
str(npk)

#trouble №2
mfit <- aov(yield ~ N + P + K + N * P, data=npk)
summary(mfit)

ggplot(mydata, aes(x = food, y = price))+
  geom_boxplot()

fit5 <- aov(price ~ food, data = mydata)
summary(fit5)

TukeyHSD(fit5)

# trouble №3
mfit2 <- aov(Sepal.Width~ Species, iris)
summary(mfit2)
TukeyHSD(mfit2)

mydata2 <- read.csv("therapy_data.csv")
str(mydata2)
mydata2$subject <- as.factor(mydata2$subject)

fit1 <- aov(well_being ~ therapy, data = mydata2)
summary(fit1)
fit1b <- aov(well_being ~ therapy*price + Error(subject/therapy*price), data = mydata2)
summary(fit1b)

ggplot(mydata2, aes(x = price, y = well_being))+
  geom_boxplot()+
  facet_grid(~subject)

fit3 <- aov(well_being ~ therapy*price*sex, data = mydata2)
summary(fit3)
fit3b <- aov(well_being ~ therapy*price*sex + Error(subject/therapy*price), data = mydata2)
summary(fit3b)

# trouble №4
dd <- read.csv("Pillulkin.csv")
str(dd)
dd$patient <- as.factor(dd$patient)

a4 <- aov(temperature ~ pill + Error(doctor/patient), data = dd)
summary(a4)

dd <- read.csv("Pillulkin (1).csv")
dd$patient <- as.factor(dd$patient)
a5 <- aov(temperature ~ pill*doctor + Error(patient/(pill+doctor)) , data = dd)
summary(a5)

# trouble №5
library(ggplot2)
library(Hmisc)
obj <- ggplot(ToothGrowth, aes(x = as.factor(dose), y = len, col = supp, group = supp))+
  stat_summary(fun.data = mean_cl_boot, geom = 'errorbar', width = 0.1, position = position_dodge(0.2))+
  stat_summary(fun.data = mean_cl_boot, geom = 'point', size = 3, position = position_dodge(0.2))+
  stat_summary(fun.data = mean_cl_boot, geom = 'line', position = position_dodge(0.2))
obj


numf <- function(s) {
  sapply(strsplit(gsub("[^- 0123456789]", "", s), " ")[[1]], as.integer)
}

cat(sapply(lapply(readLines(tail(commandArgs(), n=1)), numf), function(s) {
  x <- s[1] - s[3]
  y <- s[2] - s[4]
  as.integer(sqrt(x*x + y*y))
}), sep="\n")


 C02AAJ Example Program Results

 Example 1: Basic Problem

  i   z                    conv  berr      cond
 ---------------------------------------------------
  1   6.53E-03,  7.42E-03    3   9.25E-18  4.84E+00
  2  -6.93E-03, -7.44E-03    2   0.00E+00  4.95E+00
  3  -2.43E+01, -4.86E+00    3   8.41E-18  1.13E+01
  4   1.47E+01, -1.66E+01    3   1.07E-17  9.99E+00
  5   5.25E+00,  2.27E+01    3   2.08E-17  1.06E+01

 Example 2: Polishing Processes

  polish  relerr    fwderr
 ----------------------------
  0       3.18E-10  1.15E-04
  1       6.16E-11  8.49E-06
  2       1.11E-16  1.11E-16


# Goals: Simulate a dataset from a "fixed effects" model, and
#        obtain "least squares dummy variable" (LSDV) estimates.
#
# We do this in the context of a familiar "earnings function" -
#  log earnings is quadratic in log experience, with parallel shifts by
#  education category.

# Create an education factor with 4 levels --
education <- factor(sample(1:4,1000, replace=TRUE),
                    labels=c("none", "school", "college", "beyond"))
# Simulate an experience variable with a plausible range --
experience <- 30*runif(1000)            # experience from 0 to 20 years
# Make the intercept vary by education category between 4 given values --
intercept <- c(0.5,1,1.5,2)[education]

# Simulate the log earnings --
log.earnings <- intercept +
  2*experience - 0.05*experience*experience + rnorm(1000)
A <- data.frame(education, experience, e2=experience*experience, log.earnings)
summary(A)

# The OLS path to LSDV --
summary(lm(log.earnings ~ -1 + education + experience + e2, A))

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o4.r


# ......................................................................................
# ...............Exercise 13. Nonparametric tests, goodness-of-fit tests ...............
# ..................Michal Béreš, Martina Litschmannová, Adéla Vrtková..................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Conformance distribution probability testing of discrete NV(finite number of values) ####
# - good agreement test
#
# - we test whether the measured data(their relative frequencies) agree with any
# specific distribution(ie its probabilities)
#
# - we test using the $\chi^2$ good match test
#
# - assumptions of the test:(ATTENTION relate to the expected frequencies - ie those
# that we would monitor if the measured data were 100% according to the distribution in
# the hypothesis)
#
# - Expected frequencies ≥ 2,
#
# - at least 80% of expected frequencies>5
#
# - test statistic(the one with $\chi^2$ distribution) is $G = \sum_{i = 1}^k (O_i -
# E_i)^2 / E_i$
#
# - distribution has degree of freedom $df = k - 1 - h$
#
# - k is the number of options
#
# - h is the number of estimated parameters(this applies to incompletely specified
# tests)
#

# example see example 1

# * Good match test for a continuous random variable(or discrete with an infinite ####
# number of values)
#
# - we have to convert to a table with a finite number of values
#
# - for discrete(eg poison) we group from a certain number of columns eg 4,5,6,... to "4
# and more"
#
# - for continuous we produce a series of intervals and see how many values fall within
# the given interval
#
# - eg:(- $\infty$, 3),<3, 4),...,<10, $\infty$)
#
# - then we have to calculate for each interval how many% of data belong to each
# interval, thus obtaining a table of expected probabilities
#
# - we continue as before
#
# - there is a pearson.test(data) function from the nortest package to test the
# normality of the distribution
#

# example 2,3,4

#  PivotTables ####
#
# - tables containing data depending on two factors
#
# - one of the factors is, as a rule, an independent variable in which we monitor
# whether it affects the other factor(dependent variable)
#
# - The independent variable is usually in rows
#
# - is usually dependent in columns
#
# - beware the whole test examines the correlation, not the causality! Causality can be
# assessed by "expert" evaluation
#
# - statistical conclusion: there is a statistically significant dependence between the
# independent and dependent variable(correlation)
#
# - expert assessment: an independent variable statistically significantly affects the
# dependent variable(causality)
#

# * PivotTable Visualization ####
#
# - visualization eg using the barplot function
#
# - pay attention to what rows and columns are, we always want individual divided
# columns to be via independent variables(each column for one value of an independent
# variable)
#
# - beside=T determines whether we want to merge adjacent columns into one split column
# or not
#
# - preferred visualization using mosaicplot
#
# - the same as for barlot, the connected columns must be via independent variables
#

# examples in Examples 5,6,7

# * Dependency table dependencies ####
#
# - Correlation coefficient CC
#
# - Corrected correlation coefficient CCcor
#
# - Cramer's coefficient V
#
# - we will use this first
#
# - cramersV(cont.tab) function from lsr package
#

# Examples in Examples 5,6,7

# * PivotTable Dependency Test ####
#
# - $H_0:$ there is no dependency between an independent(eg is a smoker) and a
# dependent(eg suffering from a disease) variable
#
# - $H_A: \neg H_0$
#
# - chisq.test function(cont.tab)
#
# - assumptions: Expected frequencies ≥ 2, at least 80% of expected frequencies>5
#
# - expected frequencies can be found from chisq.test(cont.tab) \ $ expected
#

#  Association tables ####
#
# - this is a special PivotTable case
#
# - always has exactly 2 options for the dependent and exactly 2 options for the
# independent variable
#

# * Mandatory form of the association table ####
#
# - Lines indicate independent variable options
#
# - the first line is the so-called exposed part of the population(the one exposed to
# the phenomenon we study - eg smokers try to study the effects of smoking)
#
# - the second line is the unexposed part of the population
#
# - The columns indicate the options of the dependent variable
#
# - the first column indicates the occurrence of the phenomenon under investigation(eg
# occurrence of the disease, product error,...)
#
# - the second column indicates the remainder - no occurrence of the investigated
# phenomenon
#

# * Relative risk and odds ratio ####
#
# - Relative risk and odds ratio provide the same information, only in a different
# format
#
# - all point IOs are calculated using the function epi.2by2(associ.tab) from the
# package epiR
#
# - the function takes the association table as input, which must be in the correct
# format!
#

# ** Relative risk ####
#
# - denotes $RR$
#
# - this is the risk ratio(probability of occurrence of the investigated phenomenon) in
# exposed and unexposed populations
#
# - if it is equal to 1, it means the same probabilities of occurrence in exposed and
# unexposed
#
# - if it is greater than 1 then the exposed population is more likely to occur
#
# - if less than 1 then the exposed population is less likely to occur
#
# - point estimate $\hat{RR}$ is calculated as the ratio rel. frequency of the studied
# phenomenon in exposed and unexposed populations
#
# - epi.2by2 provides interval estimates
#
# - if the IO does not contain the value 1 then there is a statistically significant
# dependence between the dependent and independent variable
#

# ** Odds ratio ####
#
# - we denote $OR$
#
# - this is the ratio of chances(chance of occurrence of the studied phenomenon) in
# exposed and unexposed populations
#
# - if it is equal to 1, it means the same chances of occurrence in exposed and
# unexposed
#
# - if it is greater than 1 then the exposed population has a greater chance of
# occurrence
#
# - if less than 1 then the exposed population has a lower chance of occurrence
#
# - point estimate $\hat{OR}$ is calculated as the ratio of chances(selective) of the
# studied phenomenon in exposed and unexposed population
#
# - epi.2by2 provides interval estimates
#
# - if the IO does not contain the value 1 then there is a statistically significant
# dependence between the dependent and independent variable
#

# example in example 7

#  Examples(good match tests) ####
#
# * Example 1. ####
#
# The dice were rolled 6,000 times and the number of falling meshes was recorded.
# [image.png](attachment:64f1169e-6bc1-470a-8afb-b282230c2c9f.png)
#

# H0: The cube is fair.(so all probabilities are 1/6)
# Ha: The cube is not fair.(H0 negation)

x = c(1,2,3,4,5,6)
n.obs = c(979,1002,1015,980,1040,984)
p.exp = c(1/6,1/6,1/6,1/6,1/6,1/6)
n.exp = 6000*p.exp
n.exp # test assumptions must be checked
# All expected frequencies are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1 - pchisq(x.obs,5)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.711,
# Chi-square test of independence, df=5).

# * Example 2. ####
#
# The manufacturing company estimates the number of failures of a particular device in
# 100 hours using a Poisson distribution with parameter 1.2. Employees recorded the
# actual number of failures at a total of 150 100-hour intervals for inspection(results
# are shown in the table). Verify with a clean significance test that the number of
# failures of a given device within 100 hours actually has a Poisson distribution with
# the parameter λt=1.2.
#

# Fully specified test

# H0: The number of faults during 100 operating hours can be modeled
# Poisson distribution with parameter 1.2.
# Ha: The number of faults during 100 operating hours cannot be modeled
# Poisson distribution with parameter 1.2.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

p.exp = dpois(x,1.2)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # test assumptions must be checked
# 4 of the 5 expected frequencies, ie 80%, are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,4)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.590,
# Chi-square test of independence, df=4).

# * Example 3. ####
#
# Employees recorded a total of 150 100-hour breakdowns at check(results are shown in
# the table). Use a clean significance test to see if the number of failures in a given
# device has a true Poisson distribution in 100 hours. </br>
#  ![Image.png](attachment:4da89057-87d1-4bcd-a488-3365237654f7.png)
#

# Incompletely specified test

# H0: The number of faults during 100 operating hours can be modeled
# Poisson distribution.
# Ha: The number of faults during 100 operating hours cannot be modeled
# Poisson distribution.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

lambda.t = weighted.mean(x,n.obs)   # Poisson distribution parameter estimate
lambda.t

p.exp = dpois(x,lambda.t)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # test assumptions must be checked
# 4 out of 5 expected frequencies, ie 80%, are greater than 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,3)
p.hodnota

# At the significance level of 0.05 we do not reject HO(p-value=0.491,
# Chi-square test of independence, df=3).

# * Example 4. ####
#
# Time intervals(s) between the passages of individual vehicles were measured on the
# motorway within a few minutes. The detected values of these distances are recorded in
# the file dalnice.xlsx. Verify that this is data from a normal distribution(use a good
# match test).
#

# automatic test of good agreement from continuous data

dalnice = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=2)
colnames(dalnice)="hodnoty"
head(dalnice)

mu = mean(dalnice$hodnoty)
sigma = sd(dalnice$hodnoty)
mu
sigma

# Generate values for the x-axis
xfit=seq(from = -20, to = 30, length = 100)
# Generate values for the y-axis
yfit=dnorm(xfit, mean = mu, sd = sigma)

hist(dalnice$hodnoty, freq = FALSE, xlim = c(-20, 30))
# Add a curve to the last graph based on the values generated above
lines(xfit, yfit, col="black", lwd=2)

# install.packages("nortest")

# H0: Spacing between vehicles can be modeled by normal distribution.
# Ha: Spacing between vehicles cannot be modeled by normal distribution.

nortest::pearson.test(dalnice$hodnoty)

# Specify the number of degrees of freedom
pom = nortest::pearson.test(dalnice$hodnoty, n.classes = 5)
attributes(pom)

pom$method
pom$n.classes
pom$df
pom$p.value

# HO can be rejected at the significance level of 0.05(p-value<<0.001,
# Chi-square test of good agreement, df=12).

# test what you already know
shapiro.test(dalnice$hodnoty)

#  Examples of PivotTable and Association Tables ####
#
# * Example 5. ####
#
# Decide on the basis of the data file experimentovani-s-telem.xls(Dudová, J. -
# Experimentování s tělem(survey results), 2013. Available online at
# http://experimentovani-stelem.vyplnto.cz), whether there is a connection between
# gender of respondents and whether they have tattoos. Use Cramer V to assess the
# contingency rate.
#

tet = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=3)
head(tet)

tet = tet[,c(6,10)]
colnames(tet) = c("pohlavi","tetovani")
head(tet)

# Preprocessing
# Variants of cat. Variables(factors) must be arranged and named so
# how they should be arranged and named in the accounts. table

kont.tab = table(tet$pohlavi, tet$tetovani)
kont.tab

colnames(kont.tab) = c("má tetování","nemá tetování")
kont.tab

# Exploratory analysis
prop.table(kont.tab)    # associated relative frequencies
prop.table(kont.tab,1)  # line relative frequencies
prop.table(kont.tab,2)  # columnar relative frequencies

# Visualization in standard R
# Cluster bar graph
# compare graphs, which of the graphs is more suitable for the presentation of the data

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # matrix of 1x2 graphs

barplot(t(kont.tab),
        legend = colnames(kont.tab),
        beside = T)

barplot(kont.tab,
        legend = rownames(kont.tab),
        beside = T)

# Stacked bar graph

options(repr.plot.width = 12) # width of graphs in Jupyter
par(mfrow = c(1, 2))          # matrix of graphs 1x2

barplot(t(kont.tab),
        legend = colnames(kont.tab))

barplot(kont.tab,
        legend = rownames(kont.tab))

# Mosaic chart

options(repr.plot.width = 8) # width of graphs in Jupyter

mosaicplot(t(kont.tab),
           las = 1, # Rotate y-axis labels
           color = gray.colors(2))

# compare which of the graphs is more suitable for the presentation of the given data
mosaicplot(kont.tab,
           las = 1,
           color = gray.colors(2))

# install.packages("lsr")

# Cramer V calculation ####
lsr::cramersV(kont.tab)

# PivotTable independence test

# H0: Data is independent ->whether the individual is male or female
# Does not affect his likelihood of having a tattoo
# HA: negation H0(there is a dependency)

pom = chisq.test(kont.tab)
attributes(pom)

pom$expected # Necessary for verification of assumptions
# All expected frequencies are greater than 5.

pom

# HO can be rejected at the significance level of 0.05(p-value=0.003,
# Chi-square goodness-of-fit test, df=1).
# The observed dependence can be assessed as weak(Cramer's V=0.121).

# * Example 6. ####
#
# For a differentiated approach in personnel policy, the company's management needs to
# know whether job satisfaction depends on whether it is a Prague plant or non-Prague
# plants. The results of the survey are in the following table. Display the data using a
# mosaic chart and, based on the independence test in the combination table, decide on
# the dependence of job satisfaction on the company's location. To assess the
# contingency rate, use Cramer V. </br>
#  ![Image.png](attachment:ebc6062c-1020-4fab-8855-6665d65d59a7.png)
#

# We do not have a data matrix, ie cont. we must enter the table "manually"
kont.tab = matrix(c(10,25,50,15,20,10,130,40),
                  nrow=2,byrow=T)
rownames(kont.tab) = c("Praha","Venkov")
colnames(kont.tab) = c("velmi nespokojen","spíše nespokojen",
                       "spíše spokojen","velmi spokojen")
kont.tab = as.table(kont.tab)
kont.tab

# Exploratory Analysis ####
prop.table(kont.tab)  # associated relative frequencies
prop.table(kont.tab,1)  # line relative frequencies
prop.table(kont.tab,2)  # columnar relative frequencies

# Visualization in standard R
# Mosaic chart
mosaicplot(kont.tab,
           las = 1, # Rotate yo axis labels 90
           color = gray.colors(4))

# Cramer V
lsr::cramersV(kont.tab)

# H0: There is no connection between job satisfaction and company location.
# Ha: There is a connection between job satisfaction and the location of the company.

# Chi-square PivotTable Independence Test ####
pom = chisq.test(kont.tab)
pom$expected
# All expected frequencies are greater than 5.

pom

# HO can be rejected at the significance level of 0.05(p-value<<0.001,
# Chi-square test of good agreement, df=3).
# The observed dependence can be assessed as moderate(Cramer's V=0.296)

# * Example 7.(Association table) ####
#
# Between 1965 and 1968, a cohort study of cardiovascular disease under the Honolulu
# Heart Program began monitoring 8,006 men, of whom 7,872 did not have a history of
# stroke at the start of the study. Of this number, there were 3,435 smokers and 4,437
# non-smokers. When followed for 12 years, 171 men in the group of smokers and 117 men
# in the group of non-smokers suffered a stroke.
#
# *** a) ####
#
# Record the results in the association table.
#

kont.tab = matrix(c(171,3264,117,4320),nrow=2,byrow=T)
rownames(kont.tab) = c("kuřák","nekuřák")
colnames(kont.tab) = c("ano","ne")
kont.tab

# completion of the table of absolute frequencies
kont.tab.full = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.full) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.full) = c("ano", "ne", "sum")

kont.tab.full[1:2, 1:2] = kont.tab
kont.tab.full[1:2, 3] = rowSums(kont.tab)
kont.tab.full[3, 1:2] = colSums(kont.tab)
kont.tab.full[3, 3] = sum(kont.tab)
kont.tab.full

# addition of the table of relative frequencies
kont.tab.rel = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.rel) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.rel) = c("ano", "ne", "sum")

kont.tab.rel[1:2, 1:2] = prop.table(kont.tab)
kont.tab.rel[1:2, 3] = rowSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 1:2] = colSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 3] = sum(kont.tab.rel[1:2, 1:2])
kont.tab.rel

# *** b) ####
#
# Based on visual assessment, estimate the effect of smoking on the incidence of
# cardiovascular disease.
#

# Visualization by mosaic graph in basic R
mosaicplot(kont.tab,
           color = gray.colors(2))

# Cramer V calculation ####
lsr::cramersV(kont.tab)

# According to the mosaic graph and Cramer's V(0.061) there is a connection between smoking
# and the occurrence of apoplexy evaluated as very weak.

# *** c) ####
#
# Determine the absolute risk of cardiovascular disease in smokers and non-smokers.
#

# risk=probability
kont.tab.full

# Smokers
# Assumptions check
p = 171/3435
p

9/(p*(1-p))
# OK(3,435>190.3)

# Calculation of point and 95% Clopper-Pearson interval estimation
prop.test(x = 171, n = 3435)

# The smoker has an apoplexy risk of about 5.0%. 95% Clopper-Pearson
# the interval estimate of this risk is 4.2% to 5.8%.

# Non-smokers
# Assumption check
p = 117/4437
p

9/p/(1-p)
# OK(4,437>350.6)

# Calculation of point and 95% Clopper-Pearson interval estimation
prop.test(117,4437)

# In non-smokers, the risk of apoplexy is about 2.6%. 95% Clopper-Pearson
# the interval estimate for this risk is 2.1% to 3.2%.

# *** d) ####
#
# Determine the relative risk(including 95% of the interval estimate) of cardiovascular
# disease in smokers and non-smokers. Explain the practical significance of the results
# obtained.
#

# install.packages("epiR")

kont.tab

epiR::epi.2by2(kont.tab)

# Smokers have about 1.89 times higher risk of apoplexy than non-smokers. 95%
# the interval estimate for this relative risk is 1.50 to 2.38.
# According to the interval estimate of relative risk, it is clear that at the surface
# significance 0.05 is a statistically significantly higher risk for smokers
# apoplexy than in non-smokers.

# *** e) ####
#
# Determine the absolute chances of cardiovascular disease in smokers and non-smokers.
#

# In a smoker, the chance of apoplexy is about 52: 1,000. at 1,052 smokers
# about 52 occurrences of apoplexy can be expected.
# In non-smokers, the chance of developing apoplexy is about 27: 1,000. for 1,027 non-smokers
# approximately 27 occurrences of apoplexy can be expected.

# *** f) Determine the relative chances of cardiovascular disease in smokers. ####
#

# Smokers have about 1.93(=0.0524/0.0271) times higher chance of apoplexy
# than for non-smokers. 95% interval estimate of this ratio
# the odds are 1.52 to 2.46.
# According to the interval estimate of the odds ratio, it is clear that on the surface
# Significance 0.05 is for smokers
# statistically significantly higher chance of developing apoplexy than in non-smokers.

# *** g) ####
#
# Decide at a significance level of 0.05 on the dependence of the incidence of
# cardiovascular disease on smoking.
#

# Attention! The epi.2by2 command does not output the expected frequency for
# Chi-square test of independence.
# It is not possible to verify the test assumptions!

# H0: There is no link between smoking and the occurrence of apoplexy.
# Ha: There is a link between smoking and the occurrence of apoplexy.

pom = chisq.test(kont.tab)
pom$expected
# All expected frequencies are greater than 5.

pom

lsr::cramersV(kont.tab)

# At the significance level of 0.05, HO can be rejected(p-value<<0.001,
# Chi-square goodness-of-fit test,
# df=1). The observed dependence can be assessed as very weak
# Cramer's V=0.061).


horner <- function(a, x) {
  y <- 0
  for(c in rev(a)) {
    y <- y * x + c
  }
  y
}

cat(horner(c(-19, 7, -4, 6), 3), "\n")


 C02AGJ Example Program Results

 Example 1

 Degree of polynomial =    5

 Computed roots of polynomial

 z =  -1.4918E+00
 z =   5.5169E-01 +/-   1.2533E+00*i
 z =  -8.0579E-01 +/-   1.2229E+00*i

 Example 2

 Degree of polynomial =    5

 Computed roots of polynomial     Error estimates
                                (machine-dependent)

 z =  -1.4918E+00 +0.0000E+00*i       7.4E-16
 z =   5.5169E-01 +1.2533E+00*i       1.1E-16
 z =   5.5169E-01 -1.2533E+00*i       1.1E-16
 z =  -8.0579E-01 +1.2229E+00*i       3.0E-16
 z =  -8.0579E-01 -1.2229E+00*i       3.0E-16


# Working with the different geometries

# A. Scatter plots
# 1. Overplotting 1: large datasets
# Plot price vs. carat, colored by clarity
plt_price_vs_carat_by_clarity <- ggplot(diamonds, aes(carat, price, color = clarity))

# Add a point layer with tiny points
plt_price_vs_carat_by_clarity + geom_point(alpha = 0.5, shape = ".")

# Set transparency to 0.5. Remove line outlines by adjusting shape
plt_price_vs_carat_by_clarity + geom_point(alpha = 0.5, shape = 16)

# 2. Overplotting 2: aligned values. Occurs when one axis is continuous and the other is categorical
# Plot base
plt_mpg_vs_fcyl_by_fam <- ggplot(mtcars, aes(fcyl, mpg, color = fam))

# Default points are shown for comparison
plt_mpg_vs_fcyl_by_fam + geom_point()

# Alter the point positions by jittering, width 0.3
plt_mpg_vs_fcyl_by_fam + geom_point(position = position_jitter(0.3))

# Now jitter and dodge the point positions
plt_mpg_vs_fcyl_by_fam + geom_point(position = position_jitterdodge(jitter.width = 0.3, dodge.width = 0.3))

# 3. Overplotting 3: Low-precision data. Measurements for data points were taken at low resolution level (e.g. mm)
ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
  # Swap for jitter layer with width 0.1
  geom_jitter(alpha = 0.5, width = 0.1)

ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
  # Set the position to jitter
  geom_point(position = "jitter", alpha = 0.5)

ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
  # Use a jitter position function with width 0.1
  geom_point(alpha = 0.5, position = position_jitter(width = 0.1))

# 4. Overplotting 4: Integer data
# Examine the structure of Vocab
str(Vocab)

# Plot vocabulary vs. education
ggplot(Vocab, aes(education, vocabulary)) +
  # Add a point layer
  geom_point()

# Add a jitter layer
ggplot(Vocab, aes(education, vocabulary)) +
  # Change to a jitter layer
  geom_jitter()

ggplot(Vocab, aes(education, vocabulary)) +
  # Set the shape to 1
  geom_jitter(alpha = 0.2, shape = 1)

# B. Histograms
# 1. Drawing histograms
ggplot(mtcars, aes(mpg)) +
  # Set the binwidth to 1
  geom_histogram(binwidth = 1)

# Map y to the internal variable ..density.. show frequency densities
ggplot(mtcars, aes(mpg, y = ..density..)) +
  geom_histogram(binwidth = 1)

# Change the fill color
datacamp_light_blue <- "#51A8C9"

ggplot(mtcars, aes(mpg, ..density..)) +
  # Set the fill color to datacamp_light_blue
  geom_histogram(binwidth = 1, fill = datacamp_light_blue)

# 2. Positions in histograms
ggplot(mtcars, aes(mpg, fill = fam)) +
  # Change the position to fill. Bars fill the y-axis
  geom_histogram(binwidth = 1, position = "fill")

ggplot(mtcars, aes(mpg, fill = fam)) +
  # Change the position to identity, with transparency 0.4
  geom_histogram(binwidth = 1, position = "identity", alpha = 0.4)

# C. Bar plots
# Plot fcyl, filled by fam
ggplot(mtcars, aes(fcyl, fill = fam)) +
  # Add a bar layer
  geom_bar()

ggplot(mtcars, aes(fcyl, fill = fam)) +
  # Set the position to "fill"
  geom_bar(position = "fill")

ggplot(mtcars, aes(fcyl, fill = fam)) +
  # Change the position to "dodge"
  geom_bar(position = "dodge")

# 2. Overlapping bar plots
ggplot(mtcars, aes(cyl, fill = fam)) +
  # Change position to use the functional form, with width 0.2
  geom_bar(position = position_dodge(width = 0.2))

ggplot(mtcars, aes(cyl, fill = fam)) +
  # Set the transparency to 0.6
  geom_bar(position = position_dodge(width = 0.2), alpha = 0.6)

# 3. Sequential color palette
# Plot education, filled by vocabulary
ggplot(Vocab, aes(education, fill = vocabulary)) +
  # Add a bar layer with position "fill"
  geom_bar(position = "fill") +
  # Add a brewer fill scale with default palette
  scale_fill_brewer()

# D. Line plots
# 1. Basic Line plots
# Print the head of economics
head(economics)

# Using economics, plot unemploy vs. date
ggplot(economics, aes(date, unemploy)) +
  # Make it a line plot
  geom_line()

# Change the y-axis to the proportion of the population that is unemployed
ggplot(economics, aes(date, y = unemploy / pop)) +
  geom_line()

# 2. Multiple time series
# Plot the Rainbow Salmon time series
ggplot(fish.species, aes(x = Year, y = Rainbow)) +
  geom_line()

# Plot the Pink Salmon time series
ggplot(fish.species, aes(x = Year, y = Pink)) +
  geom_line()

# Plot multiple time-series by grouping by species
ggplot(fish.tidy, aes(Year, Capture)) +
  geom_line(aes(group = Species))

# Plot multiple time-series by coloring by species
ggplot(fish.tidy, aes(x = Year, y = Capture, color = Species)) +
  geom_line(aes(group = Species))


boxm <- function(n) {
  t <- runif(n+1)
  u1 <- t[1]
  r <- array()
  for (j in 1:n) {
    u2 <- t[j+1]
    r[j] <- sqrt(-2*log(u1)) * cos(2*pi*u2)
    u1 <- u2
  }
  r
}


library(BIBtests, quietly=TRUE)

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

set.seed(1234)
m = 10
n = 3
k = 4
x = matrix(rnorm(m*n), m, n)
y = matrix(rnorm(n*k), n, k)

cat("# Level 3\n")

TESTING("mmprod")
test = bib_mmprod(x, y)
truth = x %*% y
CHECK(test, truth)
OK()

cat("\n")


#Load up the needed packages
library(gmodels)
library(rpart)
library(rpart.plot)
library(pROC)

#Load the data into the workspace
loan_data <- readRDS(file="./data/loan_data.rds")
str(loan_data)

#Look at the number of defaults, non-defaults, and their proportions
  #There data contains 11% defaults
CrossTable(loan_data$loan_status)

#Use crosstable to look at the number/proportion of defaults and non defaults
  #for each grade
CrossTable(loan_data$grade,
           loan_data$loan_status,
           prop.r = TRUE,
           prop.c=FALSE,
           prop.t = FALSE,
           prop.chisq = FALSE)
#The proportion of defaults increases when the credit rating moves from A to G

#Create histogram of loan_amnt: hist_1
  #Most of the loan amounts are under 15k
hist_1 <- hist(loan_data$loan_amnt)

#Print locations of the breaks in hist_1
hist_1$breaks

#Change number of breaks to 200 and add labels: hist_2
hist_2 <- hist(loan_data$loan_amnt,
               breaks = 200,
               xlab = "Loan Amount",
               main = "Histogram of the loan amount")

#Plot the age variable
  #Someone has an age of over 120, which is incredibly unlikely
plot(loan_data$age, ylab="Age")

#Save the outlier's index to index_highage
index_highage <- which(loan_data$age>122)

#Remove the outlier
loan_data <- loan_data[-index_highage, ]

#Make bivariate scatterplot of age and annual income
plot(loan_data$age,
     loan_data$annual_inc,
     xlab = "Age",
     ylab = "Annual Income")

#Look at summary of the interest rates for the data
summary(loan_data$int_rate)

#Get indices of missing interest rates: na_index
na_index <- which(is.na(loan_data$int_rate))

#Compute the median of int_rate
median_ir <- median(loan_data$int_rate, na.rm=TRUE)

#Replace missing interest rates with median
loan_data$int_rate[na_index] <- median_ir

#Check if the NAs are gone
summary(loan_data$int_rate)

#Engineer a new feature vector for interest rate categories/buckets
loan_data$ir_cat <- rep(NA, length(loan_data$int_rate))

loan_data$ir_cat[which(loan_data$int_rate <= 8)] <- "0-8"
loan_data$ir_cat[which(loan_data$int_rate > 8 & loan_data$int_rate <= 11)] <- "8-11"
loan_data$ir_cat[which(loan_data$int_rate > 11 & loan_data$int_rate <= 13.5)] <- "11-13.5"
loan_data$ir_cat[which(loan_data$int_rate > 13.5)] <- "13.5+"
loan_data$ir_cat[which(is.na(loan_data$int_rate))] <- "Missing"

loan_data$ir_cat <- as.factor(loan_data$ir_cat)

#Look at the bins and their distribution
plot(loan_data$ir_cat)

#Look at the different categories in ir_cat using table()
table(loan_data$ir_cat)

#Engineer a new feature vector for employment length categories/buckets

loan_data$emp_cat <- rep(NA, length(loan_data$emp_length))
loan_data$emp_cat[which(loan_data$emp_length >= 0 & loan_data$emp_length <= 15)] <- "0-15"
loan_data$emp_cat[which(loan_data$emp_length > 15 & loan_data$emp_length <= 30)] <- "15-30"
loan_data$emp_cat[which(loan_data$emp_length > 30 & loan_data$emp_length <= 45)] <- "30-45"
loan_data$emp_cat[which(loan_data$emp_length > 45)] <- "45+"
loan_data$emp_cat[which(is.na(loan_data$emp_length))] <- "Missing"

loan_data$emp_cat <- as.factor(loan_data$emp_cat)
table(loan_data$emp_cat)

#Set a seed for reproducibility
set.seed(567)

#Store row numbers for training set: index_train
index_train <- sample(1:nrow(loan_data), (2/3)*(nrow(loan_data)))

#Create training set: training_set
training_set <- loan_data[index_train, ]

#Create test set: test_set
test_set <- loan_data[-index_train,]

#Build the logistic regression model
log_model_multi <- glm(loan_status ~ age + ir_cat+ grade+ loan_amnt+ annual_inc+ emp_cat,
                       data=training_set,
                       family="binomial")

#Obtain significance levels using summary()
summary(log_model_multi)

#Look at the predictions range
predictions_multi <- predict(log_model_multi,
                                 newdata = test_set,
                                 type = "response")

range(predictions_multi)

#Make a binary predictions-vector using a cut-off of 15% and 20%
pred_cutoff_15 <- ifelse(predictions_multi > 0.15, 1, 0)
pred_cutoff_20 <- ifelse(predictions_multi > 0.20, 1, 0)

#Check the cutoff with a confusion matrix
table(test_set$loan_status, pred_cutoff_15)
table(test_set$loan_status, pred_cutoff_20)
#Accuracy and specificity increase, but sensitivity decreases

#Check out the logit, probit and cloglog logistic regression models
log_model_logit <- glm(loan_status ~ age + emp_cat + ir_cat + loan_amnt,
                       family = binomial(link = logit),
                       data = training_set)

log_model_probit <- glm(loan_status ~ age + emp_cat + ir_cat + loan_amnt,
                        family = binomial(link = probit),
                        data = training_set)

log_model_cloglog <-glm(loan_status ~ age + emp_cat + ir_cat + loan_amnt,
                        family = binomial(link = cloglog),
                        data = training_set)

log_model_all_full <- glm(loan_status ~ loan_amnt + int_rate + grade + emp_length
                          + home_ownership + annual_inc + age + ir_cat,
                          family = binomial(link = logit),
                          data = training_set)

#Make predictions for all models using the test set
predictions_logit <- predict(log_model_logit,
                             newdata = test_set,
                             type = "response")
predictions_probit <- predict(log_model_probit,
                              newdata = test_set,
                              type = "response")
predictions_cloglog <- predict(log_model_cloglog,
                               newdata = test_set,
                               type = "response")
predictions_all_full <- predict(log_model_all_full,
                               newdata = test_set,
                               type = "response")

#Using a cut-off of 14% to make binary predictions-vectors
cutoff <- 0.14
class_pred_logit <- ifelse(predictions_logit > cutoff, 1, 0)
class_pred_probit <- ifelse(predictions_probit > cutoff, 1, 0)
class_pred_cloglog <- ifelse(predictions_cloglog > cutoff, 1, 0)

#Creating a vector to store the actual loan default status values
true_val <- test_set$loan_status

#Make a confusion matrix for the three models
tab_class_logit <- table(true_val,class_pred_logit)
tab_class_probit <- table(true_val,class_pred_probit)
tab_class_cloglog <- table(true_val,class_pred_cloglog)

#Check out the matrices
tab_class_logit
tab_class_probit
tab_class_cloglog

#Compute the classification accuracy for all three models
acc_logit <- sum(diag(tab_class_logit)) / nrow(test_set)
acc_probit <- sum(diag(tab_class_probit)) / nrow(test_set)
acc_cloglog <- sum(diag(tab_class_cloglog)) / nrow(test_set)

#Check out each accuracy
acc_logit
acc_probit
acc_cloglog
#They're all about 70%

#Create an undersampled training set with 2/3 non-defaults and 1/3 defaults
defaults <- loan_data[loan_data$loan_status==1,]
nondefaults <- loan_data[loan_data$loan_status==0,]

part1 <- nondefaults[sample(nrow(nondefaults), 4380,
                        replace = FALSE,
                        prob = NULL),]

part2 <- defaults[sample(nrow(defaults), 2190,
                            replace = FALSE,
                            prob = NULL),]

undersampled_training_set <- rbind(part1,part2)
table(undersampled_training_set$loan_status)

#Change the code provided in the video such that a decision tree is constructed using the undersampled training set. Include rpart.control to relax the complexity parameter to 0.001.
tree_undersample <- rpart(loan_status ~ .,
                          method = "class",
                          data =  undersampled_training_set,
                          control = rpart.control(cp=0.001))

#Plot the decision tree
plot(tree_undersample,
     uniform = TRUE)

#Add labels to the decision tree
text(tree_undersample)

#Plot the cross-validated error rate as a function of the complexity parameter
plotcp(tree_undersample)

#Use printcp() to identify for which complexity parameter the cross-validated error rate is minimized.
printcp(tree_undersample)

#Create an index for of the row with the minimum xerror
index <- which.min(tree_undersample$cptable[ , "xerror"])

#Create tree_min
tree_min <- tree_undersample$cptable[index, "CP"]

#Prune the tree using tree_min
ptree_undersample <- prune(tree_undersample, cp = tree_min)

#Use prp() to plot the pruned tree
prp(ptree_undersample)

#Construct a tree with adjusted prior probabilities.
tree_prior <- rpart(loan_status ~ .,
                    method = "class",
                    data = training_set,
                    control = rpart.control(cp=0.001),
                    parms = list(prior=c(0.7,0.3)))

#Plot the decision tree
plot(tree_prior,uniform=TRUE)

#Add labels to the decision tree
text(tree_prior)

#Try changing the cost matrix to penalize defaults as non-defaults more heavily
tree_loss_matrix <- rpart(loan_status ~ .,
                          method = "class",
                          data =  training_set,
                          control = rpart.control(cp = 0.001),
                          parms = list(loss=matrix(c(0,10,1,0),ncol=2)))

#Plot the decision tree
plot(tree_loss_matrix,
     uniform = TRUE)

#Add labels to the decision tree
text(tree_loss_matrix)

#Plot the cross-validated error rate as a function of the complexity parameter
plotcp(tree_prior)

#Use printcp() to identify for which complexity parameter the cross-validated error rate is minimized.
printcp(tree_prior)

#Create an index for of the row with the minimum xerror
index <- which.min(tree_prior$cptable[ , "xerror"])

#Create tree_min
tree_min <- tree_prior$cptable[index, "CP"]

#Prune the tree using tree_min
ptree_prior <- prune(tree_prior, cp = tree_min)

#Use prp() to plot the pruned tree
prp(ptree_prior)

#set a seed and run the code to construct the tree with the loss matrix again
set.seed(345)
tree_loss_matrix  <- rpart(loan_status ~ .,
                           method = "class",
                           data = training_set,
                           parms = list(loss=matrix(c(0, 10, 1, 0), ncol = 2)),
                           control = rpart.control(cp = 0.001))

#Plot the cross-validated error rate as a function of the complexity parameter
plotcp(tree_loss_matrix)

#Prune the tree using cp = 0.0012788
ptree_loss_matrix <- prune(tree_loss_matrix, cp=0.0012788)

#Use prp() and argument extra = 1 to plot the pruned tree
prp(ptree_loss_matrix, extra = 1)
case_weights <- ifelse(training_set$loan_status==0,1,3)

#Make a tree while adjusting the minsplit and minbucket parameters
tree_weights <- rpart(loan_status ~ .,
                      method = "class",
                      data = training_set,
                      weights = case_weights,
                      control = rpart.control(minsplit = 5, minbucket = 2, cp = 0.001))

#Plot the cross-validated error rate for a changing cp
plotcp(tree_weights)

#Create an index for of the row with the minimum xerror
index <- which.min(tree_weights$cp[ , "xerror"])

#Create tree_min
tree_min <- tree_weights$cp[index, "CP"]

#Prune the tree using tree_min
ptree_weights <- prune(tree_weights, cp =tree_min)

#Plot the pruned tree using the rpart.plot()-package
prp(ptree_weights, extra = 1)

#Make predictions for each of the pruned trees using the test set.
pred_undersample <- predict(ptree_undersample, newdata=test_set, type="class")
pred_prior <- predict(ptree_prior, newdata=test_set, type="class")
pred_loss_matrix <- predict(ptree_loss_matrix, newdata=test_set, type="class")
pred_weights <- predict(ptree_weights, newdata=test_set, type="class")

#Construct confusion matrices using the predictions.
confmat_undersample <- table(test_set$loan_status,pred_undersample)
confmat_prior <- table(test_set$loan_status, pred_prior)
confmat_loss_matrix <- table(test_set$loan_status, pred_loss_matrix)
confmat_weights <- table(test_set$loan_status, pred_weights)

#Compute the accuracies
acc_undersample <- sum(diag(confmat_undersample)) / nrow(test_set)
acc_prior <- sum(diag(confmat_prior)) / nrow(test_set)
acc_loss_matrix <- sum(diag(confmat_loss_matrix)) / nrow(test_set)
acc_weights <- sum(diag(confmat_weights)) / nrow(test_set)

#Make predictions for the probability of default using the pruned tree and the test set.
prob_default_prior <- predict(ptree_prior, newdata = test_set)[ ,2]

#Obtain the cutoff for acceptance rate 80%
cutoff_prior <- quantile(prob_default_prior, 0.8)

#Obtain the binary predictions.
bin_pred_prior_80 <- ifelse(prob_default_prior> cutoff_prior,1,0)

#Obtain the actual default status for the accepted loans
accepted_status_prior_80 <- cbind(prob_default_prior, bin_pred_prior_80)

test_set$loan_status[bin_pred_prior_80 == 0]

#Obtain the bad rate for the accepted loans
bad_rate <- sum(accepted_status_prior_80)/length(accepted_status_prior_80)
bad_rate

strategy_bank <- function(prob_of_def){
  cutoff=rep(NA, 21)
  bad_rate=rep(NA, 21)
  accept_rate=seq(1,0,by=-0.05)
  for (i in 1:21){
    cutoff[i]=quantile(prob_of_def,accept_rate[i])
    pred_i=ifelse(prob_of_def> cutoff[i], 1, 0)
    pred_as_good=test_set$loan_status[pred_i==0]
    bad_rate[i]=sum(pred_as_good)/length(pred_as_good)}
  table=cbind(accept_rate,cutoff=round(cutoff,4),bad_rate=round(bad_rate,4))
  return(list(table=table,bad_rate=bad_rate, accept_rate=accept_rate, cutoff=cutoff))
}

#Apply the function strategy_bank to both predictions_cloglog and predictions_loss_matrix
strategy_cloglog <- strategy_bank(predictions_cloglog)

#Obtain the strategy tables for both prediction-vectors
strategy_cloglog$table

#Plot the strategy function
par(mfrow = c(1,2))
plot(strategy_cloglog$accept_rate, strategy_cloglog$bad_rate,
     type = "l", xlab = "Acceptance rate", ylab = "Bad rate",
     lwd = 2, main = "logistic regression")

#Construct the objects containing ROC-information
ROC_logit <- roc(test_set$loan_status, predictions_logit)
ROC_probit <- roc(test_set$loan_status, predictions_probit)
ROC_cloglog <- roc(test_set$loan_status, predictions_cloglog)
ROC_all_full <- roc(test_set$loan_status, predictions_all_full)##

#Draw all ROCs on one plot
plot(ROC_logit)
lines(ROC_probit, col="blue")
lines(ROC_cloglog, col="red")
lines(ROC_all_full, col="green")

#Compute the AUCs
auc(ROC_logit)
auc(ROC_probit)
auc(ROC_cloglog)
auc(ROC_all_full)

predictions_undersample <- predict(ptree_undersample, newdata=test_set, type="vector")
predictions_prior <- predict(ptree_prior, newdata=test_set, type="vector")
predictions_loss_matrix <- predict(ptree_loss_matrix, newdata=test_set, type="vector")
predictions_weights <- predict(ptree_weights, newdata=test_set, type="vector")

#Construct the objects containing ROC-information
ROC_undersample <- roc(test_set$loan_status,predictions_undersample)
ROC_prior <- roc(test_set$loan_status,predictions_prior)
ROC_loss_matrix <- roc(test_set$loan_status,predictions_loss_matrix)
ROC_weights <- roc(test_set$loan_status,predictions_weights)

#Draw the ROC-curves in one plot
plot(ROC_undersample)
lines(ROC_prior,col="blue")
lines(ROC_loss_matrix,col="red")
lines(ROC_weights,col="green")

#Compute the AUCs
auc(ROC_undersample)
auc(ROC_prior)
auc(ROC_loss_matrix)
auc(ROC_weights)

#Build four models each time deleting one variable in log_3_remove_ir
log_4_remove_amnt <- glm(loan_status ~ grade + annual_inc + emp_cat,
                         family = binomial, data = training_set)
log_4_remove_grade <- glm(loan_status ~ loan_amnt + annual_inc + emp_cat, family = binomial, data = training_set)
log_4_remove_inc <- glm(loan_status ~ loan_amnt + grade + emp_cat, family = binomial, data = training_set)
log_4_remove_emp <- glm(loan_status ~ loan_amnt + grade + annual_inc, family = binomial, data = training_set)

#Make PD-predictions for each of the models
pred_4_remove_amnt <- predict(log_4_remove_amnt, newdata = test_set, type = "response")
pred_4_remove_grade <- predict(log_4_remove_grade, newdata = test_set, type = "response")
pred_4_remove_inc <- predict(log_4_remove_inc, newdata = test_set, type = "response")
pred_4_remove_emp <- predict(log_4_remove_emp, newdata = test_set, type = "response")

#Compute the AUCs
auc(test_set$loan_status,pred_4_remove_amnt)
auc(test_set$loan_status,pred_4_remove_grade)
auc(test_set$loan_status,pred_4_remove_inc)
auc(test_set$loan_status,pred_4_remove_emp)

#Build three models each time deleting one variable in log_4_remove_amnt
log_5_remove_grade <- glm(loan_status ~ annual_inc + emp_cat, family = binomial, data = training_set)
log_5_remove_inc <- glm(loan_status ~ grade + emp_cat, family = binomial, data = training_set)
log_5_remove_emp <- glm(loan_status ~ grade + annual_inc, family = binomial, data = training_set)

#Make PD-predictions for each of the models
pred_5_remove_grade <- predict(log_5_remove_grade, newdata = test_set, type = "response")
pred_5_remove_inc <- predict(log_5_remove_inc, newdata = test_set, type = "response")
pred_5_remove_emp <- predict(log_5_remove_emp, newdata = test_set, type = "response")

#Compute the AUCs
auc(test_set$loan_status,pred_5_remove_grade)
auc(test_set$loan_status,pred_5_remove_inc)
auc(test_set$loan_status,pred_5_remove_emp)

#Plot the ROC-curve for the best model here
plot(roc(test_set$loan_status,pred_4_remove_amnt))

str(pred_4_remove_amnt)

#Obtain the cutoff for acceptance rate 80%
cutoff_remove_amnt <- quantile(pred_4_remove_amnt, 0.8)

#Obtain the binary predictions.
bin_pred_remove_amnt <- ifelse(pred_4_remove_amnt> cutoff_remove_amnt,1,0)

#Obtain the actual default status for the accepted loans
accepted_status_remove_amnt <- cbind(pred_4_remove_amnt, bin_pred_remove_amnt)

#Check the structure of our new matrix
str(accepted_status_remove_amnt)

#Transform it into a dataframe for merging
accepted_status_remove_amnt <- data.frame(accepted_status_remove_amnt)

#Create a final dataframe which combines the predictions and actual test set
results_df <- cbind(test_set,accepted_status_remove_amnt)
table(results_df$loan_status,results_df$bin_pred_remove_amnt)