#' Compute Efficient Frontier of Mean Variance Optimization
#' @param returns
#' @param cset
#' @param list.arg
#' @param npoints
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{efrontPlot}}
#' @keywords efficient frontier
#' @examples
#' @export

efrontMV = function(returns,cset = NULL, list.arg= NULL, npoints = 10)
{

	require(quadprog)
	require(Rglpk)
	require(xts)

    if(is.null(cset))
    {
    mu = apply(returns,2,mean)
    mu.min = minmu(returns)
    mu.max = 1.2*max(mu)}     else
    {
      if (any(c("turnover.hobbs","turnover","propcost") %in% cset$clist.names)){ # find max mu without turnover/propcost constraint, since Rglpk doesn't work with turnover/propcost
        if(length(cset$clist.names)>1){

      index.mu <- which (cset$clist.names %in% c("turnover.hobbs","turnover","propcost"))
      clist.mu <- c(cset$clist.names[-index.mu],"sum")
      cset.mu <- combine.cset(clist=clist.mu,returns=returns,list.arg,verbose=F)
      mu.min = minmu(returns,cset.mu)

mu.max = .999*maxmu(returns,cset.mu)
      } else{mu = apply(returns,2,mean)
             mu.min = minmu(returns)
             mu.max = 1.2*max(mu)}
        }
      else {
      mu.min = minmu(returns)
      mu.max = .999*maxmu(returns,cset)
      }
    }
    p = ncol(returns)
    efront = matrix(rep(0,npoints*(p+2)),ncol = p+2)
    muvals = seq(mu.min,mu.max,length.out = npoints)
    for(i in 1:npoints){
    if(is.null(cset))
    {efront[i,] = mvo(returns,muvals[i],wts.only = F)}     else
    {
      efront[i,] = tryCatch(mvo(returns,muvals[i],cset,wts.only = F),error=function(e)return(NA))
      efront[i,] = as.numeric( efront[i,] )
    }}
    dimnames(efront)[[2]] = c("MU","VOL",dimnames(returns)[[2]])
    if(any(is.na(efront))){
    print("turnover/propcost constraints reduced the max mean return in efficient frontier plot")
    # violate
    efront<-efront[-which(apply(efront,1,function(x)any(is.na(x)))),]}
    efront
}

#' Plot Efficient Frontier of Mean Variance Optimization
#' @param returns
#' @param cset
#' @param mu.min
#' @param mu.max
#' @param rf
#' @param npoints
#' @param wts.xlab
#' @param printout
#' @param bar.ylim
#' @param list.arg
#' @param is.fancy
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{efrontPlot}}
#' @keywords efficient frontier
#' @examples
#' @export
efrontPlot = function(returns,cset = NULL,mu.min = NULL, mu.max = NULL, rf = NULL,
                         npoints = 10,wts.plot = T, wts.xlab="VOL",printout = F,bar.ylim = c(0,2),
                      list.arg=NULL, is.fancy=TRUE)
{
    if(is.null(cset))
    {efront = efrontMV(returns,cset = NULL, list.arg=list.arg, npoints)}     else
    {efront = efrontMV(returns,cset,list.arg=list.arg, npoints)}
	if(nrow(efront)<=1) stop("no solution, consider relaxing constraints")
    if(printout) print(efront)
    # Set smart x and y plotting region limits
    sigma = apply(returns,2,sd);mu = apply(returns,2,mean)
    xlim = c(0,max(sigma));ylim = range(mu);ylim[1] = ylim[1]-.05*diff(ylim)
    ylim[1] = min(min(efront[,1]),ylim[1])
    ylim[2] = max(max(efront[,1]),ylim[2])
    if(wts.plot) {par(mfrow = c(1,2), mgp= c(4, 2, 0), mar=c(8,6,4,2)+0.1)}
    plot(efront[,2],efront[,1],type = "l",col = 4,lwd = 2, xlab = "VOL",ylab = "MU", xlim = xlim,
            ylim = ylim, main = "MV Efficient Frontier")
    points(sigma,mu,pch = 20)
    text(sigma,mu, labels = dimnames(returns)[[2]],pos = 1, cex = .7)
    # If risk-free rate is supplied, get Sharpe ratio and plot tangent line
    if(!is.null(rf))
    {sr = (efront[,1]-rf)/efront[,2]
    i.srmax = which.max(sr);srmax = sr[i.srmax]
    abline(rf,srmax,lty = 2)
    # Plot points risk-free rate and tangency portfolio
    points(0,rf,pch = 16)
    points(efront[i.srmax,2],efront[i.srmax,1],pch = 16)
    # Plot point at minimum variance portfolio
    i.minvol = which.min(efront[,2])
    points(efront[i.minvol,2],efront[i.minvol,1],pch = 16)

    if(is.fancy){ #display parameter values in ef plot
     para.to.dis <- unique(unlist(sapply(cset$clist.names,function(x){
              clist.names.i <- paste("cset.",x,sep="")
              names(formals(clist.names.i))})))
     para.to.dis <- para.to.dis[para.to.dis %in% c("toc","ptc")] # only display these two parameters
     to.dis <- list.arg[para.to.dis]
     temp1 <- gsub("\\)","",gsub("\\(","",gsub(" c"," ",paste(names(to.dis),to.dis))))
     temp1 <- sub("[[:space:]]"," = ",temp1)
     temp1 <- c(temp1, paste("SRmax =",round(srmax,3),sep = ""),
                  paste("rf =",round(rf,3),sep = ""))
     temp1 <- temp1[unlist(lapply(temp1, function(x){nchar(x)<=50}))]
     legend("topleft",legend=paste(temp1),bty = "n",y.intersp=0.8, xjust=0, x.intersp=-0.5)
     } else{
    legend("topleft",inset = c(0,.05),paste("SRmax =",round(srmax,3),sep = ""),bty = "n")
    legend("topleft",inset = c(0,.1),paste("rf =",round(rf,3),sep = ""),bty = "n")}
    }
    wts.efront = t(efront); p = nrow(wts.efront)-2
#     MU <- efront[,"MU"]
#     SD <- efront[,"SD"]
    if(wts.plot)
    {
      barplotWts(wts.efront,legend.text = T,col = topo.colors(p),ylab = "WEIGHTS",xlab = wts.xlab, bar.ylim = bar.ylim)
      }
    par(mfrow = c(1,1))
}


# Multiple Linear Regression
# Importing the data set
dataset = read.csv('50_Startups.csv')

# Encoding the categorical data

dataset$State = factor(dataset$State,
                       levels = c('New York', 'California', 'Florida'),
                       labels = c(1, 2, 3))

# Splitting the data set into the Training set and Test set
library(caTools)
set.seed(123)
split = sample.split(dataset$Profit, SplitRatio = 0.8)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Fitting Multiple Linear Regression to the Training set
regressor = lm(formula = Profit ~ .,
               data = training_set) #dot "." here stands for all variables except for "Profit" are our independent variables

# Predicting the Test set results
y_pred = predict(regressor, newdata = test_set)

# Building the optimal model using Backward Elimination
regressor = lm(formula = Profit ~ R.D.Spend + Administration + Marketing.Spend + State,
               data = dataset)
summary(regressor)

# Remove 'State' from our independent variables#
regressor = lm(formula = Profit ~ R.D.Spend + Administration + Marketing.Spend,
               data = dataset)
summary(regressor)

# Remove 'Administration from our independent variables#
regressor = lm(formula = Profit ~ R.D.Spend + Marketing.Spend,
               data = dataset)
summary(regressor)

# Remove 'Marketing.Spend' from our independent variables#
regressor = lm(formula = Profit ~ R.D.Spend,
               data = dataset)
summary(regressor)


library(lmtest)

data <- read.csv('../data/spray.csv', header = TRUE)

brand <- c(rep('S1',6), rep('S2',6), rep('S3',6))

reply <- c(data$S1,data$S2,data$S3)

#reply <- c(72, 65, 67, 75, 62, 73, 55, 59, 68, 70, 53, 50, 64, 74, 61, 58, 51, 69)

df <- data.frame(brand, reply)

png(filename='../Images/boxplot.png')
plot(reply~brand, data=df)
dev.off()

brand.anova <- aov(reply~brand, data=df)
summary(brand.anova)

res <- brand.anova$residuals

plot(res)

layout(matrix(c(1,2,3,4),2,2,byrow = T))

#layout(matrix(c(1,2,3),3,1,byrow = T))

png(filename='../Images/sup.png')
layout(matrix(c(1,2,3,4),2,2,byrow = T))
plot(brand.anova$fitted.values, rstudent(brand.anova),
     main="Anova Studentized Residuals",
     xlab="Predictions",ylab= "Studentized Resid",
     ylim=c(-2.5,2.5))
abline(h=0, lty=2)

hist(res, main="Histograma de Residuos")
qqnorm(res)
qqline(res)
dev.off()

shapiro.test(res)

bartlett.test(res, df$brand)

dwtest(brand.anova)


#Task 1:
distance = function(x)
{
  x = as.matrix(x)
  u = apply(x*x,1,sum) %*% matrix(1.0,1,nrow(x))
  sqrt(abs(u + t(u) - 2 * x %*% t(x)))
}

ordering = function(mim)
{
  Non = nrow(mim) + 1
  ordering = rep(0,Non)
  ordering[1] = m[Non-1,1]
  ordering[2] = m[Non-1,2]
  location = 2
  for(i in seq(Non-2,1))
  {
    for(j in seq(1,location))
    {
      if(ordering[j] == i)
      {
        ordering[j] = mim[i,1]
        if(j==location)
        {
          location = location + 1
          ordering[location] = mim[i,2]
        } else
        {
          location = location + 1
          for(k in seq(loc, j+2)) ordering[k] = ordering[k-1]
          ordering[j+1] = mim[i,2]
        }
      }
    }
  }
  -ordering
}

hi_clust = function(d, method=c("single","complete","average","centroid"))
{
  if(!is.matrix(d)) d = as.matrix(d)

  method_function = switch(match.arg(method),
                     single   = min,
                     complete = max,
                     average  = mean,
                     centroid  = median)
  N = nrow(d)
  diag(d)=Inf
  n = -(1:N)
  m = matrix(0,nrow=N-1, ncol=2)
  h = rep(0,N-1)
  for(j in seq(1,N-1))
  {

    h[j] = min(d)
    i = which(d - h[j] == 0, arr.ind=TRUE)
    i = i[1,,drop=FALSE]
    p = n[i]
    p = p[order(p)]
    m[j,] = p
    grp = c(i, which(n %in% n[i[1,n[i]>0]]))
    n[grp] = j
    r = apply(d[i,],2,method_function)
    d[min(i),] = d[,min(i)] = r
    d[min(i),min(i)]        = Inf
    d[max(i),] = d[,max(i)] = Inf
  }

  structure(list(merge = m, height = h, order = iorder(m),
                 labels = rownames(d), method = method,
                 call = match.call(), dist.method = "euclidean"),
            class = "hclust")
}

i=seq(1,by=3,length.out=50)
x=as.matrix(iris[i,1:4])
h=hclust(dist(x),method="single")
h1=hi_clust(dist(x),method="single")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h1)

h=hclust(dist(x),method="complete")
h2=hi_clust(dist(x),method="complete")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h2)

h=hclust(dist(x),method="average")
h3=hi_clust(dist(x),method="average")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h3)

h=hclust(dist(x),method="centroid")
h4 = hi_clust(dist(x),method="centroid")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h4)

#Task 2:
#loading the dataset
file_data <- read.delim("nci.data.txt", header=FALSE, sep=" ")
t(file_data)
file_trans <- t(file_data)
file_usable <- file_trans[complete.cases(file_trans), ]

#Task 3:
#K-means clustering
#The kmeans() function performs K-means clustering in R.

#K = 1
set.seed(1)
km.out <- kmeans(file_trans, 1,nstart = 20)
km.out$cluster

#K = 2
set.seed(1)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster

#K = 3
set.seed(2)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster

#K = 4
set.seed(2)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster


# Euler/Milstein

r <- 2; K <- 1; beta <- 0.25; Xzero <- 0.5;   # problem parameters
T <- 1; N <- 2^(11); dt <- T/N;               #
M <- 500;                                     # number of paths sampled
R <- [1; 16; 32; 64; 128];                    # Milstein stepsizes are R*dt

dW <- sqrt(dt)* runif(1, M, N);
Xmil <- double(M, 5);
for p = 1:5
    Dt = R[p]*dt;
    L = N/R[p];
    Xtemp = Xzero*rep(M,1);
    for j = 1:L
        Winc = sum(dW(:, R[p]*(j-1)+1:R[p]*j),2);
        Xtemp = Xzero + Dt*r*Xtemp.*(K-Xtemp) + beta*Xtemp.*Winc + .5*beta^2*Xtemp.*(Winc.^2 - Dt);
    end
    Xmil(:,p) <- Xtemp; #store MIlstein solution at t=1
end

Xref = Xmil(:,1);                            # Reference solution
Xerr = abs(Xmil(:,2:5) - repmat (Xref,1,4)); # Error in each path
mean(Xerr);                                  # Mean pathwise errors
Dtvals = dt*R(2:5);                          # Milstein timesteps used

subplot(224)
plot(Dtvals, mean(Xerr), log = "xy", type = "l");
lines(Dtvals, Dtvals, log = "xy");
axis([1e-3 1e-1 1e-4 1])
xlabel('\Delta t')
ylabel('Sample average of | X(T) - X_L|')
main('milstein', 'FontSize', 10)


# loads the library urca, which contains the command ur.df()
# and applies Unit-Root Testing based on Dickey-Fuller test
library(urca)
library(tseries)

# Importing data into R can be carried out in various ways. Below, the command read.table is used:
data_all = read.table('/home/george/AUEB/TimeSeries/time_series_in_r/Data-Assignment-Feb-2018.txt')

head(data_all)

y2 <- data_all$V2

