ggbiplotedited <- function (pcobj, choices = 1:2, scale = 1, pc.biplot = TRUE,
                            obs.scale = 1 - scale, var.scale = scale, groups = NULL,
                            ellipse = FALSE, ellipse.prob = 0.68, labels = NULL, labels.size = 3,
                            alpha = 1, var.axes = TRUE, circle = FALSE, circle.prob = 0.69,
                            varname.size = 3, varname.adjust = 1.5, varname.abbrev = FALSE,
                            ...)
{
  library(ggplot2)
  library(plyr)
  library(scales)
  library(grid)
  stopifnot(length(choices) == 2)
  if (inherits(pcobj, "prcomp")) {
    nobs.factor <- sqrt(nrow(pcobj$x) - 1)
    d <- pcobj$sdev
    u <- sweep(pcobj$x, 2, 1/(d * nobs.factor), FUN = "*")
    v <- pcobj$rotation
  }
  else if (inherits(pcobj, "princomp")) {
    nobs.factor <- sqrt(pcobj$n.obs)
    d <- pcobj$sdev
    u <- sweep(pcobj$scores, 2, 1/(d * nobs.factor), FUN = "*")
    v <- pcobj$loadings
  }
  else if (inherits(pcobj, "PCA")) {
    nobs.factor <- sqrt(nrow(pcobj$call$X))
    d <- unlist(sqrt(pcobj$eig)[1])
    u <- sweep(pcobj$ind$coord, 2, 1/(d * nobs.factor),
               FUN = "*")
    v <- sweep(pcobj$var$coord, 2, sqrt(pcobj$eig[1:ncol(pcobj$var$coord),
                                                  1]), FUN = "/")
  }
  else if (inherits(pcobj, "lda")) {
    nobs.factor <- sqrt(pcobj$N)
    d <- pcobj$svd
    u <- predict(pcobj)$x/nobs.factor
    v <- pcobj$scaling
    d.total <- sum(d^2)
  }
  else {
    stop("Expected a object of class prcomp, princomp, PCA, or lda")
  }
  choices <- pmin(choices, ncol(u))
  df.u <- as.data.frame(sweep(u[, choices], 2, d[choices]^obs.scale,
                              FUN = "*"))
  v <- sweep(v, 2, d^var.scale, FUN = "*")
  df.v <- as.data.frame(v[, choices])
  names(df.u) <- c("xvar", "yvar")
  names(df.v) <- names(df.u)
  if (pc.biplot) {
    df.u <- df.u * nobs.factor
  }
  r <- sqrt(qchisq(circle.prob, df = 2)) * prod(colMeans(df.u^2))^(1/4)
  v.scale <- rowSums(v^2)
  df.v <- r * df.v/sqrt(max(v.scale))
  if (obs.scale == 0) {
    u.axis.labs <- paste("standardized PC", choices, sep = "")
  }
  else {
    u.axis.labs <- paste("PC", choices, sep = "")
  }
  u.axis.labs <- paste(u.axis.labs, sprintf("(%0.1f%% explained var.)",
                                            100 * pcobj$sdev[choices]^2/sum(pcobj$sdev^2)))
  if (!is.null(labels)) {
    df.u$labels <- labels
  }
  if (!is.null(groups)) {
    df.u$groups <- groups
  }
  if (varname.abbrev) {
    df.v$varname <- abbreviate(rownames(v))
  }
  else {
    df.v$varname <- rownames(v)
  }
  df.v$angle <- with(df.v, (180/pi) * atan(yvar/xvar))
  df.v$hjust = with(df.v, (1 - varname.adjust * sign(xvar))/2)
  g <- ggplot(data = df.u, aes(x = xvar, y = yvar)) + xlab(u.axis.labs[1]) +
    ylab(u.axis.labs[2]) + coord_equal()

  if (!is.null(df.u$groups)) {
    g <- g + geom_point(aes(color = groups), alpha = 0.1)
  }
  else {
    g <- g + geom_point(alpha = 0.1)
  }
  if (var.axes) {
    if (circle) {
      theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi,
                                                length = 50))
      circle <- data.frame(xvar = r * cos(theta), yvar = r *
                             sin(theta))
      g <- g + geom_path(data = circle, color = muted("white"),
                         size = 1/2, alpha = 1/3)
    }
    g <- g + geom_segment(data = df.v, aes(x = 0, y = 0,
                                           xend = xvar, yend = yvar), arrow = arrow(length = unit(1/2,
                                                                                "picas")), color = "black", size = 1.5)
  }
  if (!is.null(df.u$labels)) {
    if (!is.null(df.u$groups)) {
      g <- g + geom_text(aes(label = labels, color = groups),
                         size = labels.size, color = 'black', fontface = 'bold')
    }
    else {
      g <- g + geom_text(aes(label = labels), size = labels.size, color = 'black', fontface = 'bold')
    }
  }
  if (!is.null(df.u$groups) && ellipse) {
    theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi, length = 50))
    circle <- cbind(cos(theta), sin(theta))
    ell <- ddply(df.u, "groups", function(x) {
      if (nrow(x) <= 2) {
        return(NULL)
      }
      sigma <- var(cbind(x$xvar, x$yvar))
      mu <- c(mean(x$xvar), mean(x$yvar))
      ed <- sqrt(qchisq(ellipse.prob, df = 2))
      data.frame(sweep(circle %*% chol(sigma) * ed, 2,
                       mu, FUN = "+"), groups = x$groups[1])
    })
    names(ell)[1:2] <- c("xvar", "yvar")
    g <- g + geom_path(data = ell, aes(color = groups, group = groups))
  }
  if (var.axes) {
    g <- g + geom_text(data = df.v, aes(label = varname,
                                        x = xvar, y = yvar, angle = angle, hjust = hjust),
                       color = "black", size = varname.size, fontface='bold')
  }
  return(g)
}


library(shiny)

renderInputs <- function(prefix) {
  wellPanel(
    fluidRow(
      column(6,
        sliderInput(paste0(prefix, "_", "n_obs"), "Number of observations (in Years):", min = 0, max = 40, value = 20),
        sliderInput(paste0(prefix, "_", "start_capital"), "Initial capital invested :", min = 100000, max = 10000000, value = 2000000, step = 100000, pre = "$", sep = ","),
        sliderInput(paste0(prefix, "_", "annual_mean_return"), "Annual investment return (in %):", min = 0.0, max = 30.0, value = 5.0, step = 0.5),
        sliderInput(paste0(prefix, "_", "annual_ret_std_dev"), "Annual investment volatility (in %):", min = 0.0, max = 25.0, value = 7.0, step = 0.1)
      ),
      column(6,
        sliderInput(paste0(prefix, "_", "annual_inflation"), "Annual inflation (in %):", min = 0, max = 20, value = 2.5, step = 0.1),
        sliderInput(paste0(prefix, "_", "annual_inf_std_dev"), "Annual inflation volatility. (in %):", min = 0.0, max = 5.0, value = 1.5, step = 0.05),
        sliderInput(paste0(prefix, "_", "monthly_withdrawals"), "Monthly capital withdrawals:", min = 1000, max = 100000, value = 10000, step = 1000, pre = "$", sep = ","),
        sliderInput(paste0(prefix, "_", "n_sim"), "Number of simulations:", min = 0, max = 2000, value = 200)
      )
    ),
    p(actionButton(paste0(prefix, "_", "recalc"),
      "Re-run simulation", icon("random")
    ))
  )
}

# Define UI for application that plots random distributions
fluidPage(theme="simplex.min.css",
  tags$style(type="text/css",
    "label {font-size: 12px;}",
    ".recalculating {opacity: 1.0;}"
  ),

  # Application title
  tags$h2("Retirement: simulating wealth with random returns, inflation and withdrawals"),
  p("An adaptation of the",
    tags$a(href="http://glimmer.rstudio.com/systematicin/retirement.withdrawal/", "retirement app"),
    "from",
    tags$a(href="http://systematicinvestor.wordpress.com/", "Systematic Investor"),
    "to demonstrate the use of Shiny's new grid options."),
  hr(),

  fluidRow(
    column(6, tags$h3("Scenario A")),
    column(6, tags$h3("Scenario B"))
  ),
  fluidRow(
    column(6, renderInputs("a")),
    column(6, renderInputs("b"))
  ),
  fluidRow(
    column(6,
      plotOutput("a_distPlot", height = "600px")
    ),
    column(6,
      plotOutput("b_distPlot", height = "600px")
    )
  )
)


# import parameters
# recruitment parameters
Rpars=list(intcpt.mu=rep(0,n_spp),intcpt.yr=matrix(0,Nyrs,n_spp),intcpt.tau=rep(100,n_spp),
  intcpt.gr=matrix(NA,6,n_spp),g.tau=rep(NA,n_spp),
  dd=matrix(NA,n_spp,n_spp),theta=rep(NA,n_spp),sizeMean=rep(NA,n_spp),sizeVar=rep(NA,n_spp),
  recSizes=list(1))

 infile <- "../extdata/recruit_params_GnoG.csv"
 Rdata=read.csv(infile)
 # subset out non-essential parameters
 tmp=c(grep("lambda",row.names(Rdata)),grep("deviance",row.names(Rdata)),
  grep("DIC",row.names(Rdata)))   #group stuff?
 Rdata=Rdata[-tmp,]
 tmp=paste("Rpars$",row.names(Rdata),"<-",Rdata[,1],sep="")
 eval(parse(n=dim(Rdata)[1],text=tmp))
 for(i in 1:n_spp){
   infile=paste("../extdata/recSize_",spp_list[i],".csv",sep="")
   recSize=read.csv(infile)
   Rpars$sizeMean[i]=mean(log(recSize$area))
   Rpars$sizeVar[i]=var(log(recSize$area))
   #Rpars$recSizes[[i]]=recSize$area
 }
Rpars$dd=t(Rpars$dd) # c[i,j] = effect of j on i
rm(Rdata)

# define recruitment function
#number of recruits per area produced
# cover is stored in absolute area (cm^2)
get_rpa=function(Rpars,cover,doYear){
    # cover is in m^2 per m^2; convert to % scale:
    cover2=cover*100
    # calculate recruits
    Nspp=length(cover)
    mu=rep(NA,Nspp)
    for(i in 1:Nspp){
      mu[i]=cover2[i]*exp(Rpars$intcpt.yr[doYear,i]+sqrt(cover2)%*%Rpars$dd[i,])
    }
    if(sum(is.na(mu))>0) browser() # stop for errors
    rpa=mu/(cover*A)  # convert from number recruits to recruits per cm^2
    return(rpa)
}

# Fecundity function, expected number of recruits of size y produced by a size x individual
# The size distribution of recruits is on the log scale
f=function(v,u,Rpars,rpa,doSpp) {
  	nRecruits = rpa[doSpp]*exp(u)
	  #probability of producing a seedling of size v
	  tmp=dnorm(v,Rpars$sizeMean[doSpp],sqrt(Rpars$sizeVar[doSpp]))/(1-pnorm(-1.61,Rpars$sizeMean[doSpp],sqrt(Rpars$sizeVar[doSpp])))
    #number recruits of each size
    f=nRecruits*tmp
	  return(f)
}


#Reading the dataset

library(readr)
library(readxl)
AirQualityUCI <- read_xlsx("AirQualityUCI.xlsx")
View(AirQualityUCI)

str(AirQualityUCI)

#Cleaning the dataset

library(dplyr)
library(tidyr)

summary(AirQualityUCI)
str(AirQualityUCI)
head(AirQualityUCI)

tail(AirQualityUCI)

library("lubridate")

