#' Pseudo-Random DDM Parameter Generation
#'
#' Generates a data_frame with pseudo-randomly generated DDM parameters for model
#' validation or similar.
#' @export
#' @param nsub Number of "simulated" subjects.
#' @param include A vector with the desired inter-trial variabilities.
#' 'sv' for Drift Rate inter-trial variability.
#' 'sz' for Bias inter-trial variability.
#' 'st' for Non-Decision Time inter-trial variability.
#' @return Returns a Data Frame with the desired parameters.
#' @examples
#'
#' makeFakeParams(10, include = c('sv', 'st'))
makeFakeParams <- function(nsub=1, include=NULL){

    fakeparams <- lapply(1:nsub, function(x) {
        list(
            a     = runif(1, 0.5, 2),
            v    = runif(1, 0.5, 2),
            t     = runif(1, 0.15, 1),
            z    = runif(1, 0.45, 0.55)
        )
    })

    if('sv' %in% include){
        fakeparams %<>% map(., function(x) {c(x, sv = runif(1, 0.05, 0.2))})
    }

    if('sz' %in% include){
        fakeparams %<>% map(., function(x) {c(x, sz = runif(1, 0.05, 0.2))})
    }

    if('st' %in% include){
        fakeparams %<>% map(., function(x) {c(x, st = runif(1, 0.05, 0.2))})}

    fakeparams <- as.data.frame(data.table::rbindlist(fakeparams))

}


library(rgenoud)

fitness= function(x= rep(1, nrow(task_table))){
  total_value= sum(task_table$value * x)
  total_weight= sum(task_table$weight * x)
  ifelse(total_weight <= 400, total_value, 400-total_weight)
}

allowed= matrix(c(rep(0, nrow(task_table)), task_table$pieces), ncol = 2)
set.seed(42)
evolution= genoud(fn= fitness,
                  nvars= nrow(allowed),
                  max= TRUE,
                  pop.size= 10000,
                  data.type.int= TRUE,
                  Domains= allowed)

cat("Value: ", evolution$value, "\n")
cat("Weight:", sum(task_table$weight * evolution$par), "dag", "\n")
data.frame(item= task_table$items, pieces= as.integer(solution)) %>%
  filter(solution> 0)


library(changepoint)

air_data <- read.table("E:\\airbox-May.csv", header = FALSE)
colnames(air_data) <- c("date_time", "ID", "PM25", "T", "Humid", "Coor_x", "Coor_y")
air_data$f_time <- as.POSIXct(strptime(air_data$date_time, "%Y-%m-%dT%H:%M:%SZ"))

#找到對應的sensor
sensor_ID <- unique(air_data$ID)
PM25_of_sensor <- subset(air_data, ID == sensor_ID[1])
ansmeanvar = cpt.meanvar(PM25_of_sensor$PM25)
ch_id <- cpts(ansmeanvar)

#找某sensor的每一天
Day_ID <- unique(as.Date(PM25_of_sensor$f_time))
for(i in 1:length(Day_ID)){
	sensor_of_day <- PM25_of_sensor[ which( as.Date(PM25_of_sensor$f_time) == Day_ID[i] ), ]
	print(Day_ID[i])
	print(length(sensor_of_day$PM25))
	cat ("Press [enter] to continue")
	line <- readline()
	if( length(sensor_of_day$PM25) < 4 ) next
	ansmeanvar=cpt.meanvar(sensor_of_day$PM25)
	ch_id <- cpts(ansmeanvar) #回傳編號
	#plot(sensor_of_day$PM25, sensor_of_day$date_d)
	zz_b = 1:ch_id
	xx_b = sensor_of_day$f_time[zz_b]
	yy_b = rep(mean(sensor_of_day$PM25[zz_b]), times = length(zz_b))
	zz_f = (ch_id+1):length(sensor_of_day$PM25)
	xx_f = sensor_of_day$f_time[zz_f]
	yy_f = rep(mean(sensor_of_day$PM25[zz_f]), times = length(zz_f))
	plot(sensor_of_day$f_time, sensor_of_day$PM25,type = "o", xlab = "PM2.5", ylab = "Time")
	lines(xx_b,yy_b,col="red")
	lines(xx_f,yy_f,col="red")

	#curve(x=sensor_of_day$PM25[ch_id],as.numeric(sensor_of_day$f_time[1]), as.numeric(sensor_of_day$f_time[ch_id]))
	pic_name <- paste0("E:\\myGraph\\p", i,".png")
	dev.copy(png,pic_name)
	dev.off()
	#time_dif <- diff(time_of_d)
	#diff_in_dat <- as.numeric(as.Date(time_of_d[2]) - as.Date(time_of_d[1]))

}


associations.calculate.prob <- function(hits, weight=T, alpha = 2){
  hits[is.na(hits)] = 0
  if (weight) (1 - ((1/alpha) ^ hits)) else as.numeric(hits>0)
}

associations.association <- function(hits.a, hits.b, ...){
  # returns the association (a AND b)/a, hits.[ab] should be integer vectors of equal length
  prob.a = associations.calculate.prob(hits.a, ...)
  prob.b = associations.calculate.prob(hits.b, ...)
  sum(prob.a * prob.b) / sum(prob.a)
}

associations.per.period <- function(hits.a, hits.b, index = rep('total', length(hits.a)), ...)  {
  # index should be a 'break' variable similar to tapply that identify to which group each hit belongs
  # returns a data frame with columns groups=unique(index) and associations
  groups = unique(index)
  data.frame(group=groups, association=sapply(groups, function(i) associations.association(hits.a[index==i],hits.b[index==i], ...), USE.NAMES=F))
}

associations.from.hits <- function(hits, ids, objects, objects.from=unique(objects), objects.to = unique(objects), index=NULL, ...) {
  # calculate associations from each object in objects to each object in objects.to
  # hits, ids, objects and index (if given) should all be vectors of equal length
  # ids identify the documents (articles), and hits are the keyword frequencies per object per id.
  # if objects.from and objects.to are given, only calculate assocaitions from/to these objects
  # index, if given, should be a 'break' variable (see associations.per.period)
  result = NULL
  for (from in objects.from) {
    from.hits = hits[objects == from]
    for (to in objects.to[objects.to != from]) {
      # select hits for to object where id matches the ids of the from objects
      to.hits = (hits[objects == to])[match(ids[objects == from], ids[objects == to])]
      to.hits[is.na(to.hits)] = 0
      if (is.null(index))
        r = data.frame(association=associations.association(from.hits, to.hits, ...))
      else {
        r = associations.per.period(from.hits, to.hits, index=index[objects == from], ...)
      }
      r$from = from
      r$to = to
      result = rbind(result, r)
    }
  }
  return(result)
}


install.all.req  <- function(){
    install.packages(c(
,"ada"
,"apcluster" #negDistMat apcluster
,"arules" #itemFrequencyPlot apriori
,"benford.analysis"
,"BenfordTests"
,"biglm"
,"car" # scatterplotMatrix
,"caret"
,"chemometrics"
,"class"  #knn
,"clue" #cl_agreement(
,"cluster"
,"corrgram" #corrgram
,"d3Network" #d3SimpleNetwork
,"devtools" #install_github
,"DMwR"
,"doParallel" #registerDoParallel
,"dplyr" #%>%
,"e1071"
,"ff" # read.table.ffdf
,"fOptions" #BlackScholesOption
,"forecast" #auto.arima
,"foreign"
,"fortunes"
,"fpc" #pamk
,"ggm" #pcor
,"ggplot2"
,"ggvis"
,"glmnet"
,"Hmisc" #rcorr
,"httr"
,"igraph" #graph graph.tree print.igraph graph.data.frame E V vcount ecount as.undirected average.path.lenght farthest.nodes largest.cliques degree
,"ISLR"
,"kernlab" #ksvm
,"knitr"
,"lattice" #splom
,"lme4"
,"lubridate"
,"manipulate"
,"maptools"
,"MASS"
,"matlab"
,"mclust" #Mclust
,"moments" #kurtosis
,"NbClust" #NbClust
,"nnet"
,"nycflights13"
,"openNLP" #tagPOS  findAssocs
,"PBSmapping"
,"plyr"
,"polycor" #polychoric
,"psych" #tetrachoric draw.tetra
,"quantmod" #chartSeries Cl Op Hi Lo ClCl Ad getSymbols
,"randomForest"
,"rattle"
,"rCharts" #rPlot
,"reshape2"
,"RcmdrPlugin.temis"
,"Rcpp"
,"RCurl" #getURL getPageURLs getForm
,"rgl" #rglplot
,"RJSONIO"
,"rmarkdown"
,"RODBC"
,"ROracle"
,"roxygen2"
,"RSQLite"
,"RTextTools"  # create_container train_model classify_model create_analytics
,"rugarch" #ugarchspec
,"RWeka"  #NGramTokenizer
,"shiny"
,"stringr"
,"tcltk" #tkplot
,"tidyr"
,"tm" #DocumentTermMatrix tm_map removeSparseTerms Corpus VectorSource   TermDocumentMatrix
,"TraMineR" #seqdef
,"tree"
,"tseries" #po.test
,"TTR" #RSI MACD williamsAD
,"twitteR" #twitteR
,"urca" #cumsum ur.df
,"vars" #VAR VARselect
,"vegan", #cascadeKM
,"wordcloud" #wordcloud
,"xlsx" #read.xlsx
,"XML"
,"zoo"
 ),
dependencies=TRUE
)
}


# Reading in data
library(arules)
ds = read.transactions('Market_Basket.csv', sep = ',', rm.duplicates = TRUE)

# Overview of the data
summary(ds)
itemFrequencyPlot(ds, topN = 50, cex = 0.7, main = paste("Most frequently purchased items"))

# Training apriori on the data
rules = eclat(ds, parameter = list(support = 0.004, minlen = 2 ))

# Visualising
inspect(sort(rules, decreasing = TRUE, by = 'support')[1:10])


library(png)
img <- readPNG("Unfilledcirc.png")
M <- img[ , , 1]
M <- ifelse(M < 0.5, 0, 1)
image(M, col = c(1, 0))

# https://en.wikipedia.org/wiki/Flood_fill
floodfill <- function(row, col, tcol, rcol) {
  if (tcol == rcol) return()
  if (M[row, col] != tcol) return()
  M[row, col] <<- rcol
  floodfill(row - 1, col    , tcol, rcol) # south
  floodfill(row + 1, col    , tcol, rcol) # north
  floodfill(row    , col - 1, tcol, rcol) # west
  floodfill(row    , col + 1, tcol, rcol) # east
  return("filling completed")
}

options(expressions = 10000)
startrow <- 100; startcol <- 100
floodfill(startrow, startcol, 0, 2)

image(M, col = c(1, 0, 2))


#@reemuru
#data mining
#naive bayes

#set the working directory
setwd("./naive-bayes/")

#load imports-85 file with headers in the first row
bank<- read.csv(file = "Bank.csv", header = TRUE, sep = ",")

#load and initialize the necessary packages
#install.packages("e1071")
library(e1071)
library(arules)

#exclude id variable as it is not conducive to the model development process
bank$id<-NULL

#discretize age and income with equal frequency binning
bank$age<-discretize(bank$age, breaks=6)
bank$income<-discretize(bank$income, breaks=6)
#discretize age with factor command
bank$children<-factor(bank$children)

