## DEPENDENCY	###################################################################################
source("https://raw.githubusercontent.com/oltkkol/vmod/master/rlibrary_dependency.r", encoding="UTF-8")

## functions	###################################################################################

## L2 Norm
l2 <- function(r) sqrt( sum(r**2) )
l2Norm <- function(r) r/l2(r)

## Shuffles data frame rows
ShuffleRows	<- function(dataset){
	return ( dataset[sample(nrow(dataset)),] )
}

## Removes given columns from dataset
## Eg:	RemoveGivenColumns(iris, c("Species"))
RemoveGivenColumns <- function(dataset, columnNames){
	return( dataset[ , -which(colnames(dataset) %in% columnNames)] )
}

## Gets dataset with only given columns
## Eg:  KeepOnlyGivenColumns( TITANIC, c("pclass", "survived", "sex", "age") )
KeepOnlyGivenColumns <- function(dataset, columnNames){
	return( dataset[ , which(colnames(dataset) %in% columnNames)] )
}

## Keeps columns in target dataset as in source dataset
KeepOnlyGivenColumnsAsIn <- function(sourceDataset, targetDataset){
	return ( KeepOnlyGivenColumns(targetDataset, colnames(sourceDataset))  )
}

## Removes all rows containing NaN in any column
RemoveAllNanRows <- function(dataset){
	return ( na.omit(dataset) )
}

## Removes all columns with zeros
RemoveAllZeroColumns <- function(dataset){
	return (dataset[, colSums(dataset != 0) > 0])
}

## Removes all columns with zeros
RemoveAllZeroRows <- function(dataset){
	return (dataset[rowSums(dataset != 0) > 0, ])
}

RemoveAllZeroVarianceRows <- function(dataset){
	rowVariances	<- apply(dataset, 1, var)
	nonZeroRows		<- which( rowVariances != 0 )

	return ( dataset[nonZeroRows, ] )
}

RemoveAllZeroVarianceCols <- function(dataset){
	colVariances	<- apply(dataset, 2, var)
	nonZeroCols		<- which( colVariances != 0 )

	return ( dataset[,nonZeroCols ] )
}

## Clears dataset: Removes all rows with NaN and all columns with 0s only
ClearDataset <- function(dataset){
	return ( RemoveAllZeroColumns(RemoveAllNanRows(dataset)) )
}

## Gets named list of X (features) and Y (targets) from given dataset
## Eg: GetXAndY(iris, "Species")
GetXAndY <- function(dataset, targetColumnName){
	X = RemoveGivenColumns(dataset, c(targetColumnName))
	X = apply(X, 2, FUN=as.numeric)
	Y = as.factor(  KeepOnlyGivenColumns(dataset, c(targetColumnName)) )

	return ( list(X = X, Y = Y ) )
}

## Splits dataset into training and testing by ratio with class ratio preserved in both sets
## Eg:	SplitDataSetTrainTest(iris, "Species", 2/3)
SplitDataSetTrainTest <- function(dataset, targetColumnName, ratio, shuffle=T){
	if (shuffle == T){
		dataset = ShuffleRows(dataset)
	}

	mask <- sample.split( dataset[,targetColumnName], SplitRatio=ratio, group=dataset[,targetColumnName] )

	trainingDataSet	<- dataset[which(mask == TRUE),]
	testingDataSet	<- dataset[which(mask == FALSE),]

	return ( list(trainingData = trainingDataSet, testingData = testingDataSet) )
}

## Returns dataset with balanced classes
## Eg: ClassesToSameCount(iris[-(1:45), ], "Species")
ClassesToSameCount <- function(dataset, targetColumnName){
	newDataSet	<- data.frame()
	classes		<- as.factor( dataset[, targetColumnName] )
	leastSize	<- min( table(classes) )

	for(c in levels(classes)){
		classRows	<- which(classes == c)
		toLet		<- classRows[ sample( leastSize) ]

		newDataSet	<- rbind(newDataSet, dataset[toLet,])
	}

	return( newDataSet )
}

## Splits dataset into train and test datasets (by trainToTestRatio) preserving class balance (by targetColumnName).
## Rows can be shuffled before. Datasets can be scaled by scaleBy parameter "none"/"minmax"/"z-score".
## Columns with zero variances in training dataset are removed from both sets.
## Returns named list with $Train, $Test datasets with Features $X and Targets $Y names. Scaling info in $ScaleInfo.
## Eg: PrepareTrainAndTest(iris, "Species", 2/3, shuffle=T, scaleBy="z-score")
PrepareTrainAndTest <- function(dataset,
								targetColumnName,
								trainToTestRatio=2/3,
								shuffle=T,
								scaleBy="none",
								convertToFactors=F,
								allClassesSameSize=T){

	if (allClassesSameSize == T){
		dataset <- ClassesToSameCount(dataset, targetColumnName)
	}

	splitDataset <- SplitDataSetTrainTest(dataset, targetColumnName, trainToTestRatio, shuffle)

	train		<- GetXAndY(splitDataset$trainingData,	targetColumnName)
	test		<- GetXAndY(splitDataset$testingData,	targetColumnName)

	# remove zero value features (caused eg. by train/test split), apply to test
	newTrainX		<- RemoveAllZeroColumns(train$X)
	newTestX		<- KeepOnlyGivenColumns(test$X, colnames(newTrainX))

	train$X			<- as.data.frame( newTrainX )
	test$X			<- as.data.frame( newTestX )

	# scale
	scaledDatasets	<- ScaleDatasets(train, test, scaleBy=scaleBy)
	train			<- scaledDatasets$Train
	test			<- scaledDatasets$Test

	if (convertToFactors == T){
		train$X		<- DataFrameToFactor(train$X)
		test$X		<- DataFrameToFactor(test$X)
	}

	# remove zero variance features (caused eg. by train/test split), apply to test
	train$X <- RemoveAllZeroVarianceCols(train$X)
	test$X  <- KeepOnlyGivenColumns(test$X, colnames(train$X))

	return ( list(Train = train, Test = test, ScaleInfo = scaledDatasets$ScaleInfo ) )
}

## Scales train and test dataset by zscore/minmax w.r.t. train dataset
## Eg: scaledDatasets <- ScaleDatasets(train, test, scaleBy=scaleBy)
ScaleDatasets <- function(trainDataset, testDataset, scaleBy="z-score"){
	trainX			<- trainDataset$X
	testX			<- testDataset$X
	n				<- ncol(trainX)
	trainXColNames	<- colnames(trainX)

	if ( scaleBy == "min-max" || scaleBy == "minmax" ){
		trainColsRange	<- apply(trainX, 2, FUN=function(r) max(r) - min(r) )
		trainColsMin	<- apply(trainX, 2, FUN=min)

		scaledTrainX	<- sapply(1:n, function(col) (trainX[,col] - trainColsMin[col])/trainColsRange[col] )
		scaledTestX		<- sapply(1:n, function(col) (testX[,col]  - trainColsMin[col])/trainColsRange[col] )
		scaleInfo		<- list( Min = trainColsMin, Range = trainColsRange )

	}else if ( scaleBy == "z-score" || scaleBy == "zscore" ){
		trainColsSd		<- apply(trainX, 2, FUN=sd)
		trainColsMean	<- apply(trainX, 2, FUN=mean)

		scaledTrainX	<- sapply(1:n, function(col) (trainX[,col] - trainColsMean[col])/trainColsSd[col] )
		scaledTestX		<- sapply(1:n, function(col) (testX[,col]  - trainColsMean[col])/trainColsSd[col] )
		scaleInfo		<- list( Sd = trainColsSd, Mean = trainColsMean )

	}else if ( scaleBy == "binarize" || scaleBy == "bin" ){
		scaledTrainX	<- BinarizeDataFrame(trainX)
		scaledTestX		<- BinarizeDataFrame(testX)
		scaleInfo		<- list()

	}else{
		scaledTrainX	<- trainX
		scaledTestX		<- testX
		scaleInfo		<- list()
	}

	colnames(scaledTrainX)	<- trainXColNames
	colnames(scaledTestX)	<- trainXColNames

	outputTrain		<- list( X = scaledTrainX,	Y = trainDataset$Y)
	outputTest		<- list( X = scaledTestX, 	Y = testDataset$Y )

	return ( list(Train = outputTrain, Test = outputTest, ScaleInfo = scaleInfo  ) )
}

BinarizeDataFrame <- function(df){
	return ( as.data.frame( (df>0)+0 ) )
}

DataFrameToFactor <- function(df){
	return( data.frame(lapply(df, as.factor)) )
}

## Calculates confusion table for given model and given test data
PredictAndMakeConfussionMatrix <- function(model, testData, predTransformFunction=NULL){
	yHat <- predict(model, testData$X)

	if ("class" %in% names( yHat )){
		yHat <- yHat$class
	}

	if (!is.null(predTransformFunction)){
		yHat <- predTransformFunction(yHat)
	}

	return ( table(testData$Y, yHat) )
}

CalculateStatisticsForConfusionMatrix <- function(cm){
	n			= sum(cm) # number of instances
	nc			= nrow(cm) # number of classes
	diag		= diag(cm) # number of correctly classified instances per class
	rowsums 	= apply(cm, 1, sum) # number of instances per class
	colsums 	= apply(cm, 2, sum) # number of predictions per class
	p = rowsums / n # distribution of instances over the actual classes
	q = colsums / n # distribution of instances over the predicted classes

	accuracy		= sum(diag) / n
	precision		= diag / colsums
	recall			= diag / rowsums
	f1				= 2 * precision * recall / (precision + recall)

	expAccuracy		= sum(p*q)
	kappa			= (accuracy - expAccuracy) / (1 - expAccuracy)

	return (
		list( Accuracy		= accuracy,
			PrecisionMean	= mean(precision),
			RecallMean		= mean(recall),
			F1Mean			= mean(f1),
			Kappa			= kappa)
	)
}

## Calculates confusion matrix and all other statistics for model and testing data
EvaluateModel <- function(model, testData, predTransformFunction=NULL){
	cm = PredictAndMakeConfussionMatrix(model, testData, predTransformFunction)
	return (
		list(
			Confusionmatrix	= cm,
			Statistics		= CalculateStatisticsForConfusionMatrix(cm)
		)
	)
}

EvaluateModelAndPlot <- function(model, trainData, testData, predTransformFunction=NULL, newWindow=T){
	if (newWindow) x11()

	resultTrain <- EvaluateModel(model, trainData, predTransformFunction)
	resultTest	<- EvaluateModel(model, testData,  predTransformFunction)

	layout(matrix(c(1,1,1,1,2,3,4,5), nrow=2, byrow=T))
	data <- round( rbind( unlist(resultTrain$Statistics), unlist(resultTest$Statistics) ), 3)
	bp <- barplot(data , beside=T, ylim=c(0,1), legend.text=c("Train", "Test"), main=model$call, col=c("grey80", "grey95"))
	text(bp, data, labels=data, pos=1)
	barplot(table(trainData$Y)/length(trainData$Y), main="Train Ys Ratios [%]")
	barplot(table(testData$Y) /length(testData$Y) , main="Test Ys Ratios [%]")
	PlotConfusionMatrix(resultTrain$Confusionmatrix, "Train Confusion")
	PlotConfusionMatrix(resultTest$Confusionmatrix, "Test Confusion")
}

PlotConfusionMatrix <- function(confusionMatrix, title){
	N <- ncol(confusionMatrix)
	x <- confusionMatrix

	image( 1:N, 1:N, -(x[, N:1]),
			col=colorRampPalette(c(hsv(h = 0, s = 0.9, v = 0.9, alpha = 1),
									hsv(h = 0, s = 0, v = 0.9, alpha = 1),
									hsv(h = 2/6, s = 0.9, v = 0.9, alpha = 1)))(41),
			xlab="", ylab='', xaxt='n', yaxt='n', main=title, zlim=c(-10, 10) )

	axis(1, at=1:N, labels=paste(colnames(x), "'", sep=""))
	axis(2, at=N:1, labels=colnames(x), las=1)
	abline(h = 0:N + 0.5, col = 'gray')
	abline(v = 0:N + 0.5, col = 'gray')
	text(1:N, rep(N:1, each=N), labels = as.vector(x))
	box(lwd=2)
}

EvaluateModelsAndGetBest <- function(models, data, metricName = "Kappa"){
	bestModel	<- NULL
	bestValue	<- 0

	for (model in models){
		value <- EvaluateModel(model, data)$Statistics[[metricName]]
		if (value > bestValue){
			bestModel <- model
			bestValue <- value
		}
	}

	return( list(Value = bestValue, Model = bestModel) )
}

## Returns top N variables used for className by Naive Bayes model.
InspectNaiveBayes <- function(trainedNaiveBayes, className, topDecisiveCount=20){
	output				<- data.frame(stringsAsFactors=FALSE)
	variableNames		<- names(trainedNaiveBayes$tables)

	for(i in 1:length(trainedNaiveBayes$tables)){
		toAdd <- NULL
		value <- trainedNaiveBayes$tables[[i]]

		if ("1" %in% colnames(value)) {
			x <- value[,"1"][className]
			if (x != 0){
				output <- rbind( output, cbind(variableNames[i], x) )
			}
		}
	}

	rownames(output)	<- NULL
	colnames(output)	<- c("Variable", "P")
	topDecisiveCount	<- min(topDecisiveCount, nrow(output))
	output 				<- output[order(as.numeric( output$P )), ]

	return(output[1:topDecisiveCount, ])
}

## Trains and evaluates any model with train and test data (list of X, Y), returns named list with trained model & statistics
## Eg.: TrainAndEvalute(svm, train, test, kernel="linear")
TrainAndEvalute	<- function(technique, trainData, testData, ...){
	model <- technique(trainData$X, trainData$Y, ...)
	return (list(
		Model			= model,
		TrainEvaluation	= EvaluateModel(model, trainData),
		TestEvaluation	= EvaluateModel(model, testData)
	))
}