AirQualityUCI$Time<-parse_date_time(AirQualityUCI$Time, orders="ymd hms"

#Understanding the data structure

class(AirQualityUCI)
dim(AirQualityUCI)
colnames(AirQualityUCI)
str(AirQualityUCI)
library(dplyr)
glimpse(AirQualityUCI)

plot(AirQualityUCI$AH, AirQualityUCI$RH, main = "Humidity Analysis", xlab = "Absolute Humidity", ylab = "Relative Humidity")

#Hypothesis Tests
t.test(AirQualityUCI$RH, AirQualityUCI$AH)
t.test(AirQualityUCI$RH, mu = 5, alternative = 'greater')

t.test(AirQualityUCI$AH, mu = 5, alternative = 'greater')

#Grubbs Test and checking outliers

outlierKD <- function(dt, var) {
+     var_name <- eval(substitute(var),eval(dt))
+     na1 <- sum(is.na(var_name))
+     m1 <- mean(var_name, na.rm = T)
+     par(mfrow=c(2, 2), oma=c(0,0,3,0))
+     boxplot(var_name, main="With outliers")
+     hist(var_name, main="With outliers", xlab=NA, ylab=NA)
+     outlier <- boxplot.stats(var_name)$out
+     mo <- mean(outlier)
+     var_name <- ifelse(var_name %in% outlier, NA, var_name)
+     boxplot(var_name, main="Without outliers")
+     hist(var_name, main="Without outliers", xlab=NA, ylab=NA)
+     title("Outlier Check", outer=TRUE)
+     na2 <- sum(is.na(var_name))
+     cat("Outliers identified:", na2 - na1, "n")
+     cat("Propotion (%) of outliers:", round((na2 - na1) / sum(!is.na(var_name))*100, 1), "n")
+     cat("Mean of the outliers:", round(mo, 2), "n")
+     m2 <- mean(var_name, na.rm = T)
+     cat("Mean without removing outliers:", round(m1, 2), "n")
+     cat("Mean if we remove outliers:", round(m2, 2), "n")
+     response <- readline(prompt="Do you want to remove outliers and to replace with NA? [yes/no]: ")
+     if(response == "y" | response == "yes"){
+         dt[as.character(substitute(var))] <- invisible(var_name)
+         assign(as.character(as.list(match.call())$dt), dt, envir = .GlobalEnv)
+         cat("Outliers successfully removed", "n")
+         return(invisible(dt))
+     } else{
+         cat("Nothing changed", "n")
+         return(invisible(var_name))
+     }
+ }
outlierKD(AirQualityUCI,AH)

install.packages("outliers")

library(outliers)
library(ggplot2)

grubbs.flag <- function(x) {
+     outliers <- NULL
+     test <- x
+     grubbs.result <- grubbs.test(test)
+     pv <- grubbs.result$p.value
+     while(pv < 0.05) {
+         outliers <- c(outliers,as.numeric(strsplit(grubbs.result$alternative," ")[[1]][3]))
+         test <- x[!x %in% outliers]
+         grubbs.result <- grubbs.test(test)
+         pv <- grubbs.result$p.value
+     }
+     return(data.frame(X=x,Outlier=(x %in% outliers)))
+ }

grubbs.flag(AirQualityUCI$AH)

ggplot(grubbs.flag(AirQualityUCI$AH),aes(x=AirQualityUCI$AH,color=Outlier,fill=Outlier))+
+     geom_histogram(binwidth=diff(range(AirQualityUCI$AH))/30)+
+     theme_bw()

#Parsimonious Model

install.packages('devtools')
install.packages('MoEClust')

library(MoEClust)
View(AirQualityUCI)
Date

RH <-AirQualityUCI[,14]

AH <-AirQualityUCI[,15]
plot(comp$optimal, what="gpairs", jitter=FALSE)
(mod <- as.Mclust(comp$optimal))

plot(mod, what="classification")
plot(mod, what="uncertainty")

#Bartlett's Test
View(AirQualityUCI)

bartlett.test(RH~Date, AirQualityUCI)
bartlett.test(AH~Date, AirQualityUCI)

#Data Visualization

acf(AirQualityUCI)
require(graphics)
spectrum(AirQualityUCI, method = c("pgram", "ar"))
spectrum(AirQualityUCI)

#Phase Plots

install.packages("seewave")

library(seewave)

phaseplot(AirQualityUCI, , dim = 2)


## DEPDENCY #######################################################################################

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

plotMetric <- function(a, b, env, ...){
	if (is.null(env$train.acc.log)){
		env$train.acc.log   <- c()
		env$test.acc.log    <- c()
	}

	env$train.acc.log   <- append(env$train.acc.log, env$metric$get(env$train.metric)$value)
	env$test.acc.log    <- append(env$test.acc.log,  env$metric$get(env$eval.metric)$value)

	layout(matrix(c(1,1,1,1,2,2,2,2), nrow=2, byrow=T))
	plot(env$train.acc.log, type="o", col="blue")   # :-/
	points(env$test.acc.log, type="o", col="red")

	hist(as.matrix( env$model$arg.params[[1]] ), breaks=30)

	return (TRUE)
}

GetSoftmaxResult <- function(softmaxOutput){
	return ( max.col( t(softmaxOutput) ) -1 )
}

PrepareDatasetsForNeuralNetwork <- function(datasets){
	datasets$Train$X	<- data.matrix(datasets$Train$X)
	datasets$Test$X		<- data.matrix(datasets$Test$X)
	datasets$Train$Y	<- as.numeric(datasets$Train$Y) - 1
	datasets$Test$Y		<- as.numeric(datasets$Test$Y)  - 1

	return (datasets)
}

stop_quietly();

####################################################################################################
##	EXAMPLE 1: Sonar
####################################################################################################

#  1. Prepare data (see "PrepareDatasetsForNeuralNetwork" converting all to numeric and to data.matrix)
data(Sonar)

datasets	<- PrepareTrainAndTest(Sonar, "Class", 2/3, scaleBy="z-score")
datasets	<- PrepareDatasetsForNeuralNetwork(datasets)

#  2. Prepare NN Model: 20 -> 20 -> 20 -> 20 -> 2 Neural network with RELU activations
myNeuralNetwork <-(
	mx.symbol.Variable("data") %>%

	mx.symbol.FullyConnected(num_hidden = 20)	%>%
	mx.symbol.Activation(act_type = "relu")		%>%

	mx.symbol.FullyConnected(num_hidden = 20)	%>%
	mx.symbol.Activation(act_type = "relu")		%>%

	mx.symbol.FullyConnected(num_hidden = 20)	%>%
	mx.symbol.Activation(act_type = "relu")		%>%

	mx.symbol.FullyConnected(num_hidden = 20)	%>%
	mx.symbol.Activation(act_type = "relu")		%>%

	mx.symbol.FullyConnected(num_hidden = 2)	%>%
	mx.symbol.SoftmaxOutput()
)

#  3. Create & Train:
model <- mx.model.FeedForward.create( myNeuralNetwork,
										X = datasets$Train$X,
										y = datasets$Train$Y,
										eval.data=list(data=datasets$Test$X, label=datasets$Test$Y),
										optimizer="adam",
										ctx=mx.cpu(),
										num.round=200,
										array.batch.size=10,
										learning.rate=0.0001,
										wd=0.000183,
										eval.metric=mx.metric.accuracy,
										epoch.end.callback=plotMetric )

#  4. Display our network
graph.viz(model$symbol)

#  5. Evaluate
EvaluateModelAndPlot(model, datasets$Train, datasets$Test, GetSoftmaxResult)

#  6. Benchmark with LDA, SVM & naiveBayes
datasets	<- PrepareTrainAndTest(Sonar, "Class", 2/3, scaleBy="z-score")
#datasets	<- PrepareTrainAndTest(Sonar, "Class", 2/3, scaleBy="minmax")

model		<- lda(datasets$Train$X, datasets$Train$Y)
EvaluateModelAndPlot(model, datasets$Train, datasets$Test)

model		<- svm(datasets$Train$X, datasets$Train$Y, kernel="linear")
EvaluateModelAndPlot(model, datasets$Train, datasets$Test)

model		<- naiveBayes(datasets$Train$X, datasets$Train$Y)
EvaluateModelAndPlot(model, datasets$Train, datasets$Test)

####################################################################################################
##	EXAMPLE 2: Easy authorship with BOW
####################################################################################################

## [1] Prepare BOW

#  1. Read files & Tokenize them (+ limit to random X words)
authorA_Files	<- GetFilesContentsFromFolder("F:/VMOD/DATASETY/Asimov", "ASIMOV")
authorB_Files	<- GetFilesContentsFromFolder("F:/VMOD/DATASETY/Foglar", "FOGLAR")

authorA_Tokens	<- TokenizeTexts(authorA_Files)
authorB_Tokens	<- TokenizeTexts(authorB_Files)

numberOfTokens	<- 50
authorA_Tokens	<- LimitTokensInTexts(authorA_Tokens, count=numberOfTokens, takeRandom=TRUE)
authorB_Tokens	<- LimitTokensInTexts(authorB_Tokens, count=numberOfTokens, takeRandom=TRUE)

#  2. Bag of Words: per texts
allBOW				<- MakeBOWModel( append( authorA_Tokens, authorB_Tokens) )

#  3. Bag Of Words: per author
authorA_Corpora   	<- MergeTokenizedTexts(authorA_Tokens)
authorB_Corpora   	<- MergeTokenizedTexts(authorB_Tokens)
bowAuthorAVsB		<- MakeBOWModel( list(AuthorA = authorA_Corpora, AuthorB = authorB_Corpora) )

#  - calculate per author TF-IDF to identify author specific words:
weights             <- CalculateTFIDFOnBOW(bowAuthorAVsB, omitZeroWeightTerms=TRUE)
newAllBOW			<- KeepOnlyGivenColumns( allBOW, names(weights) )

#  5. Prepare datasets & Train
newAllBOW.Target	<- FirstColNameWordsToColumn(newAllBOW,  "AuthorTarget")

## [2] Prepare datasets
datasets	<- PrepareTrainAndTest(newAllBOW.Target, "AuthorTarget", 2/3, scaleBy="binarize", convertToFactors=FALSE)
datasets	<- PrepareDatasetsForNeuralNetwork(datasets)

## [3] Prepare & Train Neural Network:
myNN	<-(
	mx.symbol.Variable("data")					%>%
	mx.symbol.FullyConnected(num_hidden=100)	%>%
	mx.symbol.Activation(act_type="relu")		%>%

	mx.symbol.FullyConnected(num_hidden=10)		%>%
	mx.symbol.Activation(act_type="relu")		%>%

	mx.symbol.FullyConnected(num_hidden=2)		%>%
	mx.symbol.SoftmaxOutput()
)

mx.set.seed(0)
model <- mx.model.FeedForward.create(myNN,
										X = datasets$Train$X,
										y = datasets$Train$Y,
										eval.data=list(data=datasets$Test$X, label=datasets$Test$Y),
										optimizer="adam",
										ctx=mx.cpu(),
										num.round=50,
										array.batch.size=2,
										learning.rate=0.00001,
										wd=0.0001,
										eval.metric=mx.metric.accuracy,
										epoch.end.callback=plotMetric)

EvaluateModelAndPlot(model, datasets$Train, datasets$Test, GetSoftmaxResult)

####################################################################################################
##	EXAMPLE 3: Sentiment BOW
####################################################################################################

goodTokens		<- TokenizeTexts( GetFilesContentsFromFolder("C:/DATA/NLP/Sentiment/GOOD", "GOOD") )    # 1000 files with positive reviews
badTokens		<- TokenizeTexts( GetFilesContentsFromFolder("C:/DATA/NLP/Sentiment/BAD",  "BAD")  )    # 1000 files with negative reviews

goodCorpora   	<- MergeTokenizedTexts(goodTokens)
badCorpora   	<- MergeTokenizedTexts(badTokens)

# BOW per Texts & per sentiment, apply TFIDF on sentiment
allBOW			<- MakeBOWModel( append( goodTokens, badTokens) )
bowGoodVsBad	<- MakeBOWModel( list(Goods = goodCorpora, Bads = badCorpora) )

weights         <- CalculateTFIDFOnBOW(bowGoodVsBad, omitZeroWeightTerms=TRUE)
newAllBOW		<- KeepOnlyGivenColumns(allBOW, names(weights))

# Prepare dataset & Train & Eval
newAllBOW.Target	<- FirstColNameWordsToColumn(newAllBOW,  "Sentiment")
datasets	        <- PrepareTrainAndTest(newAllBOW.Target, "Sentiment", 2/3, scaleBy="z-score")
datasets	        <- PrepareDatasetsForNeuralNetwork(datasets)

net	<-(	mx.symbol.Variable( "data" )					%>%
		mx.symbol.Dropout( p=0.3 )						%>%

		mx.symbol.FullyConnected( num_hidden=30 )		%>%
		mx.symbol.Dropout( p=0.1 )						%>%

		mx.symbol.Activation( act_type="relu" )			%>%
		mx.symbol.FullyConnected( num_hidden=5 )		%>%

		mx.symbol.Activation( act_type="relu" )			%>%
		mx.symbol.FullyConnected( num_hidden=2 )		%>%

		mx.symbol.SoftmaxOutput()
)

model <- mx.model.FeedForward.create(net,
										X			= datasets$Train$X,
										y			= datasets$Train$Y,
										eval.data	= list(data=datasets$Test$X, label=datasets$Test$Y),
										optimizer	= "adam",
										ctx			= mx.cpu(),
										num.round		= 100,
										array.batch.size= 250,
										learning.rate	= 0.001,
										wd = 0.001,
										eval.metric = mx.metric.accuracy,
										epoch.end.callback = plotMetric)

EvaluateModelAndPlot(model, datasets$Train, datasets$Test, GetSoftmaxResult)


#my-truth calculates AR model-,p_value,My_aic,STD_AIC

rm(list=ls())
library(tseries)  #for arma process

alli<-NULL
zafari<-list.files("K:\\Project_Data_Sagar\\my_truth\\sangram_clipso\\")  #have potentials files

for(roll in zafari){
jai<-read.table(paste("K:\\Project_Data_Sagar\\my_truth\\sangram_clipso\\",roll,sep=""),skip=1)  #reading with avoiding first name
file_id<-substr(roll,1,(nchar(roll)-4) )  #file name

galiya<-jai$V4   #have whole time series
ts<-ts(galiya)

ishare<-ar(ts)   #Autoressive model
ts_p<-ishare$order    #order P value

#for AIC value
lm<-lm(ts ~ 1)     #fitting linear model
loglik<-logLik(lm)     #Extract Log-Likelihood
my_aic<-AIC(loglik)

arita<-arma(ts,order=c(ts_p,0))    #for calculating STD AIC value
y<-summary(arita)
std_aic<-y$aic

tun_tuna<-cbind(file_id,ts_p,my_aic,std_aic,deparse.level=0)   #making single row for each file
alli<-rbind(alli,tun_tuna)
}   #file iterating for

write.table(alli,"K:\\Project_Data_Sagar\\Halwa\\BADMASHI\\my_truth\\Model\\AR\\my_truth_AR_aic.txt",col.names=c("PDB_ID","P_value","MY_AIC","STD_AIC"),row.names=F)


#'
#'@title Add horizontal error bars to current plot
#'
#'@description Adds horizontal error bars to current plot.
#'
#'@param x - vector of x coordinates or matrix w/ columns 1 & 2 taken as x,y
#'@param y - vector of y coordinates (or NULL, if x is a matrix)
#'@param upper - upper CI for y
#'@param lower - lower CI for y
#'@param sigma - standard deviations for y
#'@param cv - cvs for y, instead of sigma
#'@param CI - upper confidence interval (if sigma or cv specified)
#'@param lognormal - flag (T/F). if true, assumed distribution is lognormal
#'@param width - relative width of error bars
#'@param ... - graphics parameters for segments (e.g., col, lty, lwd)
#'
#'@export
#'@import graphics
#'@import stats
#'
plotErrorBars.H<-function(x,
                        y,
                        upper=NULL,       #upper CI for x
                        lower=NULL,       #lower  CI for x
                        sigma=NULL,       #standard deviations for x
                        cv=NULL,          #cvs for x, instead of sigma
                        CI=0.95,          #upper confidence interval (if sigma or cv specified)
                        lognormal=FALSE,  #if true, assumed distribution is lognormal
                        width=1,          #relative width of error bars
                        ...               #graphics parameters for segments (e.g., col, lty, lwd)
                        ) {
#    old.par<-par(new=T);
    if (is.null(y)) {
        if (is.vector(x)) {
            yp<-x;
            xp<-1:length(x);
        } else if (is.matrix(x)) {
            yp<-x[,2];
            xp<-x[,1];
        } else {
            cat('Exiting--not implemented for this type of x. \n');
            return;
        }
    } else {
        xp = x;
        yp = y;
    }
    if (!is.null(cv)){
        sigma<-cv*xp;
    }
    if (!is.null(sigma)) {
        if (!lognormal) {
            upper<-qnorm(1-(1-CI)/2,sd=sigma);
            lower<-qnorm((1-CI)/2,sd=sigma);
        } else {
            lnxp<-log(xp);
            lnsd<-sqrt(log(1+(sigma/xp)^2))
            upper<-qlnorm(1-(1-CI)/2,meanlog=lnxp,sdlog=lnsd)-xp;
            lower<-qlnorm((1-CI)/2,meanlog=lnxp,sdlog=lnsd)-xp;
        }
    }
    usr<-par("usr");
   cat("usr = ",usr,"\n")
    ebw<-width*(usr[4]-usr[3])/((max(yp,na.rm=TRUE)-min(yp,na.rm=TRUE)));
   cat("ebw = ",ebw,"\n");
    for (i in 1:length(xp)) {
        if (!is.null(upper)) {
            segments(xp[i],yp[i],xp[i]+upper[i],yp[i],...);
            segments(xp[i]+upper[i],yp[i]-ebw,xp[i]+upper[i],yp[i]+ebw,...);
        }
        if (!is.null(lower)) {
          segments(xp[i],yp[i],xp[i]+lower[i],yp[i],...);
          segments(xp[i]+lower[i],yp[i]-ebw,xp[i]+lower[i],yp[i]+ebw,...);
        }
    }
#    on.exit(par(old.par));
}


0 -> 2 (1)
2 -> 3 (2)
3 -> 5 (2)
4 -> 5 (1)
1 -> 4 (0)
5 -> 6 (6)
4 -> 7 (8)


testthat::context('Hydrostatic pressure')

# Indicator function test ------------------------------------------------------

testthat::test_that('Indicator function for last point.', {
  # Last point can never be detected as an AO, only LS
  testthat::expect_equal(object = indicator('AO', 1, 1), expected = 0)
  testthat::expect_equal(object = indicator('LS', 1, 1), expected = 1)

  testthat::expect_equal(object = indicator('TC', 1, 1), expected = 1)
})

testthat::test_that('Indicator function for AO, LS and TC events produces correct results.', {
  testthat::expect_equal(object = indicator('AO', 2, 5), expected = c(0, 1,-1, 0, 0))
  testthat::expect_equal(object = indicator('LS', 1, 5), expected = c(1, 0, 0, 0, 0))
  testthat::expect_equal(object = indicator('TC', 5, 5), expected = c(0, 0, 0, 0, 1))
  testthat::expect_equal(object = indicator('TC', 4, 5), expected = c(0, 0, 0, 1, 1))
  testthat::expect_equal(object = indicator('TC', 1, 5), expected = c(1, 1, 1, 1, 1))
})

testthat::test_that('Indicator function fails on unknown type.', {
  testthat::expect_error(indicator('AA', 5, 5))
})

# Decay function test ------------------------------------------------------

testthat::test_that('Decay function works correctly.', {
  testthat::expect_equal(object = round(decay(2, 0.7, 5), 2), c(0.00,  1.00, -0.30, -0.21, -0.15))
  testthat::expect_equal(object = round(decay(1, 0.7, 2), 2), c(1.00, -0.30))
  testthat::expect_equal(object = round(decay(1, 0.7, 1), 2), 1)
})

# Detect function test ---------------------------------------------------------

set.seed(2019)
x <- c(-50, rnorm(18), 50, rnorm(19) + 50, -50, rnorm(4), rnorm(45) + 100*0.8^(0:44), 50, rnorm(7))
timestamps <- seq(as.POSIXct('2000-01-01'), length.out = length(x), by = '15 min')
# plot(x)

testthat::test_that('Hydrostatic pressure detect function finds all the events.', {
  res <- detect(x = x, timestamps = timestamps)[order(index, type)]
  testthat::expect_known_value(object = res, file = './test-hydropressure-detect.rds')
})

testthat::test_that('Hydrostatic pressure LS is detected.', {
  res.expected <- rep(FALSE, length(x))
  res.expected[c(2, 20, 40)] <- TRUE
  res <- detect_levelshifts(x = x, timestamps = timestamps,
                            apriori = apriori('hydrostatic pressure'))
  testthat::expect_equal(res, res.expected)
})

testthat::test_that('Hydrostatic pressure TC is detected.', {
  res.expected <- rep(FALSE, length(x))
  res.expected[45:58] <- TRUE
  res <- detect_temporalchanges(x = x, timestamps = timestamps,
                                apriori = apriori('hydrostatic pressure'))
  testthat::expect_equal(res, res.expected)
})

# Optimization function test ---------------------------------------------------

testthat::test_that("Optimizing 1 point on AO shouldn't have any effect on parameters.", {
  opt <- Optimizer(dx = rnorm(1), types = c('AO'), indexes = 1, mu = 0, sigma2 = 1)
  res <- opt$optimize()
  testthat::expect_equal(attr(res,"optim")$counts, expected = c('function' = 1, 'gradient' = 1))
})

testthat::test_that("Optimizing without types shoudn't fail.", {
  opt <- Optimizer(dx = rnorm(1000), types = NULL, indexes = NULL,
                   mu = rep(0, 1000), sigma2 = rep(1, 1000))
  res <- opt$optimize()
  testthat::expect_length(attr(res, 'par'), n = 0)
})

# Optimizer(dx = rnorm(1000), types = c('AO'), indexes = 1, mu = 0, sigma2 = 1)$optimize()
# Optimizer(dx = rnorm(1000), types = c('AO', 'LS'), indexes = c(1, 3), mu = 0, sigma2 = 1)$optimize()
# Optimizer(dx = rnorm(1000), types = c('AO', 'TC', 'LS'), indexes = c(1, 2, 3), mu = 0, sigma2 = 100)$optimize()


### -----------------------------
### simon munzert
### build a network of statisticians
### -----------------------------

## goals

# gather list of phi
# fetch Wikipedia entries
# identify links
# construct connectivity matrix
# visualize network

## load packages  -----------------------
library(tidyverse)
library(rvest)
library(igraph)
library(networkD3)

# set temporary working directory
tempwd <- ("../data/wikipediaStatisticians")
dir.create(tempwd)
setwd(tempwd)

## step 1: inspect page
url <- "https://en.wikipedia.org/wiki/List_of_statisticians"
browseURL(url)

## step 2: retrieve links
html <- read_html(url)
anchors <- html_nodes(html, xpath = "//ul/li/a[1]")
links <- html_attr(anchors, "href")

links <- links[!is.na(links)]
links_iffer <-
  seq_along(links) >=
  seq_along(links)[str_detect(links, "Odd_Aalen")] &
  seq_along(links) <=
  seq_along(links)[str_detect(links, "George_Kingsley_Zipf")] &
  str_detect(links, "/wiki/")
links_index <- seq_along(links)[links_iffer]
links <- links[links_iffer]
length(links)

##  step 3: extract names
names <- links %>% basename %>% sapply(., URLdecode)  %>% str_replace_all("_", " ") %>% str_replace_all(" \\(.*\\)", "") %>% str_trim

## step 4: fetch personal wiki pages
baseurl <- "http://en.wikipedia.org"
HTML <- list()
Fname <- str_c(basename(links), ".html")
URL <- str_c(baseurl, links)
# loop
for ( i in seq_along(links) ){
  # url
  url <- URL[i]
  # fname
  fname <- Fname[i]
  # download
  if ( !file.exists(fname) ) download.file(url, fname)
  # read in files
  HTML[[i]] <- read_html(fname)
}

## step 5: identify links between statisticians
# loop preparation
connections <- data.frame(from=NULL, to=NULL)
# loop
for (i in seq_along(HTML)) {
  pslinks <- html_attr(
    html_nodes(HTML[[i]], xpath="//p//a"), # note: only look for links in p sections; otherwise too many links collected
    "href")
  links_in_pslinks <- seq_along(links)[links %in% pslinks]
  links_in_pslinks <- links_in_pslinks[links_in_pslinks!=i]
  connections <- rbind(
    connections,
    data.frame(
      from=rep(i-1, length(links_in_pslinks)), # -1 for zero-indexing
      to=links_in_pslinks-1 # here too
    )
  )
}

# results
names(connections) <- c("from", "to")
head(connections)

# make symmetrical
connections <- rbind(
  connections,
  data.frame(from=connections$to,
             to=connections$from)
)
connections <- connections[!duplicated(connections),]

## step 6: visualize connections
connections$value <- 1
nodesDF <- data.frame(name = names, group = 1)

network_out <- forceNetwork(Links = connections, Nodes = nodesDF, Source = "from", Target = "to", Value = "value", NodeID = "name", Group = "group", zoom = TRUE, fontSize = 14, opacityNoHover = 3)

saveNetwork(network_out, file = 'connections.html')
browseURL("connections.html")

## step 7: identify top nodes in data frame
nodesDF$id <- as.numeric(rownames(nodesDF)) - 1
connections_df <- merge(connections, nodesDF, by.x = "to", by.y = "id", all = TRUE)
to_count_df <- count(connections_df, name)
arrange(to_count_df, desc(n))  %>% slice(1:20)


# ----------------------------
#  App Title: LCO CI Generator
#     Author: Jimmy Doi
# ----------------------------

library(shiny)

source("LCO_generator_all_n.r")

shinyServer(function(input, output, session) {

  output$textlevel <- renderText({
    paste0("Level = ", input$level,"%")
    })

  output$textsize <- renderText({
    paste("Sample size =", input$size)
    })

  output$textdp <- renderText({
    paste(input$dpsize,"decimal place accuracy")
    })

    output$LCOresults <- renderPrint({

    lev <- input$level/100
    dp <- switch(input$dpsize,
                   "2nd" = 2,
                   "3rd" = 3,
                   "4th" = 4)
    sz <- input$size

      LCO.CI(sz,lev,dp)

    })
})


# Load libraries
library(openxlsx)
library(BayesFactor)
library(pracma)
library(ggplot2)
library(gridExtra)

# Load Excel spreadsheet
fd_data <- read.xlsx('Spitschan.FD_Sample_Protocol.xlsx')

# Extract only those rows that actually have measurements in them
fd_data <- fd_data[!is.na(fd_data$Measurement), ]

# Iterate parameters for one participant
NSpacing = 12
ratio = logspace(-1.5, 1, NSpacing)
#ratio = 0.5
NSims = 1000

# Number of participants
NParticipantsMax = 8

# Set up some empty arrays to capture data in the loop
BFs_h0 = array(dim = c(length(ratio), NParticipantsMax, NSims))
BFs_h1 = array(dim = c(length(ratio), NParticipantsMax, NSims))

p1 <- array()
sdev = 1

for (a in 1:length(ratio)) {
  # SNR
  for (p in 1:NParticipantsMax) {
    for (s in 1:NSims) {
      # Resample data N times

      Meas_h0 = vector()
      Meas_h1 = vector()
      participantID = vector()

      # Create some empty variables
      for (r in 1:p) {
        # Generate the data for p participants
        # Simulate data under H1
        Meas_h1_baseline <- rnorm(nrow(fd_data), 0, sdev)
        Meas_h1_sinewave_A <-
          rnorm(nrow(fd_data), sdev * ratio[a], 0.1) # Generate a sine wave with noisy amplitude
        Meas_h1_sinewave <-
          Meas_h1_sinewave_A * fd_data$Sine.component # Multiply with sine wave
        Meas_h1 <-
          append(Meas_h1, Meas_h1_baseline + Meas_h1_sinewave)

        # Simlate data under H0
        Meas_h0 <-
          append(Meas_h0, rnorm(nrow(fd_data), 0, sdev)) # This is simply the noisy distribution

        # Add participant ID here
        participantID <-
          append(participantID, rep(r, nrow(fd_data)))
      }

      fd_data1 <-
        data.frame(
          rep(fd_data$`Time.since.awake.[hour]`, p),
          rep(fd_data$`Time.since.entering.FD.[hour]`, p),
          rep(fd_data$`Sine.component`, p),
          rep(fd_data$`Cosine.component`, p),
          Meas_h0,
          Meas_h1,
          participantID
        )
      colnames(fd_data1) <-
        c(
          'Time.since.awake.[hour]',
          'Time.since.entering.FD.[hour]',
          'Sine.component',
          'Cosine.component',
          'Meas_h0',
          'Meas_h1',
          'ParticipantID'
        )

      # Set up a linear model for the full model and the null model
      fd_model_full_h0 <-
        lmBF(
          `Meas_h0` ~ `Time.since.awake.[hour]` + `Time.since.entering.FD.[hour]` + `Sine.component` + `Cosine.component` + `ParticipantID`,
          data = fd_data1
        )
      fd_model_null_h0 <-
        lmBF(
          `Meas_h0` ~ `Time.since.awake.[hour]` + `Time.since.entering.FD.[hour]` + `ParticipantID`,
          data = fd_data1
        )

      # Calculate the Bayes Factor
      BF_h0 <- fd_model_full_h0 / fd_model_null_h0
      BFs_h0[a, p, s] <- extractBF(BF_h0)$bf

      # Set up a linear model for the full model and the null model
      fd_model_full_h1 <-
        lmBF(
          `Meas_h1` ~ `Time.since.awake.[hour]` + `Time.since.entering.FD.[hour]` + `Sine.component` + `Cosine.component`,
          data = fd_data1
        )
      fd_model_null_h1 <-
        lmBF(
          `Meas_h1` ~ `Time.since.awake.[hour]` + `Time.since.entering.FD.[hour]`,
          data = fd_data1
        )

      # Calculate the Bayes Factor
      BF_h1 <- fd_model_full_h1 / fd_model_null_h1
      BFs_h1[a, p, s] <- extractBF(BF_h1)$bf
      #BFs_error[a, s] <- extractBF(BF)$error

      # Calculate posterior. Adding code here for demonstration
      #posteriorcalcs = posterior(BF_h0, iterations = 1000)
      #summary(posteriorcalcs)
    }
  }
}

falsePositive <- array(dim = c(length(ratio), NParticipantsMax))
truePositive <- array(dim = c(length(ratio), NParticipantsMax))
ratios <- array(dim = c(length(ratio), NParticipantsMax))
NParticipants <- array(dim = c(length(ratio), NParticipantsMax))
thresh <- 10
for (a in 1:length(ratio)) {
  for (p in 1:NParticipantsMax) {
    ratios[a, p] <- ratio[a]
    NParticipants[a, p] <- p
    falsePositive[a, p] <-
      length(BFs_h0[a, p, BFs_h0[a, p, ] > thresh]) / length(BFs_h0[a, p, ])
    truePositive[a, p] <-
      length(BFs_h1[a, p, BFs_h1[a, p, ] > thresh]) / length(BFs_h1[a, p, ])
  }
}

# Turn them all into long vectors
falsePositive <- c(falsePositive)
truePositive <- c(truePositive)
ppv <- (truePositive) / (falsePositive + truePositive)
ratios <- c(ratios)
NParticipants <- c(NParticipants)

# Assemble as a data frame
roc <-
  data.frame(ratios, falsePositive, truePositive, NParticipants, ppv)

# Plot the data
p1 <-
  ggplot(roc, aes(
    x = log10(ratios),
    y = truePositive,
    color = NParticipants
  )) + geom_point() + geom_line(aes(group = NParticipants)) + ylim(0, 1) + coord_fixed(ratio = 2) + ggtitle('True positives')
p2 <-
  ggplot(roc, aes(
    x = log10(ratios),
    y = falsePositive,
    color = NParticipants
  )) + geom_point() + geom_line(aes(group = NParticipants)) + ylim(0, 1) + coord_fixed(ratio = 2) + ggtitle('False positives')
p3 <-
  ggplot(roc, aes(
    x = log10(ratios),
    y = ppv,
    color = NParticipants
  )) + geom_point() + geom_line(aes(group = NParticipants)) + ylim(0, 1) + coord_fixed(ratio = 2) + ggtitle('Sensitivity')

# Grab the legend
g_legend <- function(a.gplot) {
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x)
    x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  return(legend)
}