#verify discretization
str(bank)

#set the seed for reproducible results
set.seed(1234)
#split data into 70% training data and 30% test data
ind <- sample(2, nrow(bank), replace = TRUE, prob = c(0.7, 0.3))
train.data <- bank[ind == 1, ]
test.data <- bank[ind == 2, ]

#pep = DV . is wildcard setting remaining IV
#store model in variable with same name
model<-naiveBayes(pep~., train.data)
print(model)

#build confusion matrix with training data
table(predict(model, train.data), train.data$pep)

#mosaic plot using test data
mosaicplot(table(predict(model, test.data), test.data$pep), shade=TRUE, main="Predicted vs. Actual PEP")


model_phylsowingdatecorrection <- function (sowingDay = 1,
         latitude = 0.0,
         sDsa_sh = 1.0,
         rp = 0.0,
         sDws = 1,
         sDsa_nh = 1.0,
         p = 120.0){
    #'- Name: PhylSowingDateCorrection -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: PhylSowingDateCorrection Model
    #'            * Author: Loic Manceau
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Correction of the Phyllochron Varietal parameter according to sowing date
    #'- inputs:
    #'            * name: sowingDay
    #'                          ** description : Day of Year at sowing
    #'                          ** parametercategory : species
    #'                          ** datatype : INT
    #'                          ** min : 1
    #'                          ** max : 365
    #'                          ** default : 1
    #'                          ** unit : d
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: latitude
    #'                          ** description : Latitude
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** min : -90
    #'                          ** max : 90
    #'                          ** default : 0.0
    #'                          ** unit : °
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: sDsa_sh
    #'                          ** description : Sowing date at which Phyllochrone is maximum in southern hemispher
    #'                          ** parametercategory : species
    #'                          ** inputtype : parameter
    #'                          ** datatype : DOUBLE
    #'                          ** min : 1
    #'                          ** max : 365
    #'                          ** default : 1.0
    #'                          ** unit : d
    #'                          ** uri : some url
    #'            * name: rp
    #'                          ** description : Rate of change of Phyllochrone with sowing date
    #'                          ** parametercategory : species
    #'                          ** inputtype : parameter
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 365
    #'                          ** default : 0
    #'                          ** unit : d-1
    #'                          ** uri : some url
    #'            * name: sDws
    #'                          ** description : Sowing date at which Phyllochrone is minimum
    #'                          ** parametercategory : species
    #'                          ** datatype : INT
    #'                          ** default : 1
    #'                          ** min : 1
    #'                          ** max : 365
    #'                          ** unit : d
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: sDsa_nh
    #'                          ** description : Sowing date at which Phyllochrone is maximum in northern hemispher
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.0
    #'                          ** min : 1
    #'                          ** max : 365
    #'                          ** unit : d
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'            * name: p
    #'                          ** description : Phyllochron (Varietal parameter)
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 120
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : °C d leaf-1
    #'                          ** uri : some url
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: fixPhyll
    #'                          ** description :  Phyllochron Varietal parameter
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : °C d leaf-1
    if (latitude < 0.0)
    {
        if (sowingDay > as.integer(sDsa_sh))
        {
            fixPhyll <- p * (1 - (rp * min((sowingDay - sDsa_sh), sDws)))
        }
        else
        {
            fixPhyll <- p
        }
    }
    else
    {
        if (sowingDay < as.integer(sDsa_nh))
        {
            fixPhyll <- p * (1 - (rp * min(sowingDay, sDws)))
        }
        else
        {
            fixPhyll <- p
        }
    }
    return (list('fixPhyll' = fixPhyll))
}


S14AFJ Example Program Results

        Z               K       (d^K/dz^K)psi(Z)

        (-1.5, 2.5)     1       (-1.9737e-01, -2.4271e-01)


#' @export
#'
#' @title checkIsAutocorrelated - Check whether MCMC chains are autocorrelated.
#'
#' @description Run autocorrelation on every parameter in an mcmc.list and make
#' a decision whether they are significantly auto correlated.  Ideally, chains
#' are not autocorrelated when converged.
#'
#' @param obj An mcmc.list object from the \code{rjags} package.  These are output
#' by the \code{coda.samples} function.
#'
#' @param criterion scalar specifying the level of acceptable autocorrelation at
#' the assessed \code{lag}.  If all average lag2 autocorrelations are less than this number, the
#' whole mcmc object is deems 'random' or not autocorrelated.
#'
#' @param lag The lag at which to assess autocorrelation.  This should generally be a
#' low number like 1, 2, 5, or 10.
#'
#' @param quiet Whether to print any output on screen.
#'
#' @details This routine calculates auto correlation separately at the specified lag
#' for every chain in the mcmc.list, then averages autocorrelations across
#' chains.
#'
#' @return A list with the following components
#' \itemize{
#'   \item autoCorrelated: If the average autocorrelations at the specified
#'   lag are all less than
#'   \code{criterion}, the chain is declared un-autocorrelated and is set FALSE.
#'   Otherwise, this component of the returns is TRUE.
#'   \item autoCorrs: the computed autocorrelations at the specified lag.
#'   This value is the average across chains in \code{obj}.
#'  }
#'
#' @author Trent McDonald
#'
#'
#' @seealso \code{\link{checkIsConverged}}
#'
#' @examples
#' \dontrun{
#' jags = jags.model(file="someJAGSFile.txt",
#'    data=someJAGS.data, inits=someJAGS.inits,
#'    n.chains=3,n.adapt=100)
#' update(jags, n.iter=1000)
#' out = coda.samples(jags,
#'    variable.names=c("someParameter"),
#'    n.iter=1000,
#'    thin=2)
#'
#' auto <- chechIsAutocorrelated(out)
#' }

checkIsAutocorrelated <- function(obj, criterion=0.4, lag=1, quiet=FALSE){

  if(!quiet) cat(paste0("\n", paste(rep("-",4),collapse="")," Checking autocorrelation:\n"))
  vn <- varnames(obj)
  ncovars <- nvar(obj)
  nchains <- nchain(obj)
  acflag2 <- rep(NA,ncovars)
  names(acflag2) <- vn
  for( i in 1:ncovars ){
    tmp <- rep(NA,nchains)
    for(j in 1:nchains){
      tmp.2 <- acf(as.matrix(obj[[j]][,i]), lag.max = lag, plot=FALSE)
      tmp[j] <- tmp.2$acf[tmp.2$lag ==lag,,]
    }
    acflag2[i] <- mean(tmp)
    if(!quiet) cat(paste( vn[i], ": mean(acf[",lag, "]) =", round(acflag2[i],5), "\n") )
  }
  if(any(acflag2>criterion, na.rm=TRUE)){
    if(!quiet) cat(paste0("\nSome autocorrelations exceed ",criterion, ".\nInspect acfplot(mcmc.list) and increase thinning.\n"))
    ans <- TRUE
  } else {
    ans <- FALSE
  }

  list(autoCorrelated = ans, autoCorrs=acflag2)

}


#Rscript hdr_histogram.r histogramfile1 histogramfile2 ... histogramfileN NumberOfNines output.png
args = commandArgs(trailingOnly=TRUE)
output = args[length(args)]
nines = as.numeric(args[length(args) -1])
files = args[1:(length(args)-2)]

library(tidyverse)
library(drlib)
library(stringr)
library(tidyr)

plot = data_frame(FileName = files) %>%
  mutate(lines = map(FileName, ~ data.frame(line = readr::read_lines(.x, skip = 2)))) %>%
  unnest(lines) %>%
  mutate(line = trimws(line)) %>%
  separate(line, c("Value", "Percentile", "TotalCount", "OneOnOneMinusPercentile"), "\\s+") %>%
  mutate(Value = as.numeric(Value),
         Percentile = as.numeric(Percentile),
         TotalCount = as.numeric(TotalCount),
         OneOnOneMinusPercentile = as.numeric(OneOnOneMinusPercentile)) %>%
  mutate(Nines = log10(1-Percentile) / log10(.1)) %>%
  filter(!is.na(OneOnOneMinusPercentile)) %>%
  filter(Nines <= nines + .02) %>%
  ggplot(aes(Nines, Value, color=FileName)) +
  geom_line() +
  scale_x_continuous(breaks = 0:(nines), labels=paste0((1-(.1^(0:(nines)))) * 100, "%"), limits = c(0, nines + .02)) +
  labs(x="Percentile",
       y="Latency",
       title="Latency by Percentile Distribution") +
  theme_minimal() +
  theme(legend.position = "bottom")

ggsave(output, plot, width = 16, height = 4)


calc_tso <- function (count, sentiment)
{
  sentiments.ts <- as.ts(abs(sentiment))
  counts.ts <- as.ts(count)
  resSent <- tso(y = sentiments.ts, types = c("SLC","AO","TC"), discard.method = "bottom-up", tsmethod = "auto.arima", args.tsmethod = list(allowdrift = FALSE, D=1, ic = "bic"))
  resCount<- tso(y = counts.ts, types = c("SLC","AO", "TC"), discard.method = "bottom-up", tsmethod = "auto.arima", args.tsmethod = list(allowdrift = FALSE, D=1, ic = "bic"))
  plot(resSent)
  plot(resCount)

  res_tso_UNION = union(resSent$outliers$ind, resCount$outliers$ind)
  res_tso_INTERSECT = intersect(resSent$outliers$ind, resCount$outliers$ind)

  return(list(A=resCount$outliers$ind,B=resSent$outliers$ind,union=res_tso_UNION,intersect=res_tso_INTERSECT, s_p = resSent, c_p = resCount))
}


##  6장 소스코드

# CSV 파일 읽어들이기
ad.data <- read.csv("ad_result.csv", header = T, stringsAsFactors = F)
ad.data

# TV 광고의 광고비용과 신규 유저수의 산점도를 그리기
install.packages("ggplot2")
install.packages("scales")
library(ggplot2)
library(scales)

ggplot(ad.data, aes(x = tvcm, y = install)) + geom_point() +
  xlab("TV 광고비") + ylab("신규 유저수") +
  scale_x_continuous(label = comma) +
  scale_y_continuous(label = comma) + geom_smooth(method="lm")

# 잡지매체의 광고비용과 신규 유저수의 산점도를 그리기
ggplot(ad.data, aes(x = magazine, y = install)) + geom_point() +
  xlab("잡지 광고비") + ylab("신규 유저수") +
  scale_x_continuous(label = comma) +
  scale_y_continuous(label = comma) + geom_smooth(method="lm")

# 회귀분석 실행
fit <- lm(install ~ ., data = ad.data[, c("install", "tvcm", "magazine")])
fit

# 회귀분석 결과를 해석하기
summary(fit)
options(scipen=1000)


if (!require("igraph")) install.packages("igraph")
library("igraph")

