base::source('utils/data.r')
base::source('utils/dimensionality_reduction.r')
base::source('utils/regression.r')

API <- function () {
    dr <- DimensionalityReduction()
    r <- Regression()

    dimensionality_reduction <- function (X, y, dirname='images') {
        # PCA
        grDevices::png(base::paste(dirname, 'pca.png', sep='/'), width=640, height=640)
        dr$pca.show(X)
        grDevices::dev.off()
        # t-SNE
        dr$tsne.show(X, response=y)
        ggplot2::ggsave(base::paste(dirname, 'tsne.png', sep='/'))
        # MIC
        grDevices::png(base::paste(dirname, 'mic.png', sep='/'), width=640, height=640)
        dr$mic.show(X, y)
        grDevices::dev.off()
    }

    gam <- function (X_train, y_train, X_test, y_test, drm=c('null', 'pca', 'mic'), number=5) {
        # drm: dimensionality_reduction method
        drm <- base::match.arg(drm)
        if (drm == 'pca') {
            model_pca <- dr$pca.fit(X_train)
            X_train <- dr$pca.transform(model_pca, X_train, number)
            X_test <- dr$pca.transform(model_pca, X_test, number)
        } else if (drm == 'mic') {
            model_mic <- dr$mic.fit(X_train, y_train)
            X_train <- dr$mic.transform(model_mic, X_train, number)
            X_test <- dr$mic.transform(model_mic, X_test, number)
        }
        model_gam <- r$gam.fit(data=base::data.frame(X_train, y=y_train))
        base::return(list(
            X=X_test, y_true=y_test, y_pred=r$gam.predict(model_gam, X_test)
        ))
    }

    splines <- function (X_train, y_train, X_test, y_test, drm=c('null', 'pca', 'mic'), number=5) {
        # drm: dimensionality_reduction method
        drm <- base::match.arg(drm)
        if (drm == 'pca') {
            model_pca <- dr$pca.fit(X_train)
            X_train <- dr$pca.transform(model_pca, X_train, number)
            X_test <- dr$pca.transform(model_pca, X_test, number)
        } else if (drm == 'mic') {
            model_mic <- dr$mic.fit(X_train, y_train)
            X_train <- dr$mic.transform(model_mic, X_train, number)
            X_test <- dr$mic.transform(model_mic, X_test, number)
        }
        model_splines <- r$splines.fit(data=base::data.frame(X_train, y=y_train))
        base::return(list(
            X=X_test, y_true=y_test, y_pred=r$splines.predict(model_splines, X_test)
        ))
    }

    self <- list(
        dimensionality_reduction=dimensionality_reduction, gam=gam, splines=splines
    )
    base::class(self) <- base::append(base::class(self), 'API')
    base::return(self)
}

mean_squared_error <- function (y_true, y_pred) {
    index <- (!base::is.na(y_true)) & (!base::is.na(y_pred))
    y_true <- y_true[index]
    y_pred <- y_pred[index]
    base::return(base::mean(base::abs(y_true-y_pred)))
}

r2_score <- function (y_true, y_pred) {
    index <- (!base::is.na(y_true)) & (!base::is.na(y_pred))
    y_true <- y_true[index]
    y_pred <- y_pred[index]
    y_mean <- base::mean(y_true)
    SStot <- base::sum((y_true-y_mean)^2)
    SSres <- base::sum((y_true-y_pred)^2)
    base::return(1-SSres/SStot)
}


# Master Thesis Project - Extreme Value Theory
# We use here QQ-plots to assess graphically the
# goodness of fit of our extreme distributions

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)

# Fitting
	# Computing the 95 % - quantiles for each of the stocks
	quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.975),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

	# Getting the data above the threshold
	data_bnp <- df_plain[[1]]
	data_bnp <- data_bnp[data_bnp > quantiles[1]]

	data_carrefour <- df_plain[[2]]
	data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

	data_lvmh <- df_plain[[3]]
	data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

	data_sanofi <- df_plain[[4]]
	data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

	data_total <- df_plain[[5]]
	data_total <- data_total[data_total > quantiles[5]]

	# Fitting the data, and getting the corresponding location, scale and
	# shape parameters respectively, for each stock
	bnp_fit <- (gev.fit(data_bnp))
	carrefour_fit <- gev.fit(data_carrefour)
	lvmh_fit <- gev.fit(data_lvmh)
	sanofi_fit <- gev.fit(data_sanofi)
	total_fit <- gev.fit(data_total)

	# Saving the GEV parameters for later use
	params_bnp <- bnp_fit$mle
	params_carrefour <- carrefour_fit$mle
	params_lvmh <- lvmh_fit$mle
	params_sanofi <- sanofi_fit$mle
	params_total <- total_fit$mle