# Assemble the data into a grid
aleg <- g_legend(p1)
p1 <-
  p1 + theme_classic() + theme(legend.position = "none") + labs(x = "Log10 a/sigma", y = "True positive rate")
p2 <-
  p2 + theme_classic() + theme(legend.position = "none") + labs(x = "Log10 a/sigma", y = "False positive rate")
p3 <-
  p3 + theme_classic() + theme(legend.position = "none") + labs(x = "Log10 a/sigma", y = "Sensitivity")

# Save analysis
pdf("figures/Spitschan.FD_BF_10.pdf",
    width = 8,
    height = 8)

# Arrange the data
grid.arrange(p1, p2, p3, aleg, nrow = 2, ncol = 2)

# Close the pdf file
dev.off()


 DPTCON Example Program Results

 Estimate of condition number =   1.05E+02


#Diffbot ezproxy Results Database
library(RSQLite)

conn <- dbConnect(RSQLite::SQLite(), "~/Documents/ezproxy-diffbot.db")

ezproxy_records <- dbReadTable(conn, "ezproxy_records")
tags <- dbReadTable(conn, "tags")
record_tags <- dbReadTable(conn, "record_tags")

scorehist <- function(record_tags) {
  hist(record_tags$score, breaks = 25, main = paste("Histogram of ezproxy Tag Scores (n = ", toString(nrow(ezproxy_records)), ")", sep = ""), xlab = "Tag Score")
}