###################################################################################################
stop_quietly();

## 1. Simple Examples		#######################################################################

## IRIS
datasets	<- PrepareTrainAndTest(iris, "Species", 3/4)
train		<- datasets$Train
test		<- datasets$Test

model		<- svm(train$X, train$Y, kernel='linear')

EvaluateModel(model, train)
EvaluateModel(model, test)

EvaluateModelAndPlot(model, train, test)

## SONAR
data(Sonar)
dataset		<- Sonar
datasets	<- PrepareTrainAndTest(dataset, "Class", 2/3, scaleBy="minmax")

modelBayes	<- naiveBayes(datasets$Train$X, datasets$Train$Y)
modelSVM	<- svm(datasets$Train$X, datasets$Train$Y, kernel="radial")

EvaluateModelAndPlot(modelBayes,	datasets$Train, datasets$Test)
EvaluateModelAndPlot(modelSVM,		datasets$Train, datasets$Test)

##	2. MORE ADVANCED	###########################################################################

# TITANIC
titanic				<- read.csv("G:/VMOD/Datasety/titanic.txt")

#  - clear data
dataset				<- KeepOnlyGivenColumns( titanic, c("pclass", "survived", "sex", "age") )
dataset				<- RemoveAllNanRows(dataset)

dataset$sex			<- as.numeric(dataset$sex)
dataset$survived	<- as.factor(dataset$survived)

#  - prepare train/test
datasets	<- PrepareTrainAndTest(dataset, "survived", trainToTestRatio=2/3, scaleBy="z-score")
train		<- datasets$Train
test		<- datasets$Test

#  - train multiple models
model1		<- svm(train$X, train$Y, kernel='linear')
model2		<- svm(train$X, train$Y, kernel='radial')
model3		<- svm(train$X, train$Y, kernel='polynomial')
model4		<- svm(train$X, train$Y, kernel='sigmoid')
model5		<- lda(train$X, train$Y)
model6		<- qda(train$X, train$Y)
model7		<- naiveBayes(train$X, train$Y)

EvaluateModelAndPlot(model1, train, test)

#  - see best model by Kappa
models			<- list(model1, model2, model3, model4, model5, model6, model7)
bestModelResult <- EvaluateModelsAndGetBest(models, train, "Kappa" )
EvaluateModelAndPlot(bestModelResult$Model, train, test)

## 3.	MORE ADVANCED 	##########################################################################
authors		<- read.table("G:/VMOD/Datasety/BOW_FoglarAsimov_1k.txt", encoding="UTF-8", sep="\t", row.names=1, header=T)
authors		<- RemoveGivenColumns(authors, c("TextName", "TextID"))

datasets	<- PrepareTrainAndTest(authors, targetColumnName="Author", shuffle=T, trainToTestRatio=3/4, scaleBy="none")
train		<- datasets$Train
test		<- datasets$Test

modelNB		<- naiveBayes(train$X, train$Y)
EvaluateModelAndPlot(modelNB, train, test)

modelSVM	<- svm(train$X, train$Y, kernel="linear")
EvaluateModelAndPlot(modelSVM, train, test)

#  Inspect Naive Bayes:
InspectNaiveBayes(modelNB, "Foglar", 20)
InspectNaiveBayes(modelNB, "Asimov", 20)

## 4.	ULTRA FAST	###############################################################################
authors		<- read.csv("G:/VMOD/Datasety/Autori.txt", sep="\t")
dataset		<- KeepOnlyGivenColumns( authors, c("Author", "AVGTOKENLEN", "GINISCOEF", "L") )

datasets	<- PrepareTrainAndTest(dataset, "Author", trainToTestRatio=2/3)
train		<- datasets$Train
test		<- datasets$Test

#  - train multiple models
TrainAndEvalute(svm, train, test, kernel="linear")
TrainAndEvalute(svm, train, test, kernel="radial")
TrainAndEvalute(svm, train, test, kernel="polynomial")
TrainAndEvalute(svm, train, test, kernel="sigmoid")
TrainAndEvalute(lda, train, test)
TrainAndEvalute(naiveBayes, train, test)

output <- c()
for(z in seq(.Machine$double.eps, 2, 0.01)){
	accuracy	<- TrainAndEvalute(svm, train, test, kernel="radial", cost=z)$Train$Statistics$Accuracy
	output		<- rbind(output, c(z, accuracy))
}

plot(output, xlab="cost", ylab="Accuracy")


#Analisis de componentes
#se cargan los datos colocando como parametros que los decimales seran separados por un ","
y<-read.table("datos.txt",header=TRUE,dec=",")
y
#Se realiza el Analisis de de Componentes Principales usando la matriz de Covarianza #
com1<-princomp(y,cor=F)
#Seleccionar cuantas o cuales componentes
summary(com1)
plot(com1)
names(com1)
#Intepretar las componentes
loadings(com1)
#x11()
#graf(com1,2)
x11()
biplot(com1)#no se que significa


#install.packages("TSA")
library(forecast)
library(TSA)
library(zoo)
library(Metrics)
library(stats)
#install.packages("WaveletANN")
library(WaveletANN)
#library(WaveletArima)

zero_reference = 18320 #Difference between 1970-01-01 to 2020-02-29
skip = 38
ts_size = 544     # Number of Sample/Timesteps in entire time series
tr_size = 222 #334 # Number of Samples/Timesteps in Training set 236
te_size = ts_size - tr_size # Number of Samples/Timesteps in Training set 140
horizons = 14  # Number of days to forecast ahead in the future
kt = 1       # Retraining Frequency (No. of Samples)
rt = 0         # Total Number of Retrainings Occured

# Pull in the dataset from given URL
covid_data <- read.csv(file = "2021-08-26-21-42-06-OWID.csv")

dates = covid_data$date
#Convert reponse column into "zoo" object
response_variable = covid_data$new_deaths
response_variable = ifelse(covid_data$new_deaths ==0, 1, covid_data$new_deaths)

dates[skip + tr_size + 1]

covid_ts <- zoo(response_variable, seq(as.Date("2020-01-22"), as.Date("2021-08-25"), by = "days"), frequency = 1)

smape_scores = matrix(data = NA, nrow = horizons, ncol = 22)

forecast_matrix <- matrix(data = c(-1.2), nrow = horizons, ncol = te_size)

for (i in 1:te_size) {
  print(i + " of " + te_size)
  start = i + zero_reference
  model_data <- window(log(covid_ts), start = as.Date(start), end = as.Date(start + tr_size - 1), frequency = 1)

  WaveletForecast<-WaveletFittingann(ts=ts(model_data),Waveletlevels=floor(log(length(model_data))),
                                     boundary='periodic',FastFlag=TRUE,nonseaslag,seaslag,NForecast=14)

  forecasts <- WaveletForecast$Finalforecast
  for (k in 1:horizons) {
    if (k + i - 1 <= te_size) { # Condition to prevent overflow at the end of the test set;
      forecast_matrix[k, k+i-1] = forecasts[k]
    }
  }
}

for(i in 2:horizons){
  for(j in 1:i-1){
    forecast_matrix[i,j] = forecast_matrix[i-1,j]
  }
}
forecast_matrix2 <- t(forecast_matrix)
forecast_matrix2 <- exp(forecast_matrix2)
test_data <- window(covid_ts, start = as.Date((tr_size+1) + zero_reference), end = as.Date(ts_size + zero_reference), frequency = 1)

for (i in 1:horizons) {
  smape_scores[i, p] <- mean(abs((test_data - forecast_matrix2[, i]) / (test_data + forecast_matrix2[, i]))) * 200 #smape formula
  print(paste0("h=",i,",smape=",smape_scores[i,p]))
}
for (i in 1:horizons) {
  smape_scores[i, p] <- mean(abs(test_data - forecast_matrix2[, i]))
  print(paste0("h=",i,",mae=",smape_scores[i,p]))
}


source("src/elicitationIO.r")

sol <- pq2nt_discrete(m=140, p=0.031, q=0.472)

cud1 <- generate_diffusion_discrete(m=100, p=0.058, q=0.543, t_min=0, t_max=20, dt= 1)
cud <- generate_diffusion_discrete(m=100, p=0.058, q=0.543, t_min=0, t_max=20, dt= 0.001)
cuc <- generate_diffusion_continuous(m=100, p=0.058, q=0.543, t_min=0, t_max=20)

system.time({
sol.pq <<-sapply(1:100, function(x) nt2pq_discrete(140, 4.99, 6.26))
})

system.time({
  sol.pq <<-sapply(1:100, function(x) nt2pq_continuous(140, 4.99, 6.26))
})

library(DCGen)

dat <- getDefaultInputData()
show <- showInputData(dat)

ExpA = new_expert("A", "Triangle", c(54.2, 10, 150), "Triangle", c(2.3, 0, 5), "Triangle", c(5.1, 3, 8))
ExpB = new_expert("B", "Triangle", c(158.8, 30, 230), "Triangle", c(5.7, 2, 15), "Triangle", c(9.9, 7, 13))
ExpC = new_expert("C", "Triangle", c(204.4, 30, 410), "Triangle", c(7.1, 2, 10), "Triangle", c(3.5, 2, 6))

experts <- aggregate_experts(list(ExpA, ExpB, ExpC))

pars <- rand_parameters(experts, 300, method='mixture', type='continuous')

cvs <- generate_diffusion_curves(pars, t_max=20)

inp <- list(
  dnShow = T,
  centVal = 70,
  curveType = "stats",
  avgType = "mean"
)

mcvs <- apply(cvs, c(1,2), mean)
mcvs <- round(mcvs, 2)
mcvs <- mcvs[mcvs[, 1] == round(mcvs[, 1]),]
mcvs <- mcvs[seq.int(1, nrow(mcvs), by=max(round(nrow(mcvs)/10), 1)), ]
rownames(mcvs) <- rep("", nrow(mcvs))

library(rmarkdown)
out <- render(input = "report_template.Rmd", #pdf_document()
              #output_format = word_document(),
              output_format=format,
              output_dir="temp",
              output_file=filename,
              envir = list(dat=dat, pars=pars, curves=cvs, mean_curves=mcvs,
                           input=inp))


library(cellrangerRkit)
context('kmeans')

test_matrix = Matrix(matrix(rbinom(200*100, 10, 0.01), 200, 100))

grp1 <- 1:40
grp2 <- 41:100
test_matrix[1:5,grp1] <- 5
test_matrix[6:10,grp2] <- 6

row.names(test_matrix) = sprintf("gene%d", 1:200)
colnames(test_matrix) = sprintf("cell%d", 1:100)

genes = data.frame(id=sprintf("gene%d", 1:200), symbol=sprintf("symbol%d", 1:200))
row.names(genes) = genes$id

cells = data.frame(barcode=sprintf("cell%d", 1:100))
row.names(cells) = cells$barcode

gbm <- newGeneBCMatrix(test_matrix, fd=genes, pd=cells)

pca <- run_pca(gbm, 2)
set.seed(0)
km <- run_kmeans_clustering(pca, 2, nstart=10)

test_that("kmeans works", {
  expect_true(all(km$cluster[grp1] == 1) && all(km$cluster[grp2] == 2) ||
                all(km$cluster[grp1] == 2) && all(km$cluster[grp2] == 1))
} )


library("PerformanceAnalytics")
library("tidyverse")

df <- read.csv("/Users/glmarschmann/.julia/dev/DEBmicroTrait/files/isolates_assimilation_sav1.csv")

df_norm <- df %>%
  filter(transporter_density >1e-8) %>%
  mutate(transporter_density_log = log(transporter_density),
         sav_size_log = log(sav),
         Vmax_log = log(Vmax),
         KD_log = log(KD),
         affinity_log = log(affinity),
         #affinity_log = log(KD/Vmax)
         )

df_numeric <- df_norm[,12:16]
#svg("/Users/glmarschmann/.julia/dev/DEBmicroTrait/final_manuscript/plots/test.svg")
chart.Correlation(df_numeric, histogram=TRUE, label="", method="spearman")
#dev.off()


library(keras)
library(datasets)

mnist <- dataset_mnist()
x_train <- mnist$train$x
y_train <- mnist$train$y
x_test <- mnist$test$x
y_test <- mnist$test$y

# reshape
x_train <- array_reshape(x_train, c(nrow(x_train), 784))
x_test <- array_reshape(x_test, c(nrow(x_test), 784))
# rescale
x_train <- x_train / 255
x_test <- x_test / 255

y_train <- to_categorical(y_train, 10)
y_test <- to_categorical(y_test, 10)

FLAGS <- flags(
    flag_integer("dense_units1",8),
    flag_numeric("dropout1",0.4),
    flag_integer("dense_units2",8),
    flag_numeric("dropout2", 0.3)
)

model <- keras_model_sequential()
model %>%
  layer_dense(units = FLAGS$dense_units1, activation = 'relu', input_shape = c(784)) %>%
  layer_dropout(rate = FLAGS$dropout1) %>%
  layer_dense(units = FLAGS$dense_units2, activation = 'relu') %>%
  layer_dropout(rate = FLAGS$dropout2) %>%
  layer_dense(units = 10, activation = 'softmax')

model %>% compile(
  loss = 'categorical_crossentropy',
  optimizer = optimizer_rmsprop(lr = 0.001),
  metrics = c('accuracy')
)

# Training & Evaluation ----------------------------------------------------

history <- model %>% fit(
  x_train, y_train,
  batch_size = 128,
  epochs = 20,
  verbose = 1,
  validation_split = 0.2
)

