# Machine Learning - Regressão
# Prevendo Notas de Matemática dos Participantes do ENEM

# Configurando o diretório de trabalho
setwd("~/pCloudDrive/Profissional/ciencia-de-dados/codenation.dev/desafio_nota_do_enem")
getwd()

library(dplyr)     # Filtragens
library(psych)     # Scatterplot Matrix
library(e1071)     # SVM
library(rpart)     # RANDON FOREST
library(readr)     # GERAR CSV
library(tidyverse) # Drop_NA()
library(readxl)    # Importar xls

# ****************************************************
# ***                   DADOS                      ***
# ***                                              ***
# ****************************************************
# Etapa 1 - Coletando os dados
nota <- read.csv("train.csv")
notateste <- read.csv("test.csv")
PIB_2016 <- read_excel("PIB-2016.xls")

# ****************************************************
# ***                   INCLUIR                    ***
# ***                NOVAS VARIÁVEIS               ***
# ****************************************************
#média do pib por estado
PIB_2016 = PIB_2016 %>% filter(Ano == 2016)
PIB_2016 = PIB_2016[c(names(PIB_2016)[5], names(PIB_2016)[42])]
MEDIA_PIB_2016 = aggregate(PIB_2016$`Produto Interno Bruto per capita\n(R$ 1,00)`,
                           by=list(PIB_2016$`Sigla da Unidade da Federação`),
                           FUN = mean)
colnames(MEDIA_PIB_2016) = c("SG_UF_RESIDENCIA","media")

# Criar regioes com os estados por prova
glimpse(notateste$SG_UF_RESIDENCIA)
table(notateste$SG_UF_RESIDENCIA)
x <- c(notateste$SG_UF_RESIDENCIA)
lookup <- c( AC = "NORTE",  AL = "NORDESTE",  AM = "NORTE",  AP = "NORTE",  BA = "NORDESTE", CE = "NORDESTE", DF = "CENTRO-OESTE", ES = "SUDESTE", GO = "CENTRO-OESTE", MA = "NORDESTE", MG = "SUDESTE", MS = "CENTRO-OESTE", MT = "CENTRO-OESTE", PA = "NORTE", PB = "NORDESTE", PE = "NORDESTE", PI = "NORDESTE", PR = "SUL", RJ = "SUDESTE", RN = "NORDESTE", RO = "NORTE", RR = "NORTE", RS = "SUL", SC = "SUL", SE = "NORDESTE", SP = "SUDESTE", TO = "NORTE")
uniao = lookup[x]
regioes = unname(uniao)
table(regioes)
notateste$regioes = regioes
table(notateste$regioes)
names(table(notateste$regioes))

#Transformar os dois datasets com as mesmas variáveis
notateste = merge(notateste,MEDIA_PIB_2016)
nomes <- names(notateste)

# Criar regioes com os estados por prova
glimpse(nota$SG_UF_RESIDENCIA)
table(nota$SG_UF_RESIDENCIA)
x <- c(nota$SG_UF_RESIDENCIA)
lookup <- c( AC = "NORTE",  AL = "NORDESTE",  AM = "NORTE",  AP = "NORTE",  BA = "NORDESTE", CE = "NORDESTE", DF = "CENTRO-OESTE", ES = "SUDESTE", GO = "CENTRO-OESTE", MA = "NORDESTE", MG = "SUDESTE", MS = "CENTRO-OESTE", MT = "CENTRO-OESTE", PA = "NORTE", PB = "NORDESTE", PE = "NORDESTE", PI = "NORDESTE", PR = "SUL", RJ = "SUDESTE", RN = "NORDESTE", RO = "NORTE", RR = "NORTE", RS = "SUL", SC = "SUL", SE = "NORDESTE", SP = "SUDESTE", TO = "NORTE")
uniao = lookup[x]
regioes = unname(uniao)
table(regioes)
nota$regioes = regioes
table(nota$regioes)
names(table(nota$regioes))

#Transformar os dois datasets com as mesmas variáveis
nota = merge(nota,MEDIA_PIB_2016)

# ****************************************************
# ***                   TREINO                     ***
# ***                                              ***
# ****************************************************
# Segmentando apenas os dados que temos no teste
treinando = nota[c(nomes, "NU_NOTA_MT")]
treinando$Q027 = as.numeric(treinando$Q027)
treinando$Q027[(treinando$Q027 == 1)] <- mean(treinando$Q027)
glimpse(treinando)

#Para que eu possa pegar exatamente os nomes das variáveis mais a target
treinando = treinando %>% drop_na()
#treinando$Q027 = NULL
treinando$TP_DEPENDENCIA_ADM_ESC = NULL
treinando$TP_ENSINO = NULL
any(is.na(treinando))
# ****************************************************
# ***              FORMATO NUMÉRICO                ***
# ****************************************************
glimpse(treinando)
#Transformar para numérico
treinando$SG_UF_RESIDENCIA = as.numeric(treinando$SG_UF_RESIDENCIA)
treinando$TP_SEXO = as.numeric(treinando$TP_SEXO)
treinando$Q001 = as.numeric(treinando$Q001)
treinando$Q002 = as.numeric(treinando$Q002)
treinando$Q006 = as.numeric(treinando$Q006)
treinando$Q024 = as.numeric(treinando$Q024)
treinando$Q025 = as.numeric(treinando$Q025)
treinando$Q026 = as.numeric(treinando$Q026)
treinando$Q047 = as.numeric(treinando$Q047)
treinando$CO_PROVA_CN = as.numeric(treinando$CO_PROVA_CN)
treinando$CO_PROVA_CH = as.numeric(treinando$CO_PROVA_CH)
treinando$CO_PROVA_LC = as.numeric(treinando$CO_PROVA_LC)
treinando$CO_PROVA_MT = as.numeric(treinando$CO_PROVA_MT)
treinando$regioes = as.factor(treinando$regioes)
treinando$regioes = as.numeric(treinando$regioes)
treinando = treinando[c(-1)]
nota = treinando
treinando = treinando[c(-1)]

glimpse(treinando)

# ****************************************************
# ***                   TESTE                      ***
# ***                                              ***
# ****************************************************

# Criar variável de segurança
testando = notateste
testando$Q027 = as.numeric(testando$Q027)
testando$Q027[(treinando$Q027 == 1)] <- mean(testando$Q027)

#testando$Q027 = NULL
testando$TP_DEPENDENCIA_ADM_ESC = NULL
testando$TP_ENSINO = NULL

## LIMPEZA Retirando valores NA da tabela
testando = testando %>% drop_na()
any(is.na(testando))

# Transformar variaveis em numeric
testando$SG_UF_RESIDENCIA = as.numeric(testando$SG_UF_RESIDENCIA)
testando$TP_SEXO = as.numeric(testando$TP_SEXO)
testando$Q001 = as.numeric(testando$Q001)
testando$Q002 = as.numeric(testando$Q002)
testando$Q006 = as.numeric(testando$Q006)
testando$Q024 = as.numeric(testando$Q024)
testando$Q025 = as.numeric(testando$Q025)
testando$Q026 = as.numeric(testando$Q026)
testando$Q047 = as.numeric(testando$Q047)
testando$CO_PROVA_CN = as.numeric(testando$CO_PROVA_CN)
testando$CO_PROVA_CH = as.numeric(testando$CO_PROVA_CH)
testando$CO_PROVA_LC = as.numeric(testando$CO_PROVA_LC)
testando$CO_PROVA_MT = as.numeric(testando$CO_PROVA_MT)
testando$regioes = as.factor(testando$regioes)
testando$regioes = as.numeric(testando$regioes)
notateste = testando
testando$NU_INSCRICAO = NULL

# Vizualizar se os dados estão em estado numérico para envolver no algoritmo
glimpse(testando)

# ****************************************************
# ***               MODELOS DE ML                  ***
# ***                                              ***
# ****************************************************

##Regressão linear múltipla
# Etapa 3: Treinando o Modelo (usando os dados de treino)
modelo <- lm(NU_NOTA_MT ~ ., data = treinando)

# Visualizando os coeficientes
modelo

previsao1 <- predict(modelo)
View(previsao1)

#treinando$Prev = previsao1

# Etapa 4: Avaliando a Performance do Modelo
# Mais detalhes sobre o modelo
summary(modelo)
####### -> 48%

# Lembre-se que correlação não implica causalidade

#### RANDONFOREST (Arvores de decisão) ####
trainset = treinando
testset = testando

modelo_rf_v1 = rpart(NU_NOTA_MT ~ ., data = trainset, control = rpart.control( cp = .0009999999))
summary(modelo_rf_v1)

# Previsões nos dados de teste
tree_pred = predict(modelo_rf_v1, testset)

enviotree = data.frame(notateste$NU_INSCRICAO)
colnames(enviotree) = c("NU_INSCRICAO")
enviotree$NU_NOTA_MT = tree_pred

write.csv(enviotree, "answer.csv", row.names = FALSE)


master.file.df <- as.data.frame(fread(paste(input.local.data.dir,"master.file.csv",sep="")))
master.file.df <- subset(master.file.df, use.this == "yes")

dataset.names <- sort(unique(master.file.df$dataset))
for(this.dataset in dataset.names){

  # this.dataset<- "horse-colic"; this.dataset <- "lung-cancer"
  print(this.dataset)
  suppressWarnings(this.dataset.df <- as.data.frame(fread(paste(input.data.dir,"ml-datasets/",this.dataset,".data.txt",sep=""))))

  this.response.index <- ifelse(subset(master.file.df, dataset == this.dataset)$index.of.response == "last", ncol(this.dataset.df), 1)

  this.dataset.df <- this.dataset.df[this.dataset.df[,this.response.index] != "?",]

  these.levels <- sort(unique(this.dataset.df[,this.response.index]))
  n.levels <- length(these.levels)
  # these.levels <- c("foo", "bar")

  suppressWarnings(is.na <- is.na(as.numeric(these.levels[1])))

  response.hash <- NULL
  if(!is.na){

     these.levels <- as.character(these.levels)

     if(n.levels==2){
       map.values <- c("no","yes")
     }else{
      map.values <- letters[1:n.levels]
     }

     response.hash <- hash(keys = these.levels, values = map.values)
     print(paste(this.dataset, "- Mapping ", paste(these.levels, collapse=" ") ,"  to ", paste(letters[1:n.levels], collapse=" ")))

     this.dataset.df[,this.response.index] <- unlist(lapply(this.dataset.df[,this.response.index], function(x){ response.hash[[as.character(x)]] }))

  }

  this.split.data <- split.data(this.dataset.df, 0.7)

  this.holdout <- this.split.data[[1]]
  this.training <- this.split.data[[2]]

  write.table(this.holdout, file = paste(downloaded.ml.data, this.dataset, ".data.holdout.txt",sep=""), quote = FALSE,row.names=FALSE,col.names=FALSE, sep=",", na="")
  write.table(this.training, file = paste(downloaded.ml.data, this.dataset, ".data.training.txt",sep=""), quote = FALSE,row.names=FALSE,col.names=FALSE, sep=",", na="")

}


###(1)Set single feature of negative samples as the minimal value of ones in positive samples
true_negative=read.table("true_negative.txt",sep="\t",quote="",header=T)   ###true negative dataset
positive=read.table("positive.txt",sep="\t",quote="",header=T)  ##positive dataset
temp=true_negative
for(i in 2:(ncol(temp)-2)){
n=which(colnames(positive)==colnames(temp)[i])
positive_min=min(positive[,n])
temp[,i]=positive_min
write.table(temp,paste("single/",colnames(temp)[i],".csv"),sep=",",quote=F,row.names=F)
temp=true_negative
}

###(2)Set feature pairs of negative samples as the minimal value of ones in positive samples
temp=true_negative
for(i in 2:(ncol(temp)-3)){
for(j in (i+1):(ncol(temp)-2)){
n1=which(colnames(positive)==colnames(temp)[i])
positive_min1=min(positive[,n1])
temp[,i]=positive_min1

n2=which(colnames(positive)==colnames(temp)[j])
positive_min2=min(positive[,n2])
temp[,j]=positive_min2

write.table(temp,paste("combine/",colnames(temp)[i],colnames(temp)[j],".csv"),sep=",",quote=F,row.names=F)
temp=true_negative
}
}