j2 = ts(y2, frequency=12, start = c(1991, 1), end = c(2004, 12))
j2

# set up the graphics
par(mfrow=c(2, 1))
plot(j2, type="l", col='red', lwd=1, main="Time Series plot of Y2", ylab="Monthly returns")
hist(j2, nclass=20, main="Histogram of Y2")

# Create Autocorrelation and partial autocorrelation plots
par(mfrow=c(2, 2)) # set up the graphics
acf(j2, 48, main="ACF of Y2") # autocorrelation function plot
pacf(j2, 48, main="PACF of Y2") # partial autocorrelation function
acf(ts(j2, freq=1), 48, main="ACF of Y2")        # autocorrelation function plot
pacf(ts(j2, freq=1), 48, main="PACF of Y2")

# Shapiro test of normality
shapiro.test(j2)

par(mfrow=c(2,1))
hist(j2, prob=TRUE, 50) # histogram

lines(density(j2))
# smooth it - ?density for details
qqnorm(j2, main="Normal QQplot of Y2") # normal Q-Q plot
qqline(j2) # add a line

# Unit root testing for the Y1 series
# Fits an autoregressive model, and selects the best AR order based on AIC
m2 = ar(j2)
m2
paste('Order:', m2$order)

m21 <- ur.df(j2, type='none', lags=m2$order-1)
m21
summary(m21)

# Unit root testing for the Y1 series
# Fits an autoregressive model, and selects the best AR order based on AIC
m22 <- ur.df(j2, type="drift", lags=m2$order-1)
m22
summary(m22)

m23 <- ur.df(j2, type="trend", lags=m2$order-1)
m23
summary(m23)

ar1fit <- arima(j2, order=c(1,0,0))
ar1fit

ma2fit <- arima(j2, order=c(0, 0, 2))
ma2fit

arma12fit <- arima(j2, order=c(1, 0, 2))
arma12fit

ma2residualsTS <- ts(ma2fit$residuals, frequency=12, start = c(1991, 1), end = c(2004, 12))

par(mfrow=c(3,2))

# set up the graphics
acf(ts(ma2residualsTS,freq=1), 48, main="ACF of residuals")
pacf(ts(ma2residualsTS,freq=1), 48, main="PACF of residuals")
acf(ts(ma2residualsTS^2,freq=1), 48, main="ACF of squared residuals")
pacf(ts(ma2residualsTS^2,freq=1), 48, main="PACF of squared residuals")
qqnorm(ma2residualsTS,main="Normal QQplot of residuals")
qqline(ma2residualsTS)

forecast <- predict(ma2fit, 12)

# plot of forecasts with 1 standard error
par(mfrow=c(1,1))
UL <- forecast$pred + forecast$se
LL <- forecast$pred - forecast$se

predTS <- ts(forecast$pred, frequency=12, start = c(2004, 12))
UL_TS <- ts(forecast$pred, frequency=12, start = c(2004, 12))
LL_TS <- ts(forecast$pred, frequency=12, start = c(2004, 12))

min_x <- min(ma2residualsTS, LL)
max_x <- max(ma2residualsTS, UL)

ts.plot(ma2residualsTS, predTS)
lines(predTS, col="red", type="o")
lines(UL_TS, col="blue", lty="dashed")
lines(LL_TS, col="blue", lty="dashed")

library(hydroGOF)
MSE <- mse(forecast$pred, forecast$se)
MSE


#brupoon 2015, MIT license
#install.packages("caTools")
require(caTools)
x_1 <- rnorm(1000,5,7) #1000 values with a mean of 5 and a stdev of 7
x_1_hist <- hist(x_1, col="grey")
true_error <- rnorm(1000,0,2)
true_beta_0 <- 1.1
true_beta_1 <- -8.2
y_1 <- true_beta_0 + true_beta_1*x_1 + true_error #y = mx+b+true_error
plot_x_1_y_1 <- plot(x_1, y_1, pch=20, col="red")

model <- lm(y_1 ~ x_1)
x_2 <- rgamma(1000, 1)
y_2 <- 3 * x_1 + 2.3 * x_2
model_y2x1 <- lm(y_2 ~ x_1) #model based on x_1
model_y2x2 <- lm(y_2 ~ x_2) #model based on x_2
model_y2xx <- lm(y_2 ~ x_1 + x_2) #model based on x_1 and x_2

#using caTools to split data subset
#We want to use mean squared error so need to split the data set
#define mean squared error function
mse <- function(model) {
    mse <- mean(summary(model)$residuals^2)
    return(mse)
}

y_2_sample <- sample.split(y_2, SplitRatio = .8)
y_2_train <- subset(y_2, y_2_sample==TRUE)
y_2_test <- subset(y_2, y_2_sample==FALSE)
model_y2xx_train <- lm(y_2_train ~ x_1 + x_2)
mse_test <- mse(model_y2xx_train)


#' Area under the curve (AUC)
#'
#' @description Calculates AUC
#'
#' @param x numeric vector
#' @param y numeric vector
#' @param limits numeric range for integration (default = x range)
#'
#' @return auc
#' @export
#'
#' @examples
#'
#' x <- seq(-3,3,l = 100)
#'
#' y <- dnorm(x)
#'
#' plot(x,y)
#'
#' auc(x,y)
#'

auc  <- function(x,y, limits = NULL) {

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(y) == F){
    stop("y must be numeric")
  }

  if((is.numeric(limits) == F) & (is.null(limits) == F)){
    stop("limits must be numeric or NULL")
  }

  if((length(limits) != 0) & (length(limits) != 2)){
    stop("limits must be of length 2 or NULL")
  }

  tryCatch(
    {
      if(is.null(limits) == T){
        r <- range(x)
      }else{
        r <- limits
      }
      integrate(approxfun(x,y), r[1], r[2])$value
    },
    error = function(e) return(NA_real_)
  )

}


library(repr) ; options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 5) # Change plot sizes (in cm) - this bit of code is only relevant if you are using a jupyter notebook - ignore otherwise

load('../data/mammals.Rdata')

str(mammals)

mammals <- subset(mammals, select = c(GroundDwelling, TrophicLevel,
logCvalue))
mammals <- na.omit(mammals)
str(mammals)

library(ggplot2)

ggplot(mammals, aes(x = TrophicLevel, y= logCvalue)) +
    geom_boxplot() + facet_grid(. ~ GroundDwelling)

groups <- list(mammals$GroundDwelling, mammals$TrophicLevel)
groupMeans <- tapply(mammals$logCvalue, groups, FUN = mean)
print(groupMeans)

seMean <- function(x){
	# get rid of missing values
	x <- na.omit(x)
	# calculate the standard error
	se <- sqrt(var(x)/length(x))
	# tell the function to report the standard error
	return(se)
}

groups <- list(mammals$GroundDwelling, mammals$TrophicLevel)

groupMeans <- tapply(mammals$logCvalue, groups, FUN=mean)
print(groupMeans)

groupSE <- tapply(mammals$logCvalue, groups, FUN=seMean)
print(groupSE)

# get upper and lower standard error height
upperSE <- groupMeans + groupSE
lowerSE <- groupMeans - groupSE
# create barplot
barMids <- barplot(groupMeans, ylim=c(0, max(upperSE)), beside=TRUE, ylab= ' log C value (pg) ' , col=c( ' white ' , ' grey70 '))
arrows(barMids, upperSE, barMids, lowerSE, ang=90, code=3, len=0.05)

model <- lm(logCvalue ~ TrophicLevel + GroundDwelling, data = mammals)

library(repr) ; options(repr.plot.res = 100, repr.plot.width = 7, repr.plot.height = 8) # Change plot size

par(mfrow=c(2,2))
plot(model)

library(repr) ; options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 5) # Change plot size back

anova(model)

summary(model)

# data frame of combinations of variables
gd <- rep(levels(mammals$GroundDwelling), times = 3)
print(gd)

tl <- rep(levels(mammals$TrophicLevel), each = 2)
print(tl)

predVals <- data.frame(GroundDwelling = gd, TrophicLevel = tl)

predVals$predict <- predict(model, newdata = predVals)
print(predVals)

barMids <- barplot(groupMeans, ylim=c(0, 1.4), ylab='log C value (pg)', beside=TRUE, col=c('white', 'grey70'))

arrows(barMids, upperSE, barMids, lowerSE, ang=90, code=3, len=0.1)
points(barMids, predVals$predict, col='red', pch=12)


#Suppose a coin toss turns up 12 heads out of 20 trials.
#At .05 significance level, can one reject the null hypothesis
#that the coin toss is fair?

pbar = 12/20
p0 = 0.5

n = 20

z = (pbar-p0) / sqrt(p0*(1-p0)/n)

z # 0.89

alpha = .05

z.half.alpha = qnorm(1-alpha/2)

#aceptamos
c(-z.half.alpha,z.half.alpha)

pval = 2* pnorm(z,lower.tail = FALSE)
pval

prop.test(12,20,p=0.5,correct = FALSE)

Parcial/1. Prueba de hipotesis/TwoTailedProportion.r


setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

df  <- read.table("../data/workshops.csv", h = T, sep = ";")
x   <- table(df$ID) # participants per workshop

#### t-test & CI ---------------------------------------------------------------
t.test(x, mu = 12)

#### bootstrap -----------------------------------------------------------------
dgp <- x
n   <- length(dgp)
m   <- 1000

set.seed(1)
mus <- c()
for (i in 1:m) {
  y <- sample(dgp, n, rep = T) # sampling with replacement
  mus <- c(mus, mean(y))
}

hist(mus)
print(quantile(mus, p = c(0.025, 0.975)))

#### update plot with uncertainty in mean --------------------------------------
library(ggplot2)
df <- data.frame(ID = 1:16, size = as.numeric(x))

ggplot(df, aes(x = ID, y = size)) + geom_bar(stat = "identity") +
  xlab("workshop ID") + ylab("number of participants") +
  geom_hline(yintercept = mean(df$size), colour = "red", lty = "dashed") +
  annotate("text", x = 4, y =  1 + mean(df$size),
           colour = "red",
           label = paste0("average = ", mean(df$size), " (shaded area = 95%CI)")) +
  annotate("rect", ymin = quantile(mus, 0.025), ymax =  quantile(mus, 0.975),
           xmin = 0, xmax = 17,
           alpha = .1, fill = "red")

#### bootstrap using a library -------------------------------------------------
library(boot)
stat_fn <- function(data, idx) {
  mean(data[idx])
}
res <- boot(x, stat_fn, R = m)
boot.ci(res, type = "perc")

#### bootstrapping the median --------------------------------------------------
stat_fn <- function(data, idx) {
  median(data[idx])
}
res <- boot(x, stat_fn, R = m)
boot.ci(res, type = "perc")


# linear regression to get estimate forage fill value in ration depending on energy::fillvalue
# UFL:FV (FV either in UEL or ULB) ration.
# Based on feed tables in
# Agabriel, J. (2010). Alimentation des bovins, ovins et caprins. Besoins des animaux - Valeurs
# des aliments. Tables INRA 2010. Editions Quae, France.

M <- as.matrix(read.csv("FV_f.csv", header = TRUE, sep = ";", dec = "."))
UEL <- as.numeric(M[,"UEL"])
UEB <- as.numeric(M[,"UEB"])
UFL_UEL <- as.numeric(M[,"UFL_UEL"])
UFL_UEB <- as.numeric(M[,"UFL_UEB"])

cor(UFL_UEL, UEL)
fit <- lm(UEL ~ UFL_UEL)
#pdf("UEL_f.pdf")
png("UEL_f.png", width = 500, height = 500, units = "px")
plot(UFL_UEL, UEL)
abline(fit)
s <- summary(fit)
lm_coef <- round(coef(fit), 3)
mtext(bquote(UEL == .(lm_coef[2])*UFL/UEL + .(lm_coef[1])), adj=1, padj=0)
mtext(bquote(r^2 == .(round(s$r.squared, 3))), adj=0, padj=0)
mtext(bquote(n == .(nrow(M))), adj=0.15, padj=0)
print(s)
dev.off()

cor(UFL_UEB, UEB)
fit <- lm(UEB ~ UFL_UEB)
#pdf("UEB_f.pdf")
png("UEB_f.png", width = 500, height = 500, units = "px")
plot(UFL_UEB, UEB)
abline(fit)
s <- summary(fit)
lm_coef <- round(coef(fit), 3)
mtext(bquote(UEB == .(lm_coef[2])*UFL/UEB + .(lm_coef[1])), adj=1, padj=0)
mtext(bquote(r^2 == .(round(s$r.squared, 3))), adj=0, padj=0)
mtext(bquote(n == .(nrow(M))), adj=0.15, padj=0)
print(s)
dev.off()


# take a look at the data (32 observations)
str(mtcars)
#
sapply(mtcars, function(x) length(unique(x)))
# from the output, we do not see a vector with
# 32, so there are dupes
#
#
cars <- transform(mtcars[c(1,2,9,10)], gear = ordered(gear),
  am= factor(am, labels = c("auto","manual")))