plot(history)

score <- model %>% evaluate(
  x_test, y_test,
  verbose = 0
)

cat('Test loss:', score$loss, '\n')
cat('Test accuracy:', score$acc, '\n')


##########
### 3D HIST EXAMPLE:
##########

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

##### Required functions 'binplot' and 'hist3d':

binplot.3d<-function(x,y,z,alpha=1,topcol="#ff0000",sidecol="#aaaaaa")
{
  save <- par3d(skipRedraw=TRUE)
  on.exit(par3d(save))

  x1<-c(rep(c(x[1],x[2],x[2],x[1]),3),rep(x[1],4),rep(x[2],4))
  z1<-c(rep(0,4),rep(c(0,0,z,z),4))
  y1<-c(y[1],y[1],y[2],y[2],rep(y[1],4),rep(y[2],4),rep(c(y[1],y[2],y[2],y[1]),2))
  x2<-c(rep(c(x[1],x[1],x[2],x[2]),2),rep(c(x[1],x[2],rep(x[1],3),rep(x[2],3)),2))
  z2<-c(rep(c(0,z),4),rep(0,8),rep(z,8) )
  y2<-c(rep(y[1],4),rep(y[2],4),rep(c(rep(y[1],3),rep(y[2],3),y[1],y[2]),2) )
  rgl.quads(x1,z1,y1,col=rep(sidecol,each=4),alpha=alpha)
  rgl.quads(c(x[1],x[2],x[2],x[1]),rep(z,4),c(y[1],y[1],y[2],y[2]),
              col=rep(topcol,each=4),alpha=1)
  rgl.lines(x2,z2,y2,col="#000000")
}

hist3d<-function(x,y=NULL,nclass="auto",alpha=1,col="#ff0000",scale=10)
  {
  save <- par3d(skipRedraw=TRUE)
  on.exit(par3d(save))
  xy <- xy.coords(x,y)
  x <- xy$x
  y <- xy$y
  n<-length(x)
  if (nclass == "auto") { nclass<-ceiling(sqrt(nclass.Sturges(x))) }
  breaks.x <- seq(min(x),max(x),length=(nclass+1))
  breaks.y <- seq(min(y),max(y),length=(nclass+1))
  z<-matrix(0,(nclass),(nclass))
  for (i in 1:nclass)
    {
    for (j in 1:nclass)
      {
      z[i, j] <- (1/n)*sum(x < breaks.x[i+1] & y < breaks.y[j+1] &
                            x >= breaks.x[i] & y >= breaks.y[j])
      binplot.3d(c(breaks.x[i],breaks.x[i+1]),c(breaks.y[j],breaks.y[j+1]),
                 scale*z[i,j],alpha=alpha,topcol=col)
      }
    }
}
################################################################################

rgl.open()

rgl.bg(color="gray")
rgl.light()

# Drawing a 'bin' for given coordinates:
binplot.3d(c(-0.5,0.5),c(4.5,5.5),2,alpha=0.6)

# Setting the viewpoint ('theta' and 'phi' have the same meaning as in persp):
rgl.viewpoint(theta=40,phi=40)

# Choosing a lightgrey background:
rgl.bg(col="#cccccc")

##### QUADS FORMING BIN:

# Waiting for user-input to create next scenery:
# readline()

rgl.open()

# Defining transparency and colors:
alpha<-0.7; topcol<-"#ff0000"; sidecol<-"#aaaaaa"

# Setting up coordinates for the quads and adding them to the scene:
y<-x<-c(-1,1) ; z<-4; of<-0.3
x12<-c(x[1],x[2],x[2],x[1]); x11<-rep(x[1],4); x22<-rep(x[2],4)
z00<-rep(0,4); z0z<-c(0,0,z,z); zzz<-rep(z,4); y11<-rep(y[1],4)
y1122<-c(y[1],y[1],y[2],y[2]); y12<-c(y[1],y[2],y[2],y[1]); y22<-rep(y[2],4)

rgl.quads(c(x12,x12,x11-of,x12,x22+of,x12),
          c(z00-of,rep(z0z,4),zzz+of),
          c(y1122,y11-of,y12,y22+of,y12,y1122),
          col=rep(c(rep(sidecol,5),topcol),each=4),alpha=c(rep(alpha,5),1))

# Setting up coordinates for the border-lines of the quads and drawing them:
yl1<-c(y[1],y[2],y[1],y[2]); yl2<-c(y[1]-of,y[1]-of)
xl<-c(rep(x[1],8),rep(x[1]-of,8),rep(c(x[1],x[2]),8),rep(x[2],8),rep(x[2]+of,8))
zl<-c(0,z,0,z,z+of,z+of,-of,-of,0,0,z,z,0,z,0,z,rep(0,4),rep(z,4),rep(-of,4),
      rep(z+of,4),z+of,z+of,-of,-of,rep(c(0,z),4),0,0,z,z)
yl<-c(yl2,y[2]+of,y[2]+of,rep(c(y[1],y[2]),4),y[1],y[1],y[2],y[2],yl2,
      rep(y[2]+of,4),yl2,y[2],y[2],rep(y[1],4),y[2],y[2],yl1,yl2,y[2]+of,
      y[2]+of,y[1],y[1],y[2],y[2],yl1)

rgl.lines(xl,zl,yl,col="#000000")

##### COMPLETE HISTOGRAM:

# Waiting for user-input to create next scenery:
# readline()

rgl.open()

# Choosing a lightgrey background:
rgl.bg(col="#cccccc")

# Setting the rng to a fixed value:
set.seed(1000)

# Drawing a 3d histogramm of 2500 normaly distributed observations:
hist3d(rnorm(2500),rnorm(2500),alpha=0.4,nclass=7,scale=30)


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Optimizing Omega Ration Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Omega
# page 6,9, Optimizing Omega by H. Mausser, D. Saunders, L. Seco
#
# Let x.i , i= 1,...,n  be weights of instruments in the portfolio.
# Let us suppose that j = 1,...,T scenarios of returns are available
# ( r.ij denotes return of i -th asset in the scenario j ).
#
# The Omega function has the form
# MAX [ SUM <over j> 1/T * u.j ]
# [ SUM <over i> r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T
# [ SUM <over j> 1/T * d.j ] = 1
#  u.j, d.j >= 0, for each j = 1,...,T
#
# Binary b.j enforces that only one of u.j or d.j is greter than 0
# u.j <= b.j
# d.j <= 1 - b.j
#' @export
###############################################################################
add.constraint.omega <- function
(
	ia,			# input assumptions
	value,		# b value
	type = c('=', '>=', '<='),	# type of constraints
	constraints	# constraints structure
)
{
	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	n0 = ncol(ia$hist.returns)
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)

	# adjust constraints, add u.j, d.j, t
	constraints = add.variables(2*nt + 1, constraints, lb = c(rep(0,2*nt),-Inf))
		# Aw < b => Aw1 - bt < 0
		constraints$A[n + 2*nt + 1, ] = -constraints$b
		constraints$b[] = 0

		# lb/ub same transformation
		index = which( constraints$ub[1:n] < +Inf )
		if( len(index) > 0 ) {
			a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$ub[1:n])
			constraints = add.constraints(a[, index], rep(0, len(index)), '<=', constraints)
		}

		index = which( constraints$lb[1:n] > -Inf )
		if( len(index) > 0 ) {
			a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$lb[1:n])
			constraints = add.constraints(a[, index], rep(0, len(index)), '>=', constraints)
		}

		constraints$lb[1:n] = -Inf
		constraints$ub[1:n] = Inf

	# [ SUM <over i> r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T
	a = rbind( matrix(0, n, nt), -diag(nt), diag(nt), -omega)
		a[1 : n0, ] = t(ia$hist.returns)
	constraints = add.constraints(a, rep(0, nt), '=', constraints)

	# [ SUM <over j> 1/T * d.j ] = 1
	constraints = add.constraints(c( rep(0,n), rep(0,nt), (1/nt) * rep(1,nt), 0), 1, '=', constraints)

	# objective : Omega
	# [ SUM <over j> 1/T * u.j ]
	constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, nt), rep(0, nt), 0), value, type[1], constraints)

	return( constraints )
}

#' @export
portfolio.omega <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	weight = weight[, 1:ia$n]
	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	portfolio.returns = weight %*% t(ia$hist.returns)
	return( apply(portfolio.returns, 1, function(x) mean(pmax(x - omega,0)) / mean(pmax(omega - x,0)) ) )
}

###############################################################################
# Find portfolio that Maximizes Omega
#' @export
###############################################################################
max.omega.portfolio <- function
(
	ia,				# input assumptions
	constraints,	# constraints
	type = c('mixed', 'lp', 'nlp')
)
{
	n = nrow(constraints$A)
	nt = nrow(ia$hist.returns)
	type = type[1]

	if(type == 'mixed'	|| type == 'lp') {
		sol = optimize.portfolio(ia, constraints, add.constraint.omega, portfolio.omega, 'max', T)

		x = rep(NA, n)
		if(!inherits(sol, 'try-error') && sol$status ==0) {
			x0 = sol$solution[1:n]
			u = sol$solution[(1+n):(n+nt)]
			d = sol$solution[(n+nt+1):(n+2*nt)]
			t = sol$solution[(n+2*nt+1):(n+2*nt+1)]
			x = x0/t
		}
	}

	#portfolio.omega(t(x),ia)
	#sol$value

	if((type == 'mixed' && (sol$status !=0 || any( u*d != 0 ) )) || type == 'nlp') {
		# Try solving problem using Rdonlp2
		if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

		# omega
		fn <- function(x){
			portfolio.returns = x %*% t(ia$hist.returns)
			mean(pmax(portfolio.returns - omega,0)) / mean(pmax(omega - portfolio.returns,0))
		}

		x = optimize.portfolio.nlp(ia, constraints, fn, direction = 'max')
		#portfolio.omega(t(x),ia)
	}

	return( x )
}

###############################################################################
# Create efficient frontier
#' @export
###############################################################################
portopt.omega <- function
(
	ia,						# Input Assumptions
	constraints = NULL,		# Constraints
	nportfolios = 50,		# Number of portfolios
	name = 'Omega'			# Name
)
{
	# set up output
	out = list(weight = matrix(NA, nportfolios, nrow(constraints$A)))
		colnames(out$weight) = rep('', ncol(out$weight))
		colnames(out$weight)[1:ia$n] = ia$symbols

	ef.risk = portopt(ia, constraints, 2)

	# maximum return portfolio
	out$weight[nportfolios, ] = ef.risk$weight[2,]

	# minimum risk portfolio
	out$weight[1, ] = ef.risk$weight[1,]
		constraints$x0 = out$weight[1, ]

	# find points on efficient frontier
	out$return = portfolio.return(out$weight, ia)
	target = seq(out$return[1], out$return[nportfolios], length.out = nportfolios)

	constraints = add.constraints(c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)),
						target[1], type = '<=', constraints)

	for(i in 1:nportfolios ) {
		cat('i =', i, '\n')

		constraints$b[ len(constraints$b) ] = -target[i]
		out$weight[i, ] = max.omega.portfolio(ia, constraints)

			constraints$x0 = out$weight[i, ]
	}

	# compute risk / return
	out$return = portfolio.return(out$weight, ia)
	out$risk = portfolio.risk(out$weight, ia)
	out$name = name

	return(out)
}

###############################################################################
# Plot Omega Ratio for given portfolios (weights)
#' @export
###############################################################################
plot.omega <- function
(
	weight,		# weight
	ia			# input assumptions
)
{
	omegafn = function(x,L) { mean(pmax(x-L,0)) / mean(pmax(L-x,0)) }

	if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega

	weight = weight[, 1:ia$n, drop=F]

	portfolio.returns = weight %*% t(ia$hist.returns)

	threshhold = quantile(portfolio.returns, probs = c(0.05, 0.95))
	threshhold = seq(threshhold[1], threshhold[2], length.out = 100)

	par(mar = c(4,4,2,1), cex = 0.8)
	for(i in 1:nrow(weight)) {
		data = sapply(threshhold, function(L) omegafn(portfolio.returns[i, ], L))

		if(i==1) plot(threshhold,log(data), type='l', col=i,
			xlab='Threshhold', ylab='Log(Omega)', main='Portfolio Omega')
		lines(threshhold, log(data), col=i)
	}
	abline(v = omega, col='orange')
	grid()
	plota.legend(rownames(weight) ,1:nrow(weight), x = 'bottomleft')
}


#' svd
#'
#' Singular value decomposition.
#'
#' @details
#' The factorization works by first forming the crossproduct \eqn{X^T X}
#' and then taking its eigenvalue decomposition.  In this case, the square root
#' of the eigenvalues are the singular values.  If the left/right singular
#' vectors \eqn{U} or \eqn{V} are desired, then in either case, \eqn{V} is
#' computed (the eigenvectors).  From these, \eqn{U} can be reconstructed, since
#' if \eqn{X = U\Sigma V^T}, then \eqn{U = XV\Sigma^{-1}}.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param nu
#' number of left singular vectors to return.
#' @param nv
#' number of right singular vectors to return.
#' @param LINPACK
#' Ignored.
#'
#' @return
#' A list of elements \code{d}, \code{u}, and \code{v}, as with R's own
#' \code{svd()}.  The elements are, respectively, a regular vector, a shaq, and
#' a regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' svd = svd(x)
#' comm.print(svd$d) # a globally owned vector
#' svd$u # a shaq
#' comm.print(svd$v) # a globally owned matrix
#'
#' finalize()
#' }
#'
#' @name svd
#' @rdname svd
NULL