################################################################################
# * The contents of this file are Teradata Public Content and have been released
# * to the Public Domain.
# * Tim Miller & Alexander Kolovos - October 2019 - v.1.0
# * Copyright (c) 2019 by Teradata
# * Licensed under BSD; see "license.txt" file in the bundle root folder.
#
# ##############################################################################
# R and Python TechBytes Demo - Part 4: R in-nodes with SCRIPT and ExecR
# ------------------------------------------------------------------------------
# File: RFScore.r
# ------------------------------------------------------------------------------
# The R and Python TechBytes Demo comprises of 5 parts:
# Part 1 consists of only a Powerpoint overview of R and Python in Vantage
# Part 2 demonstrates the Teradata R package tdplyr for clients
# Part 3 demonstrates the Teradata Python package teradaml for clients
# Part 4 demonstrates using R in-nodes with the SCRIPT and ExecR Table Operators
# Part 5 demonstrates using Python in-nodes with the SCRIPT Table Operator
# ##############################################################################
#
# This TechBytes demo utilizes a use case to predict the propensity of a
# financial services customer base to open a credit card account.
#
# The present file is the scoring script to be used in USE CASE [1] of this
# demo. Scoring will take place in the Advanced SQL Engine of the target
# Vantage system via the SCRIPT Table Operator, and demonstrates using R code
# with SCRIPT.
#
# The present script
# a. reads the RFmodel object prepared in the context of USE CASE [1] in the
#    "R_Py_TechBytes-Part_4-Demo.r" file
# b. performs the predict() task on each AMP in the Advanced SQL Engine of the
#    target Vantage system.
# To execute the present script in the database, follow the steps in Section 2
# of USE CASE [1] in the "R_Py_TechBytes-Part_4-Demo.r" file.
################################################################################

DELIMITER='\t'

stdin <- file(description="stdin",open="r")

inputDF <- data.frame();

# NOTE: You must know in advance the name and type of the input columns.
#       Cite them in following two vectors to feed the colClasses and col.names
#       arguments of the read.table() function.
#
# cust_id         <integer>
# tot_income      <double>
# tot_age         <integer>
# tot_cust_years  <integer>
# tot_children    <integer>
# female_ind      <integer>
# single_ind      <integer>
# married_ind     <integer>
# seperated_ind   <integer>
# ca_resident_ind <integer>
# ny_resident_ind <integer>
# tx_resident_ind <integer>
# il_resident_ind <integer>
# az_resident_ind <integer>
# oh_resident_ind <integer>
# ck_acct_ind     <integer>
# cc_acct_ind     <factor>
# sv_acct_ind     <integer>
# ck_avg_bal      <double>
# sv_avg_bal      <double>
# cc_avg_bal      <double>
# ck_avg_tran_amt <double>
# sv_avg_tran_amt <double>
# cc_avg_tran_amt <double>
# q1_trans_cnt    <integer>
# q2_trans_cnt    <integer>
# q3_trans_cnt    <integer>
# q4_trans_cnt    <integer>

cn <- c("cust_id", "tot_income", "tot_age", "tot_cust_years", "tot_children", "female_ind",
        "single_ind", "married_ind", "seperated_ind", "ca_resident_ind", "ny_resident_ind",
        "tx_resident_ind", "il_resident_ind", "az_resident_ind", "oh_resident_ind",
        "ck_acct_ind", "cc_acct_ind", "sv_acct_ind", "ck_avg_bal", "sv_avg_bal", "cc_avg_bal",
        "ck_avg_tran_amt", "sv_avg_tran_amt", "cc_avg_tran_amt", "q1_trans_cnt",
        "q2_trans_cnt", "q3_trans_cnt", "q4_trans_cnt")

ct <- c("integer", "double", "integer", "integer", "integer", "integer", "integer",
        "integer", "integer", "integer", "integer", "integer", "integer", "integer", "integer",
        "integer", "factor", "integer", "double", "double", "double", "double", "double",
        "double", "integer", "integer", "integer", "integer")

inputDF <- try(read.table(stdin, sep=DELIMITER, flush=TRUE, header=FALSE, quote="",
                          na.strings="", colClasses=ct, col.names=cn), silent=TRUE)

close(stdin)

# For AMPs that receive no data, choose to simply quit the script immediately.

if (class(inputDF) == "try-error") {
  inputDF <- NULL
  quit()
}

# "tdatuser" is the user who executes the present script within the Script TO,
# and this user must have permission to read output objects from the specified
# destinations in the following. Ensure "root" user pre-sets proper permissions.

suppressPackageStartupMessages(library("randomForest"))

# Before you execute the following statement, replace <DBNAME> with the
# database name in the target Vantage Advanced SQL Engine where the .Rds
# R model file was saved in the bottom of Section 1 of the Use Case [1]
# segment in the "R_Py_TechBytes-Part_4-Demo.r" file.
ScoreModel <- readRDS("./<DBNAME>/RFmodel.rds")

Predicted <- predict(ScoreModel, newdata=inputDF, type="vote")

# Build export data frame:

Scores <- data.frame(inputDF$cust_id, Predicted, inputDF$cc_acct_ind)

# Export results to Teradata through standard output

write.table(Scores, file=stdout(), col.names=FALSE, row.names=FALSE,
            quote=FALSE, sep="\t", na="")


library(WatershedTools)
library(raster)
args <- commandArgs(trailingOnly = TRUE)[1]

metadat <- fread("catchment_list.csv")[catchment == "vjosa"]
shareDir <- file.path(metadat$dir, metadat$catchment, metadat$version)
scratchDir <- "~/Desktop/Vjosa/tmp"
dir.create(scratchDir, showWarnings=FALSE)

caPoints <- readRDS(file.path(shareDir, "tmp", "caPoints_byReach.rds"))
max_jobs <- 12
cutoffs <- floor(seq(1, length(caPoints), length.out=max_jobs+1))
jobNum <- as.integer(args[1])

dir <- file.path(scratchDir, jobNum)
gDir <- file.path(dir, 'grass')
if(!dir.exists(dir))
	dir.create(dir)
if(!dir.exists(gDir))
	dir.create(gDir)

drain <- raster(file.path(shareDir, "drainage.tif"))

if(jobNum == 0) {
	inds <- 1
} else if(jobNum == -1) {
	caFiles <- list.files(scratchDir, pattern = "[0-9]+", full.names = TRUE, recursive = TRUE)
	library(data.table)
	caData <- rbindlist(lapply(caFiles, function(x) as.data.table(readRDS(x))))
	caRaster <- rasterFromXYZ(caData, crs = proj4string(drain))
	caRaster <- writeRaster(caRaster, file = file.path(shareDir, "catchment_area.tif"),
		options = c("COMPRESS=LZW", "PREDICTOR=3"))
} else if(jobNum <= max_jobs) {
	gisbase <- WatershedTools:::getGISBase()
	tryCatch(rgrass7::use_sp(), error = function(e) warning(e))
	gs <- GrassSession(layer = drain, gisBase = gisbase, layerName = "drainage",
		home = gDir, override = TRUE)
	rm(drain)
	gc()

	# choose which reaches to work on
	inds <- cutoffs[jobNum]:cutoffs[jobNum+1]

	# loop over reaches
	done <- 0
	for(i in inds) {
		rName <- names(caPoints)[i]
		oname <- paste0(dir, "/ca_r", rName, ".rds")

		# skip if we are already done, allows resuming
		if(file.exists(oname)) {
			done <- done + 1
			next()
		}

		pts <- as.matrix(caPoints[[i]])
		# loop over points within reaches
		catchmentAreas <- catchment(pts, "drainage", areas = TRUE, gs = gs)
		catchmentAreas <- cbind(pts, catchmentAreas)
		saveRDS(catchmentAreas, oname)

		# print something showing progress
		done <- done + 1
		cat("\n", as.character(Sys.time()), "Finished reach number", rName,
			"\n   Number", done, "of", length(inds), "\n\n")
	}
	unlink(gDir, recursive = TRUE)
	cat("Finished with job", jobNum, "\n")

} else {
	stop("Please specify a number on the command line:\n  0: test\n  -1: finish\n  1-",
		max_jobs, ": do this job number")
}


# The MIT License (MIT)
# Copyright (c) 2017 Louise AC Millard, MRC Integrative Epidemiology Unit, University of Bristol
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
# documentation files (the "Software"), to deal in the Software without restriction, including without
# limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
# the Software, and to permit persons to whom the Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions
# of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
# TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.

# splits the pheno into 3 bins with the cut points between values rather at the exact value for the quantile
equalSizedBins <- function(phenoAvg) {

	## equal sized bins
        q = quantile(phenoAvg, probs=c(1/3,2/3), na.rm=TRUE)

	minX = min(phenoAvg, na.rm=TRUE)
	maxX = max(phenoAvg, na.rm=TRUE)

	phenoBinned = phenoAvg;
	if (q[1]==minX) {
		# edge case - quantile value is lowest value

		# assign min value as cat1
		idx1 = which(phenoAvg==q[1]);
		phenoBinned[idx1] = 0;

		# divide remaining values into cat2 and cat3
		phenoAvgRemaining = phenoAvg[which(phenoAvg!=q[1])];
		qx = quantile(phenoAvgRemaining, probs=c(0.5), na.rm=TRUE)
		minXX = min(phenoAvgRemaining, na.rm=TRUE)
		maxXX =	max(phenoAvgRemaining, na.rm=TRUE)

		if (qx[1]==minXX) {
			# edge case again - quantile value is lowest value
			idx2 = which(phenoAvg==qx[1]);
			idx3 = which(phenoAvg>qx[1]);
			cat("Bin 1: ==", q[1],", bin 2: ==",qx[1], "bin 3: >", qx[1], " || ", sep="")
		}
		else if (qx[1]==maxXX) {
			# edge case again - quantile value is max value
			idx2 = which(phenoAvg<qx[1] & phenoAvg>q[1]);
			idx3 = which(phenoAvg==qx[1]);
			cat("Bin 1: ==", q[1],", bin 2: > ",q[1], " AND <", qx[1] , "bin 3: ==", qx[1], " || ", sep="")
		}
		else {
			idx2 = which(phenoAvg<qx[1] & phenoAvg>q[1]);
			idx3 = which(phenoAvg>=qx[1]);
			cat("Bin 1: ==", q[1],", bin 2: > ",q[1], " AND <", qx[1] , "bin 3: >=", qx[1], " || ", sep="")
		}
		phenoBinned[idx2] = 1;
                phenoBinned[idx3] = 2;
	}
	else if (q[2]==maxX) {
		# edge case - quantile value is highest value

		# assign max value as cat3
		idx3 = which(phenoAvg==q[2]);
		phenoBinned[idx3] = 2;

		# divide remaining values into cat1 and cat2
		phenoAvgRemaining = phenoAvg[which(phenoAvg!=q[2])];
                qx = quantile(phenoAvgRemaining, probs=c(0.5), na.rm=TRUE)
		minXX = min(phenoAvgRemaining, na.rm=TRUE)
                maxXX = max(phenoAvgRemaining, na.rm=TRUE)

		if (qx[1]==minXX) {
			# edge case again - quantile value is lowest value
                        idx1 = which(phenoAvg==qx[1]);
                        idx2 = which(phenoAvg>qx[1] & phenoAvg<q[2]);
			cat("Bin 1: ==", qx[1], ", bin 2: >", qx[1], " AND < ", q[2], ", bin 3: ==", q[2], " || ", sep="")
                }
                else if	(qx[1]==maxXX) {
			# edge case again - quantile value is max value
                        idx1 = which(phenoAvg<qx[1]);
                        idx2 = which(phenoAvg==qx[1]);
			cat("Bin 1: <", qx[1], ", bin 2: ==", qx[1], ", bin 3: ==", q[2], " || ", sep="")
                }
                else {
	                idx1 = which(phenoAvg<qx[1]);
			idx2 = which(phenoAvg>=qx[1] & phenoAvg<q[2]);
			cat("Bin 1: <", qx[1], ", bin 2: >=", qx[1], " AND < ", q[2], ", bin 3: ==", q[2], " || ", sep="")
		}

                phenoBinned[idx1] = 0;
                phenoBinned[idx2] = 1;
	}
       else if (q[1] == q[2]) {
		# both quantiles correspond to the same value so set
		# cat1 as < this value, cat2 as exactly this value and
		# cat3 as > this value
              	phenoBinned = phenoAvg;
        	idx1 = which(phenoAvg<q[1]);
                idx2 = which(phenoAvg==q[2]);
                idx3 = which(phenoAvg>q[2]);
                phenoBinned[idx1] = 0;
                phenoBinned[idx2] = 1;
                phenoBinned[idx3] = 2;

		cat("Bin 1: <", q[1], ", bin 2: ==", q[2], ", bin 3: >", q[2], " || ", sep="")
       	}
        else {
		# standard case - split the data into three roughly equal parts where
		# cat1<q1, cat2 between q1 and q2, and cat3>=q2
         	phenoBinned = phenoAvg;
                idx1 = which(phenoAvg<q[1]);
                idx2 = which(phenoAvg>=q[1] & phenoAvg<q[2]);
               	idx3 = which(phenoAvg>=q[2]);
                phenoBinned[idx1] = 0;
                phenoBinned[idx2] = 1;
                phenoBinned[idx3] = 2;

		cat("Bin 1: <", q[1], ", bin 2: >=", q[1], "AND < ", q[2] ,", bin 3: >=", q[2], " || ", sep="")
	}

	cat("cat N: ", length(idx1),", ",length(idx2),", ",length(idx3), " || ", sep="");

	return(phenoBinned);
}