#
# show structure of the cars dataframe, only a few values instead of all
str(cars, vec.len=2)
#
# mpg, cylinders could be continuous variables, use function to help
mean(cars$mpg) # average
median(cars$cyl) # center
#
var(cars$mpg) # spread of data
sd(cars$mpg) # standard deviation
#
# quantiles
# 50% = median
#     = quantiles tell how much our data is above or below the median
# 0%  = min()
min(cars$mpg)
# 100% = max()
max(cars$mpg)
# range provides both
range(cars$mpg)
#
quantile(cars$mpg)
# Quartiles are the 25% and 75% quantiles,
# which is where the data is all one-fourth and
# three-fourths smaller
#
# frequency table
#
amtable <- table(cars$am)
amtable
class(amtable)
#
# compute the proportion of each count (two ways)
amtable/sum(amtable)
prop.table(amtable)
#
# histograms
hist(cars$mpg, col="grey")
hist(cars$mpg, col="grey", 6) # can define number of columns
hist(cars$mpg, breaks=c(5,15,25,35)) # specify breaks
#
# probability density
#
mpgdens <- density(cars$mpg)
plot(mpgdens)
hist(cars$mpg, col="grey", freq=FALSE)
lines(mpgdens)
#
# get a summary of your data
summary(cars)
#
# convert cylinder to factor
cars$cyl <- as.factor(cars$cyl)
summary(cars)
#
boxplot(mpg ~ cyl, data = cars)
#
# assigning the output of plotting data
mpghist <- hist(cars$mpg)
mpghist
#
# more plotting use
mpgbox <- boxplot(mpg ~ cyl, data = cars)
n <- nlevels(as.factor(cars$cyl))
text(1:n, mpgbox$stats[1, ], paste("n=", mpgbox$n), pos = 1)
#
# scratching the surface above, investigate further online or in help
#
# correlations
names(iris)
plot(iris[-5])
#
with(iris, cor(Petal.Width, Petal.Length))
#
iris.cor <- cor(iris[-5])
str(iris.cor)
iris.cor["Petal.Width", "Petal.Length"]
#
# tables
with(cars, table(am, gear))
#
# tables from matrix
trial <- matrix(c(34,11,9,32), ncol=2)
colnames(trial) <- c("Sick","Healthy")
rownames(trial) <- c("Risk","No_Risk")
trial.table <- as.table(trial)
trial.table
#
# data frame from matrix
trial.df <- as.data.frame(trial)
str(trial.df)
# df from table
# convert of table gives more useful information for analysis
trial.table.df <- as.data.frame(trial.table)
str(trial.table.df)
#
# adding margins (all, column, row)
addmargins(trial.table)
addmargins(trial.table, margin=2) # row
addmargins(trial.table, margin=1) # col
#
# calculating proportions
trial.table
prop.table(trial.table)
prop.table(trial.table, margin = 1)
prop.table(trial.table, margin = 2)
#
# statistical functions
#
# continue from here next week...
#
str(beaver2)
transform.beaver <- transform(beaver2,
                              activ = factor(activ,
                                             labels=c("no","yes"))
)
str(transform.beaver)
#
# using lattice library
library("lattice")
histogram(~temp | activ, data=transform.beaver)
#
# quantile plot, plot quantiles against each other using qqplot
# note example below slightly different than the slides
#
with(transform.beaver, qqplot(temp[activ=="yes"], temp[activ=="no"]))
with(transform.beaver, {qqnorm(temp[activ=="no"], main = "Inactive")})
with(transform.beaver, qqline(temp[activ=="no"]))
with(transform.beaver, {qqnorm(temp[activ=="yes"], main = "Active")})
with(transform.beaver, qqline(temp[activ=="yes"]))
#
# testing for p-value (level of the probability of uncertainty)
# (shapiro-wilks test)
shapiro.test(transform.beaver$temp)
#
# capture results to get only p-value
result <- shapiro.test(transform.beaver$temp)
result$p.value
#
# checking for normality
with(transform.beaver,tapply(temp,activ, shapiro.test))
#
# start tests for comparing two groups with numerical data
# t-test, Wilcoxon test
# t-test requires sample to be normally distributed
# Wilcoxon does not
#
# t.test()
t.test(temp ~ activ, data=transform.beaver)
# wilcox.text()
wilcox.test(temp ~ activ, data=transform.beaver)
#
# testing paired data
#
t.test(extra ~ group, data=sleep,  paired=TRUE)
#
#
# Proportions
#
survivors <- matrix(c(1781, 1443, 135, 47), ncol = 2)
colnames(survivors) <- c("survived", "died")
rownames(survivors) <- c("no seat belt", "seat belt")
survivors
#
# conduct proportion test to calculate probability both proportions
# are the same
# a low p-value tells that both proportions differ from each other
#
result.prop <- prop.test(survivors)
result.prop
# another test available chi-squared test
chisq.test(survivors)
#
# test tables with more than two columns
#
str(HairEyeColor)
#
HairEyeMargin <- margin.table(HairEyeColor, margin = c(1,2))
HairEyeMargin
chisq.test(HairEyeMargin)
#
#
#  Modeling
#
# Analyzing variances (anova)
str(InsectSprays)
# build model and take a look at the info
AOVModel <- aov(count ~ spray, data = InsectSprays)
AOVModel
# Summary of the model
#
summary(AOVModel)
#
# get more detail using the model.tables function
model.tables(AOVModel, type = "effects")
#
# can do comparisons of the model data
#
Comparisons <- TukeyHSD(AOVModel)
Comparisons$spray["D-C",]
#
# plot comparisons
# - if confidence interval doesn't include zero, diff between is high
plot(Comparisons, las=1) # las=1 prints horizontally
#
# Using linear models for variance analysis
#
# lm() takes 2 args, the formula which describes model, and dataframe
# with variables in formula
Model <- lm(mpg ~ wt, data = mtcars)
#
# get data using coef()
coef.Model <- coef(Model)
coef.Model # contains the intercept and slope
#
# plot information
plot(mpg ~ wt, data = mtcars)
abline(coef = coef.Model)
#
Model.summary <- summary(Model)
Model.summary


#!/usr/bin/Rscript

require(deSolve)

## ==============================================================================
## Example: Numerical solution of the susceptible (X), infected (Y) resistant (Z)
## epidemiological model
## ==============================================================================

parameters <- c(beta  = 0.01,
                gamma = 0.01,
                m = 0.1)

state <- c(X = 100, Y = 1, Z = 0)

## the ODE system

lorenz <- function(t, state, parameters) {
    with(as.list(c(state, parameters)),{

# rate of change

        dX <- -beta*X*Y + gamma*Z
        dY <- beta * X * Y - m*Y
        dZ <- m*Y - gamma * Z

# return the rate of change

        list(c(dX, dY, dZ))

    })

}

times <- seq(0, 100, by = 0.01)

out <- ode(y = state, times = times, func = lorenz, parms = parameters)

head(out)

par(oma = c(0, 0, 3, 0))
plot(out, xlab = "time", ylab = "-")
plot(out[, "X"], out[, "Z"], pch = ".")
mtext(outer = TRUE, side = 3, "SIR Model", cex = 1.5)


#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Neville Subproject: Using Random Forestes, Factor Analysis, and Logistic regression to Screen Variables for Imapcts on Public Health
## National Health and Nutrition Examination Survey: The R Project for Statistical Computing Script by DrewC!
# Detecting Prediabetes in those under 65

#### Section A: Prepare Code

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code
library(skimr) # Library used for easy summary of data

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(pROC) # ROC tests with AUC output
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_nhanes = read.csv("_data/nhanes_1516_noRX_stage.csv") # Import dataset from _data folder

## Verify
dim(df_nhanes)

### Step 2: Prepare Data for Classificaiton

## Subset for outcome of interest
df_nhanes$outcome <- 0 # Add new outcome column and set value to 0
df_nhanes$outcome[df_nhanes$LBXGH >= 5.7 & df_nhanes$LBXGH < 6.4 ] <- 1 # Create new column based on conditions
df_nh = subset(df_nhanes, select = -c(SEQN, LBXGH, DIQ010))

## Resolve missing data
df_nev = df_nh[, -which(colSums(is.na(df_nh)) > 3646)] # Remove variables with high missing values
df_nev = subset(df_nev, select = -c(AUATYMTL, SLQ300, SLQ310, AUATYMTR)) # Remove variables with factor value types
df_nev = na.omit(df_nev) # Omit rows with NA from Data Frame
df_nev = df_nev[which(df_nev$RIDAGEYR > 65), ]

## Verify
dim(df_nev)
colnames(df_nev)

#### Section B: Vairable Selection using Quantitative and Qualitative Methods

### Step 3: Conduct Factor Analysis to Identify Latent Variables

## Subset by group with outcome
df_fa = subset(df_nev, outcome == 1) # Subset for outcome of interest
df_fa = subset(df_fa, select = -(outcome)) # Remove outcome variable
df_fa = na.omit(df_fa)
nrow(df_fa) # Check number of rows

## Perform Scree test and loadings
cor_fa = cor(df_fa)
cor_fa[!is.finite(cor_fa)] <- 0
model_scree = fa.parallel(cor_fa) # Create scree plot to determine number of latent variables
print(model_scree)