svd.shaq = function(x, retu=FALSE, retv=FALSE)
{
  if (!retu && !retv)
    only.values = TRUE
  else
    only.values = FALSE

  cp = cp.shaq(x)

  ev = eigen(cp, only.values=only.values, symmetric=TRUE)

  d = sqrt(ev$values)

  if (retu)
  {
    # u.local = ev$vectors %*% diag(1/d)
    u.local = sweep(ev$vectors, STATS=1/d, MARGIN=2, FUN="*")
    u.local = Data(x) %*% u.local
    u = shaq(u.local, nrow(x), ncol(x), checks=FALSE)
  }
  else
    u = NULL

  if (retv)
    v = ev$vectors
  else
    v = NULL

  list(d=d, u=u, v=v)
}

#' @rdname svd
#' @export
setMethod("svd", signature(x="shaq"),
  function(x, nu = min(n, p), nv = min(n, p), LINPACK = FALSE)
  {
    n = nrow(x)
    p = ncol(x)

    check.is.natnum(nu)
    check.is.natnum(nv)

    retu = nu > 0
    retv = nv > 0

    ret = svd.shaq(x, retu, retv)

    if (nu && ncol(ret$u) > nu)
      ret$u = ret$u[, 1:nu]

    if (nv && NCOL(ret$v) > nv)
      ret$v = ret$v[, 1:nv]

    ret
  }
)


pi = 3.14159
circle_radius = 10.2
circle_perimeter = 2 * pi * circle_radius
circle_area = pi * circle_radius * circle_radius
cat("Let there be a circle with the radius", circle_radius, "cm.\n")
cat("Then the perimeter of the circle is", circle_perimeter, "cm.\n")
cat("The area of the circle is", circle_area, "cm squared.\n")


# Returns the number of conversions
get_conversions <- function(theta, impressions) {
  k <- ncol(theta)
  y <- rep(0.0, k)
  for (i in 1:k) {
    y[i] <- rbinom(1, size=impressions[i], prob=theta[i])
  }
  return(y)
}

# Returns the probability
get_probability <- function(conversion, impressions) {
  k <- length(conversion)
  theta <- matrix(nrow=1000, ncol=k)
  for (i in 1:k) {
    theta[,i] <- rbeta(1000, shape1=conversion[i]+1, shape2=impressions[i]-conversion[i]+1)
  }
  return(theta)
}

#Compute allocations
get_allocations <- function(theta) {
  k <- ncol(theta)
  allocations <- table(factor(max.col(theta), level=1:k))
  return(allocations/sum(allocations))
}

# COnversion and impressions are cumulative counts
# Assumed conversion rate of each creative for testing
ndays <- 10 #days to simulate
assumed_conversion <- c(0.02, 0.01, 0.01, 0.02)
conversion <- matrix(0, nrow=ndays, ncol=4)
impressions <- matrix(0, nrow=ndays, ncol=4)
impressions[1,] <- c(1000, 0, 0, 0)
next_day_allocations <- matrix(0, nrow=ndays+1, ncol=4)

#Simulating day 1
conversion[1,] <- assumed_conversion * impressions[1,]
theta <- get_probability(conversion[1,], impressions[1,])
y <- get_conversions(theta, impressions[1,])
next_day_allocations[2,] <- get_allocations(theta) * 1000

#Simulating days
for (day in 2:ndays) {
  impressions[day,] <- impressions[day-1,] + next_day_allocations[day,]
  conversion[day,] <- conversion[day-1,] + (assumed_conversion * next_day_allocations[day,])
  theta <- get_probability(conversion[day,], impressions[day,])
  y <- get_conversions(theta, impressions[day,])
  next_day_allocations[day+1,] <- get_allocations(theta) * 1000
}


#' enthalpy
#'
#' Calculates the enthalpy of air/water vapor mixture [kJ/kg]. Inputs are dry-bulb temperature [degC] and humidity ratio [unitless].
#'
#' @param t numeric Air temperature in degC.
#' @param hum_ratio numeric Humidity ratio.
#' @return enthalpy
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  enthalpy
#'
#' @export
#'
#'
#'
#'