# https://gist.github.com/LukasCBossert/9bd04115db3aa9ed974fdc69d3ff227c
NFDI_edges <- read.table(header=TRUE,
                         sep=",",
                         text="
from,to
DataPLANT,NFDI4BioDiversity
DataPLANT,NFDI4Chem
GHGA,NFDI4Health
KonsortSWD,BERD@NFDI
KonsortSWD,NFDI4BioDiversity
KonsortSWD,NFDI4Earth
KonsortSWD,NFDI4Health
KonsortSWD,Text+
NFDI4BioDiversity,NFDI4Earth
NFDI4BioDiversity,NFDI4Chem
NFDI4BioDiversity,NFDI4Health
NFDI4BioDiversity,KonsortSWD
NFDI4BioDiversity,DataPLANT
NFDI4Cat,FAIRmat
NFDI4Cat,NFDI4Chem
NFDI4Cat,NFDI4Ing
NFDI4Cat,DAPHNE4NFDI
NFDI4Chem,FAIRmat
NFDI4Chem,NFDI4Ing
NFDI4Chem,NFDI4Cat
NFDI4Chem,DAPHNE4NFDI
NFDI4Chem,PUNCH4NFDI
NFDI4Chem,NFDI4Health
NFDI4Chem,NFDI4BioDiversity
NFDI4Culture,Text+
NFDI4Culture,MaRDI
NFDI4Culture,NFDI4Ing
NFDI4Health,GHGA
NFDI4Health,KonsortSWD
NFDI4Health,NFDI4Chem
NFDI4Health,NFDI4Earth
NFDI4Health,NFDI4BioDiversity
NFDI4Ing,NFDI-MatWerk
NFDI4Ing,FAIRmat
NFDI4Ing,NFDI4Chem
NFDI4Ing,NFDI4Earth
NFDI4Ing,MaRDI
NFDI4Ing,Text+
NFDI4Ing,NFDI4Culture
BERD@NFDI,KonsortSWD
BERD@NFDI,MaRDI
BERD@NFDI,Text+
DAPHNE4NFDI,FAIRmat
DAPHNE4NFDI,NFDI-MatWerk
DAPHNE4NFDI,NFDI4Cat
DAPHNE4NFDI,NFDI4Chem
DAPHNE4NFDI,NFDI4Health
DAPHNE4NFDI,NFDI4Ing
DAPHNE4NFDI,PUNCH4NFDI
FAIRmat,DAPHNE4NFDI
FAIRmat,DataPLANT
FAIRmat,MaRDI
FAIRmat,NFDI-MatWerk
FAIRmat,NFDI4Cat
FAIRmat,NFDI4Chem
FAIRmat,NFDI4DataScience
FAIRmat,NFDI4Ing
FAIRmat,PUNCH4NFDI
MaRDI,BERD@NFDI
MaRDI,FAIRmat
MaRDI,NFDI-MatWerk
MaRDI,NFDI4Cat
MaRDI,NFDI4Chem
MaRDI,NFDI4Ing
MaRDI,PUNCH4NFDI
NFDI-MatWerk,DAPHNE4NFDI
NFDI-MatWerk,DataPLANT
NFDI-MatWerk,FAIRmat
NFDI-MatWerk,MaRDI
NFDI-MatWerk,NFDI4Chem
NFDI-MatWerk,NFDI4DataScience
NFDI-MatWerk,NFDI4Ing
NFDI4DataScience,KonsortSWD
NFDI4DataScience,MaRDI
NFDI4DataScience,NFDI-MatWerk
NFDI4DataScience,NFDI4BioDiversity
NFDI4DataScience,NFDI4Cat
NFDI4DataScience,NFDI4Chem
NFDI4DataScience,NFDI4Culture
NFDI4DataScience,NFDI4Health
NFDI4DataScience,NFDI4Ing
NFDI4DataScience,NFDI4Microbiota
NFDI4Earth,DataPLANT
NFDI4Earth,GHGA
NFDI4Earth,KonsortSWD
NFDI4Earth,NFDI4BioDiversity
NFDI4Earth,NFDI4Cat
NFDI4Earth,NFDI4Chem
NFDI4Earth,NFDI4Culture
NFDI4Earth,NFDI4Health
NFDI4Earth,NFDI4Ing
NFDI4Microbiota,DataPLANT
NFDI4Microbiota,GHGA
NFDI4Microbiota,NFDI4BioDiversity
NFDI4Microbiota,NFDI4Chem
NFDI4Microbiota,NFDI4DataScience
NFDI4Microbiota,NFDI4Health
NFDI4Microbiota,NFDI4Ing
PUNCH4NFDI,DAPHNE4NFDI
PUNCH4NFDI,FAIRmat
PUNCH4NFDI,GHGA
PUNCH4NFDI,MaRDI
PUNCH4NFDI,NFDI4Earth
PUNCH4NFDI,NFDI4Ing
Text+,KonsortSWD
Text+,NFDI4BioDiversity
Text+,NFDI4Culture
Text+,NFDI4Earth
Text+,NFDI4Ing
")

head(NFDI_edges)

NFDI_network <- graph_from_data_frame(NFDI_edges,
                                      directed = FALSE
                                     )

head(NFDI_network)

set.seed(9876543)

plot(NFDI_network,                    # loading data frame
     main  = "NFDI Network",          # adding a title
     frame = TRUE                     # making a frame
     )

set.seed(9876543)

plot(NFDI_network,                     # loading data frame
     main  = "NFDI Network",           # adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         #* better layout options
     )

set.seed(9876543)

plot(NFDI_network,                     # loading data frame
     main   = "NFDI Network",          # adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = "#ffcc66",   #* color of nodes
     vertex.frame.color = "#ffcc66",   #* color of the frame of nodes
     vertex.label.cex   = 0.5,         #* size of the description of the labels
     vertex.label.color = "black",     #* color of the description
     edge.color         = "#808080",   #* color of edges
     edge.curved        = 0.1,         #* factor of "curvity"
     )

#data.frame(
    degree(NFDI_network) #* calculate number of edges
#)

set.seed(9876543)

plot(NFDI_network,                     # loading data frame
     main   = "NFDI-Netzwerk",         # adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = "#ffcc66",   # color of nodes
     vertex.frame.color = "#ffcc66",   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0.1,         # factor of "curvity"
     vertex.size        = degree(NFDI_network), #* size of nodes depends on amount of edges
     )

NFDI_network_directed <- graph_from_data_frame(NFDI_edges,
                                               directed = TRUE
                                              )

head(NFDI_network_directed)

set.seed(9876543)

plot(NFDI_network_directed,            #<<<<<<< loading data frame
     main   = "NFDI-Netzwerk",         # adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = "#ffcc66",   # color of nodes
     vertex.frame.color = "#ffcc66",   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           #<<<<<<<<< factor of "curvity"
     vertex.size        = degree(NFDI_network_directed), #<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          #* arrow size,  defaults to 1
    )

#data.frame(
    degree(NFDI_network_directed,
                  mode = "in")
#)

set.seed(9876543)

plot(NFDI_network_directed,            # loading data frame
     main   = "NFDI Network (<in>)",  #<<<<<<<< adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = "#ffcc66",   # color of nodes
     vertex.frame.color = "#ffcc66",   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "in"), #<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
    )

#data.frame(
    degree(NFDI_network_directed,
                  mode = "out")
#)

set.seed(9876543)

plot(NFDI_network_directed,            # loading data frame
     main   = "NFDI Network (<out>)",  #<<<<<<<< adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = "#ffcc66",   # color of nodes
     vertex.frame.color = "#ffcc66",   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "out"), #<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
    )

# https://gist.github.com/LukasCBossert/ce56ebd0059b4879c7d11c1090118c25
NFDI_nodes <- read.table(header=TRUE,
                         sep=",",
                         text="
name,group,round
DataPLANT,2,1
GHGA,1,1
KonsortSWD,3,1
NFDI4BioDiversity,2,1
NFDI4Cat,5,1
NFDI4Chem,5,1
NFDI4Culture,3,1
NFDI4Health,1,1
NFDI4Ing,4,1
BERD@NFDI,3,2
DAPHNE4NFDI,5,2
FAIRmat,5,2
MaRDI,4,2
NFDI-MatWerk,4,2
NFDI4DataScience,4,2
NFDI4Earth,2,2
NFDI4Microbiota,2,2
PUNCH4NFDI,5,2
Text+,3,2
")

NFDI_network_directed <- graph_from_data_frame(d = NFDI_edges,        # d = data frame =~ edges
                                               vertices = NFDI_nodes, #nodes
                                               directed = TRUE)       #directed

NFDI_color_year <- c("lightgreen", # 2019 (1)
                     "lightblue"   # 2020 (2)
                    )
NFDI_color_groups <- NFDI_color_year[
    as.numeric(as.factor(
        V(NFDI_network_directed)$round))] # <<<< based on the round

set.seed(9876543)

plot(NFDI_network_directed,            # loading data frame
     main   = "NFDI-Network (<Funding year>)",  #<<<<<<<< adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = NFDI_color_groups,   #<<<<<<<<<< color of nodes
     vertex.frame.color = NFDI_color_groups,   #<<<<<<<<<< color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "total"), #<<<<<<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
    )

NFDI_color_code <- c("#f5ac9f", # Medicine
                     "#e43516", # Life Sciences
                     "#f9b900", # Humanities
                     "#007aaf", # Engineering Sciences
                     "#6ca11d"  # Chemistry/Physics
                    )
NFDI_color_groups <- NFDI_color_code[
    as.numeric(as.factor(
        V(NFDI_network_directed)$group))]

set.seed(9876543)

plot(NFDI_network_directed,            # loading data frame
     main   = "NFDI-Network (<NFDI conference systematics>)",  #<<<<<<<< adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = NFDI_color_groups,   #<<<<<<<<<< color of nodes
     vertex.frame.color = NFDI_color_groups,   #<<<<<<<<<< color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "total"), #<<<<<<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
    )

nfdi_plot_legend <- function(){

    legend("topleft",   # x-position
       title  = "NFDI conference systematics", # title
       legend = c(
           "(1) Medicine",
           "(2) Life Sciences",
           "(3) Humanities",
           "(4) Engineering Sciences",
           "(5) Chemistry/Physics"
       ),  # the text of the legend
       col    = NFDI_color_code ,  # colors of lines and points beside the legend text
       pch    = 20,     # the plotting symbols appearing in the legend
       bty    = "n",    # no frame, the type of box to be drawn around the legend (n=no frame)
       cex    = .75,    # character expansion factor relative to current par("cex").
       pt.cex = 2       # expansion factor(s) for the points
          )
}

set.seed(9876543)

plot(NFDI_network_directed,            # loading data frame
     main   = "NFDI Network (<NFDI conference systematics>)",  #<<<<<<<< adding a title
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = NFDI_color_groups,   # color of nodes
     vertex.frame.color = NFDI_color_groups,   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.color         = "#808080",   # color of edges
     edge.curved        = 0,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "total"), #<<<<<<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
    )
nfdi_plot_legend()