counthist <- function(record_tags) {
  hist(record_tags$count, breaks = 10, main = paste("Histogram of ezproxy Tag Count (n = ", toString(nrow(ezproxy_records)), ")", sep = ""), xlab = "Tag Count", col = "lightblue")
}

countdot <- function(record_tags) {
  dotchart(record_tags$count, main = paste("Dot Chart of ezproxy Tag Count (n = ", toString(nrow(ezproxy_records)), ")", sep = ""), xlab = "Tag Count")
}

#categorypiechart <- function(gbooks) {
#  piedata <- sort(table(gbooks$google_category), decreasing = T)
#  pie(piedata, labels = row.names(head(piedata, 15)))
#}

tagfreqpiedotchart <- function(record_tags) {
  piedata <- sort(table(record_tags$tag_id), decreasing = T)
  pie(head(piedata, 25), labels = head(tags[row.names(piedata),"label"], 25))
  dotchart(head(piedata,50), labels = head(tags[row.names(piedata),"label"], 50), cex = 0.8)
}

avgscoreplot <- function(record_tags) {

}

tagfreqpiedotchart(record_tags)


#install the library

install.packages('networkD3')
library(networkD3)

#original example I found

# Load energy projection data
URL <- "https://cdn.rawgit.com/christophergandrud/networkD3/master/JSONdata/energy.json"
Energy <- jsonlite::fromJSON(URL)

# 2 data frames: a 'links' data frame with 3 columns (from, to, value)
# and a 'nodes' data frame that gives the name of each node.

#code to plot it
sankeyNetwork(Links = Energy$links, Nodes = Energy$nodes, Source = "source",
              Target = "target", Value = "value", NodeID = "name",
              units = "TWh", fontSize = 12, nodeWidth = 30)

#I built these two dataframes from my own data
nodes = read.csv('data/sankey_nodes.csv', stringsAsFactors = FALSE)
links = read.csv('data/sankey_links.csv', stringsAsFactors = FALSE)

#then pass the two dataframes to the program
sankeyNetwork(Links = links, Nodes = nodes, Source = "source",
              Target = "target", Value = "value", NodeID = "names",
              units = "Number of Sequences", fontSize = 12)
#in Rstudio you can output the plot as either interactive html, or a plain pdf


library(car)

# read the file
x1= read.delim("E:/denboer2009-expr.txt")
rownames(x1)= x1[,1]
x3 = x1[,-1]
x= as.data.frame(t(x3))

# read the lables
y= read.delim("E:/denboer2009-pheno (2).txt")
rownames(y)= y[,1]
y= y[,-1]

# add lables to data as a column
x$sample = substr(y[,5],1,190)

#qqplot
# create a data from a gen and lables and select only T-All
selectedgene = x[c("CD3D|213539_at" , "sample")]
selectTlable = selectedgene[selectedgene$sample== "T",]
# select the gen column only and run qqplot and save it to analyse if data has Normal distribution
jpeg("qqnorm_CD3D_T_ALL.jpg")
qqPlot(selectTlable[,1],col.lines = "purple" , ylab = "CD3D Gene" , main =
         " qqnorm for CD3D gene in pationts with T-ALL")
dev.off()

# create a data from a gen and lables and select subtypes of B-ALL
selectedgene = x[c("CD3D|213539_at" , "sample")]
selectOtherlable = selectedgene[selectedgene$sample != "T",]
# select the gen column only and run qqplot and save it to analyse if data has Normal distribution
jpeg("qqnorm_CD3D_B_ALL.jpg")
qqPlot(selectOtherlable[,1] , ylab = "CD3D Gene" , main =
         " qqnorm for CD3D gene in pationts with B-ALL subtypes")
dev.off()

# qqplot and save for CD3D gene through T-ALL and B-ALL pationts
jpeg("qqplot_CD3D Gene_T-ALL and B-ALL pationts.jpg")
qqplot(selectTlable[,1] , selectOtherlable[,1], plot.it = TRUE,
       xlab = " CD3D gene with T lable",
       ylab = " CD3D gene with other lables",
       main = "qqplot for CD3D gene through T-ALL and B-ALL pationts")
dev.off()


# =============================================
# Hiearchical clusters of spleen samples
# =============================================
data <- read.csv("2015-10-27-MF-SPLEEN-CPM-NORM-log2-edgeR.csv", header=T, row.names=1)
# data <- read.csv("2015-10-27-MF-SPLEEN-RPKM-NORM-log2-edgeR.csv", header=T, row.names=1)
dim(data)
names(data)
cor(data)
plot(hclust(dist(t(data))))
png(file="2015-10-27-MF-SPLEEN-CPM-NORM-log2-edgeR-hclust.png")
# png(file="2015-10-27-MF-SPLEEN-RPKM-NORM-log2-edgeR-hclust.png")
plot(hclust(dist(t(data))))
dev.off()

# =============================================
# Hiearchical clusters of gonad samples
# =============================================
data <- read.csv("2015-10-27-MF-GONAD-CPM-NORM-log2-edgeR.csv", header=T, row.names=1)
# data <- read.csv("2015-10-27-MF-GONAD-RPKM-NORM-log2-edgeR.csv", header=T, row.names=1)
dim(data)
names(data)
head(data)
cor(data)
plot(hclust(dist(t(data))))
png(file="2015-10-27-MF-GONAD-CPM-NORM-log2-edgeR-hclust.png")
# png(file="2015-10-27-MF-GONAD-RPKM-NORM-log2-edgeR-hclust.png")
plot(hclust(dist(t(data))))
dev.off()

# =============================================
# Hiearchical clusters of heart samples
# =============================================
data <- read.csv("2015-10-27-MF-HEART-CPM-NORM-log2-edgeR.csv", header=T, row.names=1)
# data <- read.csv("2015-10-27-MF-HEART-RPKM-NORM-log2-edgeR.csv", header=T, row.names=1)
dim(data)
names(data)
cor(data)
plot(hclust(dist(t(data))))
png(file="2015-10-27-MF-HEART-CPM-NORM-log2-edgeR-hclust.png")
# png(file="2015-10-27-MF-HEART-RPKM-NORM-log2-edgeR-hclust.png")
plot(hclust(dist(t(data))))
dev.off()
# =============================================
# Hiearchical clusters of liver samples
# =============================================
data <- read.csv("2015-10-27-MF-LIVER-CPM-NORM-log2-edgeR.csv", header=T, row.names=1)
# data <- read.csv("2015-10-27-MF-LIVER-RPKM-NORM-log2-edgeR.csv", header=T, row.names=1)
dim(data)
names(data)
cor(data)
plot(hclust(dist(t(data))))
png(file="2015-10-27-MF-LIVER-CPM-NORM-log2-edgeR-hclust.png")
# png(file="2015-10-27-MF-LIVER-RPKM-NORM-log2-edgeR-hclust.png")
plot(hclust(dist(t(data))))
dev.off()


#  James Rekow

partitionVec = function(v, numPartitions){

  #  ARGS: v - numerical vector
  #        numPartitions - number of vectors into which v will be partitioned
  #
  #  RETURNS: partitionList - a list of numPartition numerical vectors that form a partition of v.
  #                           The length of each vector is length(v) / numPartitions or
  #                           1 + length(v) / numPartitions (depending on whether or not length(v) is
  #                           divisible by numPartitions) and the elements in each vector are taken
  #                           randomly from v (in such a way that no two vectors share any elements).

  splitAt <- function(x, pos) unname(split(x, cumsum(seq_along(x) %in% pos)))

  n = length(v)
  numPartitions = min(numPartitions, n)
  remainder = n %% numPartitions
  basePartitionSize = floor(n / numPartitions)
  partitionSizeVec = as.list(rep(basePartitionSize, numPartitions))

  if(remainder > 0){
    partitionSizeVec[1:remainder] = lapply(partitionSizeVec[1:remainder], function(z) z + 1)
  } #  end if

  splitIx = cumsum(partitionSizeVec)
  splitIx = splitIx[-length(splitIx)] + 1

  ranV = sample(v)

  partitionList = splitAt(x = ranV, pos = splitIx)

  return(partitionList)

} #  end partitionVec function


PriorityQueue <-
  setRefClass("PriorityQueue",
              fields = list(keys = "numeric", values = "list"),
              methods = list(
                insert = function(key,value) {
                  temp <- c(keys,key)
                  ord <- order(temp)
                  keys <<- temp[ord]
                  values <<- c(values,list(value))[ord]
                },
                pop = function() {
                  head <- values[[1]]
                  keys <<- keys[-1]
                  values <<- values[-1]
                  return(head)
                },
                empty = function() length(keys) == 0
                ))


a -> d (1)
d -> c (2)
c -> e (3)
a -> b (5)


library("swirl")
ls()
swirl()
x
x[1:10]
x[is.na(x)]
y <- x[!is.na(x)]
y
y[y >0]
x[x>0]
x[!is.na(x)& x .0]
x[!is.na(x)& x >0]
x[c(3,5,7)]
x[0]
x[3000]
x[c(-2,-10)]
x[-c(2,10)]
vect <- c(foo = 100, bar = 2, norf= NA)
vect <- c(foo = 11, bar = 2, norf= NA)
vect
names(vect)
vect2 <-c(11,2,NA)
names(vect2)<- c("foo", "bar", "norf")
identical(vect, vect2)
vect["bar"]
vect[c("foo","bar")]
my_vector <- 1:20
my_vector
dim(my_vector)
length(my_vector)
dim(my_vector) <- c(4,5)
dim(my_vector)
attributes(my_vector)
play()
my_vector
nxt()
my_vector
class(my_vector)
my_matrix <- my_vector
?matrix
my_matrix2 <- matrix(data = 1:20,nrow = 4, ncol= 5)
identical(my_matrix, my_matrix2)
patients <-  c("Bill", "Gina", "Kelly", "Sean")
cbind(patients, my_matrix)
my_data <- data.frame(patients, my_matrix)
my_data
class(my_data)
cnames <- c("patient", "age", "weight","bp","rating","test")
colnames(my_data) <- cnames
my_data