enthalpy=function(t,hum_ratio) {
                         ct$assign("t", as.array(t))
                         ct$assign("hum_ratio", as.array(hum_ratio))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=enthalpy(t[i],hum_ratio[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#
# Create example of separable and overlapping distributions for ctmixtures paper
#
library(mixtools)
library(mvtnorm)
library(ggplot2)
library(ggthemes)
library(mmadsenr)
library(gridExtra)
library(ggExtra)

# Separable example
p5 <- rmvnorm(500, c(101, 105))
p5_df <- as.data.frame(p5)
p5_df$class <- "Model 1"

p6 <- rmvnorm(500, c(100, 101))
p6_df <- as.data.frame(p6)
p6_df$class <- "Model 2"

combined_3_df <- rbind(p5_df, p6_df)
nonoverlapping <- ggplot(combined_3_df, aes(x = V1, y = V2))
nonoverlapping <- nonoverlapping + geom_point(aes(color = class)) + xlab("Variable 1") + ylab("Variable 2") + theme_hc() + scale_colour_hc()
nonoverlapping <- nonoverlapping + guides(color = FALSE)
nonoverlapping <- nonoverlapping + ylim(95,110) + xlim(97, 105)
ggMarginal(nonoverlapping, type="histogram")

#grid.arrange(variable1, empty, nonoverlapping, variable2, ncol=2,nrow=2,widths=c(4, 1), heights=c(1, 4))
pdf(file = "../paper/figure/generated/equifinality-variable-effect.pdf", width = 8, height = 8 )
ggMarginal(nonoverlapping, type="histogram")
#grid.arrange(variable1, empty, nonoverlapping, variable2, ncol=2,nrow=2,widths=c(4, 1), heights=c(1, 4))
#arrange_ggplot2(nonoverlapping, variable1, variable2)
dev.off()

# variable1 <- ggplot(combined_3_df, aes(x = V1))
# variable1 <- variable1 + geom_density(aes(color = class), size = 1) + theme_hc() + scale_colour_hc()+ guides(color = FALSE)
# variable1 <- variable1 + theme(axis.text.x= element_blank(), axis.text.y = element_blank(),
#                                axis.title.x = element_blank(), axis.title.y = element_blank(),
#                                panel.grid.major = element_blank(), panel.grid.minor = element_blank())
#
#
# variable2 <- ggplot(combined_3_df, aes(x = V2))
# variable2 <- variable2 + geom_density(aes(color = class), size = 1) + theme_hc() + scale_colour_hc()+ guides(color = FALSE)
# variable2 <- variable2 + theme(axis.text.x= element_blank(), axis.text.y = element_blank(),
#                                axis.title.x = element_blank(), axis.title.y = element_blank(),
#                                panel.grid.major = element_blank(), panel.grid.minor = element_blank())
# variable2 <- variable2 + coord_flip()
#
#
#
# empty <- ggplot()+geom_point(aes(1,1), colour="white")+
#   theme(axis.ticks=element_blank(),
#        panel.background=element_blank(),
#        axis.text.x=element_blank(), axis.text.y=element_blank(),
#        axis.title.x=element_blank(), axis.title.y=element_blank(),panel.grid.major = element_blank(), panel.grid.minor = element_blank())
#
# #grid.arrange(variable1, empty, nonoverlapping, variable2, ncol=2,nrow=2,widths=c(4, 1), heights=c(1, 4))


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6

x = crossprod(matrix(stats::rnorm(30), 10))
xs = fl(x)
y = 1:3
ys = fl(y)
z = cbind(y, rev(y))
zs = fl(z)

test = dbl(backsolve(xs, ys, upper.tri=FALSE))
truth = backsolve(x, y, upper.tri=FALSE)
stopifnot(all.equal(test, truth, tol=tol))

test = dbl(backsolve(xs, ys))
truth = backsolve(x, y)
stopifnot(all.equal(test, truth, tol=tol))

test = dbl(backsolve(xs, ys, k=2))
truth = backsolve(x, y, k=2)
stopifnot(all.equal(test, truth, tol=tol))

test = dbl(backsolve(xs, zs))
truth = backsolve(x, z)
stopifnot(all.equal(test, truth, tol=tol))

test = dbl(backsolve(xs, zs, k=2))
truth = backsolve(x, z, k=2)
stopifnot(all.equal(test, truth, tol=tol))


\name{enriched_score}
\alias{enriched_score}
\title{
Enriched Scores
}
\description{
Enriched Scores
}
\usage{
enriched_score(mat)
}
\arguments{

  \item{mat}{A normalized matrix from \code{\link{normalizeToMatrix}}.}

}
\details{
The function calculates how the signal is enriched in the target by weighting
the distance to the target.

For a numeric vector, assume the vector is denoted as combination of three sub-vectors
\code{c(x1, x2, x3)} with length \code{n1}, \code{n2} and \code{n3},
where \code{x1} are data points in upstream windows, \code{x2} are data points in target windows and
\code{x3} are data points in downstream windows, the enriched score is calcualted as

sum(x_1i* i/n1) + sum(x_3j* (n3 - j + 1)/n3) + sum(x_2k * abs(n2/2 - abs(k - n2/2)))

where the first two terms are the distance to the start or end position of the target
by weighting the distance to the position that if it is closer to the start or end position
of the target, it has higher weight. The second term weight the distance to the center point
of the target and similar, if it is closer to the center position, it has higher weight.
}
\value{
A numeric vector.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
# There is no example
NULL

}


library(ggplot2)

# change these parameters if you wnt
samplesPerExperiment <- 2
nExperiments <- 100000

# generate the experimental data
controls = rnorm(n = samplesPerExperiment*nExperiments, mean = 0, sd = 1)
tests = rnorm(n = samplesPerExperiment*nExperiments, mean = 0, sd = 1)
dim(controls) <- c(samplesPerExperiment, nExperiments)
dim(tests) <- c(samplesPerExperiment, nExperiments)

# this function calculates a t? value
tValue <- function(nSamples1, mean1, var1,
                   nSamples2, mean2, var2) {
    delta <- mean1 - mean2
    stderr <- sqrt(var1/nSamples1 + var2/nSamples2)
    t <- delta / stderr
}

xNorm <- seq(-5, 5, length = 1000)
yNorm <- dnorm(xNorm, mean = 0, sd = 1)
xTDist <- seq(-5, 5, length = 1000)
yTDist <- dt(xTDist, df = 2 * samplesPerExperiment - 2)

# apply the tValue function to the experimental data
tVector <- mapply(tValue,
       apply(controls, 2, length),
       apply(controls, 2, mean),
       apply(controls, 2, var),
       apply(tests, 2, length),
       apply(tests, 2, mean),
       apply(tests, 2, var))

# plot a histogram, centered around zero
mean(tVector)
tVector <- tVector - mean(tVector)
tVector <- tVector[abs(tVector) <= 5]
myPlot <- ggplot() +
    geom_histogram(aes(x = tVector, y = ..density..,
                   fill = "#E69F00"), # orange
                   binwidth = 0.05,
                   color = "white") +
    geom_line(aes(x = xNorm, y = yNorm), color = "#56B4E9") +   # blue
    geom_line(aes(x = xTDist, y = yTDist), color = "#009E73") + # green
    theme(axis.title.x = element_blank()) +
    theme(axis.title.y = element_blank())

# ...profit!
plot(myPlot)


sample1 <- rnorm(100,100,20)
sample2 <- rnorm(100,200,20)
hist(sample1)
hist(sample2)
res <- t.test(sample1,sample2)
res
boxplot(sample1,sample2,col=c("red","green"))
summary(sample1)
summary(sample2)
sessionInfo()


require(rms)
x1 <- runif(100)
x2 <- runif(100)
y  <- x1 + 2 * x2 + 3 * runif(100)
dd <- datadist(x1, x2); options(datadist='dd')
f  <- ols(y ~ x1 * x2)
f
p <- Predict(f, x1, x2, np=20)
bplot(p, lfun=wireframe, col='red')
bplot(p, lfun=wireframe, col='red', xlab='Age (days)', xlabrot=-10,
      cex.lab=1.4)


# Four topographic maps of Rwanda: DEM, slope, aspect and hillshade. Hillshade map shows the topographical shape of hills and mountains using levels of gray on a map. The role of this kind of maps is to display relative slopes, but not absolute height.
# set working directory to data folder
setwd("/Users/pauline/")

############################ -- LOAD PACKAGES -- ############
library(sp)
library(raster)
library(ncdf4)
library(RColorBrewer)
library(sf)
library(tmap)

############################# -- GET DATA -- ######################
# Calculate terrain characteristics
# Elevation data is needed to create a hillshade map. The raster package provides an easy access to the SRTM 90 m resolution elevation data with the getData() function. For example, it is possible to download the elevation data for the whole country of "" using the code below: download the elevation data for the whole country of Rwanda
alt = getData("alt", country = "Rwanda", path = tempdir())

############################# -- Calculate terrain characteristics: SLOPE AND ASPECT -- ######################
# Hillshade maps are created based on certain terrain characteristics - slope and aspect. Both of them can be calculated with the terrain function and the opt argument set to "slope" or "aspect".
# A hillshade map can be created using the tmap package. This package builds maps by stacking different data layers. In this case, the first layer is the hillshade object (hill), colored using different levels of gray.

slope = terrain(alt, opt = "slope")
plot(slope)
aspect = terrain(alt, opt = "aspect")
plot(aspect)
hill = hillShade(slope, aspect, angle = 40, direction = 270)
plot(hill)
plot(alt)

############################# -- SLOPE-- ######################
# tmaptools::palette_explorer() # to select color palette
tmap_mode("plot")
#data(World)
map1 <-
    tmap_style("natural") +
# other options: "classic"  "white", "gray", "natural", "cobalt", "col_blind", "albatross", "beaver", "bw", "watercolor"
    tm_shape(slope, name = "Slope", title = "Slope") +
    tm_raster(
        title = "Slope (0\u00B0-90\u00B0)",
        palette = "-Set1",
      # other styles: style = "fisher", style = "kmeans",
        style = "quantile", n = 10,
        breaks = c(5, 10, 20, 30, 40, 50, 60, 70, 80, 90),
#        labels = c("gentle", "moderate", "strong", "very strong", "steep", "extreme"),
        legend.show = T,
        legend.hist = T,
        legend.hist.z=0,
        ) +
    tm_scale_bar(
        width = 0.25,
        text.size = 0.8,
        text.color = "black",
        color.dark = "black",
        color.light = "white",
        position=c("left", "bottom"),
        lwd = 1) +
    tm_compass(
        type = "radar", position=c("right", "top"), size = 7.0) +
# "arrow", "4star", "8star", "radar", "rose"
    tm_layout(scale = .8,
        main.title = "Slope terrain map based on SRTM-90 DEM of Rwanda. Mapping: R",
        main.title.position = "center",
        main.title.color = "black",
        main.title.size = 1.0,
        title = "Slope (0\u00B0-90\u00B0)",
        title.color = "black",
        title.size = 1.0,
        title.position = c("left", "top"),
        panel.labels = c("R packages: tmap, raster, sp, sf"),
        panel.label.color = "darkslateblue",
        panel.label.size = 1.0,
        legend.position = c("right","bottom"),
        legend.bg.color = "grey90",
        legend.bg.alpha = .2,
#        legend.frame = "gray50",
        legend.outside = FALSE,
        legend.width = 0.8,
        legend.height = .5,
        legend.hist.height = .2,
        legend.title.size = 0.9,
        legend.text.size = 0.8,
        legend.stack = "horizontal",
#        bg.color="cornsilk",
        inner.margins = 0) +
    tm_graticules(
        ticks = TRUE,
        lines = TRUE,
        labels.rot = c(15, 15),
        col = "white", lwd = 1,
        labels.size = 1.0)
# plot map
map1
tmap_save(map1, "Rwanda_Slope.jpg", dpi = 300, height = 10)

############################# -- ASPECT-- ######################
tmap_mode("plot")
map2 <-
    tmap_style("watercolor") +
    tm_shape(aspect, name = "Slope", title = "Slope") +
    tm_raster(
        title = "Aspect",
        palette = "-Spectral",
        style = "quantile", n = 8,
        legend.show = T,
        legend.hist = T,
        legend.hist.z=0,
        ) +
    tm_scale_bar(
        width = 0.25,
        text.size = 0.9,
        text.color = "black",
        color.dark = "black",
        color.light = "white",
        position=c("left", "bottom"),
        lwd = 1) +
    tm_compass(
        type = "rose", position=c("right", "top"), size = 7.0) +
# other options: "arrow", "4star", "8star", "radar", "rose"
    tm_layout(scale = .8,
        main.title = "Aspect terrain map based on SRTM-90 DEM of Rwanda. Mapping: R",
        main.title.position = "center",
        main.title.color = "black",
        main.title.size = 0.9,
        title = "Aspect \n(W-E-S-N) \n(SW-SE-NW-NE)",
        title.color = "black",
        title.size = 1.0,
        title.position = c("left", "top"),
        panel.labels = c("R packages: tmap, raster, sp, sf"),
        panel.label.color = "darkslateblue",
        panel.label.size = 1.0,
        legend.position = c("right","bottom"),
        legend.bg.color = "grey90",
        legend.bg.alpha = .2,
        legend.stack = "horizontal",
        legend.outside = F,
        legend.width = 0.65,
        legend.height = .4,
        legend.hist.height = .15,
        legend.hist.width = .6,
        legend.title.size = 0.9,
        legend.text.size = 0.9,
        inner.margins = 0) +
    tm_graticules(
        ticks = TRUE,
        lines = TRUE,
        labels.rot = c(15, 15),
        col = "azure3", lwd = 1,
        labels.size = 1.0)
# plot map
map2
tmap_save(map2, "Rwanda_Aspect.jpg", dpi = 300, height = 10)

Twomaps <- tmap_arrange(map1, map2)
Twomaps
tmap_save(Twomaps, "Rwanda_SlopeAspect.jpg", dpi = 300, height = 10, width = 12)

############################# -- HILLSHADE-- ######################
# tmaptools::palette_explorer()
tmap_mode("plot")
map3 <-
    tmap_style("cobalt") +
    tm_shape(hill, name = "Hillshade", title = "Hillshade",
        auto.palette.mapping = FALSE,) +
    tm_raster(
        title = "Histogram \n(data distribution)",
        palette = "cividis",
        #style = "kmeans",
        style = "quantile", n = 10,
        legend.show = T,
        legend.hist = F,
        legend.hist.z=0,
        ) +
    tm_scale_bar(
        width = 0.25,
        text.size = 0.9,
        text.color = "white",
        color.dark = "gray",
        color.light = "white",
        position=c("center", "bottom"),
        lwd = 1) +
    tm_compass(
        type = "8star", position=c("right", "bottom"), size = 7.0) +
    tm_layout(scale = .9,
        main.title = "Hillshade terrain analysis based on DEM of Rwanda. Mapping: R",
        main.title.position = "center",
        main.title.color = "black",
        main.title.size = 1.0,
        title = "Hillshade (0\u00B0-90\u00B0)",
        title.color = "white",
        title.size = 1.0,
        title.position = c("left", "top"),
        panel.labels = c("R packages: tmap, raster, sp, sf"),
        panel.label.color = "darkslateblue",
        panel.label.size = 1.0,
        legend.position = c("right","top"),
        legend.bg.color = "grey90",
        legend.bg.alpha = .2,
        legend.frame = "gray50",
        legend.outside = FALSE,
        legend.width = .3,
        legend.height = .4,
        legend.hist.height = 0.15,
        legend.title.size = 1.1,
        legend.text.size = 0.6,
        inner.margins = 0) +
    tm_graticules(
        ticks = TRUE,
        lines = TRUE,
        col = "azure3",
        lwd = 1,
        labels.size = 1.0,
        labels.rot = c(15, 15),
        labels.col = "black")
# plot map
map3
tmap_save(map3, "Rwanda_Hillshade.jpg", height = 10)

############################# -- ELEVATION-- ######################
tmap_mode("plot")
map4 <-
    tmap_style("albatross") +
    tm_shape(alt, name = "Elevation", title = "Elevation") +
    tm_raster(
        title = "Elevation (m asl)",
        palette = terrain.colors(256),
        style = "quantile", n = 15,
        legend.show = T,
        legend.hist = T,
        legend.hist.z=0,
        ) +
    tm_scale_bar(
        width = 0.25,
        text.size = 0.9,
        text.color = "white",
        color.dark = "gray",
        color.light = "white",
        position=c("center", "bottom"),
        lwd = 1) +
    tm_compass(
        type = "4star", position=c("right", "top"), size = 7.0) +
    tm_layout(scale = .8,
        main.title = "Elevation terrain analysis based on DEM of Rwanda. Mapping: R",
        main.title.position = "center",
        main.title.color = "black",
        main.title.size = 1.0,
        title = "Elevation (m)",
        title.color = "white",
        title.size = 1.0,
        title.position = c("left", "top"),
        panel.labels = c("R packages: tmap, raster, sp, sf"),
        panel.label.color = "darkslateblue",
        panel.label.size = 1.0,
        legend.position = c("right","bottom"),
        legend.bg.color = "grey90",
        legend.bg.alpha = .2,
        legend.outside = FALSE,
        legend.width = .3,
        legend.hist.width = .15,
        legend.height = .25,
        legend.hist.height = .1,
        legend.title.size = 0.9,
        legend.text.size = 0.6,
        legend.stack = "vertical",
        inner.margins = 0) +
    tm_graticules(
        ticks = TRUE,
        lines = TRUE,
        labels.rot = c(15, 15),
        col = "azure3", lwd = 1,
        labels.size = 1.0)
# plot map
map4
tmap_save(map4, "Rwanda_Elevation.jpg", dpi = 300, height = 10)

Twomaps <- tmap_arrange(map3, map4)
Twomaps
tmap_save(Twomaps, "Rwanda_HillElev.jpg", dpi = 300, height = 10, width = 12.0)

############################# -- HISTOGRAMS-- ######################
hist(hill, maxpixels=100000, plot=TRUE)
hist(alt, maxpixels=100000, plot=TRUE)
hist(slope, maxpixels=100000, plot=TRUE)
hist(aspect, maxpixels=100000, plot=TRUE)


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

m <- 10000
n <- 250
x <- matrix(rnorm(m*n, mean=10, sd=3), m, n)

benchmark(scale(x), scaler(x), replications=reps, columns=cols)


# R script to perform statistical analysis of depression versus control data
# Author: Deepak Sharma
# Date: 14 September 2016

# Import libraries --------------------------------------------

library(e1071)
library(rpart)
library(mlbench)
library(caret)
library(MASS)

# Import data -------------------------------------------------------------

depression_vs_control <- read.csv("depression_vs_control.csv")

# Creating modeling variables
Predictor <- subset(depression_vs_control, select=-Type)
Target <-  noquote(depression_vs_control$Type)

# Generating SVM model ----------------------------------------------------

dvc_svm <- svm(noquote(Target) ~ ., data=depression_vs_control)
summary(dvc_svm)

dvc_svm1 <- svm(Predictor,Target)
summary(dvc_svm1)

Predicted <- predict(dvc_svm1,Predictor)
system.time(Predicted <- predict(dvc_svm1,Predictor))

# Results of training -----------------------------------------------------

train_result <- t(table(Predicted,Target))
train_sens <- sensitivity(train_result, "Normal") * 100
train_spec <- sensitivity(train_result, "Normal") * 100
train_accuracy <- mean(train_sens,train_spec)

# Tuning SVM model
svm_tune <- tune(svm, train.x=Predictor, train.y=Target,
  kernel="radial", ranges=list(cost=10^(-1:2), gamma=c(.5,1,2)))
print(svm_tune)

tuned_dvc_svm <- svm(Type ~ ., data=depression_vs_control, kernel="radial", cost=1, gamma=0.5)
summary(tuned_dvc_svm)

Predicted <- predict(tuned_dvc_svm,Predictor)
system.time(predict(tuned_dvc_svm,Predictor))

# Confusion matrix after Tuning
mytunedsvm <- tune.svm(Type ~ ., data = depression_vs_control, gamma = 2^(-1:1), cost = 2^(2:4))
plot(mytunedsvm, transform.x=log10, xlab=expression(log[10](gamma)), ylab="C")

# Testing SVM model -------------------------------------------------------

## Split data into a training (2/3) and test set (1/3)
index <- 1:nrow(depression_vs_control)
testindex <- sample(index, trunc(length(index)/3))
testset <- depression_vs_control[testindex,]
trainset <- depression_vs_control[-testindex,]

mytunedsvm <- tune.svm(Type ~ ., data = trainset, gamma = 2^(-1:1), cost = 2^(2:4))
summary(mytunedsvm)
plot (mytunedsvm, transform.x=log10, xlab=expression(log[10](gamma)), ylab="C")

# fit the model
svm.model <- svm(Type ~ ., data = trainset, cost = 100, gamma = 1)

# make the prediction (the dependent variable, Type, has column number 10)
# Removing the target variable
svm.pred <- predict(svm.model, testset[,-4])

# Predicting the Target variable
# Results of SVM training model
test_result <- t(table(pred = svm.pred, true = testset[,4]))
test_sens <- sensitivity(test_result, "Normal") * 100
test_spec <- sensitivity(test_result, "Normal") * 100
test_accuracy <- mean(test_sens,test_spec)


 DORMTR Example Program Results

 Eigenvalues
    -5.0034 -1.9987

 Eigenvectors
          1       2
 1   0.5658 -0.2328
 2  -0.3478  0.7994
 3  -0.4740 -0.4087
 4   0.5781  0.3737


#------------------------------------------------------------------------------
# GISinR.r
#
# An example script to show the utility of sf package for GIS analysis. This
# script will color-code watersheds in BC based on the number of hydrometric
# stations that are contained within each
#
# uses the 'bcmaps' package for access to the sub-basin shape files
# see https://www.r-spatial.org/r/2018/10/25/ggplot2-sf-2.html for useful
# guidance and examples as well.
#
# D.Hutchinson 2020-04-29
#------------------------------------------------------------------------------

# library references
library(bcmaps)
library(dplyr)
library(ggplot2)
library(sf)
library(tidyhydat)

# let's get the bc watersheds data
wsheds <- bcmaps::wsc_drainages(class = "sf")

# the above statement could be replaced by reading in a shape file
# myshape <- read_sf() # for example...

# now read in the active hydrometric network in BC
bc_network <- hy_stations(prov_terr_state_loc = "BC") %>%
              filter(HYD_STATUS == "ACTIVE") %>%
              mutate(SUB_SUB_BSN = substr(STATION_NUMBER, 1,4))

# summarize the number of stations by SUB_SUB_BASIN
sub_bsn <- bc_network %>%
           group_by(SUB_SUB_BSN) %>% summarise(N = n()) %>%
           mutate(N = as.factor(N))

# merge summary with watershed data
wsheds <- wsheds %>% left_join(sub_bsn, by = c("SUB_SUB_DRAINAGE_AREA_CD" = "SUB_SUB_BSN"))

# generate map
ggplot(wsheds) +
  geom_sf(aes(fill = N)) +
  theme_bw() +
  ggtitle("BC hydrometric network - number of stations per sub-sub-basin")

#


library(pROC)
library(cowplot)
source(file.path(PROJECT_DIR, "R/functions/gg_color_hue.r"))

fn.si = file.path(PROJECT_DIR, "generated_data", "YF", "YF_cd38_ge_sig_score.txt")
info = fread(fn.si)%>%
  dplyr::filter(Response %in% c("low","high")) %>%
  mutate(Response = factor(Response, levels=c("low","high")),
         label = ifelse(Trial==1, "Yellow Fever", paste0("Yellow Fever, Trial ", Trial)))

roc.df = data.frame()
df.text = data.frame()
N_perm = 1000

for (trial in 1:2) {
  tinfo = info %>% dplyr::filter(Trial == trial)

  r = roc(Response ~ CD38_score, data=tinfo, direction="<", quiet = T)
  set.seed(123)
  r.null = vector("numeric", N_perm)
  for(i in 1:N_perm) {
    r.null[i] = roc(Response~sample(CD38_score), data=tinfo, direction="<", quiet = T)$auc
  }
  r.p = sum(r.null > r$auc) / N_perm

  r.df = data.frame(Specificity = r$specificities, Sensitivity=r$sensitivities, Trial=trial) %>%
    arrange(Sensitivity)

  roc.df = rbind(roc.df, r.df)

  X = tinfo$CD38_score
  Y = tinfo$Response
  w.pv = wilcox.test(X[Y=="high"], X[Y=="low"], exact=F, alternative="greater")$p.value

  df.text = rbind(df.text,
                  data.frame(Trial=trial, label.auc=sprintf("AUC = %.2f\np = %.2g", r$auc, r.p),
                             label.w.pv=sprintf("p = %.2g",w.pv)))
}

roc.df = roc.df %>%
  mutate(Trial=factor(Trial),
         label = paste0("Yellow Fever, Trial ", Trial)) %>%
  arrange(Sensitivity, Specificity)
df.text$x = 0.25
df.text$y = 0.1

# df.text$x = c(0.5, 0.5)
# df.text$y = c(roc.df$Sensitivity[which(roc.df$Trial==1 & roc.df$Specificity<=0.5)[1]],
#               roc.df$Sensitivity[which(roc.df$Trial==2 & roc.df$Specificity<=0.5)[1]])
df.text = df.text %>%
  mutate(label = ifelse(Trial==1, "Yellow Fever", paste0("Yellow Fever, Trial ", Trial)))

clr = gg_color_hue(4) %>% rev()

for (t in 1:2) {
  df.text.2 = df.text %>%
    dplyr::filter(Trial==t)

  p1 = ggplot(info %>% dplyr::filter(Trial==t), aes(x=Response, y=CD38_score, group=Response)) +
    geom_boxplot(aes(fill=label), alpha=0.5, outlier.colour = NA) +
    geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
    facet_wrap(~label, nrow=1) +
    scale_fill_manual(values=c("black", "white", clr[4]), name="Response",
                      breaks=c(0,2), labels=c("low","high")) +
    geom_text(data = df.text.2, aes(label=label.w.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
    xlab("Response") + ylab("Baseline signature score") +
    coord_cartesian(xlim=c(0.8, 2.2)) +
    theme_bw() + theme(legend.position="none") +
    theme(panel.border = element_blank(), strip.background = element_blank(),
          strip.text.x = element_text(size=12),
          panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
          axis.ticks = element_blank())

  p2 = ggplot(roc.df %>% dplyr::filter(Trial==t), aes(x=Specificity,y=Sensitivity)) + geom_line(size=1) +
    geom_abline(slope=1, intercept=1, lty=2, col="black") +
    scale_x_reverse() +
    geom_text(data=df.text.2, aes(x=x,y=y,label=label.auc), vjust=-0.5) +
    scale_color_manual(values=c("red","blue")) +
    coord_fixed() + theme_bw() + guides(color="none")

  # bottom_row <- do.call("plot_grid", c(p2, align = "h", nrow=1))
  plot_grid(p1, p2, ncol=1, rel_heights = c(2, 1))

  fn.fig = file.path(PROJECT_DIR, "figure_generation", sprintf("YF_Trial%d_CD38.10gene.sig", t))
  ggsave(paste0(fn.fig, ".png"), w=2.5,h=7)
  ggsave(paste0(fn.fig, ".pdf"), w=2.5,h=7)

  # fn.fig = file.path(PROJECT_DIR, "figure_generation", sprintf("YF_Trial%d_CD38.10gene.sig_ROC",t))
  # ggsave(paste0(fn.fig,".png"), w=4,h=4)
  # ggsave(paste0(fn.fig,".pdf"), device=pdf, w=4,h=4)

  # fn.fig = file.path(PROJECT_DIR, "figure_generation", sprintf("YF_Trial%d_CD38.10gene.sig_BOXplot",t))
  # ggsave(paste0(fn.fig,".png"), w=4,h=4)
  # ggsave(paste0(fn.fig,".pdf"), device=pdf, w=4,h=4)
}


library(tidyquant)
library(magrittr)
library(readr)
library(dplyr)
library(tidyr)
library(ggplot2)
library(plotly)
library(quantmod)

setwd('D:/Docs/GitHub/Market-Matrix/')

# cumulative returns function:

cumulative_return <- function(entry_year,exit_year,ticker){
      price_data <- tq_get(ticker,
                       from = paste(entry_year,'-01-01',sep = ''),
                       to = paste(exit_year,'-12-31',sep = ''),
                       get = 'stock.prices')
      wts = c(1.0)
      ret_data <- price_data %>%
        group_by(symbol) %>%
        tq_transmute(select = adjusted,
                     mutate_fun = periodReturn,
                     period = "yearly",
                     col_rename = "ret")
      wts_tbl <- tibble(symbol = ticker,
                        wts = wts)
      ret_data <- left_join(ret_data,wts_tbl, by = 'symbol')
      ret_data <- ret_data %>%
        mutate(wt_return = wts * ret)

      port_ret <- ret_data %>%
        group_by(date) %>%
        summarise(port_ret = sum(wt_return))

      return( mean(port_ret$port_ret) )
}

# example values:

 x_to_x <- cumulative_return(1989,1989,"^GSPC")
 x_to_y <- cumulative_return(1950,1990,"^GSPC")

# create return values matrix:

enter <- seq(from = 1965, to = 1985, by = 1) %>% as.integer()
exit <- seq(from = 1965, to = 1985, by = 1) %>% as.integer()

cross_join <- crossing(enter,exit)
cross_join %<>% filter(enter <= exit)

return <- mapply(cumulative_return,cross_join$enter,cross_join$exit,"^GSPC")

cross_join$return <- return
cross_join$return_100 <- return * 100

# graphing with y descending order, x ascending order:

plot <- ggplot(cross_join, aes(exit, enter)) +
        geom_tile(aes(fill = return_100), colour = "white") +
        coord_equal() +
        scale_fill_gradient2(low = "indianred4",mid= "lemonchiffon3",  high = "darkolivegreen4") +
        scale_y_reverse()

ggplotly(plot)


#' Path disutility updater
#'
#' This function updates the path disutility at time t+1 based on disutility and path costs at time t. The path costs are computed from pattern of link flows.
#' @param x Traffic flow on all links of network
#' @param A Link-path incidence matrix
#' @param psi Recency parameter, controlling weight assigned to most recent path costs when updating disutility. Defaults to 1.
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param ut Vector of path disutilities prior to update
#' @return Vector of path disutilities
#' @keywords disutility
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' ut <- c(10,10,10,10)
#' Utility(x,A,psi=0.5,Alpha,Beta,pow,ut)
#' @export

Utility <- function(x,A=diag(length(x)),psi=1,Alpha,Beta,pow=4,ut=0){
  	psi*PathCost(x,A,Alpha=Alpha,Beta=Beta,pow=pow) + (1-psi)*ut
}


"
Изучить 5-7 любых функций языка R, исследовать передачу параметров в эти функции
Выяснить формальные имена параметров и значения параметров по умолчанию.
Проверить работу этих функций, написав для этого простейшие тестирующие программ.
По результатам проверки работы функций написать по каждой функции краткую справку
в виде комментария в тестирующей программе.
"
#В качестве параметра передается значение, которое необходимо вывести
print("Пример вывода")

vector <- c(5,54,6,3,5,54,645,754,654,6,54,34,32)
#в качестве аргумента предается вектор/сущность, которую можно посчитать
length(vector)

#добавляет элементы values в вектор x
vector <- append(vector,42)
length(vector)

# сумма элементов объекта
sum(vector)

# произведение элементов объекта
prod(vector)


# Copyright 2014-2019 Arnaud Poret
# This work is licensed under the BSD 2-Clause License.
# To view a copy of this license, visit https://opensource.org/licenses/BSD-2-Clause

# continuous logical NOT operator
# here the algebraic formulation is used
not<-function(a) {
    return(1-a)
}

# continuous logical AND operator
# here the algebraic formulation is used
# note that it accepts two or more arguments
and<-function(a,b,...) {
    x<-c(a,b,...)
    y<-x[1]
    for(i in seq(2,length(x))) {
        y<-y*x[i]
    }
    return(y)
}

# continuous logical OR operator
# here the algebraic formulation is used
# note that it accepts two or more arguments
or<-function(a,b,...) {
    x<-c(a,b,...)
    y<-x[1]
    for(i in seq(2,length(x))) {
        y<-y+x[i]-y*x[i]
    }
    return(y)
}

# main function: performs the simulation
dothejob<-function(node0,r,w,kend,nedge,nnode,nodelab,plotall,printall) {
    node<-as.matrix(node0)
    edge<-as.matrix(fedge(node,1,nedge))
    for(k in seq(2,kend)) {
        edge<-cbind(edge,as.matrix((1-r)*edge[,k-1]+r*w*fedge(node,k-1,nedge)))
        node<-cbind(node,as.matrix(fnode(edge,k-1,nnode)))
    }
    if(plotall) {
        for(i in seq(ceiling(nnode/9))) {
            dev.new()
            par(mfrow=c(3,3))
        }
        for(i in seq(nnode)) {
            nplot<-ceiling(i/9)
            dev.set(nplot+1)
            plot(node[i,],type="l",main=nodelab[i],ylim=c(0,1),xlab="",ylab="")
            if(printall) {
                dev.print(device=svg,filename=paste("plot",as.character(nplot),".svg",sep=""))
            }
        }
    }
    return(node)
}


#R for repeated measures
library(car)
data <- read.table(("http://www.uvm.edu/~dhowell/methods8/DataFiles//Tab14-3.dat"), header = TRUE)

# data$subject <- factor(1:9)   subject is already a variable in the data set.
datLong <- reshape(data = data, varying = 2:6, v.names = "outcome", timevar
= "time", idvar = "subject", ids = 1:9, direction = "long")
attach(datLong)

time <- factor(time)
Subject <- factor(Subject)
options(contrasts=c("contr.sum","contr.poly"))
modelAOV <- aov(outcome~factor(time)+Error(factor(Subject)), data = datLong)
print(summary(modelAOV))

###########################################################################
#
#Error: factor(Subject)
#          Df Sum Sq Mean Sq F value Pr(>F)
#Residuals  8  486.7   60.84
#
#Error: Within
#             Df Sum Sq Mean Sq F value Pr(>F)
#factor(time)  4 2449.2   612.3   85.04 <2e-16 ***
#Residuals    32  230.4     7.2
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
   #
###########################################################################

plot(time, outcome, pch = c(2,4,6), col = c(3,4,6))
lines(gmeans)
legend(4, 30, c("same", "different", "control"), col = c(4,6,3),
                      text.col = "green4",  pch = c(4, 6, 2),
                      merge = TRUE, bg = 'gray90')

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


# ===
# R code that calls the function to build plots
# ===

# ---
# Load code that will be called
# ---

source("confidence_interval_base.r")
source("confidence_interval_top.r")

# ---
# Set common values
# ---

plot_width  <- 25
plot_height <- 10
plot_dpi    <- 150
path        <- "/tmp"

# ---
# Create plots.
# Files are dumped into directory "path"
# ---

plot1(binwidth=150,
      x_max=4000,
      path=path,
      filename="histogram_of_ames_area_randvar_over_population.png")

plot2(smoothing=1.5,
      x_max=4000,
      path=path,
      filename="pdf_of_ames_area_randvar_over_population.png")

sample <- plot3(binwidth=150,
                x_max=4000,
                sample_size=100,
                path=path,
                filename="histogram_of_ames_area_randvar_for_single_sample.png")

# reuse previous sample and aggressively smooth the next plot

plot4(sample=sample,
      smoothing=2,
      x_max=4000,
      path=path,
      filename="pdf_of_ames_area_randvar_for_single_sample.png")

plot5(sample_size=100,
      sample_count=300,
      sample_stats_binwidth=10,
      sample_stats_min=1200,
      sample_stats_max=1800,
      filename="histogram_of_mean_over_samples_of_ames_area_randvar.png")

# The calls just print out results

empiricially_test_confidence_interval(sample_size=100, confidence=0.90, trial_count=500)
empiricially_test_confidence_interval(sample_size=100, confidence=0.95, trial_count=500)
empiricially_test_confidence_interval(sample_size=100, confidence=0.98, trial_count=500)
empiricially_test_confidence_interval(sample_size=100, confidence=0.99, trial_count=500)

# At confidence level 90% and sample size 100
# the proportion of samples (of 500 samples) with
# population mean inside their confidence interval is: 0.906
#
# At confidence level 95% and sample size 100
# the proportion of samples (of 500 samples) with
# population mean inside their confidence interval is: 0.952
#
# At confidence level 98% and sample size 100
# the proportion of samples (of 500 samples) with
# population mean inside their confidence interval is: 0.976
#
# At confidence level 99% and sample size 100
# the proportion of samples (of 500 samples) with
# population mean inside their confidence interval is: 0.99


#### soa-libraries_and_functions.r: Part of `soa-interpersonal_level.Rmd` ####
#
# This script loads libraries and creates a number of
# additional functions to facilitate data prep and analysis.
#
# The script `soa-required_packages.r` should be run once first
# to ensure that the all required packages have been installed.
#
# Written by: A. Paxton (University of Connecticut)
# Date last modified: 19 April 2019
#####################################################################################

#### Load necessary packages ####

# list of required packages
required_packages = c(
  'ggplot2',
  'dplyr'
)

# load required packages
invisible(lapply(required_packages, require, character.only = TRUE))

# "euclidean": get Euclidean distance in three-dimensional space
euclidean <- function(x,y,z) {
  seq.end = length(x)
  distance = sqrt((x[2:seq.end]-x[1:(seq.end-1)])^2 +
                    (y[2:seq.end]-y[1:(seq.end-1)])^2 +
                    (z[2:seq.end]-z[1:(seq.end-1)])^2)
  return(distance)
}


vis2aot_vermote <- function(vis) {
  aot = (3.9449 / vis) + 0.08498

  return(aot)
}

vis2aot_k <- function(vis) {
  aot = (3.912 / vis)

  return(aot)
}

vis2aot_sixs <- function(vis) {
  # vertical repartition of aerosol density for v=23km
  #                 (in number of particles per cm3)
   an23 = c(2.828e+03,1.244e+03,5.371e+02,2.256e+02,1.192e+02
  ,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
  ,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
  ,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
  ,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
  ,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00)

  # vertical repartition of aerosol density for v=5km
  #                 (in number of particles per cm3)
   an5 = c(1.378e+04,5.030e+03,1.844e+03,6.731e+02,2.453e+02
  ,8.987e+01,6.337e+01,5.890e+01,6.069e+01,5.818e+01,5.675e+01
  ,5.317e+01,5.585e+01,5.156e+01,5.048e+01,4.744e+01,4.511e+01
  ,4.458e+01,4.314e+01,3.634e+01,2.667e+01,1.933e+01,1.455e+01
  ,1.113e+01,8.826e+00,7.429e+00,2.238e+00,5.890e-01,1.550e-01
  ,4.082e-02,1.078e-02,5.550e-05,1.969e-08,0.000e+00)

   # Altitude (z) levels
   z = c(0.,    1.,    2.,    3.,    4.,    5.,    6.,    7.,    8.,
   9.,   10.,   11.,   12.,   13.,   14.,   15.,   16.,   17.,
  18.,   19.,   20.,   21.,   22.,   23.,   24.,   25.,   30.,
  35.,   40.,   45.,   50.,   70.,  100.,99999.)

   aot = 0.0
   sigma = 0.056032

#    if (any(vis <= 0))
#    {
#      return()
#    }

   # Numerically integrate over each layer of the atmosphere summing the
   # calculated AOT

   for (k in 1:32)
   {
     # Calculate dz (the difference on the x axis)
     dz = z[k+1] - z[k]

     # Get the points on the curve for both ends of dz
     point_left_5 = an5[k]
     point_right_5 = an5[k+1]

     point_left_23 = an23[k]
     point_right_23 = an23[k+1]

     # Calculate the difference
     diff_left = (115.0/18.0) * (point_left_5 - point_left_23)
     diff_right = (115.0/18.0) * (point_right_5 - point_right_23)

     # Convert from per Km back to Km
     diff_left_km = (5.0 * point_left_5/18.0) - (23.0 * point_left_23/18.0)
     diff_right_km = (5.0 * point_right_5/18.0) - (23.0 * point_right_23/18.0)

     # Use interpolation formula from the docs (uses -b(z) as shown in FORTRAN code rather than +b(z) as in manual)
     interp_left = diff_left/vis - diff_left_km
     interp_right = diff_right/vis - diff_right_km

     # Calculate AOT for this level
     ev = dz * exp( (log(interp_left)+log(interp_right)) * 0.5)
     aot = aot + (ev * sigma * 1.0e-03)
   }
   return(aot)
}

data <- read.csv("data/MODTRAN_VisAOT.csv")
vis2aot_modtran <- approxfun(data$vis, data$aot)


library(e1071)

# clusterData [variables, hotel_cluster]
# clusterTestData [variables]
calcClusterProbsSVM <- function (clusterTrainData,clusterTestData) {

  clusterTrainData$hotel_cluster <- as.factor(clusterTrainData$hotel_cluster)

  model <- svm(hotel_cluster ~ ., data = clusterTrainData,probability=T,cross=2)
  print(summary(model))

  svmProbs <- predict(model,clusterTestData,probability=T)
  svmProbs <- attr(svmProbs, "probabilities")

  allClustersCols <- lapply(0:99,function(x) { x})
  missingClusterCols  <- setdiff(allClustersCols,colnames(svmProbs))
  missingClustersMat = matrix(0,nrow=nrow(svmProbs),ncol=length(missingClusterCols))
  colnames(missingClustersMat) <- missingClusterCols
  svmProbs <- cbind(svmProbs,missingClustersMat)
  svmProbs <- svmProbs[, order(as.integer(colnames(svmProbs)))]
  svmProbs <- data.frame(svmProbs)

  return(svmProbs)

}


## ----echo=FALSE---------------------------------------------------------
knitr::opts_chunk$set(
  echo=FALSE,
  message = FALSE,
  warning = FALSE,
  error = FALSE,
  collapse = TRUE,
  comment = "",
  fig.height = 6,
  fig.width = 10,
  fig.align = "center",
  fig.retina = 3,
  cache = FALSE
)

## ----load libraries, echo=FALSE-----------------------------------------
library(tidyverse)
library(RColorBrewer)
library(gridExtra)
library(dichromat)
library(here)

## ----read TB data and wrangle and subset to USA-------------------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  dplyr::select(country, iso3, year, new_sp_m04:new_sp_fu) %>%
  pivot_longer(cols=new_sp_m04:new_sp_fu, names_to="sexage", values_to="count") %>%
  mutate(sexage = str_replace(sexage, "new_sp_", "")) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  dplyr::select(-sexage)

# Filter years between 1997 and 2012 due to missings
tb_us <- tb %>%
  filter(country == "United States of America") %>%
  filter(!(age %in% c("04", "014", "514", "u"))) %>%
  filter(year > 1996, year < 2013)

## -----------------------------------------------------------------------
tb_us %>% filter(year == 2012) %>% select(sex, age, count)

## ----focus on one year gender side-by-side bars of males/females, fig.height=3----
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=sex, y=count, fill=sex)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~age, ncol=6) +
  scale_fill_manual("Sex", values = c("#DC3220", "#005AB5")) +
  ggtitle("Arrangement A")

## ----focus on one year age side-by-side bars of age group, fig.height=3----
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=age, y=count, fill=age)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Arrangement B")

## ----ref.label='focus on one year gender side-by-side bars of males/females', fig.height=3----

## ----ref.label='focus on one year age side-by-side bars of age group', fig.height=3----

## -----------------------------------------------------------------------
tb_us %>% select(year, sex, age, count) %>% head(10)

## ----eval=FALSE---------------------------------------------------------
## - Plot type A makes it easier to examine trend for each group. This plot should probably have used 0 as the lower limit.
## - Plot type  B is really only allowing the overall trend in count to be examined separately by age. It is also possible to see trend for males. Trend for females is buried because the bars start at irregular heights. The separated bars distract from digesting the overall count.

## ----use a line plot instead of bar, fig.height=3-----------------------
ggplot(tb_us, aes(x=year, y=count, colour=sex)) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  scale_color_manual("Sex", values = c("#DC3220", "#005AB5")) +
  ggtitle("Type A")

## ----colour and axes fixes, fig.height=3--------------------------------
# This uses a color blind proof scale
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity") +
  facet_wrap(~age, ncol=6) +
  scale_color_manual("Sex", values = c("#DC3220", "#005AB5")) +
  ggtitle("Type B")

## -----------------------------------------------------------------------
countdown::countdown(1,50, top=0, right=0)

## ----ref.label='use a line plot instead of bar', fig.height=3-----------

## ----ref.label='colour and axes fixes', fig.height=3--------------------

## -----------------------------------------------------------------------
countdown::countdown(0, 30, top=0, right=0)

## -----------------------------------------------------------------------
countdown::countdown(1, 5, top=100, right=0)

## ----use a line plot for proportions, fig.height=3----------------------
tb_us %>% group_by(year, age) %>%
  summarise(p = count[sex=="m"]/sum(count)) %>%
  ggplot(aes(x=year, y=p)) +
  geom_hline(yintercept = 0.50, colour="white", size=2) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  ylab("proportion of males") +
  ggtitle("Type A")

## ----compare proportions of males/females, fig.height=4-----------------
# Fill the bars, note the small change to the code
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~age, ncol=6) +
  scale_fill_manual("Sex", values = c("#DC3220", "#005AB5")) + ylab("proportion") +
  ggtitle("Type B") + theme(legend.position = "bottom")

## ----eval=FALSE---------------------------------------------------------
## - Plot A makes it easier to examine the trend in proportion. It is easy to miss that all the proportions are greater than 0.5, despite having a guideline (white) at 0.5. It could be argued that setting the vertical axis limits could alleviate this.  The fluctuations from year to year are more visible. Maybe adding a trend model could be helpful, to reduce this noise. Without colour its less visually appealing.
## - Plot B makes it easier to see that the proportion for males is almost always higher than for females. It also suggests that there is little temporal trend, because the small fluctuations between years is less visible. Having colour makes it more visually appealing. There s less data processing.

## -----------------------------------------------------------------------
countdown::countdown(1, 40, top=100, right=100)

## ----eval=FALSE---------------------------------------------------------
## 1. scatterplot, barchart
## 2. side-by-side boxplot, stacked barchart
## 3. piechart, rose plot, gauge plot, donut, wind direction map, starplot
## 4. treemap, bubble chart, mosaicplot
## 5. chernoff face
## 6. choropleth map

## ----show different types of color palettes, fig.height=7, fig.width=12, echo=TRUE, fig.show='hide'----
display.brewer.all()

## ----ref.label='show different types of color palettes', fig.height=7, fig.width=12----

## ----mapping numbers to rainbow sequential scale, echo=TRUE, out.width="60%", fig.width=7, fig.height=4----
dsamp <- diamonds[sample(nrow(diamonds), 1000), ]
(d <- ggplot(dsamp, aes(carat, price)) +
  geom_point(aes(colour = clarity)))

## ----mapping numbers to sequential scale, echo=TRUE, fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer()

## ----mapping numbers to diverging scale, echo=TRUE, fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer(palette="PRGn")

## ----mapping numbers to qualitative palette, echo=TRUE, , fig.width=7, fig.height=4, out.width="60%"----
d + scale_colour_brewer(palette="Set1")

## -----------------------------------------------------------------------
countdown::countdown(0, 50, right=50, bottom=0)

## ----using the dichromat package to check color blind appearance, echo=TRUE, fig.show='hide'----
library(scales)
library(dichromat)
clrs <- hue_pal()(9)
d + theme(legend.position = "none")
clrs <- dichromat(hue_pal()(9))
d + scale_colour_manual("", values=clrs) + theme(legend.position = "none")

## ----show the default colour scheme, echo=FALSE, fig.width=4, fig.height=4, out.width="100%"----
clrs <- hue_pal()(9)
p1 <- d + theme(legend.position = "none") + scale_color_discrete()
p1

## ----show the dichromat adjusted colors, echo=FALSE, fig.width=4, fig.height=4, out.width="100%"----
clrs <- dichromat(hue_pal()(9))
p2 <- d + scale_color_manual("", values=clrs) + theme(legend.position = "none")

p2

## ----is shape preattentive, echo=FALSE----------------------------------
set.seed(20190715)
df <- data.frame(x=runif(100), y=runif(100), cl=sample(c(rep("A", 1), rep("B", 99))))
ggplot(data=df, aes(x, y, shape=cl)) + theme_bw() +
  geom_point(size=3) +
  theme(legend.position="None", aspect.ratio=1)

## ----is color preattentive, echo=FALSE----------------------------------
ggplot(data=df, aes(x, y, colour=cl)) +
  geom_point(size=3) +
  theme_bw() +
  scale_colour_brewer(palette="Set1") +
  theme(legend.position="None", aspect.ratio=1)

## ----a line plot on sex, fig.height=3-----------------------------------
ggplot(tb_us, aes(x=year, y=count, colour=sex)) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  ylim(c(0,1150)) +
  scale_color_manual("Sex", values = c("#DC3220", "#005AB5"))  +
  ggtitle("Arrangement A")

## ----a line plot on age, fig.height=3, fig.width=6----------------------
ggplot(tb_us, aes(x=year, y=count, colour=age)) +
  geom_line() + geom_point() +
  facet_wrap(~sex, ncol=6) +
  ylim(c(0,1150)) +
  scale_colour_brewer("", palette="Dark2") +
  ggtitle("Arrangement B")

## ----side-by-side bars of males/females, fig.height=3-------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=sex, y=count, fill=sex)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~age, ncol=6) +
  scale_fill_manual("Sex", values = c("#DC3220", "#005AB5"))  +
  ggtitle("Position - common scale ")

## ----piecharts of males/females, fig.height=3---------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=1, y=count, fill=sex)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~age, ncol=6) +
  scale_fill_manual("Sex", values = c("#DC3220", "#005AB5")) +
  ggtitle("Angle") + xlab("") + ylab("") +
  coord_polar(theta = "y")

## ----side-by-side bars of age, fig.height=3-----------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=age, y=count, fill=age)) +
  geom_bar(stat="identity", position="dodge") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Position - common scale ")

## ----piecharts of age, fig.height=3-------------------------------------
tb_us %>% filter(year == 2012) %>%
  ggplot(aes(x=1, y=count, fill=age)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~sex, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  ggtitle("Angle") + xlab("") + ylab("") +
  coord_polar(theta = "y")

## ----facetting plots can result in change blindness, echo=TRUE, out.width="50%", fig.width=6.5, fig.height=3.5----
ggplot(dsamp, aes(x=carat, y=price, colour = clarity)) +
  geom_point() +
  geom_smooth(se=FALSE) +
  scale_color_brewer(palette="Set1") +
  facet_wrap(~clarity, ncol=4)

## ----averlaying makes comparisons easier, echo=TRUE, out.width="70%", fig.width=7, fig.height=4----
ggplot(dsamp, aes(x=carat, y=price, colour = clarity)) +
  geom_point() +
  geom_smooth(se=FALSE) +
  scale_color_brewer(palette="Set1")

## -----------------------------------------------------------------------
countdown::countdown(7, 0)


library(ztpln)

seed <- 123

# K = 1 --------------------------
set.seed(seed)
K <- 1
mu <- runif(K, 0, 15)
sig <- runif(K, 0, 2)
n <- 100

mu
sig

y <- rztpln(n = 100, mu, sig)
y

lik1 <- sum(dztpln(y, mu, sig, log = TRUE))
#lik2 <- sum(log(poilog::dpoilog(y, mu, sig) / (1 - poilog::dpoilog(0, mu, sig))))

k <- 5
mu <- 3
sig <- 2
y <- rztpln(n = 100, mu, sig)
y

lik1 <- sum(dztpln(k, mu, sig, log = TRUE))
#lik2 <- sum(log(poilog::dpoilog(k, mu, sig) / (1 - poilog::dpoilog(0, mu, sig))))

#poilog::dpoilog(0, mu, sig)
#do_dpln(0, mu, sig^2)

#lik1 - lik2

ztplnMLE(y)

# K = 2 --------------------------
set.seed(seed)
K <- 2
mu <- runif(K, 0, 15)
sig <- runif(K, 0, 2)
n <- 100

# random draw from dirichlet  distribution
theta0 <- rgamma(K, sample(1:3, K, replace = TRUE))
theta <- theta0 / sum(theta0)

mu
sig
theta

y <- rztplnm(n = 100, mu, sig, theta)
y

lik1 <- sum(dztplnm(y, mu, sig, theta, log = TRUE))

tmp <- NULL
for (k in 1:K) tmp <- cbind(tmp, theta[k] * dztpln(y, mu[k], sig[k]))
lik2 <- sum(log(apply(tmp, 1, sum)))

lik1 - lik2

ztplnmMLE(y, K = 2)
ztplnmMLE(y, K = 2, type1 = FALSE)

# K = 3 --------------------------
set.seed(seed)
K <- 2
mu <- runif(K, 0, 15)
sig <- runif(K, 0, 2)
n <- 100

# random draw from dirichlet  distribution
theta0 <- rgamma(K, sample(1:3, K, replace = TRUE))
theta <- theta0 / sum(theta0)

mu
sig
theta

y <- rztplnm(n = 100, mu, sig, theta)
y

lik1 <- sum(dztplnm(y, mu, sig, theta, log = TRUE))

tmp <- NULL
for (k in 1:K) tmp <- cbind(tmp, theta[k] * dztpln(y, mu[k], sig[k]))
lik2 <- sum(log(apply(tmp, 1, sum)))

lik1 - lik2

ztplnmMLE(y, K = 3)
ztplnmMLE(y, K = 3, type1 = FALSE)


 ZUPMTR Example Program Results

 Eigenvalues
        -6.0002           -3.0030

 Eigenvectors
                    1                 2
 1  ( 0.7299, 0.0000) (-0.2120, 0.1497)
 2  (-0.1663,-0.2061) ( 0.7307, 0.0000)
 3  (-0.4165,-0.1417) (-0.3291, 0.0479)
 4  ( 0.1743, 0.4162) ( 0.5200, 0.1329)


install.packages("lmtest")
install.packages("gvlma")

library(corrplot)
library(lars)
library(BLR)
library(glmnet)
library(caret)
library(MASS)
library(car)
library(stats)
library(descr)
library(corrplot)
library(ggplot2)
library(dplyr)
library(psych)
library(pastecs)
library(dplyr)
library(ggpubr)
library(GGally)
library(lmtest)
library(gvlma)

setwd(dir = "f://diabetes")

data <- read.csv(file="data.csv", header=TRUE, sep=",",
                 colClasses = c("character"))

data$EDAD <- as.numeric(data$EDAD)
data$TIEMPODIAG <- as.numeric(data$TIEMPODIAG)
data$PESO <- as.numeric(data$PESO)
data$TALLA <- as.numeric(data$TALLA)
data$IMC <- as.numeric(data$IMC)
data$HEMOGLOBINA <- as.numeric(data$HEMOGLOBINA)
data$GLICOSILADA <- as.numeric(data$GLICOSILADA)
data$TRIGLICERIDOS <- as.numeric(data$TRIGLICERIDOS)
data$COLESTEROL <- as.numeric(data$COLESTEROL)
data$HDL <- as.numeric(data$HDL)
data$ALBUMINA <- as.numeric(data$ALBUMINA)
data$BUN <- as.numeric(data$BUN)
data$UREA <- as.numeric(data$UREA)
data$CREATININA <- as.numeric(data$CREATININA)
data$TFGCKD <- as.numeric(data$TFGCKD)
data$TFGMDRD <- as.numeric(data$TFGMDRD)

dim(data)
str(data)
names(data)
head(data)
summary(data)

#TFG = EDAD , SEXO, CRERATENINA
# filter(data, SEXO == "F")
data_selected <- select(data, -(EDAD), -(PESO) , - (TALLA), -(ALIAS), -(SEXO), -(ECIVIL), -(TRATAMIENTO), -(HTA), -(PIEDIABETICO), -(TFGMDRD), -(CREATININA))
data_selected_extend <- select(data, -(EDAD), -(PESO) , - (TALLA), -(ALIAS), -(SEXO), -(TRATAMIENTO), -(HTA), -(PIEDIABETICO), -(TFGMDRD), -(CREATININA))
describe(data_selected)
names(data_selected)
colnames(data_selected) <- c("TIE", "IMC", "HEMO", "GLI", "TRI", "COL", "HDL", "ALB","BUN", "URE",  "TFG" )

boxplot(TFGCKD ~ ECIVIL , data_selected_extend)

lm1 = lm( TFG ~ BUN , data = data_selected)
lm2 = lm( TFG ~ BUN + URE  , data = data_selected)

anova(lm1, lm2)

# < 0.5 me quedo con el modelo con mas variables

lmcompleto <- lm(TFG ~ ., data = data_selected)
lmNulo <- lm(TFG ~ 1, data = data_selected)
summary(lmNulo)

# step backward
lmback <- step(lmcompleto, direction= "backward")
summary(lmback)

lmfor <- step(lmNulo,scope =list(lower= lmNulo, upper=lmcompleto), direction = "forward")
summary(lmfor)

lmwise <- step(lmNulo,scope =list(upper=lmcompleto), direction = "both")
summary(lmwise)

# Bondad de ajuste
# revizar r cuadro proporcion de variabilidad que puedo explicar
# redisual debe ser pequenio en relacion con

shapiro.test(fitted(lmwise))

# In statistics, a collection of random variables is heteroscedastic (or heteroskedastic;[a] from Ancient Greek hetero "different" and skedasis "dispersion") if there are sub-populations that have different variabilities from others. Here "variability" could be quantified by the variance or any other measure of statistical dispersion. Thus heteroscedasticity is the absence of homoscedasticity.

bptest(formula = TFG ~ BUN + COL + URE + HEMO, data = data_selected, varformula = ~ fitted.values(lmwise), studentize = FALSE)

gvlma(lm1)
# Validacion del modelo


options(repr.plot.width = 7, repr.plot.height = 6)
options(jupyter.plot_mimetypes = c('application/pdf', 'image/png'))

library(destiny)
data(guo)

dm_guo <- DiffusionMap(guo, verbose = FALSE,
                       censor.val = 15, censor.range = c(15, 40))
dm_guo

plot(dm_guo, pch = 20)

palette(cube_helix(6))
plot(dm_guo, col_by = 'num_cells', pch = 20,
     legend_main = 'Cell stage')


input <- file('stdin', 'r')

a <- as.double(readLines(input, n=1))
b <- as.double(readLines(input, n=1))
c <- as.double(readLines(input, n=1))

result = sprintf("MEDIA = %.1f", (a * 2.0 + b * 3.0 + c * 5.0) / 10.0)
write(result, "")


#rm(list = ls())

require('magrittr')

dir('2.data/2.salmon')

salmon.data <- read.table('2.data/2.salmon/salmonTidy.csv', header = T, sep = ',', dec = '.')
salmon.data %>% head(3)

pdf('mon.pdf.pdf')

par(mfcol = c(3, 1), oma = c(1, 5 , 1, 5))

plot(salmon.data$weight[salmon.data$river == 'scorff'], salmon.data$length[salmon.data$river == 'scorff'])
hist(salmon.data$weight, col = salmon.data$weight)
boxplot(salmon.data$weight ~ salmon.data$year)

dev.off()

# exercices 6.1.1 =====

salmon.data %>% head
salmon.num <- salmon.data[ , sapply(salmon.data, FUN = is.numeric)]

apply(salmon.num, MARGIN = 2, FUN = median, na.rm = TRUE)
sapply(salmon.num, FUN = median, na.rm = TRUE)

tapply(X = salmon.data$length, INDEX = list(salmon.data$year, salmon.data$river),
   FUN = mean) %>% t %>% head(3) %>% `*`(3) %>% sum

head(t(tapply(X = salmon.data$length, INDEX = list(salmon.data$year, salmon.data$river),
       FUN = mean)), 3)

# exercices 6.2.1 ==================

#a counter 'a' from 2 to 9
max.a <- 9
storage.vec <- rep(NA, max.a - 1)

for(a in 2:max.a){
  addition <- a + 3
  storage.vec[a - 1] <- print(paste('addition =', addition, sep = ' '))
  print(paste('a value = ', a))
}

storage.vec


#Exercise 05
#Feb 16 2022
#RCS

#-----------Question 1----------#
n_dims <- runif(1,3,10)
n_dims <- as.integer(n_dims)
n_dims2 <- seq(1:(n_dims^2))
sample(n_dims2) #sample vector
n_dims2_matrix <- matrix(n_dims2, ncol = n_dims, byrow = TRUE) #create matrix
n_dims2_matrix #print matrix
t(n_dims2_matrix) #transpose matrix
sum(n_dims2_matrix[,1]) #sum of first row
sum(n_dims2_matrix[,n_dims]) #sum of last row
mean(n_dims2_matrix[,1]) #mean of first row
mean(n_dims2_matrix[,n_dims]) #mean of last row

eigen(n_dims2_matrix)
typeof(n_dims2_matrix) #integer

#--------Question 2------------#
my_matrix <- matrix(data = runif(16), nrow = 4, byrow =TRUE)
my_logical <- runif(100)
my_logical <- my_logical <= 0.5
my_logical
my_letters <- sample(letters[1:26])
my_list <- list(my_matrix,my_logical,my_letters)
my_list
new_list <- list(my_matrix[2,2], my_logical[2], my_letters[2])
new_list

typeof(my_matrix)
typeof(my_logical)
typeof(my_letters)

unlisted <- unlist(new_list)
unlisted
new_list
unlisted2 <- c(new_list[[1]],new_list[[2]],new_list[[3]])
unlisted2
typeof(unlisted2)

#----------Question 3------------#
my_unis <- runif(26,0,10)
my_letters <- sample(toupper(letters[1:26]))
df <- data.frame(my_unis,my_letters)
df
df[sample(length(df$my_unis), replace = FALSE, size = 4),1] = NA
df
typeof(df)
which(is.na(df))
df[order(df$my_letters, decreasing = FALSE),]
df
mean(df$my_unis, na.rm = TRUE)


setwd ("local")
lidarData = read.csv("BA_lidarData.csv")
# Subset data to remove "Plot" variable- first column
lidarData = lidarData[,-1]
install.packages('leaps')
library(leaps)
?regsubsets
BAregsubsets = regsubsets(BAtotal~.,data = lidarData, nbest = 4, nvmax = 3, method = 'seqrep')
summary(BAregsubsets)
plot(BAregsubsets, scale = "r2")
Lm0 = lm(BAtotal~P70+all_1st_cover_mean, data = lidarData)
Lm1 = lm(BAtotal~P70*all_1st_cover_mean, data = lidarData)
summary(Lm0)
summary(Lm1)
Lm2 = lm(BAtotal~P70:all_1st_cover_mean, data = lidarData)
summary(Lm2)
Lm3 = lm(BAtotal~P50+all_cover_mean, data = lidarData)
summary(Lm3)
plot(Lm1)
install.packages("MASS")
library(MASS)
?boxcox
boxcox(Lm1)
bcLm1 = boxcox(Lm1)
lambda <- bcLm1$x[which.max(bcLm1$y)]
# But no need to transform after all
BAtransformed = lidarData$BAtotal^lambda
names(lidarData)
Lm4 = lm(BAtotal~P40*X1st_cover_mean*all_1st_cover_mean, data = lidarData)
summary(Lm4)
plot(Lm4)
?anova
anova(Lm0,Lm1)
Lm1_BAtotal_pred = Lm1$fitted
plot(Lm1_BAtotal_pred, lidarData$BAtotal, ylab = "BAtotal observed", xlab = "BAtotal predicted")
?abline
abline(0,1,col="purple")