nfdi_plot_group <- function(NFDI_name) {

    set.seed(9876543)
    nfdi_local_network <- function(NFDI_name) {
    plot(NFDI_network_directed,
     main   = "NFDI Network (<NFDI conference systematics>)",  # adding a title
    sub = NFDI_name,
     frame  = TRUE,                    # making a frame
     layout = layout.graphopt,         # better layout options
     vertex.color       = NFDI_color_groups,   # color of nodes
     vertex.frame.color = NFDI_color_groups,   # color of the frame of nodes
     vertex.label.cex   = 0.5,         # size of the description of the labels
     vertex.label.color = "black",     # color of the description
                                       # color: https://www.w3schools.com/colors/colors_picker.asp
     edge.curved        = 0.2,           # factor of "curvity"
     vertex.size        = degree(NFDI_network_directed,
                                 mode = "total"), #<<<<<<<<<<< size of nodes depends on amount of edges
     edge.arrow.size    = .5,          # arrow size,  defaults to 1
         edge.color = with(NFDI_edges,
                           ifelse(from %in% NFDI_name,"#808080", # grey
                                  ifelse(to == NFDI_name,"#000000", # black
                                         NA)))
        )
    nfdi_plot_legend()

          }

    ####################################################
    ### ! important!
    ### If you want to export the plots,
    ### you need to create a folder called "img" first.
    ####################################################
    # pdf(paste0("img/network_group_",NFDI_name,".pdf"))   # save image as PDF
    # nfdi_local_network(NFDI_name)   # display image for saving
    # dev.off()                       # close image stream

 nfdi_local_network(NFDI_name)  # display image in JupyterNotebook
}
nfdi_plot_group("NFDI4Ing")

nfdi_plot_group("NFDI4Microbiota")

for (name in NFDI_nodes$name){
  nfdi_plot_group(name)
}


cat(sapply(tolower(readLines(tail(commandArgs(), n=1))), function(s) {
  xs <- strsplit(s, "")[[1]]
  ct <- rep.int(0, 26)
  for (i in 1:length(xs)) {
    if (xs[i] >= 'a' && xs[i] <= 'z') {
      ct[utf8ToInt(xs[i]) - 96] <- ct[utf8ToInt(xs[i]) - 96] + 1
    }
  }
  ct <- sort.int(ct)
  i <- 26
  b <- 0
  while (i > 0 && ct[i] > 0) {
    b <- b + i * ct[i]
    i <- i - 1
  }
  b
}), sep="\n")


library('ForeCA')

args <- commandArgs(trailingOnly = TRUE)
arg_id <- args[1]
arg_cwd <- args[2]

X <- ts(read.csv(sprintf('%s/foreca_omega_input_%s.csv', arg_cwd, arg_id), header=FALSE))
O <- Omega(X, spectrum.control = list(method = "wosa"))
print(O)
M <- matrix(O)

write.matrix(M, sprintf('%s/foreca_omega_result_%s.csv', arg_cwd, arg_id))


#' Function to determine y axis values
#'
#' @param maxval Maximum value of frequency in original data frame
#' @importFrom graphics text
#' @export
freq.axis <- function(maxval) {
    roundto = 100
	roundup <- function(maxval, to = roundto) { to*(maxval%/%to + as.logical(maxval%%to)) }

	scalerange = seq(100,1000,900/(roundup(maxval)/roundto))
	scalelabels = rev(seq(0,roundup(maxval), roundto))

	# show main vertical scale line
	#segments(x0 = -1,
	#		 y0 = 0,
	#		 x1 = -1,
	#		 y1 = 1000,
	#		 col = "black")

	# show ticks
	#segments(x0 = -1,
    #         y0 = scalerange,
    #         x1 = -10,
    #         y1 = scalerange,
    #         col = "black")

	# show axis labels
    text(-10, scalerange, scalelabels, cex = .8)
}


import('../../base/operators')

#' Function to calculate and return a cleaned Cox proportional hazards model
#'
#' @param formula  A formula specifying the relationship between variables
#' @param data     A data.frame, list, or by default the formula env containing vars
#' @param min_pts  Minimum number of points to create a model for
#' @param atomic_class  Variable classes that should not be split by default
#' @return         A data.frame containing the model result
coxph = function(formula, data=environment(formula), min_pts=3, atomic_class='vector') {
    pts = model.frame(formula, data)
    size = lapply(pts, function(x) {
        # could potentially convert to factor first as well
        if (is.logical(x) || is.factor(x) || is.character(x))
            as.list(table(x))
        else
            sum(!(is.na(x) | x==0))
    })
    names(size) = names(pts)

    orig_names = names(size)
    size = unlist(size)
    for (n in orig_names)
        names(size) = sub(paste0(n,"\\."), n, names(size))

    #TODO: should drop covariates if unique, only if nothing left drop regression
    # (and display a warning of what was dropped)
    # also, drop factor levels individually if < min_pts
    if (nrow(pts) < min_pts)
        return(NULL)

	fstr = strsplit(sub("\\+", ",", deparse(formula)), "~")[[1]]
	formula = formula(paste("survival::Surv(", fstr[1], ") ~", fstr[-1]))
	survival::coxph(formula, data) %>%
		broom::tidy() %>%
		cbind(size = sapply(.$term, function(x) size[x]))
#		cbind(size = pts) %catch% NULL #FIXME: there must be a better way to do this
}

if (is.null(module_name())) {
    test1 = list(time=c(4,3,1,1,2,2,3),
                   status=c(1,1,1,0,1,1,0),
                   x=c(0,2,1,1,1,0,0),
                   sex=c(0,0,0,0,1,1,1))

	result = coxph(time + status ~ x + sex, data=test1)
}


# Pull OECD into dataframe
all <- read.csv("~/Dropbox/project/studyguide/data/OECD_CPI_All.csv", header=TRUE)
all <- select(all,LOCATION,Country,TIME,Value)
colnames(all) <- c("isocode","Country","Year","CPIAll")

ener <- read.csv("~/Dropbox/project/studyguide/data/OECD_CPI_Energy.csv", header=TRUE)
ener <- select(ener,LOCATION,Country,TIME,Value)
colnames(ener) <- c("isocode","Country","Year","CPIEnergy")

d <- merge(all,ener,by = c('isocode','Year'))
d$index <- 100
d$diff <- d$CPIAll-d$CPIEnergy

d <- mutate(group_by(d,isocode), cumdiff=rev(cumsum(diff)))
d$relenergy <- exp(d$cumdiff/100)

f <- d[which(d$isocode %in% c("USA","GBR","JPN","KOR","CHL")),]

fig <- plot_ly(f, x = ~Year, y = ~relenergy, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Relative price of energy', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Real energy price (2019=1)'),
              hovermode="x unified")
api_create(fig, filename = "oecd-cpi-energy")

dat = WDI(indicator=c('GDPE' = 'EG.GDP.PUSE.KO.PP.KD',
                      'EGDP'='EG.USE.COMM.GD.PP.KD',
                      'GDPE2'='EG.GDP.PUSE.KO.PP',
                      'EGDP2'='EG.EGY.PRIM.PP.KD',
                      'L' = 'SL.TLF.TOTL.IN',
                      'GDPL'='SL.GDP.PCAP.EM.KD'
                      )
          ,country='all')
dat$ratio <- dat$GDPE/dat$GDPL

f <- dat[which(dat$iso2c %in% c("US","JP","KR","CN","NG","GB")),]
fig <- plot_ly(f, x = ~year, y = ~EGDP, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Energy Intensity', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Energy (kg oil equiv) / GDP'),
              hovermode="x unified")
api_create(fig, filename = "wdi-energy-gdpe")


#################################################################################
#
# Mark Cembrowski, Janelia Research Campus, April 3 2015
#
# This is an extension of cummeRbund's MDS that allows for unmasking or masking
# of specific samples.
#
#################################################################################

# square=F: logical.  Square axes? (ie centred about (0,0)?)
# dims=2: numeric.  Number of dimensions.  Note I've hardcoded this to be either
# 	two or three dimensions.  Any more makes this unwieldly to plot, and
#	an error is thrown if the user tries to do anything other than these two
#	values.
mds <- function(replicates=F,unmask=c(),mask=c(),square=F,dims=2,x='M1',y='M2',
			doFpkm=T){
	if(doFpkm){
		if(replicates){
			theSamples <- colnames(fpkmRepMat)
			dat <- fpkmRepMat
		}else{
			theSamples <- colnames(fpkmPoolMat)
			dat <- fpkmPoolMat
		}
	}else{
		if(replicates){
			theSamples <- colnames(cpmRepMat)
			dat <- cpmRepMat
		}else{
			theSamples <- colnames(cpmPoolMat)
			dat <- cpmPoolMat
		}
	}

	# Check to make sure mask and unmask are not on at the same time.
	if( ( length(mask)*length(unmask) ) > 0.1){
		stop('Cannot select mask and unmask at same time')
	}

	if(length(mask)>0.1){
		isMasked <- vector(length=length(theSamples))*0
		for (ii in 1:length(mask)){
			isMasked <- isMasked + grepl(mask[ii],theSamples)
		}
		isMasked <- isMasked>0.1
		dat <- dat[,!isMasked]
	}
	if(length(unmask)>0.1){
		isUnmasked <- vector(length=length(theSamples))*0
		for (ii in 1:length(unmask)){
			isUnmasked <- isUnmasked + grepl(unmask[ii],theSamples)
		}
		isUnmasked <- isUnmasked>0.1
		dat <- dat[,isUnmasked]
	}

	dat <- log10(dat+1)

	d <- JSdist(makeprobs(dat))
	fit <- cmdscale(d,eig=F,k=dims)
	if(dims==2){
		res <- data.frame(names=rownames(fit),M1=fit[,1],M2=fit[,2])
		gg <- ggplot(res,aes(color=names,label=names))
	        gg <- gg + geom_point(aes(x=M1,y=M2))
		gg <- gg + geom_text(aes(x=M1,y=M2))
	}else{
		if(dims!=3){
			stop('Need either two or three dimensions.')
		}else{
			res <- data.frame(names=rownames(fit),M1=fit[,1],M2=fit[,2],M3=fit[,3])
			gg <- ggplot(res,aes(color=names,label=names))
			gg <- gg + geom_point(aes_string(x=x,y=y))
			gg <- gg + geom_text(aes_string(x=x,y=y))
		}
	}

	maxAxis <- max(fit)*1.1
	gg <- gg + expand_limits(x=c(-maxAxis,maxAxis),y=c(-maxAxis,maxAxis))
	gg <- gg + theme_bw()
	gg <- gg + theme(legend.position='none')
	print(gg)

#	if(square){
#		temp <- ggplot_build(gg)
#		xMax <- max(abs(temp$panel$ranges[[1]]$x.range))
#		yMax <- max(abs(temp$panel$ranges[[1]]$y.range))
#		gg <- gg + xlim(-xMax,xMax)
#		gg <- gg + ylim(-yMax,yMax)
#	}
}


#'@title calcKristCa
#'
#'@description Calculate incremental hull (roughness) resistance coefficient
#'(\code{Ca}) (dimensionless) using the Kristensen method.
#'
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#'Must align with \code{tankerBulkCarrierGCargoShipTypes} and
#' \code{containerShipTypes} groupings
#'@param actualDisplacement Actual loaded displacement (vector of numericals,
#' m^3) (see \code{\link{calcActualDisp}})
#'@param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#'vessels (vector of strings)
#'@param containerShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as container ships (vector of strings)
#'
#'@details
#'Models the effect of realistic hull roughness on resistance, which is not
#'captured in the frictional and residual resistance coefficients from tank
#'towing operations.
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierGCargoShipTypes}, \code{containerShipTypes} grouping
#' parameters to provide these ship type groupings. Any ship types not included
#' in these groupings will be considered as miscellaneous
#'
#'@return \code{Ca} (vector of numericals, dimensionless)
#'
#'@references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \code{\link{calcActualDisp}}
#'
#'@family Kristensen Calculations
#'@family Resistance Calculations
#'
#'@examples
#'calcKristCa(c("bulk.carrier","container.ship"),c(73663.27,216726.45))
#'
#'@export