# help manual of "Data input" functions
?read.table
?read.csv

# read csv to frame
my_data <- read.csv('evals.csv')

# open data table in window
View(mydata)

# structure of frame
str(mydata)

# return vector of value's names
names(mydata)

# create new var in frame
mydata$nvar <- 0

# amount of rows in frame
nrow(mydata)

# return amount of vars(cols) in frame
ncol(mydata)

# identity rows in frame by num
mydata$id <- 1:nrow(mydata)

# summaty data of all vars in frame
summary(mydata)

# use one of them var in frame
mydata$score *2

# create logical vector
mydata$gender == 'female'

# select ops by logical vector
mydata[mydata$gender == 'female',1]

# create set about query
subset(mydata, gender == 'female')
subset(mydata, score > 3.5)

# separate frame to set
mydata2 <- subset(mydata, gender == 'female')
mydata3 <- subset(mydata, gender == 'male')
# joins sets to frame
mydata4 <- rbind(mydata2, mydata3)

# separete frame by cols
mydata5 <- mydata[,1:10]
mydata6 <- mydata[,11:23]
# join frame by cols
mydata7 <- cbind(mydata5, mydata6)

# show avaible system datasets
library(help="datasets")

df <- mtcars

df$even_gear <- 1- df$gear %% 2
print(df$even_gear)

print(df[df$cyl == 4,1])

df[c(3,7,10,12,nrow(df)),1:ncol(df)]


#' @title findAxes
#' @description Places vertices into axes
#' @details Places vertices into axes based on a clustering algorithm
#' @aliases findAxes
#' @export findAxes
#' @author Jared P. Lander
#' @importFrom igraph walktrap.community "V<-" V
#' @param graph An igraph object
#' @param func A function that returns a cluster membership for each node
#' @param \dots Further arguments for \code{func}
#' @return A graph with a new Vertex slot 'axis' that stores the cluster membership
#' @examples
#' library(igraph)
#' data(flights)
#' g <- graph.data.frame(flights, directed=TRUE)
#' g2 <- findAxes(g)
#' V(g2)$axis
#'
findAxes <- function(graph, func=walktrap.community, ...)
{
    # compute axes membership
    axes <- func(graph, ...)

    # if it is a communities object grab the membership vector
    if(class(axes) == 'communities')
    {
        axes <- axes$membership
    }

    # assign the axes to the vertices
    V(graph)$axis <- axes

    return(graph)
}


 DGTRFS Example Program Results

 Solution(s)
             1          2
 1     -4.0000     5.0000
 2      7.0000    -4.0000
 3      3.0000    -3.0000
 4     -4.0000    -2.0000
 5     -3.0000     1.0000

 Backward errors (machine-dependent)
       7.2E-17    5.9E-17

 Estimated forward error bounds (machine-dependent)
       9.4E-15    1.4E-14


runLimTREE <- function(line, paramFile, dat = NULL, ...) {
    if (is.null(dat))
	dat = loadInputData()

    params = read.csv(paramFile, stringsAsFactors=FALSE)[line,]
    params = unlist(params)

    out = LimTREE(dat[['MAP']], dat[['RainTerm_Drought']],
                  dat[['SW1']], dat[['SW2']],
                  dat[['BurntArea']], dat[['StressTerm_Drought']], dat[['MTWM']],
                  dat[['MTCM']],
                  dat[['PopDen']],
                  dat[['buffalo']], dat[['cattle']], dat[['goat']], dat[['sheep']],
                  dat[['urban']], dat[['crop']], dat[['pas']],
                  params['m_drought'],
                  params['min_mat'], params['max_mat'],
                  params['trans_d'], params['p_fire'],
                  params['k_pop'],
                  params['k_buffalo'], params['k_cattle'],
                  params['k_goat'], params['k_sheep'],
                  params['p_drought'],
                  params['min_maxTemp'], params['max_minTemp'],
                  params['q10_maxTemp'], params['q10_minTemp'],
                  params['v_drought'], params['v_maxTemp'], params['v_minTemp'],
                  params['v_pop'],
                  params['v_buffalo'], params['v_cattle'],
                  params['v_goat'], params['v_sheep'],
                  params['v_crop'] ,params['v_pas'],
                  params['MAP_x0'], params['MAP_k'], params['MAT_x0'], params['MAT_k'],
                  params['SW_x0'], params['SW_k'], params['mort_x0'], params['mort_k'],
                  params['ex_x0'], params['ex_k'],
                  params['max_T'], ...)

    return(out)
}

LimTREE <- function(MAP, rain_drought, SW1, SW2, fire, stress_drought,
                    maxTemp, minTemp,
                    popDen,
                    buffalo, cattle, goat, sheep,
                    urban, crop, pas,
		    m_drought, min_mat, max_mat,
                    d, p_fire,
                    k_popDen, k_buffalo, k_cattle, k_goat, k_sheep,
                    p_drought, min_maxTemp, max_minTemp,
                    q10_maxTemp, q10_minTemp,
		    v_drought, v_maxTemp, v_minTemp,
                    v_popDen, v_buffalo, v_cattle, v_goat, v_sheep,
                    v_crop, v_pas,
		    MAP0, MAPk, MAT0, MATk, SW0, SWk, Mort0, Mortk, Exc0, Exck, maxT,
		    includeSW = TRUE, ...) {

    f_MAP  = LimMAP  (MAP, rain_drought, m_drought, MAP0 , MAPk, ...)
    #f_MAT  = LimMAT  (MAT, min_mat, max_mat, MAT0 , MATk, ...)

    if (includeSW) f_SW   = LimSW(SW1, SW2  , d, SW0  , SWk, ...)
    else {
	f_SW = f_MAP
	f_SW[!is.na(f_SW)] = 1.0
    }

    f_MAT = f_MAP
    f_MAT[!is.na(f_MAT)] = 1.0

    f_Mort = LimMort (fire, stress_drought, maxTemp, minTemp, popDen,
                      buffalo, cattle, goat, sheep,
                      v_drought, v_maxTemp, v_minTemp,
                      v_popDen, v_buffalo, v_cattle, v_goat, v_sheep,
                      p_fire,
                      k_popDen, k_buffalo, k_cattle, k_goat, k_sheep,
                      p_drought,
                      min_maxTemp, max_minTemp, q10_maxTemp, q10_minTemp,
                      Mort0, -Mortk, ...)

    f_Exc  = LimExc  (urban, crop, pas, v_crop, v_pas, Exc0, -Exck, ...)

    f_SW  = raster::resample(f_SW , f_MAP)
    f_Exc = raster::resample(f_Exc, f_MAP)
    Tree = f_MAP * f_SW * f_Mort * f_Exc * maxT #  * f_MAT
    return(addLayer(Tree, f_MAP, f_MAT, f_SW, f_Mort, f_Exc))
}

logistic <- function(x, x0, k, sensitivity = FALSE) {
    FUN <- function(xi = x, ki = k)  1 / (1 + exp(-ki * (xi - x0)))
    dFUN <- function(xi) FUN(xi, k) * FUN(xi, -k)
    if (sensitivity)
	out = dFUN(x)/ dFUN(x0)
    else
	out = FUN()
    return(out)
}

LimMAP <- function(MAP, drought, m_drought,...){
    #MAP = MAP + (1-drought) * (1/m_drought) * (exp(-m_drought * MAP)-1)
    MAP = log(MAP)
    logistic(MAP, ...)
}

LimMAT <- function(MAT, min_mat, max_mat, ..., retutnVar = FALSE) {
    MAT = MAT - min_mat
    max_mat = max_mat - min_mat

    MAT[MAT <0] = 0

    MAT = logmin(MAT)
    if (retutnVar) return(MAT)
    logistic(MAT, ...)
}

LimList <- function(x, v, ..., retutnVar = FALSE) {
    v = c(1, v)
    x = mapply('*', x, v)
    xi = x[[1]]
    for (i in x[-1]) xi = xi + i

    xi = xi / sum(v)
    if (retutnVar) out = xi else out = try(logistic(xi, ...), silent = TRUE)
    if (class(out) =="try-error") out = xi
    return(out)
}

LimSW   <- function(SW1, SW2, d,...) {
    SW = (SW1 + d * SW2)/(1+d)
    #SW = logmin(SW)

    logistic(SW, ...)
}

LimTREE.convertUnity <- function(x, k)
    1 - exp(x * (-1/k))

LimTREE.Temp <- function(Temp, mn, q10) {
    Temp = (q10 + 1.0)^(Temp - mn)
    return(Temp)
}

LimMort <- function(fire, drought, maxTemp, minTemp, popDen,
                    buffalo, cattle, goat, sheep,
                    v_drought, v_maxTemp, v_minTemp,
                    v_popDen, v_buffalo, v_cattle, v_goat, v_sheep,
		    p_fire,
                    k_popDen, k_buffalo, k_cattle, k_goat, k_sheep,
                    p_drought, min_maxTemp, max_minTemp,
                    q10_maxTemp, q10_minTemp, ...) {

    fire = fire^p_fire
    popDen0 = popDen
    popDen   = LimTREE.convertUnity( popDen, k_popDen )
    buffalo  = LimTREE.convertUnity(buffalo, k_buffalo)
    cattle   = LimTREE.convertUnity( cattle, k_cattle )
    goat     = LimTREE.convertUnity(   goat, k_goat   )
    sheep    = LimTREE.convertUnity(  sheep, k_sheep  )

    maxTemp = LimTREE.Temp(maxTemp     ,  min_maxTemp, q10_maxTemp)
    minTemp = LimTREE.Temp(minTemp*(-1), -max_minTemp, q10_minTemp)
    drought = drought^p_drought

    LimList(c(fire, drought, maxTemp, minTemp,
              popDen, buffalo, cattle, goat, sheep),
            c(v_drought, v_maxTemp, v_minTemp,
              v_popDen, v_buffalo, v_cattle, v_goat, v_sheep), ...)
}

LimExc  <- function(urban, crop, pas, v_crop, v_pas, ...)
    LimList(c(urban, crop, pas), c(v_crop, v_pas), ...)


library(psych)
library(cluster)
library(RColorBrewer)
library(data.table)
library(dendextend)
library(ggplot2)
library(NbClust)
library(scales)
library(extrafont)
library(gridExtra)
library(stats)

# this.dir<- dirname(parent.frame(2)$ofile)
# parent.dir <- strsplit(this.dir,'scripts')[[1]]
# setwd(parent.dir)

f9scores = read.csv('output/fscores-mean-imputed.csv',sep=",",header=TRUE)
f9scores$city <- as.character(f9scores$city)
f9scores$city[326] <- "Valencia(VZL)" #change Valencia for identification of duplicate
f9scores$city <- factor(f9scores$city, levels=f9scores$city[c(1:331)])
num_fac <- 9

### Distances
scaled.f9scores = as.data.frame(apply(as.matrix(f9scores[1:9]), 2, rescale)) #as.data.frame(scale(as.matrix(f9scores[1:9])))
dis9scaled = dist(scaled.f9scores,method="manhattan")
dis9scaled.mat = as.matrix(dis9scaled)
write.csv(scaled.f9scores, 'output/f9scores-scaled.csv', row.names = F)

#num_clust = 12 #This is set in iterate.r

##################################################################################################################
#### Plot dendrogram
##################################################################################################################

## Function to perform clustering
clusterFit <- function(d, m) {
  fit <- hclust(d, method=m) # apply hierarchical clustering
  return(fit)
}

## Get clustering for 9-factor solution
clusfit9scaled.ward = clusterFit(dis9scaled, "ward.D2")

# Compute goodness-of-fit metrics
optClustWardScaled9 <- NbClust(as.data.frame(scaled.f9scores),distance="manhattan", method="ward.D2",min.nc=10,max.nc=15,index="gap")
#optClustWardScaled9 <- NbClust(diss=dis9scaled.mat, method="ward.D2",min.nc=7,index="all")

## Group cities into clusters based on number of clusters desired
getClusters <- function (clusfit, k, scores) {
  #cluster <- dendextend:::cutree(clusfit, k, order_clusters_as_data = TRUE)
  cluster = cutree(clusfit, k)
  clusters = data.frame(cluster)
  row.names(clusters) = scores$city
  return(clusters)
}
fac9clusters.ward.scaled <- getClusters(clusfit9scaled.ward, num_clust, f9scores) #f9scores only for names!!
fac9clusters.ward.scaled.ordered <- fac9clusters.ward.scaled[order(fac9clusters.ward.scaled$cluster),,drop=FALSE]
write.csv(fac9clusters.ward.scaled, paste0('output/clusters-9-factors-ward-scaled.csv'))

typocolors_all = c(
  '#1f78b4', #darkblue
  '#a6cee3', #lightblue
  '#b2df8a', #lightgreen
  '#33a02c',  #darkgreen
  '#fb9a99', #lightred
  '#e31a1c', #darkred
  '#6a3d9a', #darkpurple
  '#cab2d6', #lightpurple
  '#ffff99', #lightbrown
  '#b15928', #darkbrown
  '#fdbf6f', #lightorange
  '#ff7f00', #darkorange
  '#8e0152'  #purple
   )

typocolors = typocolors_all[1:num_clust]
if(num_clust==12){
dendtypolist = c(
  "Auto Innovative", "Auto Sprawl",
  "MassTransit Moderate", "MassTransit Heavyweight",
  "Congested Emerging", "Congested Boomer",
  "MetroBike Giant", "MetroBike Emerging",
  "Hybrid Moderate","Hybrid Giant",
  "BusTransit Sprawl", "BusTransit Dense")
}else{
  dendtypolist = c("Auto Innovative", "Auto Sprawl",
                   "MassTransit Sustainable", "MassTransit Moderate", "MassTransit Heavyweight",
                   "Congested Emerging", "Congested Boomer",
                   "MetroBike Giant", "MetroBike Emerging",
                   "Hybrid Moderate","Hybrid Giant",
                   "BusTransit Moderate", "BusTransit Giant")
}

