#' Build a Link-path Incidence Matrix
#'
#' This function builds a link-path incidence matrix, in which feasible routes are determined using stochastic network loading based on user-specified link costs. The routes are based on a probit model, implemented via simulation.
#' @param Links For a network with N nodes, Links is an NxN matrix. The i,j entry of Links is the link number (ID) for the node connecting node i to node j. Entries should be set to NA if there is no link between the node pair in question.
#' @param Costs A 2-column matrix, the first column of which is the link number (ID) and the second the link travel cost. Costs should be strictly positive.
#' @param theta Standard deviation of link costs when apply probit-based stochastic network loading to identify routes. Can be vector of length equal to the number of links, or a scalar (which is then replicated if necessary). Default value is theta=0, so that only shortest paths between OD pairs are generated.
#' @param nsim Number of simulation runs to find routes. In each run, link costs are modified by adding normal error, and the shortest paths computed with respect to these modified costs. nsim defaults to 100.
#' @param orig Set of nodes specified as possible origins of travel. Defaults to all nodes for which there is at least one feasible route to another node.
#' @param dest Set of nodes specified as possible destinations of travel. Defaults to all nodes that are reachable from elsewere by a feasible path.
#' @return A list containing the link-path incidence matrix A, a vector O specifying the origin for each path, and a vector D specifying the destination for each path.
#' @keywords link-path incidence matrix
#' @export
#' @examples
#' Links <- matrix(0,nrow=9, ncol=9)
#' Links[1,7] <- 1
#' Links[2,7] <- 2
#' Links[1,5] <- 3
#' Links[7,8] <- 4
#' Links[2,6] <- 5
#' Links[5,8] <- 6
#' Links[8,5] <- 7
#' Links[8,6] <- 8
#' Links[6,8] <- 9
#' Links[5,3] <- 10
#' Links[8,9] <- 11
#' Links[6,4] <- 12
#' Links[9,3] <- 13
#' Links[9,4] <- 14
#' Costs <- cbind(1:14,rep(1,14))
#' buildA(Links,Costs)
#' buildA(links,Costs,theta=0.4,orig=c(1,2),dest=c(3,4))

buildA <- function(Links,Costs,theta=0,nsim=100,orig=NA,dest=NA){
	require(e1071)
	r <- nrow(Links)
	n <- nrow(Costs)
	A <- D <- O <- numeric(0)
	X <- Links*NA
	theta <- rep(theta,length.out=n)
	if (is.na(orig[1])) orig <- 1:r
	if (is.na(dest[1])) dest <- 1:r
	if (theta[1] <= 0) nsim <- 1
	for (i in 1:nsim){
		for ( i in Costs[,1]){
			X[Links==Costs[i,1]] <- Costs[i,2] + rnorm(1,sd=theta[i])
		}
		X[X<0] <- 1e-6
		SP <- allShortestPaths(X)
		for (o in orig){
			for (d in dest){
				if (o!=d){
					if(!is.na(SP$length[o,d])){
						p <- extractPath(SP,o,d)
						a <- rep(0,n)
						for (j in 1:(length(p)-1) ){
							link <- Links[p[j],p[j+1]]
							a[link] <- 1
						}
						A <- cbind(A,a)
						O <- c(O,o)
						D <- c(D,d)
					}
				}
			}
		}
	}
	indx <- duplicated(A,MARGIN=2)
	A <- A[,!indx]
	O <- O[!indx]
	D <- D[!indx]
	indx <- order(O,D)
	A <- A[,indx]
	O <- O[indx]
	D <- D[indx]
	list(A=unname(A),O=O,D=D)
}


factors <- function(n)
{
   if(length(n) > 1)
   {
      lapply(as.list(n), factors)
   } else
   {
      one.to.n <- seq_len(n)
      one.to.n[(n %% one.to.n) == 0]
   }
}
factors(60)


#' Create spline curve and calculate 1st derivative
#'
#' @param YValues
#' @param XValues
#' @param xlabel
#' @param ylabel
#' @param mainlabel
#' @param ylim
#'
#' @return plot
#'
#' @examples
SplineCurveAndDerivative <- function(YValues, XValues,xlabel="x",ylabel="y",mainlabel="main",ylim=c(-0.5,0.5)){
  if(length(YValues)!=length(XValues)){
    stop("Number of elements in maturity and discount margin must be the same")
  }

  #spline

  spl <- smooth.spline(YValues~ XValues,all.knots = TRUE)
  par(mfrow=c(2,1))

  plot(spl,ylab = ylabel ,xaxt='n',xlab = xlabel,main = mainlabel)
  graphics::abline(h = 0, lty = 2)
  splData <- seq(min(XValues),max(XValues),(max(XValues)-min(XValues))/500)
  sx <- seq(from=head(XValues,1),to = tail(XValues,1),by = (tail(XValues,1)-head(XValues,1))/1000)
  lines(predict(spl,as.numeric(sx)))
  if(class(XValues) == "Date" || class(XValues)=="POSIXt"){
    axis.Date(side = 1,XValues,format = '%m/%Y',labels = T,at=XValues,las=2)
  }
  pred.prime<-predict(spl,as.numeric(sx),deriv=1)
  d1 <- data.frame(pred.prime)
  plot(d1,type = "l",xaxt='n',xlab=xlabel,ylab="derivative",ylim = ylim)
  graphics::abline(h = 0, lty = 2)
  if(class(XValues) == "Date"){
    axis.Date(side=1,sx,format = "%m/%Y",labels = T,at =XValues,las=2)
  }
  par(mfrow=c(1,1))
  recordedPlot =recordPlot()
  return(recordedPlot)

}


#' Function that carries out a sinusoidal regression
#'
#' Fits a sinusoid through data provided as an \code{x} and \code{y}
#' vector and returns a list containing both the fitted curve and the
#' parameters of that curve.
#' Used to produce initial values for modeling data windows and later
#' to find peaks in modeled julian day values to align the result to
#' a cumulative age timeline.
#'
#' @param x Vector of \code{x} values of input data
#' @param y Vector of \code{y} values of input data
#' @param fixed_period Optional variable for fixing the period of the sinusoid
#' in the depth domain. Defaults to \code{NA}, period is not fixed. Supply a
#' single value to fix the period.
#' @param plot Should the fitting result be plotted? \code{TRUE/FALSE}
#' @return A list containing a vector of parameters of the fitted sinusoid
#' and the fitted values belonging to each \code{x} value.
#' Fitting parameters:
#' \code{I} = the mean annual value of the sinusoid (height)
#' \code{A} = the amplitude of the sinusoid
#' \code{Dper} = the period of the sinusoid in \code{x} domain
#' \code{peak} = the location of the peak in the sinusoid
#' \code{R2adj} = the adjusted \code{R^2} value of the fit
#' \code{p} = the p-value of the fit
#' @examples
#' # Create dummy data
#' x <- seq(1000, 11000, 1000)
#' y <- sin((2 * pi * (seq(1, 11, 1) - 8 + 7 / 4)) / 7)
#' sinlist <- sinreg(x, y, plot = FALSE) # Run the function
#' @export
sinreg <- function(x, # Function to perform sinusoid regression meant to estimate the starting parameters for fitting growth and temperature sinusoids
    y,
    fixed_period = NA, # Option to fix the period in depth domain. Default = NA (Period not fixed)
    plot = FALSE # Plot results?
    ){

    if(is.na(fixed_period)){ # If period is not fixed, run simple periodogram to find the most likely period
        Ots <- ts(y) # Turn y into a time series
        ssp <- spectrum(Ots, plot = FALSE) # Create periodogram of y
        Nper <- 1/ssp$freq[ssp$spec==max(ssp$spec)] # Estimate period in terms of sample number
        Dper <- Nper * diff(range(x))/length(x) # Convert period to depth domain
    }else if(is.numeric(fixed_period) & length(fixed_period) == 1){ # Check if a valid entry is provided for Dper
        Dper <- fixed_period
    }else{
        stop("ERROR: Supplied value for fixed period is not recognized")
    }

    sinlm <- lm(y ~ sin(2*pi/Dper*x)+cos(2*pi/Dper*x)) # Run linear model, cutting up d18O = Asin(2*pi*D) into d18O = asin(D)+bcos(D)
    sinm<-sinlm$fitted # Extract model result
    if(plot == TRUE){
        dev.new()
        plot(x, y); lines(x, sinm, col = "red")
    }

    coeff<-summary(sinlm)[["coefficients"]] # Extract a, b and intercept + uncertainties

    # Calculate coefficients of the form d18O = I + Asin(2*pi*D + p)
    I<-coeff[1,1] # Intercept (mean annual value)
    A<-sqrt(coeff[2,1]^2+coeff[3,1]^2) # Amplitude of seasonality
    phase<--acos(coeff[2,1]/A) # Phase of sinusoid
    peak<-(0.25+(phase/(2*pi))) * Dper # timing of seasonal peak
    R2adj<-summary(sinlm)$adj.r.squared # Goodness of model fit (adjusted R2)
    p <- as.numeric(pf(summary(sinlm)$fstatistic[1],summary(sinlm)$fstatistic[2],summary(sinlm)$fstatistic[3],lower.tail=F)) # p-value of model

    return(list(c(I,A,Dper,peak,R2adj,p),sinm)) # Return results of regression
}


opt_d<-function(v){
  n<- length(v)

  profiled_lik <- function(v1, v2){
    mu1 <- mean(v1)
    mu2 <- mean(v2)
    d1<- v1- mu1
    d2<- v2- mu2
    n<- length(v1) + length(v2)
    sigma2 <- (sum(d1^2) + sum(d2^2))/(n-1)
    -0.5*log(sigma2*2*pi)*n- (n-1)/2
  }

  list_p_lik<- do.call("c",lapply(c(1:(n-1)), function(i){
    profiled_lik(v[1:i],v[(i+1):n])
  }))

  which.max(list_p_lik)

}


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

rm(list = ls())

observed <- c(0.59, 0.72, 0.47, 0.44, 0.31, 0.56, 0.22, 0.90, 0.96, 0.78, 0.66, 0.18, 0.73, 0.43, 0.58, 0.11)

test <- ks.test(observed, punif)

(pvalue <- test$p.value)
# 0.614776160341058


#' Calculate social network measures
#'
#' This function calculate network measures from social networks
#' generated from Veritas data.
#'
#' Calculate the following measures:
#'  - *people_degree:* Number of individually reported people
#'  - *group_degree:* Number of people generated from groups
#'  - *degree:* Number of people
#'  - *clustering:* Participant clustering coefficient. Equivalent of the
#'    network density without relations between the participants and the alters.
#'  - *simmelian:* Simmelian brokerage.
#'    See [Latora et al., 2013](https://doi.org/10.1007/s10955-013-0722-z)
#'
#' @param social_networks networks generated with [createSocialNetworks()]
#'
#' @return Data frame of network measures by participant
#'
#' @export
socialNetworkMeasures <- function(social_networks){

    # Create a function to calculate measure on a single network
    calculateMeasures <- function(g){

        # Degree
        people_degree <- sum(igraph::V(g)$status %in% "alter")
        group_degree <- sum(igraph::V(g)$status %in% "group")
        all_degree <- people_degree + group_degree

        # Clustering
        cc <- igraph::induced.subgraph(g, igraph::V(g)$status != "ego") %>%
                    igraph::graph.density()

        # Simmelian brokerage
        sb <- simmelianBrokerage(g)

        # Return
        c(people_degree = people_degree, group_degree = group_degree,
          degree = all_degree, clustering = cc, simmelian = sb)
    }

    # Run on all social networks
    out <- do.call(rbind, lapply(social_networks, calculateMeasures))

    # transform to data.frame and add pid as column
    out <- data.frame(out)
    out <- cbind(data.frame(pid = row.names(out)), out)
    row.names(out) <- NULL

    # Return
    return(out)
}

#' Calculate Simmelian Brokerage
#'
#' Adapted from a code by Christopher G. Watson.
#'  Retrieve from https://pastebin.com/XqkEYtJS
#'
#' @param g igraph network object generated with createSocialNetwork.r
#'
#' @return Simmelian Brokerage measure
#'
#' @noRd
simmelianBrokerage <- function(g){

  # Return NA if there is only less than two alter
  if(igraph::vcount(g) < 2) {
    return(NA)

    # Calculate local eff
  } else{

    # Remove ego
    g_sub <- igraph::induced.subgraph(g, igraph::V(g)$status != "ego")

    # Ego degree
    degree <- igraph::vcount(g_sub)

    # Calculate shortest path
    paths <- igraph::shortest.paths(g_sub, weights = NA)
    paths <- paths[upper.tri(paths)]

    # Calculate local efficiency
    local_eff <- 2 / degree / (degree - 1) * sum(1 / paths[paths != 0])

    # Calculate simmelian
    return(degree - (degree - 1) * local_eff)

  }
}