calcKristCa<-function(shipType,actualDisplacement,
                      tankerBulkCarrierGCargoShipTypes=c("tanker","general.cargo","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                      containerShipTypes=c("container.ship")){

Ca<- ifelse(shipType%in%containerShipTypes,
            (0.5*log10(actualDisplacement)-0.1*(log10(actualDisplacement))^2)/1000,
            ifelse(shipType%in%tankerBulkCarrierGCargoShipTypes,
  (pmax(-0.1, 0.5*log10(actualDisplacement)-0.1*(log10(actualDisplacement))^2))/1000,
  NA
)
)
return(Ca)
}


#' Calculate the gene mean expression Fold Change between all possible combinations of clusters.
#'
#' `pairwise_cluster_fold_change()` returns a list of dataframes containing the pairwise fold changes between all combinations of cluster.
#'
#' This function will perform fold change ratios of mean gene expression between all possible combination of clusters specified on colLabels inside the sc object.
#'
#' @param x Dataframe. Normalized counts containint gene expression.
#' @param comparative Factor. A vector of corresponding cluster for each sample of (x).
#'
#' @return A list of dataframes containing the pairwise fold changes between all combinations of cluster.
#'
#' @export
pairwise_cluster_fold_change <- function(x, clusters){
  divis_funct <- function(x,y) "/"(x,y)
  clusters <- as.factor(clusters)
  i <- split(1:ncol(x), clusters)
  x <- sapply(i, function(i){ rowMeans(x[,i])})
  j <- expand.grid(levels(clusters),levels(clusters))
  j <- t(j[!(j[,1] == j[,2]),])[c(2,1),]
  log.folds <- log2(divis_funct(x[,j[1,]]+1, x[,j[2,]]+1))
  colnames(log.folds) <- paste("logFC",j[1,], j[2,], sep = '.')
  n <- length(levels(clusters))-1
  nr <- ncol(log.folds)
  fc.values <- lapply(split.data.frame(t(log.folds), rep(1:ceiling(nr/n), each=n, length.out=nr)),t)
  return(fc.values)
}


# d: dataset, m: mean, sd: width, a: aplitude
vOrigDeriv = Inf

aApproxDeriv = 0
mApproxDeriv = 0
sdApproxDeriv = 0

dataDeriv <- convolve(data, c(-1,1), type= 'filter')

for (sd in sdTab) {
  for(m in mTab) {
    dnFast <- dnorm(1:length(dataDeriv), mean = m, sd = sd)

    n <- (log2Population - 1):1
    aTabPow <- 2 ** n
    aApproxCur = 2 ** log2Population
    vAtAApproxCur = Inf
    for (a in aTabPow) {
      v <- var(dataDeriv - (dnFast * aApproxCur))
      vAp <- var(dataDeriv - (dnFast * (aApproxCur + a)))
      vAm <- var(dataDeriv - (dnFast * (aApproxCur - a)))

      if (v > vAp && vAm > vAp) {
        aApproxCur = aApproxCur + a
      } else if (v > vAm && vAp > vAm) {
        aApproxCur = aApproxCur - a
      }
      if (v < vAtAApproxCur) {
        aApproxCurMin = aApproxCur
        vAtAApproxCur = v
      }
    }
    if (vAtAApproxCur < vOrigDeriv) {
      sdApproxDeriv = sd
      mApproxDeriv = m
      aApproxDeriv = aApproxCurMin
      vOrigDeriv = vAtAApproxCur
    }
  }
}
print('sdApproxDeriv: ')
print(sdApproxDeriv)
print('mApproxDeriv: ')
print(mApproxDeriv)
print('aApproxDeriv: ')
print(aApproxDeriv)
print('vOrigDeriv: ')
print(vOrigDeriv)


# follow-up exploration of data
library(dplyr)
library(ggplot2)
library(data.table)
library(ggforce)
library(lme4)
library(nlme)
library(plotrix)

pix_to_mm = function(N) {
  #mm between pixels HP Pavilion 23tm
  MMBP = 0.265
  return(MMBP*N)
}

setwd("/Users/adkinsty/Box Sync/LeeLab/Experiments/Exp_files/reaching/new_analyses/")

# Experiment 1
exp1.data = fread("../standard_data/all_standard_test_data5.csv")[,-1] %>%
  select(-c(1,2)) %>% # get rid of initial junk columns
  mutate(rew = rewardVal,
         pen = penaltyVal,
         isPen = ifelse(pen==0,0,1),
         prr = abs(penaltyVal)/rewardVal,
         sep = factor(abs(sepDist),levels=c(32,44)),
         sub = factor(subject),
         x = pix_to_mm(standardPokePosX),
         prev_pen = shift(ifelse(score<0,1,0),1,"right")) %>%
  select(c(x,rew,prr,pen,sep,sub,targetPos,block,prev_pen,isPen))

# sep & prr effects
null = lmer(exp1.data,formula= x ~ sep + (1+prr+sep|sub))
prr  = lmer(exp1.data,formula= x ~ sep + prr + (1+prr+sep|sub)) # prr=penalty:reward
s = anova(null,prr)
sep  = lmer(exp1.data,formula= x ~ sep + (1+isPen|sub))
sep_ef = anova(null,sep)
null2 = lmer(exp1.data,formula= x ~ sep + prr + (1|sub))
intr = lmer(exp1.data,formula= x ~ sep + prr + sep*prr + (1|sub))
intr_ef = anova(null2,intr)
isPen = lmer(exp1.data,formula= x ~ sep + isPen + (1+isPen|sub))

# plot of x ~ sep+prr+sep*prr
pr_dt = exp1.data%>%group_by(sub,prr,sep)%>%
  summarise(x=mean(x,na.rm=TRUE)) %>% group_by(prr,sep) %>%
  summarise(se=std.error(x,na.rm=TRUE),x=mean(x,na.rm=TRUE)) %>%
  mutate(pr=factor(prr,levels=c(0,1,5)))
ggplot(pr_dt,aes(x=pr,y=x,colour=sep,group=sep))+geom_point()+geom_line()+
  geom_errorbar(aes(ymin=x-se,ymax=x+se),width=0.05)

# Experiment 2
exp2.data = fread("../standard_data/all_standard_test_data3.csv")[,-1] %>%
  dplyr::select(-c(1)) %>% # get rid of initial junk columns
  mutate(pen = abs(pen_val),
         sub = subject,
         x = standardPokePosX,
         prev_pen = shift(ifelse(points<0,1,0),1,"right")) %>%
  dplyr::select(pen,sub,x,prev_pen)

# penalty effect
null = lmer(exp2.data,formula= x ~ (1+pen|sub))
pen  = lmer(exp2.data,formula= x ~ pen + (1+pen|sub))
pen_ef = anova(null,pen)
# plot of x ~ pen
pr_dt = exp2.data%>%group_by(sub,pen)%>%
  summarise(x=mean(x,na.rm=TRUE)) %>% group_by(pen) %>%
  summarise(se=std.error(x,na.rm=TRUE),x=mean(x,na.rm=TRUE)) %>%
  mutate(pen=factor(as.character(pen),levels=c("0","-100","-500")))
ggplot(pr_dt,aes(x=pen,y=x))+geom_point()+geom_line()+
  geom_errorbar(aes(ymin=x-se,ymax=x+se),width=0.05)


############ example of file use for CCIEA plotting code ###################

df = data.frame(read.table("ExampleData.csv", header=TRUE, sep=','))
source("PlotTimeSeries.R")
source("QuadPlot_incl_normalize.R")

#plot the time series

par(mfrow=c(2,1))
te = 2
YLIM = c(0.55, 0.75)
PlotTimeSeries(df[df$timeseries=="Simpson diversity - North",], TicsEvery = te, YLIM=YLIM)
PlotTimeSeries(df[df$timeseries=="Simpson diversity - South",], TicsEvery = te, YLIM=YLIM)

# make a quadplot
par(mfrow=c(1,1))
NormalizeAndQuadPlot(df$year, df$index, df$timeseries, 5, PlotLegend = TRUE)


A: 0
B: 3
C: 7
D: 3
E: 5
F: 9
G: 6


library(KernSmooth)
library(akima)
library(glmnet)

denPre2D <- function(edge,classLabel,DataFit,newData,method=c("integers","bandwidth")[2]){

  Index0 <- which(classLabel==0)
  Index1 <- which(classLabel==1)
  x <- DataFit[c(Index0,Index1),edge[1]]
  y <- DataFit[c(Index0,Index1),edge[2]]
  x0 <- newData[,edge[1]]
  y0 <- newData[,edge[2]]
  N <- max(c(x,y))
  coI <- 1:length(Index0)
  caI <- length(Index0)+(1:length(Index1))

  caWidth <- c(bw.nrd0(x[caI]),bw.nrd0(y[caI]))
  coWidth <- c(bw.nrd0(x[coI]),bw.nrd0(y[coI]))
  gridSize <- switch(method,
                     integers  = c(N, N),
                     bandwidth = ceiling(N / c(min(caWidth[1], coWidth[1]),
                                               min(caWidth[2], coWidth[2]))))
  gridSize <- pmax(gridSize,10) # make sure there are at least 100 points in total

  caSmooth <- bkde2D(x=cbind(x[caI], y[caI]), bandwidth=caWidth,  gridsize=gridSize)
  caP <- caSmooth$fhat
  coSmooth <- bkde2D(x=cbind(x[coI], y[coI]), bandwidth=coWidth, gridsize=gridSize)
  coP <- coSmooth$fhat

  # make sure there are no zeros in the smooth function (since we will take a log of that)
  # caP[caP==0] <- min(caP[caP>0])/100
  caP <- pmax(caP, 1e-10)
  # coP[coP==0] <- min(coP[coP>0])/100
  coP <- pmax(coP, 1e-10)

  cafit <- bicubic(x=caSmooth$x1, y=caSmooth$x2, z=caP, x0=x0,y0=y0)
  cofit <- bicubic(x=coSmooth$x1, y=coSmooth$x2, z=coP, x0=x0,y0=y0)
  cafit$z <- pmax(cafit$z, 1e-10)
  cofit$z <- pmax(cofit$z, 1e-10)
  denPre <- log(cafit$z/cofit$z)
  denPre
}

jdinac <- function(EDGE,classLabel,DataFit,DataPre,zFit=NULL,zPre=NULL,nsplit=10,nfolds=5){

  if(missing(DataPre)) {
    DataPre <- DataFit
    zPre <- zFit
  }
  if(!is.null(zFit) & !is.null(zPre)){
    Pre.Z <- jdinac.z(EDGE=EDGE,classLabel=classLabel,DataFit=DataFit,DataPre=DataPre,
                        zFit=zFit,zPre=zPre,nsplit=nsplit,nfolds=nfolds)
    yPre <- Pre.Z$yPre
    Eset <- Pre.Z$Eset
  } else if(nsplit<=0){
    stop("nsplit must be positive integer")
  } else {
    preY <- NULL
    vset <- NULL
    for(i in 1:nsplit){
      size0 <- sum(classLabel==0)
      size1 <- sum(classLabel==1)
      sn0 <- round(size0/2)
      sn1 <- round(size1/2)
      splitid <- c(sample(1:size0,sn0),sample((1:size1)+size0,sn1))

      cLabel <- classLabel[splitid]
      denX <- apply(EDGE,1,denPre2D,classLabel=cLabel,DataFit=DataFit[splitid,],
                    newData=rbind(DataFit[-splitid,],DataPre))
      y <- classLabel[-splitid]
      cv.fit <- cv.glmnet(x=denX[1:length(y),], y=y, family = "binomial", nfolds=nfolds)
      yp <- predict(cv.fit,newx=denX[-(1:length(y)),], s="lambda.min",type="response")
      preY <- cbind(preY,yp)
      coefs <- which(coef(cv.fit,s="lambda.min")[-1] !=0)
      vset <- c(vset,coefs)

      cLabel <- classLabel[-splitid]
      denX <- apply(EDGE,1,denPre2D,classLabel=cLabel,DataFit=DataFit[-splitid,],
                    newData=rbind(DataFit[splitid,],DataPre))
      y <- classLabel[splitid]
      cv.fit <- cv.glmnet(x=denX[1:length(y),], y=y, family = "binomial", nfolds=nfolds)
      yp <- predict(cv.fit,newx=denX[-(1:length(y)),], s="lambda.min",type="response")
      preY <- cbind(preY,yp)
      coefs <- which(coef(cv.fit,s="lambda.min")[-1] !=0)
      vset <- c(vset,coefs)
    }
    yPre <- rowMeans(preY)
    numb <- table(vset)
    Vid <- as.numeric(rownames(numb))
    Eset <- cbind(EDGE[Vid,],numb)
    Eset <- Eset[order(Eset[,3],decreasing=T),]
    colnames(Eset) <- c("row","col","numb")
  }
  list(yPre=yPre,Eset=Eset)
}

jdinac.z <- function(EDGE,classLabel,DataFit,DataPre,zFit,zPre,nsplit=10,nfolds=5){

  if(class(zFit)!="matrix" | class(zPre)!="matrix")
    stop("zFit and zPre must be 'matrix'")
  if(nsplit<=0){
    stop("nsplit must be positive integer")
  } else {
    preY <- NULL
    vset <- NULL
    for(i in 1:nsplit){
      size0 <- sum(classLabel==0)
      size1 <- sum(classLabel==1)
      sn0 <- round(size0/2)
      sn1 <- round(size1/2)
      splitid <- c(sample(1:size0,sn0),sample((1:size1)+size0,sn1))

      cLabel <- classLabel[splitid]
      denX <- apply(EDGE,1,denPre2D,classLabel=cLabel,DataFit=DataFit[splitid,],
                    newData=rbind(DataFit[-splitid,],DataPre))
      y <- classLabel[-splitid]
      zfit <- zFit[-splitid, ,drop=F]
      cv.fit <- cv.glmnet(x=cbind(zfit,denX[1:length(y),]), y=y, family = "binomial", nfolds=nfolds)

      yp <- predict(cv.fit,newx=cbind(zPre,denX[-(1:length(y)),]), s="lambda.min",type="response")
      preY <- cbind(preY,yp)
      coefs <- which(coef(cv.fit,s="lambda.min")[-1] !=0)
      vset <- c(vset,coefs)

      cLabel <- classLabel[-splitid]
      denX <- apply(EDGE,1,denPre2D,classLabel=cLabel,DataFit=DataFit[-splitid,],
                    newData=rbind(DataFit[splitid,],DataPre))
      y <- classLabel[splitid]
      zfit <- zFit[splitid, ,drop=F]
      cv.fit <- cv.glmnet(x=cbind(zfit,denX[1:length(y),]), y=y, family = "binomial", nfolds=nfolds)
      yp <- predict(cv.fit,newx=cbind(zPre,denX[-(1:length(y)),]), s="lambda.min",type="response")
      preY <- cbind(preY,yp)
      coefs <- which(coef(cv.fit,s="lambda.min")[-(1:(1+ncol(zFit)))] !=0)
      vset <- c(vset,coefs)
    }
    yPre <- rowMeans(preY)
    numb <- table(vset)
    Vid <- as.numeric(rownames(numb))
    Eset <- cbind(EDGE[Vid,],numb)
    Eset <- Eset[order(Eset[,3],decreasing=T),]
    colnames(Eset) <- c("row","col","numb")
  }
  list(yPre=yPre,Eset=Eset)
}


#' Generate temporary change outlier regression matrix
#'
#' Generates a regression matrix of TC (temporary change) outliers to be included in weekly modeling routines
#'
#' @param outlier_dates Integer matrix - matrix of dates for TC outliers
#' @param this_week Numeric vector; Week of the year for each observation.
#' @param this_year Numeric vector; Year of each observation.
#' @param forecast Numeric scalar; Number of forecasts. Default: 0.
#' @param air_name Logical scalar; If TRUE, names are formatted as they are in the fractional airline routine;
#'                 otherwise format them as in movereg. Default: TRUE
#' @param this_freq Numeric scalar; frequency of time series. Default: 365.25/7, for a weekly series
#' @param tc_alpha Numeric scalar; Rate of decay for the TC outlier.
#'                 Default: will be computed as in \code{X-13ARIMA-SEATS} for a weekly series
#' @param return_xts Logical scalar; return matrix as an \code{xts} time series object. Default is FALSE.
#'        If TRUE, \code{this_week} and \code{this_year} should be \code{xts} time series objects.
#' @return Generate matrix of temporary change outlier regressors, with column names that describe the individual regressors
#' @examples
#' ic_tc_dates <-
#'    matrix(c(13, 2020), ncol=2, byrow=TRUE)
#' ic_tc_matrix <-
#'    gen_level_outlier_matrix(ic_tc_dates, ic_week, ic_year, 0,
#'                             return_xts = FALSE)
#' cc_tc_dates <-
#'    matrix(c(13, 2020), ncol=2, byrow=TRUE)
#' cc_tc_matrix_xts <-
#'    gen_level_outlier_matrix(cc_tc_dates, cc_week_xts, cc_year_xts, 0,
#'                             return_xts = TRUE)
#' @import stats
#' @export
gen_tc_outlier_matrix <- function(outlier_dates, this_week, this_year, forecast = 0, air_name = TRUE, this_freq = NULL,
                                  tc_alpha = NULL, return_xts = FALSE) {
    # Author: Brian C. Monsell (OEUS), Version 2.2, 3/14/2022

    # Set number of outliers, length of outlier regressors
    num_otlr <- nrow(outlier_dates)
    len_otlr <- length(this_week) + forecast

    # If \code{tc_alpha} is not set, compute as in \code{X-13ARIMA-SEATS}
    if (is.null(this_freq)) {
        this_freq <- 365.25 / 7
    }
    if (is.null(tc_alpha)) {
        tc_alpha <- 0.7^(12/this_freq)
    }

    # Inititalize outlier matrix to 0
    outlier_matrix <- matrix(0, ncol = num_otlr, nrow = len_otlr)

    # for each outlier, create a filter indicating which observation matches the outlier date and set
    # that observation to one in column i of the outlier matrix
    for (i in 1:num_otlr) {
        this_filter <- (this_week == outlier_dates[i, 1]) & (this_year == outlier_dates[i, 2])

        # Inititalize \code{this_obs} and \code{this_pos}
        this_obs <- 0
        this_pos <- len_otlr + 1

        for (j in 1:len_otlr) {
            # Update \code{this_obs} and \code{this_pos} at date of TC outlier for observation j
            if (this_filter[j]) {
                this_obs <- 1
                this_pos <- j
            }

            # Set observation j based on whether it is before or after the outlier date
            if (j > this_pos) {
                outlier_matrix[j, i] <- outlier_matrix[j - 1, i] * tc_alpha
            } else {
                outlier_matrix[j, i] <- this_obs
            }
        }
    }

    # Generate outlier names, set column names of outlier matrix to outlier names
    if (air_name) {
        outlier_names <- paste0("TC(week ", outlier_dates[, 1], ", ", outlier_dates[, 2], ")")
    } else {
        outlier_names <- paste("TC week", outlier_dates[, 1], outlier_dates[, 2])
    }
    colnames(outlier_matrix) <- outlier_names

    # return outlier matrix
    if (return_xts) {
       outlier_matrix_xts <-
          xts::xts(x = outlier_matrix,
                   order.by = as.Date(zoo::index(this_week), origin = "1970-01-01"))
       return(outlier_matrix_xts)
    } else {
       return(outlier_matrix)
    }
}


x <- seq(-10, 10, length = 30)
y <- x
ff <- function(x,y) { r <- sqrt(x^2 + y^2); 10 * sin(r) / r }
z <- outer(x, y, ff)
z[is.na(z)] <- 1
for (i in 1:3) {
  persp(x, y, z, phi = 30 + i * 10, theta = 30)
}


aux_step03_Weight_of_Norm_matrix <-function(inMatrix, inWeight){

  outMat <- inMatrix
  ncols<-dim(inMatrix)[2]
  nrows<-dim(inMatrix)[1]

  #iMcalc2 <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)
  iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

  nC <- dim(iMcalc)[2] # Convert weigths into a matrix in order to perform Mult
  aMmul <- matrix(rep(inWeight, times=nrows), ncol=nC, byrow=TRUE)

  auxCalc <- iMcalc * aMmul

  outMat[,2:ncols]<-auxCalc

  return(outMat)
}

#'
#' @param Matrices with Benefits and Costs,
#' @param Vectors with Benefits and Costs weights,
#' @return Score of Paths
#' @author Bruno Sousa
#' @note v1.0 no arguments validation
#' @title METH_runTOPSIS
#' @name METH_runTOPSIS
METH_runTOPSIS <- function(iMBen, iMCost, iVecBen,iVecCost ){
  # Important Global Variables
  MIN_COST_TOPSIS_TENDENCY <- 0.0001  # To avoid divisions by zero
  BETA_TOPSIS_TENDENCY_WEIGHTS <- 0.5
  MINSUM_TOPSIS <- 1e-99 # To avoid divisions by zero in normalization

  #source("libNormalization.R")

  mBen_Criteria <- iMBen
  mCost_Criteria <- iMCost

  vBen_weight <- iVecBen
  vCost_weight <- iVecCost

  # Euclidean Distance
  fAux_Euclidean_Dist<- function(i1, i2){
    adif <- (i1 - i2)^2

    return(adif)
  }

  #
  # Convert weight costs into Benefit costs
  #
  aux_step01_Tendency_Cnv <- function(inCosts){
    nCol <- dim(inCosts)[2]
    aux <- matrix(inCosts[,2:nCol], ncol=nCol-1)

    aux[which(aux==0) ] <- MIN_COST_TOPSIS_TENDENCY
    aux <- 1/aux

    return (aux)
  }

  #
  # Append Benefits and Cost weigths
  #
  aux_step01_Tendend_Weigths <- function(inWeBen, inWeCost){

    ret_Ben  <-    BETA_TOPSIS_TENDENCY_WEIGHTS * inWeBen
    ret_Cost <- (1 - BETA_TOPSIS_TENDENCY_WEIGHTS) * inWeCost

    ret_ <- c(ret_Ben, ret_Cost)

    return(ret_)
  }

  #
  # Normalize matrix
  # Using Vector normalization instead of min-max
  #
  aux_step02_Normalization <- function(inMatrix){

    #internal function to help in normalization
    fSum <- function(i){
      sumrow <- MINSUM_TOPSIS
      aSu <- sum(i^2) + sumrow
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)

    #Apply Sum by col
    auxSum <- apply(iMcalc, 2, FUN=fSum)

    nC <- dim(iMcalc)[2]
    aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    auxCalc <- iMcalc / sqrt(aMSum)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  #
  # Determine PIS according to DiA Method
  #
  aux_step04_PIS <-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, max)
    return (auxRet)
  }

  aux_step04_NIS<-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, min)
    return (auxRet)
  }

  #
  # Determine the distance to the ideal points (PIS and NIS)
  #
  aux_step05_distance_to_ideal <- function(inApos,  inMatrix){
    #Be careful with the idx of Ideal....
    ncols<- dim(inMatrix)[2]
    nrows<- dim(inMatrix)[1]

    auxMBenef <- matrix(ncol=2,nrow=nrows)
    auxMBenef[,1] <- inMatrix[,1]

    mCalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

    for (nR in seq(from=1, to=nrows)){
      aSumBen <- 0
      for (nC in seq(from=1, to=ncol(mCalc))){
        aSumBen <- aSumBen + fAux_Euclidean_Dist(mCalc[nR, nC] , inApos[nC])
      }
      auxMBenef[nR,2] <- aSumBen
    }

    ret_ <- auxMBenef
    return (ret_)
  }

  #
  # Determine R score
  #
  aux_step06_Ranking<-function(inSepPos, inSepNeg){

    nRow <- dim(inSepPos)[1]
    nCol <- dim(inSepPos)[2]
    auxCi <- matrix(ncol=2, nrow=nRow)
    auxCi[,1] <- inSepPos[,1]
    mCalc <- matrix(c(inSepPos[,2], inSepNeg[,2]), ncol=2, nrow=nRow, byrow=FALSE)

    fDist <- function(i){ # Apply a function on pairwise columns
      ipos <- mCalc[i,1]
      ineg <- mCalc[i,2]
      auxCj <- ineg / (ipos + ineg)
      return (auxCj)
    }

    # dist
    aDist <- sapply(1:nrow(mCalc), fDist)
    auxCi[,2] <- aDist
    return(auxCi)
  }

  ncolMB <- dim(mBen_Criteria)[2]
  TPSTOPsisBenefits <- as.matrix(mBen_Criteria )

  ncolMC <- dim(mCost_Criteria)[2]
  TPSTOPsisCosts <- as.matrix(mCost_Criteria )

  TPSWeiBenTOP <- vBen_weight
  TPSWeiCostTOP <- vCost_weight

  #
  # Step 01
  #
  TPSTOPsisCostsTended <- aux_step01_Tendency_Cnv(TPSTOPsisCosts)
  TPSWeiBenTOPall <- aux_step01_Tendend_Weigths(TPSWeiBenTOP, TPSWeiCostTOP)
  TPSTOPsisBenefits <- cbind(TPSTOPsisBenefits, TPSTOPsisCostsTended)
  TPSWeiBenTOP <- TPSWeiBenTOPall
  stopifnot(TPSTOPsisBenefits != NULL)

  #
  # Step 02
  #
  TPSTOPsisBenefitsTOP <- aux_step02_Normalization(TPSTOPsisBenefits)

  #
  # Step 03
  #
  TPSTOPsisBenefitsTOP <- aux_step03_Weight_of_Norm_matrix(TPSTOPsisBenefitsTOP, TPSWeiBenTOP)

  # Step 04 - Ideal Solutions
  TPSApos_Dia <- aux_step04_PIS(TPSTOPsisBenefitsTOP)
  TPSAneg_Dia <- aux_step04_NIS(TPSTOPsisBenefitsTOP)

  # Step 05 - Distance to Ideal
  TPSDposBen_Dia <- aux_step05_distance_to_ideal(TPSApos_Dia, TPSTOPsisBenefitsTOP )
  TPSDnegBen_Dia <- aux_step05_distance_to_ideal(TPSAneg_Dia, TPSTOPsisBenefitsTOP)

  #Step 06
  #RdistBen_Dia  <- aux_step06_Rscore(DposBen_Dia, DnegBen_Dia)
  TPStopsisRanking <- aux_step06_Ranking(TPSDposBen_Dia, TPSDnegBen_Dia)
  #TPStopsisRanking

  #print(TPStopsisRanking)
  return(TPStopsisRanking[order(TPStopsisRanking[,2]),])
}