##################################################################################################################
#### Plot dendrogram
##################################################################################################################
# https://gist.github.com/jslefche/eff85ef06b4705e6efbc
theme_black = function(base_size = 12, base_family = "") {

  theme_grey(base_size = base_size, base_family = base_family) %+replace%

    theme(
      # Specify axis options
      axis.line = element_blank(),
      axis.text.x = element_text(size = base_size*0.8, color = "white", lineheight = 0.9),
      axis.text.y = element_text(size = base_size*0.8, color = "white", lineheight = 0.9),
      axis.ticks = element_line(color = "white", size  =  0.2),
      axis.title.x = element_text(size = base_size, color = "white", margin = margin(0, 10, 0, 0)),
      axis.title.y = element_text(size = base_size, color = "white", angle = 90, margin = margin(0, 10, 0, 0)),
      axis.ticks.length = unit(0.3, "lines"),
      # Specify legend options
      legend.background = element_rect(color = NA, fill = "black"),
      legend.key = element_rect(color = "white",  fill = "black"),
      legend.key.size = unit(1.2, "lines"),
      legend.key.height = NULL,
      legend.key.width = NULL,
      legend.text = element_text(size = base_size*0.8, color = "white"),
      legend.title = element_text(size = base_size*0.8, face = "bold", hjust = 0, color = "white"),
      legend.position = "right",
      legend.text.align = NULL,
      legend.title.align = NULL,
      legend.direction = "vertical",
      legend.box = NULL,
      # Specify panel options
      panel.background = element_rect(fill = "black", color  =  NA),
      panel.border = element_rect(fill = NA, color = "white"),
      panel.grid.major = element_line(color = "grey35"),
      panel.grid.minor = element_line(color = "grey20"),
      panel.spacing = unit(0.5, "lines"),
      # Specify facetting options
      strip.background = element_rect(fill = "grey30", color = "grey10"),
      strip.text.x = element_text(size = base_size*0.8, color = "white"),
      strip.text.y = element_text(size = base_size*0.8, color = "white",angle = -90),
      # Specify plot options
      plot.background = element_rect(color = "black", fill = "black"),
      plot.title = element_text(size = base_size*1.2, color = "white"),
      plot.margin = unit(rep(1, 4), "lines")
    )
}

plotD <- function (clusfit,kk,meth,scores,ff)
{
  dend <- as.dendrogram(clusfit)
  #dend <- reorder(dend, 1:13, mean)
  nodePar <- list(lab.cex = 0.8, pch = c(NA, NA), cex = 1.6,font=2)
  labels(dend) <- as.character(scores$city[clusfit$order])
  #dend <- set(dend, "labels_cex", .45)
  d1=color_branches(dend,k=kk,col = typocolors) # brewer.pal(kk,"Paired"))
  dcol <- get_leaves_branches_col(d1)
  d1 <- color_labels(d1,k=kk,col=typocolors) #brewer.pal(kk,"Paired"))
  png(file=paste0("output/Dendrogram-",kk,"-clusters-",ff,"-factors-Method-",meth,".png"),family="CM Sans", width=5300,height=2600)
  plot(d1)
  #colored_bars(dcol, dend, rowLabels = c("13 Typologies"))
  dev.off()
}
plotD(clusfit9scaled.ward,num_clust,"Ward.D2-Scaled",f9scores,9)

plotDgg <- function (clusfit,kk,meth,scores,ff)
{
  dend <- as.dendrogram(clusfit)
  dend <- assign_values_to_branches_edgePar(dend=dend, value = "white", edgePar = "col")
  dend <- color_branches(dend,k=kk,col = typocolors) # brewer.pal(kk,"Paired"))
  ggd1 <- as.ggdend(dend)
  base <- ggplot(ggd1,labels=FALSE)
  base +
    geom_hline(yintercept=6.2, color="gray",lty=2,lwd=1) +
    geom_hline(yintercept=3.6, color="gray",lty=3,lwd=1) +
    theme_black() +
    theme(panel.border = element_blank(),
            panel.grid.major = element_blank(),
            panel.grid.minor = element_blank(),
            axis.title=element_blank(),
            axis.ticks=element_blank(),
            axis.text=element_blank(),
            legend.position=c(0,1)
          )
}
p1 <- plotDgg(clusfit9scaled.ward,num_clust,"Ward.D2-Scaled",f9scores,9)

idx = c(1:331)
df2<-data.frame(cluster=cutree(clusfit9scaled.ward,num_clust) ,states=factor(idx)) #,levels=idx)) #[clusfit9scaled.ward$order]))
head(df2)
df3 <- df2[order(df2$cluster),]
df3$states <- factor(1:331)
df3$cluster <- factor(df3$cluster, labels = dendtypolist)

p2 <- ggplot(df3,aes(states,y=1,fill=factor(cluster)))+
  geom_tile()+
  #scale_y_continuous(expand=c(0,0)) +
  scale_fill_manual(values = typocolors,breaks=dendtypolist)+
  #scale_fill_discrete( #+ scale_fill_manual(values = typocolors)+
  theme(axis.title=element_blank(),
        axis.ticks=element_blank(),
        axis.text=element_blank(),
        legend.position=c(.85,9.3),
        legend.title=element_blank(),
        legend.text = element_text(colour="white", size=16),
        legend.key.size = unit(1.5, 'lines'),
        legend.key = element_rect(fill = "gray", colour = "transparent"),
        legend.background = element_rect(fill = "transparent", colour = "transparent")
        )

gp1 <-ggplotGrob(p1)
gp2<-ggplotGrob(p2)

maxWidth = grid::unit.pmax(gp1$widths[2:5], gp2$widths[2:5])
gp1$widths[2:5] <- as.list(maxWidth)
gp2$widths[2:5] <- as.list(maxWidth)

loadfonts()
png(file=paste0("output/Dendrogram-GG-clusters-","9","-factors-Method-","Ward.D2-Scaled",".png"),family="CM Sans",width=1200,height=1000,res=100)
#gp1
grid.arrange(gp1, gp2, ncol=1,heights=c(9/10,1/10))

dev.off()


# https://stat.ethz.ch/pipermail/r-help/2008-September/173189.html
library(utils)
oneMonth <- 1.0 / 12.0
tsData <- ts(rnorm(103, 100), start=2000, deltat=oneMonth) # goes until Jul
plot(tsData,ylab="Values",xlab="Zeit",xaxt="n")
axis(1,time(tsData),rep(substr(month.abb,1,1),length=length(tsData)),cex.axis=.3,tcl=-.5)
jan<-time(tsData)[cycle(tsData) == 1]  # january
axis(1,jan,FALSE,tcl=-1)
abline(v=jan,lty=2)


#organizando lo datos
datos<-read.csv("Hoja de Colegios - cop_simpl.csv",dec = ",")
#transformar tipo y valores religiosos a factor
#esto facilita algunos analisis
datos$Tipo<-as.factor(datos$Tipo)
datos$Rel<-as.factor(datos$Rel)
datos <- datos[order(datos$PUNT,decreasing = TRUE),]#de mayor a menor nota
datos

library(ggplot2)
#ordenados por nota
ggplot(data = datos, mapping = aes(x = reorder(Centro, PUNT), PUNT),fill=factor(Tipo)) +
  geom_bar(stat = "identity",col = "black", size = 0.25, width=0.5) + coord_flip()+theme_bw()+
    ylab("puntuación") +xlab("")

table(datos$Tipo,datos$NOTA)

table(datos$Rel,datos$NOTA)
#solo los laicos llegan a tener una nota alta

#suma de valores
valores = colSums(datos[c(4:12)])
names<-c("Fem","Antibul","LGTB","Ecol","Exam","Coop","Dep","Cri","Pluril")
tabla.valores<-data.frame(names,valores)
ggplot(data = tabla.valores, mapping = aes(x = reorder(names,valores ), valores)) +
  geom_bar(stat = "identity",col = "black", size = 0.5, width=0.5) + coord_flip()+theme_bw()+
    ylab("número de centros") +
    xlab("valores")

# overlay histogram and normal density
a<-ggplot(datos, aes(PUNT)) +
  stat_function(
    fun = dnorm,
    args = list(mean = mean(datos$PUNT), sd = sd(datos$PUNT)),
    lwd = 1,
    col = 'black'
  )+theme_bw()+
    ylab("densidad") +
    xlab("puntuación") +
    ggtitle("a) Densidad")
b<-ggplot(datos, aes(PUNT)) +
  geom_histogram()+theme_bw()+
    ylab("frecuencia") +
    xlab("puntuación") +
    ggtitle("b) Histograma")
library(gridExtra)
grid.arrange(a,b,ncol=2)

shapiro.test(log(datos$PUNT))#no normality as data is skewed to the right

median(datos$PUNT)
wilcox.colegios<-wilcox.test(datos$PUNT,mu=5,exact = F)
wilcox.colegios
#http://www.sthda.com/english/wiki/one-sample-wilcoxon-signed-rank-test-in-r

library(rcompanion)
wilcoxonOneSampleR(x = datos$PUNT, mu=5)#tamaño del efecto alto

c<-ggplot(datos,aes(x=Tipo,y=PUNT))+geom_boxplot(fill="grey",outlier.shape = NA)+theme_bw()+
stat_summary(fun="mean",shape=7,size=3)+geom_jitter(width=0.05)+
    ylab("puntuación") +ggtitle("a) Tipo de centro")+xlab("")

d<-ggplot(datos,aes(x=Rel,y=PUNT))+geom_boxplot(fill="grey",outlier.shape = NA)+theme_bw()+
  stat_summary(fun="mean")+ylab("puntuación") +
    ggtitle("b) Valores religiosos")+
stat_summary(fun="mean",shape=7,size=3)+geom_jitter(width=0.05)+xlab("")

grid.arrange(c,d,ncol=2)

kruskal.test(PUNT~Tipo,data=datos)

library(rstatix)
dunn_test(PUNT~Tipo,data=datos, p.adjust.method = "bonferroni")

kruskal_effsize(PUNT~Tipo,data=datos)

library("dplyr")
group_by(datos, Tipo) %>%
  summarise(
    count = n(),
    mean = mean(PUNT, na.rm = TRUE),
    median = median(PUNT, na.rm = TRUE),
    sd = sd(PUNT, na.rm = TRUE),
    se =  sd(PUNT, na.rm = TRUE)/sqrt(n())
    )

wilcox.test(PUNT~Rel,data=datos,exact = F)
wilcox_effsize(PUNT~Rel,data=datos)
#The effect size r is calculated as Z statistic divided by square root of the sample size

group_by(datos, Rel) %>%
  summarise(
    count = n(),
    mean = mean(PUNT, na.rm = TRUE),
    median = median(PUNT, na.rm = TRUE),
    sd = sd(PUNT, na.rm = TRUE),
    se =  sd(PUNT, na.rm = TRUE)/sqrt(n())
    )


# Load h2o library
suppressPackageStartupMessages(library(h2o))

# Start and connect to a local H2O cluster
h2o.init(nthreads = -1)

# Importing data from local CSV
h_secom <- h2o.importFile(path = "secom.csv", destination_frame = "h_secom")

# Print out column names
colnames(h_secom)

# Look at "Classification"
summary(h_secom$Classification, exact_quantiles=TRUE)

# "Classification" is a column of numerical values
# Convert "Classification" in secom dataset from numerical to categorical value
h_secom$Classification <- as.factor(h_secom$Classification)

# Look at "Classification" again
summary(h_secom$Classification, exact_quantiles=TRUE)

# Define target (y) and features (x)
target <- "Classification"
features <- setdiff(colnames(h_secom), target)
print(features)

# Splitting dataset into training and test
h_split <- h2o.splitFrame(h_secom, ratios = 0.7, seed = 1234)
h_train <- h_split[[1]] # 70%
h_test  <- h_split[[2]] # 30%

# Look at the size
dim(h_train)
dim(h_test)

# Check Classification in each dataset
summary(h_train$Classification, exact_quantiles = TRUE)
summary(h_test$Classification, exact_quantiles = TRUE)

# Define the criteria for random grid search
search_criteria = list(strategy = "RandomDiscrete",
                       max_models = 10,
                       seed = 1234)

# Define the range of hyper-parameters for grid search
hyper_params <- list(
    sample_rate = c(0.6, 0.7, 0.8, 0.9),
    col_sample_rate = c(0.6, 0.7, 0.8, 0.9),
    max_depth = c(4, 5, 6)
)

# Set up grid search
# Add a seed for reproducibility
rand_grid <- h2o.grid(

    # Core parameters for model training
    x = features,
    y = target,
    training_frame = h_train,
    ntrees = 500,
    learn_rate = 0.05,
    balance_classes = TRUE,
    seed = 1234,

    # Settings for Cross-Validation
    nfolds = 5,
    fold_assignment = "Stratified",

    # Parameters for early stopping
    stopping_metric = "mean_per_class_error",
    stopping_rounds = 15,
    score_tree_interval = 1,

    # Parameters for grid search
    grid_id = "rand_grid",
    hyper_params = hyper_params,
    algorithm = "gbm",
    search_criteria = search_criteria

)

# Sort and show the grid search results
rand_grid <- h2o.getGrid(grid_id = "rand_grid", sort_by = "mean_per_class_error", decreasing = FALSE)
print(rand_grid)

# Extract the best model from random grid search
best_model_id <- rand_grid@model_ids[[1]] # top of the list
best_model <- h2o.getModel(best_model_id)
print(best_model)

# Check performance on test set
h2o.performance(best_model, h_test)

# Use the model for predictions
yhat_test <- h2o.predict(best_model, h_test)

# Show first 10 rows
head(yhat_test, 10)