# Drawing the QQ-plots
N <- dim(df_plain)[1]
qVect <- (N + 1 - 1:N)/(N + 1)

	# Ordering the samples (increasing sort)
	data_bnp <- sort(df_plain[[1]])
	data_carrefour <- sort(df_plain[[2]])
	data_lvmh <- sort(df_plain[[3]])
	data_sanofi <- sort(df_plain[[4]])
	data_total <- sort(df_plain[[5]])

	# Getting the quantiles of the fitting distributions
	gev_bnp <- qgev(qVect,params_bnp[3],params_bnp[1],params_bnp[2])
	gev_carrefour <- qgev(qVect,params_carrefour[3],params_carrefour[1],params_carrefour[2])
	gev_lvmh <- qgev(qVect,params_lvmh[3],params_lvmh[1],params_lvmh[2])
	gev_sanofi <- qgev(qVect,params_sanofi[3],params_sanofi[1],params_sanofi[2])
	gev_total <- qgev(qVect,params_total[3],params_total[1],params_total[2])

	# Plotting for all the Data
	quartz()
    png(file = "QQ_BNP.png")
	plot(qVect,gev_bnp, main = "QQ-plot BNP", xlab ="", ylab = "")
	abline(lm(gev_bnp~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Carrefour.png")
	plot(qVect, gev_carrefour, main = "QQ-plot Carrefour", xlab ="", ylab = "")
	abline(lm(gev_carrefour~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_LVMH.png")
	plot(qVect, gev_lvmh, main = "QQ-plot LVMH", xlab ="", ylab = "")
	abline(lm(gev_lvmh~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Sanofi.png")
	plot(qVect, gev_sanofi, main = "QQ-plot Sanofi", xlab ="", ylab = "")
	abline(lm(gev_sanofi~qVect), col = "red")
	dev.off()
	graphics.off()

	quartz()
	png(file = "QQ_Total.png")
	plot(qVect, gev_total, main = "QQ-plot Total", xlab ="", ylab = "")
	abline(lm(gev_total~qVect), col = "red")
	dev.off()
	graphics.off()

	# Plotting only for the high quantiles

		# Computing the 95 % - quantiles for each of the stocks
		quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.975),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

		# Getting the data above the threshold
		data_bnp <- df_plain[[1]]
		data_bnp <- data_bnp[data_bnp > quantiles[1]]

		data_carrefour <- df_plain[[2]]
		data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

		data_lvmh <- df_plain[[3]]
		data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

		data_sanofi <- df_plain[[4]]
		data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

		data_total <- df_plain[[5]]
		data_total <- data_total[data_total > quantiles[5]]

		# BNP
		N_BNP <- length(data_bnp)
		qVectBNP <- (N_BNP + 1 - 1:N_BNP)/(N_BNP + 1)

		data_bnp <- sort(data_bnp)
		gev_bnp <- qgev(qVectBNP,params_bnp[3],params_bnp[1],params_bnp[2])

		quartz()
    	png(file = "QQ_BNP2.png")
		plot(qVectBNP,gev_bnp, main = "QQ-plot BNP Paribas, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp~qVectBNP), col = "red")
		dev.off()
		graphics.off()

		# Carrefour
		N_Carrefour <- length(data_carrefour)
		qVectCarrefour <- (N_Carrefour + 1 - 1:N_Carrefour)/(N_Carrefour + 1)

		data_carrefour <- sort(data_carrefour)
		gev_carrefour <- qgev(qVectCarrefour,params_carrefour[3],params_carrefour[1],params_carrefour[2])

		quartz()
    	png(file = "QQ_Carrefour2.png")
		plot(qVectCarrefour,gev_carrefour, main = "QQ-plot Carrefour, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour~qVectCarrefour), col = "red")
		dev.off()
		graphics.off()

		# LVMH
		N_LVMH <- length(data_lvmh)
		qVectLVMH <- (N_LVMH + 1 - 1:N_LVMH)/(N_LVMH + 1)

		data_lvmh <- sort(data_lvmh)
		gev_lvmh <- qgev(qVectLVMH,params_lvmh[3],params_lvmh[1],params_lvmh[2])

		quartz()
    	png(file = "QQ_LVMH2.png")
		plot(qVectLVMH,gev_lvmh, main = "QQ-plot LVMH, above \n97.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh~qVectLVMH), col = "red")
		dev.off()
		graphics.off()

		# Sanofi
		N_Sanofi <- length(data_sanofi)
		qVectSanofi <- (N_Sanofi + 1 - 1:N_Sanofi)/(N_Sanofi + 1)

		data_sanofi <- sort(data_sanofi)
		gev_sanofi <- qgev(qVectSanofi,params_sanofi[3],params_sanofi[1],params_sanofi[2])

		quartz()
    	png(file = "QQ_Sanofi2.png")
		plot(qVectSanofi,gev_sanofi, main = "QQ-plot Sanofi, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi~qVectSanofi), col = "red")
		dev.off()
		graphics.off()

		# Total
		N_Total <- length(data_total)
		qVectTotal <- (N_Total + 1 - 1:N_Total)/(N_Total + 1)

		data_total <- sort(data_total)
		gev_total <- qgev(qVectTotal,params_total[3],params_total[1],params_total[2])

		quartz()
    	png(file = "QQ_Total2.png")
		plot(qVectTotal,gev_total, main = "QQ-plot Total, above \n95 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total~qVectTotal), col = "red")
		dev.off()
		graphics.off()


z1 <- 1.5 + 3i
z2 <- 1.5 + 1.5i
print(z1 + z2)   #  3+4.5i
print(z1 - z2)   #  0+1.5i
print(z1 * z2)   #  -2.25+6.75i
print(z1 / z2)   #  1.5+0.5i
print(-z1)       #  -1.5-3i
print(Conj(z1))  #  1.5-3i
print(abs(z1))   #  3.354102
print(z1^z2)     #  -1.102483-0.383064i
print(exp(z1))   #  -4.436839+0.632456i
print(Re(z1))    #  1.5
print(Im(z1))    #  3


#!/usr/bin/Rscript

library(testthat, quietly=T)
library(quantumClustering, quietly=T)

# Comment out if you do not have doMC installed and/or do not want to
# run processes in parallel
library(doMC, quietly=T)
registerDoMC(cores=4)

# Get rid of the species in order to cluster only on numeric data
iris_clustering <- iris[, setdiff(colnames(iris), "Species")]

test_that("Achieves proper iris clusters for sigma_factor=1", {
    sigma <- calcSD(iris_clustering)
    clusters <- qc(iris_clustering, sigma=sigma, min_d_factor=2)
    expected_out <- c(rep(2, 50), rep(1, 100))
    expect_equal(clusters, expected_out)
})

test_that("Achieves proper iris clusters for sigma_factor=1.85", {
    sigma <- calcSD(iris_clustering) / 4
    clusters <- qc(iris_clustering, sigma=sigma, min_d_factor=2)
    expected_out <-
        c(2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
          2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
          1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,
          3,3,3,4,1,4,3,3,3,3,3,1,1,3,3,5,4,1,3,1,4,1,3,3,1,1,3,3,4,5,3,1,1,4,
          3,3,1,3,3,3,1,3,3,3,1,3,3,1)
    expect_equal(clusters, expected_out)
})

test_that("Cluster limitation removes first cluster", {
    sigma <- calcSD(iris_clustering) / 2
    # Should be the same as sigma_factor=1, or clusters of 50 and 100
    # Since the second is bigger, only it will be accepted.  Therefore,
    # cluster 1 becomes 0 (unclustered) and cluster 2 becomes 1.
    clusters <- qc(iris_clustering, sigma=sigma, min_d_factor=2,
                   n_clusters_max=1)

    expected_out <- c(rep(0, 50), rep(1, 100))
    expect_equal(clusters, expected_out)
})

print("Success!")


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

#install.packages("mlbench") # we can download new libraries right from the R terminal!
library(mlbench)
#help(package="mlbench")
data(BreastCancer)
#help(topic="BreastCancer", package="mlbench")
BreastCancer$Id <- NULL # Just get rid of this column. We won't need it.

# Let's fit a tree to our data
library(rpart) # rpart stands for "recursive partitioning"
basicTree <- rpart(Class ~ ., BreastCancer, method='class')
basicTree
plot(basicTree)
text(basicTree, cex=0.7) # cex controls text size
# Try leaving the "type='class'" parameter out of the next line.
# What do you think happens? Is this maybe a good thing to do in this application?
basicTreePredictions <- predict(basicTree, BreastCancer, type='class')
basicTreeResults <- table(basicTreePredictions == BreastCancer$Class) / length(basicTreePredictions)
basicTreeResults # TRUE: 0.9642, FALSE: 0.0357

# Why don't we try growing our tree so far down that every node contains only one class?
godTree <- rpart(Class ~ ., BreastCancer, method='class',
                 control=c(cp=-1, minsplit=2, minbucket=1))
plot(godTree)
text(godTree, cex=0.6)
godTreePredictions <- predict(godTree, BreastCancer, type='class')
godTreeResults <- table(godTreePredictions == BreastCancer$Class) / length(godTreePredictions)
godTreeResults # TRUE: 1, FALSE: 0

"
Amazing! We have a perfect predictor. All other machine learning algorithms cower in
sight of the glorious predictive power of godTree.

Of course, I'm kidding. What happens when a new data point comes along and, due to
uncertainty, randomness, etc., doesn't conform perfectly to the model we have constructed?
We are interested in how well our predictor performs on *unseen*, future data, so we must
'holdout' some data when we fit our model, then see how well the model performs on our
holdout data. This will give us a good estimate of how well our model *actually* performs
on unseen data.

In general, we partition our data into a 'train' set, which we fit our model to,
and a 'test' set, which we evaluate our model on. This is the most basic form of
cross-validation.
"

partition <- sample(nrow(BreastCancer), floor(0.7 * nrow(BreastCancer)))
trainData <- BreastCancer[partition,]
testData <- BreastCancer[-partition,] # can you guess what the '-' operator is doing here?

godTree <- rpart(Class ~ ., trainData, method='class',
                 control=c(cp=-1, minsplit=2, minbucket=1))
godTreeTrainPredictions <- predict(godTree, trainData, type='class')
godTreeTestPredictions <- predict(godTree, testData, type='class')

godTreeTrainResults <- table(godTreeTrainPredictions
                             == trainData$Class) / length(godTreeTrainPredictions)
godTreeTrainResults # Accuracy on train set TRUE: 1, FALSE: 0
godTreeTestResults <- table(godTreeTestPredictions
                               == testData$Class) / length(godTreeTestPredictions)
godTreeTestResults # Accuracy on test set (approx.) TRUE: 0.9523, FALSE: 0.0476

# Still pretty good, but this is a relatively easy classification problem.
# When we have significantly higher accuracy on the training data as opposed to the
# test data, this is called 'overfitting'. We fit our model to the train data *too* well.

"
We now have a model, and a way to accurately test the predictive power of our model by
partitioning our data into a training set and a test set. The question remains, what
parameters should our model have, and what values should they take on?
In the case of linear regression, our parameters are
the slope and intercept of the regression line. In the case of decision trees, our
parameters should control how far down we grow our tree. There are a few ways to do this,
but in the rpart function we may control the growth of our tree by varying the
complexity parameter (cp), the minimum # of data points in a node needed to consider a
split (minsplit), the minimum amount of data points that are allowed to sit in a
leaf (minbucket), or the maxdepth of the tree (maxdepth).
You may look up what exactly a 'complexity parameter' is, but all
you really need to know is that the lower your cp, the more your tree will grow (subject
to the minsplit, minbucket, maxdepth constraints). Setting cp = -1 (like in the
godTree example) will tell rpart to keep splitting until it cannot split anymore
(again, subject to the minsplit, minbucket, maxdepth constraints).

In general, finding optimal parameters is an optimization problem. Usually a numerical
optimization problem (i.e., there is no closed form optimal solution). More on this
in later lectures.

We will use an algorithm called 'grid search' to find an optimal parameter set.
Grid search is just a fancy name for trying-every-reasonable-combination-of-parameters. Since
cp, minsplit, minbucket, and maxdepth are each different ways of measuring the same thing,
we can effectively tell rpart to ignore the minsplit, minbucket, and maxdepth constraints and only
consider the cp for a 'good enough' optimization of our parameters.
"

# R is a functional language, so it can be frustratingly difficult to do something as
# simple as add an element to the end of an array (vector). We use the foreach library
# to streamline the process. We will also be using a new dataset from a new library
# ElemStatLearn, 'Spam', which is more difficult to classify and illustrates
# the concept better.
#install.packages(c("foreach", "ElemStatLearn"))
library(foreach)
library(ElemStatLearn)
data(spam)
#help(topic="spam", package="ElemStatLearn")

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

cpValues <- c(0.5, 0.1, 0.05, 0.01, 0.005, 0.001, 0.0005, 0.0001)
treesLoss <- foreach(val = cpValues, .combine='c') %do% {
    ctrl <- rpart.control(cp=val, minsplit=2, minbucket=1) # maxdepth defaults to 30
    tree <- rpart(spam ~ ., trainData, method='class', control=ctrl)
    treePredictions <- predict(tree, testData, type='class')
    # proportion incorrect
    loss <- table(treePredictions == testData$spam)["FALSE"][[1]] / length(treePredictions)
    return(loss)
}
results <- data.frame(cp = cpValues, loss = treesLoss)
# x log scale and reversed
plot(results, log='x', xlim=c(max(results$cp), min(results$cp)), type='o')

"
Great. Around 1e-3 seems optimal. BUT, we have made yet another naive mistake.
Decision trees are *high variance* predictors. This means that the decision trees
we generate are highly dependent on the specific data points in our training dataset.
If we had sampled a different training set, it's possible we may have had a different
optimal value. To counterbalance this variability, we use k-fold cross-validation.
Wikipedia has a nice paragraph on k-fold CV:
https://en.wikipedia.org/wiki/Cross-validation_(statistics)#k-fold_cross-validation

In the above article 'validation set' is similar to a test set. We will discuss
validation sets and why we need them later. K-fold CV reduces variability (in
the traditional statistical sense of the word) by averaging our results.

This issue alludes to something you will need to know about (eventually), but probably
won't be covered this lecture. That is the Bias-Variance Tradeoff
https://en.wikipedia.org/wiki/Bias%E2%80%93variance_tradeoff
"

# do 10-fold CV
trainData <- trainData[sample(nrow(spam)),] # randomly permute the rows in our data frame
partitionSize <- floor(nrow(trainData) / 10)
treesLoss <- foreach(val = cpValues, .combine='c') %do% {
    ctrl <- rpart.control(cp=val, minsplit=2, minbucket=1)
    summedResults <- 0
    for (i in seq(1, nrow(trainData) - partitionSize, partitionSize)) {
        validationSetIndices <- i:(i + partitionSize - 1) # seq from i to (partitionSize-1)
        validationData <- trainData[validationSetIndices,]
        nonValidationData <- trainData[-validationSetIndices,]
        tree <- rpart(spam ~ ., nonValidationData, method='class', control=ctrl)
        treePredictions <- predict(tree, validationData, type='class')
        loss <- table(treePredictions == validationData$spam)["FALSE"][[1]] / length(treePredictions)
        summedResults <- summedResults + loss
    }
    averagedResults <- summedResults / 10
    return(averagedResults)
}
cvResults <- data.frame(cp = cpValues, loss = treesLoss)
plot(cvResults, log='x', xlim=c(max(results$cp), min(results$cp)))

# Now we have a nice, smooth curve, and the optimal cp value will either be 1e-3 or 5e-4 depending
# on how easy to classify your test set happens to be (Sometimes we repeat the k-fold CV process
# itself multiple times to eliminate this 'lucky draw' element). If you're bored you can modify
# the code and plot the standard error bars on top of each data point. Another way of choosing the
# optimal parameter is to choose the value that gives the loosest fit to the training data yet is
# still within one standard error of the "best" value.

# So how good is a decision tree with an optimal parameter value?
bestTree <- rpart(spam ~ ., trainData, method='class', control=c(cp=1e-3, minsplit=2, minbucket=1))
bestTreePredictions <- predict(bestTree, testData, type='class')
bestTreeResults <- table(bestTreePredictions == testData$spam) / length(bestTreePredictions)
bestTreeResults # (approx.) TRUE: 0.9225, FALSE: 0.07748

"
Now that we've made it this far, I can tell you a secret: Decision Trees are relatively crude
predictors. Yet we are still able to correctly identify 92% of emails as either spam or
not spam using a singe decision tree and the 'bag-of-words' model (this is how the variables
in our spam data were generated, see [ESL 9.2.5]). To create even more powerful tree-based
predictors, we must learn about ensembles... (see treeEnsembles.r)
"


rm(list=ls())

Fx <- function(x) exp(x)

# Halla la raiz de Fx

Aitken <- function(a,b,c) {

    x<-1
    error<-1
    while (error > 1.e-4) {
        #if (Fx(x) == 0) break
        i<-x
        x<-(b-a)^2/(c-2*b+a)
        a<-b
        b<-c
        c<-x
        error<-abs(i-x)
        cat("X=",x,"\tE=",error,"\n")

    }

}

Aitken(0.6,0.85,0.725)


vector('numeric', 5) # numeric vector with 0 at every index

vector('complex', 5) # complex vector with 0+0i at every index

vector('logical', 5) # logical vector with FALSE at every index

vector('character', 5) # character vector with "" at every index

myNumericVector <- vector('numeric', 5)
typeof(myNumericVector)
length(myNumericVector)

# Creating vectors by concatenation
myRealNumericVector <- c(1, 2, 3, 4)
typeof(myRealNumericVector)
class(myRealNumericVector)

myDecimalNumericVector <- c(0.1, 0.2, 0.3, 0.4)

myLogicalVector <- c(TRUE, FALSE)

myCharacterVector <- c('a', 'b', 'c')

myIntegerVector <- 1:10

myComplexVector <- c(1+1i, 2+2i)

# Vector with just one value
myVector <- 5
is.vector(myVector)
length(myVector)

# Converting vectors to string
myVectorStrings <- c('learning','is', 'fun')

# The collapse parameter specifies the character to be used between
# ... individual vector elements

paste(myVectorStrings, collapse = ',')

# Inserting elments in a Vector

# By using c() we can concatenate two vectors, in addition to inserting
# ... a number into a vector.

myVector <- c(1, 2, 3, 4)
cat("Original Vector: ")
print(myVector)

myVector <- c(0, myVector)
cat("Appending 0 at the start of the vector: ")
print(myVector)

myVector <- c(myVector, 5)
cat("Appending 5 at the end of the vector: ")
print(myVector)

tempVector <- c(6, 7, 8)
myVector <- c(myVector, tempVector)
cat("Appending another vector at the end of the original vector: ")
print(myVector)

# Accessing and modifying vectors
# vectorName[<index>]
# Indexings starts ate 1, which means that the first elements of the vector is at index 1
myVector <- c(0, 1, 2, 3)
myVector[1] <- 5
print(myVector[1])


#------------------------------------------------------------------------------------------------------------------------------------------
# return the TPR and FPR estimated for a set of thresholds in a given validation set of scores
# thresholds vary from 0.01 to 0.99 with 0.01 step
getTPRandFPRbyThreshold <- function(validation_scores)
{

  unique_scores <- seq(0.01,0.99,0.01)
  arrayOfTPRandFPRByTr = NULL
  for (threshold in unique_scores)
  {
    total_positive = length(which(validation_scores[,3]==1))
    total_negative = length(which(validation_scores[,3]==2))
    fp = length(which(validation_scores[,1]>threshold & validation_scores[,3]==2))
    tp = length(which(validation_scores[,1]>threshold & validation_scores[,3]==1))
    tpr = tp/total_positive
    fpr = fp/total_negative

    threshold = format(round(threshold, 2), nsmall = 2)

    arrayOfTPRandFPRByTr = rbind(arrayOfTPRandFPRByTr,c(threshold,tpr,fpr))
  }

  colnames(arrayOfTPRandFPRByTr) <- c('tr','tpr','fpr')

  return (arrayOfTPRandFPRByTr)
}


library(shiny)
library(matrixcalc)
library(plotly)

getLikelihood <- function(point, expectation, covMatrix) {
  pointMinusMean <- t(as.matrix(point - expectation))

  covMatrixInverse <- solve(covMatrix)
  nom <- exp(-(pointMinusMean %*% covMatrixInverse %*% t(pointMinusMean)) / 2)
  denom <- sqrt((2 * pi) ^ nrow(covMatrix) * det(covMatrix))

  return(nom / denom)
}

getPlugInProbability <- function(point, lambda, prior, expectations, covMatrix) {
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;

  return (probability)
}

function(input, output, session, ...) {
  output$err <- function() {
    # E <- matrix(c(input$E1, input$E3, input$E2, input$E4), nrow = 2)
    # if (!matrixcalc::is.positive.definite(E)) {
    #   return("Error: covariance matrix has to be positive definite.")
    # }
    return("")
  }

  output$p1 <- renderPlotly({
    lambdas <- c(input$la1, input$la2)
    prior <- c(input$ratio / 100, 1 - (input$ratio / 100))
    expectations <- list(
      c(input$mu11, input$mu12),
      c(input$mu21, input$mu22)
    )

    covMatrix <- list(
      matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE),
      matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    )

    center <- c((input$mu11 + input$mu21) / 2, (input$mu12 + input$mu22) / 2)

    xs <- seq(from = center[1] - 5, to = center[1] + 5, by = 0.1)
    ys <- seq(from = center[2] - 5, to = center[2] + 5, by = 0.1)
    z <- c()

    for (y in ys) {
      curr <- c()
      for (x in xs) {
        arg <- c(x, y)
        value <- (getPlugInProbability(c(x, y), lambdas[1], prior[1], expectations[[1]], covMatrix[[1]]) - getPlugInProbability(c(x, y), lambdas[2], prior[2], expectations[[2]], covMatrix[[2]]))

        curr <- c(curr, value)
      }
      z <- rbind(z, curr)
    }

    fig <- plot_ly(
      type = 'contour',
      x = ~xs,
      y = ~ys,
      z = ~z)
    fig
  })

  output$p2 <- renderPlotly({
    lambdas <- c(input$la1, input$la2)
    prior <- c(input$ratio / 100, 1 - (input$ratio / 100))
    expectations <- list(
      c(input$mu11, input$mu12),
      c(input$mu21, input$mu22)
    )

    covMatrix <- list(
      matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE),
      matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    )

    center <- c((input$mu11 + input$mu21) / 2, (input$mu12 + input$mu22) / 2)

    xs <- seq(from = center[1] - 5, to = center[1] + 5, by = 0.1)
    ys <- seq(from = center[2] - 5, to = center[2] + 5, by = 0.1)
    z <- c()

    for (y in ys) {
      curr <- c()
      for (x in xs) {
        arg <- c(x, y)
        value <- (getPlugInProbability(c(x, y), lambdas[1], prior[1], expectations[[1]], covMatrix[[1]]) - getPlugInProbability(c(x, y), lambdas[2], prior[2], expectations[[2]], covMatrix[[2]]))

        curr <- c(curr, value)
      }
      z <- rbind(z, curr)
    }

    fig <- plot_ly(
      type = 'surface',
      x = ~xs,
      y = ~ys,
      z = ~z)
    fig
  })
}


##title: My short analysis
##author: Vijay

# First we load the packages
library(tidyr)
library(ggplot2)
library(Hmisc)
library(psych)

pers_exp <- USPersonalExpenditure

# Let's look at the data
pers_exp	#it looks like the row names are not actually in the matrix
		#let's fix that

expenditure_type <- rownames(pers_exp)
expenditure_type <- gsub( ' ' , '_' , expenditure_type) # Replace spaces with underscores
rownames(pers_exp) <- NULL
pers_exp <- as.data.frame(pers_exp)
pers_exp <- cbind(expenditure_type,pers_exp)

# Let's look at the data now
pers_exp	#better, but it doesn't look tidy to me
		#let's fix that

pers_exp <- gather( pers_exp , `1940` , `1945` , `1950` , `1955` , `1960` ,
	key = year, value =  expenditure)
pers_exp <- spread( pers_exp , key = expenditure_type , value = expenditure)

# Let's look at the data now
pers_exp	#better

# We should now look at some descriptive stats
# Let's use the describe function from the psych package
psych::describe(pers_exp)

# Okay, that's nice but we really just want the Private Education info

psych::describe(pers_exp$Private_Education)

# This shows a difference between the minumum and maximum values
# with both the mean and median roughly in between.
# This would suggest a general change, but we cannot be sure of the direction.
# A plot might help with this

# Plot private education over time
ggplot( pers_exp , aes( year , Private_Education))+
	geom_bar(stat='identity')+
	labs( x = 'Year' , y = 'Expenditure on private education\nin billions of $') +
	theme_classic()
# This plot shows that expenditure on Private Education has
# increased between 1940 and 1960.

# Let's now see if the correlation between these values is significant

# First calculate correlation and p-value
cor_vals <- rcorr( pers_exp$year , pers_exp$Private_Education )

# Straight up scatter plot
ggplot( pers_exp , aes( x = as.numeric(year) , y = Private_Education)) +
  geom_point() +
  geom_smooth(method='lm') +
  annotate('text' , x = 1945 , y = 3.2 ,
    label = paste('R^2 == ' , round(cor_vals$r[1,2],3) , sep=''), parse = T) +
  annotate('text' , x = 1945 , y = 3 ,
    label = paste('p ==', round(cor_vals$P[1,2],5) , sep=''), parse = T) +
  labs(x = 'Year' , y = 'Expenditure on private education\nin billions of $') +
  theme_classic()

# Bar plot with scatter plot overlay
ggplot( pers_exp , aes( x = as.numeric(year) , y = Private_Education)) +
  geom_bar(stat='identity')+
  geom_point() +
  geom_smooth(method='lm') +
  annotate('text' , x = 1945 , y = 3.2 ,
    label = paste('R^2 == ' , round(cor_vals$r[1,2],3) , sep=''), parse = T) +
  annotate('text' , x = 1945 , y = 3 ,
    label = paste('p ==', round(cor_vals$P[1,2],5) , sep=''), parse = T) +
  labs(x = 'Year' , y = 'Expenditure on private education\nin billions of $') +
  theme_classic()


write(round(pnorm(40, 30, 4), 3), stdout())
write(round(1 - pnorm(21, 30, 4), 3), stdout())
write(round(pnorm(35, 30, 4) - pnorm(30, 30, 4), 3), stdout())


YachtHydrodynamics <- read.table(url("https://archive.ics.uci.edu/ml/machine-learning-databases/00243/yacht_hydrodynamics.data"))
names(YachtHydrodynamics)<- c('LongPos', 'PrismaticCoef', 'LengDispRatio',
  'BeamDraughtRatio', 'LengthBeamRatio','FroudeNumber','ResResistance')

summary(YachtHydrodynamics)

par(mfrow=c(2,3))
plot(YachtHydrodynamics$LongPos,YachtHydrodynamics$ResResistance,xlab="LongPos",ylab="ResResistance")
plot(YachtHydrodynamics$PrismaticCoef,YachtHydrodynamics$ResResistance,xlab="PrismaticCoef",ylab="ResResistance")
plot(YachtHydrodynamics$LengDispRatio,YachtHydrodynamics$ResResistance,xlab="LengDispRatio",ylab="ResResistance")
plot(YachtHydrodynamics$BeamDraughtRatio,YachtHydrodynamics$ResResistance,xlab="BeamDraughtRatio",ylab="ResResistance")
plot(YachtHydrodynamics$LengthBeamRatio,YachtHydrodynamics$ResResistance,xlab="LengthBeamRatio",ylab="ResResistance")
plot(YachtHydrodynamics$FroudeNumber,YachtHydrodynamics$ResResistance,xlab="FroudeNumber",ylab="ResResistance")

Lm1 <- lm(ResResistance ~ ., data = YachtHydrodynamics)
summary(Lm1)
Slm1 <- step(Lm1)


#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: 2013-2017 Crude Mortality from Top 50 Causes
# The R project for Statistical Computing Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Step 1: Import Libraries and Data

## 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 Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_fl = read.csv("_data/flcharts_50_stage.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder
df_causes = read.csv("_data/flcharts_aadr_causes_stage.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder
df_cms = read.csv("_data/cedric_cms_pr_value.csv", fileEncoding = "UTF-8-BOM") # Import dataset from _data folder

## Verify Data
head(df_fl) # Mini table with top 5 observations
head(df_causes) # Mini table with top 5 observations
head(df_cms) # Mini table with top 5 observations

### Step 2: Prepare Data for Analysis

## Tidy data types and objects
df_fl = df_fl %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_causes = df_causes %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_cms = df_cms %>% mutate_if(is.factor, as.character) # Change character to numeric values
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10
glimpse(df_causes) # Rows, columns, variable types and 10
glimpse(df_cms) # Rows, columns, variable types and 10

## Write Output to File
text_1 = skim(df_fl)
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Cedric subproject: Developing better ways to measure equity in health",  file) # Insert title
write("Florida Charts Census Tract Mortality Data: 2013-2017 Crude Mortality from Top 50 Causes\n\n",  file) # Insert title
write("Data Summary\n",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
close(file) # Close file

### Step 3: Identify Top Mortality Measures by Inequality

## Create data frame of Gini by causes
df_features = subset(df_fl, select = -c(Tract, County)) # Remove Other Causes variable
df_gini = as.data.frame(apply(df_features, 2, ineq)) # Apply function to all comuns, 1 for rows and save to data frame
df_gini$rownames <- rownames(df_gini)
colnames(df_gini) <- c("Gini", "Causes") # Rename Columns to function and feature label
rownames(df_gini) <- c()

## Join with To 50 Causes by AADR for 2013-2017
df_join = inner_join(df_gini, df_causes, by = "Causes") ## Join By Columns

## Sort by top 10
df_rank1 = df_join[order(-df_join$AADR),] # Sort df by column
df_rank1 = head(df_rank1, 10)
df_rank2 = df_rank1[order(-df_rank1$Gini),] # Sort df by column

## Verify Data
head(df_rank1) # Mini table with top 5 observations
head(df_rank2) # Mini table with top 5 observations
head(df_join) # Mini table with top 5 observations

## Write Output to File
text_1 = df_rank1
text_2 = df_rank2
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("\n\nTop Causes of Mortality",  file) # Insert title
write("\nBy AADR",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
write("\nTop 10 Gini\n",  file) # Insert title
capture.output(text_2, file = file, append = TRUE) # write summary to file
close(file) # Close file

#### Section B: Get Outcome Specific Gini coefficient and MSPB at Hospitals by County

### Step 7: Compare Gini and For-Profit Hospitals

## Create health outcome variables
df_fl$Diabetes = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Diabetes, type = "Gini")) # Group By Columns and Average
df_county = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_county) <- c("County", "Gini") # Change Column Names
df_county = df_county[order(-df_county$Gini),] # Sort df by column

## Join with County Value Measure
df_join2 = inner_join(df_county, df_cms, by = "County", how = "left") ## Join By Columns
dim(df_join2)

## Spearman Rank
corr_diabetes = cor.test(x = df_join2$Gini, y = df_join2$MSPB, method = "spearman") # Pearson's Rank for Q->Q

## Write Output to File
text_1 = head(df_county, 10)
text_2 = corr_diabetes
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("\n\nAssociation of Diabetes Inequity and MSPB",  file) # Insert title
write("\nTop 10 Counties by Inequality",  file) # Insert title
capture.output(text_1, file = file, append = TRUE) # write summary to file
write("\nFor Profit Hospitals",  file) # Insert title
capture.output(text_2, file = file, append = TRUE) # write summary to file
write("\n\n\nTHE END",  file) # Insert title
close(file) # Close file

print("THE END")
#### End Script


# x, y: the x and y coordinates of the hull points
# n: the number of points in the curve.
bezierCurve <- function(x, y, n=10)
	{
	outx <- NULL
	outy <- NULL

	i <- 1
	for (t in seq(0, 1, length.out=n))
		{
		b <- bez(x, y, t)
		outx[i] <- b$x
		outy[i] <- b$y

		i <- i+1
		}

	return (list(x=outx, y=outy))
	}

bez <- function(x, y, t)
	{
	outx <- 0
	outy <- 0
	n <- length(x)-1
	for (i in 0:n)
		{
		outx <- outx + choose(n, i)*((1-t)^(n-i))*t^i*x[i+1]
		outy <- outy + choose(n, i)*((1-t)^(n-i))*t^i*y[i+1]
		}

	return (list(x=outx, y=outy))
	}

# Example usage
x <- c(4,6,4,5,6,7)
y <- 1:6
plot(x, y, "o", pch=20)
points(bezierCurve(x,y,20), type="l", col="red")


#!/usr/bin/env Rscript

removeOutliers <- function(dataset) {
    datasetRemoved = list()

    lsrl = lm(dataset$y ~ dataset$x)
    cookd = cooks.distance(lsrl)

    datasetRemoved$x = dataset$x[cookd < (2/length(dataset$x))]
    datasetRemoved$y = dataset$y[cookd < (2/length(dataset$x))]
    return(datasetRemoved)
}

removeDuplicates <- function(dataset) {
    datasetRemoved = list()
    datasetRemoved$x = dataset$x[c(TRUE, diff(dataset$x) != 0)]
    datasetRemoved$y = dataset$y[c(TRUE, diff(dataset$x) != 0)]
    return(datasetRemoved)
}

# Datasets
dataA = list()
dataB = list()
dataAB = list()

# Read Files
# NOTE: we can't just readline() b/c running this script w/ Rscript is "non-interactive"...
cat("First File to Read: ")
fileA = readLines(file("stdin"), 1)
dataAfile = read.csv(paste("data/", fileA, ".csv", sep=""), header = TRUE)
cat("Second File to Read: ")
fileB = readLines(file("stdin"), 1)
dataBfile = read.csv(paste("data/", fileB, ".csv", sep=""), header = TRUE)
closeAllConnections()

# Assign to Datasets
dataA$x = dataAfile$TOTAL.AMP
dataA$y = dataAfile$VOLT
dataB$x = dataBfile$TOTAL.AMP
dataB$y = dataBfile$VOLT

# Filter Outliers (optional)
dataA = removeOutliers(dataA)
dataB = removeOutliers(dataB)

# Remove Duplicate Current Readings (optional)
dataA = removeDuplicates(dataA)
dataB = removeDuplicates(dataB)

# Find combined data set
dataAB$x = c(dataA$x, dataB$x)
dataAB$y = c(dataA$y, dataB$y)

# TODO correlation coefficient for each dataset?
# TODO display LSRL for each set?
# TODO keep original dataset, plot outliers

# Plot Datasets (optional)
x11()
plot(dataA$x, dataA$y, main="Motor Comparison, Amps vs. Volts", xlab="Amps", ylab="Volts", col="blue")
points(dataB$x, dataB$y, col="green")
abline(lm(dataA$y ~ dataA$x), col="blue")
abline(lm(dataB$y ~ dataB$x), col="green")
abline(lm(dataAB$y ~ dataAB$x), col="black")

# TODO avoid recomputing Linear Models, store in dataA$lm? Also store dataA$residuals? (Or just dataA$lm$residuals)

# Find SSRs
dataA$ssr = sum(resid(lm(dataA$y ~ dataA$x)) ^ 2)
dataB$ssr = sum(resid(lm(dataB$y ~ dataB$x)) ^ 2)
dataAB$ssr = sum(resid(lm(dataAB$y ~ dataAB$x)) ^ 2)

# Do Chow Test to find F statistic
k = 2
df = length(dataA$x) + length(dataB$x) - (2 * k)

fstat = ((dataAB$ssr - (dataA$ssr + dataB$ssr)) / k) / ((dataA$ssr + dataB$ssr) / (df))

# Print Info
cat("SSR A:\t", dataA$ssr, "\n")
cat("SSR B:\t", dataB$ssr, "\n")
cat("SSR AB:\t", dataAB$ssr, "\n")
cat("k:\t", k, "\n")
cat("df:\t", df, "\n")
cat("F Stat:\t", fstat, "\n")
cat("P-Val:\t", pf(fstat, k, df, lower.tail=FALSE), "\n")

# Basically a bunch of hacks
cat("Press [Enter] to Quit...")
enter = readLines(file("stdin"), 1)
closeAllConnections()


#DBSCAN
install.packages("fpc")
search()

library(fpc)
search()

iris2 <- iris[-5] # remove class tags
View(iris2)

ds <- dbscan(iris2, eps=0.45, MinPts=5 )

# compare clusters with original class labels
ds

str(ds)

ds$cluster
View(ds$cluster)

table(ds$cluster, iris$Species) #cluster 0 indicates noise/outliers

plot(ds, iris2) #plots all attribute combination (one vs other) for 4 clusters

plot(ds, iris2[c(1,4)]) #plotting two features distribution clusterwise

#other values of parameters

ds1 <- dbscan(iris2, eps=0.40, MinPts=5)
ds1$cluster

table(ds1$cluster, iris$Species) #cluster 0 indicates noise/outliers
plot(ds1, iris2) #plots all attribute combination (one vs other) for 4 clusters

plot(ds1, iris2[c(1,4)]) #plotting two features distribution clusterwise


# Example 1 p. 389 Figure 10.3
library(rsm)
rotd <- ccd(3, n0 = c(4,2), alpha = "rotatable", randomize = FALSE)
rotdm <- rotd[ , 3:5]
library(Vdgraph)
Vdgraph(rotdm)

# Figure 10.5 p. 392
# create design with rsm
library(rsm)
bbd3 <- bbd(3,randomize=FALSE,n0=3)
library(Vdgraph)
Vdgraph(bbd3[ , 3:5])

# Figure 10.6 p. 392
library(Vdgraph)
FDSPlot(bbd3[ , 3:5], mod=2)

# Figure 10.8 p. 394
library(Vdgraph)
data(SCDH2)
Vdgraph(SCDH2)

# Figure 10.9 p. 395
# first get the ccd2
library(rsm)
ccd2<- ccd(2, n0 = c(3,2), alpha = "rotatable", randomize = FALSE)[ ,3:4]
Compare2FDS(SCDH2,ccd2,"SCD","CCD",mod=2)

# Figure 10.10 p. 396
library(Vdgraph)
data(D310)
Vdgraph(D310)

# Example 2 p. 396-397
library(rsm)
ccd.pick(k=3)

# Example 3 p. 397
library(rsm)
ccd.up<-ccd(y~x1+x2+x3,n0=c(4,2),alpha="rotatable",randomize=FALSE)
Vdgraph(ccd.up[ , 3:5])

# Example 4 p. 398
ccd.up<-ccd(y~x1+x2+x3,n0=c(4,2),alpha="rotatable",
            coding=list(x1~(Temp-150)/10,x2~(Press-50)/5, x3~(Rate-4/1)),randomize=FALSE)
head(ccd.up)

# Example 5 p. 398
library(rsm)
Treb<-bbd(y ~ x1 + x2 + x3, randomize = FALSE, n0 = 3,
          coding=list(x1~(A-6)/2, x2~(B-15)/5, x3~(C-2.5)/.5))
head(Treb)

# Example 6 p. 399
library(Vdgraph)
data(D310)
D310

# Example 7 p. 400
des <- transform(D310, Temp=10*x1+150, Press=5*x2+50, Rate = x3 + 4)
des[sample(1:10) ,4:6]

# Example 8 p. 401
library(daewr)
data(qsar)

# Example 9 p.403 and Figure 10.13 p. 404
library(AlgDesign)
desgn1<-optFederov(~quad(.),data=qsar,nTrials=15,center=TRUE,
                   criterion="D",nRepeats=40)
desgn2<-optFederov(~quad(.),data=qsar,nTrials=15,center=TRUE,
                   criterion="I",nRepeats=40)
Compare2FDS(desgn1$design, desgn2$design, "D-optimal", "I-optimal", mod=2)

# Example 10 p. 404
desgn2$design

# Example 11 p. 406
k1 <- .15; k2 <- .72; gamma0 <- 2.65; t0 <- 0.41
x <- c(seq(1:25))
dfdk1 <- c(rep(0, 25))
dfdk2 <- c(rep(0, 25))
dfdgamma0 <- c(rep(0, 25))
dfdt0 <- c(rep(0, 25))
for (i in 1:25) {
  dfdk1[i] <- -1 * gamma0 * exp(-k1 * (x[i] - t0)) *(x[i] - t0)
  dfdk2[i] <-gamma0 * exp(-k2 * (x[i] - t0)) * (x[i] - t0)
  dfdgamma0[i] <- exp(-k1 * (x[i] - t0)) - exp( -k2 *                                                  ( x[i] - t0))
  dfdt0[i] <- gamma0 * exp(-k1 * (x[i] - t0)) * k1 - gamma0 *
    exp(-k2 * (x[i] - t0)) * k2; }
grid <- data.frame(x, dfdk1, dfdk2, dfdgamma0, dfdt0)

# Example 12 p. 407
library(AlgDesign)
desgn2<-optFederov(~ +dfdk1+dfdk2+dfdgamma0+dfdt0,data=grid,nTrials=8,center=TRUE, criterion="D",nRepeats=20)
desgn2

# This additional code illustrates fitting a model to simulated data from the design
design<-desgn2$design
k1 <- .15; k2 <- .72; gamma0 <- 2.65; t0 <- 0.41
# this is the simulated response
design$y<-gamma0*(exp(-k1*(design$x-t0))-exp(-k2*(design$x-t0)))+rnorm(8,0,.05)
# this is the code to fit the model
mod.nls<-nls(y~gamma0*(exp(-k1*(x-t0))-exp(-k2*(x-t0))),data=design,
             start=list(gamma0=2.65,k1=.15,k2=.72,t0=0.41))
summary(mod.nls)

# Example 13 p. 408
library(daewr)
data(cement)
head(cement)

# Example 14 p. 408
library(rsm)
grout.lin <- rsm(y ~ SO(x1, x2, x3),data = cement, subset = (Block == 1))
anova(grout.lin)

# Example 15 p. 409
library(daewr)
data(Treb)
head(Treb)

# Example 16 p. 410
library(rsm)
treb.quad <- rsm(y ~ SO(x1, x2, x3), data = Treb)
summary(treb.quad)

# Example 17 p. 411
library(daewr)
data(cement)
grout.quad <- rsm(y ~ Block + SO(x1,x2,x3), data = cement)
summary(grout.quad)

# Example 18 p. 412 - 413
library(daewr)
data(Tet)
mod.nln1 <-nls(Conc ~ gamma0 * (exp( -k1 * (Time - t0)) - exp( -k2 * (Time - t0))),
               data = Tet, start = list(gamma0 = 10, k1 = .12, k2 = .5, t0 = .5))
summary(mod.nln1)

# Example 20 p. 413-414 Figure 10.15
library(daewr)
data(Treb)
library(rsm)
treb.quad <- rsm(y ~ SO(x1, x2, x3), data = Treb)
par (mfrow=c(2,2))
contour(treb.quad, ~ x1+x2+x3 )
par (mfrow=c(1,1))

# Example 21 p. 414-415 Figure 10.16
par (mfrow=c(2,2))
persp(treb.quad, ~ x1+x2+x3, zlab="Distance", contours=list(z="bottom") )
par (mfrow=c(1,1))

# Example 22 p. 415-416, Figure 10.17
par (mfrow=c(1,2))
contour(treb.quad, x1~x3, at=list(x2=1))
persp(treb.quad, x1~x3, at=list(x2=1),zlab="Distance", contours=list(z="bottom"))
par (mfrow=c(1,1))

# Example 23 p. 418
# slice at stationary point instead of coding value
par (mfrow=c(2,2))
contour(treb.quad, ~ x1+x2+x3, at = xs(treb.quad) )
par (mfrow=c(1,1))

# Example 24 p. 419
ridge<-steepest(treb.quad, dist=seq(0, 1.412, by=.1), descent=FALSE)
ridge

# Figure 10.20 p. 420
par (mfrow=c(2,1))
leg.txt<-c("A","B","C")
plot(ridge$dist,ridge$yhat, type="l",xlab="radius",ylab="Max. Predicted")
plot(ridge$dist,seq(1,22,by=1.5), type="n", xlab="radius", ylab="Factors")
lines(ridge$dist,ridge$A,lty=1)
lines(ridge$dist,ridge$B,lty=2)
lines(ridge$dist,ridge$C,lty=3)
legend(1.2,19,leg.txt,lty=c(1,2,3))
par (mfrow=c(1,1))

#Example 25 p. 421
start<-c(12.5,400)
prod <- function(x) {
  time <- x[1]
  Temp <- x[2]
  k1 <- .523 * exp(-9847 * ((1/Temp - 1/400 )))
  k2 <- .2 * exp(-12327 * ((1/Temp - 1/400 )))
  f <- 132 * (exp(-k1 * time) - exp( -k2 *time)) * k1/(k1-k2)
}
ui <- matrix(c(1, -1, 0, 0, 0, 0, 1, -1), 4, 2)
ci <- c(0, -25, 375, -425)
constrOptim(start, prod, NULL, ui, ci)

# Figure 10.21 p. 422
par (mfrow=c(1,1))
time<-seq(0,25,length=52)
Temp<-seq(375,425,length=52)
p<-matrix(rep(0,2704),nrow=52)
for (i in 1:52)    {
  for (j in 1:52) {
    k1<-.523*exp(-9847*((1/Temp[j]-1/400)))
    k2<-.2*exp(-12327*((1/Temp[j]-1/400)))
    p[i,j]<--132*(exp(-k1*time[i])-exp(-k2*time[i]))*k1/(k1-k2)
  }
}
contour(time,Temp,p,xlab="Time, hrs",ylab="Temp, Deg K")

# Example 26 p. 424
# maximize tsr for cost <=10 cents
# Note: since no R packages allow nonlinear equality constraints
# I included this constraint in the tsr function by adding the
# 100*maxumum of (cost -10) and zero
start<-c(100,.6,40)
tsrcost<-function(x) {
  Temp<-x[1]
  Ratio<-x[2]
  AOPPM<-x[3]
  tsrcost<- -(-226+3.375*Temp+86.5*Ratio+2.646*AOPPM-.0128*Temp*Temp-17.5*Ratio*Ratio-.0121*AOPPM*AOPPM
              +           -.3857*Ratio*Temp-.0126*AOPPM*Temp-.0333*AOPPM*Ratio)+
    +           100*max((.8313+1.27*Ratio+.37*Ratio*AOPPM-10),0)
}
ui<-matrix(c(1,-1,0,0,0,0,0,0,1,-1,0,0,0,0,0,0,1,-1),6,3)
ci<-c(70,-140,.5,-1.5,5,-65)
constrOptim(start,tsrcost,NULL,ui,ci)
# note this minimizes tsrcost, subject to ui%*%x-ci>=0

# Example 27 p. 426
x<-c(0,0,0)
saPred<-function(x) 125.4106 -8.1233*x[1]+17.0266*x[2]+.4277*x[3]+2.4184*x[1]*x[2]
-8.4376*x[1]*x[3]+9.0134*x[2]*x[3]+33.88054*x[1]^2+14.81976*x[2]^2+13.07001*x[3]^2

pvPred<-function(x) .661354-.1963*x[1]-.02016*x[2]-.00291*x[3]+.02399*x[1]*x[2]
+.010327*x[1]*x[3]-.0374*x[2]*x[3]+.15126*x[1]^2+.118423*x[2]^2+.0679*x[3]^2

dpPred<-function(x) 39.35608+3.19547*x[1]+.21729*x[2]-1.46979*x[3]+.58873*x[1]*x[2]
-.62136*x[1]*x[3]-1.53234*x[2]*x[3]+.41413*x[1]^2-2.39408*x[2]^2-2.36399*x[3]^2

library(desirability)
saD<-dMax(100, 217)
pvD<-dMax(0.6, 1.3)
dpD<-dTarget(38, 40, 42)
overallD<-dOverall(saD, pvD, dpD)

# Code on web page referred to on p. 426
rsmOpt <- function(x, dObject, space = "square")
{
  sa <- saPred(x)
  pv <- pvPred(x)
  dp <- dpPred(x)

  out <- predict(dObject, data.frame(sa = sa, pv = pv, dp = dp))

  if(space == "circular")
  {
    if(sqrt(sum(x^2)) > 1.0) out <- 0
  } else if(space == "square") if(any(abs(x) > 1.0)) out <- 0
  out
}

searchGrid <- expand.grid(Mixtime = seq(-1.0, 1.0, length = 5),
                          filTtime = seq(-1.0, 1.0, length = 5),
                          PackMth = seq(-1.0, 1.0, length = 5))
for(i in 1:dim(searchGrid)[1])
{
  tmp <- optim(as.vector(searchGrid[i,]),
               rsmOpt,
               dObject = overallD,
               space = "square",
               control = list(fnscale = -1))
  if(i == 1)
  {
    best <- tmp
  } else {
    if(tmp$value > best$value) best <- tmp
  }
}

predOutcomes <-c(saPred(c(-0.2924993,-1,-1)), pvPred(c(-0.2924993,-1,-1)), dpPred(c(-0.2924993,-1,-1)))
print(predOutcomes)

# Example 28  p. 427
#Create Blocked bbd
library(rsm)
# four-factor design
bbd(4,n0=1,randomize=FALSE)
# five-factor design
bbd(5,n0=3,randomize=FALSE)
#Create Blocked CCD designs
# two-factor design
ccd(2,n0=c(3,3),alpha="orthogonal",randomize=FALSE)
# three-factor design
ccd(3, n0=2,alpha="orthogonal",randomize=FALSE, blocks=Block~( x1*x2*x3))
# four-factor design
ccd(4, n0=2, alpha="orthogonal",randomize=FALSE, blocks=Block~(x1*x2*x3*x4))
# five-factor design
ccd(4, generators=(x5~x1*x2*x3*x4), n0=c(6,1),alpha="orthogonal",randomize=FALSE)

# Example 29 p. 428
library(AlgDesign)
fact<-gen.factorial(levels=2,nVars=3)
fact<-rbind(fact,fact)
center<-data.frame(matrix(rep(c(0,0,0),6),ncol=3))
star<-data.frame(rbind(diag(3),-diag(3)))
cand<-rbind(fact,center,star)
bdesign<-optBlock(~quad(),cand,blocksizes=c(4,4,4,4,4,4,4),criterion="Dpc",nRepeats=1000)
bdesign

# Example 30 p. 429
library(daewr)
data(qsar)
library(AlgDesign)
desgn1<-optBlock(~quad(.),qsar,blocksizes=c(4,4,4,4,4),criterion="Dpc",nRepeats=1000)
desgn1

# Example 31 p. 430
library(daewr)
data(pastry)
class(pastry$Block)
library(rsm)
blkrsm<-rsm(y~Block+SO(x1,x2,x3), data=pastry)
summary(blkrsm)

#Example 32 p. 432
# REML analysis using lmer
library(daewr)
data(cake)
library(lme4)
mmod<-lmer(y~x1+x2+x1:x2+x1sq+x2sq+(1|Ovenrun),data=cake)
summary(mmod)
# Least Squares Analysis using rsm
library(rsm)
mmodls<-rsm(y ~ SO(x1,x2), data=cake)
summary(mmodls)

# Example 33 EESPRS page 434
library("AlgDesign")
# uses gen.factorial function from AlgDesign to create Factorial portion of the design
sp<-gen.factorial(2,2,varNames=c("P","Q"))
Wp<-gen.factorial(2,2,varNames=c("A","B"))
A<-Wp$A
#stacks whole plots
wp<-c(rep((1:4),each=4))
A<-c(rep((Wp$A),each=4))
B<-c(rep((Wp$B),each=4))
Fac<-cbind(wp,A,B,rbind(sp,sp,sp,sp))
# Subplot Axial Portion
A<-c(rep(0,4))
B<-c(rep(0,4))
P<-c(-2,2,0,0)
Q<-c(0,0,-2,2)
wp<-c(rep(5,4))
spa<-cbind(wp,A,B,P,Q)
# Whole Plot Axial Portion
wp<-c(rep((6:9),each=4))
A<-c(rep(c(-2,2,0,0),each=4))
B<-c(rep(c(0,0,-2,2),each=4))
P<-c(rep(0,16))
Q<-c(rep(0,16))
wpa<-cbind(wp,A,B,P,Q)
# center points
wp<-c(rep((10:11),each=4))
A<-c(rep(0,8))
B<-c(rep(0,8))
C<-c(rep(0,8))
D<-c(rep(0,8))
wpc<-cbind(wp,A,B,P,Q)
SPDs<-rbind(Fac,spa,wpa,wpc)
############################################

# Example 34 p. 438
library(daewr)
EEw1s2( )
EE15R5WP<-EEw1s2('EE15R5WP')
EE15R5WP
# extra  example fitting model with this design
# sample data
y<-c(-0.714811191,-0.829505189,-0.848985975,-0.110751257,1.4710031138,-0.611644758,
     -1.087524003,0.8956219826,-0.130413701,-0.735548889,-0.129036864,-0.534510763,
     -0.004106583,0.204772326,-0.302557987)
EE15R5WP<-data.frame(EE15R5WP,y)
colnames(EE15R5WP)<-c('WP','A','P','Q','y')
# fit the model with \texttt{lmer} function in the \texttt{lme4} package
modre<-lmer(y~A+I(A^2)+(1|WP)+P+I(P^2)+Q+I(Q^2)+A:P+
              A:Q+P:Q,data=EE15R5WP)
summary(modre)
# fit the model with the \texttt{rsm} function in the \texttt{rsm} package
modls<-rsm(y~SO(A,P,Q),data=EE15R5WP)
summary(modls)


# From JoAnn Alvarez

require(rms)
set.seed(1)
age <- rnorm(200,40,12)
sex <- factor(sample(c('female','male'),200,TRUE))
logit <- (sex=='male') + (age-40)/5
y <- ifelse(runif(200) <= plogis(logit), 1, 0)
f <- lrm(y ~ pol(age,2)*sex)
anova(f)
# Compare a 30 year old female to a 40 year old male
# (with or without age x sex interaction in the model)
contrast(f, list(sex='female', age=30), list(sex='male', age=40))
# Test for interaction between age and sex, duplicating anova
contrast(f, list(sex='female', age=30),
            list(sex='male',   age=30),
            list(sex='female', age=c(40,50)),
            list(sex='male',   age=c(40,50)), type='joint')
# Duplicate overall sex effect in anova with 3 d.f.
contrast(f, list(sex='female', age=c(30,40,50)),
            list(sex='male',   age=c(30,40,50)), type='joint')

jim <- contrast(f, list(sex = "male", age=30),
                   list(sex = "male", age=40))
print(jim, fun = exp)
jane <- contrast(f, list(sex = c("male", "female"), age=30),
                    list(sex = c("male", "female"), age=40))
print(jane, fun = exp)

# From http://stats.stackexchange.com/questions/191063/lrm-and-orm-contrast-rms-package

require(rms)
set.seed(1)
x <- factor(rbinom(100,2,0.6), labels = c("a","b","c"), ordered = TRUE)
y <- factor(rbinom(100,1,0.5), labels=c("no","yes"))
f <- lrm(x ~ y)
g <- orm(x ~ y)
coef(f); coef(g)

print(contrast(f, list(y='no'), list(y='yes')), X=TRUE)
print(contrast(g, list(y='no'), list(y='yes')), X=TRUE)


=begin
  # sample-group01.rb

  require "algebra"
  e = Permutation[0, 1, 2, 3, 4]
  a = Permutation[1, 0, 3, 4, 2]
  b = Permutation[0, 2, 1, 3, 4]
  p a * b #=> [2, 0, 3, 4, 1]

  g = Group.new(e, a, b)
  g.complete!
  p g == PermutationGroup.symmetric(5) #=> true

((<_|CONTENTS>))
=end


A <- matrix(c(3,1,4,1),ncol = 2)
mat <- A
for(i in 1:99){
	mat <- (mat %*% A)
}
print(mat)

# inspired by:
# https://www.youtube.com/watch?v=PFDu9oVAE-g&list=PLZHQObOWTQDPD3MizzM2xVFitgF8hE_ab&index=13
# 14 min, 30 seconds

B <- matrix(c(3,0,0,2), ncol = 2)
mat2 <- B
for(i in 1:99){
	mat2 <- (mat2 %*% B)
}
print(mat2)

mat2[1,1] == 3^100 #true
mat2[2,2] == 2^100 #true


# Master Thesis Project - Extreme Value Theory
# Looking into the distribution of B^(n)[t]
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/randomWalk.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/Epsilon_is.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brokenLine.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache5/brownianMotion.r")

# Let the user enter the time horizon of the brownian motion
cat("Time step ?")
t <- as.numeric(readline("t :\n"))

# Number of trials
cat("Sample size ?")
N <- as.numeric(readline("N :\n"))

# n must be large for B^(n)[t] to be a good approximation of B[t]
n <- 1000

# Generating the Brownian Motion
BM_vect <- rep(0,N)
for (i in 1:N) {
	BM_vect[i] <- (brownianMotion(t,1/n))[floor(n*t)]
}

# Plot the Brownian Motion
quartz()

title <- paste("Sample from a distribution", expression(B[t]^(n)), " with t = ", t)

hist(BM_vect, main = "Density plot", freq = FALSE, col = "lightgreen")
curve(dnorm(x, mean = mean(BM_vect), sd = sd(BM_vect)), add = TRUE, col = "darkblue", lwd = 4)
print(var(BM_vect))
curve(dnorm(x, mean = 0, sd = sqrt(t)), add = TRUE, col = "red", lwd = 4)


# Hankui in SDSU
# source("build_graph.r");

# build the CNN structure
## con_indicator (2 or 4) indicates the whether convolution is used or not
## is_shallow indicates the DNN structure
# input_dim_x=13; input_dim_y=3;

source("cnn.common.r");

#************************************************************************************************************************
## non-linear activation function
## type = 0: RELU
## type = 1: parametric RELU He et al. 2015
## type = 6: RELU6
non_linear <- function(x, ndim=shape(100), type=1) {
	alphas <- tf$Variable(tf$ones(1L)*0.25);
	if (type==1) {
		pos <- tf$nn$relu(x);
		# neg <- alphas * (x - abs(x)) * 0.5; ## not work
		# neg <- (x - abs(x)) * 0.5; ## work
		# neg <- tf$scalar_mul(alphas, (x - abs(x)) * 0.5 ); ## not work
		neg <- tf$multiply(alphas, (x - abs(x)) * 0.5 ); ## work
		result <- pos + neg;
	} else if (type==6) {
		result <- tf$nn$relu6(x);
	} else result <- tf$nn$relu(x);

	result
}

#************************************************************************************************************************
## a neural network unit including a linear transformation (convolution/fully connection) and a non-linear function
## leftwidth*leftlength*n1 representing the dimension of the convolution layer to be normalized if is_norm=TRUE and is_con=TRUE
##                      n1 representing the dimension of the fully connected layer to be normalized if is_norm=TRUE and is_con=FALSE
nn_unit <- function (x_image, W_conv1, b_conv1, leftwidth=1, leftlength=11, n1=100, is_norm=TRUE, is_training=TRUE, non.linear.type=0, is_con=TRUE, is_pad=FALSE, is_max_pool=FALSE) {

	# i=1
	# is_training = TRUE
	# x_image=h_convs[[i]]
	# W_conv1=weightlists[[i]]
	# b_conv1=baislists[[i]]
	# leftwidth=left_widths[i]
	# leftlength=left_lengths[i]
	# n1=n_nodes[i]
	# is_training=is_training;
	# non.linear.type=non.linear.type;
	# is_con=TRUE
	# is_pad=FALSE

	if (is_norm) {
		if (is_con) {
			h_cov_nopad_1 <- conv2d_no_pad(x_image, W_conv1, is_pad);
			h_batch_1 <- batch_norm_wrapper(h_cov_nopad_1, is_training, ndim=shape(leftwidth,leftlength,n1) );
			h_conv1 <- non_linear(h_batch_1, type=non.linear.type);
		} else {
			h_fc_last <- tf$matmul(x_image, W_conv1);
			h_batch_last <- batch_norm_wrapper(h_fc_last, is_training, ndim=shape(n1) );
			h_conv1 <- non_linear(h_batch_last, type=non.linear.type);
		}
		# h_conv1 <- tf$nn$relu6(h_batch_1);
	} else {
		if (is_con) {
			h_cov_nopad_1 <- conv2d_no_pad(x_image, W_conv1, is_pad) + b_conv1;
			h_conv1 <- non_linear(h_cov_nopad_1, type=non.linear.type);
		} else {
			h_cov_nopad_1 <- tf$matmul(x_image, W_conv1) + b_conv1;
			h_conv1 <- non_linear(h_cov_nopad_1, type=non.linear.type);
		}
	}
	if (is_max_pool==TRUE) {
		h_conv1_pull <- max_pool_2x2(h_conv1);
		h_conv1 <- h_conv1_pull;
	} else if (is_max_pool==2) {
		# print("Average pooling has been used \n");
		h_conv1_pull <- avg_pool_2x2(h_conv1);
		# h_conv1_pull <- max_pool_2x2(h_conv1);
		# h_conv1_pull <- max_pool_1x2(h_conv1);
		h_conv1 <- h_conv1_pull;
	}
	# h_pool1_in <- max_pool_1x2(h_conv1);
	h_conv1
}

#************************************************************************************************************************
## global variables for building graph
max_depth   <- 21;
weightlists <<- vector("list", max_depth);
baislists   <<- vector("list", max_depth);

#************************************************************************************************************************
## build the graph for training or testing
## con_indicator (2 or 4) indicates the whether convolution is used or not
## is_shallow indicates the DNN structure
# is_training=TRUE;
# input_dim_x=13; input_dim_y=3;
build_graph <- function (con_indicator, is_training=TRUE, x, input_dim_x, input_dim_y, input_dim_z=1L, is_norm=TRUE, is_shallow=TRUE) {

	input_dim_stacked <- input_dim_x*input_dim_y*input_dim_z;
	non.linear.type <- 6;
	non.linear.type <- 1;
	non.linear.type <- 0;
	cat("\tbuild_graph with non.linear.type", non.linear.type, "\n");
	## ***************************************
	## option 2: 2d filter followed by a fully connected layer
	isdim <- FALSE;
	# isdim <- TRUE;
	n_nodes <- vector(mode="integer",  length=max_depth);
	depth <<- 4;
	conv_depth <- depth-2;
	# n1 <- 0L; n2 <- 0L; n3 <- 0L; n4 <- 0L; n5 <- 0L;  n6 <- 0L;  n7 <- 0L;
	if (con_indicator==2) {
		# left_lengths <- vector(mode="integer",  length=max_depth);
		## dimension left after convolution
		left_lengths <- rep(1L, max_depth);
		left_widths <- left_lengths;

		con_dims  <- rep(1L, max_depth);
		con_dim2  <- rep(1L, max_depth);

		con_dims[1  ] <- 3;
		con_dim2[1:6] <- 3;

		n_nodes[1] <- 64L;
		n_nodes[2] <- 128L;
		n_nodes[3] <- 256L;
		# n_nodes[1] <- 128L;
		# n_nodes[2] <- 256L;
		# n_nodes[3] <- 1024L; ## tested on May 23 2018 for simplified VGG accuracy
		left_lengths[1] <- 11L;
		left_lengths[2] <- 9L;
		# left_lengths[3] <- 7L;

		if (is_shallow==FALSE) {
			depth <<- 8;
			conv_depth <- depth-2;

			left_lengths[1] <- 11L;
			left_lengths[2] <- 9L;
			left_lengths[3] <- 7L;
			left_lengths[4] <- 5L;
			left_lengths[5] <- 3L;
			left_lengths[6] <- 1L;

			n_nodes[1] <- 128L;
			n_nodes[1] <- 64L; ## revised on Nov 1 2018
			n_nodes[2] <- 128L;
			n_nodes[3] <- 256L;
			n_nodes[4] <- 256L;
			n_nodes[5] <- 512L;
			n_nodes[6] <- 512L;
			n_nodes[7] <- 1024L;
		} else if (is_shallow==5) {
			depth <<- 19;
			conv_depth <- depth-3;## note this has been changed from depth-2 to depth-3 on June 20, 2018
			left_widths[1:1 ] <- 3;

			con_dims[1:2 ] <- 3;
			con_dim2[1:17] <- 3;

			left_lengths[1 ] <- 13L;
			left_lengths[2 ] <- 11L;
			left_lengths[3 ] <- 11L;
			left_lengths[4 ] <- 9L;
			left_lengths[5 ] <- 9L;
			left_lengths[6 ] <- 9L;
			left_lengths[7 ] <- 9L;
			left_lengths[8 ] <- 7L;
			left_lengths[9 ] <- 7L;
			left_lengths[10] <- 7L;
			left_lengths[11] <- 5L;
			left_lengths[12] <- 5L;
			left_lengths[13] <- 5L;
			left_lengths[14] <- 3L;
			left_lengths[15] <- 3L;
			# left_lengths[16] <- 3L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 1 to 3
			left_lengths[16] <- 1L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 3 to 1 on June 20, 2018
			left_lengths[17] <- 1L;

			n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
			n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
			n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0; n_nodes[ 8] <- n0;
			n0 <- 512 ; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0; n_nodes[14] <- n0; n_nodes[15] <- n0; n_nodes[16] <- n0;
			n0 <- 1024; n_nodes[17] <- n0; n_nodes[18] <- n0;
		}

		# is_use_pooling = 2;
		# is_use_pooling = TRUE;
		is_use_pooling = FALSE;
		if (is_use_pooling>=1) {
			con_dims[1:2] <- 3;
			con_dim2[1:6] <- 3;

			n_nodes[1] <- 64L;
			n_nodes[2] <- 128L;
			n_nodes[3] <- 256L;
			left_lengths[1] <- 13L;
			left_lengths[2] <- 7L;
			left_lengths[3] <- 4L;
			left_widths[1] <- 3L;
			left_widths[2] <- 2L;
			left_widths[3] <- 1L;

			if (is_shallow==FALSE) {
				depth <<- 7;
				conv_depth <- depth-2;
				con_dims[1:3] <- 3;
				con_dim2[1:5] <- 3;

				left_lengths[1] <- 13L;
				left_lengths[2] <- 7L;
				left_lengths[3] <- 4L;
				left_lengths[4] <- 2L;
				left_lengths[5] <- 1L;

				left_widths[1] <- 3L;
				left_widths[2] <- 2L;
				left_widths[3] <- 1L;

				n_nodes[1] <- 64L;
				n_nodes[2] <- 128L;
				n_nodes[3] <- 256L;
				n_nodes[4] <- 256L;
				n_nodes[5] <- 512L;
				n_nodes[6] <- 1024L;
			} else if (is_shallow==5) {
				depth <<- 16;
				conv_depth <- depth-3;## note this has been changed from depth-2 to depth-3 on June 20, 2018

				con_dims[1:7 ] <- 3;
				con_dim2[1:13] <- 3;

				left_lengths[1 ] <- 13L;
				left_lengths[2 ] <- 13L;
				left_lengths[3 ] <- 13L;
				left_lengths[4 ] <- 7L;
				left_lengths[5 ] <- 7L;
				left_lengths[6 ] <- 7L;
				left_lengths[7 ] <- 4L;
				left_lengths[8 ] <- 4L;
				left_lengths[9 ] <- 4L;
				left_lengths[10] <- 2L;
				left_lengths[11] <- 2L;
				left_lengths[12] <- 2L;
				left_lengths[13] <- 1L;

				left_widths[1 ] <- 3L;
				left_widths[2 ] <- 3L;
				left_widths[3 ] <- 3L;
				left_widths[4 ] <- 2L;
				left_widths[5 ] <- 2L;
				left_widths[6 ] <- 2L;
				left_widths[7 ] <- 1L;

				# left_lengt14hs[1 ] <- 13L;
				# left_lengths[2 ] <- 11L;
				# left_lengths[3 ] <- 11L;
				# left_lengths[4 ] <- 9L;
				# left_lengths[5 ] <- 9L;
				# left_lengths[6 ] <- 9L;
				# left_lengths[7 ] <- 9L;
				# left_lengths[8 ] <- 7L;
				# left_lengths[9 ] <- 7L;
				# left_lengths[10] <- 7L;
				# left_lengths[11] <- 5L;
				# left_lengths[12] <- 5L;
				# left_lengths[13] <- 5L;
				# left_lengths[14] <- 3L;
				# left_lengths[15] <- 3L;
				# left_lengths[16] <- 1L; ## NOTE THAT THIS HAS BEEN CHANGED FROM 3 to 1 on June 20, 2018
				# left_lengths[17] <- 1L;

				n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
				n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
				n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0;
				n0 <- 512 ; n_nodes[ 8] <- n0; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0;
				n0 <- 1024; n_nodes[14] <- n0; n_nodes[15] <- n0;
			}
		} ## pooling is true

		## weights and bias
		for (i in 1:depth) {
			scale_factor <- 2;
			if (i==1) {
				# weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], 1, n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i]*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], 1, n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i])) );
				baislists  [[i]] <- bias_variable(shape(1, left_lengths[i], n_nodes[i]) );
			} else if (i<=conv_depth) {
				weightlists[[i]] <- weight_variable(shape(con_dims[i], con_dim2[i], n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(con_dims[i]*con_dim2[i]*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, left_lengths[i], n_nodes[i]) );
			} else if (i==(conv_depth+1) ) { ## last convolution layer
				concatenation <- left_widths[i-1] * left_lengths[i-1];
				if (is_use_pooling>=1) concatenation <- ceiling(left_widths[i-1]/2) * ceiling(left_lengths[i-1]/2); ## max pool is used
				# weightlists[[i]] <- weight_variable(shape(1 * left_lengths[i-1] * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(concatenation * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, n_nodes[i]) );
			} else if (i<=(depth-1) ) { ## fully connected layers
				# concatenation <- left_widths[i-1] * left_lengths[i-1];
				# if (is_use_pooling) concatenation <- ceiling(left_widths[i-1]/2) * ceiling(left_lengths[i-1]/2); ## max pool is used
				# weightlists[[i]] <- weight_variable(shape(1 * left_lengths[i-1] * n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				weightlists[[i]] <- weight_variable(shape(n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/(1*1*n_nodes[i])) );
				baislists  [[i]] <- bias_variable(shape(1, n_nodes[i]) );
			} else {
				W_fc_n  <- weight_variable(shape(n_nodes[i-1], classn), stddev=sqrt(scale_factor/(1*1*n_nodes[i-1])) );
				b_fc_n  <- bias_variable(shape(classn) );
				weightlists[[i]] <- W_fc_n;
				baislists  [[i]] <- b_fc_n;
			}
		}

		## convolution
		h_conv0 <- tf$reshape(x, shape(-1L, input_dim_y, input_dim_x, input_dim_z));

		h_convs <- list();
		h_convs[[1]] <- h_conv0;
		if (is_use_pooling==FALSE) { ## pooling is NOT used
			if (is_shallow<5) {
				for (i in 1:conv_depth)
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE);
			} else {
				for (i in 1 :1 )
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE);
				for (i in 2:conv_depth)
					h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=(left_lengths[i-1]==left_lengths[i])  );
			}
		} else { ## pooling is used is_max_pool = if (left_widths[i-1]>1 && left_lengths[i-1]>1) { TRUE } else if (left_widths[i-1]==1 && left_lengths[i-1]>1) {2} else {FALSE}
				## revised on Aug 10 2019 for pooling is true
			for (i in 1:conv_depth) {
				# is_max_pool = if (left_widths[i-1]>1 && left_lengths[i-1]>1) { TRUE } else if (left_widths[i-1]==1 && left_lengths[i-1]>1) {2} else {FALSE};
				# is_max_pool = if (left_lengths[i]==left_lengths[i+1]) {FALSE} else { if (left_widths[i]>1 && left_lengths[i]>1) { TRUE } else if (left_widths[i]==1 && left_lengths[i]>1) {2} else {FALSE} };
				is_max_pool <- (left_lengths[i]!=left_lengths[i+1]);
				if (is_max_pool && is_use_pooling==2) is_max_pool <- 2;
				h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE, is_max_pool=is_max_pool);
			}
		}
		## fully connected layer
		# h_pool2_flat <- tf$reshape(h_convs[[conv_depth+1]], shape(-1L, 1 * left_lengths[conv_depth] * n_nodes[conv_depth]));
		h_pool2_flat <- tf$reshape(h_convs[[conv_depth+1]], shape(-1L, concatenation*n_nodes[conv_depth]));
		h_convs[[conv_depth+1]] <- h_pool2_flat;

		for (i in (conv_depth+1):(depth-1) )
			h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftlength=left_lengths[i], n1=n_nodes[i], is_norm=is_norm, is_training=is_training, non.linear.type=non.linear.type, is_con=FALSE);

		if (isdim) {
			cat("W_fc_n: ") ; get_dim(W_fc_n);
			cat("b_fc_n: ") ; get_dim(b_fc_n);
			cat("y_conv: ") ; get_dim(y_conv);
			stop("Stop because of isdim CHECK");
		}

	}

	## ***************************************
	## option 4: only contain fully connected layers
	if (con_indicator==4) {
		conv_depth <- 0;
		## ***************************************
		## option 4: only one filter is applied
		if (is_shallow==TRUE) {
			n0 <- 256L;
			n1 <- 512L;
			nn <- 512L; ## S2: z=256; x=512; 39*z+ z* x + x* x + x* 15 (410880): ?
			n_nodes[1] <- n0;
			n_nodes[2] <- n1;
			n_nodes[3] <- n1;
		} else if (is_shallow==FALSE) {
			depth <<- 8;
			n0 <- 256L;
			n1 <- 512L;
			nn <- 1024L; ## S2: z=256; x=512; y=1024L; 39*x + x* x + x* x + x* x + x* x + x* y + y*y + y*15 (2656768): 84.5174%
			##S3: z=256L; x=512L; y=1024L; 39*z + z* z + z* z + z* x + x* x + x* y + y*y + y*15 (2122496)

			n_nodes[1] <- n0;
			n_nodes[2] <- n0;
			n_nodes[3] <- n0;
			n_nodes[4] <- n1;
			n_nodes[5] <- n1;
			n_nodes[6] <- nn;
			n_nodes[7] <- nn;
		} else {
			depth <<- 19;
			n0 <- 64  ; n_nodes[ 1] <- n0; n_nodes[ 2] <- n0;
			n0 <- 128 ; n_nodes[ 3] <- n0; n_nodes[ 4] <- n0;
			n0 <- 256 ; n_nodes[ 5] <- n0; n_nodes[ 6] <- n0; n_nodes[ 7] <- n0; n_nodes[ 8] <- n0;
			n0 <- 512 ; n_nodes[ 9] <- n0; n_nodes[10] <- n0; n_nodes[11] <- n0; n_nodes[12] <- n0; n_nodes[13] <- n0; n_nodes[14] <- n0; n_nodes[15] <- n0; n_nodes[16] <- n0;
			# n0 <- 4096; n_nodes[17] <- n0; n_nodes[18] <- n0;
			n0 <- 1024; n_nodes[17] <- n0; n_nodes[18] <- n0;
		}

		## weights and bias
		widths0 <- input_dim_stacked;
		# weightlists <- list();
		# baislists <- list();
		for (i in 1:depth) {
			scale_factor <- 2;
			if (i==1) {
				weightlists[[i]] <<- weight_variable(shape(widths0, n_nodes[i]), stddev=sqrt(scale_factor/n_nodes[i]) );
				baislists  [[i]] <<- bias_variable(shape(n_nodes[i]) );
			} else if (i<=depth-1) {
				weightlists[[i]] <<- weight_variable(shape(n_nodes[i-1], n_nodes[i]), stddev=sqrt(scale_factor/n_nodes[i]) );
				baislists  [[i]] <<- bias_variable(shape(n_nodes[i]) );
			} else {
				W_fc_n  <- weight_variable(shape(n_nodes[i-1], classn), stddev=sqrt(scale_factor/n_nodes[i-1]) );
				b_fc_n  <- bias_variable(shape(classn) );
				weightlists[[i]] <<- W_fc_n;
				baislists  [[i]] <<- b_fc_n;
			}
		}

		## convolution / non-linear functions
		h_conv0 <- tf$cast(tf$reshape(x, shape(-1L, widths0)), tf$float32);

		h_convs <- list();
		h_convs[[1]] <- h_conv0;
		for (i in 1:(depth-1) )
			h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftlength=left_lengths[i], n1=n_nodes[i], is_norm=is_norm, is_training=is_training, non.linear.type=non.linear.type, is_con=FALSE);

		## softmax layer
		h_fc_n_drop <- h_convs[[depth]];

		## final layer
		# y_conv <- tf$nn$softmax(tf$matmul(h_fc_n_drop, W_fc_n) + b_fc_n);

		if (isdim) {
			cat("W_fc2 : ") ; get_dim(W_fc2 );
			cat("b_fc2 : ") ; get_dim(b_fc2 );
			cat("y_conv: ") ; get_dim(y_conv);
			stop("Stop because of isdim CHECK");
		}
	}

	# last_active <- tf$matmul(h_convs[[depth]], W_fc_n);
	last_active <- tf$matmul(h_convs[[depth]], W_fc_n) + b_fc_n;
	last_mean <- tf$reduce_mean(last_active, 1L);
	y_conv  <- tf$nn$softmax(last_active);

	## regularizer
	regularizer <- 0;
	# for (i in 1:(depth-1) )  {
		# if (i<=conv_depth) {
			# regularizer <- regularizer+tf$nn$l2_loss(weightlists[[i]]);
		# } else regularizer <- regularizer+10*tf$nn$l2_loss(weightlists[[i]]);
	# }
	# regularizer <- regularizer+10*tf$nn$l2_loss(W_fc_n);

	for (i in 1:(depth-1) )  {
		regularizer <- regularizer+tf$nn$l2_loss(weightlists[[i]]);
	}
	regularizer <- regularizer+tf$nn$l2_loss(W_fc_n);

	## print information
	cat("\tcon_indicator =", con_indicator, "depth =", depth, "conv_depth =", conv_depth, "is_use_pooling =", is_use_pooling, "\n\t");
	for (i in 1:(depth-1) ) cat("width[", i, "] = ", n_nodes[i], "  ", sep="");
	cat("\n");
	# if (con_indicator==2) cat("\t\tn3 = ", n3, "n4 = ", n4, "n5 = ", n5, "n6 = ", n6, "\n");

	list("y_conv"=y_conv, "regularizer"=regularizer, "last_active"=last_active, last_mean="last_mean")
}

			# if (is_shallow<6) {
				# i = 1;
				# is_max_pool = TRUE;
				# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE, is_max_pool=is_max_pool);
			# } else {
				# for (i in 1 :1 )
					# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=TRUE);
				# for (i in 2:conv_depth)
					# h_convs[[i+1]] <- nn_unit(h_convs[[i]], weightlists[[i]], baislists[[i]], leftwidth=left_widths[i], leftlength=left_lengths[i], n1=n_nodes[i], is_training=is_training, is_con=TRUE, is_pad=(left_lengths[i-1]==left_lengths[i])  );
			# }


library(FinancialMath)

# kapital pozostajacy do splacenia
kapital <- 45058.08

# liczba pozostalych rat
lba_pozostalych_rat <- 185

# oprocentowanie
oprocentowanie <- c(2.35, 2.45)

# liczba dni w jakich obowiazywalo oprocentowanie
# 20.01.2021  ZMIANA WYSOKOSCI ODSETEK
dni_oprocentowania <- c(20, 11)

##########################################
#
#               rata #175
#
##########################################

oprocentowanie <- oprocentowanie / 100
rata <- amort.period(Loan = kapital, n = lba_pozostalych_rat, i = oprocentowanie[2], ic = 12, pf = 12)
rata <- round(rata[2], digits = 2)

# obliczanie raty kapitalowej przy zalozeniu ze przez caly okres obowiazuje oprocentowanie docelowe
rata_odsetkowa_doc <- round(kapital * sum(dni_oprocentowania) / 365 * oprocentowanie[2], digits = 2)
rata_kapitalowa <- rata - rata_odsetkowa_doc

# oblicanie faktycznej raty odsetkowej
rata_odsetkowa <- kapital * dni_oprocentowania / 365 * oprocentowanie
rata_odsetkowa <- round(sum(rata_odsetkowa), digits = 2)

cat("rata_kapitalowa[175] = ", rata_kapitalowa, "\n")
cat("rata_odsetkowa[175] = ", rata_odsetkowa, "\n")
cat("rata[175] = ", rata_kapitalowa + rata_odsetkowa, "\n")
cat("rata[176+] = ", rata, "\n")