library(GEOquery)
library(limma)

# get the data from GEO ( GSE matrix & annotation GPL)
# define destination to save data, SO didn't need load data each time
series = "GSE34670"
platform = "GPL96"
gset = getGEO(series, GSEMatrix =TRUE, AnnotGPL=TRUE, destdir = "Data/")
# if the data have several platforms, choose the certain platform
if (length(gset) > 1) idx <- grep(platform, attr(gset, "names")) else idx <- 1
gset = gset[[idx]]

# define groups for samples
gr = c(rep("cALL_BM", 5) , "cALL_PB" ,rep("cALL_BM", 19), "CL_cALL2" , "CL_697" , "CL_NALM6" , rep("CD10", 6), rep("CD10_pool" , 3) )
# elicit expression matrix from data
ex = exprs(gset)

# log2 transformation
ex = log2(ex + 1 )
exprs(gset) = ex

## Differential expression analysis
# turn our groups to factor & assign it as gset$description
gr = factor(gr)
gset$description = gr

# create a design matrix to show samples are belong to which level
design = model.matrix(~description + 0, gset)
colnames(design) = levels(gr)

# fit a leaner model to data
fit = lmFit(gset, design)

# define the levels which we want make contrast & calculate p-value
cont.matrix = makeContrasts(cALL_BM-CD10, levels=design)
fit2 = contrasts.fit(fit, cont.matrix)
fit2 = eBayes(fit2, 0.01)

# make a top Table / adjust by false discovery rate (fdr)(benjamini-hochberg), default one
tT = topTable(fit2, adjust="fdr", sort.by="B", number=Inf)
# extract a subset of required columns and write the table
tT = subset(tT, select=c("Gene.symbol","Gene.ID","adj.P.Val","logFC"))
write.table(tT, "Results/cALL_CD10.txt", row.names=F, sep="\t", quote = F)

# extract a subset of genes with adjusted_P_Value < 0.05 & log fold change more than 2_fold
ALL.up = subset(tT, logFC > 1 & adj.P.Val < 0.05)
ALL.up.genes = unique(as.character(strsplit2(ALL.up$Gene.symbol, "///")))
write.table(ALL.up.genes, file = "Results/cALL_CD10-UP.txt", quote = F, row.names = F , col.names = F)

#extract a subset of genes with adjusted_P_Value < 0.05 & log fold change less than 1/2_fold
ALL.down = subset(tT, logFC <  -1 & adj.P.Val < 0.05)
ALL.down.genes = unique(as.character(strsplit2(ALL.down$Gene.symbol, "///")))
write.table(ALL.down.genes, file = "Results/cALL_CD10-down.txt", quote = F, row.names = F , col.names = F)

Differential Expression Analysis/Differential expression analysis.r


  # --------------------------------- multispecies analysis ---------------
  # TODO: complete; not yet completed

  ordinate = function(x, varname, threshold=0.1, transf="log") {

    k = 1e8         # a large constant number to make xtabs work

    x = x[is.finite (x[,varname]),]
    x$id = paste(x$trip, x$set,  sep="~")
    m = xtabs( as.integer(x$totno*k) ~ as.factor(id) + as.factor(spec), data=x ) / k

    i = unique(c(which(rowSums(m)/dim(m)[1] < threshold ), which( rowSums(m)==0 ) ))
    j = unique(c(which(colSums(m)/dim(m)[1] < threshold ), which( colSums(m)==0 ) ))

      if (length(i) > 0 ) m = m[ -i , ]
      if (length(j) > 0 ) m = m[ , -j ]

      if (transf == "log" ) m = log10(m + 1)
      ord = cca( m )
      sp.sc = scores(ord)$species
      si.sc = scores(ord)$sites

      scores = data.frame( id=rownames(si.sc), ca1=as.numeric(si.sc[,1]), ca2=as.numeric(si.sc[,2]) )
      scores$id = as.character(scores$id)

  }


# load the R libraries
library(tidyverse)
library(stringr)
library(edgeR) # used in Parts 2 and 3

# Set up to select the proper columns and label them
keep <- c(1, 2, 5, 6, 9, 10)
labels = c("a_25", "b_20", "c_15", "d_10", "e_5", "f_2.5")

# read in the PSM dataset, keep the 6 columns, and set labels
psm_start <- read_csv("psm_tmt.csv")
psm_start <- psm_start[keep]
colnames(psm_start) <- labels

# PAW Grouped peptides
peptide_start <- read_csv("grouped_peptide_summary_TMT_8.csv")
peptide_start <- peptide_start[keep]
colnames(peptide_start) <- labels

# PAW grouped proteins
protein_start <- read_csv("grouped_protein_summary_TMT_8.csv")
protein_start <- protein_start[keep]
colnames(protein_start) <- labels

# filter out rows with any missing data points and see how many rows remain
psms <- psm_start[apply(psm_start, 1, function(x) all(x > 0)), ]
print("PSMs (before and after filtering zeros):")
format(c(nrow(psm_start), nrow(psms)), digits = 0, big.mark = ',')

peptides <- peptide_start[apply(peptide_start, 1, function(x) all(x > 0)), ]
print("Peptides (before and after filtering zeros):")
format(c(nrow(peptide_start), nrow(peptides)), digits = 0, big.mark = ',')

proteins <- protein_start[apply(protein_start, 1, function(x) all(x > 0)), ]
print("Proteins (before and after filtering zeros):")
format(c(nrow(protein_start), nrow(proteins)), digits = 0, big.mark = ',')

# check column sums for PSMs, peptides, and proteins
print("PSMs column sums:")
format(round(colSums(psms), digits = 0), big.mark = ",")

print("Peptide column sums:")
format(round(colSums(peptides), digits = 0), big.mark = ",")

print("Protein column sums:")
format(round(colSums(proteins), digits = 0), big.mark = ",")

show_densities <- function(df, xmin, xmax, title) {
    # makes density distributions of the log2 intensities
        # df - data frame with TMT intensities
        # xmin, xmax - x axis limits
        # title- plot title

    # get data in long form
    df_long <- gather(log2(df), key = "dilution", value = "intensity")

    # make the density plots colored by dilution
    ggplot(df_long, aes(x = intensity, fill = dilution)) +
        geom_density(alpha = 0.2) +
        ggtitle(title) +
        xlim(xmin, xmax)
}

# compare PSM intensity (peak heights) distributions
show_densities(psms, 5, 25, "PSM data")

# compare peptide intensity (peak heights) distributions
show_densities(peptides, 5, 25, "Peptide data")

# compare protein intensity (peak heights) distributions
show_densities(proteins, 0, 30, "Protein data")

# helper function for scatter plots
show_scatter <- function(df, title) {
    # makes linear scale scatter plots (all series against reference)
        # df - tidy data frame with intensities and average reference vector
        # title - plot title

    # add the reference column (average) and put into long form for ggplot
    df$ref <- rowMeans(df)
    gg_df <- gather(df, key = dilution, value = intensity, a_25:f_2.5)

    # make the full range scatter plot
    full  <- ggplot(data = gg_df, aes(x = ref, y = intensity)) +
        geom_point(aes(color = dilution, shape = dilution), alpha = 0.5) +
        geom_smooth(aes(color = dilution), method = "lm") +
        ggtitle(title)

    # expanded scale
    expanded <- ggplot(data = gg_df, aes(x = ref, y = intensity)) +
        geom_point(aes(color = dilution, shape = dilution), alpha = 0.5) +
        geom_smooth(aes(color = dilution), method = "lm") +
        coord_cartesian(xlim = c(0, 500000), ylim = c(0, 500000)) +
        ggtitle(str_c(title, " (expanded scale)"))

    print(full)
    print(expanded)
}

# scater plots for PSMs
show_scatter(psms, "raw PSMs")

# scater plots for peptides
show_scatter(peptides, "Peptides")

# scater plots for proteins
show_scatter(proteins, "Proteins")

# MA style plot for PSMs
show_MA_plot <- function(df, title) {
    # transforms the data and makes MA plots (all versus reference)
        # df - data frame with intensities and reference vector
        # title - plot title

    # take ratios relative to reference then log transform
    df$ref <- rowMeans(df)
    log_df <- log2(df[1:6] / df$ref) # these are log 2
    log_df$ref <- log10(df$ref) # this stays in log 10

    # we need data in tidy long form
    gg_log_df <- gather(log_df, key = dilution, value = log_ratios, a_25:f_2.5)

    # compute the expected horizontal lines
    ratios <- log2(colMeans(df)[1:6] / colMeans(df)[7])

    # make the plot
    ggplot(data = gg_log_df, aes(x = ref, y = log_ratios)) +
        geom_point(aes(color = dilution, shape = dilution), alpha = 0.3) +
        geom_hline(yintercept = ratios) +
        xlab("log ref intensity") +
        ggtitle(title)
}

# make some MA plots for PSMs
show_MA_plot(psms, "PSMs (MA plot)")

# make some MA plots for peptides
show_MA_plot(peptides, "Peptides (MA plot)")

# make some MA plots for proteins
show_MA_plot(proteins, "Proteins (MA plot)")

# how close were the measured dilution factors?
tot_int <- sum(colSums(proteins))
unit <- tot_int / sum(c(25, 20, 15, 10, 5, 2.5))
round(colSums(proteins) / unit, 2)

# loading the edgeR library was done at the top of the notebook
# load data into DGEList objects (counts are intensities, group are sample labels)
# the original data frames have added columns so we need just the first 6 cols

# PSMs first
y_psms  <- DGEList(counts = psms[1:6], group = factor(labels))
y_psms$samples

# peptides next
y_peptides  <- DGEList(counts = peptides[1:6], group = factor(labels))
y_peptides$samples

# finally, proteins
y_proteins  <- DGEList(counts = proteins[1:6], group = factor(labels))
y_proteins$samples

# these are the original column sums (they should match the library sizes)
round(colSums(proteins[1:6]), 0)

# dividing by library sizes makes each sample sum to 1.0
scaled_proteins <- sweep(proteins[1:6], 2, y_proteins$samples$lib.size, FUN = "/")
round(head(scaled_proteins), 8)
colSums(scaled_proteins)

# make our own cpm scale
cpm_proteins <- scaled_proteins * 1000000
round(head(cpm_proteins), 0)
colSums(cpm_proteins)

# use the cpm function in edgeR
round(head(cpm(y_proteins)), 0)
colSums(cpm(y_proteins))

# compute TMM factors - they get added to $samples
y_proteins_tmm <- calcNormFactors(y_proteins)
# round(y_proteins_tmm$samples$norm.factors, 6)
y_proteins_tmm$samples