library("ggplot2")
setwd("~/dev/BitFunnel/src/Scripts")

df <- read.csv(header=TRUE, file="/tmp/compare-docfreqs.csv")

print("Creating plot.")
png(filename="docfreqs.png",width=1600,height=1200)
ggplot(df, aes(x=idf1,y=idf2)) +
theme_minimal() +
# scale_x_log10() +
# scale_y_log10() +
geom_point(alpha=1/10) +
theme(axis.text = element_text(size=40),
      axis.title = element_text(size=40))
dev.off()


####################################
#Lecture on color, Trevor Branch, FISH554
#Using color in R
#Look at Stowers Guide to color on class website
#for named colors
####################################

library(tidyverse)
library(RColorBrewer)

#list of named colors in R
colors()

#create some random data, with sorted y values
values <- as_tibble(cbind(x=1:10,
      y=sort(sample(1:100, size=10, replace=TRUE))))
values

#the default barplot
ggplot(data=values, aes(x=x, y=y)) +
   geom_col() +
   theme_minimal()

#color the bars by the values in the bars
ggplot(data=values, aes(x=x, y=y, fill=y)) +
   geom_col() +
   theme_minimal()

#change the default colors of all bars, color=outline, fill=inside
ggplot(data=values, aes(x=x, y=y)) +
   geom_col(fill='darkgreen', color='black') +
   theme_minimal()

#create a smooth set of colors between two colors using
#scale_fill_gradient
ggplot(data=values, aes(x=x, y=y, fill=y)) +
   geom_col() + theme_minimal() +
   scale_fill_gradient(low='red', high='blue')

#create a custom diverging palette with a midpoint using
#scale_fill_gradient2, midpoint is value of middle of scale
#limits let you decide what value is the low color and high color
ggplot(data=values, aes(x=x, y=y, fill=y)) +
   geom_col() + theme_minimal() +
   scale_fill_gradient2(low='red', mid='gray90', high='blue',
                        midpoint=50, limits=c(0,100))

#change the fill colors to a smooth palette of lots of colors
#color is related to the height of the bar
#rich.colors() is a better palette than rainbow()
library(gplots)
ggplot(data=values, aes(x=x, y=y, fill=y)) +
   geom_col() +
   theme_minimal() +
   scale_fill_gradientn(colors = rich.colors(n=10))

#instead just color each bar a different color unrelated to the
#values (remove from the aes() function)
ggplot(data=values, aes(x=x, y=y)) +
   geom_col(fill = rich.colors(n=10)) +
   theme_minimal()

#points instead of bars, shape 21 is circle with different outer
#and inner bars, use nrow() to find out how many colors to select
ggplot(data=values, aes(x=x, y=y)) +
   geom_point(fill = rich.colors(n=nrow(values)), color='black',
              size=10, shape=21) +
   theme_minimal()

#==========colorBrewer================================================
library(RColorBrewer)
display.brewer.all()

#only plot the first 8 values (too many values for colors for all)
ggplot(data=values[1:8,], aes(x=x, y=y)) +
   geom_point(fill = brewer.pal(n=8, name='Dark2'),
              size=10, shape=21) +
   theme_minimal()

#go to website and look for colors www.colorbrewer2.org
#this is what I do since it is easy to see how good they look on a map
bcolors <- c('#e41a1c', '#377eb8', '#4daf4a', '#984ea3', '#ff7f00')
ggplot(data=values[1:5,], aes(x=x, y=y)) +
   geom_point(fill = bcolors, size=10, shape=21) +
   theme_minimal()

#use colorbrewer as a palette to interpolate between colors
#scale_fill_gradientn means interpolate between whatever colors
# you give it, limit sets the minimum for the lowest color
# and NA allows the default upper value to stand
display.brewer.all()
ggplot(data=values, aes(x=x, y=y, fill=y)) +
   geom_col() + theme_minimal() +
   scale_fill_gradientn(colors=brewer.pal(n=7,name='Oranges'),
                        limit=c(0,NA))

#=====transparency==========================
#create some random data from two normal distributions
set.seed(100) #so that random draws can be repeated
values2 <- as_tibble(cbind(x=rnorm(1000), y=rnorm(1000)))

#shape 21 is a circle with outline=color, fill=fill
ggplot(data=values2, aes(x=x, y=y)) +
   geom_point(color='black', fill = 'red', size=5, shape=21) +
   theme_minimal()

#shape 16 is circle of just one color
#alpha = 0.2 is very transparent (0 <= alpha <= 1)
ggplot(data=values2, aes(x=x, y=y)) +
   geom_point(color = 'red', size=5, shape=16, alpha=0.2) +
   theme_minimal()

#less transparent
ggplot(data=values2, aes(x=x, y=y)) +
   geom_point(color = 'red', size=5, shape=16, alpha=0.6) +
   theme_minimal()

#only want fill to be transparent but outer line of circle solid
#note: adding 5 circles with alpha = 0.2 results in solid color
ggplot(data=values2, aes(x=x, y=y)) +
   geom_point(size=5, shape=21,
              color='red',
              fill = adjustcolor(col='red',alpha.f=0.2)) +
   theme_minimal()

#====miscellaneous useful functions
col2rgb('yellow')  #return the red, green, blue components of a color

#convert RGB colors scaled from 0 to 1 into a hexadecimal number
rgb(1.0, 1.0, 0.0)

#convert RGB integers between 0 and 255 into hexadecimal
rgb(255, 255, 0, maxColorValue=255)

#return all named colors with "red" in their names
#'grep' = useful command to return locations of matches of strings
#         within vectors
colors()[grep('red',colors())]


library(ggplot2)
source("date.r")
source("map.r")
source("explore-data.r")
theme_set(theme_bw())

# Look at quality first ------------------------------------------------------

as.data.frame(prop.table(table(geo$quality)) * 100)

# Explore distribution of various groupings ----------------------------
qplot(long, lat, data = geo)

labels <- list(
  labs(x = NULL, y = NULL),
  opts(axis.text.x = theme_blank()),
  opts(axis.text.y = theme_blank())
)

loc <- ggplot(geo, aes(long, lat)) + labs(x = NULL, y = NULL)

loc + geom_bin2d(bins = 100) + bayarea
loc + geom_point(shape = ".") + bayarea

loc + geom_point(aes(colour = county), shape = ".")
loc + geom_point(shape = ".") + facet_wrap(~ city)

# Experiment with binning ----------------------------------------------------

source("map.r")
qplot(long, lat, data = geo, xlim=rlong, ylim=rlat, geom="bin2d", binwidth = c(.2,.2)) + camap

# Create 0.2 x 0.2 grid
geo$longr <- round_any(geo$long, 0.2)
geo$latr <- round_any(geo$lat, 0.2)

geo$month <- geo$date
mday(geo$month) <- 15
geo$month <- as.Date(geo$month)

binned <- ddply(geo, .(longr, latr, month), function(df) {
  data.frame(n = nrow(df), avg = mean(df$price, na.rm = T))
}, .progress = "text")

qplot(month, n, data=binned, geom="line", group=interaction(longr,latr))

# Look at geocoded addresses in SF -------------------------------------------
# Can we see how the city has grown?
sf <- subset(geo, county == "San Francisco County" & quality %in% c("QUALITY_ADDRESS_RANGE_INTERPOLATION", "QUALITY_EXACT_PARCEL_CENTROID"))

# 25000 houses
qplot(year, data = sf, binwidth = 1)
qplot(year, data = sf, binwidth = 10)
sf$decade <- paste(round_any(sf$year, 10, floor), "s", sep="")

ggplot(sf, aes(long, lat)) + geom_point(shape = ".") + labels
ggsave(file = "beautiful-data/graphics/sf-geo.pdf", width = 8, height = 6)
ggsave(last_plot() + coord_flip(), file = "beautiful-data/graphics/sf-geo-big.pdf", width = 8, height = 11.5)

# Aggregate into bins and compute summaries -------------------
# This seems to do the best job of showing where the new and old houses
# are.
sf <- within(sf, {
  lat_round <- round_any(lat, 0.005)
  long_round <- round_any(long, 0.005)
})

built <- ddply(sf, .(lat_round, long_round),  function(df) {
  with(df, data.frame(
    n = nrow(df),
    avg_year = mean(year, na.rm = TRUE),
    sd = sd(year, na.rm = TRUE),
    iqr = IQR(year, TRUE),
    price_avg = mean(price, na.rm = TRUE),
    price_sd = sd(price, na.rm = TRUE),
    price_q1 = quantile(price, 0.1, na.rm = TRUE),
    price_median = median(price, na.rm = TRUE),
    price_q9 = quantile(price, 0.9, na.rm = TRUE)
  ))
}, .progress = "text")
built <- subset(built, n >= 5)

grey_scale <- scale_fill_gradient(low="grey80", high="black")

qplot(long_round, lat_round, data = built, fill = n, geom="tile") +
  grey_scale +
  labels +
  labs(fill = "Number\nof houses")
ggsave(file = "beautiful-data/graphics/sf-bin-n.pdf", width = 8, height = 6)

sf$loc <- paste(sf$lat, sf$long, sep ="-")
overlaps <- as.data.frame(table(sf$loc))
names(overlaps) <- c("loc", "n")

sf <- merge(sf, overlaps, by = "loc")
ggplot(sf, aes(long, lat, size = n)) +
  geom_point(stat = "unique", colour = alpha("black", 0.5)) +
  scale_area(to = c(0.3, 6), breaks = c(1, 50, 100, 200, 252)) +
  labels
ggsave(file = "beautiful-data/graphics/sf-geo-n.pdf", width = 8, height = 6)

# # The large numbers appear to represent apartment buildings
# apt <- subset(sf, loc == "37.786586--122.393573")$street
# aptno <- as.numeric(gsub("355 1st Street( \\\\#)?S?", "", apt))
# length(unique(aptno))

# Explore prices -------------------------------------------------------

qplot(price_avg, price_median, data=built)
qplot(price_median, price_q9 - price_q1, data=built)
qplot(price_median, (price_q9 - price_q1) / price_median, data=built)

qplot(long_round, lat_round, data = built, fill = price_avg / 1e6, geom="tile") + labels + grey_scale + labs(fill = "Average\nprice")
ggsave(file = "beautiful-data/graphics/sf-bin-price.pdf", width = 8, height = 6)

# Locate expensive areas
expensive <- subset(built, price_avg / 1e6 > 1)
ggplot(sf, aes(long, lat)) +
  geom_point(stat = "unique", size = 0.5) +
  geom_point(aes(long_round, lat_round, size = price_avg), colour = alpha("red", 0.5), data = expensive) +
  scale_area(to = c(2, 4))

subset(expensive, lat_round < 37.74)

qplot(long_round, lat_round, data = built, fill = (price_sd) / price_avg, geom="tile") + labels + grey_scale + labs(fill = "c.v.")
ggsave(file = "beautiful-data/graphics/sf-bin-cv.pdf", width = 8, height = 6)

# Explore year built ---------------------------------------------------

qplot(long_round, lat_round, data = built, fill = iqr, geom="tile") + labels + grey_scale + labs(fill = "Inter-quartile\nrange")
ggsave(file = "beautiful-data/graphics/sf-bin-iqr.pdf", width = 8, height = 6)

qplot(long_round, lat_round, data = built, fill = avg_year, geom="tile") + labels + grey_scale + labs(fill = "Average\nyear\nbuilt")
ggsave(file = "beautiful-data/graphics/sf-bin-built.pdf", width = 8, height = 6)

qplot(long_round, lat_round, data = built, fill = sqrt(avg_price / 1e6), geom="tile") + labels + grey_scale + labs(fill = "Average\nprice")
ggsave(file = "beautiful-data/graphics/sf-bin-price.pdf", width = 8, height = 6)


#!/usr/bin/Rscript

## Author: David Eccles (gringer), 2008 <programming@gringer.org>

## stats2contour.r -- converts a delta summary file into a Minor Allele Frequency contour graph

source('/itsshared/phd/common.r')
library(cairoDevice)

usage <- function(){
  cat("usage: ./stats2contour.r <file>\n");
}

table.delta <- read.table(commandArgs(TRUE)[1],
                          header = TRUE, row.names = 1)

A.names <- names(table.delta)[grep("p.A",names(table.delta))];

## determine minor allele frequencies, and comparative SNP in other population
table.delta$MAF.p1 <- table.delta[A.names[1]];
names(table.delta$MAF.p1) <- "MAF.p1";
table.delta$comp.p2 <- table.delta[A.names[2]];
names(table.delta$comp.p2) <- "comp.p2";
##make sure this is minor allele frequency, compare with same allele
##in second population
major.locs <- which(table.delta$MAF.p1 > 0.5);
table.delta$MAF.p1[major.locs,] =
  1 - (table.delta$MAF.p1[major.locs,])
table.delta$comp.p2[major.locs,] =
  1 - (table.delta$comp.p2[major.locs,])
# population names
pn <- sub("\\.","",sub("p.A.","",A.names));

##pdf(paste("histdelta_",pn[1],"_",pn[2],".pdf", paper = "a4");
##hist(table.delta$delta, main = paste(
##     "Histogram of Delta values for each SNP\n(",
##                                  pn[1]," vs ",pn[2],")",sep=""), col =
##     "red", xlab = "Delta", xlim = c(0,1));

## dev.off()

for(dx in seq(0,1,by=0.1)){
  cat("Number of SNPs with delta >= ",dx,": ",length(which(abs(table.delta$MAF.p1 - table.delta$comp.p2) >= dx)),"\n", sep="");
}

library(MASS); # for kde2d
dd <- kde2d(unlist(table.delta$MAF.p1), unlist(table.delta$comp.p2),
            lims = c(0,0.5,0,1));