#'
#' @param Matrices with Benefits and Costs,
#' @param Vectors with Benefits and Costs weights,
#' @return Score of Paths
#' @author Bruno Sousa
#' @note v1.0 no arguments validation
#' @title METH_runDiA
#' @name METH_runDiA
METH_runDiA <- function(iMBen, iMCost, iVecBen,iVecCost ){
  # Important Global Variables
  MIN_COST_TOPSIS_TENDENCY <- 0.0001  # To avoid divisions by zero
  BETA_TOPSIS_TENDENCY_WEIGHTS <- 0.5
  MINSUM_TOPSIS <- 1e-99 # To avoid divisions by zero in normalization

  #source("libNormalization.R")

  mBen_Criteria <- iMBen
  mCost_Criteria <- iMCost

  vBen_weight <- iVecBen
  vCost_weight <- iVecCost

  #
  # Convert weight costs into Benefit costs
  #
  aux_step01_Tendency_Cnv <- function(inCosts){
    nCol <- dim(inCosts)[2]
    aux <- matrix(inCosts[,2:nCol], ncol=nCol-1)

    aux[which(aux==0) ] <- MIN_COST_TOPSIS_TENDENCY
    aux <- 1/aux

    return (aux)
  }

  #
  # Append Benefits and Cost weigths
  #
  aux_step01_Tendend_Weigths <- function(inWeBen, inWeCost){

    ret_Ben  <-    BETA_TOPSIS_TENDENCY_WEIGHTS * inWeBen
    ret_Cost <- (1 - BETA_TOPSIS_TENDENCY_WEIGHTS) * inWeCost

    ret_ <- c(ret_Ben, ret_Cost)

    return(ret_)
  }

  #
  # Normalize matrix
  # Using Vector normalization instead of min-max
  #
  aux_step02_Normalization <- function(inMatrix){

    #internal function to help in normalization
    fSum <- function(i){
      sumrow <- MINSUM_TOPSIS
      aSu <- sum(i^2) + sumrow
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)

    #Apply Sum by col
    auxSum <- apply(iMcalc, 2, FUN=fSum)

    nC <- dim(iMcalc)[2]
    aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    auxCalc <- iMcalc / sqrt(aMSum)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  #
  # Determine PIS according to DiA Method
  #
  aux_step04_PIS <-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, max)
    return (auxRet)
  }

  aux_step04_NIS<-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, min)
    return (auxRet)
  }

  #
  # Determine the distance to the ideal points (PIS and NIS)
  #
  aux_step05_distance_to_ideal <- function(inApos,  inMatrix){
    #Be careful with the idx of Ideal....
    ncols<- dim(inMatrix)[2]
    nrows<- dim(inMatrix)[1]

    auxMBenef <- matrix(ncol=2,nrow=nrows)
    auxMBenef[,1] <- inMatrix[,1]

    mCalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)
    #internal fx
    fAux_Positive_Dif <- function(i1, i2){
      adif <- (i1 - i2)
      if (adif < 0) {
        adif <- adif * (-1)
      }
      return(adif)
    }

    for (nR in seq(from=1, to=nrows)){
      aSumBen <- 0
      for (nC in seq(from=1, to=ncol(mCalc))){
        aSumBen <- aSumBen + fAux_Positive_Dif(mCalc[nR, nC] , inApos[nC])
      }
      auxMBenef[nR,2] <- aSumBen
    }

    ret_ <- auxMBenef
    return (ret_)
  }

  #
  # Determine R score
  #
  aux_step06_Rscore<-function(inSepPos, inSepNeg){

    nRow <- dim(inSepPos)[1]
    nCol <- dim(inSepPos)[2]
    auxCi <- matrix(ncol=2, nrow=nRow)
    auxCi[,1] <- inSepPos[,1]
    mCalc <- matrix(c(inSepPos[,2], inSepNeg[,2]), ncol=2, nrow=nRow, byrow=FALSE)

    # get ideal point
    PIA_pos <- min(inSepPos[,2])
    PIA_neg <- max(inSepNeg[,2])

    fDist <- function(i){ # Apply a function on pairwise columns
      ipos <- mCalc[i,1]
      ineg <- mCalc[i,2]
      auxSqrt <- sqrt( (ipos - PIA_pos)^2 + (ineg - PIA_neg)^2 )
      return (auxSqrt)
    }

    # dist
    aDist <- sapply(1:nrow(mCalc), fDist)
    auxCi[,2] <- aDist
    return(auxCi)
  }

  ncolMB <- dim(mBen_Criteria)[2]
  DiATOPsisBenefits <- as.matrix(mBen_Criteria )

  ncolMC <- dim(mCost_Criteria)[2]
  DiATOPsisCosts <- as.matrix(mCost_Criteria )

  DiAWeiBenTOP <- vBen_weight
  DiAWeiCostTOP <- vCost_weight

  #
  # Step 01
  #
  DiATOPsisCostsTended <- aux_step01_Tendency_Cnv(DiATOPsisCosts)
  DiAWeiBenTOPall <- aux_step01_Tendend_Weigths(DiAWeiBenTOP, DiAWeiCostTOP)
  DiATOPsisBenefits <- cbind(DiATOPsisBenefits, DiATOPsisCostsTended)
  DiAWeiBenTOP <- DiAWeiBenTOPall
  stopifnot(DiATOPsisBenefits != NULL)

  #
  # Step 02
  #
  DiATOPsisBenefitsTOP <- aux_step02_Normalization(DiATOPsisBenefits)
  DiATOPsisBenefitsTOPNorm <- DiATOPsisBenefitsTOP

  #
  # Step 03
  #
  DiATOPsisBenefitsTOP <- aux_step03_Weight_of_Norm_matrix(DiATOPsisBenefitsTOP, DiAWeiBenTOP)

  # Step 04
  DiAApos_Dia <- aux_step04_PIS(DiATOPsisBenefitsTOP)
  DiAAneg_Dia <- aux_step04_NIS(DiATOPsisBenefitsTOP)

  # Step 05
  DiADposBen_Dia <- aux_step05_distance_to_ideal(DiAApos_Dia, DiATOPsisBenefitsTOP )
  DiADnegBen_Dia <- aux_step05_distance_to_ideal(DiAAneg_Dia, DiATOPsisBenefitsTOP)

  #Step 06
  DiARdistBen_Dia  <- aux_step06_Rscore(DiADposBen_Dia, DiADnegBen_Dia)
  #DiARdistBen_Dia

  #print(DiARdistBen_Dia)
  return(DiARdistBen_Dia[order(DiARdistBen_Dia[,2]),])

}