# see what column sums we get after a cpm function call now that there are TMM factors
round(colSums(cpm(y_proteins_tmm)), 0)
round(mean(colSums(cpm(y_proteins_tmm))))

# adjust the library sizes by the TMM factors to get the real library size factors
real_factors <- y_proteins_tmm$samples$lib.size * y_proteins_tmm$samples$norm.factors

# apply the factors to get the TMM normalized data table (fractional scale)
proteins_tmm_norm <- sweep(proteins[1:6], 2, real_factors, FUN = "/")

# put TMM normalized data on a one million scale
by_hand_cpm <- proteins_tmm_norm * 1000000

round(head(by_hand_cpm), 0)
round(colSums(by_hand_cpm), 0)
round(mean(colSums(by_hand_cpm)))

# make multi-dimensional scaling plots to see if series are similar
plotMDS(calcNormFactors(y_psms), main = "PSMs")
plotMDS(calcNormFactors(y_peptides), main = "Peptides")
plotMDS(calcNormFactors(y_proteins), main = "Proteins")

# define a function for normalizing data and computing CVs
get_cv <- function(DGE) {
    # normalizes edgeR data, makes cpm scale, computes CV distribution
        # DGE - edgeR DGEList object
        # returns a CV distribution vector

    # get a cmp scale table of normalized data
    CPM <- as.data.frame(cpm(calcNormFactors(DGE)))

    # compute CVs for first 4 channels (drop the 5 and 2.5 dilutions)
    cv <- 100 * apply(CPM[1:4], 1, sd) / rowMeans(CPM[1:4])
}

# compute the CVs and look at the distribution summary numbers
psm_cvs <- get_cv(y_psms)
peptide_cvs <- get_cv(y_peptides)
protein_cvs <- get_cv(y_proteins)

print("PSM CVs:")
summary(psm_cvs)

print("Peptide CVs:")
summary(get_cv(y_peptides))

print("Protein CVs:")
summary(get_cv(y_proteins))

BP <- function(cv, ymax, title) {
    # returns a labeled boxplot
        # cv - vector of CV values
        # ymax - upper limit for plot
        # title - main plot title

    # make the box plot and label the median
    bp  <- boxplot(cv, ylim = c(0, ymax), notch = TRUE, main = title)
    label <- text(x = 0.65, y = boxplot.stats(cv)$stats[3],
         labels = round(boxplot.stats(cv)$stats[3], 1))
    list(bp, label)
}

# compare some box plots of the CV distributions
par(mfrow = c(1, 3))
plot.label <- BP(get_cv(y_psms), 100, "PSMs")
plot.label <- BP(get_cv(y_peptides), 100, "Peptides")
plot.label <- BP(get_cv(y_proteins), 100, "Proteins")
par(mfrow = c(1, 1))

# log the R session (we should always end notebooks with this)
sessionInfo()


#R Vignere Functions Document

alphabet <- c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k",
"l", "m", "n", "o", "p", "q", "r", "s",
"t", "u", "v", "w", "x", "y", "z")

english_frequencies <- data.frame(
    letters = alphabet,
    frequencies = c(8.4966, 2.0720, 4.5388, 3.3844, 11.1607, 1.8121, 2.4705,
    3.0034, 7.5448, 0.1965, 1.1016, 5.4893, 3.0129, 6.6544, 7.1635, 3.1671,
    0.1962, 7.5809, 5.7351, 6.9509, 3.6308, 1.0074, 1.2899, 0.2902, 1.7779,
    0.2722) / 100
)

#Removes all punctuation, upper case letters and spaces from a string
format_func <- function(string) {
    string <- gsub("[[:punct:][:blank:]]", "", string)
    string <- gsub("[0-9]", "", string)
    string <- tolower(string)
    return(string)
}

#Function returns the encrypted text by applying the vigenere cipher
#Function requires a key, and a string, returns the ciphertext
encrypt_func <- function(text, key) {
    encrypted <- c()
    #loop to get alphabetical indexes of the characters in the text
    split_text <- strsplit(text, "")[[1]] #creates a character class
    for (i in 1:nchar(text)) {
        letter_index <- which(alphabet %in% split_text[i])
        j <- i %% nchar(key)
        if (j == 0) {
            j <- nchar(key)
        }
        key_index <- which(alphabet %in% substring(key, j, j))
        #applying the relevant shift to the letters, using the vigenere cipher
        alphabet_index <- (letter_index + key_index - 2) %% length(alphabet) + 1
        encrypted <- paste(encrypted, alphabet[alphabet_index], sep = "")
    }
    return(encrypted)
}

decrypt <- function(ciphertext, key) {
    decrypted <- c()
    for (i in 1:nchar(ciphertext)) {
        j <- i %% nchar(key)
        if (j == 0) {
            j <- nchar(key)
        }
        key_index <- which(alphabet %in% substring(key, j, j))
        cipher_index <- which(alphabet %in% substring(ciphertext, i, i))
        alphabet_index <- (cipher_index - key_index) %% 26 + 1
        decrypted <- paste(decrypted, alphabet[alphabet_index], sep = "")
    }
    return(decrypted)
}

#Kasiski Algorithm Functions to find the key length

#Repeats function, finds all n letter repeats within the ciphertext
#   then counts their frequency, finds the spacing between repeats,
#   then finds the most comming factor of all the spacings (kas_mode)
repeats <- function(ciphertext, n) {
    elements <- c()
    indexes <- list()
    spacings <- list()
    for (i in 1:nchar(ciphertext)) {
        if (i <= nchar(ciphertext) - n + 1) {
            substr <- substring(ciphertext, i, i + n - 1)
            if (substr %in% elements == FALSE) {
                elements <- c(elements, substr)
                data <- gregexpr(substr, ciphertext)
                data2 <- list("attributes<-" (data[[1]], NULL))
                indexes <- append(indexes, data2)
                if (length(data2[[1]]) > 1) {
                    diff <- c()
                    for (j in 1:(length(data2[[1]]) - 1)) {
                        for (k in 1:(length(data2[[1]]) - j)) {
                            diff <- c(diff, data2[[1]][j + k] - data2[[1]][j])
                        }
                    }
                    spacings <- append(spacings, diff)
                }
            }
        }
    }
    factors_matrix <- c()
    for (i in 2:nchar(ciphertext)) {
        counts <- 0
        for (d in spacings) {
            if ((d %% i) == 0) {
                counts <- counts + 1
            }
        }
        if (counts != 0) {
            factors_matrix <- rbind(factors_matrix, c(i, counts))
        }
    }
    kas_mode <- 0
    mode_val <- 0
    for (r in 1:nrow(factors_matrix)) {
        if (factors_matrix[r, 2] >= mode_val) {
            kas_mode <- factors_matrix[r, 1]
            mode_val <- factors_matrix[r, 2]
        }
    }
    return(kas_mode)
}

#Function takes every nth letter starting from index m,
#where m is in range 0:n-1
str_subset <- function(junk, n, m) {
   ifelse(n == 1, junk,
paste(strsplit(junk, split = NULL)[[1]][(1:nchar(junk)) %% n == m],
collapse = ""))
}

#Function below returns a list of the ciphertext split into n=key_length
#subsections, so that letter frequency analysis can be used
nth_letter <- function(key_length, ciphertext) {
    list_of_substrings <- c()
    sub_indexes <- 1:(key_length - 1)
    sub_indexes <- append(sub_indexes, 0)
    if (key_length == 1) {
        sub_indexes <- c(1)
    }
    for (i in sub_indexes) {
        list_of_substrings <- append(list_of_substrings,
        str_subset(ciphertext, key_length, i))
    }
    return(list_of_substrings)
}

sub_letter_totals <- function(key_length, ciphertext) {
    sorted_frequencies <- c()
    list_of_substrings <- nth_letter(key_length, ciphertext)
    index <- 1
    for (sub in list_of_substrings) {
        letter_freqs <- c()
        sub_split <- strsplit(sub, "")[[1]]
        for (letter in alphabet) {
            count <- length(grep(letter, sub_split))
            letter_freqs <- append(letter_freqs, count)
        }
        sorted_frequencies[[index]] <- letter_freqs
        index <- index + 1
    }
    return(sorted_frequencies)
}

percentages <- function(vec_of_vecs) {
    int <- 1
    s_percs <- c()
    for (i in vec_of_vecs) {
        j <- i / sum(i)
        s_percs[[int]] <- j
        int <- int + 1
    }
    return(s_percs)
}

chi_squared <- function(eng_freqs, sub_percs) {
    chis <- c()
    ind <- 1
    for (sublist in sub_percs) {
        chi_stats <- c()
        for (i in 1:length(alphabet)) {
            chi <- 0
            if (i == 1) {
                series <- i:26
            }
            else {
                series <- (28 - i):26
                series <- c(series, 1:(27 - i))
            }
            for (j in seq_along(sublist)) {
                value <- ((sublist[j] - eng_freqs[[2]][series[j]]) ^ 2) / (eng_freqs[[2]][series[j]])
                chi <- chi + value
            }
            chi_stats <- c(chi_stats, chi)
        }
        chis[[ind]] <- chi_stats
        ind <- ind + 1
    }
    return(chis)
}

#Function which returns the n most likely letters for every key letter.
#It takes in two arguments, the vector list of chi squared values, and n.
#It returns a vector, of length == key length.
likely_letters <- function(chi_vector, n) {
    n_likely <- c()
    step <- 1
    for (chis in chi_vector) {
        letters <- c()
        sorted_freqs <- chis[order(chis)]
        for (int in 1:n) {
            letters <- c(letters, alphabet[match(sorted_freqs[int], chis)])
        }
        n_likely[[step]] <- letters
        step <- step + 1
    }
    return(n_likely)
}

### Twist Algorithm Implementation, used to find the key length

twist_subsets_func <- function(key_limit, text) {
    all_key_lengths <- c()
    for (m in 1:(key_limit + 1)) {
        nth_sub <- sub_letter_totals(m, text)
        perc <- percentages(nth_sub)
        all_key_lengths[[m]] <- perc
    }
    return(all_key_lengths)
}

twists <- function(twist_subsets) {
    twists <- c()
    for (c in 1:length(twist_subsets)) {
        twist <- 0
        for (r in 1:length(twist_subsets[[c]])) {
            list_of_percs <- sort(twist_subsets[[c]][r][[1]], decreasing = TRUE)
            twist <- twist + sum(list_of_percs[1:13]) - sum(list_of_percs[14:26])
        }
        twist <- twist * (100 / c)
        twists <- c(twists, twist)
    }
    return(twists)
}

twistplus <- function(twists) {
    twistplus <- c()
    for (i in seq_along(twists)) {
        subtract <- 0
        if (i != length(twists)) {
            for (j in 1:i) {
                subtract <- subtract + (twists[j]/(i))
            }
            number <- twists[i + 1] - subtract
            twistplus <- c(twistplus, number, i + 1)
        }
    }
    mode_value <- 0
    sequence <- seq_along(twistplus)
    integers <- which(sequence %% 2 == 1)
    for (j in integers) {
        if(twistplus[j] > mode_value) {
            mode <- twistplus[j + 1]
            mode_value <- twistplus[j]
        }
    }
    return (mode)
}

############################
#Testing
############################

#Code below demonstrates how the Vigenere Cipher is solved with the twistplus algorithm
#to identify the key length.

normal_text <- "there are various kinds of certainty. a belief is psychologically certain when the subject who has it is supremely convinced of its truth. certainty in this sense is similar to incorrigibility, which is the property a belief has of being such that the subject is incapable of giving it up.but psychological certainty is not the same thing as incorrigibility. a belief can be certain in this sense without being incorrigible; this may happen, for example, when the subject receives a very compelling bit of counterevidence to the (previously) certain belief and gives it up for that reason."
keyword <- "notebook"

c_text <- encrypt_func(format_func(normal_text), keyword)
twists_a <- twists(twist_subsets_func(8, c_text))
mode <- twistplus(twists_a)
print(mode)

output <- sub_letter_totals(mode, c_text)
percs <- percentages(output)
chi_vals <- chi_squared(english_frequencies, percs)
likely <- likely_letters(chi_vals, 3)
print(likely)

decryp <- decrypt(c_text, "notebook")
print(decryp)