pdf(paste("contour_MAF_",pn[1],"_",pn[2],".pdf",sep=""))
#Cairo_svg(paste("contour_MAF_",pn[1],"_",pn[2],".svg",sep=""))
par(cex.axis = 1.5, cex.lab = 1.5, mar = c(4.5,4.7,2,1));
filled.contour(dd, nlevels = 40,
               xlab = paste("MAF(",pn[1],")",sep=""),
               ylab = paste("f(",pn[2],")",sep=""),
##               main = paste("Contour graph of ",pn[1]," Minor Allele ",
##               "Frequencies", "\n(",pn[2]," vs ",pn[1],")",sep=""),
               levels = c(exp(pretty(log(c(1,max(dd$z)+1)),39))-1),
               col = rainbow(40), cex = 1.5, cex.main = 1.5, cex.axis=1.5,
               ylim = c(0,1), xlim = c(0,0.5))
dummy <- dev.off();


#  James Rekow

conGraphCreator = function(graphMethod, graphArgs, M){

  #  ARGS: graphMethod - method used to create connectivity graph
  #        graphArgs - a named list of values to be used in the method specified by graphMethod.
  #
  #  RETURNS: conGraph - connectivity graph whose vertices represent samples and whose edges
  #                      represent pairs of samples with the potential to interact

  #  current graphMethods and required graphArgs:
  #    "cSub": numI
  #    "smallWorld": numI, dim, nei, p
  #    "ranGNM": numI, p.or.m
  #    "ranGNP": numI, p.or.m
  #    "scaleFree": numI, power

  library(igraph)
  source("embedGraph.r")

  #  list of currently available methods
  methodList = c("cSub", "smallWorld", "ranGNM", "ranGNP", "scaleFree")

  #  check that the supplied graphMethod is supported
  if(!(graphMethod %in% methodList)){
    stop(paste("In conGraphCreator an invalid graphMethod was selected. Currently
               available graphMethods are:", paste(methodList, collapse = ", "), "."))
  } #  end if

  ##  implement graphMethod to create connectivity graph for interacting samples

  if(graphMethod == "cSub"){

    args = c(graphArgs, list(n = graphArgs$numI, directed = FALSE, loops = FALSE))
    args$numI = NULL
    intGraph = do.call(make_full_graph, args)

  } #  end csub

  if(graphMethod == "smallWorld"){

    args = c(graphArgs, list(size = graphArgs$numI, loops = FALSE, multiple = FALSE))
    args$numI = NULL
    intGraph = do.call(sample_smallworld, args)

  } #  end smallworld

  if(graphMethod == "ranGNM"){

    args = c(graphArgs, list(n = graphArgs$numI, type = "gnm", directed = FALSE, loops = FALSE))
    args$numI = NULL
    intGraph = do.call(erdos.renyi.game, args)

  } #  end ranGNM

  if(graphMethod == "ranGNP"){

    args = c(graphArgs, list(n = graphArgs$numI, type = "gnp", directed = FALSE, loops = FALSE))
    args$numI = NULL
    intGraph = do.call(erdos.renyi.game, args)

  } #  end ranGNP

  if(graphMethod == "scaleFree"){

    args = c(graphArgs, list(n = graphArgs$numI, algorithm = "psumtree", directed = FALSE,
                             out.pref = TRUE))
    args$numI = NULL
    intGraph = do.call(sample_pa, args)

  } #  end scaleFree

  #  embed connectivity graph inside graph representing entire base cohort
  conGraph = embedGraph(M = M, intGraph = intGraph)

  return(conGraph)

  } #  end conGraphCreator function


# Simulation study: drifting AR(1) model

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(df) {
  compare(df, read.baro('KNMI_20200312_hourly'))
}

# plot(arima.sim(n = 10000, list(ar = c(0.9)), sd = sqrt(23.62)) + 1033.64)
# plot(forecast:::simulate.Arima(fit.arima, 10000))

df.drifter <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2010-01-01 00:00:00'), to = as.POSIXct('2020-01-01 00:00:00'), by = '12 hours'),
  PRESSURE_VALUE = arima.sim(n = 7305, list(ar = c(0.9)), sd = sqrt(23.62)) + 1033.64 + c(rep(0, 3000), 1:4305)*0.005,
  key = 'TIMESTAMP_UTC'
)

arima(df.drifter$PRESSURE_VALUE, order = c(1, 0, 0))
plot(df.drifter$PRESSURE_VALUE)

df.diff <- ref.compare(df.drifter)
plot(df.diff$PRESSURE_DIFF)

# AR(1) component in case of difference between two barometers -----------------
sim <- function(n, mu, sigma, phi1, betas = NULL, xreg = NULL,
                init = mu, xt = NULL, a = rnorm(n, 0, sd = sigma)) {

  R <- rep(0, n)
  if (!is.null(betas) || !is.null(xreg)) {
    reg <- xreg[-1,,drop=FALSE] - phi1*xreg[-n,,drop=FALSE]
    R <- c(0, reg %*% betas)
  }

  if (is.null(xt)) {
    # xp is the previous x: x_{t-1}
    Reduce(f = function(xp, t) phi1*xp + mu*(1-phi1) + R[t] + a[t], x = 2:n, init = init, accumulate = TRUE)
  } else {
    c(xt[1],
      phi1*xt[-n] + mu*(1-phi1) + R[-1] + a[-1])
  }
}

set.seed(2020)
correlated.errors <- data.table::as.data.table(
  MASS::mvrnorm(1e5, mu = c('a' = 0, 'b' = 0), Sigma = matrix(c(23, 20, 20, 23), ncol = 2))
)
cov(correlated.errors$a, correlated.errors$b)

## all equal: OK (error due to correlation is small --> -2*covariance)
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.9, mu = 1032, a = correlated.errors$a),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1032, a = correlated.errors$b)
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)

## uncorrelated: OK (error = the sum of individual errors)
set.seed(2020)
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.9, mu = 1020, sigma = sqrt(23)),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1035, sigma = sqrt(23))
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)

## mu different: OK (new mu = difference between the two)
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.9, mu = 1020, a = correlated.errors$a),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1035, a = correlated.errors$b)
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)

## sigma different: OK (new sigma: addition of the two minus 2*cov)
set.seed(2020)
correlated.errors.different.sigma <- data.table::as.data.table(
  MASS::mvrnorm(1e5, mu = c('a' = 0, 'b' = 0), Sigma = matrix(c(10, 15, 15, 23), ncol = 2))
)
cov(correlated.errors.different.sigma$a, correlated.errors.different.sigma$b)
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.9, mu = 1035, a = correlated.errors.different.sigma$a),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1035, a = correlated.errors.different.sigma$b)
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)

## phi different: MA component seems necessary, new sigma larger
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.5, mu = 1035, a = correlated.errors$a),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1035, a = correlated.errors$b)
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)

## phi different & uncorrelated: MA component seems necessary, new sigma larger
set.seed(2020)
df.diff <- data.table::data.table(
  TIMESTAMP_UTC = seq(from = as.POSIXct('2001-01-01 00:00:00'), by = '12 hours', length.out = 1e5),
  BARO_01 = sim(n = 1e5, phi1 = 0.5, mu = 1035, sigma = sqrt(23)),
  BARO_02 = sim(n = 1e5, phi1 = 0.9, mu = 1035, sigma = sqrt(23))
)
df.diff[, DIFF := BARO_01 - BARO_02]
forecast::auto.arima(df.diff$DIFF, trace = TRUE, stationary = TRUE)


AMlet = function(y,X,thresh.value="universal", sigma=NA, p=1, low.level=4, by.level=F, filter.number=2, family="DaubExPhase", bc="periodic", conv.thresh=1.e-10, max.iter=ncol(X)*1000){
  ## Fits additive models using wavethresh

    N=length(y)
    P=ncol(X)
    continue=T
    Xo=apply(X,2,order)
    Xr=apply(X,2,rank)

    ## linear model fit
    outlm=lm(y~X, model=T)
    alpha0=outlm$coef[1]
    Shat=t(outlm$coef[-1]*t(X))
    res=y-alpha0-apply(Shat,1,sum)
    iter=0
    sigmahat=mad(outlm$res)
    if(is.numeric(sigma)) sigmahat=sigma
    while(continue&(iter<max.iter)){
      iter=iter+1
      Shat0=Shat
      sigmahatnew=c()
      for(pp in 1:P){
        resp=res+Shat[,pp]
        respo=resp[Xo[,pp]]
        outp=wavethresh(respo, thresh.value, sigmahat, p, low.level, by.level, filter.number, family, bc)
        Shatp=outp$mu.hat[Xr[,pp]]
        res=resp-Shatp
        Shat[,pp]=Shatp
        if(!is.numeric(sigma)){
          ytHaar=wd(respo,1,family="DaubExPhase")
          sigmahatnew=c(sigmahatnew,mad(accessD(ytHaar,log(N,2)-1),center=0))
        }
      }
      if(!is.numeric(sigma)) sigmahat=(sigmahat+median(sigmahatnew))/2
      else sigmahat=sigma
      alpha0new=mean(res+alpha0)
      res=res+alpha0-alpha0new
      alpha0=alpha0new
      continue=((mean(abs(Shat-Shat0))/mean(abs(Shat)))>conv.thresh)
    }

  out=NULL
  out$Shat=Shat
  out$alpha0=alpha0
  out$muhat=alpha0+apply(Shat,1,sum)
  out$sigmahat=sigmahat
  out$Xo=Xo
  out$outlm=outlm
  out$converged=(iter<max.iter)
  return(out)
}


# load data
depdata = read.csv("C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\dependencies\\dependencydone_for_stat.csv")

depdata$positive = as.numeric(depdata$positive)
depdata$negative = as.numeric(depdata$negative)
depdata$functional = as.numeric(depdata$functional)
depdata$structural = as.numeric(depdata$structural)
depdata$descriptive = as.numeric(depdata$descriptive)
depdata$instruction = as.numeric(depdata$instruction)
depdata$interCLT = as.numeric(depdata$interCLT)
depdata$other = as.numeric(depdata$other)

library(sqldf)
depstat = sqldf("select governor, relation, dependant, sum(positive) as npositive, count(*)  as nobs from depdata group by governor, relation, dependant")

# Compute population statistic
prc.positive.total <- sum(depstat$npositive) / sum(depstat$nobs)

expected.positive <- depstat$nobs * prc.positive.total

delta.positive <- depstat$npositive - expected.positive

# The standard deviation of a binomial variable
std.deviation <- sqrt(depstat$nobs * prc.positive.total * (1 - prc.positive.total))

depstat$z.score <- delta.positive / std.deviation

write.table(depstat, "C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\dependencies\\Probs\\depstat.csv", sep=",")

# DONE: Now let's test on actual data

par.size <- 5
paragraph <- sample(1:nrow(all.deps), par.size)

w <- sum(all.deps[paragraph, 'z.score']) / sqrt(par.size)


# R Code
# Complexity Measure Experiment
# L. Garcia, A. Lorena, M. de Solto 2017
# Extract complexity measures from the datasets

formulae <- function(cls) {
  formula(paste(cls, "~", paste(MEASURES, collapse="+")))
}

oracle <- function(fun, tran, test) {

  lapply(CLASSIFIERS, function(c) {
    t(mapply(function(tran, test) {
    eval(call(fun, formulae(c), tran, test))
    }, tran=tran, test=test))
  })

}

root <- function() {

  data = read()
  distribution(data)
  histogram(data)

  tmp = leaveout(data)
  aux = oracle("evaluation", tmp$tran, tmp$test)
  boxplot(aux)

  aux = oracle("prediction", tmp$tran, tmp$test)
  performance(data, aux)
  features(data)
}


#!/usr/bin/env Rscript

# See the NOTICE file distributed with this work for additional information
# regarding copyright ownership.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#How to plot the Jaccard index:
#Rscript plotLorentzCurve.r <INPUT> <OUTPUT.pdf>

args = commandArgs(trailingOnly=TRUE)

if (length(args)==0) {
    stop("Missing arguments: Rscript plotLorentzCurve.r <INPUT> <OUTPUT.pdf>", call.=FALSE)
}

library(ineq)
library(scales)

pdf(args[2])

A <- read.table(args[1],header=FALSE, sep="\t")
current<-as.numeric(A$V2)
previous<-as.numeric(A$V1)

lorentz_curve_current<-Lc(current, n = rep(1,length(current)), plot =F)
clorentz_curve_previous<-Lc(previous, n = rep(1,length(previous)), plot =F)
plot(clorentz_curve_previous, col="red",lty=1,lwd=3,main="Lorenz Curve of cluster size distributions",xlab="percentage of clusters", ylab="percentage of cluster size " )
lines(lorentz_curve_current,lty=1, lwd=3,col="blue")
legend("topleft", c( "previous", "current" ), lty=c(1,1), lwd=3, col=c("red", "blue"))

dev.off()


require(graphics)
require(Matrix)

pdf(file="plots/Experiment5a.pdf",
  width=5, height=4.0, family="serif", pointsize=14)

points = as.vector(seq(1,10));
input = as.matrix(read.table("results/Experiment5a_times.dat", sep=",")[3])
data = colMeans(matrix(input, 3, 10))/1000
data2 = data[1]*points;

plot_colors <- c("orange","black")

plot(   points, data,
        type="o",
        pch=25,
        cex=1.1,
        col=plot_colors[1],
        ylim = c(0,7300),
        xlab="",
        ylab="",
        axes=FALSE,
        bg=plot_colors[1],
        log="",
        lwd=1.1,
        lty=1
  )

axis(2, las=2) # horizontal y axis
axis(1, las=1)      # horizontal x axis
mtext(2, text="Execution Time [s]",line=2.8)
mtext(1, text="Row Replication Factor (x 2,458,285)",line=2)

lines(points, data2, type="l", lty=2, lwd=1.1, col=plot_colors[2], cex=1.0)

#segments(16,0,16,570, lty=2, lwd=1.1)
text(9,900,"scale-up")

box()

legend( "topleft",
       c("USCensus","Ideal Scaling"), col=plot_colors, pt.bg=plot_colors,
       pch=c(25,NA), lty=c(1,2), lwd=c(1.1), bty="n");

dev.off()