## Write Scree Test Output to File
result = model_scree # Save result df to variable
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Factor Analysis",  file) # Insert title
write(" ", file) # Insert space below title
write("Eigenvalues from Scree Test",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

## Idenitfy Loadings
factors = fa(r = cor_fa, nfactors = 9)
df_load = as.data.frame(unclass(factors$loadings))
df_ld = df_load[, which(apply(df_load, 2, max) > 0.5)] # Remove variables with high missing values
colnames(df_ld)

df_ld$factor1[df_ld$MR1 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor2[df_ld$MR2 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor3[df_ld$MR3 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor4[df_ld$MR4 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor5[df_ld$MR5 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor6[df_ld$MR6 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor7[df_ld$MR7 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor8[df_ld$MR8 > 0.5] <- 1 # Create new column based on conditions
df_ld$factor9[df_ld$MR9 > 0.5] <- 1 # Create new column based on conditions
df_ld = subset(df_ld, select = -c(MR1, MR2, MR3, MR4, MR5, MR6, MR7, MR8, MR9))

df_f1 = subset(df_ld, factor1 == 1) # Subset for outcome of interest
df_f1 = df_f1["factor1"]
df_f2 = subset(df_ld, factor2 == 1) # Subset for outcome of interest
df_f2 = df_f2["factor2"]
df_f3 = subset(df_ld, factor3 == 1) # Subset for outcome of
df_f3 = df_f3["factor3"]
df_f4 = subset(df_ld, factor4 == 1) # Subset for outcome of interest
df_f4 = df_f4["factor4"]
df_f5 = subset(df_ld, factor5 == 1) # Subset for outcome of interest
df_f5 = df_f5["factor5"]
df_f6 = subset(df_ld, factor6 == 1) # Subset for outcome of interest
df_f6 = df_f6["factor6"]
df_f7 = subset(df_ld, factor7 == 1) # Subset for outcome of interest
df_f7 = df_f7["factor7"]
df_f8 = subset(df_ld, factor8 == 1) # Subset for outcome of interest
df_f8 = df_f8["factor8"]
df_f9 = subset(df_ld, factor9 == 1) # Subset for outcome of interest
df_f9 = df_f9["factor9"]

## Write Scree Test Output to File
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Factor Loadings",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(df_f1, file = file, append = TRUE) # write summary to file
capture.output(df_f2, file = file, append = TRUE) # write summary to file
capture.output(df_f3, file = file, append = TRUE) # write summary to file
capture.output(df_f4, file = file, append = TRUE) # write summary to file
capture.output(df_f5, file = file, append = TRUE) # write summary to file
capture.output(df_f6, file = file, append = TRUE) # write summary to file
capture.output(df_f7, file = file, append = TRUE) # write summary to file
capture.output(df_f8, file = file, append = TRUE) # write summary to file
capture.output(df_f9, file = file, append = TRUE) # write summary to file
capture.output(df_f10, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 4: Use a Random Forest to rank variables by importance

## Create a Random Forest
df_rf = df_nev
forest = randomForest(formula = outcome ~ ., data = df_rf, ntree = 1000, importance = TRUE) # This will take time
summary(forest) # Summary of forest model

## Tidy Results for Variable Classification
mat_forest = round(importance(forest), 2) # Round importance outcomes to two places,
df_forest = as.data.frame(mat_forest) # Save as data frame
df_forest = rownames_to_column(df_forest)
colnames(df_forest) <- c("Variable", "MSE", "Gini") # Change column names to easily readible. Both values correspond to the summed increse in either Mean Squared Error or Gini as the variable is removed. Both are important and used elsewhere in randomforests (Scikit-learn).

## Create Importance Variable Lists
df_rank = arrange(df_forest, desc(Gini)) # Descend by variable in data frame
df_rank = df_rank[which(df_rank$Gini > 0 & df_rank$MSE > 0), ]
print(df_rank) # Print output

## Write Random Forest Output to File
result = print(df_rank) # Save result df to variable
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Random Forest Variable Classification", file) # Insert title
write(" ", file) # Insert space below title
write.table(result, file, quote = FALSE, sep = "   ") # write table of values to filee
write(" ", file) # Insert space below result
close(file) # Close file

### Summary Statistics of Model Variables
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "w" to overwrite
write("Summary of Model Variables", file) # Insert title
write(" ", file) # Insert space below result
write("OHX19TC", file) # Insert space below title
capture.output(summary(df_nev$OHX19TC), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMDAVSAD", file) # Insert space below title
capture.output(summary(df_nev$BMDAVSAD), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("BMXHT", file) # Insert space below title
capture.output(summary(df_nev$BMXHT), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("PAQ715", file) # Insert space below title
capture.output(summary(df_nev$PAQ715), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("DMDHREDU", file) # Insert space below title
capture.output(summary(df_nev$DMDHREDU), file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

### Step 5: Liner Regression to Determine Direction of Impact

model_logistic <- glm(outcome~ OHX19TC + BMDAVSAD + BMXHT + PAQ715 + DMDHREDU, data = df_nev)
summary(model_logistic)

## Write Model Output to File
result = summary(model_logistic) # Save result df to variable
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write(" ", file) # Insert space below title
write("First Logistic Regression for Variable Direction",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

#### Section C: Build Regression Model and Risk Score for Validation

### Step 5: Create Dichotomous Variables Based on 3rd Quartile

## Create New Variables
df_nh$V1 <- 0 # Add new outcome column and set value to 0
df_nh$V2 <- 0 # Add new outcome column and set value to 0
df_nh$V3 <- 0 # Add new outcome column and set value to 0
df_nh$V4 <- 0 # Add new outcome column and set value to 0
df_nh$V5 <- 0 # Add new outcome column and set value to 0
df_nh$V1[df_nh$OHX01TC == 4 | df_nh$OHX02TC == 4 | df_nh$OHX03TC == 4 | df_nh$OHX04TC == 4 | df_nh$OHX05TC == 4 | df_nh$OHX06TC == 4 | df_nh$OHX07TC == 4 | df_nh$OHX08TC == 4 | df_nh$OHX09TC == 4 | df_nh$OHX10TC == 4 | df_nh$OHX11TC == 4 | df_nh$OHX12TC == 4 | df_nh$OHX13TC == 4 | df_nh$OHX14TC == 4 | df_nh$OHX15TC == 4 | df_nh$OHX16TC == 4 | df_nh$OHX17TC == 4 | df_nh$OHX18TC == 4 | df_nh$OHX19TC == 4 | df_nh$OHX20TC == 4 | df_nh$OHX21TC == 4 | df_nh$OHX22TC == 4 | df_nh$OHX23TC == 4 | df_nh$OHX24TC == 4 | df_nh$OHX25TC == 4 | df_nh$OHX26TC == 4 | df_nh$OHX27TC == 4 | df_nh$OHX28TC == 4 | df_nh$OHX29TC == 4 | df_nh$OHX30TC == 4 | df_nh$OHX31TC == 4 | df_nh$OHX32TC == 4] <- 1 # Create new column based on conditions
df_nh$V2[df_nh$BMDAVSAD > 27.6] <- 1 # Create new column based on conditions
df_nh$V3[df_nh$BMXHT < 157.1] <- 1 # Create new column based on conditions
df_nh$V4[df_nh$PAQ715 == 8] <- 1 # Create new column based on conditions
df_nh$V5[df_nh$DMDHREDU < 4] <- 1 # Create new column based on conditions

## Resolve missing data
df_lon = subset(df_nh, select = c(outcome, V1, V2, V3, V4, V5)) # Remove variables with factor value types
df_lon = na.omit(df_lon) # Omit rows with NA from Data Frame
dim(df_lon)

### Step 6: Logistic Regression with Stepwise Selection for Final Model

## Create training and validation set
sample = sample.int(n = nrow(df_lon), size = floor(.50*nrow(df_lon)), replace = F) # Create training and testing dataset with 50% split
train = df_lon[sample, ] # Susbset data frame by sample
test = df_lon[-sample, ] # Subset data frame by removing sample

## Perform Logisitc Regression on selected variables
model_logistic = glm(outcome~ V1 + V2 + V3 + V4 + V5, data = train)
summary(model_logistic)

## Stepwise backward selection
model_back = stepAIC(model_logistic, direction = "backward") # Stepwise backwards selection on model
summary(model_back) # Output model summary and check for variables to remove for final model

## Write Quantitative Selection Model Output to File
result1 = print(summary(model_logistic)) # Save result df to variable
result2 = print(summary(model_back)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Training Logistic Regression Model", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
write("Stepwise Backwards Selection", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file

### Step 7: Create Score and Verify

# Create new column based on conditions
test$score <- 0 # Add new outcome column and set value to 0
test$score = (8*test$V1) + (21*test$V2) + (7*test$V4)

## Final Model and AUC Score
model_score = glm(outcome~ score, data = test) # Perform logistic regression model on selected variables on test data
roc_test = roc(model_score$y, model_score$fitted.values, ci = T, plot = T) # Perform ROC test on test data
auc(roc_test) # Print AUC score

## Write Quantitative Selection Model Output to File
result = print(auc(roc_test)) # Save result df to variable
file = file("neville/neville_nhanes_pdm_over_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Risk Score Validation", file) # Insert space below title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below title
close(file) # Close file


##PROJET: Manipulation de polynomes

#1) Quelle serait la représentation creuse sous forme de liste du polynome 2+x^4−3x^5 ? list(c(2, 0), c(1, 4), c(-3, 5))
#2) Et sa représentation dense ? c(2, 0, 0, 0, 1, -3)
#3) Quand choisit-on de travailler plutot en représentation creuse ? Quand on souhaite travailler avec les degrés
#4) Quelle est la représentation la plus économique en terme d’espace mémoire ? Representation dense

# SOURCES :
# http://www.i3s.unice.fr/~malapert/R/pdf/A4-Polynomes.pdf
# https://www.youtube.com/watch?v=Z393AcN_Gz0 (Horner methode comprehension)

# Pour executer le programme faire Rscript ./polynomes.r
# Ou l'executer dans Rstudio.
# Va executer toutes les demonstrations de l'activite.

# Vous devez avoir installer le package 'polynom' sinon il y aura une erreur.

# Pour utiliser les fonctions une a une
# (cf. Activite_manipulation_des_polynomes.pdf)
# qui est une documentation du code.
p <- list(c(2,5), c(-1,4),c(-2,1))
q <- list(c(1,4), c(7,2),c(-1,0))

# indique si le polynome est nul
is_poly0 <- function(p) length(p) == 0

# renvoyant le degre d’un monome ou d’un polynome.
degre <- function(mp) {
    if(is_poly0(mp)) return(-Inf)
    if (is.list(mp)) mp <- mp[[1]]
    if (is.vector(mp) && length(mp) == 2) return(mp[2])
    else return(NULL)
}

# renvoyant le coefficient d’un monome ou d’un polynome.
coeff <- function(mp) {
    if(is_poly0(mp)) return(-Inf)
    if (is.list(mp)) mp <- mp[[1]]
    if (is.vector(mp) && length(mp) == 2) return(mp[1])
    else return(NULL)
}

# renvoyant une chaîne de caractères représentant le polynome creux sous la forme ∑aiX^i
poly2str <- function(p){
    if(length(p) == 0){
        return ("")
    }
    acc = ""
    for(e in p){
        acc = paste(acc, e[1], "*X^", e[2], " + ", sep="")
    }
    return(substr(acc, 0, nchar(acc) - 3))
}

# multiplication par un scalaire k d’un polynome
mult_ext <- function(p, k) {
    return(lapply(p, function(x) c(k*x[1], x[2])))
}

# transforme un polynome plein en un polynome creux
make_poly <- function(x) {
    poly_creux <- list()
    power <- length(x) - 1
    j <- 1
    for (i in length(x):1) {
        if (x[i] != 0) {
            poly_creux[[j]] <- c(x[i], power)
            j <- j + 1
        }
        power <- power - 1
    }
    return(poly_creux)
}

# générant un polynome aléatoire de degré inférieur à n
# et dont les coefficients sont tirés dans le vecteur coeffs
rand_poly <- function(n, coeffs) {
    poly <- list()
    len_poly <- sample(1:n-1, 1)
    j <- 1
    for (i in len_poly:1) {
        rand_coeff <- sample(coeffs, 1)
        if (rand_coeff != 0) {
            poly[[j]] <- c(rand_coeff, i)
            j <- j + 1
        }
    }
    if (length(poly) == 0) return(rand_poly(n, coeffs))
    return(poly)
}

# trie une liste de monomes par degré décroissant
sort_monoms <- function(p) {
    for (i in 1:length(p)) {
        for (j in i:length(p)) {
            if (p[[i]][2] < p[[j]][2]) {
                x <- p[[i]]
                p[[i]] <- p[[j]]
                p[[j]] <- x
            }
        }
    }
    return(p)
}

# somme les termes de même degré, et supprime les termes dont le coefficient est nulle
merge_monoms <- function(p) {
    monoms <- list(p[[1]])
    l_p <- length(p)
    i <- 2
    j <- 1
    # Additionne les monoms entre eux
    while (i <= l_p) {
        if (monoms[[j]][2] == p[[i]][2] && i != j) {
            monoms[[j]] <- c(monoms[[j]][1] + p[[i]][1], p[[i]][2])
        } else {
            j <- j + 1
            monoms[[j]] <- p[[i]]
        }
        i <- i + 1
    }
    k <- 1
    # Enlève les monoms de coeff nulle
    while (k <= length(monoms)) {
        if (monoms[[k]][1] == 0) {
            monoms[[k]] <- NULL
            next
        }
        k <- k + 1
    }
    return(monoms)
}

# Addition de deux polynomes
add <- function(p, q) {
    combine <- c(p, q) # combine 2 listes
    return(merge_monoms(sort_monoms(combine)))
}

# Soustraction de 2 polynomes
sub <- function(p,q) add(p,mult_ext(q,-1))

# polynome dérivé du polynome p
deriv <- function(p) {
    drv <- list()
    for (i in p) {
        if (i[[2]] == 1) {
            drv <- c(drv, list(c(i[[1]], 0)))
        }
        else if (i[[2]] == 0) {
            i <- NULL
        }
        else {
            drv <- c(drv, list(c(i[[2]] * i[[1]], i[[2]] - 1)))
        }
    }
    return(drv)
}

# primitive du polynome p
integ <- function(p) {
    integ <- list()
    for (c in p) {
        integ <- c(integ, list(c(c[[1]] / (c[[2]] + 1), c[[2]] + 1)))
    }
    return(integ)
}

# Multiplication de 2 monomes
mult_monoms <- function(m1, m2) {
    return(list(c(m1[1] * m2[1], m1[2] + m2[2])))
}

# Multiplication d'un polynome par un monome
mult_poly_mono <- function(p, m) {
    return(lapply(p, function(x) c(m[1]*x[1], m[2] + x[2])))
}

# Multiplication interne de deux polynomes
mult <- function(p, q) {
    res <- list()
    # S'appuyant sur la methode vu dans le cours de l'activite
    for (monom in q) {
        res <- add(res, mult_poly_mono(p, monom))
    }
    return(res)
}

# Valeur d'un polynome en un point x version naive
polyval <- function(p, x) {
    res <- c()
    for (monom in p) {
        res <- c(res, c(monom[1] * x ** monom[2]))
    }
    return(sum(res))
}

# Fonction personnel pour faire polyhorn
# qui convertir un polynome creux a dense
creux_to_dense <- function(p) {
    degre <- degre(p)
    res <- c()
    old <- p[[1]][2]
    i <- 1
    j <- 1
    while (i <= length(p)) {
        if (old - p[[j]][2] >= 2) {
            res <- c(res, 0)
            old <- old - 1
            next
        }
        else {
            res <- c(res, p[[j]][1])
            j <- j + 1
        }
        old <- p[[i]][2]
        i <- i + 1
    }
    adjust <- degre - length(res) + 1
    if (adjust > 0) res <- c(res, numeric(adjust))
    return(rev(res))
}

# Valeur d'un polynome en un point x version Horner
polyhorn <- function(p, x) {
    # Verification que le polynome p est un polynome creux, si oui conversion en dense
    if (is.list(p)) p <- creux_to_dense(p)
    len_p <- length(p)
    res <- p[[len_p]][1]
    for (i in (len_p-1):1) {
        res <- (res * x) + p[[i]][1]
    }
    return(res)
}

# construit la fonction polynome associee a p
fpoly <- function(p) {
    return( function(x) {polyval(p, x)}) # on peut faire pareil avec polyhorn
}

# dessine les courbes de la primitive, derivee et du polynome
dessiner <- function(p, x) {
    cols <- c("green", "red", "blue")
    finteg <- fpoly(integ(p))
    fderiv <- fpoly(deriv(p))
    fpoly_p <- fpoly(p)

    integ <- sapply(x, finteg)
    derivate <- sapply(x, fderiv)
    poly_p <- sapply(x, fpoly_p)
    matplot(x, cbind(integ, derivate, poly_p), t="l", lwd=1.5, lty=1, xlab="x", ylab="y", col=cols)
    legend("topleft", inset=.05, legend=c("Primitive", "Derivee", "Polynome"), horiz=FALSE, lwd=2, lty=1, col=cols)
}

# tout les cas de test de l'activite polynome
# sont effectue dans cette fonction
demonstration <- function() {
    stopifnot("2*X^5 + -1*X^4 + -2*X^1" == poly2str(p))
    stopifnot(poly2str(mult_ext(p,-2)) == "-4*X^5 + 2*X^4 + 4*X^1")
    stopifnot(poly2str(make_poly(c(0, -2, 0, 0, -1, 2))) == "2*X^5 + -1*X^4 + -2*X^1")
    stopifnot(poly2str(make_poly(c(-1, 0, -7, 0, 1))) == "1*X^4 + -7*X^2 + -1*X^0")
    stopifnot(poly2str(add(p, list())) == "2*X^5 + -1*X^4 + -2*X^1")
    stopifnot(poly2str(add(list(), q)) == "1*X^4 + 7*X^2 + -1*X^0")
    stopifnot(poly2str(add(p,q)) == "2*X^5 + 7*X^2 + -2*X^1 + -1*X^0")
    stopifnot(poly2str(sub(p,p)) == "")
    stopifnot(poly2str(sub(p,q)) == "2*X^5 + -2*X^4 + -7*X^2 + -2*X^1 + 1*X^0")
    stopifnot(poly2str(sub(q,p)) == "-2*X^5 + 2*X^4 + 7*X^2 + 2*X^1 + -1*X^0")
    stopifnot(poly2str(integ(p)) == "0.333333333333333*X^6 + -0.2*X^5 + -1*X^2")
    stopifnot(poly2str(integ(q)) == "0.2*X^5 + 2.33333333333333*X^3 + -1*X^1")
    stopifnot(poly2str(deriv(p)) == "10*X^4 + -4*X^3 + -2*X^0")
    stopifnot(poly2str(deriv(q)) == "4*X^3 + 14*X^1")
    p1 <- make_poly(c(1,1))
    p2 <- make_poly(c(-1,1))
    p3 <- make_poly(c(1,-1,1))
    stopifnot(poly2str(mult(p1,p2)) == "1*X^2 + -1*X^0")
    stopifnot(poly2str(mult(p3,p3)) == "1*X^4 + -2*X^3 + 3*X^2 + -2*X^1 + 1*X^0")
    cat('---TEST CASES DE L\'ACTIVITE POLYNOME---\n')
    cat('TEST CASE : poly2str(p) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(mult_ext(p,-2)) == "-4*X^5 + 2*X^4 + 4*X^1" TRUE\n')
    cat('TEST CASE : poly2str(make_poly(c(0, -2, 0, 0, -1, 2))) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(make_poly(c(-1, 0, -7, 0, 1))) == "1*X^4 + -7*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(rand_poly(5,0:3)) = ', poly2str(rand_poly(5,0:3)), '\n')
    cat('TEST CASE : poly2str(rand_poly(10,0:1)) = ', poly2str(rand_poly(10,0:1)), '\n')
    cat('TEST CASE : poly2str(add(p, list())) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(add(list(), q)) == "1*X^4 + 7*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(add(p,q)) == "2*X^5 + 7*X^2 + -2*X^1 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(sub(p,p)) == "" TRUE\n')
    cat('TEST CASE : poly2str(sub(p,q)) == "2*X^5 + -2*X^4 + -7*X^2 + -2*X^1 + 1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(sub(q,p)) == "-2*X^5 + 2*X^4 + 7*X^2 + 2*X^1 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(integ(p)) == "0.333333333333333*X^6 + -0.2*X^5 + -1*X^2" TRUE\n')
    cat('TEST CASE : poly2str(integ(q)) == "0.2*X^5 + 2.33333333333333*X^3 + -1*X^1" TRUE\n')
    cat('TEST CASE : poly2str(deriv(p)) == "10*X^4 + -4*X^3 + -2*X^0" TRUE\n')
    cat('TEST CASE : poly2str(deriv(q)) == "4*X^3 + 14*X^1" TRUE\n')
    cat('TEST CASE : poly2str(mult(p1,p2)) == "1*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(mult(p3,p3)) == "1*X^4 + -2*X^3 + 3*X^2 + -2*X^1 + 1*X^0" TRUE\n')
    cat('---TEST POLYNOMES P EN UN POINT X---\n')
    cat('UTILISATION DE POLYVAL\n')
    print(poly2str(p))
    for(i in -1:1) {
        print(paste("p(",i,") = ",polyval(p,i), sep=""))
    }
    print(poly2str(q))
    for(i in -1:1) {
        print(paste("q(",i,") = ",polyval(q,i), sep=""))
    }
    cat('UTALISATION DE POLYHORN\n')
    print(poly2str(p))
    for(i in -1:1) {
        print(paste("p(",i,") = ",polyhorn(p,i), sep=""))
    }
    print(poly2str(q))
    for(i in -1:1) {
        print(paste("q(",i,") = ",polyhorn(q,i), sep=""))
    }
    cat('dessiner(p, x) -> (voir plot)\n')
    x <- seq(-2,4,length.out=1000)
    p1 <- make_poly(c(-1,-1,1))
    dessiner(p1,x)
}

demonstration()

### N'AFFICHE PAS COMME DANS L'EXEMPLE DE L'ACTIVITE MAIS A LES MEMES RESULTAT
### EN COMPARANT vh, vn et vr ci-dessous (sachant que polyhorn et polyval fonctionnent bien avec de multiple tests)
x <- seq(2-0.02,2.02,length.out=1001)
vec <- c(-2,0,1)
## p(x) = (x^2-2)^16
p1 <- make_poly(vec)
for(i in 1:4) {
  p1 <- mult(p1,p1)
}
## Evaluate p using our methods (observed)
vn <- sapply(x, polyval, p=p1)
vh <- sapply(x, polyhorn, p=p1)

library("polynom")
## Evaluate p using R package (expected)
pr <-as.polynomial(c(-2,0,1))
## p is an R object ! I directly used the power operator.
pr <- pr ** 16
## I also use a generic function
vr <- predict(pr,x)

## Last, visualize the results
cols <- c("red", "gold")
matplot(x, cbind(vn-vr,vh-vr),t="l", lwd=2, lty=1,col=cols, xlab="x",ylab="P(x)-P^R(x)")
legend("topleft", inset=.05, legend=c("Naive", "Horner"), horiz=TRUE, lwd=2, lty=1, col=cols)


true.lambda <- 2.4
true.mu <- .000000005
N0 <- 2
y0 <- statmod::rinvgauss(N0, mean = true.mu, shape = true.lambda)

a_0 <- .9

log(prod(statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda)^a_0) )
a_0* sum(statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda, log = TRUE))
sum(a_0 * statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda, log = TRUE))

logP <- sum(log(y0))
S <- sum(y0)
Sprime <- sum(1/y0)

a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  + (a_0*N0*true.lambda)/true.mu -(a_0*S*true.lambda)/(2*true.mu^2)-(a_0*Sprime*true.lambda)/2
a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  + true.lambda * ( (a_0*N0)/true.mu -(a_0*S)/(2*true.mu^2)-(a_0*Sprime)/2   )
a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  - ( -(a_0*N0)/true.mu +(a_0*S)/(2*true.mu^2) + (a_0*Sprime)/2 ) * true.lambda

-(a_0*N0)/true.mu +(a_0*S)/(2*true.mu^2) + (a_0*Sprime)/2


blockMiss = function(n){
  # n = length of song

  nsections = sqrt(n)	# quick way to determine number of sections in the song

  mix = c(0.3,0.4,0.2,0.1)	# mixture probabilities of difficulty of a section: Easy, Medium ,Hard, Very Hard
  missprop = c(0.01,0.05,0.25,0.5)	# Probability of missing a note for each of the four types of sections

  sectiontype = sample(1:4,nsections,mix,replace=T)	# randomly assign a difficulty to each section with probability from the mix vector

  sectionsize = rmultinom(1,n,rep(1,nsections))[,1]	# randomly allocate section sizes for song using multinomial distribution

  song = numeric(n)

  notes = 0
  for(i in 1:nsections){
    song[(notes+1):(notes + sectionsize[i])] = rbinom(sectionsize[i],1,missprop[sectiontype[i]])
    notes = notes + sectionsize[i]
  }

  return(song)

}

x = matrix(0,200,100)

for(j in 1:100){
	x[,j] = blockMiss(200)
}

write(t(x),"p.varies_block_n200_r100.txt",ncol=200)  # each row in this file is a different simulated song

y = matrix(0,600,100)
for(j in 1:100){
	y[,j] = blockMiss(600)
}

write(t(y),"p.varies_block_n600_r100.txt",ncol=600)  # each row in this file is a different simulated song


# The probability of observing y successes in n trials of a binomial experiment
# number of trials
n<-20
#  let probability of success on a single trial be z
z<-0.85
# probability that 18 or more of the 20 seeds will germinate?
y<-18
probability_for18seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
y<-19
probability_for19seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
y<-20
probability_for20seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
total_probability<-probability_for18seeds+probability_for19seeds+probability_for20seeds
print(total_probability)


#' @name GLMGA
#' @rdname  GLMGA
#' @title The GLMGA distribution
#'
#' @param y vector of quantiles.
#' @param u vector of probabilities.
#' @param sigma parameter of GLMGA distribution.
#' @param a parameter of GLMGA distribution.
#' @param b parameter of GLMGA distribution.
#' @param log logical; if TRUE, probabilities/densities p are returned as log(p).
#' @param n number of observations. If length(n) > 1, the length is taken to be the number required.
#' @importFrom stats runif
#' @importFrom stats pbeta
#' @description Density (\code{dGLMGA}), distribution function (\code{pGLMGA}), quantile function (\code{qGLMGA}) and random generation (\code{rGLMGA}) for the GLMGA distribution with parameters sigma, a and b.
#' @references Zhengxiao Li, Jan Beirlant, Shengwang Meng. Generalizing The Log-Moyal Distribution And Regression Models For Heavy-Tailed Loss Data. ASTIN Bulletin: The Journal of the IAA, 11(1):57-99, 2021.
#' @details
#' The GLMGA distribution with parameters (sigma, a, b) has density
#' \deqn{f(y)=\frac{(2b)^a}{\sigma B(a,\frac{1}{2})}\frac{y^{-(\frac{1}{2\sigma}+1)}}{(y^{-\frac{1}{\sigma}}+2b)^{a + \frac{1}{2}}},}
#' for \eqn{y>0,\sigma>0, a>0, b>0}.
#'
#' The cumulative distribution function \eqn{F(y)} is
#'
#' \deqn{F(y)=1-I_{\frac{1}{2},a}(\frac{y^{-1/\sigma}}{y^{-1/\sigma}+2b}).}
#'
#' Here \eqn{I_{m,n}()} is the beta cumulative distribution function (or regularized incomplete beta function) with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{pbeta}} and defined in its help.
#'
#' The quantile function \eqn{F^{-1}(u)} is
#'
#' \deqn{(2b)^{-\sigma}[\frac{I^{-1}_{\frac{1}{2},a}(1-p)}{1-I^{-1}_{\frac{1}{2},a}(1-p)}]^{-\sigma},}
#' where \eqn{u \in (0,1)}, and \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}}.
#'
#'
#'
#' @return
#' \code{dGLMGA} gives the density, \code{pGLMGA} gives the distribution function, \code{qGLMGA} gives the quantile function, and \code{rGLMGA} generates random deviates.
#'
#' Invalid arguments will result in return value NaN, with a warning.
#'
#' The length of the result is determined by n for rgamma, and is the maximum of the lengths of the numerical arguments for the other functions.
#'
#' The numerical arguments other than n are recycled to the length of the result. Only the first elements of the logical arguments are used.
#'
#'
NULL

#' @rdname  GLMGA
#' @export
#' @examples
#' # density function at value 0.5 and 0.1
#' dGLMGA(c(0.5, 0.1), sigma = 2, a = 2, b = 3, log = FALSE)
dGLMGA <- function(y, sigma, a, b, log = FALSE) {
  if (log == FALSE) {
    exp(-0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b))
  } else if (log == TRUE) {
    -0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b)
  }
}

#' @rdname GLMGA
#' @export
#'
#' @examples
#' # cdf at value 10 and 20.
#' pGLMGA(c(10, 20), sigma = 2, a = 2, b = 3)
pGLMGA <- function(y, sigma, a, b) {
  z <- y^(-1 / sigma) / (y^(-1 / sigma) + 2 * b)
  p <- 1 - pbeta(z, shape1 = 0.5, shape2 = a)
  p
}

#' @rdname GLMGA
#' @export
#'
#' @examples
#' # quantile function at level 50% and 10%
#' qGLMGA(c(0.5, 0.1), sigma = 2, a = 2, b = 3)
qGLMGA <- function(u, sigma, a, b) {
  c <- (2 * b)^(-sigma)
  # I <- pbeta(u, shape1 = 0.5, shape2 = a)
  Iinv <- qbeta(1 - u, shape1 = 0.5, shape2 = a)
  c * (Iinv / (1 - Iinv))^(-sigma)
}

#' @rdname GLMGA
#' @export
#' @examples
#' # simulate 10 samples from GLMGA distribution with parameters (2, 2, 3)
#' rGLMGA(n = 10, sigma = 2, a = 2, b = 3)
rGLMGA <- function(n, sigma, a, b) {
  u <- runif(n, min = 0, max = 1)
  qGLMGA <- Vectorize(qGLMGA)
  r <- qGLMGA(u, sigma = sigma, a = a, b = b)
  r
}

#' #' Sum of vector elements
#' #'
#' #' \code{sum} returns the sum of all the values present in its arguments.
#' #'
#' #' This is a generic function: methods can be defined for it directly
#' #' or via the \code{\link{Summary}} group generic. For this to work properly,
#' #' the arguments \code{...} should be unnamed, and dispatch is on the
#' #' first argument.
#' #'
#' #' @param ... Numeric, complex, or logical vectors.
#' #' @param na.rm A logical scalar. Should missing values (including NaN)
#' #'   be removed?
#' #' @return If all inputs are integer and logical, then the output
#' #'   will be an integer. If integer overflow
#' #'   \url{https://en.wikipedia.org/wiki/Integer_overflow} occurs, the output
#' #'   will be NA with a warning. Otherwise it will be a length-one numeric or
#' #'   complex vector.
#' #'
#' #'   Zero-length vectors have sum 0 by definition. See
#' #'   \url{https://en.wikipedia.org/wiki/Empty_sum} for more details.
#' #' @examples
#' #' sum(1:10)
#' #' sum(1:5, 6:10)
#' #' sum(F, F, F, T, T)
#' #'
#' #' sum(.Machine$integer.max, 1L)
#' #' sum(.Machine$integer.max, 1)
#' #'
#' #' \dontrun{
#' #' sum("a")
#' #' }
#' sum <- function(..., na.rm = TRUE) {}


## Plotting Sierpinski carpet fractal v.2. aev 4/2/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiC2 <- function(ord, fn="", ttl="", clr="brown") {
  m=640; abbr="SCR2"; dftt="Sierpinski carpet fractal v.2";
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  S = matrix(1,1,1);
  for (i in 1:ord) {
    Q = cbind(S,S,S); R = cbind(S,0*S,S); S = rbind(Q,R,Q);
  }
  plotmat(S, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiC2(5);


x <- c(-12, 1, 16)
y <- c(-19, -14, -9, 8)

prob.x <- c(0.35, 0.3, 0.35)

prob.y_x <- c(0.2, 0.33, 0.23, 0.17,
              0.25, 0.25, 0.22, 0.28,
              0.23, 0.25, 0.23, 0.29)

parametro_a <- -0.41
parametro_b <- 0.56
parametro_c <- 0.15
parametro_d <- 0.35

mat.y_x <- matrix(data = prob.y_x, ncol = length(y), nrow = length(x), byrow = TRUE);

prob.xy <- c()

for( i in 1:length(x) ){

  for( j in 1:length(y) ){

    prob.xy <- c(prob.xy, mat.y_x[i,j] * prob.x[i]);

  }

}

mat.xy <- matrix(data = prob.xy, ncol = length(y), nrow = length(x), byrow = TRUE);

prob.y <- c(sum(mat.xy[1:3,1]),sum(mat.xy[1:3,2]),sum(mat.xy[1:3,3]),sum(mat.xy[1:3,4]))

e.x <- sum(x*prob.x)
e.y <- sum(y*prob.y)

e.xy <- c()
for(i in 1:length(x)) {
  for(j in 1:length(y)) {
    e.xy <- c(e.xy, mat.xy[i,j]*x[i]*y[j])
  }
}
e.xy <- sum(e.xy)
cov <- e.xy - e.x*e.y

cov2 <- cov*parametro_a*parametro_c

var.x <- sum(x^2*prob.x)-e.x^2
var.y <- sum(y^2*prob.y)-e.y^2

ro <- cov/sqrt(var.x*var.y)

sgn.ac <- parametro_a*parametro_c/abs(parametro_a*parametro_c)

cat("X\n")
print(x)
print(prob.x)
cat("\nY\n")
print(y)
print(prob.y)
cat("\nCongiunta\n")
print(mat.xy)
cat("\nE(XY)\n")
print(e.xy)
cat("\nE(X)\n")
print(e.x)
cat("\nE(Y)\n")
print(e.y)
cat("\nCovarianza\n")
print(cov)
cat("\nCovarianza della combinazione lineare\n")
print(cov2)
cat("\nVar(X)\n")
print(var.x)
cat("\nVar(Y)\n")
print(var.y)
cat("\nRo\n")
print(ro)
cat("\nRo della comb. lineare\n")
print(sgn.ac*ro)


=begin
  # sample-factorize01.rb

  require "algebra"

  P = Polynomial(Integer, "x")
  x = P.var
  f = 8*x**7 - 20*x**6 + 6*x**5 - 11*x**4 + 44*x**3 - 9*x**2 - 27
  p f.factorize #=> (2x - 3)^3(x^2 + x + 1)^2
((<_|CONTENTS>))
=end


library(stats)

create_model <- function(input,resp,name) {
    fit <- nls(resp~exp(a+b*input),start = list(a=log(20),b=-0.001))
    B <- coef(fit)
    n <- length(input)
    d <- 2

    pred <- function(x) {
        #Generate predictions
        return(exp(B["a"]+B["b"]*x))
    }
    sig.est = sqrt(sum((resp-pred(input))^2)/(n-d))

    #Linearize model for confidence and prediction
    #f(x|B) ~ f(x|B_hat) + gradient(f(x|B_hat)*(B - B_hat)
    #y~f(x|B)+e  <=> g = gradient()(a,b)
    #                z = y - g + g*B
    mdiv <- deriv(y~exp(a+b*x),c("a","b"),function(a,b,x){})
    G <- mdiv(a=B["a"],b=B["b"],input)
    G <- attr(G,"gradient")
    z <- resp - pred(input) + G%*%B

    #Find linear standard error
    var.lin <- ((sig.est^2)*solve(t(G)%*%G))
    se.lin <- sqrt(diag(var.lin))

    #Model parameters of lineraized version can be treated
    #linearly

    #Confidence of parameters
    level <- 0.95
    alpha <- 1-level
    B.ci <- cbind(B + qt(alpha/2,n-d)*se.lin, B + qt(1-alpha/2,n-d)*se.lin)
    row.names(B.ci) <- names(B)
    colnames(B.ci) <- c(paste0((1-level)/2*100,"%"),paste0((1+level)/2 * 100,"%"))

    #Confidence
    input.new <- seq(0,100,1)
    pred.input.new <- pred(input.new)
    grad2 <- mdiv(a=B["a"],b=B["b"],input.new)
    G2 <- attr(grad2,"gradient")
    GS <- rowSums((G2%*%vcov(fit))*G2)
    delta <- sqrt(GS)*qt(1-alpha/2, n-d)
    df.delta <- data.frame(odometer=input.new,price = pred.input.new,
                            lwr.conf = pred.input.new-delta,upr.conf = pred.input.new+delta)

    #Prediction
    sig2.est <- summary(fit)$sigma
    pred.delta <- sqrt(GS + sig2.est^2)*qt(1-alpha/2,n-d)
    df.delta[c("lwr.pred","upr.pred")] <- cbind(pred.input.new - pred.delta,
                                                 pred.input.new + pred.delta)
    input.df <- data.frame(odometer=input,price=resp)

    #Create plot
    p = ggplot(data = df.delta,aes(x=odometer,y=price))+geom_point(data=input.df)+
                geom_line(size = 1.5,col="green")+
                geom_ribbon(aes(ymin = lwr.conf,ymax = upr.conf,color="95% Confidence"),alpha = 0.2,fill = "green")+
                geom_ribbon(aes(ymin = lwr.pred,ymax = upr.pred,color="95% Prediction"),alpha = 0.2,fill = "blue") +
                scale_colour_manual(name="",values=c("95% Confidence"="green","95% Prediction"="blue"))+
                labs(title = paste(name, "prediction plot"))

    return(list(fit = fit,B.conf = B.ci, pred = df.delta,df = input.df,plot = p))
}


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

## Check residual plots for patterns
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
plot(model.ibm$fitted, res.ibm)  # plot residuals vs fitted values
plot(bigdataset$date, res.ibm)  # plot residuals versus date

## Test for Autocorrelations
library{lmtest}
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
dwtest(res.ibm ~ 1)

## Test for Cross-Correlations
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
model.aapl <- lm(logret.aapl ~ logret.factor1, data=bigdataset)
res.aapl <- residuals(model.aapl)
# Compute Pearson and Fisher tests
cor.test(res.ibm, res.aapl, method="pearson")

## Check for Influential Points
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.student.ibm <- rstudent(model.ibm)
plot(res.student.ibm)

cooks.distances.ibm <- cooks.distance(model.ibm)
plot(cooks.distances.ibm)

# Compute Pena's sensitivities
p <- length(coef(model.ibm))
Q <- qr.Q(model.ibm$qr)  # the Q of the QR decomposition
H <- Q %*% t(Q)  # the hat matrix
h <- diag(H)
S <- H^2 %*% rstudent(model.ibm)^2/(p*h*(1-h))

## Check for Multicollinearity
cor.coeff <- cov2cor(vcov(model.ibm))
cor.coeff                     # coefficient correlation matrix
eigen(cor.coeff)              # compute eigenvectors, eigenvalues
det(cor.coeff)                # determinant
kappa(cor.coeff, exact=TRUE)  # condition number


# Multiple solution for Fizzbuzz in R
# Author - pranavanand24

# 1) A Better Solution Using a For Loop

fbnums <- 1:50
output <- vector()

for (i in fbnums) {
  output[i] <- ""

  if (i %% 3 == 0) {output[i] <- paste0(output[i], "Fizz")}
  if (i %% 5 == 0) {output[i] <- paste0(output[i], "Buzz")}
  if (output[i] == "") {output[i] <- i}
}

print(output)

# 2) A Functional Solution Using map()

library(tidyverse)

fbnums <- 1:50

fbmap <- function(input, mod1, mod2, exp1, exp2) {
  output <- ""

  if (input %% mod1 == 0) {output <- paste0(output, exp1)}
  if (input %% mod2 == 0) {output <- paste0(output, exp2)}
  if (output == "") {output <- as.character(input)}

  return(output)
}

output <- map_chr(fbnums, ~ fbmap(.x, 3, 5, "Fizz", "Buzz"))
print(output)

# 3) A Package Solution Using FizzBuzzR

install.packages("fizzbuzzR")

library(fizzbuzzR)

fizzbuzz(start = 1, end = 50, step = 1, mod1 = 3, mod2 = 5)


# PLAYING WITH VECTORS

n       <- c( 1, 2, 3, 4, 5, 6, 7,  8,  9, 10, 11 )
vec     <- c( 1, 2, 3, 4, 5, 6, 5,  4,  3,  2, 1  )
vec2    <- c( 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55 )
vec3    <- rev(vec2)
p_cols  <- c( "blue" , "red" , "orange" , "green" )
yrange  <- range( 0 , vec , vec2 , vec3 )

vecs <- data.frame(n,vec,vec2,vec3)

# R starts at one, not zero
nn <- vecs([[1]])

plot (
    vec3 ,
    col=p_cols[1] ,
    type="l" ,
    xlab="X" ,
    ylab="Y" ,
    ylim=yrange
    )

plot (
    vec2 ,
    col=p_cols[1] ,
    type="b" ,
    xlab="X" ,
    ylab="Y" ,
    ylim=yrange
    )

plot (
    vec ,
    col=p_cols[1] ,
    type="p" ,
    xlab="X" ,
    ylab="Y" ,
    ylim=yrange
    )
lines(
    vec2 ,
    col=p_cols[2] ,
    type="p"
    )
lines(
    vec3 ,
    col=p_cols[3] ,
    type="p"
    )

# PLAYING WITH DATA FRAMES

i <- c(1 ,2 ,3 ,4 ,5 ,6 ,7 ,8 ,9 ,10 ,11 ,12 ,13 ,14 ,15 ,16 ,17 ,18 ,19 ,20 )
f <- c(0 , 1 , 1 , 2 , 3 , 5 , 8 , 13 , 21 , 34 , 55 , 89 , 144 , 233 , 377 , 610 , 987 , 1597 , 2584 , 4181)

fib <- data.frame( i,f)
head(fib)
colnames(fib) <- c('index','fibonacci')
head(fib)

# p = points
# l = lines
# b = both

plot(fib, type='p')
plot(fib, type='l')
plot(fib, type='b')

# after ggplot2
library('ggplot2')
ggplot( fib , aes( x=index,y=fibonacci ) )+geom_bar(stat="identity")
ggplot( fib , aes( x=index,y=fibonacci ) )+geom_line()


data()
data("Orange")
head(Orange)
install.packages('mlbench')
library("mlbench")
data('Seatbelts')

is.data.frame(Seatbelts)
df <- data.frame(Seatbelts)
df
is.data.frame(df)
head(df)
names(df)
View(df)
nrow(df)
ncol(df)
colnames(df)
row.names(df)
state.division(df)
summary(df)
str(df)
rowSums(is.na(df))
mean(Seatbelts)
mean(Seatbelts[1])
mean(df[,1])
median(df[,3])
median(df[1,])
min(df$DriversKilled)
max(df$VanKilled)
hist(df, x = DriversKilled)
hist(df$drivers)
hsit(df$PetrolPrice)
hist(df$PetrolPrice)
hist(df$DriversKilled , xlab = 'DriversKilled', ylab ='freq', col ='red')
plot(x= df$drivers ,y= df$kms , type = "l")
plot(x= df$drivers ,y= df$kms , type = "b")
plot(x= df$drivers ,y= df$kms , type = "p")

bx <- boxplot(y = df$law, x = df$kms)
 set.seed(124)
nrow(df)

trainingIndex <- sample(1:nrow(df),size =0.75*nrow(df))
length(trainingIndex)
trainingset <- df[trainingIndex,]
testingset<- df[-trainingIndex,]
paste("TrainingSize :" , nrow(trainingset),"TestingSize :" ,nrow(testingset))

#### linear Regression Model#######
names(df)
model_fit <- lm(formula = DriversKilled ~.,
                data = trainingset)

y_predict <- predict(model_fit,testingset[-1])
testingset[1]
summary(model_fit)
plot(model_fit$residuals)
model_fit$coefficients

predict_and_real_y <-data.frame(cbind(Actual_y = testingset[1] , Predicted_y = y_predict))
cor(predict_and_real_y)

anova(model_fit)
summary(y_predict)

###Decision Tree Regression###
data(cars)
df<-as.data.frame(cars)
is.data.frame(cars)
head(df)
tail(df)
dim(df)
str(df)
summary(df)
hist(df$speed , col = 'red')
hist(df$dist,col='blue')
plot( x= df$speed, y= df$dist , type = 'p' )
plot(x=df$speed,y=df$dist, type = 'l')

set.seed(20)
nrow(df)
trainingIndex <- sample(1 : nrow(df), size = 0.70 * nrow(df))
trainingIndex

length(trainingIndex)
 trainingset <- df[trainingIndex,]
testingset<-df[-trainingIndex,]

library(rpart)

model_fit<-rpart(formula = speed~.,data =trainingset,
                 control = rpart.control(minsplit = 2))

summary(model_fit)

y_predict<-predict(model_fit,testingset[-1])

predict_and_real_y <- data.frame(cbind(Actual_y = testingset , Predicted_y =y_predict))
cor(predict_and_real_y)

plot(model_fit)
text(model_fit)

install.packages("randomForest")
library(randomForest)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(EQL)

# calculate moments to pass to Edgeworth expansion
mean.obs <- mean(x.obs)
var.obs <- var(x.obs)
skew.obs <- skewness(x.obs, method="moment")*n.obs/(n.obs-2)
exkurt.obs <- kurtosis(x.obs, method="moment")*n.obs/(n.obs-3)-3

# create the Edgeworth expansion. Since we have moments, we
# do this for a "sum" with 1 term.
edge.expand <- edgeworth(x, 1, rho3=skew.obs, rho4=exkurt.obs,
                         mu=mean.obs, sigma2=var.obs, type="sum")

# without EQL, we would have to do this:
dedge <- function(x) {
    z <- (x-mean.obs)/sqrt(var.obs)
    dnorm(z)*(1 + skew.obs*(z^3-3*z)/6 + exkurt.obs*(z^4-6*z^2+3)/24
              + skew.obs^2*(z^6-15*z^4+45*z^2-15)/72)/sqrt(var.obs)
}


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

rm(list = ls())

observed <- c(6, 18, 32, 35, 17, 10, 2)

(k <- length(observed))
# 7

(n <- sum(observed))
# 120

LogLikelihood <- function(lamdba, y, k) {
  (sum(y[1:(k - 1)] * dpois(0:(k - 2), lambda = lamdba, log = TRUE)) +
    y[k] * ppois(k - 2, lambda = lamdba, log = TRUE, lower.tail = FALSE))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(1, NegativeLogLikelihood, lower = 10e-4, y = observed, k = k,
             method = "L-BFGS-B")

(lambda.hat <- opt$par)
# 2.65019719097978

(expected <- n * c(dpois(0:(k - 2), lambda = lambda.hat),
                   1 - ppois(k - 1, lambda = lambda.hat)))
# 8.47647391824289 22.4643273675407 29.7674486433533 26.2965362590832 ...

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

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


# Simulation of sampling the artificial population
library(maptools)
pop.data <- readShapePoints("Created\\Set42pop")

pop.mean <- mean(pop.data$Yield)
pop.sd <- sd(pop.data$Yield)

# From Sec. 5.2.1
W <- bbox(pop.data)[1,1]
E <- bbox(pop.data)[1,2]
S <- bbox(pop.data)[2,1]
N <- bbox(pop.data)[2,2]
N <- N + 2.5
S <- S - 2.5
E <- E + 2.5
W <- W - 2.5
coords.mat <- matrix(c(W,E,E,W,W,N,N,S,S,N), ncol = 2)
library(maptools)
sampbdry.vec <- vector(mode="list", length=1)
sampbdry.vec[[1]] <- Polygons(list(Polygon(coords.mat)), ID="1")
sampbdry.sp <- SpatialPolygons(sampbdry.vec,
   proj4string = CRS("+proj=utm +zone=10 +ellps=WGS84"))

# Random sample
set.seed(123)
spsamp.pts <- spsample(sampbdry.sp, 32, type = "random")
# Plot the sample points
par(mai = c(1,1,1,1))
plot(sampbdry.sp, axes = TRUE) # Fig. 5.4
plot(spsamp.pts, add = TRUE, pch = 19, cex = 0.8)
title(main = "Random Sampling", xlab = "Easting",
  ylab = "Northing", cex.main = 2, cex.lab = 1.5,
  font.lab = 2)

# Determine the member of the population closest to a sample point
closest.point <- function(sample.pt, grid.data){
   dist.sq <- (coordinates(grid.data)[,1] - sample.pt[1])^2 +
      (coordinates(grid.data)[,2] - sample.pt[2])^2
   return(which.min(dist.sq))
}

# Monte Carlo simulation of random sampling
rand.samp <- function (samp.size){
# Create the locations of the random sample
   spsamp.pts <- spsample(sampbdry.sp, samp.size, type = "random")
# Extract a two column array of the x and y coords
   sample.coords <- coordinates(spsamp.pts)
# Apply the function closest.point() to each row of the
# array sample.coords (i.e., each sample location)
   samp.pts <- apply(sample.coords, 1, closest.point,
      grid.data = pop.data)
# Each element of samp.pts is the index of the population value
# closest to the corresponding location in sample.coords
   data.samp <- pop.data[samp.pts,]
   samp.mean <- mean(data.samp$Yield)
   prct.err <- abs(samp.mean - pop.mean) / pop.mean
   return(c(samp.mean,prct.err))
}

samp.size <- 32
set.seed(123)
U <- replicate(1000,rand.samp(samp.size))
print(mean(U[2,]), 3) # Equation (5.1)
print(sd(U[1,]), 4)

hist(U[1,])


print ("first task")

a <- c(-5, 1, 6, -3, 2, -2, 5, 2, 0, -6, 2, 1, 0, -2, -3, 1)
b <- c(3, -2, 6, -4, -7, 8, -1, 0, 9, -2, 8, 9, -2, 1, 0, -1)
p <- c ( -8, 4, -2, 8, 0, 3, -5, 3, 2, -3, -4, 5, 9, 1, -3, 0)
fir <- ((5)*a)-(6*b)
print ("first answer")
fir
sec <- ((5)*as.numeric(a%*%p))*b+3*(norm(p, type="2"))*b
print ("second answer")
sec
thr <- (-2)*(norm(p, type="2"))*p+5*as.numeric(a%*%p)*a+3*as.numeric(b%*%p)*b
print ("third answer")
thr

2 задание

print ("second task")
mat <- rbind(c(-4,3,0,-10,8,0,0,0),c(12,-5,0,-1,8,0,0,0),c(-1,6,0,2,8,0,0,0),c(7,0,12,0,0,1,0,-3),c(-7,0,0,0,0,-1,-4,3),c(0,0,0,-3,-8,0,1,-2),c(0,0,0,8,-1,0,-4,-2),c(0,0,0,-6,2,0,-9,1))
rua <- c(34,44,-6,-44,-4,-61,-13,50)
X <- solve(mat)%*%rua
print ("Answer for the sec task")
X
mat%*%X
rua

4 задание

print ("fourth task")
A <- rbind(c(19, 0, 0, 0, 0 ,0 ,0 ,20),c(0, 7 ,0 ,0 ,7 ,0 ,0 ,0),c(0, 0, 13, 0, 0, 0, 0, 0),c(0 ,0 ,0 ,11, 0, 0, 0, 0),c(0 ,7 ,0 ,0, 17, 0, 0 ,0),c(0, 0, 0, 0, 0 ,5, 0, 0),c(0, 0, 0, 0, 0, 0, 3 ,0),c(0, 0, 0, 0, 0, 0, 0, 1))
A
options(digits=3) # Задать количество значащих цифр для вывода
print ("собственные числа ")
d <- eigen(A)$values; d # Собственные значения матрицы A
print ("собственные вектора")
P <- eigen(A)$vectors; P # Собственные векторы A, стоящие в столбцах матрицы
P
print (" Проверим ортогональность полученного собственного базиса ")
sum(P[,1]^2) # Например, длина первого собственного вектора
P[,1] %*% P[,2] # Например, скалярное произведение (f1, f2)
sum(P[,2]^2); P[,2] %*% P[,3] # длина 2 собственного вектора и (f2, f3)
sum(P[,3]^2); P[,3] %*% P[,4] # длина 3 собственного вектора и (f3, f4)
sum(P[,4]^2); P[,4] %*% P[,5] # длина 4 собственного вектора и (f4, f5)
sum(P[,5]^2); P[,5] %*% P[,6] # длина 5 собственного вектора и (f5, f6)
sum(P[,6]^2); P[,6] %*% P[,7] # длина 6 собственного вектора и (f6, f7)
sum(P[,7]^2); P[,7] %*% P[,8] # длина 7 собственного вектора и (f7, f8)
sum(P[,8]^2); P[,8] %*% P[,1] # длина 8 собственного вектора и (f8, f1)
print ("Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.
Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.")

6 задание

print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "min")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(-6, 2)) # Задаем целевую функцию: f = 5*X1 +3*X2 для модели М
add.constraint(M, c(5,7), ">=", 35) # Задаем ограничение:
add.constraint(M, c(-3, 9/2), ">=", -27/2) # Аналогично
add.constraint(M, c(1, -3), ">=", -12) # Аналогично
add.constraint(M, c(1, 0), "<=", 8) # Аналогично
rownames(M) <- c("A", "B", "C", "D") # Называем ограничения в модели М
M
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M)
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max


.overall_f_statistics <- function(X, y){
    n <- dim(X)[1]
    k <- dim(X)[2]
    intercept <- matrix(rep(1, length(y)), ncol=1)
    intecept_only_residual.2 <- sum(residual(intercept, y)^2)
    regression_residual.2 <- sum(residual(X, y)^2)
    f_stat <- (n-k)/k * (intecept_only_residual.2 - regression_residual.2)/regression_residual.2
    return(f_stat)
}

#' @export
overall_significance_f_test <- function(X, y){
    n <- dim(X)[1]
    k <- dim(X)[2]
    f_stat <- .overall_f_statistics(X, y)

    return(TestResult(test_name = "Overall Significant F Test",
                      H0_description = "All coefficients (except intercept) equal 0: β1 = β2 = ... = βk = 0",
                      test_statistic = f_stat,
                      distribution = "f",
                      df1 = k,
                      df2 = n-k))
}


#Example : 2.3b    Chapter : 2.3   Pageno  : 61
#Multiplication with Elimination and Permutation matricies
Ab<-matrix(c(1,4,0,2,8,3,2,9,2,1,3,1),ncol=4)
E21<-matrix(c(1,0,0,-4,1,0,0,0,1),ncol=3,byrow=T)
P32<-matrix(c(1,0,0,0,0,1,0,1,0),ncol=3,byrow=T)
E21Ab<-E21%*%Ab
print(E21Ab)
P32E21Ab<-P32%*%E21Ab
print(P32E21Ab)
P32E21<-P32%*%E21
print(P32E21)
P32E21Ab<-P32E21%*%Ab
print(P32E21Ab)
#Solution for this system is
b<-P32E21Ab[,4]
P32E21Ab<-P32E21Ab[,-4]
x<-solve(P32E21Ab,b)
print(x)


data("PlantGrowth")
# Results compairing yeilds of plants grown under 2 different conditions
# variables weight and group (explanitory variable) assigned (treatment 1, treatment 2)

head(PlantGrowth)

boxplot(weight ~ group, data=PlantGrowth)

# assume each group has same modeling

lmod = lm(weight ~ group, data=PlantGrowth)
summary(lmod) # intercept refers to control group, next 2 params give modification to mean of control group to give groups 1 and 2

anova(lmod) # anova table, give analysis of variance table. Results of statistical test for each factor variabe show how it contributes to the varability in the data. Variability between and within factors, large ratio then factor vartiable does contribute

# Baysien model

library("rjags")

mod1_string = " model {
    for (i in 1:length(y)) {
        y[i] ~ dnorm(mu[grp[i]], prec)
    }

    for (j in 1:3) {
        mu[j] ~ dnorm(0.0, 1.0/1.0e6)
    }

    prec ~ dgamma(5/2.0, 5*1.0/2.0)
    sig = sqrt( 1.0 / prec )

} "

mod2_string = " model {
    for (i in 1:length(y)) {
        y[i] ~ dnorm(mu[grp[i]], prec[grp[i]])
    }

    for (j in 1:3) {
        mu[j] ~ dnorm(0.0, 1.0/1.0e6)
        prec[j] ~ dgamma(5/2.0, 5*1.0/2.0)
        sig[j] = sqrt( 1.0 / prec[j])
    }

} "

set.seed(82)
str(PlantGrowth)
data_jags = list(y=PlantGrowth$weight,
              grp=as.numeric(PlantGrowth$group))

params = c("mu", "sig")

inits = function() {
    inits = list("mu"=rnorm(3,0.0,100.0), "prec"=rgamma(1,1.0,1.0))
}

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

mod2 = jags.model(textConnection(mod2_string), data=data_jags, inits=inits, n.chains=3)
update(mod2, 1e3)

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

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

HPDinterval(mod1_csim)

HPDinterval(mod2_csim)

dic1 = dic.samples(mod1,n.iter=5e3)
dic2 = dic.samples(mod2,n.iter=5e3)

dic1-dic2


# create time series with trends ==============================================================

time.series.length <- 50

# trends
trend.1 <- 10 + seq(1:time.series.length) / time.series.length
trend.2 <- 8 + seq(1:time.series.length) / (time.series.length / 3)
plot(trend.1, trend.2)

# noisy data
time.series.1 <- trend.1 + rnorm(n = time.series.length, mean = 0, sd = .2)
time.series.2 <- trend.2 + rnorm(n = time.series.length, mean = 0, sd = .35)
plot(time.series.1, time.series.2)

# run somes statistical tests / analyses ===========================================================

# calculate correlation
cor.test(time.series.1, time.series.2)

# store lm outputs in object and use summary
lm.results <- lm(time.series.2 ~ time.series.1)
summary(lm.results)

plot(time.series.1, time.series.2)

# use lm parameters to draw regression line on plot
curve(lm.results$coefficients[1] + lm.results$coefficients[2] * x,
      lwd = 2, col = 'blue', add = T)


#Data

x1 <- 4
x2 <- 9
x3 <- 10

expected <- 8.609
variance <- 3.869

#install.packages("pracma", repos="http://R-Forge.R-project.org")
library(pracma)

data <- c(x1,x2,x3)

momento <- function(x, y, r, centrato = FALSE) {
  res <- 0

  if(length(x) != length(y) || r < 0 || r %% 1 != 0 ) {
    res <- NaN
  }

  if(centrato == FALSE) {
    for(i in 1:length(x)) {
      res <- res + x[i]^r*y[i]
    }
  } else {
    res <- ifelse(r == 1, 0,
             ifelse(r == 2, momento(x, y, 2)-(momento(x, y, 1)^2),
               ifelse(r == 3, momento(x, y, 3) - momento(x, y, 1)^3 -
                              3*momento(x, y, 1)*momento(x, y, 2, centrato = TRUE),
                  res <- NaN)))
  }
  return(res)
}

mat_original <- matrix(c(data[1], data[2], data[3], expected,
                       data[1]^2, data[2]^2, data[3]^2, variance+expected^2,
                       1, 1, 1, 1), byrow = TRUE, nrow = 3, ncol = 4)

mat <- rref(mat_original)
prob <- c(mat[10],mat[11],mat[12])

print(matrix(c(data[1], data[2], data[3], prob[1], prob[2], prob[3]),
             byrow = TRUE, nrow = 2, ncol = 3))

mnnoncentrato3 <- momento(data, prob, 3)
mncentrato3 <- momento(data, prob, 3, centrato = TRUE)

print(mnnoncentrato3)
print(mncentrato3)


#install.packages("dplyr")
#install.packages("data.table")
#install.packages("ggplot2")
#install.packages("corrplot")
#install.packages("scales")

library(data.table)
library(dplyr)
library(ggplot2)
library(corrplot)

train <- read.csv("housing_data.csv")
head(train)

# Data  Checks:

dim(train)
str(train)

# Check the NA's
missing <- sort(sapply(train ,function(x) sum(is.na(x))  ) , decreasing = T)
missing[missing>0]

cat("There are" , length(missing[missing>0]) , "variables with missing values")

# Let us check the response variable :

options( scipen =999)
# Plot of the sales:
ggplot(data=train[!is.na(train$SalePrice),] ,  aes(x=SalePrice )) +
  geom_histogram(fill="blue" ,binwidth = 10000) +
  xlim(c(0, 800000)) +
  labs(x="Sale Price")

# Numerical verses the character variables :

num_vars <- names(which(sapply(train , is.numeric)))
num_vars <-num_vars[-c(1,36,37)]   # Remove the id variable

#Let us plot the correlation between these variables:

all_numVar <- train[, num_vars] # Only take the numerical variables

head(all_numVar)
str(all_numVar)

cor_numVar <- cor(all_numVar, use="pairwise.complete.obs") #correlations of train numeric variables

corrplot.mixed(cor_numVar , tl.col="black", tl.pos = "lt")

#sort on decreasing correlations with SalePrice
cor_sorted <- as.matrix(sort(cor_numVar[,'SalePrice'], decreasing = TRUE))
#select only high corelations
CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5)))
cor_numVar <- cor_numVar[CorHigh, CorHigh]

corrplot.mixed(cor_numVar , tl.col="black", tl.pos = "lt")

# Relationship between Sales Price and Overall Quality:
attach(train)
ggplot( data = train , aes(x = as.factor(OverallQual) , y= SalePrice)) +
  geom_boxplot() +
  labs(x = "Quality" , y="Sales Price")

# Garage area and the sales price relationship
names(train[, num_vars])
ggplot(train , aes(x =GrLivArea , y= SalePrice)) +
  geom_point( ) + geom_smooth() +
  labs(x = "GrLivArea" , y="Sales Price")

ggplot(train , aes(x =GrLivArea , y= SalePrice , color= OverallQual)) +
  geom_point( ) + theme_bw()

detach(train)

# Treating missing values:

round(missing[missing>0]/1460,2) # Proportion of missing variables:
head(train$PoolArea)

##This should be done on individual basis.

## Example: LotFrontage

## A good method of imputation here could be imputing with median lot frontage
## per neighorhood.

ggplot( train , aes(x = as.factor(Neighborhood) , y=LotFrontage) ) +
  geom_bar(stat='summary' ,  fun.y = "median") +
  theme(axis.text.x =  element_text(angle = 90)) +
  scale_x_discrete(name="Neighorhood")


library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 4) # Change plot sizes (in cm) - this bit of code is only relevant if you are using a juyter notebook - ignore otherwise

par(mfrow=c(1,2))
hist(rpois(1000, lambda = 1),xlab = "Value", main="")
hist(rpois(1000, lambda = 100),xlab = "Value", main="")

par(mfrow=c(1,2))
hist(rbinom(1000, 1, 0.5),xlab = "Value", main="")
hist(rbinom(1000, 100, 0.5),xlab = "Value", main="")

par(mfrow=c(1,2))
hist(rgamma(1000,1,1),xlab = "Value", main = "")
hist(rgamma(1000,100,1),xlab = "Value", main = "")

colonies <- read.csv("../data/PracData.csv", stringsAsFactors = T)
str(colonies)
head(colonies)

boxplot(ColonyCount ~ Treatment, data=colonies)

colonies$logCC <- log(colonies$ColonyCount + 1)
boxplot(logCC ~ Treatment, data=colonies)

tapply(colonies$ColonyCount, colonies$Treatment, min, na.rm = TRUE)

tapply(colonies$ColonyCount, colonies$Treatment, max, na.rm = TRUE)

MyData1 <- rep(c("Control", "NG", "NG"), 4)
MyData1

MyData1 %in% c("Control", "NG")

 MyData1 == "Control" |  MyData1 == "NG"

MyData1 == c("Control", "NG")

coloniesCN <- subset(colonies, Treatment %in% c("Control", "NG"))
str(colonies)

coloniesCN <- subset(colonies, Treatment == "Control" | Treatment == "NG")
str(coloniesCN)

coloniesCN <- droplevels(coloniesCN)
str(coloniesCN)

library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 4) # Change plot size

library(ggplot2)
ggplot(coloniesCN, aes(x = Strain, y= logCC)) +
    geom_boxplot() + facet_grid(. ~ Treatment)

tab <- tapply(coloniesCN$ColonyCount, list(coloniesCN$Treatment, coloniesCN$Strain), mean, na.rm=TRUE)

print(tab)

barplot(tab, beside=TRUE, log= 'y' )

library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 6) # Change plot size

modLM <- lm(logCC ~ Strain * Treatment, data=coloniesCN)
par(mfrow=c(2,2), mar=c(3,3,3,1), mgp=c(2,0.8,0))
plot(modLM)

modPois <- glm(ColonyCount ~ Strain * Treatment, data=coloniesCN, family= 'poisson')

summary(modPois)

par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(2, 0.8, 0))
plot(modPois)

modQPois <- glm(ColonyCount ~ Strain * Treatment, data = coloniesCN, family = 'quasipoisson')

summary(modQPois)

par(mfrow = c(2, 2), mar = c(3, 3, 3, 1), mgp = c(2, 0.8, 0))
plot(modQPois)

anova(modQPois, test = "F")

drop.scope(modQPois)

modQPois2 <- update(modQPois, . ~ . - Strain:Treatment)
anova(modQPois, modQPois2, test = "F")

# use expand.grid to get all combinations of factors
df <- expand.grid(Strain = levels(coloniesCN$Strain), Treatment = levels(coloniesCN$Treatment))

predict(modQPois, newdata = df, type = "response")

table(Halo = colonies$HaloLawn, Strain = colonies$Strain, Treatment =  colonies$Treatment)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__, |___|___|
#==============================================================================
# Nonparametric Smoothing in Regression
#==============================================================================
# Title          : Nonparametric_regression_kernel.r
# Description    : Nonparametric regression using kernel weights.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20170604
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : Reference
#                  http://www.stat.cmu.edu/~cshalizi/uADA/12/lectures/ch04.pdf
# R version      : 3.4
#==============================================================================

# Using Nonparametric Smoothing in Regression
x = runif(300, 0, 3)
yf = sin(x)*cos(20*x) + rnorm(length(x), 0, 0.15)
yg = log(x + 1) + rnorm(length(x), 0, 0.15)
par(mfcol=c(2, 1))
plot(x, yf, xlab="x", ylab=expression(f(x) + epsilon))
curve(sin(x)*cos(20*x), col="grey", add=TRUE)
plot(x, yg, xlab="x", ylab=expression(g(x) + eta))
curve(log(x + 1), col="grey", add=TRUE)

# Selecting a region
windows()
par(mfcol=c(2,1))
colors=ifelse((x<1.7)&(x>1.5),"black","grey")
plot(x,yf,xlab="x",ylab=expression(f(x)+epsilon),col=colors)
curve(sin(x)*cos(20*x),col="grey",add=TRUE)
points(1.6,mean(yf[(x<1.7)&(x>1.5)]),pch="*",cex=2)
plot(x,yg,xlab="x",ylab=expression(g(x)+eta),col=colors)
curve(log(x+1),col="grey",add=TRUE)
points(1.6,mean(yg[(x<1.7)&(x>1.5)]),pch="*",cex=2)

#
loc_ave_err <- function(h,y,y0) {abs(y0-mean(y[(1.6-h < x) & (1.6+h>x)]))}
yf0=sin(1.6)*cos(20*1.6)
yg0=log(1+1.6)
f.LAE = sapply(0:100/100,loc_ave_err,y=yf,y0=yf0)
g.LAE = sapply(0:100/100,loc_ave_err,y=yg,y0=yg0)
plot(0:100/100,f.LAE,xlab="Radius of averaging window",
ylab="Absolute value of error",type="l")
lines(0:100/100,g.LAE,lty=2)
abline(h=0.15,col="grey")

# Cross-validation for univariate kernel regression
cv_bws_npreg <- function(x,y,bandwidths=(1:50)/50, num.folds=10) {
	require(np)
	n <- length(x)
	stopifnot(n> 1, length(y) == n)
	stopifnot(length(bandwidths) > 1)
	stopifnot(num.folds > 0, num.folds==trunc(num.folds))
	fold_MSEs <- matrix(0,nrow=num.folds,
	ncol=length(bandwidths))
	colnames(fold_MSEs) = bandwidths
	case.folds <- rep(1:num.folds,length.out=n)
	case.folds <- sample(case.folds)
	for (fold in 1:num.folds) {
		train.rows = which(case.folds==fold)
		x.train = x[train.rows]
		y.train = y[train.rows]
		x.test = x[-train.rows]
		y.test = y[-train.rows]
		for (bw in bandwidths) {
			fit <- npreg(txdat=x.train,tydat=y.train,
			exdat=x.test,eydat=y.test,bws=bw)
			fold_MSEs[fold,paste(bw)] <- fit$MSE
		}
	}
	CV_MSEs = colMeans(fold_MSEs)
	best.bw = bandwidths[which.min(CV_MSEs)]
	return(list(best.bw=best.bw, CV_MSEs=CV_MSEs, fold_MSEs=fold_MSEs))
}

fbws <- cv_bws_npreg(x,yf,bandwidths=(1:100)/200)
gbws <- cv_bws_npreg(x,yg,bandwidths=(1:100)/200)
plot(1:100/200,sqrt(fbws$CV_MSEs),xlab="Bandwidth", ylab="Root CV MSE",type="l",ylim=c(0,0.6))
lines(1:100/200,sqrt(gbws$CV_MSEs),lty=2)
abline(h=0.15,col="grey")

x.ord = order(x)
par(mfcol = c(2, 1))
plot(x, yf, xlab = "x", ylab = expression(f(x)+epsilon))
fhat <- npreg(bws = fbws$best.bw, txdat = x, tydat = yf)
lines(x[x.ord], fitted(fhat)[x.ord], lwd = 4)
curve(sin(x)*cos(20*x), col = "grey", add = TRUE, lwd = 2)
plot(x, yg, xlab = "x", ylab = expression(g(x)+eta))
ghat <- npreg(bws = fbws$best.bw, txdat = x, tydat = yg)
lines(x[x.ord], fitted(ghat)[x.ord], lwd = 4)
curve(log(x+1), col = "grey", add = TRUE, lwd = 2)

# Gaussian kernel regression of the points
noise.np <- npreg(y~x1+x2,data=noise)
y.out <- matrix(0,100,100)
y.out <- predict(noise.np,newdata=x12grid)
wireframe(y.out~x12grid$x1*x12grid$x2,scales=list(arrows=FALSE),xlab=expression(x^1),ylab=expression(x^2),zlab="y")

# Average Predictive Comparisons
new.frame <- data.frame(x=seq(-3,3,length.out=300),y=median(y.noise))
plot(new.frame$x,predict(noise.np,newdata=new.frame),
type="l",xlab=expression(x^1),ylab="y",ylim=c(0,1.0))
new.frame$y <- quantile(y.noise,0.25)
lines(new.frame$x,predict(noise.np,newdata=new.frame),lty=2)
new.frame$y <- quantile(y.noise,0.75)
lines(new.frame$x,predict(noise.np,newdata=new.frame),lty=3)

curve(exp(7*x)/(1+exp(7*x)),from=-5,to=5,ylab="y")


library(caTools)
library(ggplot2)

dataset <- read.csv('../../Salary_Data.csv')
set.seed(123)
split <- sample.split(dataset$Salary, SplitRatio=2/3)
train_set <- subset(dataset, split == TRUE)
test_set <- subset(dataset, split == FALSE)

print(train_set)
print(test_set)

regressor <- lm(formula = Salary ~ YearsExperience,
               data = train_set)

guess <- predict(regressor, newdata = test_set)

print(test_set$Salary)
print(guess)

ggplot() +
    geom_point(aes(x = train_set$YearsExperience, y = train_set$Salary),
               colour = 'green') +
    geom_point(aes(x = test_set$YearsExperience, y = test_set$Salary),
               colour = 'red') +
    geom_line(aes(x = train_set$YearsExperience, y = predict(regressor, newdata = train_set)),
              colour = 'black') +
    xlab('Years of Experience') +
    ylab('Salary')


# define x and z
library(tidyverse)
library(dslabs)
data(heights)
index <- heights$sex=="Male"
x <- heights$height[index]
z <- scale(x)

# proportion of data below 69.5
mean(x <= 69.5)

# calculate observed and theoretical quantiles
p <- seq(0.05, 0.95, 0.05)
observed_quantiles <- quantile(x, p)
theoretical_quantiles <- qnorm(p, mean = mean(x), sd = sd(x))

# make QQ-plot
plot(theoretical_quantiles, observed_quantiles)
abline(0,1)

# make QQ-plot with scaled values
observed_quantiles <- quantile(z, p)
theoretical_quantiles <- qnorm(p)
plot(theoretical_quantiles, observed_quantiles)
abline(0,1)


# Example : 4   Chapter : 4.4     Page No: 233
# Projections of the vector onto line,plane if basis are given as orthonormal vectors
Q<-matrix(c(-1,2,2,2,-1,2,2,2,-1),ncol=3)
Q<-(1/3)*Q
q1<-Q[,1]
q2<-Q[,2]
q3<-Q[,3]
b<-c(0,0,1)
p1<-sum(q1*b)*q1
p2<-sum(q2*b)*q2
p3<-sum(q3*b)*q3
print("Projection of b onto q1")
print(p1)
print("Projection of b onto q2")
print(p2)
print("Projection of b onto q3")
print(p3)
print("Projection of b onto plane of q1 and q2")
print(p1+p2)
print("Projection of b onto space of q1,q2, and q3")
print(p1+p2+p3) # same as vector b


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

rm(list = ls())

observed <- c(8, 46, 55, 40, 11)

(k <- length(observed))
# 5

(n <- sum(observed))
# 160

(p.hat <- sum(observed * 0:(k-1)) / (n * (k - 1)))
# 0.5

(expected <- n * dbinom(0:(k - 1), size = k - 1, prob = p.hat))
# 10 40 60 40 10

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

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