#######################
#Testing the Kasiski Algorithm
#######################

#Try different length ciphertexts and keys to determine the effectiveness of the Kasiski Algorithm
#compared to the Twistplus algorithm. You may find different results for the function repeats(text, n), when
#changing 'n' the length of the repeated fragment of text.
repeats(c_text, 5)


#!/usr/bin/env Rscript
args <- commandArgs(TRUE)
infile = paste("", args[1], sep="")
outfile = paste("", args[2], sep="")
if(nchar(infile) >= 1 && !infile == "NA" && nchar(outfile) >= 1 && !outfile == "NA") {
    x = read.table(infile, sep="\t", header=T)
    xm1 = as.matrix(x[,-1])
    rownames(xm1) = x[,1]
    xm = xm1
    xm[is.na(xm)] = 0
    hcr = hclust(dist(xm), "ave")
    hcc = hclust(dist(t(xm)), "ave")
    xmo = xm1[hcr$order,hcc$order]
    write.table(xmo, outfile, quote=F, sep="\t", row.names=T, col.names=T, na="NA")
} else {
    warning("Usage: heatmap_table_sort_row_col.r [input table] [output sorted table]")
}


pollutantmean <- function(directory, pollutant, id=1:332){
  files <- list.files(directory, full.names = TRUE)
  all_csv <- lapply(files[id], function(file){
    read.csv(file)
  })
  data_set <- do.call(rbind.data.frame, all_csv)
  result <- data_set[[pollutant]]
  mean <- mean(result, na.rm = TRUE)
  return(mean)
}


library(limma);

fileData <- read.columns("E:\\STUDY\\THESIS\\FILES GIVEN BY SWAPNIL\\Datasets\\camel\\camel-1.6.csv",c("wmc","dit","noc","cbo","rfc","lcom","loc","avg_cc","bug"),sep=",");

dataSet <- data.frame(wmc=fileData$wmc,dit=fileData$dit,
                      noc=fileData$noc,cbo=fileData$cbo,
                      rfc=fileData$rfc,lcom=fileData$lcom,
                      avg_cc=fileData$avg_cc,loc=fileData$loc,bug=fileData$bug);

write.csv(dataSet,"E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\finalData.csv",row.names=F);

source("E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\SOURCE CODE\\readTrain&Test.r");
source("E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\SOURCE CODE\\actual.r");
source("E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\SOURCE CODE\\predicted.r");
source("E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\SOURCE CODE\\predictedPerLOC.r");
source("E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\SOURCE CODE\\predictedPerCC.r");


# import data
customers <- read.csv("https://github.com/CriticalPathTraining/IntroToR/raw/master/SalesByCustomer.csv")

# give columns prettier names
names(customers) = c("Customer","State","Gender","Age","Sales")

# sort the data
customers <- customers[ order(customers$Age, decreasing=TRUE),  ]

florida.customers = subset(customers, State == "FL", c("Customer", "Gender", "Age", "Sales") )
texas.customers = subset(customers, State == "TX", c("Customer", "Gender", "Age", "Sales") )
california.customers = subset(customers, State == "CA", c("Customer", "Gender", "Age", "Sales") )

rm(customers)


#' sign
#'
#' Sign.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix.
#'
#' @useDynLib float R_sign_spm
#' @name sign
#' @rdname sign
NULL

sign_float32 = function(x)
{
  .Call(R_sign_spm, DATA(x))
}

#' @rdname sign
#' @export
setMethod("sign", signature(x="float32"), sign_float32)


####################################
#-----------plotting hourly mean around light off
####################################

# input = behav_gp

#keep a version of untouched behav_gp
behav_gpori = behav_gp
# change the class of hours as numeric instead of charachter
if (!is.numeric(behav_gp$Bin)) {
  behav_gp <- behav_gp %>% mutate(Bin = as.numeric(Bin))
}
behav_gp = behav_gp %>% select (-lightcondition)

#---------------creating 60 mins bins for visualisation---------------#

animals = unique(behav_gp$ID)
hour.info = as.data.frame(matrix(ncol = 2, nrow = length(animals)))
colnames(hour.info) = c('earliest_bin', 'last_bin')
# define columns containing behaviours in behav_gp
b.var = 4:ncol(behav_gp)
behav.dark = data.frame()

for (i in animals) {
  # create subset of data for only the given animal
  temp <- filter(behav_gp, ID == i)
  # save meta information about given animal
  meta <- i
  # find the individual row with the start of the dark phase
  d.start = which(temp$bintodark == 0)
  # get maximal number of full hours after start of dark phase
  max.b = floor(max(temp$bintodark) / 60)
  # get number of full hours before start of dark phase
  min.b = ceiling(min(temp$bintodark) / 60)

  ### define bins after start of dark phase

  # create empty matrices to hold summed hourly data
  temp.ad = matrix(ncol = length(b.var) + 1, nrow = max.b)
  temp.bd = matrix(ncol = length(b.var) + 1, nrow = abs(min.b))

  # sum up all values for each full hour after start of dark phase
  for (t in 1:max.b) {
    for (b in b.var) {
      temp.ad[t, 1] = t - 1
      temp.ad[t, b - min(b.var) + 2] = sum(temp[(d.start + (60 * (t - 1))):(d.start +
                                                                              ((60 * t) - 1)), b])
    }
  }

  ### sum up all values for each full hour before the dark phase
  # for (t in 1:abs(min.b)) {
  #   for (b in b.var) {
  #     temp.bd[t,1] = seq(min.b,-1)[t]
  #     temp.bd[t,b-12] = sum(temp[ ((d.start-1)+(-60*(t)))  : ((d.start-1)+(-60*(t-1))),b])
  #   }
  # }
  for (t in min.b:-1) {
    for (b in b.var) {
      temp.bd[t + (abs(min.b) + 1), 1] = t
      temp.bd[t + (abs(min.b) + 1), b - min(b.var) + 2] = sum(temp[(d.start +
                                                                      ((t * 60) + 1)):(d.start + ((t + 1) * 60)) , b])
    }
  }

  # combine all bins
  temp <- rbind(temp.bd, temp.ad)
  # set colum names
  colnames(temp) = c('Bin.dark', names(behav_gp)[b.var])
  # add meta information again
  temp <- cbind(meta, temp)
  hour.info[which(animals == i), 1] = min.b
  hour.info[which(animals == i), 2] = max.b - 1
  # combine for each animal_ID
  behav.dark = rbind(behav.dark, temp)
}

behav.dark2 <-
  data.frame(lapply(behav.dark, function(x)
    as.numeric(as.character(x))))

behav.dark2$meta = as.character(behav.dark2$meta)
# calculate meaningful time limits
timeMin = max (hour.info$earliest_bin) - 0.1
timeMax = min (hour.info$last_bin) + 0.1

# filter for data where all mice have data:
behav.dark2 = behav.dark2 %>% filter (Bin.dark > timeMin &
                                        Bin.dark < timeMax)

####################################
# 5.2. data plotting
####################################

#### plot for each behaviour the group average per hour (based on BIN given in the raw data [not actual time])

N_behav = ncol(behav.dark2) - 2
#distance traveled
dist <- left_join(behav.dark2, metadata, by = c("meta" = "ID"))
#dist$distance.traveled = behav.dark[,'Distance_traveled']

#dist_d = dist  %>% ungroup %>% group_by(genotype,treatment,Bin.dark) %>% summarise (avg = mean(Distance_traveled), sd = sd(Distance_traveled))
#CD = dist  %>% ungroup %>% group_by(genotype,treatment,Bin.dark) %>% summarise (avg = mean(ComeDown), sd = sd(ComeDown))

if (groupingby == "Berlin") {
  dist_sum = dist %>%
    ungroup %>%
    group_by(genotype, treatment, Bin.dark) %>%
    summarise_at(vars(Distance_traveled:Stretch), funs(mean, sd)) %>%
    mutate (Bin.dark = Bin.dark + 0.5) # get the x value in the middle of time interval

}

if (groupingby == "Jhuang") {
  dist_sum = dist %>%
    ungroup %>%
    group_by(genotype, treatment, Bin.dark) %>%
    summarise_at(vars(Distance_traveled:Drink), funs(mean, sd)) %>%
    mutate (Bin.dark = Bin.dark + 0.5) # get the x value in the middle of time interval

}

#pdf("test.pdf")
pl <- list()

for (i in c(1:N_behav)) {
  dist_d = dist_sum [, c(1, 2, 3, 3 + i, 3 + i + N_behav)]
  Title_plot = names (dist_d) [4]
  names (dist_d) [4:5] = c("avg", "sd")
  dist_d [4:5] <- dist_d [4:5] / 36
  p = plot24h(dist_d, Title_plot)
  #print(p)
  pl[[i]] = p
}
#dev.off()

pl.all.d <- do.call(grid.arrange, c(pl, list(ncol = 3)))

text.all.d = paste(
  '
  Comment:
  %age time spent doing each behaviour per hour and per genotype with dark phase start correction. The space between the dotted lines represents the time intervall in which data for all animals is present. Due to the different individual start times this alignment around the dark phase is necessary',
  collapse = " "
)

# all graphs in one plot
#setwd(plot.path)
pdf(
  file = paste0(plot.path, "/hourly_plotting_corrected.pdf"),
  width = 15,
  height = 10
)

grid.arrange(
  splitTextGrob(text.all.d),
  pl.all.d,
  ncol = 1,
  heights = c(1, 5),
  top = textGrob(
    paste0(
      'All hourly behaviour kinetics with dark phase correction (',
      groupingby,
      ' grouping)'
    ),
    gp = gpar(fontsize = 30, font = 3)
  )
)

dev.off()

# return behav_gp to original value before this code
behav_gpori -> behav_gp


if (!exists("nsamples") || !(is.numeric(nsamples))) stop("nsamples must be set")

data(mcv_world_estimate) ## measles coverage estimates
data(esen2_schedules) ## vaccination schedules
data(contact_countries) ## ESEN2-to-POLYMOD country mapping

wms <- ms.sero %>%
  tbl_df %>%
  mutate(survey.yr = as.integer(sub("[^0-9].*$", "", survey.yr)),
         country = if_else(country == "Czech", "Czech Republic", as.character(country)),
         country = countrycode(country, "country.name", "eurostat.name"),
         country = factor(country),
         lower.age.limit = as.integer(sub("[-+ ].*$", "", age1)))

## work out immunity levels by country and age group
wms_sero <- list()

base_parameters <-
    list(symmetric=TRUE, weigh.dayofweek=TRUE, sample.all.age.groups=TRUE,
         estimated.contact.age="sample", missing.participant.age="remove", quiet=TRUE)

survey_parameters <- list(survey=polymod)

R_countries <- list()

eqi_scenarios <- c("positive", "negative", "removed")

sample_sero <- function(df, nsamples = 1)
{
  lapply(1:nsamples, function (x)
  {
    temp <- df[sample(1:nrow(df), replace=TRUE), ]
    temp$sample <- x
    temp
  }) %>%
    bind_rows %>%
    group_by(stdres, sample, lower.age.limit) %>%
    summarise(n = n()) %>%
    ungroup %>%
    complete(stdres, sample, lower.age.limit, fill=list(n=0)) %>%
    spread(stdres, n) %>%
    mutate(positive = (EQI + POS) / (EQI + POS + NEG),
           negative = POS / (EQI + POS + NEG),
           removed = POS / (POS + NEG)) %>%
    select(-EQI, -NEG, -POS) %>%
    gather(eqi, immunity, -sample, -lower.age.limit) %>%
    complete(sample, lower.age.limit, eqi, fill=list(immunity=1)) %>%
    spread(lower.age.limit, immunity) %>%
    nest(-sample, -eqi) %>%
    rowwise() %>%
    mutate(immunity=list(unlist(data[1,]))) %>%
    select(-data)
}

maternal.immunity <- wms %>%
  filter(lower.age.limit==0) %>%
  nest() %>%
  mutate(sero_sample=map(data, sample_sero, nsamples = nsamples)) %>%
  unnest(sero_sample) %>%
  mutate(immunity=unlist(immunity))