makeRmd <- function(test,inclPre=TRUE){
    varb <- paste0('has',test)
    cat('
---
title: "Attrition Analysis:',test,', ',ifelse(inclPre,'Including','Excluding'),' Pretest No-Shows"
output: html_document
---

```{r init, include=FALSE}
library(knitr)
opts_chunk$set(echo=FALSE,message=FALSE,warning=FALSE,error=FALSE,fig.width=9,fig.height=9,
  cache=FALSE)
```

```{r}
library(tidyverse)
library(RItools)
library(mosaic)
source("../code/functions.r")

Scale <- function(x) (x-mean(x,na.rm=TRUE))/sd(x,na.rm=TRUE)

dat <- read_csv("../data/Assessment_merged_2021_06_16_state_assessment_N=4311.csv")

### attrition variables
dat <- dat%>%
    mutate(
        ScaleScore7 = Scale(Scale.Score_7th.grade),
        hasPretest=is.finite(pre_MA_total_score),
        hasMidtest=is.finite(mid_MA_total_score),
        hasPosttest=is.finite(post_MA_total_score),
        hasDelayed=is.finite(delayed.total_math_score),
        hasStatetest=is.finite(ScaleScore7),
        Z =rdm_condition
)%>%
filter(!is.na(Z))
```

```{r}

dat <- dat%>%
    mutate(
        race=student_raceEthnicityFed%>%
               factor()%>%
               fct_lump_min(200)%>%
               fct_recode(`Hispanic/Latino`="1",Asian="3",White="6",Black="4")%>%
            fct_relevel("White"),
        ScaleScore5 = Scale(`ScaleScore_5th grade`),
        pretest = pre.total_math_score-round(mean(pre.total_math_score,na.rm=TRUE))
        )

covNames <-
    c("pretest","ScaleScore5","race","FEMALE","EIP","ESOL","IEP","GIFTED") ## more?
```

#Drop schools with <0.01 posttest scores (S03 & S07)
```{r}

dat$initial_school_id[is.na(dat$initial_school_id)] <- "SNA"

## drop schools where (almost) everyone dropped out (S03 & S07)
dat <- dat%>%
    group_by(initial_school_id)%>%
    mutate(postPer=mean(hasPosttest))%>%
    filter(postPer>0.01)%>%
    ungroup()%>%
    select(-postPer)
```
',
ifelse(inclPre,'','
Excluding students with no pretest scores.
```{r}
dat <- filter(dat,hasPretest)
```
'
),'
```
````
Non-Attrition rates by condition:
```{r}

```{r attritionRates}
dat%>%
    bind_rows(mutate(dat,Z="Overall"))%>%
    mutate(Z=factor(Z,levels=c("Overall",unique(dat$Z))))%>%
    group_by(Z)%>%
    summarize(n_assigned=n(),across(starts_with("has"),mean))%>%
    kable(digits=3)
```

```

Study sample:
Students with ',test,' scores, ',ifelse(inclPre,'including','excluding'),' those without pretest scores, and excluding students of teachers in S03 and S07 and students with NA condition assignment.

```{r}
dat%>%
  filter(',varb,')%>%
  mutate(N=n())%>%
  group_by(Z)%>%
  summarize(Total=N[1],n=n())%>%
  kable()
```

Overall and Differential Attrition vis a vis WWC Standards:
```{r}
## treatment levels
trtLevs <- unique(na.omit(dat$Z))
trtLevs <- trtLevs[!endsWith(trtLevs,"Resource")]
nlevs <- length(trtLevs)
ndiff <- nlevs*(nlevs-1)/2

wwc <- read.csv("wwc.csv")
names(wwc)[1] <- "Overall"

ov <- NULL
diff <- NULL
diffName <- NULL

for(i in 1:(nlevs-1))
  for(j in (i+1):nlevs){
    diffDat <- filter(dat,Z%in% trtLevs[c(i,j)])
    ov <- c(ov,1-mean(diffDat[["',varb,'"]]))
    diff <- c(diff,
               mean(subset(diffDat,Z==trtLevs[i])[["',varb,'"]])-
               mean(subset(diffDat,Z==trtLevs[j])[["',varb,'"]])
             )
             diffName <- c(diffName,paste(trtLevs[c(i,j)],collapse=" vs. "))
  }

with(wwc,
  plot(Overall,Differential1,type="l",ylim=c(0,11),
       main="',paste(test,ifelse(inclPre,'Including','Excluding'), 'Pretest No-Shows'),'",
                  xlab="Overall Attrition", ylab="Differential Attrition"))
  polygon(c(0,0,65,65),c(0,11,11,0),col="red")
  polygon(c(0,wwc[[1]],65),c(0,wwc$Differential1,0),col="yellow")
  polygon(c(0,wwc[[1]]),c(0,wwc$Differential0),col="green")

  ov <- ov*100
  diff <- abs(diff)*100

  points(ov,diff,pch=16)
  text(ov,diff,diffName,pos=2)

```

Balance plot:
```{r}
dat%>%
    filter(',varb,')%>%
    mutate(race=substr(as.character(race),1,1))%>%
    balPlot(covNames,trtVar="Z",data=.)
```

Balance tests:
```{r}
ddd <- dat%>%
    filter(',varb,',!is.na(Z), !endsWith(Z,"Resource"))

tests <- map_dfr(covNames,~balTestOne(ddd[[.]],ddd$Z,ddd$initial_teacher_class))
tests <- tests[,sapply(tests,function(x) all(!is.na(x)))]
tests$p.adj <- p.adjust(tests$p.value,method="fdr")
tests$covariate <- covNames
tests%>%
    select(covariate,method,statistic,p.value,p.adj)%>%
    kable()
```
xBalance version:
```{r}
covForm <- as.formula(paste("~",paste(covNames,collapse="+")))
totForm <- update(covForm,Z~.)

bals <- xbalMult(totForm,ddd,trtLevs=unique(ddd$Z)[!endsWith(unique(ddd$Z),"Resource")],strata=list(cls=~ddd$initial_teacher_class),na.rm=TRUE)
plotXbals(bals)

map_dfr(names(bals),~tibble(Comparison=.,Overall.p=bals[[.]]$overall[1,"p.value"]))%>%
    kable(digits=3)
```
',
file=paste0(test,'Attrition',ifelse(inclPre,'','ExclPre'),'.Rmd'),
sep='',append=FALSE
)
}

for(test in c('Midtest','Posttest','Delayed','Statetest')){
    makeRmd(test)
    knitr::knit(paste0(test,'Attrition.Rmd'))
    rmarkdown::render(paste0(test,'Attrition.md'))
}


## Indicator Library

EMA <- function(starttime, endtime, duration, symbol, env,datatype){
  if (starttime == endtime){
    return(SMA(starttime, duration, symbol, env, datatype)) #### Change when SMA function is written
  }
  else{
    timeweight = 2/(duration +1)
    EMAval = (env[[datatype]][["CLOSE"]][currtime] -
                EMA(starttime - 1, endtime, duration, symbol, env,datatype))*timeweight +
                EMA(starttime - 1, endtime, duration, symbol, env,datatype)
    return (EMAval)
  }
}

MACD <- function(starttime, endtime1, endtime2, endtime3, duration1, duration2, duration3, symbol, env,datatype){
  MACDval = EMA(starttime, endtime1, duration1, symbol, env, datatype) -
            EMA(starttime, endtime2, duration2, symbol, env, datatype)
  signalval = EMA(starttime, endtime3, duration3, symbol, env, datatype)
  return (MACDval - signalval)
}


AKS<-function(p){
  i<-2:p-1
  l<-unique(factorial(p) / (factorial(p-i) * factorial(i)))
  if(all(l%%p==0)){
    print(noquote("It is prime."))
  }else{
   print(noquote("It isn't prime."))
  }
}


l0 <- 15 # length going at sea
l.inf <- c(100, 110) # theoritical max length, different by country
k <- .5 # yearly growth rate start
k.year <- k * (1 - .01 * 0:(year.end - year.start))# growth rate decreasing with year
sd.length <- 5 # var around mean
t0 <- -.91 # parameter shifting von bertalanffy growth curve

# mean length faben version von bertqlanffy growth model
mean.length <- l0 +
  (l.inf[as.numeric(as.factor(salmons$country))] - l0) *
  (1 -
     exp(- k.year[salmons$year - min(salmons$year) + 1] *
           (salmons$sea.age - t0)))

hist(mean.length)

# add gamma noise
length <- rgamma(n = dim(salmons)[1],
                 shape = (mean.length / sd.length) ^ 2,
                 scale = (sd.length ^ 2) / mean.length)
hist(length)
min(length)
salmons$length <- round(length, 1)
# add noise with normal and coeffcient of variation
#length <- rnorm(n = dim(salmons)[1], mean = mean.length, sd = mean.length * .1)
#length <- round(length, 1)
#hist(length)


args <- commandArgs(trailingOnly = TRUE)

m.data <- read.table (file = args[1], sep = "\t", header = TRUE, row.names = 1)
m.data <- as.matrix (m.data)
m.data <- t (m.data)

res.table <- matrix (NA, nrow = ncol (m.data), ncol = 6)
rownames (res.table) <- colnames (m.data)
colnames (res.table) <- c ("p.linear.model", "p.feat.wt", "p.feat.rest", "mean.feat", "mean.rest", "mean.wt")

for (i in 3:ncol (m.data)) {

	if (args[3] == 1) {
		res <- lm(m.data[,1] ~ m.data[,i])
		res.sum <- anova (res)
		res.table[i,1] <- res.sum$'Pr(>F)'[1]
	} else {
		res <- anova(lm (m.data[,1] ~  m.data[,2] + m.data[,i]))
		res.table[i,1] <- res$'Pr(>F)'[2]
	}

	sub.feat <- subset (as.numeric(as.character(m.data[,1])), m.data[,i] == "Feat")
	sub.rest <- subset (as.numeric(as.character(m.data[,1])), m.data[,i] == "Rest")
	sub.wt <- subset (as.numeric(as.character(m.data[,1])), m.data[,i] == "WT")

	if (is.finite(mean (sub.feat))) {
		res.table[i,4] <- mean (sub.feat)
	}

	if (is.finite(mean (sub.rest))) {
		res.table[i,5] <- mean (sub.rest)
	}

	if (is.finite(mean (sub.wt))) {
		res.table[i,6] <- mean (sub.wt)
	}

	if (length (sub.feat) > 2 & length (sub.wt) > 2) {
		res.p <- wilcox.test (sub.feat, sub.wt)
		res.table[i,2] <- res.p$p.value
	}

	if (length (sub.feat) > 2 & length (sub.rest) > 2) {
		res.p <- wilcox.test (sub.feat, sub.rest)
		res.table[i,3] <- res.p$p.value
	}
}

res.table <- as.data.frame (res.table)
res.table$pcorr <- p.adjust (res.table$p.linear.model, method = "fdr")

write.table (res.table, file = args[2], sep = "\t", col.names = FALSE, row.names = TRUE, quote = FALSE)


str(Titanic)
titanic=data.frame(Titanic)
str(titanic)
#filter data where survived = Yes
#error-->filter(titanic,Survived=="Yes")
(df <- titanic[ which(titanic$Survived == "Yes"),])
df
(df1 <- titanic[which(titanic$Sex == "Male" | titanic$Survived == "Yes"),])
df1
#https://youtu.be/fbsNhipRK3Y https://youtu.be/1UJ2KUzIOKw

#attach
attach(titanic)
(df <- titanic[which(Survived == "Yes"),])
(df <- titanic[which(Survived == "Yes",c(1,3,5)),])
df
View(mtcars)
mpg
mtcars$mpg
attach(mtcars)
mpg
detach(mtcars)
mpg

#using subset method for filter data
df2 <- subset(titanic,Survived == "Yes" & Sex == "Male")
df2

#limit the set of column
df3 <- subset(titanic,Survived == "Yes" & Sex == "Male",select=c(1,3,5))
df3

#sample
(x <- sample(1:100)) #random
(x1 <-1:100) # sequence
(x <-sample(50,10)) # replace =F
(x <- sample(2,50,replace=T,prob=c(0.8,0.2)))
(x <- sample(3,50,replace=T,prob=c(0.5,0.3,0.2)))

#rep
(y <- rep(1:5)) #times=1
(y <- rep(c("a","d"),4,5))
(y <- rep(c("a","d"),times=4,len=5))
(y <- rep(c("a","d"),times=4,each=5,len=50))


library(dplyr)
library(tidyr)
library(ggplot2)
library(ascii)
library(lubridate)
library(ellipse)
library(mclust)
library(cluster)

###############################################################
## Import datasets needed for chapter 7
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

sp500_px <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_px.csv'), row.names = 1)
sp500_sym <- read.csv(file.path(PSDS_PATH, 'data', 'sp500_sym.csv'), stringsAsFactors = FALSE)
loan_data <- read.csv(file.path(PSDS_PATH, 'data', 'loan_data.csv'))
loan_data$outcome <- ordered(loan_data$outcome, levels=c('paid off', 'default'))

###############################################################
## PCA for oil data
oil_px = as.data.frame(scale(oil_px, scale=FALSE))
oil_px <- sp500_px[, c('CVX', 'XOM')]
pca <- princomp(oil_px)
pca$loadings

## Figure 7-1: principal components for oil stock data
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0701.png'), width = 4, height=4, units='in', res=300)
loadings <- pca$loadings
ggplot(data=oil_px, aes(x=CVX, y=XOM)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values=c(46)) +
  stat_ellipse(type='norm', level=.99, color='grey25') +
  geom_abline(intercept = 0, slope = loadings[2,1]/loadings[1,1], color='grey25', linetype=2) +
  geom_abline(intercept = 0, slope = loadings[2,2]/loadings[1,2],  color='grey25', linetype=2) +
  scale_x_continuous(expand=c(0,0), lim=c(-3, 3)) +
  scale_y_continuous(expand=c(0,0), lim=c(-3, 3)) +
  theme_bw()

dev.off()

## Figure 7-2: screeplot
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0702.png'), width = 4, height=4, units='in', res=300)

syms <- c( 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM', 'SLB', 'COP',
           'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
top_cons <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]
sp_pca <- princomp(top_cons)
par(mar=c(6,3,0,0)+.1, las=2)
screeplot(sp_pca, main='')

dev.off()

## Loadings for stock data
loadings = sp_pca$loadings[,1:5]
loadings <- as.data.frame(loadings)
loadings$Symbol <- row.names(loadings)
loadings <- gather(loadings, "Component", "Weight", -Symbol)
head(loadings)

## Figure 7-3: Plot of component loadings
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0703.png'), width = 4, height=4, units='in', res=300)

loadings$Color = loadings$Weight > 0
ggplot(loadings, aes(x=Symbol, y=Weight, fill=Color)) +
  geom_bar(stat='identity', position = "identity", width=.75) +
  facet_grid(Component ~ ., scales='free_y') +
  guides(fill=FALSE)  +
  ylab('Component Loading') +
  theme_bw() +
  theme(axis.title.x = element_blank(),
        axis.text.x  = element_text(angle=90, vjust=0.5))

dev.off()

###############################################################
## K-means chapter

set.seed(1010103)
df <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
km <- kmeans(df, centers=4, nstart=1)

df$cluster <- factor(km$cluster)
head(df)

centers <- data.frame(cluster=factor(1:4), km$centers)
centers

## Figure 7-4: K-means clusters for two stocks
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0704.png'), width = 4, height=3, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values = 1:4,
                     guide = guide_legend(override.aes=aes(size=1))) +
  geom_point(data=centers,  aes(x=XOM, y=CVX), size=2, stroke=2)  +
  theme_bw() +
  scale_x_continuous(expand=c(0,0), lim=c(-2, 2)) +
  scale_y_continuous(expand=c(0,0), lim=c(-2.5, 2.5))

dev.off()

## cluster means algorithm
syms <- c( 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM', 'SLB', 'COP',
           'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
df <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]

set.seed(10010)
km <- kmeans(df, centers=5, nstart=10)
km$size
centers <- km$centers

#centers <- scale(scale(centers, center=FALSE, scale=1/attr(df, 'scaled:scale')),
#                 center=-attr(df, 'scaled:center'), scale=FALSE)

## Figure 7-5 interpreting the clusters
centers <- as.data.frame(t(centers))
names(centers) <- paste("Cluster", 1:5)
centers$Symbol <- row.names(centers)
centers <- gather(centers, "Cluster", "Mean", -Symbol)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0705.png'), width = 4, height=5, units='in', res=300)

centers$Color = centers$Mean > 0
ggplot(centers, aes(x=Symbol, y=Mean, fill=Color)) +
  geom_bar(stat='identity', position = "identity", width=.75) +
  facet_grid(Cluster ~ ., scales='free_y') +
  guides(fill=FALSE)  +
  ylab('Component Loading') +
  theme_bw() +
  theme(axis.title.x = element_blank(),
        axis.text.x  = element_text(angle=90, vjust=0.5))

dev.off()

## Figure 7-6: selecting the number of clusters (elbow plot)
pct_var <- data.frame(pct_var = 0,
                      num_clusters=2:14)
totalss <- kmeans(df, centers=14, nstart=50, iter.max = 100)$totss
for(i in 2:14){
  pct_var[i-1, 'pct_var'] <- kmeans(df, centers=i, nstart=50, iter.max = 100)$betweenss/totalss
}

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0706.png'), width = 4, height=3, units='in', res=300)

ggplot(pct_var, aes(x=num_clusters, y=pct_var)) +
  geom_line() +
  geom_point() +
  labs(y='% Variance Explained', x='Number of Clusters') +
  scale_x_continuous(breaks=seq(2, 14, by=2))   +
  theme_bw()
dev.off()

################################################################
## hclust chapter

syms1 <- c('GOOGL', 'AMZN', 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX',
           'XOM', 'SLB', 'COP', 'JPM', 'WFC', 'USB', 'AXP',
           'WMT', 'TGT', 'HD', 'COST')

df <- sp500_px[row.names(sp500_px)>='2011-01-01', syms1]
d <- dist(t(df))
hcl <- hclust(d)

## Figure 7-7: dendograme of stock data
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0707.png'), width = 4, height=4, units='in', res=300)

par(cex=.75, mar=c(0, 5, 0, 0)+.1)
plot(hcl, ylab='distance', xlab='', sub='', main='')

dev.off()

## Figure 7-8: comparison of the different measuresof dissimilarity
cluster_fun <- function(df, method)
{
  d <- dist(df)
  hcl <- hclust(d, method=method)
  tree <- cutree(hcl, k=4)
  df$cluster <- factor(tree)
  df$method <- method
  return(df)
}

df0 <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
df <- rbind(cluster_fun(df0, method='single'),
            cluster_fun(df0, method='average'),
            cluster_fun(df0, method='complete'),
            cluster_fun(df0, method='ward.D'))
df$method <- ordered(df$method, c('single', 'average', 'complete', 'ward.D'))

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0708.png'), width = 5.5, height=4, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.3) +
  scale_shape_manual(values = c(46, 3, 1,  4),
                     guide = guide_legend(override.aes=aes(size=2))) +
  facet_wrap( ~ method) +
  theme_bw()

dev.off()

###############################################################
# Model-based clusting
# Multivariate normal

mu <- c(.5, -.5)
sigma <- matrix(c(1, 1, 1, 2), nrow=2)
prob <- c(.5, .75, .95, .99) ## or whatever you want
names(prob) <- prob ## to get id column in result
x <- NULL
for (p in prob){
  x <- rbind(x,  ellipse(x=sigma, centre=mu, level=p))
}
df <- data.frame(x, prob=factor(rep(prob, rep(100, length(prob)))))
names(df) <- c("X", "Y", "Prob")

## Figure 7-9: Multivariate normal ellipses
dfmu <- data.frame(X=mu[1], Y=mu[2])
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0709.png'), width = 4, height=4, units='in', res=300)

ggplot(df, aes(X, Y)) +
  geom_path(aes(linetype=Prob)) +
  geom_point(data=dfmu, aes(X, Y), size=3) +
  theme_bw()

dev.off()

## Figure 7-10 mclust applied XOM and CVX

df <- sp500_px[row.names(sp500_px)>='2011-01-01', c('XOM', 'CVX')]
mcl <- Mclust(df)
summary(mcl)

cluster <- factor(predict(mcl)$classification)
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0710.png'), width = 5, height=4, units='in', res=300)

ggplot(data=df, aes(x=XOM, y=CVX, color=cluster, shape=cluster)) +
  geom_point(alpha=.8) +
  theme_bw() +
  scale_shape_manual(values = c(46, 3),
                     guide = guide_legend(override.aes=aes(size=2)))

dev.off()

summary(mcl, parameters=TRUE)$mean
summary(mcl, parameters=TRUE)$variance

## Figure 7-11: BIC scores for the different models fit by mclust

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0711.png'), width = 4, height=4, units='in', res=300)

par(mar=c(4, 5, 0, 0)+.1)
plot(mcl, what='BIC', ask=FALSE, cex=.75)

dev.off()
#

#######################################################################
# Scaling chapter

defaults <- loan_data[loan_data$outcome=='default',]
df <- defaults[, c('loan_amnt', 'annual_inc', 'revol_bal', 'open_acc', 'dti', 'revol_util')]
km <- kmeans(df, centers=4, nstart=10)
centers <- data.frame(size=km$size, km$centers)
round(centers, digits=2)

df0 <- scale(df)
km0 <- kmeans(df0, centers=4, nstart=10)
centers0 <- scale(km0$centers, center=FALSE, scale=1/attr(df0, 'scaled:scale'))
centers0 <- scale(centers0, center=-attr(df0, 'scaled:center'), scale=FALSE)
centers0 <- data.frame(size=km0$size, centers0)
round(centers0, digits=2)

km <- kmeans(df, centers=4, nstart=10)
centers <- data.frame(size=km$size, km$centers)
round(centers, digits=2)

## Figure 7-12: screeplot for data with dominant variables

syms <- c('GOOGL', 'AMZN', 'AAPL', 'MSFT', 'CSCO', 'INTC', 'CVX', 'XOM',
          'SLB', 'COP', 'JPM', 'WFC', 'USB', 'AXP', 'WMT', 'TGT', 'HD', 'COST')
top_15 <- sp500_px[row.names(sp500_px)>='2011-01-01', syms]
sp_pca1 <- princomp(top_15)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0712.png'), width = 4, height=4, units='in', res=300)

par(mar=c(6,3,0,0)+.1, las=2)
screeplot(sp_pca1, main='')

dev.off()

round(sp_pca1$loadings[,1:2], 3)

#
###############################################################
## Figure 7-13: Categorical data and Gower's distance

x <- loan_data[1:5, c('dti', 'payment_inc_ratio', 'home_', 'purpose_')]
x

daisy(x, metric='gower')

set.seed(301)
df <- loan_data[sample(nrow(loan_data), 250),
                c('dti', 'payment_inc_ratio', 'home_', 'purpose_')]
d = daisy(df, metric='gower')
hcl <- hclust(d)
dnd <- as.dendrogram(hcl)

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0713.png'), width = 4, height=4, units='in', res=300)
par(mar=c(0,5,0,0)+.1)
plot(dnd, leaflab='none', ylab='distance')
dev.off()

dnd_cut <- cut(dnd, h=.5)
df[labels(dnd_cut$lower[[1]]),]

## Problems in clustering with mixed data types
df <- model.matrix(~ -1 + dti + payment_inc_ratio + home_ + pub_rec_zero, data=defaults)
df0 <- scale(df)
km0 <- kmeans(df0, centers=4, nstart=10)
centers0 <- scale(km0$centers, center=FALSE, scale=1/attr(df0, 'scaled:scale'))
round(scale(centers0, center=-attr(df0, 'scaled:center'), scale=FALSE), 2)


require(plyr)
require(scales)

# ---------------------------------------------------------------------------------------------
# Formatting functions for ggplot  graph axis
# ---------------------------------------------------------------------------------------------

#' Human Numbers: Format numbers so they're legible for humans
#' Use this in ggplot for labels where you might use the comma or percent functions from the
#' Scales package.
#'
#' Checks whether numbers are positive or negative.
#' Allows up to 1 significant figure
#' sapply used for element-wise application of the humanity function as a vector may include
#' numbers where billions, millions or thousands are appropriate.
#'
#' @return a character vector the same length as the input vector
#' @param x a numeric vector to format,
#' @smbl a symbol you'd like to prefix your numbers by e.g. "$"
#' @signif = the number of significant places you want the function to return
#' @examples
#' human_numbers(c(1000000 , 1500000, 10000000000))
#' human_numbers(c(1.200000e+05, -2.154660e+05, 2.387790e+05, 4.343500e+04 ,5.648675e+12), "$")
#' ggplot2 + scale_y_continuous(labels = human_numbers)
#' ggplot2 + scale_x_continuous(labels = human_numbers)
#' ggplot2 + scale_x_continuous(labels = human_gbp)

human_numbers <- function(x = NULL, smbl ="", signif = 1){
  humanity <- function(y){

    if (!is.na(y)){
        tn <- round(abs(y) / 1e12, signif)
       b <- round(abs(y) / 1e9, signif)
       m <- round(abs(y) / 1e6, signif)
       k <- round(abs(y) / 1e3, signif)

      if ( y >= 0 ){
        y_is_positive <- ""
      } else {
        y_is_positive <- "-"
      }

      if ( k < 1 ) {
        paste0( y_is_positive, smbl, round(abs(y), signif ))
        } else if ( m < 1){
        paste0 (y_is_positive, smbl,  k , "k")
      } else if (b < 1){
        paste0 (y_is_positive, smbl, m ,"m")
      }else if(tn < 1){
          paste0 (y_is_positive, smbl, b ,"bn")
      } else {
        paste0 (y_is_positive, smbl,  comma(tn), "tn")
      }
    } else if (is.na(y) | is.null(y)){
        "-"
    }
  }

  sapply(x,humanity)
}

#' Human versions of large currency numbers - extensible via smbl

human_gbp   <- function(x){human_numbers(x, smbl = "£")}
human_usd   <- function(x){human_numbers(x, smbl = "$")}
human_euro  <- function(x){human_numbers(x, smbl = "€")}
human_num   <- function(x){human_numbers(x, smbl = "")}


library(DAAG) # пакет, в котором лежит база spam7
library(ggplot2) # очень хороший пакет для визуализации
library(GGally) # здесь мы берем функцию gpairs
library(dplyr) # кледезь функций для табличек
library(car)

require(rpart) # пакет для дерева решений
library(rpart.plot) # пакет для визуализации дерева решений

intall.packages('DAAG') # так мы устанавливаем пакеты

df = cars # подгружаем базу cars

head(df) # показать первые 5 строк

df = mutate(df, dist = dist*0.3, speed = 1.67*speed) # переводим километры в час и просто километры
qplot(df$speed, df$dist, xlab = 'speed', ylab= 'dist')#+ stat_smooth(method = 'lm') # визуализация

m1 = lm(data= df, dist~speed)
m1
summary(m1)

df2 = swiss # следующая база "Швециарские контоны"

head(df2)# показать первые 5 строк

ggpairs(df2) # хорошая визуализация

m2 = lm(data=df2, Fertility~Agriculture+Education+Catholic) # следующая модель
summary(m2)

###########################
spam = rpart(formula = yesno ~ crl.tot + dollar + bang + money + n000 + make, data=spam7) # дерево решений
rpart.plot(spam) # визуализация дерева


m <- c(1:12)
names(m) <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
              "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
month <- function(s) {
  12 * (as.numeric(substr(s, 5, 8)) - 1990) + m[substr(s, 1, 3)] - 1
}

cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), "; "), function(s) {
  r <- vector()
  for (i in s) {
    for (j in month(substr(i, 1, 8)):month(substr(i, 10, 17))) {
      if (!(j %in% r)) {
        r <- append(r, j)
      }
    }
  }
  length(r) %/% 12
}), sep="\n")


#' @param cparsk copula parameter vector, third component in [0,1]
#' @param eps tolerance for convergence
#' @param mxiter maximum number of Newton-Raphson iterations
#' @rdname bb1sk
#' @export
qcondbb1sk21=function(p,u,cparsk, eps=1.e-8,mxiter=30,iprint=F)
{
  iter=0; diff=1.;
  v=qcondbb1(p,u,cparsk[1:2])  # starting point
  #while(iter<mxiter & abs(diff)>eps)
  while(iter<mxiter & max(abs(diff))>eps)
  { num=pcondbb1sk21(v,u,cparsk)-p;
    den=dbb1sk(u,v,cparsk);
    diff=num/den;
    v=v-diff;
    #while(v<0. || v>1.) { diff=diff/2.; v=v+diff;}
    while(min(v)<0. | max(v)>1.) { diff=diff/2.; v=v+diff;}
    iter=iter+1;
    if(iprint) cat(iter,v,"\n")
  }
  v
}

#' @rdname bb1sk
#' @export
qcondbb1sk12=function(p,v,cparsk, eps=1.e-8,mxiter=30,iprint=F)
{
  iter=0; diff=1.;
  u=qcondbb1(p,v,cparsk[1:2])  # starting point
  #while(iter<mxiter & abs(diff)>eps)
  while(iter<mxiter & max(abs(diff))>eps)
  { num=pcondbb1sk12(u,v,cparsk)-p;
    den=dbb1sk(u,v,cparsk);
    diff=num/den;
    u=u-diff;
    #while(u<0. || u>1.) { diff=diff/2.; u=u+diff;}
    while(min(u)<0. | max(u)>1.) { diff=diff/2.; u=u+diff;}
    iter=iter+1;
    if(iprint) cat(iter,u,"\n")
  }
  u
}

#' @rdname bb1sk
#' @export
qcondbb1sk <- qcondbb1sk21


# load packages needed to run this code
library(generativeart)
library(ggplot2)
library(tidyr)
library(dplyr)
library(gganimate)
# library(tidyverse)
library(stringr)

# set seed
seed <- 4321
set.seed(seed)

# formula for new x, y coordinates
formula <- list(
  x = quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))
)

# making a data frame with the visualization
for (i in c(1:5)){ # going through five iterations to get to the desired image
  df <- seq(from = -pi, to = pi, by = 0.02) %>%
    expand.grid(x_i = ., y_i = .) %>%
    dplyr::mutate(!!!formula)
}

# split up the data frame to extract the initial and final states
df %>% select(x = x_i, y = y_i) %>%
  mutate(state = 1) -> df_t1 #initial state
df %>% select(x, y) %>%
  mutate(state = 2) -> df_t2 #final state

# combine the two data frames together
rbind(df_t1, df_t2) -> df_animate

# make an animation
df_animate %>%
  ggplot(aes(x = x, y = y)) +
  geom_point(alpha = 0.1, size = 0, shape = 20) +
  theme_void() +
  coord_fixed() +
  coord_polar() +
  theme(plot.background = element_rect(fill = "#ffe79a")) +
  transition_states(state, transition_length = 1, state_length = 1) -> p_genart

# save each animation as individual frames
# each frame will be saved as a PNG image
animate(p_genart,
        device = "png",
        width = 600,
        height = 600)

# save as gif
anim_save(str_interp("image_generation${seed}.gif"))


# Course Statistics for Data Scientists 2019-2020
# Case Study Linear Mixed Models

#reading the data from file
mydata<-read.table('DATARationSplitPlot.txt',header=T)
mydata
attach(mydata)

# changing variates to factors
Pair<-factor(pair)
Ration<-factor(ration)
Sex<-factor(sex,labels=c('male','female'))

...


# Enter your code here. Read input from STDIN. Print output to STDOUT
rej <- 0.12
answer1 <- pbinom(2, size = 10, prob = rej)
write(round(answer1, 3), stdout())
answer2 <- pbinom(8, size = 10, prob = 1 - rej)
write(round(answer2, 3), stdout())


# rgl demo: rgl-bivar.r
# author: Daniel Adler

rgl.demo.bivar <- function()
{
  require(MASS);

  # parameters:
  n<-50; ngrid<-40

  # generate samples:
  set.seed(31415)
  x<-rnorm(n); y<-rnorm(n)

  # estimate non-parameteric density surface via kernel smoothing
  denobj<-kde2d(x, y, n=ngrid)
  den.z <-denobj$z

  # generate parametric density surface of a bivariate normal distribution
  xgrid <- denobj$x
  ygrid <- denobj$y
  bi.z <- dnorm(xgrid)%*%t(dnorm(ygrid))

  # visualize:
  zscale<-20

  # New window
  open3d()

  # clear scene:
  clear3d("all")

  # setup env:
  bg3d(color="#887777")
  light3d()

  # Draws the simulated data as spheres on the baseline
  spheres3d(x,y,rep(0,n),radius=0.1,color="#CCCCFF")

  # Draws non-parametric density
  surface3d(xgrid,ygrid,den.z*zscale,color="#FF2222",alpha=0.5)

  # Draws parametric density
  surface3d(xgrid,ygrid,bi.z*zscale,color="#CCCCFF",front="lines")
}

rgl.demo.bivar()


# FUNCTION

is_triplet <- function(a, b, c) {
    (a < b) && (b < c) && (a ** 2 + b ** 2 == c ** 2)
}

# SCRIPT

for (a in 1:1000) {
    for (b in (a + 1):(1000 - a)) {
        c = 1000 - (a + b)
        if (is_triplet(a, b, c)) {
            cat(a, b, c, "\n", sep = " ")
            quit("no")
        }
    }
}


# init

library(mlbench)
data(PimaIndiansDiabetes)

N <- nrow(PimaIndiansDiabetes)
CLASS_COL <- ncol(PimaIndiansDiabetes)

IN_TRAIN <- sample(1:N, N * 2 / 3)
PIMA_TRAIN <- PimaIndiansDiabetes[IN_TRAIN,]
PIMA_TEST <- PimaIndiansDiabetes[ - IN_TRAIN,]

PIMA_FORM <- diabetes ~ .

### KNN ###

library(class)

PIMA_PRED <- knn(PIMA_TRAIN[, - CLASS_COL], PIMA_TEST[ - CLASS_COL], PIMA_TRAIN[, CLASS_COL], 3)
(PIMA_TAB <- table(PIMA_TEST[, CLASS_COL], PIMA_PRED))
(ERR_KNN <- 1 - sum(diag(PIMA_TAB)) / sum(PIMA_TAB))

### RPART ###

library(rpart)

(PIMA_MODEL <- rpart(PIMA_FORM, data = PIMA_TRAIN))

PIMA_PRED <- predict(PIMA_MODEL, PIMA_TEST, type = "class")
(PIMA_TAB <- table(PIMA_TEST[, CLASS_COL], PIMA_PRED))
(ERR_RPART <- 1 - sum(diag(PIMA_TAB)) / sum(PIMA_TAB))

### NAIVEBAYES ###

library(e1071)

(PIMA_MODEL <- naiveBayes(PIMA_FORM, data = PIMA_TRAIN))

PIMA_PRED <- predict(PIMA_MODEL, PIMA_TEST, type = "class")
(PIMA_TAB <- table(PIMA_TEST[, CLASS_COL], PIMA_PRED))
(ERR_NAIVEBAYES <- 1 - sum(diag(PIMA_TAB)) / sum(PIMA_TAB))

### SVM ###

(PIMA_MODEL <- svm(PIMA_FORM, PIMA_TRAIN))

PIMA_PRED <- predict(PIMA_MODEL, PIMA_TEST, type = "class")
(PIMA_TAB <- table(PIMA_TEST[, CLASS_COL], PIMA_PRED))
(ERR_SVM <- 1 - sum(diag(PIMA_TAB)) / sum(PIMA_TAB))

### NNET ###

library(nnet)

(PIMA_MODEL <- nnet(PIMA_FORM, PIMA_TRAIN, size = 1, maxit = 1000, decay = 1e-3))

PIMA_PRED <- predict(PIMA_MODEL, PIMA_TEST, type = "class")
(PIMA_TAB <- table(PIMA_TEST[, CLASS_COL], PIMA_PRED))
(ERR_NNET <- 1 - sum(diag(PIMA_TAB)) / sum(PIMA_TAB))

# summary

ERR_VAL <- c(ERR_KNN, ERR_RPART, ERR_NAIVEBAYES, ERR_SVM, ERR_NNET)
ERR_NAME <- c('KNN', 'RPART', 'NAIVEBAYES', 'SVM', 'NNET')
X <- barplot(ERR_VAL, names.arg = ERR_NAME, ylim = c(0, 1), col = '#800000')
text(X, y = ERR_VAL + 0.05, labels = paste(format(ERR_VAL * 100, digits = 3), "%", sep = ""))


load_all("~/Documents/GitHub/bc/frontiers2017")
source('R/helper_functions.r')
la <- load_all
te <- test
atp <- auto_test_package

run_full_long_tests <- FALSE

# Sample Data for use in testing:
# Test finger in flexed posture, from frontiers2018 feasibility theory paper
JR <- rbind(c(-0.08941, -0.0447, -0.009249, 0.03669, 0.1421, 0.2087, -0.2138), c(-0.04689,
    -0.1496, 0.052, 0.052, 0.0248, 0, 0.0248), c(0.06472, 0.001953, -0.1518, -0.1518,
    0.2919, 0.0568, 0.2067), c(0.003081, -0.002352, -0.0001649, -0.0001649, -0.0004483,
    0.0001579, -0.000685))
maximal_tension_per_muscle <- c(123, 219, 23.52, 91.74, 21.6, 124.8, 129.6)
muscle_name_per_index <- c("FDP", "FDS", "EIP", "EDC", "LUM", "DI", "PI")
force_dimnames <- c("Fx", "Fy", "Fz", "tx")
H_matrix <- JR %*% diag(maximal_tension_per_muscle)
colnames(H_matrix) <- muscle_name_per_index
rownames(H_matrix) <- force_dimnames
bounds_tuple_of_numeric <- rep(list(list(lower = 0, upper = 1)), length(maximal_tension_per_muscle))

# Toy example for testing and illustration
H_matrix_mini <- cbind(m0=c(3.333333333),
      m1=c(-3.533333333),
      m2=c(2.0))
rownames(H_matrix_mini) <- "Fx"
bounds_tuple_of_numeric_mini <- rep(list(list(lower = 0, upper = 1)), 3)

##' medial is towards center of the hand
##' derived from culled_hand4_flex_uar_5k_clean_static_response_from_tail_100ms_mean.csv
cadaver_5k_dataset_train4k_LRM <- function(){

muscle_name_per_index <- c("FDP","FDS","EIP","EDC","LUM","DI","PI")
wrench_names <- c("dorsal_fx","medial_fy","proximal_fz","JR3_MX","JR3_MY","JR3_MZ")

	lrm_model_of_tension_transduction <- rbind(c(-0.055472,0.0085059,-0.04143,0.040855,0.060872,0.0083857),
										   	   c(-0.051982,0.0056465,-0.088819,0.030892,0.08346,0.003642),
										   	   c(0.0052534,-0.0002142,0.025817,-0.002114,-0.0083006,-0.00026338),
										   	   c(0.0070741,-0.0036766,0.021978,-0.019363,-0.0087962,-0.0016665),
										   	   c(0.036154,0.0041829,-0.039141,0.0022464,-0.030165,0.003371),
										   	   c(-0.002553,-0.014332,-0.0088733,-0.088249,0.0106,-0.0037038),
										   	   c(0.039546,0.0079125,-0.038078,0.045004,-0.036593,0.0019535)) %>% t %>% as.data.frame
	colnames(lrm_model_of_tension_transduction) <- muscle_name_per_index
	rownames(lrm_model_of_tension_transduction) <- wrench_names
	bias_on_wrench <- c(0.30017,-0.034335,0.17062,-0.26764,-0.40899,-0.014565)
	names(bias_on_wrench) <- wrench_names
	# bounds_tuple_of_numeric <- rep(list(list(lower = 0, upper = 10)), length(muscle_name_per_index))
	# browser()
	bounds_tuple_of_numeric <- lapply(c(123, 219, 23.52, 91.74, 21.6, 124.8, 129.6),function(x) {list(lower = 0, upper = x)})
	return(list(H_matrix=lrm_model_of_tension_transduction, wrench_bias=bias_on_wrench, bounds_tuple_of_numeric=bounds_tuple_of_numeric))
}


fact = function(n)
{
  i = 1

  fact =1

  for(i in 1:n)
  {
    fact = fact * i

  }
  return(fact)
}
y = as.integer(readline(prompt = "enter a value"))
x = fact(y)
print(x)


#   R version: 4.0.2 x64
#   RStudio version: Version 1.3.1056 (Win 10)
#
#   Author: Aris Alissandrakis
#   Web: https://arisalissandrakis.wordpress.com/
#   Twitter: @AAlissandrakis

# Timelines are vectors of length equal to the number of time events (sample size, n, etc)

# The generate_timeline function returns a vector or length "sample_size",
# with minimum and maximum values "min_val" and "max_val",
# regression slope "slope",
# amplitude of noise "noise_amount",
# and a series of "bumps" (normal distributions added to the timeline) defined as a list of vectors
# containing values for where each bump is centered along the timeline "m", the spread of each bump "sd"
# and their peak amplitudes "a"

generate_timeline <- function(sample_size = 150, min_val = 0, max_val = 100, slope = .5, noise_amount = .1, bumps = list(m=c(75),sd=c(5),a=c(25)))
{
  if (!is.null(bumps))
  {
    n_bumps = length(bumps$m)
  }

  X = c()
  Y = c()

  for (t in c(1:sample_size))
  {
    x = t

    y = min_val + (max_val-min_val)/2

    y = y +  x * slope # add a slope

    if (!is.null(bumps))
    {
      for (b in c(1:n_bumps))
      {
        m = bumps$m[b]
        sd = bumps$sd[b]
        a = bumps$a[b] / dnorm(m,m,sd)
        y = y + a * dnorm(x,m,sd)
      }
    }

    y = y + (noise_amount * y) * rnorm(1)  # add noise

    X = c(X, x)
    Y = c(Y, y)
  }

  Y = Y - min(Y) # set minimum to zero
  Y = Y * (max_val - min_val) / max(Y) # set maximum value
  Y = Y + min_val # adjust minimum

  Y = round(Y)

  return(Y)
}

# The smooth_noise function generates a smoothed spline (of length "n" and amplitude "a")
# that can be added as additional noise to any generated timeline (of length "n").

smooth_noise <- function(n=150, a=10)
{
  noize = rnorm(n)

  # generate random normally distributed noise, with sample size n

  noize[1] = 0
  noize[n] = 0

  # make sure the first and last values are zero

  w = rep(0,n)

  # initialize a vector of size n

  w0 = sample(c(1:n),15)

  # randomly choose 15 indexes from 1 to n

  for (i in w0)
  {
    w[i] = 1
  }

  w[1] = 1
  w[n] = 1

  # assign a value of 1 to these indexes, also the first and last ones

  noize = smooth.spline(noize,w=w,df=20)$y

  # use smooth.spline() with noize and w

  noize = noize - min(noize)

  # subtract the min value, so the noize min value becomes zero

  noize = noize * a/max(noize)

  # multiply with the provided a value, to normalize noize values between zero and a

  noize = noize - a/2

  # make the mean value of noize zero

  return(noize)
}

# The scale_and_position_timeline function vertically scales (acording to "range")
# and repositions (centered at "position") a previously generated timeline "tl".

scale_and_position_timeline <- function(tl, range=50, position=50)
{
  range_tl = max(tl)-min(tl)

  if (range_tl>range)
  {
    tl = tl - min(tl)
    tl = tl * (range/max(tl))
  }

  # adjust range only if timeline range is larger than the provided range

  tl = tl - (mean(tl)-position)

  # adjust the vertical position of the timeline, centered around the provided position

  return(tl)
}


library(coop)
library(rbenchmark)
cols <- cols <- c("test", "replications", "elapsed", "relative")
reps <- 25

m <- 1000
n <- 150
x <- matrix(rnorm(m*n), m, n)

x[sample(m*n, size=.1*m*n)] <- NA_real_

benchmark(R=(res.r <- cov(x, use="pair")), coop=(res.coop <- covar(x, use="pair")), replications=reps, columns=cols)
all.equal(res.r, res.coop)

benchmark(R=(res.r <- cor(x, use="pair")), coop=(res.coop <- pcor(x, use="pair")), replications=reps, columns=cols)
all.equal(res.r, res.coop)


# From Max Gordon <max@gforge.se>
require(rms)
set.seed(1)
center <- factor(sample(letters[1:8],500,TRUE))
treat  <- factor(sample(c('a','b'),  500,TRUE))
y      <- 8*(treat=='b') + rnorm(500,100,20)
f <- ols(y ~ treat*center, x=TRUE, y=TRUE)
g <- bootcov(f, B=50)

lc <- levels(center)
contrast(f, list(treat='b', center=lc),
         list(treat='a', center=lc))


##' @title
##' Area Under Precision-Recall Curve
##'
##' @description
##'
##' \code{mtr_auc_prc}
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_auc_roc}}
##' @author An Chu
##' @include helper-functions.r
##' @examples
##'
##' set.seed(101)
##' pred <- runif(1000)
##' act <- round(pred)
##' pred[sample(1000, 500)] <- runif(500)   # noise
##' mtr_auc_prc(act, pred)
##'
##'
##'
##' @export
mtr_auc_prc <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    check_binary(actual)

    thresholds <- predicted
    recall <- map_dbl(thresholds, function(x) mtr_recall(actual, predicted, cutoff = x))
    precision <- map_dbl(thresholds, function(x) mtr_precision(actual, predicted, cutoff = x))

    trapezoid(precision, recall)
}


# alberto.fernandez.isabe@urjc.es
# Crear secuencias
seq(1,6)
# Crear secuencias siguiendo un patron
seq(1,6, by=0.5)
# Crear secuencias de x números
seq(1,6, length=10)

# Repetir una secuencia x veces
rep(1,5)
# Repetir un vector x veces
rep(c(1,2),5)
# Repetir una secuencia a partir de una secuencia
rep(1:4,2)
# Iterear entre una secuencia
rep(1:3, c(1,4,5))

# Vector con valores faltantes
x_na <- c(1,2,3,NA,4,5)
# Ver si existe un valor faltante NA
x_isna <- is.na(x_na)
# Factores
estudiantes.origen <- c("getafe","mostoles","leganes","madrid","parla")
# Longitud
length(estudiantes.origen)
# Como un fator
festudiantes <- as.factor(estudiantes.origen)
# Funciones level y summary
levels(festudiantes)
summary(festudiantes)
# Función tapply, aplica una funcion en cada grupo de componentes del primer argumento con la del segundo utilizando una funcion
# Para que funcione ambos argumentos tienen que tener la misma longitud
estudiantes.altura <- c(1.53,1.65,1.64,1.74,1.90)
tapply(estudiantes.altura, estudiantes.origen, mean)
# Factores ordenados
nivel.ingles <- c("medio", "bajo", "medio", "alto", "medio")
fnivel.ingles = ordered(nivel.ingles, levels=c("bajo", "medio", "alto"))
fnivel.ingles

# Matrices

# matrix(data,row,col)

matrix(1:6) # Matriz 6,1
matrix(1:6, nrow=2) # Matriz 2 ,3
matrix(1:6, nrow=2, byrow=1)

# summary en una matriz da información min, max, media, mediana, etc

# Dataframe, lista de listas, una matriz tiene que tener siempre los mismos tipos de datos, en un dataframe cada lista tiene un tipo
# de dato
# data.frame(data1,data2)
# attach accede a los nombres de variables de un dataframe, lista ó entorno
# deatach anula los accesos

# merge mezcla todos los valores no repetidos si all=TRUE si está all=FALSE (por defecto) los repetidos

# Setear todos los valores NA,
# Media sin tener en cuenta los NA
mean(airquality[airquality$Month == 7,]$Ozone, na.rm = TRUE)
# Mayor temperatura y ozono

# Operador %>% lanza una función sobre un iterable (matriz, dataframe, etc...)

length(airquality[airquality$Ozone<100&airquality$Temp>90,]$Month)

# tidy r
# Cada variable forma una columna
# Cada observación forma una fila
# Cada tipo de unidad de observación es una tabla
# gather() toma varias columnas y las devuelve clave-valor
# spread() toma dos columnas clave valor y las seapara
# separate() toma una columna y las separa
# unite() toma dos columnas y las unen

# dply
# select() seleciona variables
# filter() ver observacones en las que no coincidde con un valor
# group_by() agrupa
# summarise() ejecuta funciones y devuelve valores de una columna
# arrange() permite ordenar
# inner_join()
df2 <- head(mtcars)
filter(df2,wt < 2.5)
df4 <- head(mtcars)
summarise(df4, mean = mean(disp))

df5 <- head(mtcars)
arrange(df5, wt , hp) # Ordena dataset por las columnas introducidas

# joins
inner_join(band_members, band_instruments, by="name")
left_join(band_members, band_instruments, by="name")
right_join(band_members, band_instruments, by="name")
full_join(band_members, band_instruments, by="name")
# Datos que coinciden en el segundo dataset y muestra los del primero
semi_join(band_members, band_instruments, by="name")
# Datos que no coinciden en el segundo dataset y muestra los del primero
anti_join(band_members, band_instruments, by="name")

# Mutate mutate()
df6 <- head(mtcars)
mutate(df6, cyl_sqr = cyl * cyl) # Añade nueva columna
mutate(df6, cyl_sqr = NULL) # Elimina la columna nombrada

set.seed(1)
stocks <- data.frame(time = as.Date('2009-01-01') + 0:9,
                     Walmart = rnorm(10, 20, 1), Target = rnorm(10, 20, 2),
                     Walgreens = rnorm(10, 20, 4))
# Generar clave valor para stock y precio
s2 <- gather(stocks, key=stock, value=price, "Walmart", "Walgreens")
# Devolver el cambio al valor anterior
s3 <- spread(s2, key=stock, value=price)
# Anidar gather, group by, summarise
stocks %>% gather(key=stock, value=price, "Walmart","Walgreens") %>% group_by(key=stock) %>% summarise(min = min(price), max = max(price))


##' @title
##' Classification Metrics Parameters
##'
##' @description
##'
##' Documentation for shared parameters of functions that computes
##' classification metrics.
##'
##' @param actual \code{[numeric]} Ground truth binary numeric vector containing
##'     1 for the positive class and 0 for the negative class.
##' @param predicted \code{[numeric]} A vector of estimated probabilities.
##' @param cutoff \code{[numeric]} A cutoff value for \code{predicted} vector
##'     which classify a sample into a given class. Default value is 0.5
##'
##' @include helper-functions.r
##' @name classification_params
NULL

##' @title
##' Confusion Matrix
##'
##'
##' @description
##'
##' Confusion matrix - a special kind of contingency table - is a specific table
##' layout that allows the visualization of performance of a classification
##' model (or classifier). It composes of four different combinations of
##' predicted and actual values.
##'
##' \code{confusion_list} computes and returns those combinations as a
##' \code{named list} while \code{mtr_confusion_matrix} returns a \code{named
##' matrix}.
##'
##' Here's elements of confusion matrix:
##'
##' \itemize{
##'   \item True Positive (TP)
##'   \item False Positive (FP)
##'   \item True Negative (TN)
##'   \item False Negative (FN)
##' }
##'
##' @inheritParams classification_params
##' @return A named list or a named two dimensions matrix
##' @author An Chu
##' @examples
##'
##' act <- c(1, 0, 0, 1, 1)
##' pred <- c(0.9, 0.3, 0.6, 0.5, 0.2)
##'
##' ## output as a R's list
##' ## metrics:::confusion_list(act, pred) # default value of cutoff = 0.5
##' ## metrics:::confusion_list(act, pred, cutoff = 0.7)
##'
##' ## output as a R's matrix
##' mtr_confusion_matrix(act, pred)
##' mtr_confusion_matrix(act, pred, cutoff = 0.7)
##'
##'
##' @name confusion_matrix
confusion_list <- function(actual, predicted, cutoff = 0.5) {

    check_equal_length(actual, predicted)
    check_binary(actual)
    check_cutoff_range(cutoff)

    TP <- sum((predicted > cutoff) & (actual == 1))
    TN <- sum((predicted <= cutoff) & (actual == 0))
    FN <- sum((predicted <= cutoff) & (actual == 1))
    FP <- sum((predicted > cutoff) & (actual == 0))

    list(TP = TP, TN = TN, FP = FP, FN = FN)
}

##' @rdname confusion_matrix
##' @export
mtr_confusion_matrix <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    conf_mat <- matrix(numeric(4), ncol = 2,
                       dimnames = list(c("Positive", "Negative"),
                                       c("True", "False")))

    conf_mat["Positive", "True"] <- conf_list[["TP"]]
    conf_mat["Positive", "False"] <- conf_list[["FP"]]
    conf_mat["Negative", "True"] <- conf_list[["FN"]]
    conf_mat["Negative", "False"] <- conf_list[["TN"]]

    conf_mat
}

## True Positive Rate ----------------------------------------------------------

##' @title
##' True Positive Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name tpr
##' @export
mtr_tpr <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FN <- conf_list[["FN"]]
    FP <- conf_list[["FP"]]
    denominator <- TP + FN

    if (denominator == 0 && FP != 0) return(0)
    if (denominator == 0 && FP == 0) return(1)

    TPR <- TP / denominator
    TPR
}

##' @rdname tpr
##' @export
mtr_true_positive_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_hit_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_sensitivity <- mtr_tpr

##' @rdname tpr
##' @export
mtr_detection_rate <- mtr_tpr

##' @rdname tpr
##' @export
mtr_recall <- mtr_tpr

## True Negative Rate ----------------------------------------------------------

##' @title
##' True Negative Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name tnr
##' @export
mtr_tnr <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TN <- conf_list[["TN"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]
    denominator <- TN + FP

    if (denominator == 0 && FN == 0) return(1)
    if (denominator == 0 && FN != 0) return(0)

    TNR <- TN / denominator
    TNR
}

##' @rdname tnr
##' @export
mtr_true_negative_rate <- mtr_tnr

##' @rdname tnr
##' @export
mtr_specificity <- mtr_tnr

##' @rdname tnr
##' @export
mtr_selectivity <- mtr_tnr

## False Negative Rate ---------------------------------------------------------

##' @title
##' False Negative Rate
##'
##' @inheritParams classification_params
##' @return A numeric output
##' @author An Chu
##' @name fnr
##' @export
mtr_fnr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_tnr(actual, predicted, cutoff = cutoff)
}

##' @rdname fnr
##' @export
mtr_miss_rate <- mtr_fnr

##' @rdname fnr
##' @export
mtr_false_negative_rate <- mtr_fnr

## False Positive Rate ---------------------------------------------------------

##' @title
##' False Positive Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name fpr
##' @export
mtr_fpr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_tnr(actual, predicted, cutoff = cutoff)
}

##' @rdname fpr
##' @export
mtr_fallout <- mtr_fpr

##' @rdname fpr
##' @export
mtr_false_alarm_rate <- mtr_fpr

##' @rdname fpr
##' @export
mtr_far <- mtr_fpr

##' @rdname fpr
##' @export
mtr_false_positive_rate <- mtr_fpr

## Accuracy --------------------------------------------------------------------

##' @title
##' Accuracy
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_balanced_accuracy}}
##' @author An Chu
##' @name acc
##' @export
mtr_accuracy <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    TN <- conf_list[["TN"]]

    accuracy <- (TP + TN) / Reduce(sum, conf_list)

    accuracy
}

##' @rdname acc
##' @export
mtr_ccr <- mtr_accuracy

## Misclassification Rate ------------------------------------------------------

##' @title
##' Misclassification rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_misclassification_rate <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_accuracy(actual, predicted, cutoff = cutoff)
}

## Balanced Accuracy -----------------------------------------------------------

##' @title
##' Balanced Accuracy
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_accuracy}}
##' @author An Chu
##' @export
mtr_balanced_accuracy <- function(actual, predicted, cutoff = 0.5) {

    sensitivity <- mtr_sensitivity(actual, predicted, cutoff = cutoff)
    specificity <- mtr_specificity(actual, predicted, cutoff = cutoff)

    (sensitivity + specificity) / 2
}

## Positive Predicted Value ----------------------------------------------------

##' @title
##' Positive Predicted Value
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name ppv
##' @author An Chu
##' @export
mtr_ppv <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    denominator <- TP + FP

    if (denominator == 0) return(0)

    PPV <- TP / (TP + FP)
    PPV
}

##' @rdname ppv
##' @export
mtr_positive_predicted_value <- mtr_ppv

##' @rdname ppv
##' @export
mtr_precision <- mtr_ppv

## Average Precision -----------------------------------------------------------

##' @title
##' Average Precision
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_average_precision <- function(actual, predicted) {

    ## keep distinct index of prediction and truth  vector
    ordering <- order(predicted)
    thresholds <- predicted[ordering]
    predicted <- predicted[ordering]
    actual <- actual[ordering]

    precision <- map_dbl(thresholds, function(x) mtr_precision(actual, predicted, x))
    recall <- map_dbl(thresholds, function(x) mtr_recall(actual, predicted, x))

    avg_prec <- sum(diff(recall) * precision[-1], na.rm = TRUE) * (-1)
    avg_prec
}

## False Discovery Rate --------------------------------------------------------

##' @title
##' False Discovery Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name fdr
##' @author An Chu
##' @export
mtr_fdr <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_ppv(actual, predicted, cutoff = cutoff)
}

##' @rdname fdr
##' @export
mtr_false_discovery_rate <- mtr_fdr

## Negative Predicted Value ----------------------------------------------------

##' @title
##' Negative Predicted Value
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name npv
##' @author An Chu
##' @export
mtr_npv <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TN <- conf_list[["TN"]]
    FN <- conf_list[["FN"]]
    denominator <- TN + FN

    if (denominator == 0) return(0)

    NPV <- TN / (TN + FN)
    NPV
}

##' @rdname npv
##' @export
mtr_negative_predicted_value <- mtr_npv

## False Omission Rate ---------------------------------------------------------

##' @title
##' False Omission Rate
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @name for
##' @author An Chu
##' @export
mtr_for <- function(actual, predicted, cutoff = 0.5) {
    1 - mtr_npv(actual, predicted, cutoff = cutoff)
}

##' @rdname for
##' @export
mtr_false_omission_rate <- mtr_for

## F1 Score --------------------------------------------------------------------

##' @title
##' F1 Score
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_fbeta_score}}
##' @author An Chu
##' @export
mtr_f1score <- function(actual, predicted, cutoff = 0.5) {

    precision <- mtr_precision(actual, predicted, cutoff = cutoff)
    recall <- mtr_recall(actual, predicted, cutoff = cutoff)
    f1score <- (2 * precision * recall) / (precision + recall)

    f1score
}

## F-beta Score ----------------------------------------------------------------

##' @title
##' F-beta Score
##'
##'
##' @param beta \code{[numeric]} To be filled
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_f1score}}
##' @author An Chu
##' @export
mtr_fbeta_score <- function(actual, predicted, cutoff = 0.5, beta = 1) {

    precision <- mtr_precision(actual, predicted, cutoff = cutoff)
    recall <- mtr_recall(actual, predicted, cutoff = cutoff)
    fbeta <- (1 + beta^2) * ((precision * recall) / (beta^2 * precision + recall))

    fbeta
}

## Fowlkes-Mallows Index -------------------------------------------------------

##' @title
##' Fowlkes-Mallows Index
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name gscore
##' @export
mtr_gscore <- function(actual, predicted, cutoff = 0.5) {

    conf_list = confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]
    gscore <- sqrt((TP / (TP + FP)) * (TP / (TP + FN)))

    gscore
}

##' @rdname gscore
##' @export
mtr_fowlkes_mallows <- mtr_gscore

## Prevalence ------------------------------------------------------------------

##' @title
##' Prevalence
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_prevalence <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)

    TP <- conf_list[["TP"]]
    FN <- conf_list[["FN"]]
    prevalence <- (TP + FN) / Reduce(sum, conf_list)

    prevalence
}

##' @title
##' Detection Prevalence
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_detection_prevalence <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)
    TP <- conf_list[["TP"]]
    FP <- conf_list[["FP"]]
    dec_pre <- (TP + FP) / Reduce(sum, conf_list)

    dec_pre
}

## KS statistic ----------------------------------------------------------------

##' @title
##' KS Statistic
##'
##' @description
##'
##' Kolmogorov–Smirnov statistic quantifies a distance between the empirical
##' distribution function of the sample and the cumulative distribution function
##' of the reference distribution.
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_ks_statistic <- function(actual, predicted) {

    descending <- order(predicted, decreasing = TRUE)
    actual <- actual[descending]
    predicted <- predicted[descending]

    bins <- 10                          # this is arbitrary
    len <- length(actual)
    n <- len %/% bins        # number of obs per bin

    group_index <- rep(1:(bins - 1), each = n)
    group_index <- append(group_index, rep(bins, len - length(group_index)))

    perct_pos <- tapply(actual, group_index, function(x) sum(x == 1)) / sum(actual == 1)
    perct_neg <- tapply(actual, group_index, function(x) sum(x == 0)) / sum(actual == 0)

    max(cumsum(perct_pos) - cumsum(perct_neg))
}

## Informedness ----------------------------------------------------------------

##' @title
##' Informedness
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name yindex
##' @export
mtr_informedness <- function(actual, predicted, cutoff = 0.5) {

    sensitivity <- mtr_sensitivity(actual, predicted, cutoff = cutoff)
    specificity <- mtr_specificity(actual, predicted, cutoff = cutoff)

    sensitivity + specificity - 1
}

##' @rdname yindex
##' @export
mtr_youden_index <- mtr_informedness

## Markedness ------------------------------------------------------------------

##' @title
##' Markedness
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_markedness <- function(actual, predicted, cutoff = 0.5) {

    ppv <- mtr_positive_predicted_value(actual, predicted, cutoff = cutoff)
    npv <- mtr_negative_predicted_value(actual, predicted, cutoff = cutoff)

    ppv + npv - 1
}

## Matthews Correlation Coefficient --------------------------------------------

##' @title
##' Matthews Correlation Coefficient
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @export
mtr_matthews_corr_coef <- function(actual, predicted, cutoff = 0.5) {

    conf_list <- confusion_list(actual, predicted, cutoff = cutoff)
    TP <- conf_list[["TP"]]
    TN <- conf_list[["TN"]]
    FP <- conf_list[["FP"]]
    FN <- conf_list[["FN"]]

    denom1 <- TP + FP
    denom2 <- TP + FN
    denom3 <- TN + FP
    denom4 <- TN + FN

    if (denom1 == 0 || denom2 == 0 || denom3 == 0 || denom4 == 0) return(NA_real_)

    mcc <- ((TP * TN) - (FP * FN)) / sqrt(prod(denom1, denom2, denom3, denom4))
    mcc
}

## Hamming Loss ----------------------------------------------------------------

mtr_hamming_loss <- function(actual, predicted, cutoff = 0.5) {

}

## Hinge Loss ------------------------------------------------------------------

mtr_hinge_loss <- function(actual, predicted, cutoff = 0.5) {

}

## Jaccard Score ---------------------------------------------------------------

mtr_jaccard_score <- function(actual, predicted, cutoff = 0.5) {

}


setabc <- function(f, fb, sr) {
  pit = pi/sr
  r = exp(-pit*fb)
  coefs = c(0,0,0)
  coefs[3] = -r * r
  coefs[2] = 2*r*cos(2*pit*f)
  coefs[1] = 1 - coefs[2] - coefs[3]
  if (f < 0.0) {
    coefs[1] = 1 / coefs[1]
    coefs[2] = -coefs[1] * coefs[2]
    coefs[3] = -coefs[1] * coefs[3]
  }
  return(coefs)
}

res <- function(x,f,fb,sr) {
  cf = setabc(f,fb,sr)
  m1 = 0
  m2 = 0
  y = x
  if (f >= 0) {
    for (j in 1:length(x)) {
      y[j] = x[j]*cf[1] + m1*cf[2] + m2*cf[3]
      m2 = m1
      m1 = y[j]
    }
  } else {
    for ( j in 1:length(x)) {
      y[j] = x[j]*cf[1] + m1*cf[2] + m2*cf[3]
      m2 = m1
      m1 = x[j]
    }
  }
  return(y)
}


sim_function <- function(L_mat,tw_st_full,index_order,sigma_mat,n_0,T_0,B,scale_1,scale_2){

	n <- nrow(L_mat)
	T <- ncol(L_mat)
	n_1 <- n - n_0
	T_1 <- T - T_0

	L_mat_or_sc <- scale_1*L_mat[index_order,]
	tw_st_or <- tw_st_full[index_order,]

	results <- matrix(0, ncol = 3, nrow = B)

    estimates = lapply(1:B, function(b) {
		Y_b <- L_mat_or_sc + tw_st_or + scale_2*rmvnorm(n,sigma = sigma_mat)
		estimates = list(synthdid_estimate(Y_b,n_0,T_0), sc_estimate(Y_b,n_0,T_0), did_estimate(Y_b,n_0,T_0))
        names(estimates) = c('synth-did', 'sc', 'did')
        estimates
	})
	for(b in 1:B) {
        results[b,] = sapply(estimates[[b]], c)
    }
	bias_methods <- colMeans(results)
	sd_methods <- sqrt(diag(var(results)))

	agg_results <- rbind(sqrt(colMeans(results^2)),bias_methods,sd_methods)
	agg_results_round <- round(agg_results,3)
	colnames(agg_results_round) <- c('sdid','did','sc')
	rownames(agg_results_round) <- c('RMSE','bias','sd')

	list(aggregates = agg_results_round, estimates=estimates)

}


#' Generate t-statistics
#'
#' Generate t-statistics from estimates generated from the fractional airline model
#'
#' @param this_beta Numeric vector; estimated model parameters from the fractional airline model.
#' @param this_cov Numeric matrix; estimated covariance matrx from the fractional airline model.
#' @return Numeric vector of t-values
#' @examples
#' ic_air_est <-
#'   rjd3highfreq::fractionalAirlineEstimation(ic_obs, periods=c(365.25/7),
#'                                      x=ic_holiday_matrix,
#'                                      outliers=c('ao', 'ls'),
#'                                      criticalValue = 6)
#' ic_air_t_reg   <- t_values_air(ic_air_est$model$b, ic_air_est$model$bcov)
#' ic_air_t_arima <- t_values_air(ic_air_est$estimation$parameters,
#'                                ic_air_est$estimation$covariance)
#' @import stats
#' @export
t_values_air <- function(this_beta, this_cov) {
    # Author: Brian C. Monsell (OEUS), Version 2.0, 2/2/2022

    # generate length of the beta vector, initialize t-statistics vector to zero
    this_n <- length(this_beta)
    this_tvalue <- array(0, dim = 0)

    # generate t-statistics
    for (i in 1:this_n) {
        this_tvalue[i] <- this_beta[i]/sqrt(this_cov[i, i])
    }

    # return t-statistics
    return(this_tvalue)
}


# Get the data in place --
load(file="demo.rda")
summary(firms)

# Look at it --
plot(density(log(firms$mktcap)))
plot(firms$mktcap, firms$spread, type="p", cex=.2, col="blue", log="xy",
     xlab="Market cap (Mln USD)", ylab="Bid/offer spread (bps)")
m=lm(log(spread) ~ log(mktcap), firms)
summary(m)

# Making deciles --
library(gtools)
library(gdata)
                                      # for deciles (default=quartiles)
size.category = quantcut(firms$mktcap, q=seq(0, 1, 0.1), labels=F)
table(size.category)
means = aggregate(firms, list(size.category), mean)
print(data.frame(means$mktcap,means$spread))

# Make a picture combining the sample mean of spread (in each decile)
# with the weighted average sample mean of the spread (in each decile),
# where weights are proportional to size.
wtd.means = by(firms, size.category,
  function(piece) (sum(piece$mktcap*piece$spread)/sum(piece$mktcap)))
lines(means$mktcap, means$spread, type="b", lwd=2, col="green", pch=19)
lines(means$mktcap, wtd.means, type="b", lwd=2, col="red", pch=19)
legend(x=0.25, y=0.5, bty="n",
       col=c("blue", "green", "red"),
       lty=c(0, 1, 1), lwd=c(0,2,2),
       pch=c(0,19,19),
       legend=c("firm", "Mean spread in size deciles",
         "Size weighted mean spread in size deciles"))

# Within group standard deviations --
aggregate(firms, list(size.category), sd)

# Now I do quartiles by BOTH mktcap and spread.
size.quartiles = quantcut(firms$mktcap, labels=F)
spread.quartiles = quantcut(firms$spread, labels=F)
table(size.quartiles, spread.quartiles)
# Re-express everything as joint probabilities
table(size.quartiles, spread.quartiles)/nrow(firms)
# Compute cell means at every point in the joint table:
aggregate(firms, list(size.quartiles, spread.quartiles), mean)

# Make pretty two-way tables
aggregate.table(firms$mktcap, size.quartiles, spread.quartiles, nobs)
aggregate.table(firms$mktcap, size.quartiles, spread.quartiles, mean)
aggregate.table(firms$mktcap, size.quartiles, spread.quartiles, sd)
aggregate.table(firms$spread, size.quartiles, spread.quartiles, mean)
aggregate.table(firms$spread, size.quartiles, spread.quartiles, sd)

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


# Performing data visualization
# ggplot2: library that is used for data visualization's

# Load the ggplot2 package as well
library(gapminder)
library(dplyr)
library(ggplot2)

# Create gapminder_1952
gapminder_1952 <- gapminder %>% filter(year == 1952)

# 1. Produce scattergraph
# aes: relates to the axis
# geom_point(): added to signify that a geometric point layer is requested for the plot
# Change to put pop on the x-axis and gdpPercap on the y-axis
ggplot(gapminder_1952, aes(x = pop, y = gdpPercap)) +
  geom_point()

# 2. Add log scale to the axis
# scale_x_log10(): method converts the x axis variable to log base 10 scale. For y axis conversion just switch x with y
# Change this plot to put the x-axis on a log scale
ggplot(gapminder_1952, aes(x = pop, y = lifeExp)) +
  geom_point() +
  scale_x_log10()

# Scatter plot comparing pop and gdpPercap, with both axes on a log scale
ggplot(gapminder_1952, aes(x = pop, y = gdpPercap)) +
  geom_point() +
  scale_x_log10() +
  scale_y_log10()

# 3. Additional aesthetics. color and size
# Scatter plot comparing pop and lifeExp, with color representing continent
ggplot(gapminder_1952, aes(x = pop, y = lifeExp, color = continent)) +
  geom_point() +
  scale_x_log10()

# Add the size aesthetic to represent a country's gdpPercap
ggplot(gapminder_1952, aes(x = pop, y = lifeExp, color = continent, size = gdpPercap)) +
  geom_point() +
  scale_x_log10()

# 4. Faceting, provides subgraph
# Scatter plot comparing pop and lifeExp, faceted by continent
ggplot(gapminder_1952, aes(x = pop, y = lifeExp)) +
  geom_point() +
  scale_x_log10() +
  facet_wrap(~ continent)

# Scatter plot comparing gdpPercap and lifeExp, with color representing continent
# and size representing population, faceted by year
ggplot(gapminder, aes(x = gdpPercap, y = lifeExp, color = continent, size = pop)) +
    geom_point() +
    scale_x_log10() +
    facet_wrap(~ year)


#Red neurona sin PCA con variables categoricas

indice<-sample(1:nrow(y),87)

######################################
# Creamos el objeto red neuronal feedforward
#############################
# PRUEBA CON variables cuantitativas y cualitativas
##############################
## Creamos dos conjuntos de datos artificiales: ''P'' es el conjunto
#de datos de entrada y ''target'' el de salida. con el 80% de los datos
######################
target<-clase
target
##
## inicialmente con Comp1 Comp2 con el 88% de la infomarcion de los datos
########################
P3<-data[indice,!(names(data) %in% c("cant_mat","cal_1"))]
P3

## Creamos el objeto red neuronal feedforward
############################################
net3 <- newff(n.neurons=c(ncol(P3),5,4,2), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
#############################
##Se entrena la red
#######################
result3 <- train(net3,P3 , target, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=39 )
######################
# se grafica la red entrenada con los datos de entrenamiento
####
s <- sim(result3$net, P3)
cbind(round(s),(apply(clase,1,sum)+1))
round(s)
###################
# Validacion con el 20% restante
##############
P_v <-data[-indice,1:5]
s <- sim(result2$net, P_v)
round(s)
dist_uno_uno <- dist(rbind(c(1,1),s))[1:39]
dist_cero_uno <- dist(rbind(c(0,1),s))[1:39]
dist_cero_cero <- dist(rbind(c(0,0),s))[1:39]

salT<-cbind(ytest,
round(s), #Se une el vector de salida redondeado
	dist_uno_uno,
	dist_cero_uno,
	dist_cero_cero,
	cbind(((dist_uno_uno)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero))),
		((dist_cero_uno)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero))),
		((dist_cero_cero)/rowSums(cbind(dist_uno_uno,dist_cero_uno,dist_cero_cero)))
	)
)
salT<-data.frame(salT)
colnames(salT)<-c("M_1","M_2","M_3","_M_4","P","X1","X2","D1_1_1","D2_0_1","D3_0_0","P_1_1","P_0_1","P_0_0")
print(salT,digits=5)

s
cbind(round(s), claseT)
tasa<-rep(FALSE,nrow(s))
tasa[round(s)[,1]== claseT[,1] & round(s)[,2]== claseT[,2]]<-TRUE
tasa <- sum(tasa==TRUE)*100/length(tasa)

tasa

ECM_2 <- error.LMS(c(s,claseT,net1))
ECM_2


#hierarchical clustering
?hclust

View(iris)

id1 <- sample(1:dim(iris)[1], 30) #taking 30 observations
View(id1)

irisSample <- iris[id1,]  #extracting those 30 points
View(irisSample)

irisSample$Species <- NULL
View(irisSample)

hc <- hclust(dist(irisSample), method="ave") #ave,single
#hc <- hclust(dist(irisSample), method="single") #ave,single
plot(hc, hang = -1, labels=iris$Species[id1])

# cut tree into 4 clusters
rect.hclust(hc, k=4)

groups <- cutree(hc, k=4) #store observation placement in cluster
groups
View(groups)


library("ggplot2")
library("discSurv")
library("pec")

t0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2010/master/csv/ti_1500_2xxx_monthly.csv", sep=",", na = "NA")
t1 <- t0[,c("year","month","ti")]
p0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/pi_1500_2xxx_monthly.csv", sep=",", na = "NA")
prec0 <- read.csv("https://raw.githubusercontent.com/climdata/dwdPrecipitation/master/csv/monthly_precipitation_de.csv", sep=",", na = "NA")
prec1 <- prec0[, c("year","month","Deutschland")]

tps <- merge(t1,p0, by=c("year","month"))
tps <- merge(tps,prec1, by=c("year","month"))
tps$t1 <- sin((tps$month-1)*pi/6)
tps$t2 <- cos((tps$month-1)*pi/6)
tps <- tps[order(tps$ts),]

mx5 <- lm(Deutschland ~ (pi+ti)*(t1+t2), tps)
summary(mx5)
pr5 <- predict(mx5, newdata=tps, se.fit=TRUE)
tps$spi5 <- pr5$fit
tps$se5 <- pr5$se

mx2 <- lm(Deutschland ~ pi+ti+t1+t2, tps)
summary(mx2)
pr2 <- predict(mx2, newdata=tps, se.fit=TRUE)
tps$spi2 <- pr2$fit
tps$se2 <- pr2$se

tps$pi3 <- (tps$pi+3)/60
tps$ti3 <- (tps$ti+3)/60
tps$t13 <- (tps$t1+1)/20
tps$t23 <- (tps$t2+1)/20
tps$Deutschland3 <- (tps$Deutschland)/200

mx3 <- lm(Deutschland ~ (pi+ti+t1+t2)^2, tps)
#mx3 <- glm(formula=Deutschland3 ~ (pi+ti+t1+t2)^2, data=tps, family=binomial(link=gumbel()))

summary(mx3)
pr3 <- predict(mx3, newdata=tps, se.fit=TRUE)
tps$spi3 <- pr3$fit
tps$se3 <- pr3$se

mx4 <- lm(Deutschland ~ t1+t2, tps)
summary(mx4)
pr4 <- predict(mx4, newdata=tps, se.fit=TRUE)
tps$spi4 <- pr4$fit
tps$se4 <- pr4$se

p <- ggplot(data = tps, aes(x = Deutschland, y = spi3)) +
  #geom_point(aes(y = spi4), color="#00AA00", alpha=0.2, size=2) +
  geom_point(aes(y = spi3), color="#0000BB", alpha=0.3, size=2) +
  geom_point(aes(y = spi2), color="#FF0000", alpha=0.4, size=2) +
  geom_point(aes(y = spi5), color="#00FF00", alpha=0.5, size=2) +
  geom_smooth(method = "lm", se=TRUE, color="cyan", formula = y ~ x)
p


> strings <- c("152", "-3.1415926", "Foo123")
> suppressWarnings(!is.na(as.numeric(strings)))
[1]  TRUE  TRUE FALSE


                      #### Clark and West test 2007 ####

#Before simulating MC I have to set the coefficients of the simulated regressions to predefined values.
#All this values are given/calculated by given numbers in paper by Paye.

#Set the coefficients to prespecified values..
const2=0.27
coef_ar1_x=0.60
unconexp_x=const2/(1-coef_ar1_x)

#Set the autoregresseive coefficients to predetermined values.
const1=-0.61
coef_ar1_y=0.52
coef_ar2_y=0.22
unconexp_y=(const1+unconexp_x)/(1-coef_ar1_y-coef_ar2_y)

# To generate the error terms one need to specify the variances/std.dev of error terms.
var_et=0.092
var_vt=0.160
cov_et_vt=0.026
corr_et_vt=cov_et_vt/sqrt(var_et*var_vt)

# Generate the distribution according to standard normal distribution. I set n=2000
set.seed(123456)
zt1<-rnorm(2000,0,1)
zt2<-rnorm(2000,0,1)

et<-zt1*sqrt(var_et)
vt<-(zt1*corr_et_vt+zt2*sqrt(1-corr_et_vt))*sqrt(var_vt)

#For loop inside the prediction/estimation
set.seed(123456)
wndw = 20 #number of observations for the in-sample (estimation) analysis.
T = 120  #number of observations for the out-of-sample (forecast) analysis.
y <- matrix(NA, 2000,10000)  #Randomly generated dependent variable matrix.
y_sample <- matrix(NA,T+wndw,10000) #creating a matrix which incorporates both in-sample and out-of-sample analysis osbervations: T+wndw=150 observations.
x <-matrix(NA,2000,10000)
x_sample <-matrix(NA,T+wndw,10000)

for (ii in 1:10000) {
  # Generate first two datapoints
  y[1,ii] <- unconexp_y
  y[2,ii] <- 1
  x[1,ii] <-unconexp_x
  x[2,ii] <-1
  #randomly generate the rest of the data for indep.var. starting from the third obs.
  for (tt in 3:2000) {
    x[tt,ii] = const2+coef_ar1_x*x[tt-1,ii]+rnorm(1)*sqrt(var_vt)
    y[tt,ii] = const1 + coef_ar1_y*y[tt-1,ii] + coef_ar2_y*y[tt-2,ii] + rnorm(1)*sqrt(var_et)
  }
  #Select last 150 observations for later in- and out-of-sample analysis and assign them to predefined y_sample matrix.
  y_sample[,ii] <- y[(2000 - wndw - T + 1) : 2000, ii]
  x_sample[,ii] <- x[(2000 - wndw - T + 1) : 2000, ii]
}

# Estimate model on rolling window
prediction <- matrix(NA,T+wndw,10000) #create an empty matrix later to be filled by forecasting values. First 20 observations are not gonna be used, only T=120 observations are used.
losses<-matrix(NA,T+wndw,10000) #This command generates a matrix for the forecast errors where it is calculated by subtracting actual generated data from the forecasted values.
losses_sqr<-matrix(NA,T+wndw,10000) #This command generates a matrix for the forecast error squares where it is calculated by taking the square of 'losses' series.
prediction4 <- matrix(NA,T+wndw,10000)
losses4<-matrix(NA,T+wndw,10000)
losses4_sqr<-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  for (kk in wndw:(T+wndw-1)) {
    # estimate with data from (kk-wndw+1) : kk.Model is defined as AR(2) model and estimated with linear regression.
    fit2<-lm(y_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y_sample[(kk-wndw+1): kk,ii],2))
    #Forecasts are obtained by extracting the coefficients from the regression model of AR(2).
    prediction[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y_sample[kk,ii]+fit2$coefficients[3]*y_sample[kk-1,ii]
    #Forecast errors are the difference between the actual and predicted(forecast) values.
    losses[kk+1,ii] <- y_sample[kk+1,ii] - prediction[kk+1,ii]
    losses_sqr[kk+1,ii] <- (y_sample[kk+1,ii] - prediction[kk+1,ii])^2

    fit<-lm(y_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y_sample[(kk-wndw+1): kk,ii],2)+dplyr::lead(x_sample[(kk-wndw+1): kk,ii]))
    prediction4[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y_sample[kk,ii]+fit$coefficients[3]*y_sample[kk-1,ii]+fit$coefficients[4]*x_sample[kk,ii]
    losses4[kk+1,ii] <- y_sample[kk+1,ii] - prediction4[kk+1,ii]
    losses4_sqr[kk+1,ii] <- (y_sample[kk+1,ii] - prediction4[kk+1,ii])^2

  }
}

adj_term1<-matrix(NA,T+wndw,10000)
adj_term1<-(prediction-prediction4)^2

cw_stats1<-matrix(NA,T+wndw,10000)
cw_stats1<-(losses_sqr-losses4_sqr+adj_term1)*100

count<-matrix(NA,1,10000)

for (ii in 1:10000) {
  cw_stats1_eq<-lm(cw_stats1[21:140,ii]~1)
  if (summary(cw_stats1_eq)$coefficients[1, 4]<0.10){
    count[,ii]=1
  }else{
    count[,ii]=0
  }
}

#This code calculates the analysis percentage of rejection rates (at 10% sign. level)
#over 10000 simulated samples. The test is based on Clark and West (2007) test.

CW_test_stats1<-100*(rowSums(count)/10000)

#Here I am simulating from the model that sets the coefficient for the xt-1 variable (new variable) to zero.
#Therefore, I create a new variable called x.
wndw = 20
T = 120
set.seed(123456)

#Set the coefficients to prespecified values
const2=0.27
coef_ar1_x=0.60
unconexp_x=const2/(1-coef_ar1_x)

#Set the autoregresseive coefficients to predetermined values.
const1=-0.61
coef_ar1_y=0.52
coef_ar2_y=0.22
unconexp_y=(const1+unconexp_x)/(1-coef_ar1_y-coef_ar2_y)

# To generate the error terms one need to specify the variances/std.dev of error terms.
var_et=0.092
var_vt=0.160
cov_et_vt=0.026
corr_et_vt=cov_et_vt/sqrt(var_et*var_vt)

# Generate the distribution according to standard normal distribution. I set n=2000
set.seed(123456)
zt1<-rnorm(2000,0,1)
zt2<-rnorm(2000,0,1)

et<-zt1*sqrt(var_et)
vt<-(zt1*corr_et_vt+zt2*sqrt(1-corr_et_vt))*sqrt(var_vt)

#For loop inside the prediction/estimation
set.seed(123456)
wndw = 20
T = 120
y2 <- matrix(NA, 2000,10000)
y2_sample <- matrix(NA,T+wndw,10000)
x <-matrix(NA,2000,10000)
x_sample <-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  # Generate datapoints
  y2[1,ii] <- unconexp_y
  y2[2,ii] <- 1
  x[1,ii] <-unconexp_x
  x[2,ii] <-1
  for (tt in 3:2000) {
    x[tt,ii] = const2+coef_ar1_x*x[tt-1,ii]+rnorm(1)*sqrt(var_vt)
    y2[tt,ii] = const1 + coef_ar1_y*y2[tt-1,ii] + coef_ar2_y*y2[tt-2,ii] +0.09*x[tt-1,ii]+ rnorm(1)*sqrt(var_et)
  }
  y2_sample[,ii] <- y2[(2000 - wndw - T + 1) : 2000, ii]
  x_sample[,ii] <- x[(2000 - wndw - T + 1) : 2000, ii]
}

# Estimate model on rolling window
prediction2 <- matrix(NA,T+wndw,10000)
losses2<-matrix(NA,T+wndw,10000)
losses2_sqr<-matrix(NA,T+wndw,10000)
prediction4 <- matrix(NA,T+wndw,10000)
losses4<-matrix(NA,T+wndw,10000)
losses4_sqr<-matrix(NA,T+wndw,10000)
for (ii in 1:10000) {
  for (kk in wndw:(T+wndw-1)) {
    # estimate with data from (kk-wndw+1) : kk
    fit<-lm(y2_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y2_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y2_sample[(kk-wndw+1): kk,ii],2)+dplyr::lead(x_sample[(kk-wndw+1): kk,ii]))
    prediction2[kk+1,ii]<-fit$coefficients[1]+fit$coefficients[2]*y2_sample[kk,ii]+fit$coefficients[3]*y2_sample[kk-1,ii]+fit$coefficients[4]*x_sample[kk,ii]
    losses2[kk+1,ii] <- y2_sample[kk+1,ii] - prediction2[kk+1,ii]
    losses2_sqr[kk+1,ii] <- (y2_sample[kk+1,ii] - prediction2[kk+1,ii])^2
    fit2<-lm(y2_sample[(kk-wndw+1): kk,ii]~dplyr::lead(y2_sample[(kk-wndw+1): kk,ii])+dplyr::lead(y2_sample[(kk-wndw+1): kk,ii],2))
    prediction4[kk+1,ii]<-fit2$coefficients[1]+fit2$coefficients[2]*y2_sample[kk,ii]+fit$coefficients[3]*y2_sample[kk-1,ii]
    losses4[kk+1,ii] <- y2_sample[kk+1,ii] - prediction4[kk+1,ii]
    losses4_sqr[kk+1,ii] <- (y2_sample[kk+1,ii] - prediction4[kk+1,ii])^2
  }
}

#...

adj_term1<-matrix(NA,T+wndw,10000)
adj_term1<-(prediction2-prediction4)^2

cw_stats1<-matrix(NA,T+wndw,10000)
cw_stats1<-(losses2_sqr-losses4_sqr+adj_term1)*100

count<-matrix(NA,1,10000)

for (ii in 1:10000) {
  cw_stats1_eq<-lm(cw_stats1[21:140,ii]~1)
  if (summary(cw_stats1_eq)$coefficients[1, 4]<0.10){
    count[,ii]=1
  }else{
    count[,ii]=0
  }
}

#This code calculates the analysis percentage of rejection rates (at 10% sign. level)
#over 10000 simulated samples. The test is based on Clark and West (2007) test.
CW_test_stats2<-100*(rowSums(count)/10000)


#==============================================================================
#	Test for lmer
#==============================================================================

#------------------------------------------------------------------------------
#	Because current version of predict.merMod oes not support predicting
#	with newdata when formula has ".", following test does not use "."
#	in the formula.
#
#	object <- lmer(Sepal.Length ~ . + (1 | Species), data = iris)
#	predict(object, newdata=iris)
#------------------------------------------------------------------------------

source("tests.r")

test <- ma.test$new(
	call = substitute(
		lmer(
			Sepal.Length ~ Petal.Length + Petal.Width + (1 | Species),
			data = iris
		)
	),
	"lmer",
	expected.for.call = expected(
		call = substitute(
			lmer(
				Sepal.Length ~ Petal.Length + Petal.Width + (1 | Species),
				data = iris
			)
		),
		formula = Sepal.Length ~ Petal.Length + Petal.Width + (1|Species),
		data = iris, model.type = "regression", family = "gaussian",
		link = gaussian()$linkfun, linkinv = gaussian()$linkinv
	)
)
test$run.all()
rm(test)


 ZGEEVX Example Program Results

 Eigenvalues

          Eigenvalue           rcond    error
  1 (-6.0004E+00,-6.9998E+00)  0.9932  3.2E-15
  2 (-5.0000E+00, 2.0060E+00)  0.9964  3.2E-15
  3 ( 7.9982E+00,-9.9637E-01)  0.9814  3.3E-15
  4 ( 3.0023E+00,-3.9998E+00)  0.9779  3.3E-15

 Eigenvectors

          Eigenvector          rcond    error

  1 ( 8.4572E-01, 0.0000E+00)  8.4011    -
    (-1.7723E-02, 3.0361E-01)
    ( 8.7521E-02, 3.1145E-01)
    (-5.6147E-02,-2.9060E-01)

  2 ( 3.8655E-01,-1.7323E-01)  8.0214    -
    ( 3.5393E-01,-4.5288E-01)
    (-6.1237E-01,-0.0000E+00)
    ( 8.5928E-02, 3.2836E-01)

  3 ( 1.7297E-01,-2.6690E-01)  5.8292    -
    (-6.9242E-01,-0.0000E+00)
    (-3.3240E-01,-4.9598E-01)
    (-2.5039E-01, 1.4655E-02)

  4 ( 3.5614E-02, 1.7822E-01)  5.8292    -
    (-1.2637E-01,-2.6663E-01)
    (-1.2933E-02, 2.9657E-01)
    (-8.8982E-01,-0.0000E+00)

 Errors below 10*machine precision are not displayed


# treeEnsembles.r
# MWL, Lecture 2
# Author(s): [Phil Snyder]

"
An ensemble is a predictor that obtains its predictions by taking a weighted average of multiple
single predictors. We will look at three different types of tree-based ensembles: bagging,
random forests, and boosting with trees. Both random forests and boosting are methods
used in industry every day - and can be very powerful predictors.
"

library("ElemStatLearn")
data("spam")

partition <- sample(nrow(spam), floor(0.7 * nrow(spam)))
trainData <- spam[partition,]
testData <- spam[-partition,]

# Bagging

"
Bagging is a portmanteau of 'bootstrap aggregation'. 'Bootstrap' is a sampling method where you
sample from a data set *with replacement*. Usually your sample size is equivalent to the size of
the original data set. 'Aggregation' refers to the fact that we are aggregating or averaging the
predictors (in the case of classification, by having them take a vote on the class) trained on
our bootstrap samples. Typically bagging only helps in the case of high variance predictors (such
as decision trees) because it reduces variance while maintaining bias (again, see bias-variance
trade-off). More info available in [ESL 8.7].
"

#install.packages("ipred")
library("ipred")
bagg <- bagging(spam ~ ., trainData, nbagg=50) # 50 trees
# Of course, normally we would do CV to find the optimal parameters
# (implicit here are the rpart parameters)
baggPredictions <- predict(bagg, testData)
baggResults <- table(baggPredictions == testData$spam) / length(baggPredictions)
baggResults # (approx.) TRUE: 0.924, FALSE: 0.0760

# Random Forests

"
Random Forests are similar to bagging, except each tree is only trained on a random subset of the
dimensions of the original dataset. For example, if our data had dimensions V1, ..., V10
we might train the first tree on dimensions V1, V4, V8 and our second tree on V2, V4, V5, etc.
We do this so that our individual trees become less *correlated*. The correlation between trees
limits how good of a predictor we may obtain by averaging their individual predictions. You
may also think of the individual trees in a random forest as being 'experts' in a specific domain.
The more limited the domain of the expert, the deeper and more refined the experts knowledge becomes
in that domain. For more info see [ESL 15].
"

#install.packages("randomForest")
library("randomForest")
rf <- randomForest(spam ~ ., trainData, ntree=80) # 80 trees trained on random dimensions
# in classification, by default we randomly select m = floor(sqrt(p)) dimensions to train on
# where p is the # of dimensions in our original dataset.
rfPredictions <- predict(rf, testData)
rfResults <- table(rfPredictions == testData$spam) / length(rfPredictions)
rfResults # (approx.) TRUE: 0.945, FALSE: 0.055

"
This is our best predictor yet, though random forests have their limits. If the dimensions
of our data have very little to do with how the class is determined, then it's likely many of
the trees will make decisions based on useless information, adding noise to our predictions.
"

# Boosting

"
Here we will do boosting with decision trees, though it is possible to do boosting with different
predictors. The general idea behind boosting is that each data point in the training set is given
a weight. At first these weights are all equal. We then fit a tree to the train data. For every data
point that the tree classifies incorrectly, we increase its weight. We then fit a second tree
to the data. The second tree gives the data points with greater weight greater importance, and is
less likely to classify them incorrectly. The process then repeats, iterating sequentially through
each dimension. This will perhaps become more clear when we talk about loss/objective
functions. For more info see [ESL 10].
"

#install.packages("adabag")
library("adabag")
boost <- boosting(spam ~ ., trainData, mfinal=100) # 100 boosted trees
boostPredictions <- predict(boost, testData)
boostPredictions$error # proportion incorrect

"
Boosting is a powerful idea, and we will generalize it to other predictors later.

You may have noticed that it took a fair amount of time to fit our models to the data. This is
where the 'computer science' portion of machine learning comes into play. The most powerful
predictors (usually ensembles, or various forms of neural nets, or both) can take days to train,
even with extreme computational optimization. Next lecture we will take a closer look at the
optimization of our model parameters as well as some more archetypical concepts in machine learning.
"


#DOT PLOTS | method of plotting lg # of labeled values
dotchart(mtcars$mpg, labels=row.names(mtcars),cex=.7, main='Gas Mileage for Car Models', xlab='Miles Per Gallon')

#DOT PLOT GROUPED, SORTED AND COLORED
x<-mtcars[order(mtcars$mpg),]#sort via mpg high to low
x$cyl<-factor(x$cyl) #tranform into a factor
x$color[x$cyl==4]<-"red" #add to dataframe
x$color[x$cyl==6]<-"blue"
x$color[x$cyl==8]<-"darkgreen"
dotchart(x$mpg, labels=row.names(x), cex=.7, groups=x$cyl, gcolor="black", color=x$color, pch=19, main="Gas Mileage for Car Models\ngrouped by cylinder", xlab="Miles Per Gallon")