#'
#' @param Matrices with Benefits and Costs,
#' @param Vectors with Benefits and Costs weights,
#' @return Score of Paths
#' @author Bruno Sousa
#' @note v1.0 no arguments validation
#' @title METH_runNMMD
#' @name METH_runNMMD
METH_runNMMD <- function(iMBen, iMCost, iVecBen,iVecCost ){
  require("corpcor")
  require("HDMD")

  # Important Global Variables
  MIN_COST_TOPSIS_TENDENCY <- 0.0001  # To avoid divisions by zero
  BETA_TOPSIS_TENDENCY_WEIGHTS <- 0.5
  MINSUM_TOPSIS <- 1e-99 # To avoid divisions by zero in normalization

  #source("libNormalization.R")

  mBen_Criteria <- iMBen
  mCost_Criteria <- iMCost

  vBen_weight <- iVecBen
  vCost_weight <- iVecCost

  # Function to check if Mahalanobis can be processed
  # This is to avoid errors on singular matrices.
  # TODO: need to understand why this can happen
  #
  # TODO2: Need a positive definite matrix... Probably due to the fact of having few data
  #        Some useful urls:
  #        http://www.r-bloggers.com/dealing-with-non-positive-definite-matrices-in-r/
  #   http://www2.gsu.edu/~mkteer/npdmatri.html
  fAux_Do_Mahalanobis <- function(iM){
    ret <- TRUE
    #auxCov  <- cov(iM)
    auxCov2 <- cov.shrink(iM,verbose=FALSE)

    #if (det(auxCov)==0){ ret <- FALSE }
    if (!is.positive.definite(auxCov2)){
      ret <- FALSE
    }
    return (ret)
  }

  #Mahalanobis Distance
  fAux_Mahalanobis_Dist <- function(iM, me=NULL){

    if (length(me)==0){
      auxMean <- apply(iM, 2, mean)
    }else{
      auxMean <- me
    }
    #auxCov  <- cov(iM)
    auxCov  <- cov.shrink(iM, verbose=FALSE)

    # To avoid errors
    if (fAux_Do_Mahalanobis(iM)){
      #print(paste("doing Maha for"  ))
      #print(iM)
      #print(auxCov)
      #print(det(auxCov))
      auxDistMaha <- mahalanobis(iM, auxMean, auxCov)
      return (auxDistMaha)
    }else{
      return (-1)
    }
  }

  myPairwise.mahalanobis <- function (x, grouping = NULL, cov = NULL, inverted = FALSE, digits = 5, ...)
  {
    x <- if (is.vector(x))
      matrix(x, ncol = length(x))
    else as.matrix(x)
    if (!is.matrix(x))
      stop("x could not be forced into a matrix")
    if (length(grouping) == 0) {
      grouping = t(x[1])
      x = x[2:dim(x)[2]]
      cat("assigning grouping\n")
      print(grouping)
    }
    n <- nrow(x)
    p <- ncol(x)
    if (n != length(grouping)) {
      cat(paste("n: ", n, "and groups: ", length(grouping),
                "\n"))
      stop("nrow(x) and length(grouping) are different")
    }
    g <- as.factor(grouping)
    g
    lev <- lev1 <- levels(g)
    counts <- as.vector(table(g))
    if (any(counts == 0)) {
      empty <- lev[counts == 0]
      warning(sprintf(ngettext(length(empty), "group %s is empty",
                               "groups %s are empty"), paste(empty, collapse = " ")),
              domain = NA)
      lev1 <- lev[counts > 0]
      g <- factor(g, levels = lev1)
      counts <- as.vector(table(g))
    }
    ng = length(lev1)
    group.means <- tapply(x, list(rep(g, p), col(x)), mean)
    if (missing(cov)) {
      inverted = FALSE
      cov = cor(x)
    }
    else {
      if (dim(cov)[1] != p && dim(cov)[2] != p)
        stop("cov matrix not of dim = (p,p)\n")
    }
    Distance = matrix(nrow = ng, ncol = ng)
    dimnames(Distance) = list(names(group.means), names(group.means))
    Means = round(group.means, digits)
    Cov = round(cov, digits)
    Distance = round(Distance, digits)
    for (i in 1:ng) {
      Distance[i, ] = mahalanobis(group.means, group.means[i,], cov, inverted)
    }
    result <- list(means = group.means, cov = cov, distance = Distance)
    result
  }

  #Mahalanobis Distance
  fAux_Pairwise.Mahalanobis_Dist <- function(iM, me=NULL){

    if (length(me)==0){
      auxMean <- apply(iM, 2, mean)
    }else{
      auxMean <- me
    }
    #auxCov  <- cov(iM)
    auxCov  <- cov.shrink(iM, verbose=FALSE)

    # To avoid errors
    if (fAux_Do_Mahalanobis(iM)){
      #print(paste("doing Maha for"  ))
      #print(iM)
      #print(det(auxCov))
      #print(ncol(iM))
      #auxDistMaha <- pairwise.mahalanobis(iM, grouping=t(iM[,1]), digits=5, center=auxMean, cov=auxCov)
      auxDistMaha <- myPairwise.mahalanobis(iM, grouping=t(iM[,1]), digits=5, center=auxMean, cov=auxCov)
      return (auxDistMaha)
    }else{
      return (-1)
    }
  }

  #
  # Convert weight costs into Benefit costs
  #
  aux_step01_Tendency_Cnv <- function(inCosts){
    nCol <- dim(inCosts)[2]
    aux <- matrix(inCosts[,2:nCol], ncol=nCol-1)

    aux[which(aux==0) ] <- MIN_COST_TOPSIS_TENDENCY
    aux <- 1/aux

    return (aux)
  }

  #
  # Append Benefits and Cost weigths
  #
  aux_step01_Tendend_Weigths <- function(inWeBen, inWeCost){

    ret_Ben  <-    BETA_TOPSIS_TENDENCY_WEIGHTS * inWeBen
    ret_Cost <- (1 - BETA_TOPSIS_TENDENCY_WEIGHTS) * inWeCost

    ret_ <- c(ret_Ben, ret_Cost)

    return(ret_)
  }

  #
  # Normalize matrix
  # Using Vector normalization instead of min-max
  #
  aux_step02_Normalization <- function(inMatrix){

    #internal function to help in normalization
    fSum <- function(i){
      sumrow <- MINSUM_TOPSIS
      aSu <- sum(i^2) + sumrow
      return(aSu)
    }

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)

    #Apply Sum by col
    auxSum <- apply(iMcalc, 2, FUN=fSum)

    nC <- dim(iMcalc)[2]
    aMSum <- matrix(rep(auxSum, times=nrows), ncol=nC, byrow=TRUE)
    auxCalc <- iMcalc / sqrt(aMSum)

    outMat[,2:ncols]<-auxCalc
    return(outMat)

  }

  #
  # Weight the normalized matrix, by multiplying each value by its weight
  #
  aux_step03_Weight_of_Norm_matrix <-function(inMatrix, inWeight){

    outMat <- inMatrix
    ncols<-dim(inMatrix)[2]
    nrows<-dim(inMatrix)[1]

    iMcalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=TRUE)

    nC <- dim(iMcalc)[2] # Convert weigths into a matrix in order to perform Mult
    aMmul <- matrix(rep(inWeight, times=nrows), ncol=nC, byrow=TRUE)

    auxCalc <- iMcalc * aMmul

    outMat[,2:ncols]<-auxCalc

    return(outMat)
  }

  #
  # Determine PIS according to DiA Method
  #
  aux_step04_PIS <-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, max)
    return (auxRet)
  }

  aux_step04_NIS<-function(inM){
    ncolu <- dim(inM)[2]
    nrows <- dim(inM)[1]
    iMcalc <- matrix(inM[,2:ncolu], nrow=nrows, ncol=ncolu-1, byrow=TRUE)
    auxRet <- apply(iMcalc, 2, min)
    return (auxRet)
  }

  #
  # Determine the distance to the ideal points (PIS and NIS)
  #
  aux_step05_distance_to_idealNMMD <- function(inMatrix){
    #Be careful with the idx of Ideal....
    ncols<- dim(inMatrix)[2]
    nrows<- dim(inMatrix)[1]

    #auxMBenef <- matrix(ncol=2,nrow=nrows)
    #auxMBenef[,1] <- inMatrix[,1]

    mCalc <- matrix(inMatrix[,2:ncols], nrow=nrows, ncol=ncols-1, byrow=FALSE)

    auxMBenef <- fAux_Pairwise.Mahalanobis_Dist(mCalc, colMeans(mCalc))

    ret_ <- auxMBenef
    return (ret_)
  }

  #
  # Determine R score
  #
  aux_step06_RankingNMMD<-function(inPathsIDs, inDist ){

    nRow <- dim(inDist)[1]
    nCol <- dim(inDist)[2]
    auxCi <- matrix(ncol=nCol, nrow=nRow)
    #auxCi[,1] <- 1:nRow
    auxCi[,1] <- inPathsIDs
    mCalc <- inDist

    fDist <- function(i){ # Apply a function on pairwise columns
      auxCj <- sum(mCalc[i,]) / (ncol(mCalc))
      return (auxCj)
    }

    # dist
    aDist <- sapply(1:nrow(mCalc), fDist)
    auxCi[,2] <- aDist
    return(auxCi)
  }

  ncolMB <- dim(mBen_Criteria)[2]
  NMMDTOPsisBenefits <- as.matrix(mBen_Criteria )

  ncolMC <- dim(mCost_Criteria)[2]
  NMMDTOPsisCosts <- as.matrix(mCost_Criteria )

  NMMDWeiBenTOP <- vBen_weight
  NMMDWeiCostTOP <- vCost_weight

  #
  # Step 01
  #

  #Keep Path Ids
  NMMD_PATHIds <- mBen_Criteria[,1]

  NMMDTOPsisCostsTended <- aux_step01_Tendency_Cnv(NMMDTOPsisCosts)
  NMMDWeiBenTOPall <- aux_step01_Tendend_Weigths(NMMDWeiBenTOP, NMMDWeiCostTOP)
  NMMDTOPsisBenefits <- cbind(NMMDTOPsisBenefits, NMMDTOPsisCostsTended)
  NMMDWeiBenTOP <- NMMDWeiBenTOPall
  stopifnot(NMMDTOPsisBenefits != NULL)

  #
  # Step 02
  #
  #naCol <- dim(NMMDTOPsisBenefits)[2]
  #print(NMMDTOPsisBenefits[,2:naCol])
  #if (!fAux_Do_Mahalanobis(NMMDTOPsisBenefits[,2:naCol])){
  #	print("Doing Normalization")
  NMMDTOPsisBenefitsTOP <- aux_step02_Normalization(NMMDTOPsisBenefits)
  #}

  #
  # Step 03
  #
  NMMDTOPsisBenefitsTOP <- aux_step03_Weight_of_Norm_matrix(NMMDTOPsisBenefitsTOP, NMMDWeiBenTOP)

  # Step 04 - Ideal Solutions

  # Step 05 - Distance to Ideal

  NMMDDistBen_Dia <- aux_step05_distance_to_idealNMMD( NMMDTOPsisBenefitsTOP)

  #Step 06

  NMMDtopsisRanking <- aux_step06_RankingNMMD(NMMD_PATHIds, NMMDDistBen_Dia$distance)
  #NMMDtopsisRanking

  #print(NMMDtopsisRanking)
  #print("NMMD")
  #print(NMMDtopsisRanking[order(-NMMDtopsisRanking[,2])])
  #print("\n")
  return(NMMDtopsisRanking[order(-NMMDtopsisRanking[,2]),])

}