project_country <- function(country, year, eqi, immunity, schedule, vaccination=c("projected", "ignored"), years=10)
{
  vaccination <- match.arg(vaccination)
  vacc_country <- country
  sero_year <- year
  sero_eqi <- eqi
  schedule <- schedule[!is.na(schedule)]

  uptake <- mcv_world_estimate %>%
    filter(country==vacc_country) %>%
    mutate(uptake=uptake/100) %>%
    spread(vaccine, uptake) %>%
    replace_na(list(MCV1=0, MCV2=0))

  if (country=="Lithuania") {
    uptake %<>% mutate(MCV3=MCV2)
  }

  uptake %<>%
    column_to_rownames("year") %>%
    select(starts_with("MCV")) %>%
    as.matrix %>%
    t

  ## fill missing dose information
  while (nrow(uptake) < length(schedule))
  {
    uptake <- rbind(uptake, rep(0, ncol(uptake)))
  }

  if (vaccination=="ignored") years <- 1

  immunities <- list()
  mat.imm <- maternal.immunity %>%
    filter(sample==sample(seq_len(max(sample)), 1),
           eqi==sero_eqi) %>%
    .$immunity

  for (i in seq_len(years)) {
    projected <-
      project_immunity(immunity, year, year + i, uptake, schedule, mat.imm, 0.95)
    immunities[[i]] <-
      tibble(lower.age.limit=as.integer(names(projected)), immunity=projected,
                              year=year+i)
  }

  immunities <- immunities %>%
    bind_rows %>%
    group_by(lower.age.limit) %>%
    summarise(immunity=mean(immunity))

  ret <- immunities$immunity
  names(ret) <- immunities$lower.age.limit

  return(ret)
}

## create samples form serology
swms <- wms %>%
  filter(!is.na(survey.yr)) %>%
  unite(country_yr, country, survey.yr, by="country") %>%
  nest(-country_yr) %>%
  mutate(sero_sample=map(data, sample_sero, nsamples = nsamples)) %>%
  unnest(sero_sample) %>%
  separate(country_yr, c("country", "year"), sep="_") %>%
  mutate(year=as.integer(year)) %>%
  left_join(esen2_schedules, by="country") %>%
  crossing(vaccination=c("projected", "ignored")) %>%
  rowwise() %>%
  mutate(immunity=list(project_country(country, year, eqi, immunity, schedule, vaccination))) %>%
  ungroup()

country_matrices <- swms %>%
  group_by(country, vaccination) %>%
  summarise(n=n(), age.groups=list(as.integer(unique(names(unlist(immunity)))))) %>%
  ungroup() %>%
  rowwise() %>%
  mutate(options=
           list(c(base_parameters, survey_parameters,
                  list(n=n,
                       age.limits=as.integer(grep("^[0-9]", age.groups,
                                                  value=TRUE)),
                       countries=contact_countries[country]))),
         matrix=list(do.call(contact_matrix, options)),
         matrices=list(matrix$matrices),
         demography=list(matrix$demography$proportion)) %>%
  unnest(matrices, .preserve=demography) %>%
  rename(matrix=matrices) %>%
  group_by(country, vaccination) %>%
  mutate(id=1:n()) %>%
  select(-n)

sero_adjImm <- swms %>%
  group_by(country, vaccination) %>%
  mutate(id=1:n()) %>%
  ungroup %>%
  left_join(country_matrices, by=c("country", "vaccination", "id")) %>%
  select(-id) %>%
  rowwise() %>%
  mutate(adjusted_immunity=adjust_immunity(mixing=matrix, immunity=unlist(immunity)),
         mean_immunity=sum(demography * immunity)) %>%
  ungroup %>%
  select(country, year, sample, eqi, vaccination,
         adjusted_immunity, mean_immunity)


#-------------------------------------------------------------------------------
#'	(Internal) Multiple arguments version of which.min and which.max.
#'
#'	Evaluations of maximum/minimum are sequentially conducted in an order of
#'	variables provided in the arguments if the data were provided as numeric
#'	vectors.
#'	If first argument is a matrix or data.frame, evaluation are sequentially
#'	conducted left column to right column.
#'	If there is a tie, this function returns ALL index of them. This behavior is
#'	different from original which.min/which.max.
#'
#'	@param data
#'		a matrix, data.frame or list containing same length of vectors.
#'	@param min.max.function
#'		`min` or `max`.
#-------------------------------------------------------------------------------
which.min.or.max.multi <- function(data, min.max.function){
	# Check length of argument
	if (length(data) != 1 & !"data.frame" %in% class(data)){
		for (i in 2:length(data)){
			if (length(data[[1]]) != length(data[[i]])){
				stop("Length of the variables is not same!")
			}
		}
	}
	# search max/min value
	index <- 1:length(data[[1]])
	for (i in 1:length(data)){
		current.data <- data[[i]][index]
		index <- index[current.data == min.max.function(current.data)]
		if (length(index) == 1){
			return(index)
		}
	}
	return(index)
}

#-------------------------------------------------------------------------------
#'	(Internal) Multiple arguments version of which.min.
#'
#'	@param data
#'		a matrix, data.frame or list containing same length of vectors.
#-------------------------------------------------------------------------------
which.min.multi <- function(data){
	UseMethod("which.min.multi")
}

#-------------------------------------------------------------------------------
#'	(Internal) Multiple arguments version of which.min.
#'
#'	@param data
#'		a matrix, data.frame or list containing same length of vectors.
#-------------------------------------------------------------------------------
which.max.multi <- function(data){
	UseMethod("which.max.multi")
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi list
#-------------------------------------------------------------------------------
which.min.multi.list <- function(data){
	which.min.or.max.multi(data, min)
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi list
#-------------------------------------------------------------------------------
which.max.multi.list <- function(data){
	which.min.or.max.multi(data, max)
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi data.frame
#-------------------------------------------------------------------------------
which.min.multi.data.frame <- function(data){
	which.min.or.max.multi(data, min)
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi data.frame
#-------------------------------------------------------------------------------
which.max.multi.data.frame <- function(data){
	which.min.or.max.multi(data, max)
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi matrix
#-------------------------------------------------------------------------------
which.min.multi.matrix <- function(data){
	which.min.multi.list(data.frame(data))
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi matrix
#-------------------------------------------------------------------------------
which.max.multi.matrix <- function(data){
	which.max.multi.list(data.frame(data))
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi numeric
#-------------------------------------------------------------------------------
which.min.multi.numeric <- function(data, ...){
	which.min.multi.list(list(data, ...))
}

#-------------------------------------------------------------------------------
#'	@method which.min.multi numeric
#-------------------------------------------------------------------------------
which.max.multi.numeric <- function(data, ...){
	which.max.multi.list(list(data, ...))
}


context("MBM Models")
library(mbm)

# make symmetric y matrix and some random covariates
set.seed(100)
y <- matrix(rbeta(100, 1, 1), ncol=10); diag(y) <- 0; y[upper.tri(y)] <- t(y)[upper.tri(y)]
x <- matrix(rnorm(30), ncol=3)

test_that("Python loads", {
	expect_error(check_python(), regex = NA)
})

test_that("Common errors", {
	expect_error(mod <- mbm(y,x, link = "log"))
	expect_error(mod <- mbm(y,x, likelihood = "poisson"))

	yy <- matrix(rbeta(200^2, 1, 1), ncol=200); diag(y) <- 0; y[upper.tri(y)] <- t(y)[upper.tri(y)]
	xx <- matrix(rnorm(200*3), ncol=3)
	expect_error(mbm(yy,xx), regex = 'memory')
	mod <- mbm(y,x)
	expect_error(predict(mod, newdata=x[,-1]), "variables")
	expect_warning(confint(mod, method="sample"), "not implemented")
	expect_error(confint(mod, parm="newdata"), "supported")
})

test_that("basic model options and standard methods produce no errors", {
	expect_error(mod <- mbm(y,x), NA)
	expect_error(gp_params(mod), regex = 'sparse')
	expect_error(mod <- mbm(y,x, force_increasing = TRUE), NA)

	## svgps with small numbers of iterations always throw a warning
	expect_warning(mod <- mbm(y,x, sparse = TRUE, sparse_iter = 10), regex = "iterations")
	expect_warning(mod <- mbm(y,x, sparse = TRUE, sparse_iter = 10, link = 'probit'),
		regex = "iterations")
	expect_warning(mod <- mbm(y,x, sparse = TRUE, sparse_iter = 10, force_increasing = TRUE),
		regex = "iterations")
	# expect_error({sink("/dev/null"); summary(mod); sink()}, regex=NA)
	expect_equal(dim(inducing(mod)), dim(mod$inducing_inputs))
	chol_pars <- gp_params(mod)
	expect_equal(length(chol_pars$mean), attr(mod, "inducing_inputs"))
	expect_equal(dim(chol_pars$cholesky), rep(attr(mod, "inducing_inputs"), 2))
	})

# test link functions
test_that("adding link functions succeeds", {
	link = 'identity'
	mod <- mbm(y,x, link = link)
	expect_match(mod$link, link)
	expect_match(tolower(class(mod$pyobj$likelihood$gp_link)), link, all=FALSE)

	link = 'probit'
	mod <- mbm(y,x, link = link)
	expect_match(mod$link, link)
	expect_match(tolower(class(mod$pyobj$likelihood$gp_link)), link, all=FALSE)
})

# test prediction
test_that("mbm prediction", {
	newx <- cbind(seq(-2, 2, length.out=20), seq(-1, 1, length.out=20),
		seq(-0.5, 0.5, length.out=20))
	mod <- mbm(y,x)
	expect_error(pr <- predict(mod), regex=NA)
	expect_equal(nrow(pr), nrow(mod$covariates))
	expect_error(pr <- predict(mod, newdata = newx), regex=NA)
	expect_equal(nrow(pr), length(dist(newx)))
	mod <- mbm(y,x, link = 'probit')
	prResp <- predict(mod, type='response')[,1]
	expect_true(all(prResp >= 0 & prResp <= 1))
})

test_that("methods", {
	mod <- mbm(y,x)
	expect_true(is.mbm(mod))
	vdiffr::expect_doppelganger('print-method', mod)
	vdiffr::expect_doppelganger('plot-noline-noserr', plot(mod, line = FALSE, sterr=FALSE))
	vdiffr::expect_doppelganger('plot-noline-serr', plot(mod, line = FALSE, sterr=TRUE))
	vdiffr::expect_doppelganger('plot-line-noserr', plot(mod, line = TRUE, sterr=FALSE))
	vdiffr::expect_doppelganger('plot-line-serr', plot(mod, line = TRUE, sterr=TRUE))
	expect_error(ci <- confint(mod), NA)
	expect_true(all(is.finite(ci)))

})
# test samples
# test (or drop) response curves
# test setting lengthscale
# test methods (printing etc)
# test spatial predict


# Setup
source('2020-08-31-jsa-type-v2-ch2/02-model/init.r')

# Script
print(paste0(Sys.time(), " --- Visualising results"))

####### Load data

# Original data
data_raw <- read.csv(
    paste0(dir_model_folder, "data.csv"),
    na.strings=c(""),
    stringsAsFactor = TRUE
)

# R data
data <- read_rdump(paste0(dir_model_folder, "count_info.data.R"))

# Load zero inflated fits
load(paste0(dir_model_folder, "fit.data"))      # as "fit"

# Load posterior simulation
load(paste0(dir_model_folder, "post.data"))     # as "allsim"

# Load forecast predictions
load(paste0(dir_model_folder, "forecast.data")) # as "forecast"

# Map model indices to original variables
mapping <- unique(data.frame(
    groupname = as.character(data_raw$group),
    group = as.numeric(data_raw$group)
))

####### Check for chain convergence
log_chain_sampling(fit, dir_model_folder)

#######  Get simulations and actual data
li_df <- summarize_simulations_observed(data, allsim)

Z <- li_df$Z                      # Counts for each year for sim and actual, df
sum_y <- li_df$sum_y              # Cumulative counts for simulated data, dt
obs_count <- li_df$obs_count      # Cumulative counts for observed data, dt

####### Get parameter (delta)
li_df_delta <- extract_delta(fit)

group_cf1 <- li_df_delta$group_cf1   # Intercept of delta coefficient
group_cf2 <- li_df_delta$group_cf2   # Slope of delta (beta) coefficient
cf2 <- li_df_delta$cf2               # Summarized slope of delta (beta) & 80 CI

####### Create results table - part 1
results <- combine_results(sum_y, obs_count, cf2, mapping)

####### Save plots
# Facet labels for **all** plots
labels <- as.character(mapping$groupname)
names(labels) <- mapping$group

# Plot 1/2 data
li_df_plot1_2 <- prepare_plot1_2_data(Z) # Z as df
obs <- li_df_plot1_2$obs   # Observations with count/ cumulative, df
sims <- li_df_plot1_2$sims # Simulations with count/ cumulative, df

# Plot 1 - cumulative_fit.pdf (cumulative counts)
save_plot1(sims, obs, labels, dir_model_folder)

# Plot 2 - count_fit.pdf (counts)
save_plot2(sims, obs, labels, dir_model_folder)

# Plot 3 data
li_df_plot3 <- prepare_plot3_data(data, data_raw, group_cf1, group_cf2)
sims <- li_df_plot3$sims         # Simulations for omega, df
om_mean <- li_df_plot3$om_mean   # Mean of omega, dt

# Plot 3 - regression.pdf / counts with regression line
save_plot3(obs, sims, om_mean, labels, dir_model_folder)
# note: obs is output from prepare_plot1_2_data
# note: regression "om_mean" plotted is exp(delta[1] + delta[2] * time)

####### Create results table - part 2 (add on forecasts)
# Summarize forecast results
forecast_results <- summarize_forecasts(data, data_raw, forecast, obs)

# Output csv table
output_results_csv(results, forecast_results, dir_model_folder)


pdf_file<-"pdf/tablecharts_bumpchart.pdf"
cairo_pdf(bg="grey98", pdf_file,width=9,height=12)

par(omi=c(0.5,0.5,0.9,0.5),mai=c(0,0.75,0.25,0.75),xpd=T,family="Lato Light",las=1)
library(plotrix)
library(gdata)

# Import data and prepare chart

z1<-read.xls("myData/bumpdata.xlsx", encoding="latin1")
rownames(z1)<-z1$name
z1$name<-NULL
myColours<-rep("grey",nrow(z1)); myLineWidth<-rep(1,nrow(z1))
myColours[5]<-"skyblue"; myLineWidth[5]<-8
par(cex=1.1)

# Create chart

bumpchart(z1,rank=F,pch=18,top.labels=c("2002","2011"),col=myColours,lwd=myLineWidth,mar=c(2,12,1,12),cex=1.1)

# Titling

mtext("Revenue development of Fortune 500 enterprises",3,line=1.5,adj=0,family="Lato Black",outer=T,cex=2.1)
mtext("Source: money.cnn.com/magazines/fortune/fortune500/",1,line=0,adj=1,cex=0.95,font=3,outer=T)

# Other elements

axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025, at=c(min(z1$r2002), max(z1$r2002)),c(round(min(z1$r2002)/1000,digits=1), round(max(z1$r2002)/1000, digits=1)))
axis(4,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025, at=c(min(z1$r2011), max(z1$r2011)),c(round(min(z1$r2011)/1000,digits=1), round(max(z1$r2011)/1000, digits=1)))

mtext("in billion Euro",3,font=3,adj=0,cex=1.5,line=-0.5,outer=T)

par(family="Lato Black")
axis(2,col=par("bg"),col.ticks="grey81",col.axis="skyblue",lwd.ticks=0.5,tck=-0.025,at=z1[5,1],round(z1[5,1]/1000, digits=1))
axis(4,col=par("bg"),col.ticks="grey81",col.axis="skyblue",lwd.ticks=0.5,tck=-0.025,at=z1[5,2],round(z1[5,2]/1000, digits=1))

dev.off()


ALIGN_BITS <- c (0, 1, 2, 3, 4)
RANDOM_BITS <- c (6, 12)

# Read input files

read_results <- function (name)
{
  results <- c ()
  files <- list.files (name, full.names=TRUE)
  for (file in files)
  {
    lines <- readLines (file)
    line <- grep ("Operations performed: [0-9]+ \\([0-9.]+ ops/sec\\)", lines, value=TRUE)
    result <- as.numeric (sub (".*\\(([0-9.]+) ops/sec\\).*", "\\1", line))
    if ((length (result) == 1) && (result > 0)) results <- c (results, result)
  }

  return (results)
}

results_vanilla <- read_results ("sysbench-vanilla")

for (align in ALIGN_BITS)
{
  for (random in RANDOM_BITS)
  {
    name_directory = paste ("sysbench", "randomized", align, random, sep="-")
    name_variable = paste ("results", align, random, sep="_")
    assign (name_variable, read_results (name_directory))
  }
}

# Plot observations

plot_graph <- function (name, align_list, random)
{
  variable_list <- c ("results_vanilla", paste ("results", align_list, random, sep="_"))
  length_list <- unlist (lapply (variable_list, function (x) length(get (x))))
  horizontal_limits <- c (1, max (length_list))
  value_list <- unlist (lapply (variable_list, get))
  minimum <- min (value_list)
  maximum <- max (value_list)
  vertical_limits <- c (minimum, maximum)

  postscript (paste (name, "ps", sep="."))

  plot (c (), xlim = horizontal_limits, ylim = vertical_limits, ylab="Performance")
  for (variable_index in 1:length (variable_list))
  {
    variable = variable_list [variable_index]
    points (get (variable), pch = variable_index, col = variable_index)
  }

  legend (
    "bottomright",
    variable_list,
    pch = 1:length (variable_list),
    col = 1:length (variable_list))

  dev.off ()
}

plot_graph ("random-cache-line", ALIGN_BITS, 6)
plot_graph ("random-page-frame", ALIGN_BITS, 12)


REBOL [Title: "Basic SHAPE test"]

load-gui

;;; WINDOW
win: make gob! [text: "Basic SHAPE test" offset: 200x20 size: 800x800]

;;; background GOB
gobb: make gob! []
gobb/size: win/size
gobb/color: white
append win gobb

gobd: make gob! []
gobd/size: gobb/size

line-test: [
	move 100x40 'hline 200
	'move -200x40 hline 300
	move 100x120 'vline 200
	'move 40x-200 vline 320
	'move 40x-200 line 300x120
	'move -120x40 'line 120x0
]

curve-test: [
	move 100x450 curve 100x550 300x550 300x450
	move 350x450 'curve 0x100 200x100 200x0
	move 100x550 'vline 100 curv 300x650 300x550
	'move 50x0 'vline 100 'curv 200x0 200x-100
	move 0x0
]

qcurve-test: [
	move 100x700 qcurve 200x800 300x700
	'move 50x0 'qcurve 100x100 200x0
	move 350x50 'qcurve 100x100 200x0 qcurv 750x50
	move 350x110 'qcurve 100x100 200x0 'qcurv 200x0
	move 0x0
]

arc-test1: [
	move 350x400
	line 400x375
	arc 450x350 25x25 -30 sweep
	line 500x325
	arc  550x300 25x50 -30 sweep
	line 600x275
	arc  650x250 25x75 -30 sweep
	line 700x225
	arc  750x200 25x100 -30 sweep
	line 800x175

	move 50x450
	'line 50x-25
	'arc 50x-25 25x25 -30 sweep
	'line 50x-25
	'arc 50x-25 25x50 -30 sweep
	'line 50x-25
	'arc 50x-25 25x75 -30 sweep
	'line 50x-25
	'arc 50x-25 25x100 -30 sweep
	'line 50x-25
	move 0x0
]

arc-test2: [
	move 700x450 hline 650 arc 700x400 50x50 0 large close
	move 675x425 vline 375 arc 625x425 50x50 0 close
	move 700x650 'hline -50 'arc 50x-50 50x50 0 large  close
	move 675x625 'vline -50 'arc -50x50 50x50 0
]

gobd/draw: to-draw [
	pen black
	shape line-test
	pen red
	fill-pen blue
	shape curve-test
	fill-pen green
	shape qcurve-test
	fill-pen off
	shape arc-test1
	fill-pen yellow
	shape arc-test2
] copy []

append gobb gobd

view win


pdf_file<-"pdf/profile_chart.pdf"
cairo_pdf(bg="grey98", pdf_file, width=12, height=8)

source("scripts/functions/profile.plot.r")
par(lheight=1.15,mai=c(0.25,0.25,0.25,0.25), omi=c(0.5,0.5,1.1,0.5),
	family="Lato Light",las=1)

# Import labels

text.left<-NULL
text.right<-NULL
text.left<-c(text.left,"Individuals should take more responsibility for\nproviding for themselves.")
text.right<-c(text.right,"The state should take more\nresponsibility to ensure that everyone is\nprovided for.")
text.left<-c(text.left,"People who are unemployed should\nhave to take any job available or lose\ntheir unemployment benefits.")
text.right<-c(text.right,"People who are unemployed should\nhave the right to refuse a job they\ndo not want.")
text.left<-c(text.left,"Competition is good. It stimulates\npeople to work hard and develop\nnew ideas.")
text.right<-c(text.right,"Competition is harmful. It brings\nout the worst in people.")
text.left<-c(text.left,"The government should give companies\nmore freedom.")
text.right<-c(text.right,"The state should control firms more\neffectively.")
text.left<-c(text.left,"Incomes should be made more equal.")
text.right<-c(text.right,"There should be greater incentives\nfor individual effort.")
text.left<-c(text.left,"Private ownership of business\nand industry should be increased.")
text.right<-c(text.right,"Government ownership of\nbusiness and industry should be\nincreased.")

# Import and prepare data

library(Hmisc)
ZA4753<-spss.get("myData/ZA4753_v1-1-0.sav",use.value.labels=F)
myVariables<-c("v302","v194","v195", "v196","v197","v198","v199")
myResult<-dim(2)
myData<-ZA4753[, myVariables]
for (i in 2:length(myVariables))
{
  mySelection<-subset(myData[, c(1, i)], myData [, i] >= 1 & myData [, i] <= 10)
  myValues<-t(aggregate(mySelection [, 2], by=list(mySelection [, 1]), FUN=mean, na.rm=T))
  myResult<-rbind(myResult, myValues[2, ])
}

# Create chart

colnames(myResult) <- c("Men", "Women")
myC1<-"skyblue"
myC2<-"darkred"
profile.plot(myResult,text.left,text.right,colours=c(myC1,myC2),legend.n.col=2)

# Titling

mtext("Now I’d ask you to please tell me your views on different statements.",3,line=3,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("Source: ZA4753: European Values Study 2008: Germany (EVS 2008). N=2,075",1,line=1,adj=1.0,cex=1.1,font=3,outer=T)
dev.off()


#Create array of 3*3 matrix

print("Two vectors of different lengths:")
v1 =  c(1,3,4,5)
v2 =  c(10,11,12,13,14,15)
print(v1)
print(v2)
result = array(c(v1,v2),dim = c(3,3,2))
print("New array:")
print(result)


\name{psm_analysis_weighted}
\alias{psm_analysis_weighted}

\title{
Weighted van Westendorp Price Sensitivity Meter Analysis (PSM)
}

\description{
\code{psm_analysis_weighted()} performs a \bold{weighted} analysis
  of consumer price preferences and price sensitivity known as
  \bold{van Westendorp Price Sensitivity Meter (PSM)}. The function
  requires a sample design from the \pkg{survey} package as the
  main input. Custom weights or sample designs from other packages
  are not supported.

  To run a PSM analysis \bold{without} weighting, use the function
  \code{\link{psm_analysis}}.

}

\usage{
psm_analysis_weighted(
  toocheap, cheap, expensive, tooexpensive,
  design,
  validate = TRUE,
  interpolate = FALSE,
  interpolation_steps = 0.01,
  intersection_method = "min",
  pi_cheap = NA, pi_expensive = NA,
  pi_scale = 5:1,
  pi_calibrated = c(0.7, 0.5, 0.3, 0.1, 0))
}

\arguments{
  \item{toocheap, cheap, expensive, tooexpensive}{Names
  of the variables in the data.frame/matrix that contain the
  survey data on the respondents' "too cheap", "cheap",
  "expensive" and "too expensive" price preferences.

  If the \code{toocheap} price was not assessed, a
  variable of NAs can be used instead.  If \code{toocheap}
  is NA for all cases, it is possible to calculate the Point of
  Marginal Expensiveness and the Indifference Price Point, but it
  is impossible to calculate the Point of Marginal Cheapness and
  the Optimal Price Point.}
  \item{design}{A survey design which has been created by the
  function \code{\link{svydesign}()} from the \pkg{survey}
  package. The data that is used as an input of \code{svydesign()}
  must include all the variable names for \code{toocheap},
  \code{cheap}, \code{expensive} and \code{tooexpensive} variables
  specified above.}
  \item{validate}{logical. should only respondents with
  consistent price preferences (too cheap < cheap < expensive
  < too expensive) be considered in the analysis?}
  \item{interpolate}{logical. should interpolation of the price
  curves be applied between the actual prices given by the
  respondents? If interpolation is enabled, the output appears
  less bumpy in regions with sparse price information. If the
  sample size is sufficiently large, interpolation should not
  be necessary.}
  \item{interpolation_steps}{numeric. if \code{interpolate} is
  \code{TRUE}: the size of the interpolation steps. Set by
  default to 0.01, which should be appropriate for most goods
  in a price range of 0-50 USD/Euro.}
    \item{intersection_method}{"min" (default), "max", "mean" or
  "median". defines the method how to determine the price
  points (range, indifference price, optimal price) if there
  are multiple possible intersections of the price curves.
  "min" uses the lowest possible prices, "max" uses the
  highest possible prices, "mean" calculates the mean among
  all intersections and "median" uses the median of all
  possible intersections}
  \item{pi_cheap, pi_expensive}{Only required for the Newton
  Miller Smith extension. Names of the variables in the data
  that contain the survey data on the respondents' purchase
  intent at their individual cheap/expensive price.}
  \item{pi_scale}{Only required for the Newton Miller Smith
  extension. Scale of the purchase intent variables pi_cheap and
  pi_expensive. By default assuming a five-point scale with 5
  indicating the highest purchase intent.}
  \item{pi_calibrated}{Only required for the Newton Miller Smith
  extension. Calibrated purchase probabilities that are assumed
  for each value of the purchase intent scale. Must be the same
  order as the pi_scale variable so that the first value of
  pi_calibrated corresponds to the first value in the pi_scale
  variable. Default values are taken from the Sawtooth Software
  PSM implementation in Excel: 70\% for the best value of the
  purchase intent scale, 50\% for the second best value,
  30\% for the third best value (middle of the scale), 10\%
  for the fourth best value and 0\% for the worst value.}
}

\details{
The main logic of the Price Sensitivity Meter Analysis is
explained in the documentation of the \code{\link{psm_analysis}}
function. The \code{psm_analysis_weighted} performs the same
analysis, but weights the survey data according to a known
population.}

\value{
The function output consists of the following elements:

    \item{\code{data_input}:}{\code{data.frame} object. Contains
    the data that was used as an input for the analysis.}
    \item{\code{validated}:}{\code{logical} object. Indicates
    whether the \code{"validate"} option has been used (to
    exclude cases with intransitive price preferences).}
    \item{\code{invalid_cases}:}{\code{numeric} object. Number
    of cases with intransitive price preferences.}
    \item{\code{total_sample}:}{\code{"numeric"} object.
    Total sample size of the input sample \emph{before}
    assessing the transitivity of individual price preferences.}
    \item{\code{data_vanwestendorp}:}{\code{data.frame} object.
    Output data of the Price Sensitivity Meter analysis.
    Contains the \bold{weighted} cumulative distribution
    functions for the four price assessments (too cheap, cheap,
    expensive, too expensive) for all prices.}
    \item{\code{pricerange_lower}:}{\code{numeric} object. Lower
    limit of the acceptable price range as defined by the
    Price Sensitivity Meter, also known as \bold{point of
    marginal cheapness}: Intersection of the "too cheap" and the
    "expensive" curves.}
    \item{\code{pricerange_upper}:}{\code{numeric} object. Upper
    limit of the acceptable price range as defined by the Price
    Sensitivity Meter, also known as \bold{point of marginal
    expensiveness}: Intersection of the "too expensive" and the
    "cheap" curves.}
    \item{\code{idp}:}{\code{numeric} object. \bold{Indifference
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "cheap" and the "expensive" curves.}
    \item{\code{opp}:}{\code{numeric} object. \bold{Optimal
    Price Point} as defined by the Price Sensitivity Meter:
    Intersection of the "too cheap" and the "too expensive"
    curves.}
    \item{\code{weighted}:}{\code{logical} object. Indicating
    if weighted data was used in the analysis. Outputs from
    \code{psm_analysis_weighted()} always have the value
    \code{TRUE}. When data is unweighted, use the function
    \code{\link{psm_analysis}.}}
    \item{\code{survey_design}:}{\code{survey.design2} object.
    Returning the full survey design as specified with the
    \code{\link[survey]{svydesign}} function from the \pkg{survey} package.}
    \item{\code{NMS}:}{\code{logical} object. Indicates whether
    the additional analyses of the Newton Miller Smith Extension
    were performed.}
}

\references{
  Van Westendorp, P (1976) "NSS-Price Sensitivity Meter (PSM) --
  A new approach to study consumer perception of price"
  \emph{Proceedings of the ESOMAR 29th Congress}, 139--167. Online
  available at \url{https://www.researchworld.com/a-new-approach-to-study-consumer-perception-of-price/}.

  Newton, D, Miller, J, Smith, P, (1993) "A market acceptance
  extension to traditional price sensitivity measurement"
  \emph{Proceedings of the American Marketing Association
  Advanced Research Techniques Forum}.

  Sawtooth Software (2016) "Templates for van Westendorp PSM for
  Lighthouse Studio and Excel". Online available at
  \url{https://sawtoothsoftware.com/resources/software-downloads/tools/van-westendorp-price-sensitivity-meter}
}

\examples{

# assuming a skewed sample with only 1/3 women and 2/3 men

input_data <- data.frame(tch = round(rnorm(n = 250, mean = 8, sd = 1.5), digits = 2),
                         ch = round(rnorm(n = 250, mean = 12, sd = 2), digits = 2),
                         ex = round(rnorm(n = 250, mean = 13, sd = 1), digits = 2),
                         tex = round(rnorm(n = 250, mean = 15, sd = 1), digits = 2),
                         gender = sample(x = c("male", "female"),
                                         size = 250,
                                         replace = TRUE,
                                         prob = c(2/3, 1/3)))

# ... and in which women have on average 1.5x the price acceptance of men
input_data$tch[input_data$gender == "female"] <- input_data$tch[input_data$gender == "female"] * 1.5
input_data$ch[input_data$gender == "female"] <- input_data$ch[input_data$gender == "female"] * 1.5
input_data$ex[input_data$gender == "female"] <- input_data$ex[input_data$gender == "female"] * 1.5
input_data$tex[input_data$gender == "female"] <- input_data$tex[input_data$gender == "female"] * 1.5

# creating a sample design object using the survey package
# ... assuming that gender is balanced equally in the population of 10000

input_data$gender_pop <- 5000

input_design <- survey::svydesign(ids = ~ 1, # no clusters
                          probs = NULL, # hence no cluster samling probabilities,
                          strata = input_data$gender, # stratified by gender
                          fpc = input_data$gender_pop, # strata size in the population
                          data = input_data)
                          # data object used as input: no need to specify single variables

output_weighted_psm <- psm_analysis_weighted(toocheap = "tch",
  cheap = "ch",
  expensive = "ex",
  tooexpensive = "tex",
  design = input_design)

summary(output_weighted_psm)
}


# check Levenshtein's Distance (e.g., misspellings) [may need to do before canonical name generation]
# Watch for: Ornithodoros vunkeri; Ornithodoros yukeri; Ornithodoros yunkeri
library(stringdist)
temp <- c()
similar_names <-c()
compared_names <- c()
cutoff_distance <- 2
df2 <- c()
io <- FALSE
for(i in 1:length(df$canonicalName)){
  if(!(df$canonicalName[i] %in% similar_names)){ # testing
    for(j in 1:length(df$canonicalName)){
      score <- stringdist(df$canonicalName[i], df$canonicalName[j], "dl")
      temp <- c(temp, score)
    }
    if(any(temp %in% c(1:cutoff_distance))){
      if(io){
        df2 <- cbind(df2, temp)
        wc = wc + 1
      } else {
        df2 <- as.data.frame(temp)
        rownames(df2) <- df$canonicalName
        io <- TRUE
        wc <- 1
      }
      colnames(df2)[which(colnames(df2) == "temp")] <- df$canonicalName[i]
      similar <- rownames(df2)[which(df2[,wc]==min(df2[,wc][which(df2[,wc]>0)]))]
      comp_name <- rep(df$canonicalName[i], length(similar))
      similar_names <- c(similar_names, similar)
      compared_names <- c(compared_names, comp_name)
    }
    temp <- c()
  }
  if(i %% 10 == 0){
    print(paste('Completed iteration:', i, 'out of', length(df$canonicalName), 'iterations (', round(i/length(df$canonicalName),2)*100,'% DONE)'))
  }
}
print('FINISHED!')
check_mat <- as.data.frame(cbind(compared_names, similar_names)) # create matched names data frame
write.csv(check_mat,"~/GitHub/ixodes-tpt/output/matched_names_review.csv", row.names = FALSE) # write out matched names for review
print('proceed to missing higher taxa')


#' Matrix Multiplication
#'
#' Conceptually, this computes \code{t(x) \%*\% x} for a shaq \code{x}.
#'
#' @section Communication:
#' The operation consists of a local crossproduct, followed by an
#' \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param y
#' Must be \code{NULL}.
#'
#' @return
#' A regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' cp = crossprod(x)
#' comm.print(cp)
#'
#' finalize()
#' }
#'
#' @name crossprod
#' @rdname crossprod
NULL

cp.shaq = function(x, y = NULL)
{
  if (!is.null(y))
    comm.stop("only implemented for y=NULL")

  cp.local = base::crossprod(Data(x))
  allreduce(cp.local)
}

#' @rdname crossprod
#' @export
setMethod("crossprod", signature(x="shaq"), cp.shaq)


# 3. faza: Izdelava zemljevida

#zemljevid diplomantov

# Uvozimo funkcijo za pobiranje in uvoz zemljevida.
source("lib/uvozi.zemljevid.r")

# Uvozimo zemljevid.
cat("Uvažam zemljevid...\n")
regije <- uvozi.zemljevid("http://www.stat.si/doc/Geo/Statisticne_regije_NUTS3.zip",
                          "regije", "Statisticne_regije.shp", mapa = "zemljevid",
                          encoding = "Windows-1250")

# Funkcija, ki podatke preuredi glede na vrstni red v zemljevidu
preuredi <- function(podatki, zemljevid) {
  return(data.frame(podatki[order(rownames(podatki)), ])[rank(levels(zemljevid$IME)[rank(zemljevid$IME)]), ])
}

# Preuredimo podatke, da jih bomo lahko izrisali na zemljevid.
DIPLOMANTI <- preuredi(DIPLOMANTI, regije)

# Izračunamo MIN in MAX vrednost
min.2007 <- min(DIPLOMANTI[2], na.rm=TRUE)
max.2007 <- max(DIPLOMANTI[2], na.rm=TRUE)

# Narišimo zemljevid v PDF.
cat("Rišem zemljevid...\n")
pdf("slike/zemljevid_diplomanti.pdf", width=6, height=4)

# n = 100
# barve = topo.colors(n)[1+(n-1)*(druzine$povprecje-min.povprecje)/(max.povprecje-min.povprecje)]
# plot(obcine, col = barve)
popravek.koordinat <- c(0,0,0,0,0,0,-4000,0,0,0,0,0,0,0,0,0,0,3000,-3000,0,0,0,0,-7000)

regije$x2007 <- DIPLOMANTI[,2]
print(spplot(regije, "x2007", col = heat.colors(100), main = "Diplomanti v Sloveniji za leto 2007",
             sp.layout = list(list("sp.text", coordinates(regije) + popravek.koordinat , regije$IME, cex = 0.4))))

dev.off()