###############################################################################################################################################
#  fitted method for class marssMLE.
##############################################################################################################################################
fitted.marssMLE <- function(object, ...,
                            type = c("ytT", "xtT", "ytt", "ytt1", "xtt1"),
                            interval = c("none", "confidence", "prediction"),
                            conf.level = 0.95,
                            output = c("tibble", "matrix")) {
  type <- match.arg(type)
  output <- match.arg(output)
  interval <- match.arg(interval)
  conditioning <- substring(type, 3)
  type <- substr(type, 1, 1)
  MLEobj <- object
  if (is.null(MLEobj[["par"]])) {
    stop("fitted.marssMLE: The marssMLE object does not have the par element.  Most likely the model has not been fit.", call. = FALSE)
  }
  if (interval != "none" && (!is.numeric(conf.level) || length(conf.level) != 1 || conf.level > 1 || conf.level < 0))
    stop("fitted.marssMLE: conf.level must be a single number between 0 and 1.", call. = FALSE)
  alpha <- 1-conf.level
  extras <- list()
  if (!missing(...)) {
    extras <- list(...)
    if ("one.step.ahead" %in% names(extras)) stop("fitted.marssMLE: Use type='ytt1' or 'xtt1' instead of one.step.ahead=TRUE.", call. = FALSE)
  }

  # need the model dims in marss form with c in U and d in A
  model.dims <- attr(MLEobj[["marss"]], "model.dims")
  TT <- model.dims[["x"]][2]
  n <- model.dims[["y"]][1]
  m <- model.dims[["x"]][1]

  if (type == "y") {
    if (conditioning == "T") hatxt <- MARSSkf(MLEobj)[["xtT"]]
    if (conditioning == "t1") hatxt <- MARSSkf(MLEobj)[["xtt1"]]
    if (conditioning == "t") hatxt <- MARSSkfss(MLEobj)[["xtt"]]
    if(interval!="none"){
      if (conditioning == "T") hatVt <- MARSSkf(MLEobj)[["VtT"]]
      if (conditioning == "t1") hatVt <- MARSSkf(MLEobj)[["Vtt1"]]
      if (conditioning == "t") hatVt <- MARSSkfss(MLEobj)[["Vtt"]]
    }
    Z.time.varying <- model.dims[["Z"]][3] != 1
    A.time.varying <- model.dims[["A"]][3] != 1
    R.time.varying <- model.dims[["R"]][3] != 1

    val <- matrix(NA, n, TT)
    rownames(val) <- attr(MLEobj$marss, "Y.names")
    if(interval!="none") se <- val

    Zt <- parmat(MLEobj, "Z", t = 1)$Z
    At <- parmat(MLEobj, "A", t = 1)$A
    Rt <- parmat(MLEobj, "R", t = 1)$R

    for (t in 1:TT) {
      # parmat returns marss form
      if (Z.time.varying) Zt <- parmat(MLEobj, "Z", t = t)$Z
      if (A.time.varying) At <- parmat(MLEobj, "A", t = t)$A
      val[, t] <- Zt %*% hatxt[, t, drop = FALSE] + At
      if(interval=="confidence")
        se[, t] <- takediag(Zt %*% tcrossprod( hatVt[, , t], Zt))
      if(interval=="prediction"){
        if (R.time.varying) Rt <- parmat(MLEobj, "R", t = t)$R
        se[, t] <- takediag(Zt %*% tcrossprod( hatVt[, , t], Zt) + Rt)
      }
    }

    # Set up output
    if(output=="tibble"){
      data.names <- attr(MLEobj[["model"]], "Y.names")
      data.dims <- attr(MLEobj[["model"]], "model.dims")[["y"]]
      nn <- data.dims[1]
      TT <- data.dims[2]
      ret <- data.frame(
        .rownames = rep(data.names, each = TT),
        t = rep(1:TT, nn),
        y = vec(t(MLEobj[["model"]]$data))
      )
    }

  }

  if (type == "x") {
    if (conditioning == "T") hatxt <- MARSSkf(MLEobj)[["xtT"]]
    if (conditioning == "t1") hatxt <- MARSSkfss(MLEobj)[["xtt"]]
    if (interval!="none"){
      if (conditioning == "T") hatVt <- MARSSkf(MLEobj)[["VtT"]]
      if (conditioning == "t1") hatVt <- MARSSkfss(MLEobj)[["Vtt"]]
    }

    B.time.varying <- model.dims[["B"]][3] != 1
    U.time.varying <- model.dims[["U"]][3] != 1
    Q.time.varying <- model.dims[["Q"]][3] != 1

    val <- matrix(NA, m, TT)
    rownames(val) <- attr(MLEobj[["marss"]], "X.names")
    if(interval!="none") se <- val

    x0 <- coef(MLEobj, type = "matrix")[["x0"]]
    if(interval!="none") V0 <- coef(MLEobj, type = "matrix")[["V0"]]
    Bt <- parmat(MLEobj, "B", t = 1)[["B"]]
    Ut <- parmat(MLEobj, "U", t = 1)[["U"]]
    Qt <- parmat(MLEobj, "Q", t = 1)[["Q"]]
    if (MLEobj$model$tinitx == 0){
      val[, 1] <- Bt %*% x0 + Ut
      if (interval=="confidence") se[, 1] <- takediag(Bt %*% tcrossprod(V0, Bt))
      if (interval=="prediction") se[, 1] <- takediag(Bt %*% tcrossprod(V0, Bt) + Qt)
    }
    if (MLEobj[["model"]][["tinitx"]] == 1){
      val[, 1] <- x0
      if(interval != "none") se[, 1] <- takediag(V0)
    }
    for (t in 2:TT) {
      if (B.time.varying) Bt <- parmat(MLEobj, "B", t = t)[["B"]]
      if (U.time.varying) Ut <- parmat(MLEobj, "U", t = t)[["U"]]
      val[, t] <- Bt %*% hatxt[, t - 1, drop = FALSE] + Ut
      if (interval=="confidence")
        se[, t] <- takediag(Bt %*% tcrossprod( hatVt[, ,t-1], Bt))
      if (interval=="prediction"){
        if (Q.time.varying) Qt <- parmat(MLEobj, "Q", t = t)[["Q"]]
        se[, t] <- takediag(Bt %*% tcrossprod( hatVt[, ,t-1], Bt) + Qt)
      }
    }

    # Set up output
    if(output=="tibble"){
    state.names <- attr(MLEobj[["model"]], "X.names")
    state.dims <- attr(MLEobj[["model"]], "model.dims")[["x"]]
    mm <- state.dims[1]
    TT <- state.dims[2]

    ret <- data.frame(
      .rownames = rep(state.names, each = TT),
      t = rep(1:TT, mm),
      xtT = vec(t(MLEobj[["states"]]))
    )
    }
  }

  if (interval=="none"){
    if(output=="matrix") return(val)
    retlist = list(.fitted=val)
  }
  if (interval=="confidence"){
    se[se<0 & abs(se)<sqrt(.Machine$double.eps)] <- 0
    se <- sqrt(se) # was not sqrt earlier
    retlist <- list(
        .fitted = val,
        .se.fit = se,
        .conf.low = val + qnorm(alpha/2) * se,
        .conf.up = val + qnorm(1- alpha/2) * se
    )
  }
  if (interval=="prediction"){
    se[se<0 & abs(se)<sqrt(.Machine$double.eps)] <- 0
    se <- sqrt(se) # was not sqrt earlier
    if (type == "x"){
      retlist <-list(
      .fitted = val,
      .sd.x = se,
      .lwr = val + qnorm(alpha/2) * se,
      .upr = val + qnorm(1- alpha/2) * se
    )
    }
  if (type == "y"){
    retlist <- list(
      .fitted=val,
      .sd.y=se,
      .lwr = val + qnorm(alpha/2) * se,
      .upr = val + qnorm(1- alpha/2) * se
    )
  }
  }
  if(output=="matrix") return(retlist)
  return(cbind(ret, as.data.frame(lapply(retlist, function(x){vec(t(x))}))))
} # end of fitted.marssMLE


source("model/act-s.r")
source("model/models.r")
library(dplyr)
options(dplyr.width=1000)

###############################################################
## Parameter space original model
###############################################################
reset_params()
cuesim <<- -1
pc <<- 0
# ndistr <<- c(1,3)

# lf <<- seq(0.1,0.7,.1)
# mp <<- seq(0,3,.5)
# mas <<- seq(0.5,4,.5)
# ans <<- seq(0,0.5,.1)
# dbl <<- c(-0.5,0,1,3)
# pspace_orig <- run(model_4cond, iterations=2000)
# #
# pspace_orig <- tbl_df(pspace_orig)
# glimpse(pspace_orig)
# #
# # means_cond_orig <- compute_means_cond(pspace_orig)
# means_int_orig <- compute_means_int(pspace_orig)
# means_int_orig_log <- mutate_each(means_int_orig, funs(convert2log))

lf <<- seq(0.1,0.2,.1)
mp <<- seq(0,3,.5)
mas <<- seq(1,5,.5)
ans <<- seq(0.1,0.5,.1)
# dbl <<- c(-0.5,0,1,3)
psp1 <- run(model_4cond, iterations=3000)
means1 <- compute_means_int(psp1)
#
lf <<- seq(0.3,0.5,.1)
mp <<- seq(0,3,.5)
mas <<- seq(1,5,.5)
ans <<- seq(0.1,0.5,.1)
# dbl <<- c(-0.5,0,1,3)
psp2 <- run(model_4cond, iterations=3000)
means2 <- compute_means_int(psp2)
means2$Set <- means2$Set+max(means1$Set)
means2 <- rbind(means1,means2)
#
means_int_orig <- means2
means_int_orig_log <- mutate_each(means_int_orig, funs(convert2log10))
#
require(tidyr)
means_int_orig_log_long <- gather(means_int_orig_log, "parameter", "value", lf, ans, mas, mp, dbl)

save(means_int_orig, means_int_orig_log, means_int_orig_log_long, file="pspace_original.Rd")

###############################################################
## Parameter space extended model, standard conditions
###############################################################
# load("pspace_extended_matrix.Rd")

## Prominence
reset_params()
ans <<- 0.15
mp <<- 1.5
mas <<- c(1,3)
lf <<- c(0.15,0.2,0.25)
dbl <<- seq(-0.5,4,0.25)
pc <<- c(0,5)
cuesim <<- -1
# ndistr <<- c(1,3)
#
pspace_prom <- run(model_4cond, iterations=3000)
pspace_prom <- tbl_df(pspace_prom)
glimpse(pspace_prom)

means_cond_prom <- compute_means_cond(pspace_prom)
means_int_prom <- compute_means_int(pspace_prom)
means_int_prom_log <- mutate_each(means_int_prom, funs(convert2log))

## Cue confusion
reset_params()
ans <<- 0.15
mp <<- 1.5
mas <<- 1
lf <<- c(0.15,0.2,0.25)
dbl <<- seq(-0.2,0.2,.2)
pc <<- 5
cuesim <<- seq(-1,0,0.1)
ndistr <<- c(1,3)
#
pspace_cueconf <- run(model_4cond, iterations=3000)
pspace_cueconf <- tbl_df(pspace_cueconf)
glimpse(pspace_cueconf)
#
means_cond_cueconf <- compute_means_cond(pspace_cueconf)
means_int_cueconf <- compute_means_int(pspace_cueconf)
means_int_cueconf_log <- mutate_each(means_int_cueconf, funs(convert2log))

# ## Simulations
# reset_params()
# ans <<- 0.15
# mp <<- 1.5
# mas <<- 1
# lf <<- c(0.15,0.2,0.25)
# dbl <<- seq(-0.5,4,0.1)
# pc <<- c(0,5)
# cuesim <<- seq(-1,0,0.1)
# ndistr <<- c(1,3)
# #
# simspace <- run(model_4cond, iterations=2000)
# simspace <- tbl_df(simspace)
# glimpse(simspace)
# #
# means_cond_simspace <- compute_means_cond(simspace)
# means_int_simspace <- compute_means_int(simspace)

# save(means_cond_prom, means_int_prom, means_cond_cueconf, means_int_cueconf, means_int_prom_log, means_int_cueconf_log, file="pspace_extended.Rd")

require(ggplot2)

(qplot(dbl, M, linetype=Target, geom=c("line"),
  xlab="Distractor base-level activation",
  ylab="Interference effect in ms",
  data=subset(means_int_ext, lf==0.15 & cuesim==-1 & ndistr==1))
+ geom_errorbar(aes(max=CI.upper, min=CI.lower, width=0))
+ scale_y_continuous(breaks=seq(-300,50,20))
+ theme_bw()
)

summary(factor(means_int_ext$dbl))
summary(factor(subset(means_int_ext,lf==.15 & ndistr==1 & ans==0.15 & mp==1.5 & mas==1)$dbl))

(qplot(cuesim, M, linetype=Target, shape=factor(dbl), color=factor(dbl), geom=c("line","point"),
  data=subset(means_int_ext, lf==.15 & ndistr==1 & factor(dbl)%in%c(-0.2,0,0.2)),
  xlab="Cue confusion in %",
  ylab="Mean latency difference in ms",
  )
+ geom_hline(aes(yintercept=0), colour="grey10")
# + geom_smooth()
+ geom_errorbar(aes(max=CI.upper, min=CI.lower, width=0))
+ scale_colour_manual("", values=c("gray","black","gray"), guide=FALSE)
+ scale_y_continuous(breaks=seq(-60, 80, 20))
+ theme_bw()
)

load("pspace_original.Rd")
require(ggplot2)
#
ylabs <- c(-300,-100,-20,-5,0,5,20,100)
#
(p.orig <- ggplot(aes(value, M, shape=Target, linetype=Target, color=Target),
  data=subset(means_int_orig_log_long, parameter!="dbl" & parameter%in%c("lf","ans","mp","mas")))
+ xlab("Parameter values")
+ ylab("Mean latency difference in ms")
+ geom_hline(aes(yintercept=0), colour="gray10")
+ geom_point(position=position_jitter(width=0.05), aes(color=Target), data=subset(means_int_orig_log_long, parameter%in%c("lf","ans")))
+ geom_point(position=position_jitter(width=0.5), aes(color=Target), data=subset(means_int_orig_log_long, parameter%in%c("mas","mp")))
# + geom_errorbar(aes(max=CI.upper, min=CI.lower, width=0))
+ geom_smooth(method=lm, formula=y~poly(x,3), col="black", fullrange=TRUE)
+ scale_colour_manual(values=c("gray70","gray50"))
+ scale_shape_manual(values=c(1,2))
+ scale_y_continuous(breaks=convert2log10(ylabs), labels=ylabs)
+ theme_classic()
+ theme(legend.position="bottom"
  ,legend.key=element_blank()
  ,panel.grid.major.y=element_line(color="gray80")
  ,panel.grid.minor.y=element_blank()
  # ,panel.grid.major.x=element_line(color="gray80")
  ,panel.grid.major.x=element_blank()
  ,panel.grid.minor.x=element_blank()
  )
+ facet_wrap(~parameter, scales="free")
)

#load("pspace_original_matrix.Rd")
require(ggplot2)
#
head(means_int_orig)
library(tidyr)
orig <- subset(means_int_orig_log, dbl==0)
orig <- gather(orig, "parameter", "value", lf, ans, mas, mp, dbl)
nsets <- max(orig$Set)
#
(p.orig <- qplot(Target, M,
  ,geom=c("boxplot"),
  data=subset(orig, parameter!="dbl" & parameter%in%c("lf","ans","mp","mas")),
  xlab="",
  ylab="Mean latency difference in ms",
  )
+ geom_hline(aes(yintercept=0), colour="gray10")
+ scale_colour_manual("Target: ", values=c("black","gray50"))
+ scale_shape_manual("Target: ", values=c(16,2))
+ theme_bw()
+ theme(legend.position="bottom"
  ,legend.key=element_blank()
  ,panel.grid.major.y=element_line(color="gray80")
  ,panel.grid.minor.y=element_blank()
  ,panel.grid.major.x=element_blank()
  ,panel.grid.minor.x=element_blank()
  )
# + facet_wrap(~parameter, scales="free")
)

## subset mismatch > 0
mispos <- subset(means_int_orig, Target=="Mismatch" & M>0 & mp<4)
lpos <- dim(mispos)[1]
l <- dim(subset(means_int_orig, Target=="Mismatch"))[1]
posprop <- lpos/l
Mpos <- mean(mispos$M)
mppos <- mean(mispos$mp)
anspos <- mean(mispos$ans)
lfpos <- mean(mispos$lf)
maspos <- mean(mispos$mas)


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

# Raw Input Files: NONE
# Derived Input files:
#   'OrigSubset1_Lead.csv'
#   'OrigSubset1_Train.csv'
#   'Parsed_RawDump_Full.csv'

NE = 44514
NT = 22126031

t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
te.lead = as.numeric(strptime("2010-09-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
te.train = as.numeric(strptime("2010-04-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tl5.lead = te.train
tl5.train = as.numeric(strptime("2009-11-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);

ResMatLead = read.csv(paste(RESDIR,"OrigSubset1_Lead.csv",sep=''), header=T); ResMatLead[ResMatLead==-1] = 0
ResMatTrain = read.csv(paste(RESDIR,"OrigSubset1_Train.csv",sep=''), header=T); ResMatTrain[ResMatTrain==-1] = 0

ResMatLead = as.matrix(ResMatLead)
ResMatTrain = as.matrix(ResMatTrain)

# load(paste(RESDIR,'Parsed_RawDump_Full.rdata',sep=''))
# A = read.csv(paste(RESDIR,'Parsed_RawDump_Full.csv',sep=''),header=T)
con <- file(paste(DATADIR,'training.tsv',sep=''),'r')
header = readLines(con,n=1); #read the header
stopifnot(header== "user_id\tarticle_id\trevision_id\tnamespace\ttimestamp\tmd5\treverted\treverted_user_id\treverted_revision_id\tdelta\tcur_size")

# Create Name space variable-name list
var_sum_edit = list()
var_sum_reverts = list()
var_sum_edit_l5 = list()
var_sum_reverts_l5 = list()
for (nspace in 0:5){
	var_sum_edit[nspace+1] = paste('sum_edit_ns',nspace,sep='')
	var_sum_reverts[nspace+1] = paste('sum_reverts_ns',nspace,sep='')

	var_sum_edit_l5[nspace+1] = paste(var_sum_edit[nspace+1],'_l5',sep='')
	var_sum_reverts_l5[nspace+1] = paste(var_sum_reverts[nspace+1],'_l5',sep='')
}
var_sum_edit = unlist(var_sum_edit);
var_sum_edit_l5 = unlist(var_sum_edit_l5);
var_sum_reverts = unlist(var_sum_reverts);
var_sum_reverts_l5 = unlist(var_sum_reverts_l5);
# THe huge loop
artlist = rep(list(NA),NE)
artlist.train = rep(list(NA),NE)

# Create editor.id->index map for efficient reverse lookup
uid.idx =  matrix(NA,max(ResMatLead[,'user_id']),2)
for (i in 1:dim(ResMatLead)[1]){
	uid.idx[ResMatLead[i,'user_id'],1] = i
}

for (i in 1:dim(ResMatTrain)[1]){
	uid.idx[ResMatTrain[i,'user_id'],2] = i
}

time_start = proc.time()

for (i in 2:(NT+1)){
	if (i%%200000 == 0) {
		cat(sprintf("Parsed %i  / %i lines, Elapsed %.2f minutes",i,NT+1,(as.numeric(proc.time()-time_start)[3]/60)),"\n");
		flush.console();
	}
	#sline = strsplit(A[i],'\t')[[1]]
	rline = readLines(con, n=1)
	sline = strsplit(rline,'\t')[[1]]

	uid = as.integer(sline[1])
	artid = as.integer(sline[2])
	nspace = as.integer(sline[4]) #namespace
	tstamp = as.numeric(strptime(sline[5], "%Y-%m-%d %H:%M:%S") - t0);
	revflag = as.integer(sline[7])
	revuid = as.integer(sline[8])
	delta = as.integer(sline[10])
	# uid = A[i,1]
	# artid = A[i,2]
	# nspace = A[i,3]
	# tstamp = A[i,4]
	# revflag = A[i,5]
	# revuid = A[i,6]
	# delta = A[i,7]
	#--------------------------------------------
	ilead = uid.idx[uid,1]; stopifnot(!is.na(ilead));
	itrain = uid.idx[uid,2]
	user.in.training = (!is.na(itrain))
	edit.in.leadl5 = (tstamp >= tl5.lead)
	edit.in.trainl5 = ((tstamp >= tl5.train) && (tstamp < te.train))

	#---------- LEADERBOARD ---------------------
	ResMatLead[ilead,var_sum_edit[nspace+1]] = ResMatLead[ilead,var_sum_edit[nspace+1]] + 1
	if(edit.in.leadl5){
		ResMatLead[ilead,var_sum_edit_l5[nspace+1]] = ResMatLead[ilead,var_sum_edit_l5[nspace+1]] + 1
	}
	if(revflag==1){
		ResMatLead[ilead,'sum_reverts'] = ResMatLead[ilead,'sum_reverts'] + 1
		ResMatLead[ilead,var_sum_reverts[nspace+1]] = ResMatLead[ilead,var_sum_reverts[nspace+1]] + 1
		if(edit.in.leadl5){
			ResMatLead[ilead,'sum_reverts_l5'] = ResMatLead[ilead,'sum_reverts_l5'] + 1
			ResMatLead[ilead,var_sum_reverts_l5[nspace+1]] = ResMatLead[ilead,var_sum_reverts_l5[nspace+1]] + 1
		}

		if (revuid == uid){
			ResMatLead[ilead,'sum_reverts_self'] = ResMatLead[ilead,'sum_reverts_self'] + 1
			if(edit.in.leadl5){
				ResMatLead[ilead,'sum_reverts_self_l5'] = ResMatLead[ilead,'sum_reverts_self_l5'] + 1
			}
		}
		# irevid = which(ResMatLead[,'user_id'] == revuid) # uid.idx[revuid,1]
		# if (length(irevid) > 0){
			# ResMatLead[irevid,'sum_reverts_self'] = ResMatLead[irevid,'sum_reverts_self'] + 1
			# if(edit.in.leadl5){
				# ResMatLead[irevid,'sum_reverts_self_l5'] = ResMatLead[irevid,'sum_reverts_self_l5'] + 1
			# }
		# }
	}

	if (!(artid %in% artlist[[ilead]])){
		ResMatLead[ilead,'sum_articles'] = ResMatLead[ilead,'sum_articles']+1
		if(edit.in.leadl5){
			ResMatLead[ilead,'sum_new_articles_l5'] = ResMatLead[ilead,'sum_new_articles_l5']+1
		}
		artlist[[ilead]] = c(artlist[[ilead]],artid)
	}

	ResMatLead[ilead,'sum_delta'] = ResMatLead[ilead,'sum_delta'] + delta
	if(edit.in.leadl5){
		ResMatLead[ilead,'sum_delta_l5'] = ResMatLead[ilead,'sum_delta_l5'] + delta
	}

	#---------- TRAINING ---------------------
	if(user.in.training && tstamp < te.train){
		ResMatTrain[itrain,var_sum_edit[nspace+1]] = ResMatTrain[itrain,var_sum_edit[nspace+1]] + 1
		if(edit.in.trainl5){
			ResMatTrain[itrain,var_sum_edit_l5[nspace+1]] = ResMatTrain[itrain,var_sum_edit_l5[nspace+1]] + 1
		}
		if(revflag==1){
			ResMatTrain[itrain,'sum_reverts'] = ResMatTrain[itrain,'sum_reverts'] + 1
			ResMatTrain[itrain,var_sum_reverts[nspace+1]] = ResMatTrain[itrain,var_sum_reverts[nspace+1]] + 1
			if(edit.in.trainl5){
				ResMatTrain[itrain,'sum_reverts_l5'] = ResMatTrain[itrain,'sum_reverts_l5'] + 1
				ResMatTrain[itrain,var_sum_reverts_l5[nspace+1]] = ResMatTrain[itrain,var_sum_reverts_l5[nspace+1]] + 1
			}

			if (revuid == uid){
				ResMatTrain[itrain,'sum_reverts_self'] = ResMatTrain[itrain,'sum_reverts_self'] + 1
				if(edit.in.trainl5){
					ResMatTrain[itrain,'sum_reverts_self_l5'] = ResMatTrain[itrain,'sum_reverts_self_l5'] + 1
				}
			}
			# irevid = which(ResMatTrain[,'user_id'] == revuid) # uid.idx[revuid,1]
			# if (length(irevid) > 0){
				# ResMatTrain[irevid,'sum_reverts_self'] = ResMatTrain[irevid,'sum_reverts_self'] + 1
				# if(edit.in.trainl5){
					# ResMatTrain[irevid,'sum_reverts_self_l5'] = ResMatTrain[irevid,'sum_reverts_self_l5'] + 1
				# }
			# }
		}

		if (!(artid %in% artlist.train[[itrain]])){
			ResMatTrain[itrain,'sum_articles'] = ResMatTrain[itrain,'sum_articles']+1
			if(edit.in.trainl5){
				ResMatTrain[itrain,'sum_new_articles_l5'] = ResMatTrain[itrain,'sum_new_articles_l5']+1
			}
			artlist.train[[itrain]] = c(artlist.train[[itrain]],artid)
		}

		ResMatTrain[itrain,'sum_delta'] = ResMatTrain[itrain,'sum_delta'] + delta
		if(edit.in.trainl5){
			ResMatTrain[itrain,'sum_delta_l5'] = ResMatTrain[itrain,'sum_delta_l5'] + delta
		}
	}
}

ResMatTrain[,'y_next5_edits'] = ResMatLead[which(ResMatLead[,'user_id'] %in% ResMatTrain[,'user_id']),'sum_edits_l5']

write.csv(ResMatLead, file = paste(RESDIR,"OrigSet_xinp1p2p3.csv",sep=''), row.names = FALSE);
write.csv(ResMatTrain, file = paste(RESDIR,"OrigSet_xinp1p2_yinp3.csv",sep=''), row.names = FALSE);

close(con)

#/ Column	Explanation
#/ user_id	user-id
#/ FSDT	The First timestamp that this user made an edit on
#/ LSDT	The last timestamp (before 31-Oct-2009 midnight) that this  user made an edit
#/ registration_date	The date that the user registered on
#/ sum_edits	Total number of edits that the user made (as on p1 end)
#/ sum_edit_days	Total number of days  that the user made edits on (as on p1 end)
#[ sum_edit_ns0	Total number of edits that this user made (as on p1 end) in the namespace category 0
#[ sum_edit_ns1	Total number of edits that this user made (as on p1 end) in the namespace category 1
#[ sum_edit_ns2	Total number of edits that this user made (as on p1 end) in the namespace category 2
#[ sum_edit_ns3	Total number of edits that this user made (as on p1 end) in the namespace category 3
#[ sum_edit_ns4	Total number of edits that this user made (as on p1 end) in the namespace category 4
#[ sum_edit_ns5	Total number of edits that this user made (as on p1 end) in the namespace category 5
#[ sum_reverts	Total number of reverts that the user had (as on p1 end)
#[ sum_reverts_ns0	Total number of reverts (as on p1 end)  for edits of namespace 0
#[ sum_reverts_ns1	Total number of reverts (as on p1 end)  for edits of namespace 1
#[ sum_reverts_ns2	Total number of reverts (as on p1 end)  for edits of namespace 2
#[ sum_reverts_ns3	Total number of reverts (as on p1 end)  for edits of namespace 3
#[ sum_reverts_ns4	Total number of reverts (as on p1 end)  for edits of namespace 4
#[ sum_reverts_ns5	Total number of reverts (as on p1 end)  for edits of namespace 5
#[ sum_reverts_self	Total number of reverts (as on p1 end) that the user  himself/herself made
# sum_articles	Total number of  unique articles edited by the user (as on p1 end)
# sum_delta	sum of all the deltas of edits madeby the user (as of p1 end)
#/ sum_edits_l5	Total number of edits that the user made (in the last 5 month before p1 ended)
#/ sum_edit_days_l5	Total number of days  that the user made edits on (in the last 5 months before p1 ended)
#[ sum_edit_ns0_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 0
#[ sum_edit_ns1_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 1
#[ sum_edit_ns2_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 2
#[ sum_edit_ns3_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 3
#[ sum_edit_ns4_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 4
#[ sum_edit_ns5_l5	Total number of edits that this user made (in the last 5 months before p1 ended) in the namespace category 5
#[ sum_reverts_l5	Total number of reverts that the user had (in the last 5 months before p1 ended)
#[ sum_reverts_ns0_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 0
#[ sum_reverts_ns1_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 1
#[ sum_reverts_ns2_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 2
#[ sum_reverts_ns3_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 3
#[ sum_reverts_ns4_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 4
#[ sum_reverts_ns5_l5	Total number of reverts (in the last 5 months before p1 ended)  for edits of namespace 5
#[ sum_reverts_self_l5	Total number of reverts (in the last 5 months before p1 ended) that the user  himself/herself made
# sum_new_articles_l5	Total number of articles that the user edited for the first tiem in the last 5 months before p1 ended
# sum_delta_l5	sum of all the deltas of edits madeby the user (in the last 5 months before p1 ended)
#/ Edits_mth_cutoff_minus_4	Number of edits 4 months before the last month of p1 (i.e., Jun-09)
#/ Edits_mth_cutoff_minus_3	Number of edits 3 months before the last month of p1 (i.e., Jul-09)
#/ Edits_mth_cutoff_minus_2	Number of edits 2 months before the last month of p1 (i.e., Aug-09)
#/ Edits_mth_cutoff_minus_1	Number of edits 1 month before the last month of p1 (i.e., Sep-09)
#/ Edits_mth_cutoff_minus_0	Number of edits 0 months before the last month of p1 (i.e., in the month of Oct-09)
# y_next5_edits	Number of edits that the user made in the 5 months post p1 (Nov-09to Mar-10)


#compare out of sample forecast to number of SVs within a group.
rm(list=ls())
source('paths.r')
library(data.table)

#set figure output path.----
output.path <- 'test.png'

#load data.----
#load in-/out-of-sample diversity stats.
cal.div <- readRDS(tedersoo_ITS_common_phylo_groups_list_1k.rare.path)
val.div <- readRDS(NEON_ITS_fastq_all_cosmo_phylo_groups_1k_rare.path)

#Load in calibration/validation models.
cal <- readRDS(ted_ITS_prior_all.groups_JAGSfits.path)
val <- readRDS(NEON_site_fcast_all_groups_1k_rare.path)

#Load in validation data.
val.obs <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)

#Get calibration R2 values, merge in diversity stats.----
cal.r2_table <- list()
for(i in 1:length(cal)){
  cal_level <- cal[[i]]
  div <- cal.div[[i]]$group_frequencies
  pred <- cal_level$predicted
   obs <- cal_level$observed
  cal.lev_r2   <- list()
  cal.lev_r2.1 <- list()
  for(j in 1:ncol(pred)){
    mod <- lm(( obs[,j]) ~ (pred[,j]))
    cal.lev_r2[[j]] <- summary(mod)$r.squared
    #relative to 1:1 line.
    rss <- sum((pred[,j] - obs[,j]) ^ 2)       ## residual sum of squares
    tss <- sum((obs[,j] - mean(obs[,j])) ^ 2)  ## total sum of squares
    rsq.1 <- 1 - rss/tss
    rsq.1 <- ifelse(rsq.1 < 0, 0, rsq.1)
    cal.lev_r2.1[[j]] <- rsq.1
  }
  cal.lev_r2 <- data.frame(unlist(cal.lev_r2))
  cal.lev_r2 <- cbind(colnames(obs), cal.lev_r2)
  colnames(cal.lev_r2) <- c('group','cal_rsq')
  cal.lev_r2$cal_rsq.1 <- unlist(cal.lev_r2.1)
  #merge in diversity stats.
  colnames(div) <- c('group', 'cal_samp_freq','cal_N.SV','cal_diversity','cal_evenness')
  cal.lev_r2 <- merge(cal.lev_r2, div, all.x = T)
  cal.lev_r2 <- cal.lev_r2[-grep('other',cal.lev_r2$group),]
  cal.r2_table[[i]] <- cal.lev_r2
}
names(cal.r2_table) <- names(cal)

#get validation R2 values (site-level), merge in diversity stats.----
val.r2_table <- list() #full table
for(i in 1:length(val)){
  pred <-     val[[i]]$site.fit$mean
   obs <- val.obs[[i]]$site.fit$mean
  pred <- pred[,order(match(colnames(pred), colnames(obs)))]

  #make sure same order and identity of rownames
   obs <-  obs[rownames(obs ) %in% rownames(pred),]
  pred <- pred[rownames(pred) %in% rownames( obs),]
  rsq   <- list()
  rsq.1 <- list()
  abundance <- list()
  variance  <- list()
  range     <- list()
  for(j in 1:ncol(obs)){
    #get best-fit rsq.
    mod <- lm(obs[,j] ~ pred[,j])
    rsq[[j]] <- summary(mod)$r.squared
    #get rsq relative to 1:1 line.
    rss <- sum((pred[,j] - obs[,j]) ^ 2)       ## residual sum of squares
    tss <- sum((obs[,j] - mean(obs[,j])) ^ 2)  ## total sum of squares
    rsq_1 <- 1 - (rss/tss)
    rsq_1 <- ifelse(rsq_1 < 0, 0, rsq_1)
    rsq.1[[j]] <- rsq_1
    abundance[[j]] <- boot::inv.logit(mean(boot::logit(obs[,j])))
     variance[[j]] <- boot::inv.logit(  sd(boot::logit(obs[,j])))
        range[[j]] <- max(obs[,j]) - min(obs[,j])
  }
        rsq <- data.frame(unlist(rsq))
      rsq.1 <- data.frame(unlist(rsq.1))
  abundance <- data.frame(unlist(abundance))
   variance <- data.frame(unlist(variance))
      range <- data.frame(unlist(range))
  rsq <- cbind(colnames(obs), rsq, rsq.1,abundance, variance,range)
  colnames(rsq) <- c('group','val_rsq','val_rsq.1','val_abundance','val_variance','val_range')

  rsq$group <- as.character(rsq$group)
  div <- val.div[[i]]$group_frequencies
  colnames(div) <- c('group','val_samp_freq','val_N.SV','val_diversity','val_evenness')
  rsq <- rsq[-grep('other',rsq$group),]
  rsq <- merge(rsq, div, all.x = T)
  rsq$phylo_level <- names(val)[i]
  val.r2_table[[i]] <- rsq
}
names(val.r2_table) <- names(val)

#merge the tables.----
cal.stats <- do.call(rbind, cal.r2_table)
val.stats <- do.call(rbind, val.r2_table)
d <- merge(cal.stats, val.stats)

#Model the R2 values.----
#vlaidation rsq of taxa with cal_rsq > 0.10.
#calibration and validation rsq are not related.
#validation rsq is related to validation variance, N.SVs (which are correlated). Best model just includes val_variance.
#diversity, N.SVs, variance all correlated, variance best predictor.
#also related to phylo level, but again, this mkaes val_variance model worse.
#true whether we model rsq or rsq.1
mod <- lm(val_rsq ~ cal_rsq + phylo_level,data = d[d$cal_rsq > 0.33,])
summary(mod)

par(mfrow = c(2,2))
plot(val_rsq ~ cal_rsq        , data = d[d$cal_rsq > 0.1,])
plot(val_rsq ~ log10(val_N.SV), data = d[d$cal_rsq > 0.1,])
plot(val_rsq ~ val_diversity  ,data = d[d$cal_rsq > 0.1,])
plot(val_rsq ~ val_variance   , data = d[d$cal_rsq > 0.1,])

#png save line.----
png(filename=output.path,width=8,height=5,units='in',res=300)

#THIS IS THE ANSWER.
#When you subset to calibration R2 > 0.33, calibration does predict validation, R2 = 0.49, unadjusted.
par(mfrow=c(1,2),
    mar = c(4,4,1,1))
o.cex = 1.3

#plot 1.----
mod1 <- lm(val_rsq ~ cal_rsq, data = d[d$cal_rsq > 0.33,])
plot(val_rsq ~ cal_rsq, data = d[d$cal_rsq > 0.33,], ylab = NA, xlab = NA, bty = 'l', pch = 16, cex = 1.5)
mtext(mtext(expression(paste("Validation R"^"2")) , side = 2, line = 2.5, cex = o.cex))
mtext(mtext(expression(paste("Calibration R"^"2")), side = 1, line = 3, cex = o.cex))
abline(mod1, lwd = 2)
mtext(paste0('R2 = ',round(summary(mod1)$r.squared,2)), side = 3, line = -2, adj = 0.05, cex = 1.2)
mtext('a.', side = 1, line = -1.5, adj = 0.95, cex = 1.2)

#You can explain 88% (R2 = 0.88, unadjusted) if you add phylo/functional group to the model.
mod2 <- lm(val_rsq ~ cal_rsq + phylo_level, data = d[d$cal_rsq > 0.33,])
y <- d[d$cal_rsq > 0.33,]$val_rsq
x <- fitted(mod2)
plot(y ~ x, ylab = NA, xlab = NA, bty =  'l', pch = 16, cex = 1.5)
mtext(mtext(expression(paste("Observed Validation R"^"2")) , side = 2, line = 2.5, cex = o.cex))
mtext(mtext(expression(paste("Predicted R"^"2")), side = 1, line = 3, cex = o.cex))
abline(lm(y~x), lwd = 2)
mtext(paste0('R2 = ',round(summary(mod2)$r.squared,2)), side = 3, line = -2, adj = 0.05, cex = 1.2)
mtext('b.', side = 1, line = -1.5, adj = 0.95, cex = 1.2)

#end plot.----
dev.off()

#random forest? Best r2 you gonna get is ~ 22-23%.
#library(randomForest)
#library(rfUtilities)
#rf.d <- d[complete.cases(d),]
#rf.d <- rf.d[,!(colnames(rf.d) %in% c('val_rsq.1','group'))]
#rf.d$phylo_level <- as.factor(rf.d$phylo_level)
#rf.mod <- randomForest(val_rsq ~ ., data = rf.d)
#varImpPlot(rf.mod, type = 2)
#plot(rf.d$val_rsq ~ rf.mod$predicted)
#summary(lm(rf.d$val_rsq ~ rf.mod$predicted))
#rf.cv <- rf.crossValidation(rf.mod, xdata=rf.d[,!(colnames(rf.d) %in% 'val_rsq')]) #not working.


#' @title  Confusion Matrix for the Best Model
#'
#' @description Given an \code{loocv()} output and \code{Cal_AUC()} output, this function calculates the confusion matrix for the label produced from the model with optimized number of features.
#' @param CV Output object from loocv().
#' @param auc_out Output object form Cal_AUC()
#' @export
#' @return A list of confusionMatrix class.
#'
#' @examples
#' data(training)
#'
#' ### using leave-one-out cross-validation ###
#' cv = loocv(training)
#'
#' ### using 10-fold cross-validation ###
#' cv = tfcv(training)
#'
#' auc_out = Cal_AUC(cv)
#'
#' best_cm(CV=cv,auc_out=auc_out)
#'
best_cm <- function(CV=cv, auc_out=auc_out){
  bestrank <- auc_out$NumberOfFeature[which.max(auc_out$AUC_Area)]
  tmp <-lapply(CV,function(x) x[x$feature_rank==bestrank,])
  file_rank = data.frame(Reduce(function(...) merge(...,all=T),tmp))

  pred <- as.numeric(as.numeric(as.vector(file_rank$Type1_Posterior_Prb)) > as.numeric(as.vector(file_rank$Type2_Postereior_Prb)))
  truth <- as.numeric(as.vector(file_rank$Type1Label))

  return(confusionMatrix(pred,truth))

}


x <- 1:100
	ifelse(x %% 15 == 0,
		'FizzBuzz',
		ifelse(x %% 5 == 0,
			'Buzz',
			ifelse(x %% 3 == 0,
				'Fizz',
				x)))


#!/usr/bin/env Rscript

library(ggplot2)
library(reshape2)
library(pheatmap)
library(scales)

www<-10
hhh<-8

heat_df <- read.csv("~/IdeaProjects/2013-10-01_DisqusThreadsClusters/home/shendrickson/2013-08-07_DisqusTxtDrive/viz/heat_df.csv")

heat <- read.csv("~/IdeaProjects/2013-10-01_DisqusThreadsClusters/home/shendrickson/2013-08-07_DisqusTxtDrive/viz/heat.csv", header=F)

hm <- as.matrix(heat)
hm <- -1.0*hm
####
pdf(file="heat_group.pdf", width=www, height=hhh)
heatmap(hm, col = heat.colors(256))
dev.off()
####
pdf(file="heat_group.2.pdf", width=www, height=hhh)
pheatmap(hm)
dev.off()

heat_df$Cluster <- as.factor(heat_df$Cluster)
X<-melt(heat_df, id=c("Cluster"))

####
X <- within(X, {variable <- reorder(variable, value, FUN=max)})
X <- within(X, {Cluster<- reorder(Cluster, value, FUN=max)})
pdf(file="gg_heat.pdf", width=2*www, height=2*hhh)
ggplot(X) +
geom_tile(aes(y=Cluster, x=variable, fill=value)) +
scale_fill_gradient(low="white", high="red") +
ylab("Topics") + xlab("Threads")
dev.off()

data <- read.csv("~/IdeaProjects/2013-10-01_DisqusThreadsClusters/home/shendrickson/2013-08-07_DisqusTxtDrive/viz/data.csv")
####
pdf(file="time.pdf", width=www, height=hhh)
ggplot(data) + geom_histogram(aes(time/86400.), binwidth=1, fill="blue")
dev.off()
####
clorder <- within(data, {clusID <-reorder(clusID, time)} )
pdf(file="timebycluster.pdf", width=www, height=hhh)
ggplot(data) + geom_histogram(aes(time/86400.), binwidth=1, fill="red") +
facet_wrap(~clusID, ncol=5, scale="free_y") +
xlab("Days") + ylab("Comments") +
theme(strip.text.x = element_text(size=0))
dev.off()
####
thorder <- within(data, {thrID <-reorder(thrID, time)} )
pdf(file="timebythread.pdf", width=www, height=hhh)
ggplot(thorder) + geom_histogram(aes(time/86400.), binwidth=1, fill="red") +
facet_wrap(~thrID, ncol=5, scale="free_y") +
xlab("Days") + ylab("Comments") +
theme(strip.text.x = element_text(size=0))
dev.off()


# Average the bottom temperatures from Morley et al. 2018
# Useful for plotting
# To run on Amphiprion

##############
# Parameters
##############
CLIMPATH <- '/local/shared/pinsky_lab/projections_PlosOne2018/Climate_projection_PlosOne2018'

################
# Functions
################
require(data.table)
require(ggplot2)

#########################
# Run the calculations
########################

# find rcp26 and rcp85 files
files <- list.files(path = CLIMPATH, pattern = '^pred.*rcp[28]',
                    full.names = TRUE)
filesE <- files[grepl('EAST', files)]
filesW <- files[grepl('WEST', files)]

# read in east coast data
# trim to 2007-2019 and average by climate grid
print(length(filesE))
for (i in 1:length(filesE)) {
    cat(i)
    load(filesE[i])
    pred.bathE <- as.data.table(pred.bathE)
    pred <- pred.bathE[year > 2006 & year < 2020, .(SBT = mean(SBT.seasonal)), by = c('latClimgrid', 'lonClimgrid')]
    pred[, mod := gsub(paste0(CLIMPATH, '\\/|predictionEASTnoBias_rcp|85|26|_jas_|\\.RData'), '', filesE[i])]
    pred[, rcp := gsub(paste0(CLIMPATH, '\\/|predictionEASTnoBias_rcp|_jas_|\\.RData|', unique(mod)), '', filesE[i])]
    if (i == 1) aggE <- pred
    if (i != 1) aggE <- rbind(aggE, pred)
    rm(pred.bathE, pred)
}
nrow(aggE) # 196740

# read in west coast data
# trim to 2007-2019 and average by climate grid
print(length(filesW))
for (i in 1:length(filesW)) {
    cat(i)
    load(filesW[i])
    pred.bathW <- as.data.table(pred.bathW)
    pred <- pred.bathW[year > 2006 & year < 2020, .(SBT = mean(SBT.seasonal)), by = c('latClimgrid', 'lonClimgrid')]
    pred[, mod := gsub(paste0(CLIMPATH, '\\/|predictionWESTnoBias_rcp|85|26|_jas_|\\.RData'), '', filesW[i])]
    pred[, rcp := gsub(paste0(CLIMPATH, '\\/|predictionWESTnoBias_rcp|_jas_|\\.RData|', unique(mod)), '', filesW[i])]
    if (i == 1) aggW <- pred
    if (i != 1) aggW <- rbind(aggW, pred)
    rm(pred.bathW, pred)
}

# average across GCMs and rcps and combine
aveE <- aggE[, .(sbt = mean(SBT)), by = c('latClimgrid', 'lonClimgrid')]
aveW <- aggW[, .(sbt = mean(SBT)), by = c('latClimgrid', 'lonClimgrid')]
clim <- rbind(aveE, aveW)

# simple plot
ggplot(clim, aes(x = lonClimgrid, y = latClimgrid, color = sbt)) +
    geom_point(size = 0.05)

# write out
write.csv(clim, file = gzfile('output/climatology.csv.gz'))


func_sort=function(x){
  num<-as.numeric(unlist(strsplit(as.character(x),"")))
  num<-sort(num)*2
  return(num)
}

R Community/R functions Assignments/Assignment10.r


library(ape)
library(phytools)
require(data.table)

args = commandArgs(trailingOnly=TRUE)

dat <- read.table(args[1], header=F, sep='\t', row.names=1)
colnames(dat) <- rownames(dat)
d <- as.dist(as.matrix(dat))
njt <- nj(d)
mid.njt <- midpoint.root(njt)
write.tree(mid.njt, file=args[2])


#' Number of dimensions.
#'
#' Number of dimensions of an array or vector
#'
#' @param x array
#' @keywords internal
dims <- function(x) length(amv_dim(x))

#' Dimensions.
#'
#' Consistent dimensions for vectors, matrices and arrays.
#'
#' @param x array, matrix or vector
#' @keywords internal
amv_dim <- function(x) if (is.vector(x)) length(x) else dim(x)

#' Dimension names.
#'
#' Consistent dimnames for vectors, matrices and arrays.
#'
#' Unlike \code{\link{dimnames}} no part of the output will ever be
#' null.  If a component of dimnames is omitted, \code{amv_dimnames}
#' will return an integer sequence of the appropriate length.
#'
#' @param x array, matrix or vector
#' @keywords internal
#' @export
amv_dimnames <- function(x) {
  d <- if (is.vector(x)) list(names(x)) else dimnames(x)

  if (is.null(d)) d <- rep(list(NULL), dims(x))
  null_names <- which(unlist(llply(d, is.null)))
  d[null_names] <- llply(null_names, function(i) seq_len(amv_dim(x)[i]))

  # if (is.null(names(d))) names(d) <- paste("X", 1:length(d), sep="")
  d
}

#' Reduce dimensions.
#'
#' Remove extraneous dimensions
#'
#' @param x array
#' @keywords internal
reduce_dim <- function(x) {
  subs <- lapply(dim(x), function(x) if (x == 1) 1 else bquote())
  call <- as.call(c(list(as.name("["), quote(x)), subs, list(drop = TRUE)))
  eval(call)
}


library(ggplot2)
library(RJSONIO)
library(reshape2)

plot_all = function(out_dir, simulation, bayesian_fit, ss_fit, poisson_fit) {
  # plot incidence series
  x = seq(1, length.out = length(simulation$I))
  data <- data.frame(unlist(x), Percent.Change = unlist(simulation$I))
  cols = c("dates", "I")
  colnames(data) = cols
  data$Expected <- simulation$expected_I
  data$observed <- simulation$I
  p =
    ggplot(data) +
    geom_line(data = data, aes(x = dates, y = observed, color = "black")) +
    geom_line(data = data, aes(x = dates, y = Expected, color = "blue")) +
    scale_colour_manual(values = c('black'='black', 'blue'='blue'), name = '',
                        labels = c(expression(I[N]), expression("E[I"[N]~"]"))) +
    xlab('t') +
    ylab('Incidencias') +
    theme(legend.title = element_blank(),legend.text=element_text(size=15),
          axis.title=element_text(size=15), axis.text.x=element_text(size=12),
          axis.text.y=element_text(size=12), legend.position="bottom")
  png(paste(out_dir, "I.png", sep="/"), pointsize=15, width=420, height=350)
  print(p)
  dev.off()

  # plot R
  aux_length =  length(simulation$I) - 1
  x = seq(1, length.out = aux_length)
  data <- data.frame(unlist(x), Percent.Change = unlist(x))
  cols = c("dates", "I")
  colnames(data) = cols
  data$real <- simulation$R[1:aux_length]
  data$bayesian <- bayesian_fit$R[1:aux_length]
  data$ss <- ss_fit$R[1:aux_length]
  data$poisson <- poisson_fit[[2]]$R[1:aux_length]
  y_upper_bound = if (max(simulation$R) < 6) 7 else 8.5
  p =
    ggplot(data) +
    geom_line(data = data, aes(x = dates, y = real, color = "Teórico")) +
    geom_line(data = data, aes(x = dates, y = bayesian, color = "Bayesiano")) +
    geom_line(data = data, aes(x = dates, y = ss, color = "Estado-Espacio")) +
    geom_line(data = data, aes(x = dates, y = poisson, color = "Poisson")) +
    scale_color_manual(values = c(
      'Teórico' = 'black',
      'Bayesiano' = 'blue',
      'Estado-Espacio' = 'darkgreen',
      'Poisson' = 'deeppink1'
    )) +
    xlab('t') +
    ylab('R(t)') + coord_cartesian(ylim=c(0, y_upper_bound)) +
    guides(col = guide_legend(ncol = 2)) +
    theme(legend.title = element_blank(),legend.text=element_text(size=15),
          axis.title=element_text(size=15), axis.text.x=element_text(size=12),
          axis.text.y=element_text(size=12), legend.position="bottom")
  png(paste(out_dir, "R.png", sep="/"), pointsize=15, width=420, height=350)
  print(p)
  dev.off()

  # plot Poisson regularization variants
  data$poisson_2 <- poisson_fit[[1]]$R[1:aux_length]
  data$poisson_3 <- poisson_fit[[3]]$R[1:aux_length]
  p =
    ggplot(data) +
    geom_line(data = data, aes(x = dates, y = real, color = "Teórico")) +
    geom_line(data = data, aes(x = dates, y = poisson, color = "Poisson")) +
    geom_line(data = data, aes(x = dates, y = poisson_2, color = "Poisson 1")) +
    geom_line(data = data, aes(x = dates, y = poisson_3, color = "Poisson 2")) +
    scale_color_manual(values = c(
      'Teórico' = 'black',
      'Poisson 1' = 'darkgreen',
      'Poisson 2' = 'blue',
      'Poisson' = 'deeppink1'
    )) +
    xlab('t') +
    ylab('R(t)') +
    guides(col = guide_legend(ncol = 2)) +
    theme(legend.title = element_blank(),legend.text=element_text(size=15),
          axis.title=element_text(size=15), axis.text.x=element_text(size=12),
          axis.text.y=element_text(size=12), legend.position="bottom")
  png(paste(out_dir, "R_Poisson.png", sep="/"), pointsize=15, width=420, height=350)
  print(p)
  dev.off()
}

# read fit results and plot
mape_table = NULL
scenario_count = 1
scenario_dirs = dir("simulations", pattern="scenario[0-9]", full.names=TRUE)
for (scenario_dir in scenario_dirs) {
  # R and I line plots
  simulation = fromJSON(paste(scenario_dir, "simulation.json", sep="/"), simplify = TRUE)
  bayesian_fit = fromJSON(paste(scenario_dir, "bayesian_fit.json", sep="/"), simplify = TRUE)
  ss_fit = fromJSON(paste(scenario_dir, "ss_fit.json", sep="/"), simplify = TRUE)
  poisson_fit = fromJSON(paste(scenario_dir, "poisson_fit.json", sep="/"), simplify = TRUE)
  plot_all(scenario_dir, simulation, bayesian_fit, ss_fit, poisson_fit)

  # build MAPE table
  scenario_mape = fromJSON(paste(scenario_dir, "R_mape.json", sep="/"), simplify = TRUE)
  scenario_mape = scenario_mape[c("bayesian", "ss", "Poisson 2")]
  names(scenario_mape) = c("Bayesiano", "Estado-Espacio", "Poisson")
  mape_subtable = data.frame(t(scenario_mape))
  mape_subtable[["scenario"]] = toString(scenario_count)
  scenario_count = scenario_count + 1
  mape_table = if (is.null(mape_table)) mape_subtable else rbind(mape_table, mape_subtable)
}
# store raw MAPE table
write.csv(mape_table, "simulations/mape.csv", row.names=FALSE)
# plot MAPE table
mape_melt = melt(mape_table, value.name="mape")
colnames(mape_melt) = c("scenario", "model", "mape")
mape_melt$model = as.character(mape_melt$model)
mape_melt$model[mape_melt$model == "Estado.Espacio"] = "Estado-Espacio"
mape_melt$mape[mape_melt$mape > 2] = NaN
p = ggplot(mape_melt) +
    geom_col(data=mape_melt, position="dodge", aes(x=scenario, y=mape, fill=model)) +
    scale_fill_manual(values = c('blue', 'darkgreen', 'deeppink1')) +
    xlab('Escenario') +
    ylab('MAPE(R)') +
    theme(legend.title = element_blank(), legend.text=element_text(size=15),
          axis.title=element_text(size=15), axis.text.x=element_text(size=12),
          axis.text.y=element_text(size=12), legend.position="bottom")
png("simulations/mape.png", pointsize=15, width=630, height=350)
print(p)
dev.off()


library(ggplot2)
library(dplyr)

dataframe <- read.csv(file="dataset10.dat" ,head=TRUE,sep="\t")

## group
serie <- tbl_df(dataframe) %>%
  group_by(variability, size) %>%
  summarise(avg_time = mean(time))

## plot

setEPS()
postscript("plan_size_and_context_2d_lines_avg.eps")

ggplot(data = serie, aes(x=size, y=avg_time, group=factor(variability),color=factor(variability))) + geom_line() + scale_colour_hue(l=20) +  labs(x = "Plan Size", y="Average Time(ms)", group="a") + guides(col = guide_legend(title="Variability", reverse = TRUE))

dev.off()


list(a=123, b="abc", TRUE, 1:5, c=list(d=runif(5), e=5+6))


orders <- read.csv('/var/folders/_5/jv4ptlps2ydb4_ptyj_l2y100000gn/T/out-7373128809679149089.csv') # insert output file here
statistics <- read.csv('/var/folders/_5/jv4ptlps2ydb4_ptyj_l2y100000gn/T/out-1984107031930922019.csv') # insert output file here
statistics$date = as.Date(statistics$date)

deposit = 15000
plot(statistics$date, (deposit+statistics$pl)/deposit-1, type='l', xlab = 'Date', ylab='Returns')

pctWin = sum(orders$pl > 0)/length(orders$pl)
print(paste('Win percentage: ', pctWin*100, '%'))

## specific to the cointegration strategy

kalmanStatistics = read.csv('/var/folders/_5/jv4ptlps2ydb4_ptyj_l2y100000gn/T/out-3935155810073028635.csv') # insert output file here
kalmanStatistics$date = as.Date(kalmanStatistics$date)

plot(kalmanStatistics$beta, type='l')

series = kalmanStatistics$y - kalmanStatistics$x * kalmanStatistics$beta - kalmanStatistics$alpha

plot(kalmanStatistics$date[50:length(series)], series[50:length(series)], type='l', xlab = 'Date', ylab='Residuals')


#### Theoretical simulation for learning parking (such as parallel or perpendicular parking)
#### Usage: Just load and run parking_simulation.20220109.r in R
####   by dragging the R script file into R console,
####   or by executing source("parking_simulation.20220109.r") in R console.

### Author: Adam Yongxin Ye
### Version: 0.1.0 (2022-01-09)

library(grid)

`%.%` = function(x,y) paste0(x,y)

carGrob = function(x=0, y=0, wheel_angle=0, width=1, length=2, wheel_to_front=0.3, wheel_to_back=wheel_to_front, wheel_length=0.3, frame_lwd=1, wheel_lwd=3, col="black", default.units="cm"){
	if (!is.unit(x))  x <- unit(x, default.units)
	if (!is.unit(y))  y <- unit(y, default.units)
	if (!is.unit(width))  width <- unit(width, default.units)
	if (!is.unit(length))  length <- unit(length, default.units)
	if (!is.unit(wheel_to_front))  wheel_to_front <- unit(wheel_to_front, default.units)
	if (!is.unit(wheel_to_back))  wheel_to_back <- unit(wheel_to_back, default.units)
	if (!is.unit(wheel_length))  wheel_length <- unit(wheel_length, default.units)

	x1 = x - width*0.5
	x2 = x + width*0.5
	y1 = y - wheel_to_back
	y2 = y1 + length
	y3 = y2 - wheel_to_front
	frameGrob = rectGrob(x=x1 + width*0.5, y=y1 + length*0.5, width=width, height=length, gp=gpar(col=col, lwd=frame_lwd))
	wheel_axis_F = segmentsGrob(x1, y3, x2, y3, gp=gpar(col=col, lwd=frame_lwd))
	wheel_axis_R = segmentsGrob(x1, y, x2, y, gp=gpar(col=col, lwd=frame_lwd))
	wheel_dx = wheel_length*0.5*sinpi(wheel_angle/180)
	wheel_dy = wheel_length*0.5*cospi(wheel_angle/180)
	wheel_FL = segmentsGrob(x1-wheel_dx, y3+wheel_dy, x1+wheel_dx, y3-wheel_dy, gp=gpar(col=col, lwd=wheel_lwd))
	wheel_FR = segmentsGrob(x2-wheel_dx, y3+wheel_dy, x2+wheel_dx, y3-wheel_dy, gp=gpar(col=col, lwd=wheel_lwd))
	wheel_RL = segmentsGrob(x1, y+wheel_length*0.5, x1, y-wheel_length*0.5, gp=gpar(col=col, lwd=wheel_lwd))
	wheel_RR = segmentsGrob(x2, y+wheel_length*0.5, x2, y-wheel_length*0.5, gp=gpar(col=col, lwd=wheel_lwd))
	gTree(children = gList(frameGrob, wheel_axis_F, wheel_axis_R, wheel_FL, wheel_FR, wheel_RL, wheel_RR))
}

drawCarVP = function(x=0, y=0, angle=0, wheel_angle=0, width=1, length=2, wheel_to_front=0.3, wheel_to_back=wheel_to_front, wheel_length=0.3, frame_lwd=1, wheel_lwd=3, col="black", default.units="cm"){
	if (!is.unit(x))  x <- unit(x, default.units)
	if (!is.unit(y))  y <- unit(y, default.units)
	if (!is.unit(width))  width <- unit(width, default.units)
	if (!is.unit(length))  length <- unit(length, default.units)
	if (!is.unit(wheel_to_front))  wheel_to_front <- unit(wheel_to_front, default.units)
	if (!is.unit(wheel_to_back))  wheel_to_back <- unit(wheel_to_back, default.units)
	if (!is.unit(wheel_length))  wheel_length <- unit(wheel_length, default.units)

	dy_to_center = length*0.5 - wheel_to_back
	vp_x = x - dy_to_center * sinpi(angle/180)
	vp_y = y + dy_to_center * cospi(angle/180)
	carVP = viewport(x=vp_x, y=vp_y, width=width, height=length, angle=angle)
	carGr = carGrob(x=width*0.5, y=wheel_to_back, wheel_angle=wheel_angle, width=width, length=length, wheel_to_front=wheel_to_front, wheel_to_back=wheel_to_back, wheel_length=wheel_length, frame_lwd=frame_lwd, wheel_lwd=wheel_lwd, col=col, default.units=default.units)
	pushViewport(carVP)
	grid.draw(carGr)
	popViewport()
	invisible(carVP)
}

createCar = function(x=0, y=0, angle=0, wheel_angle=0, wheel_angle_limit=30, width=1, length=2, wheel_to_front=0.3, wheel_to_back=wheel_to_front, wheel_length=0.3, frame_lwd=1, wheel_lwd=3, col="black", default.units="cm"){
	ans = list(x=x, y=y, angle=angle, wheel_angle=wheel_angle, wheel_angle_limit=wheel_angle_limit, width=width, length=length, wheel_to_front=wheel_to_front, wheel_to_back=wheel_to_back, wheel_length=wheel_length, frame_lwd=frame_lwd, wheel_lwd=wheel_lwd, col=col, default.units=default.units)
	class(ans) = "car"
	invisible(ans)
}
drawCar = function(car){
	with(car, drawCarVP(x=x, y=y, angle=angle, wheel_angle=wheel_angle, width=width, length=length, wheel_to_front=wheel_to_front, wheel_to_back=wheel_to_back, wheel_length=wheel_length, frame_lwd=frame_lwd, wheel_lwd=wheel_lwd, col=col, default.units=default.units))
}

carStearWheel = function(car, new_wheel_angle){
	car$wheel_angle = new_wheel_angle
	if(car$wheel_angle > car$wheel_angle_limit){
		car$wheel_angle = car$wheel_angle_limit
	}
	if(car$wheel_angle < -car$wheel_angle_limit){
		car$wheel_angle = -car$wheel_angle_limit
	}
	invisible(car)
}
carStearWheelDelta = function(car, delta_wheel_angle){
	carStearWheel(car, car$wheel_angle + delta_wheel_angle)
}
carMove = function(car, distance){
	if(car$wheel_angle==0){
		car$x = car$x - distance*sinpi(car$angle/180)
		car$y = car$y + distance*cospi(car$angle/180)
	}else{
		radius = (car$length-car$wheel_to_front-car$wheel_to_back) / tanpi(car$wheel_angle/180)
		center_x = car$x - radius*cospi(car$angle/180)
		center_y = car$y - radius*sinpi(car$angle/180)
		angle_distance = distance / radius / pi * 180
		car$angle = car$angle + angle_distance
		car$x = center_x + radius*cospi(car$angle/180)
		car$y = center_y + radius*sinpi(car$angle/180)
	}
	invisible(car)
}

#carDemo = createCar(5, 5)
#carDemo %>% drawCar
#carDemo %>% carMove(5) %>% drawCar
#carDemo %>% carMove(5) %>% carStearWheel(30) %>% carMove(5) %>% drawCar

ToyotaCorolla_scale = c(4630, 1780, 2700)   # length, width, wheel base

ToyotaCorolla_scale = ToyotaCorolla_scale / 1500

restart_simulation = function(userCar_x=5, userCar_y=5, parkedCar_x=6.5, parkedCar_y=c(3,11), parkedCar_angle=0, roadEdge_x=7.3, wheel_length=0.4){
	parkedCar_list = list()
	num_parkedCar = max(c(length(parkedCar_x), length(parkedCar_y)))
	parkedCar_x = rep(parkedCar_x, length.out=num_parkedCar)
	parkedCar_y = rep(parkedCar_y, length.out=num_parkedCar)
	parkedCar_angle = rep(parkedCar_angle, length.out=num_parkedCar)
	for(k in 1:num_parkedCar){
		parkedCar_list[[k]] = createCar(parkedCar_x[k], parkedCar_y[k], angle=parkedCar_angle[k], length=ToyotaCorolla_scale[1], width=ToyotaCorolla_scale[2], wheel_to_front=(ToyotaCorolla_scale[1]-ToyotaCorolla_scale[3])/2, wheel_length=wheel_length)
	}

	userCar = createCar(userCar_x, userCar_y, col="brown", length=ToyotaCorolla_scale[1], width=ToyotaCorolla_scale[2], wheel_to_front=(ToyotaCorolla_scale[1]-ToyotaCorolla_scale[3])/2, wheel_length=wheel_length)
	speed = 0

	redraw = function(){
		grid.newpage()
		for(k in 1:num_parkedCar){
			drawCar(parkedCar_list[[k]])
		}
		drawCar(userCar)
		grid.text("speed=" %.% speed %.% " , wheel_angle=" %.% userCar$wheel_angle %.% " , car_angle=" %.% round(userCar$angle, 3), 0, 0, just=c(0,0))
		for(now_roadEdge_x in roadEdge_x){
			grid.segments(now_roadEdge_x, 0, now_roadEdge_x, 100, default.units="cm", gp=gpar(lwd=2))
		}
	}

	dt = 0.5
	t = 0
	while(TRUE){
		redraw()
		### ref: https://stackoverflow.com/questions/15272916/how-to-wait-for-a-keypress-in-r
		prompt_txt = "Press arrow key to adjust, or any other key to maintain speed, or ESC to end"
		should_exit = FALSE
		getGraphicsEvent(prompt=prompt_txt, consolePrompt=prompt_txt, onKeybd=function(key){
			if(key=="Up"){
				speed <<- round(speed + 0.1, 2)
			}else if(key=="Down"){
				speed <<- round(speed - 0.1, 2)
			}else if(key=="Left"){
				userCar <<- carStearWheelDelta(userCar, + 30/1.5*0.5)
			}else if(key=="Right"){
				userCar <<- carStearWheelDelta(userCar, - 30/1.5*0.5)
			}else if(key=="ctrl-[" || key=="\033" || key=="ctrl-C"){   # ESC
				should_exit <<- TRUE
			}else{
#				print(key)
			}
			1
		})
		if(should_exit){
			break
		}
		userCar = carMove(userCar, speed*dt)
		t = t + dt
#		Sys.sleep(0.01)
	}
}

### Add X11() for compatibility in MacOS
X11(type="cairo")

simulation_option = 1

if(simulation_option==1){

	## parallel parking
	restart_simulation(userCar_x=5, userCar_y=5, parkedCar_x=6.5, parkedCar_y=c(3,11), parkedCar_angle=0, roadEdge_x=7.3, wheel_length=0.4)

}else if(simulation_option==2){

	## perpendicular parking
	restart_simulation(userCar_x=5, userCar_y=5, parkedCar_x=6.5, parkedCar_y=c(5,8.1), parkedCar_angle=-90, roadEdge_x=c(9.2,2), wheel_length=0.4)

}
### ref: https://www.acko.com/car-guide/how-to-park-a-car-perfectly-easy-guide-to-parallel-parking/


#Summarize model calibration and validation fits.
#To be run after spatial calibration and forecast scripts have been run.
#Report calibration and validations rsq, rsq.1, RMSE, N.
rm(list=ls())
source('paths.r')
source('NEFI_functions/rsq_1.1.r')
library(Metrics)

#set output path.----
output.path <- NEON_dmilti.ddirch_analysis_summary.path

#Load calibration data.----
cal <- readRDS(ted_ITS_prior_all.groups_JAGSfits.path)  #dirichlet only on transformed relative abundances.

#re-order list, make function group first.
cal <- cal[c('fg','phylum','class','order','family','genus')]
names(cal)[1] <- 'functional'

#Get calibration statistics.----
cal.stat <- list()
lev.cal.out <- list()
for(i in 1:length(cal)){
  lev <- cal[[i]]
  obs <- lev$observed
  pred <- lev$predicted
  #normalize counts
  obs <- obs/rowSums(obs)
  pred <- pred / rowSums(pred)
  lev.stat <- list()
  for(j in 1:ncol(obs)){
    name <- colnames(obs)[j]
    if(name == 'other'){next}
    rsq   <- summary(lm(obs[,j] ~ pred[,j]))$r.squared
    rsq.1 <- rsq_1.1(obs[,j], pred[,j])
    rmse  <- rmse(obs[,j], pred[,j])
    abundance <- mean(obs[,j])
    rmse.norm <- rmse / abundance
    return <- c(name, rsq, rsq.1, rmse,abundance, rmse.norm)
    names(return) <- c('name','rsq','rsq.1','rmse','abundance','rmse.norm')
    lev.stat[[j]] <- return
    }
  lev.stat <- data.frame(do.call(rbind, lev.stat))
  lev.stat[,2:ncol(lev.stat)] <- apply(lev.stat[,2:ncol(lev.stat)], 2, as.character)
  lev.stat[,2:ncol(lev.stat)] <- apply(lev.stat[,2:ncol(lev.stat)], 2, as.numeric  )
  cal.stat[[i]] <- lev.stat
}
names(cal.stat) <- names(cal)

#Get 'predictable' calibration subset (rsq.1 > 0.1).----
cal.stat.predictable <- list()
for(i in 1:length(cal.stat)){
  cal.stat.predictable[[i]] <- cal.stat[[i]][cal.stat[[i]]$rsq > 0.1,]
}
names(cal.stat.predictable) <- names(cal.stat)

#Get calibration summaries for all and predictable taxa.----
#all taxa.
cal.stat.sum <- list()
for(i in 1:length(cal.stat)){
  rsq   <-   mean(cal.stat[[i]]$rsq  )
  rsq.1 <-   mean(cal.stat[[i]]$rsq.1)
  rmse  <-   mean(cal.stat[[i]]$rmse )
  rmse.norm <- mean(cal.stat[[i]]$rmse.norm)
  N     <- length(cal.stat[[i]]$rsq  )
  stat <- c(rsq, rsq.1, rmse, N, rmse.norm)
  cal.stat.sum[[i]] <- stat
}
cal.stat.sum <- data.frame(do.call(rbind, cal.stat.sum))
rownames(cal.stat.sum) <- names(cal.stat)
colnames(cal.stat.sum) <- c('rsq','rsq.1','rmse','N','rmse.norm')

#predictable taxa.
cal.stat.predictable.sum <- list()
for(i in 1:length(cal.stat)){
  rsq   <-   mean(cal.stat.predictable[[i]]$rsq  )
  rsq.1 <-   mean(cal.stat.predictable[[i]]$rsq.1)
  rmse  <-   mean(cal.stat.predictable[[i]]$rmse )
  N     <- length(cal.stat.predictable[[i]]$rsq  )
  rmse.norm <- mean(cal.stat.predictable[[i]]$rmse.norm)
  stat <- c(rsq, rsq.1, rmse, N, rmse.norm)
  cal.stat.predictable.sum[[i]] <- stat
}
cal.stat.predictable.sum <- data.frame(do.call(rbind, cal.stat.predictable.sum))
rownames(cal.stat.predictable.sum) <- names(cal.stat.predictable)
colnames(cal.stat.predictable.sum) <- c('rsq','rsq.1','rmse','N','rmse.norm')

#wrap all calibration data.----
calibration <- list(cal.stat, cal.stat.predictable, cal.stat.sum, cal.stat.predictable.sum)
names(calibration) <- c('cal.stat','cal.stat.predictable','cal.stat.sum','cal.stat.predictable.sum')

#Load validation data.----
val.truth <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)
val.cast  <- readRDS(NEON_site_fcast_all_groups_1k_rare.path)
#Re-order.
val.cast  <- val.cast [c('fg','phylum','class','order','family','genus')]
val.truth <- val.truth[c('fg','phylum','class','order','family','genus')]
names(val.cast)[1] <- 'functional'

#get validation stats @ core, plot site scale.----
core.stat <- list()
plot.stat <- list()
site.stat <- list()
for(i in 1:length(val.cast)){
  fcast <- val.cast[[i]]
  core.lev.stat <- list()
  plot.lev.stat <- list()
  site.lev.stat <- list()
  #core.level----
  y <- val.truth[[i]]$core.fit
  x <- fcast$core.fit$mean
  #make sure row and column orders match.
  rownames(y) <- gsub('-GEN','',rownames(y))
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #grab statistics for all taxa within level.
  #core level.----
  for(k in 1:ncol(x)){
    name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    obs.rmse <- rmse(y[,k], x[,k])
    abundance.y <- mean(y[,k])
    abundance.x <- mean(x[,x])
    rmse.norm <- obs.rmse / abundance.y
    if(name == 'other'){next}
    stat.return <- c(name, rsq, rsq.1, obs.rmse,rmse.norm,abundance.y,abundance.x)
    names(stat.return) <- c('name','rsq','rsq.1','rmse','rmse.norm','abundance.y','abundance.x')
    core.lev.stat[[k]] <- stat.return
  }
  #plot.level----
  x <- fcast$plot.fit$mean
  y <- val.truth[[i]]$plot.fit$mean
  #make sure row and column order match.
  rownames(y) <- gsub('-GEN','',rownames(y))
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #grab statistics for all taxa within level.
  for(k in 1:ncol(x)){
    name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    obs.rmse <- rmse(y[,k], x[,k])
    abundance.y <- mean(y[,k])
    abundance.x <- mean(x[,k])
    rmse.norm <- obs.rmse / abundance.y
    if(name == 'other'){next}
    stat.return <- c(name, rsq, rsq.1, obs.rmse,rmse.norm,abundance.y,abundance.x)
    names(stat.return) <- c('name','rsq','rsq.1','rmse','rmse.norm','abundance.y','abundance.x')
    plot.lev.stat[[k]] <- stat.return
  }
  #site.level----
  x <- fcast$site.fit$mean
  y <- val.truth[[i]]$site.fit$mean
  #make sure row and column order match.
  rownames(y) <- gsub('-GEN','',rownames(y))
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #grab statistics for all taxa within level.
  for(k in 1:ncol(x)){
    name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    rsq.1 <- rsq_1.1(y[,k], x[,k])
    obs.rmse <- rmse(y[,k], x[,k])
    abundance.y <- mean(y[,k])
    abundance.x <- mean(x[,k])
    rmse.norm <- obs.rmse / abundance.y
    if(name == 'other'){next}
    stat.return <- c(name, rsq, rsq.1, obs.rmse,rmse.norm,abundance.y,abundance.x)
    names(stat.return) <- c('name','rsq','rsq.1','rmse','rmse.norm','abundance.y','abundance.x')
    site.lev.stat[[k]] <- stat.return
  }
  #wrap up for return.----
  core.stat[[i]] <- data.frame(do.call(rbind, core.lev.stat))
  plot.stat[[i]] <- data.frame(do.call(rbind, plot.lev.stat))
  site.stat[[i]] <- data.frame(do.call(rbind, site.lev.stat))
  core.stat[[i]][,2:ncol(core.stat[[i]])] <- apply(core.stat[[i]][,2:ncol(core.stat[[i]])], 2, as.character)
  core.stat[[i]][,2:ncol(core.stat[[i]])] <- apply(core.stat[[i]][,2:ncol(core.stat[[i]])], 2, as.numeric  )
  plot.stat[[i]][,2:ncol(plot.stat[[i]])] <- apply(plot.stat[[i]][,2:ncol(plot.stat[[i]])], 2, as.character)
  plot.stat[[i]][,2:ncol(plot.stat[[i]])] <- apply(plot.stat[[i]][,2:ncol(plot.stat[[i]])], 2, as.numeric  )
  site.stat[[i]][,2:ncol(site.stat[[i]])] <- apply(site.stat[[i]][,2:ncol(site.stat[[i]])], 2, as.character)
  site.stat[[i]][,2:ncol(site.stat[[i]])] <- apply(site.stat[[i]][,2:ncol(site.stat[[i]])], 2, as.numeric  )
}
#name the lists w/ their function/taxonomic levels.
names(core.stat) <- names(val.cast)
names(plot.stat) <- names(val.cast)
names(site.stat) <- names(val.cast)

#Get 'predictable' validation subset.----
core.stat.predictable <- list()
plot.stat.predictable <- list()
site.stat.predictable <- list()
for(i in 1:length(core.stat)){
  core <- core.stat[[i]]
  plot <- plot.stat[[i]]
  site <- site.stat[[i]]
  ref  <- cal.stat.predictable[[i]]
  core.stat.predictable[[i]] <- core[core$name %in% ref$name,]
  plot.stat.predictable[[i]] <- plot[plot$name %in% ref$name,]
  site.stat.predictable[[i]] <- site[site$name %in% ref$name,]
}
names(core.stat.predictable) <- names(core.stat)
names(plot.stat.predictable) <- names(plot.stat)
names(site.stat.predictable) <- names(site.stat)

#Get validation summaries @# site level for all and predictable taxa.----
#all validation summary - site level.
site.stat.sum <- list()
for(i in 1:length(site.stat)){
  rsq   <- mean(site.stat[[i]]$rsq  )
  rsq.1 <- mean(site.stat[[i]]$rsq.1)
  rmse  <- mean(site.stat[[i]]$rmse )
  N     <- nrow(site.stat[[i]])
  rmse.norm <- mean(site.stat[[i]]$rmse.norm)
  stat  <- c(rsq, rsq.1, rmse, N, rmse.norm)
  names(stat) <- c('rsq','rsq.1','rmse','N','rmse.norm')
  site.stat.sum[[i]] <- stat
}
site.stat.sum <- data.frame(do.call(rbind, site.stat.sum))
site.stat.sum <- cbind(names(site.stat), site.stat.sum)
colnames(site.stat.sum)[1] <- 'level'

#predictable validation summary - site level.
site.stat.predictable.sum <- list()
for(i in 1:length(site.stat)){
  rsq   <- mean(site.stat.predictable[[i]]$rsq  )
  rsq.1 <- mean(site.stat.predictable[[i]]$rsq.1)
  rmse  <- mean(site.stat.predictable[[i]]$rmse )
  N     <- nrow(site.stat.predictable[[i]])
  rmse.norm <- mean(site.stat.predictable[[i]]$rmse.norm)
  stat  <- c(rsq, rsq.1, rmse, N, rmse.norm)
  names(stat) <- c('rsq','rsq.1','rmse','N','rmse.norm')
  site.stat.predictable.sum[[i]] <- stat
}
site.stat.predictable.sum <- data.frame(do.call(rbind, site.stat.predictable.sum))
site.stat.predictable.sum <- cbind(names(site.stat), site.stat.predictable.sum)
colnames(site.stat.predictable.sum)[1] <- 'level'

#wrap all validation data.----
val.stat <- list(core.stat, plot.stat, site.stat)
names(val.stat) <- c('core.stat','plot.stat','site.stat')
val.stat.predictable <- list(core.stat.predictable, plot.stat.predictable, site.stat.predictable)
names(val.stat.predictable) <- c('core.stat','plot.stat','site.stat')
validation <- list(val.stat,val.stat.predictable,site.stat.sum, site.stat.predictable.sum)
names(validation) <- c('val.stat','val.stat.predictable','site.stat.sum','site.stat.predictable.sim')

#save output.----
output <- list(calibration, validation)
names(output) <- c('calibration','validation')
saveRDS(output, output.path)

#end script.


Step2plus_Celltype_marker_inference_new<-function(tg_R1_lists,data_CORS_cancer,tg_R1_cut=8,tg_R1_list_stat,cell_type_enrich_cut=0.5,resolution_level=resolution_level0,hcutn0=40)
{
        #have two sets of parameters for BCV t tests
        #1. For testing total rank and determining adding the base of a new cell type (strong condition)
        #2. For the linear model based cell type specific marker selected (weak condition)
        #3. Parameter set includes: number of BCV bins, number of rounds for t test and msep cut
	  #4. Add a new step, select top K R1 bases by using hclust, and add R1 bases by a mixed score of (1) three combination linear dependency and (2) cell type uniqueness
        tg_R1_lists_st<-tg_R1_lists
        for(i in 1:length(tg_R1_lists_st))
        {
                tg_R1_lists_st[[i]]<-tg_R1_lists_st[[i]][1:min(length(tg_R1_lists_st[[i]]),tg_R1_cut)]
        }

        print("Compute_total_rank!")
        tg_all_genes<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
                tg_all_genes<-c(tg_all_genes,tg_R1_lists_st[[i]])
        }
        tg_all_genes<-unique(tg_all_genes)
        tg_data_ccc<-data_CORS_cancer[tg_all_genes,]
        BCV_stat_c<-BCV_ttest3(tg_data_ccc,rounds=100,slice0=4,maxrank0=30,msep_cut=0.0001)
        dim_tt<-sum(BCV_stat_c[[1]]<0.01)
        print("Total Cell Dim")
	print( dim_tt)
        #remove the leave one out step and add a hclust pre-filtering step
	data_c<-data_CORS_cancer
	Base_all<-c()
	for(i in 1:length(tg_R1_lists_st))
	{
        tg_data_c<-data_c[tg_R1_lists_st[[i]],]
        cc<-svd(tg_data_c)$v[,1]
        ccc<-cor(cc,t(tg_data_c))
        if(mean(ccc)<0)
      {
                cc<--cc
        }
        Base_all<-rbind(Base_all,cc)
	}
	rownames(Base_all)<-names(tg_R1_lists_st)
	bbb_all0<-Base_all
	rownames(bbb_all0)<-1:nrow(bbb_all0)

	hcutn0<-min(hcutn0,nrow(bbb_all0))
	data_genes_all<-data_CORS_cancer[tg_all_genes,]
	hcutn1<-min(hcutn0+3,nrow(bbb_all0))
	hclust_R1_screen<-hclust_screen_top_bases(bbb_all0,data_genes_all,hcutn=hcutn1)
	ccc<-c()
	for(i in 1:length(hclust_R1_screen[[1]]))
	{
		aaa<-cor(t(hclust_R1_screen[[1]][[i]]))
		diag(aaa)<-0
		ccc<-c(ccc,max(aaa))
	}
	R_bases_hclust_top_correlations<-ccc
	hh<-hclust_R1_screen[[3]][[hcutn0]]
	Base_hclust_screen_result<-Base_screen(bbb_all0,hh,tg_R1_list_stat)
	Base_hclust_screen_selected<-as.numeric(Base_hclust_screen_result[[1]])

	tg_R1_lists_selected<-list()
	tg_R1_list_stat_selected<-list()
	nn<-c()
	for(i in 1:length(Base_hclust_screen_selected))
	{
		tg_R1_lists_selected[[i]]<- tg_R1_lists_st[[Base_hclust_screen_selected[[i]]]]
		tg_R1_list_stat_selected[[i]]<-tg_R1_list_stat[[Base_hclust_screen_selected[[i]]]][tg_R1_lists_selected[[i]],]
		cc<-apply(tg_R1_list_stat_selected[[i]],2,mean)
		nn<-c(nn,names(which(cc==max(cc))[1]))
	}
	names(tg_R1_lists_selected)<-nn
	tgs<-tg_R1_lists_selected

        print("Linking graph based cell type selection")
        ddd<-combn(length(tgs),3)
        comp_ids<-c()
        stat_all<-rep(0,length(tgs))
        stat_2total<-rep(0,length(tgs))
        names(stat_all)<-1:length(tgs)
        data_c<-data_CORS_cancer

	Base_all<-c()
	for(i in 1:length(tgs))
	{
        tg_data_c<-data_c[tgs[[i]],]
        cc<-svd(tg_data_c)$v[,1]
        ccc<-cor(cc,t(tg_data_c))
        if(mean(ccc)<0)
      {
                cc<--cc
        }
        Base_all<-rbind(Base_all,cc)
	}
	rownames(Base_all)<-names(tgs)

for(i in 1:ncol(ddd))
{
        tg_genes<-unique(c(tgs[[ddd[1,i]]],tgs[[ddd[2,i]]],tgs[[ddd[3,i]]]))
     	  pp<-sum(BCV_ttest2(data_c[tg_genes,],rounds=20,maxrank0=5)<0.001)
       if(pp==2)
        {
                        comp_ids<-c(comp_ids,i)
                        #print(i)
                  lm0<-lm(Base_all[ddd[1,i],]~Base_all[ddd[2,i],]+Base_all[ddd[3,i],]+0)
                  if(sum(is.na(coefficients(lm0)))==0)
                        {
                                stat_2total[ddd[,i]]<-stat_2total[ddd[,i]]+1
                        if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==1))
                        {
                                stat_all[ddd[2,i]]<-stat_all[ddd[2,i]]+1
                                stat_all[ddd[3,i]]<-stat_all[ddd[3,i]]+1
                        }
                        if((sign(coefficients(lm0))[1]==-1)&(sign(coefficients(lm0))[2]==1))
                        {
                                stat_all[ddd[2,i]]<-stat_all[ddd[2,i]]+1
                                stat_all[ddd[1,i]]<-stat_all[ddd[1,i]]+1
                        }
                        if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==-1))
                        {
                                stat_all[ddd[3,i]]<-stat_all[ddd[3,i]]+1
                                stat_all[ddd[1,i]]<-stat_all[ddd[1,i]]+1
                        }
                        }
       }
         if(i%%100==1)
        {
                print(i)
        }
}

stat_all0<-stat_all/stat_2total
scores10<-stat_all0
s1<-scores10[order(-scores10)]
ss<-rownames(Base_all)[order(-scores10)]
score_plus<-rep(0,length(ss))
names(score_plus)<-names(s1)
ss0<-unique(ss)
ss0_counts<-rep(1,length(ss0))
names(ss0_counts)<-ss0
for(i in 1:length(ss))
{
	score_plus[i]<-ss0_counts[ss[i]]
	ss0_counts[ss[i]]<-ss0_counts[ss[i]]+1
}
score_plus0<-(1/score_plus)^2
s2<-score_plus0+s1
s2<-s2[order(-s2)]

#names(tgs)[as.numeric(names(s2))]
#names(tgs)[selected_id]

total_dim<-dim_tt
N<-0
tt_selected_genes<-c()
selected_p<-c()
selected_c<-c()
tg_d_stat<-c()
selected_id<-c()
for(i in 1:length(s2))
{
        if(N<=total_dim)
        {
                tg_id_c<-as.numeric(names(s2)[i])
                print(c(tg_id_c,tg_id_c))
                if(length(selected_p)==0)
                {
                        selected_p<-tgs[[tg_id_c]]
                        tg_d_stat<-1
                        selected_id<-c(tg_id_c)
                        N<-N+1
                        print(N)
                        print(selected_id)
                }
                else
                {
                        selected_c<-c(selected_p,tgs[[tg_id_c]])
                        selected_c<-unique(selected_c)
                        tg_data_ccc0<-data_CORS_cancer[selected_c,]
                        BCV_stat_c0<-BCV_ttest3(tg_data_ccc0,rounds=100,slice0=2,maxrank0=30,msep_cut=0.0001)
                        tg_d_c<-sum(BCV_stat_c0[[1]]<0.001)#which(BCV_stat_c0[[1]]>0.001)[1]-1
                        print(tg_d_c)
                        if(tg_d_c>tg_d_stat[length(tg_d_stat)])
                        {
                                tg_d_stat<-c(tg_d_stat,tg_d_c)
                                selected_id<-c(selected_id,tg_id_c)
                                selected_p<-selected_c
                                N<-N+1
                                print(N)
                                print(selected_id)
                        }
                        print("")
                }
        }
}

tg_2badded_cells<-setdiff(unique(names(tgs)),unique(names(tgs)[selected_id]))
add_R1_base_cut<-list()
#add_R1_base_full<-list()
if(length(tg_2badded_cells)>0)
{
        ccc<-rep(0,length(tg_2badded_cells))
        names(ccc)<-tg_2badded_cells
        ttt<-s2
        for(i in 1:length(ttt))
        {
                if(sum(names(tgs)[as.numeric(names(ttt[i]))]==tg_2badded_cells))
                {
                        tg<-names(tgs)[as.numeric(names(ttt[i]))]
                        if(ccc[tg]==0)
                        {
                                add_R1_base_cut[[which(tg_2badded_cells==tg)]]<-tgs[[as.numeric(names(ttt[i]))]]
                                #add_R1_base_full[[which(tg_2badded_cells==tg)]]<-tg_R1_lists[[as.numeric(names(ttt[i]))]]
                                ccc[tg]<-1
                        }
                }
        }
}
names(add_R1_base_cut)<-tg_2badded_cells

#############################
nn<-rep("",length(tg_R1_list_stat_selected))
for(i in 1:length(tg_R1_list_stat_selected))
{
        if(max(tg_R1_list_stat_selected[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat_selected[[i]])),resolution_level])>cell_type_enrich_cut)
        {
                ccc<-tg_R1_list_stat_selected[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat_selected[[i]])),resolution_level]
                nn[i]<-names(which(ccc==max(ccc))[1])
        }
}
selected_cell_types<-intersect(resolution_level,unique(nn))

cellreso_R1_base_cut<-list()
#cellreso_R1_base_full<-list()

for(i in 1:length(selected_cell_types))
{
        cc1<-c()
        #cc2<-c()
        for(j in 1:length(nn))
        {
                if(nn[j]==selected_cell_types[i])
                {
                        cc1<-c(cc1,tgs[[j]])
                        #cc2<-c(cc2,tg_R1_lists[[j]])
                }
        }
        cellreso_R1_base_cut[[i]]<-unique(cc1)
        #cellreso_R1_base_full[[i]]<-unique(cc2)
}
names(cellreso_R1_base_cut)<-selected_cell_types
#names(cellreso_R1_base_full)<-selected_cell_types

#############################
supp_results<-list(tg_R1_lists_selected,tg_R1_list_stat_selected,selected_id,tg_d_stat,dim_tt,stat_all,stat_2total,hclust_R1_screen,Base_hclust_screen_selected,R_bases_hclust_top_correlations)
names(supp_results)<-c("tg_R1_lists_selected","tg_R1_list_stat_selected","selected_id","tg_d_stat","total_cell_type_number","stat_all","stat_2total","hclust_R1_screen","Base_hclust_screen_selected","R_bases_hclust_top_correlations")

selected_R1_base_cut<-list()
#selected_R1_base_full<-list()

for(i in 1:length(selected_id))
{
        selected_R1_base_cut[[i]]<-tgs[[selected_id[i]]]
        #selected_R1_base_full[[i]]<-tg_R1_lists[[selected_id[i]]]
}
names(selected_R1_base_cut)<-names(tgs)[selected_id]
#names(selected_R1_base_full)<-names(tgs)[selected_id]

R2_selected_cell_type_markers<-list(selected_R1_base_cut,add_R1_base_cut,cellreso_R1_base_cut,supp_results)
names(R2_selected_cell_type_markers)<-c("selected_R1_base_cut","add_R1_base_cut","cellreso_R1_base_cut","supp_results")
return(R2_selected_cell_type_markers)
}

hclust_screen_top_bases<-function(bbb_all0,data_genes_all,hcutn=80)
{
aaa<-data_genes_all
h<-hclust(dist(bbb_all0))
tg_trunc_list<-list()
tg_trunc_list_old<-list()
st<-0
trunc_RS_bases_all<-list()
RMSE_IM<-list()
hclust_info<-list()
hcutn0<-min(hcutn,nrow(bbb_all0))
for(i in 1:hcutn0)
{
	fff<-cutree(h,i)
	hclust_info[[i]]<-fff
	fff0<-unique(fff)
	tg_trunc_list_old<-tg_trunc_list
	tg_trunc_list<-list()
	#tg_trunc_list_info<-list()
	tg_trunc_RS_bases<-c()
	RMSE_table_c<-c()
	if(st==0)
	{
		for(j in 1:length(fff0))
		{
			tg_ccc<-names(which(fff==fff0[j]))
			tg_trunc_list[[j]]<-tg_ccc
			if(length(tg_ccc)==1)
        		{
                		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0[tg_ccc,])
        		}
        		else
        		{
               		bbb_all0_c<-bbb_all0[tg_ccc,]
                		bbb_all0_cc<-t(svd(bbb_all0_c)$v)[1,]
				aaa0<-cor(t(t(bbb_all0_cc)),t(bbb_all0_c))
				aaa0<-aaa0[which(abs(aaa0)>0.6)]
				if(mean(aaa0)<0)
				{
					bbb_all0_cc<--bbb_all0_cc
				}
               		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0_cc)
        		}

		}
		rownames(tg_trunc_RS_bases)<-1:nrow(tg_trunc_RS_bases)
		trunc_RS_bases_all[[i]]<-tg_trunc_RS_bases
		ccc<-c()
		for(j in 1:nrow(tg_trunc_RS_bases))
		{
        		ttt_c<-tg_trunc_RS_bases[j,]%*%t(tg_trunc_RS_bases[j,])/sum((tg_trunc_RS_bases[j,])^2)
        		ccc<-cbind(ccc,RMSE_row(aaa%*%ttt_c)/RMSE_row(aaa))
        	}
		RMSE_IM[[i]]<-ccc
		st<-1
	}
	else
	{
		ccc_old<-ccc
		for(j in 1:length(fff0))
		{
			tg_ccc<-names(which(fff==fff0[j]))
			tg_trunc_list[[j]]<-tg_ccc
			if(length(tg_ccc)==1)
        		{
                		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0[tg_ccc,])
        		}
        		else
        		{
               		bbb_all0_c<-bbb_all0[tg_ccc,]
                		bbb_all0_cc<-t(svd(bbb_all0_c)$v)[1,]
				aaa0<-cor(t(t(bbb_all0_cc)),t(bbb_all0_c))
				aaa0<-aaa0[which(abs(aaa0)>0.6)]
				if(mean(aaa0)<0)
				{
					bbb_all0_cc<--bbb_all0_cc
				}
               		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0_cc)
              	}
		}
		rownames(tg_trunc_RS_bases)<-1:nrow(tg_trunc_RS_bases)
		trunc_RS_bases_all[[i]]<-tg_trunc_RS_bases
		perturb_id<-hcut_update(tg_trunc_list,tg_trunc_list_old)
		ccc<-c()
		for(j in 1:nrow(tg_trunc_RS_bases))
		{
			if(sum(j==perturb_id[[2]])==0)
			{
				ccc<-cbind(ccc,ccc_old[,perturb_id[[3]][j]])
			}
			else
			{
				ttt_c<-tg_trunc_RS_bases[j,]%*%t(tg_trunc_RS_bases[j,])/sum((tg_trunc_RS_bases[j,])^2)
				ccc<-cbind(ccc,RMSE_row(aaa%*%ttt_c)/RMSE_row(aaa))
				#print(c(i,j))
			}
        }
		RMSE_IM[[i]]<-ccc
	}
}
if(hcutn0<nrow(bbb_all0))
{
N<-hcutn
tg_ids<-seq(hcutn+1,nrow(bbb_all0),by=30)
tg_ids<-c(tg_ids,nrow(bbb_all0))
for(i in 1:length(tg_ids))
{
	N<-N+1
	#print(c(N,tg_ids[i]))
	fff<-cutree(h,tg_ids[i])
	hclust_info[[N]]<-fff
	fff0<-unique(fff)
	tg_trunc_list<-list()
	tg_trunc_RS_bases<-c()
	RMSE_table_c<-c()
	st<-0
	if(st==0)
	{
		for(j in 1:length(fff0))
		{
			tg_ccc<-names(which(fff==fff0[j]))
			tg_trunc_list[[j]]<-tg_ccc
			if(length(tg_ccc)==1)
        		{
                		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0[tg_ccc,])
        		}
        		else
        		{
               		bbb_all0_c<-bbb_all0[tg_ccc,]
                		bbb_all0_cc<-t(svd(bbb_all0_c)$v)[1,]
				aaa0<-cor(t(t(bbb_all0_cc)),t(bbb_all0_c))
				aaa0<-aaa0[which(abs(aaa0)>0.6)]
				if(mean(aaa0)<0)
				{
					bbb_all0_cc<--bbb_all0_cc
				}
               		tg_trunc_RS_bases<-rbind(tg_trunc_RS_bases,bbb_all0_cc)
        		}
		}
		rownames(tg_trunc_RS_bases)<-1:nrow(tg_trunc_RS_bases)
		trunc_RS_bases_all[[N]]<-tg_trunc_RS_bases
		ccc<-c()
		for(j in 1:nrow(tg_trunc_RS_bases))
		{
        		ttt_c<-tg_trunc_RS_bases[j,]%*%t(tg_trunc_RS_bases[j,])/sum((tg_trunc_RS_bases[j,])^2)
        		ccc<-cbind(ccc,RMSE_row(aaa%*%ttt_c)/RMSE_row(aaa))
        	}
		RMSE_IM[[N]]<-ccc
	}
}
}
ccc<-list(trunc_RS_bases_all,RMSE_IM,hclust_info)
names(ccc)<-c("Bases_all","RMSE_all","clust_info_all")
return(ccc)
}

Base_screen<-function(bbb_all0,hh,tg_R1_list_stat)
{
	tg_R1_list_stat0<-tg_R1_list_stat
	names(tg_R1_list_stat0)<-1:length(tg_R1_list_stat)
	ttt<-unique(hh)
	merge_list_info<-list()
	R1_selected_c<-c()
	for(i in 1:length(ttt))
	{
		#print(i)
		cc<-names(which(hh==ttt[i]))
		merge_list_info[[i]]<-list(cc,1)
		if(length(cc)==1)
		{
			R1_selected_c<-c(R1_selected_c,cc)
		}
		if(length(cc)==2)
		{
			ddd<-cor(t(bbb_all0[cc,]))
			#print(ddd)
			m1<-max(apply(tg_R1_list_stat0[[cc[1]]],2,mean))
			m2<-max(apply(tg_R1_list_stat0[[cc[2]]],2,mean))
			if(m1>=m2)
			{
				R1_selected_c<-c(R1_selected_c,cc[1])
			}
			else
			{
				R1_selected_c<-c(R1_selected_c,cc[2])
			}
			merge_list_info[[i]][[2]]<-ddd
		}
		if(length(cc)>2)
		{
			ddd<-cor(t(bbb_all0[cc,]))
			fff<-apply(ddd,1,mean)
			ggg<-which(fff==max(fff))
			if(length(ggg)==1)
			{
				R1_selected_c<-c(R1_selected_c,cc[ggg])
			}
			else
			{
				dd<-cc[ggg]
				mm<-c()
				for(j in 1:length(dd))
				{
					mm<-c(mm,max(apply(tg_R1_list_stat0[[dd[j]]],2,mean)))
				}
				ee<-dd[which(mm==max(mm))[1]]
				R1_selected_c<-c(R1_selected_c,ee)
			}
			merge_list_info[[i]][[2]]<-ddd
		}
	}
      return(list(R1_selected_c,merge_list_info))
}

hcut_update<-function(tg_trunc_list,tg_trunc_list_old)
{
	out_list<-rep(0,length(tg_trunc_list))
	for(i in 1:length(tg_trunc_list))
	{
		for(j in 1:length(tg_trunc_list_old))
		{
			if(length(intersect(tg_trunc_list[[i]],tg_trunc_list_old[[j]]))>0)
			{
				out_list[i]<-j
			}
		}
	}
	tg_old_id<-as.numeric(names(which(table(out_list)==2)))
	tg_new_id<-which(out_list==tg_old_id)
	return(list(tg_old_id,tg_new_id,out_list))
}


TestGeneSig <- function(tobj, sig.list, subj.col, df.subj,
                         test.col, test.col.levels, test.to.print=NA,
                         out.dir = ".") {

  library(Seurat)
  library(pROC)

  # Calculate score from genes x samples matrix as average z-score
  get_score <- function(x) {
    x = t(scale(t(x)))
    return (colMeans(x, na.rm=T))
  }

  dat = tobj@data
  meta = tobj@meta.data %>%
    dplyr::rename_(subject = subj.col) %>%
    dplyr::mutate(subject = factor(subject, levels=df.subj$subject))

  df.test = data.frame()

  for(s in seq_along(sig.list)) {
    sig = sig.list[[s]]
    sig.name = names(sig.list)[s]
    cat(sig.name, " ")
    gi = rownames(dat) %in% sig

    dat2 = aggregate(t(as.matrix(dat[gi,,drop=F])), list(subject = meta$subject), mean, drop=F)
    dat2[is.na(dat2)] = 0
    df = dat2 %>%
      left_join(df.subj %>% dplyr::select_("subject",response=test.col), by="subject")

    mat = df %>%
      tibble::column_to_rownames("subject") %>%
      dplyr::select(-response) %>%
      data.matrix()

    if(sum(mat)==0) next

    for(test in c("Ngene","SigScore")) {
      if(test == "Ngene") {
        X = rowSums(mat>0)
      } else if(test == "SigScore") {
        X = get_score(t(mat))
      }
      Y = df$response %>% factor(levels=test.col.levels)
      r = roc(Y,X, direction="<", quiet = T)
      w.pv = wilcox.test(X[Y==test.col.levels[2]], X[Y==test.col.levels[1]], alternative = "greater", exact=F)$p.value
      mean.diff = mean(X[Y==test.col.levels[2]], na.rm=T) - mean(X[Y==test.col.levels[1]], na.rm=T)
      t.stat = ifelse(length(unique(X)) == 1, 0,
                      t.test(X[Y==test.col.levels[2]], X[Y==test.col.levels[1]], alternative = "greater")$statistic)

      df.test = rbind(df.test, data.frame(sig = sig.name, test, auc=r$auc, mean.diff, t.stat, w.pv, N = length(tobj@cell.names)))

      if(test %in% test.to.print) {
        r.df = data.frame(Specificity = r$specificities, Sensitivity=r$sensitivities) %>%
          dplyr::arrange(Sensitivity)

        df.fig = data.frame(subject=df$subject, score=X, Response=factor(Y))
        df.text = data.frame(label.auc=sprintf("AUC = %.2f", r$auc),
                             label.w.pv=sprintf("p = %.2g",w.pv))
        df.text$x = 0.25
        df.text$y = 0.1

        p1 = ggplot(df.fig, aes(x=Response, y=score, group=Response)) +
          geom_boxplot(alpha=1, outlier.colour = NA) +
          geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
          scale_fill_manual(values=c("white", "black"), name="Response",
                            breaks=c(0,2), labels=c("low","high")) +
          geom_text(data = df.text, aes(label=label.w.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
          xlab("Response") + ylab("Score") +
          theme_bw() + theme(legend.position="none") +
          theme(panel.border = element_blank(), strip.background = element_blank(),
                strip.text.x = element_text(size=12),
                panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
                axis.ticks = element_blank())

        p2 = ggplot(r.df, aes(x=Specificity, y=Sensitivity)) +
          geom_line(size=1) +
          geom_abline(intercept = 1, slope = 1, lty=2) +
          scale_x_reverse() +
          geom_text(data=df.text, aes(x=x,y=y,label=label.auc)) +
          coord_fixed() +
          theme_bw() + theme(panel.grid = element_blank())

        pp = plot_grid(p1, p2, ncol=1, rel_heights = c(1, 1))

        fn.fig = file.path(out.dir, glue::glue("{sig.name}_score_vs_response"))
        # ggsave(paste0(fn.fig, ".png"), plot=pp, w=3,h=7)
        ggsave(paste0(fn.fig, ".pdf"), plot=pp, w=3,h=7)
      }
    }
  }
  return(df.test)
}


#!/usr/bin/r -ti

suppressMessages(library(Rcpp))
suppressMessages(library(inline))

# R function that will be called from C++
vecfunc <- function(x) {
    y <- x^1.05                         # do a transformation
    print(y)                            # but also print
    plot(y, ylim=c(1,8), type='b')      # and even plot
    Sys.sleep(0.225)                    # sleep before next call
    return(y)
}

# C++ source code to operate on function and vector
cpp <- '
	int n = as<int>(N);
	NumericVector numvec(xvec) ;
	Function f(fun) ;
	for( int i=0; i<n; i++){
		numvec = f( numvec ) ;
	}
	return numvec ;
'

# create a C++ function
funx <- cfunction(signature(N = "integer" , xvec = "numeric", fun = "function" ),
                  cpp, , Rcpp = TRUE, include = "using namespace Rcpp; ")

# create the vector
xvec <- sqrt(c(1:12, 11:1))

# set up x11
x11(width=3,height=3)
par(mar=c(3,3,1,1),cex=0.8, pch=19)

# run example
funx( 10L, xvec, vecfunc )


context('Functions for merging constraints')

test_that("spatiotemporal tunnel har is computationally tractable", {
	r <- generate_and_add_velocity_constraint(multiconstraint, 1.0, 1.0, 7)
	res <- lpsolve_force_in_dir("max", r, indices_for_muscles=muscle_and_lambda_indices(r, 7)$indices_for_muscles)
	global_solution <- res$raw_x_concatenated
	valid <- evaluate_solution(global_solution, r)
	point_list <- r %>% har_sample(1e1, eliminate=FALSE)
})

test_that("two constraints can be combined without affecting one another's individual outputs", {
	# fx_constraint
	first_constraint<- a_matrix_lhs_direction(H_matrix, direction = c(1,0,0,0), bounds_tuple_of_numeric)
	# fy_constraint
	second_constraint<- a_matrix_lhs_direction(H_matrix, direction = c(0,1,0,0), bounds_tuple_of_numeric)
	merged_constraint <- diagonal_merge_constraints(first_constraint, second_constraint, "2")
})

test_that("velocity helper functions work", {
	expect_equal(transition_names(c("a","b","c","d","e","f")), c("a_to_d", "b_to_e" ,"c_to_f"))
	expect_equal(transition_names(c("a","b","c","d")), c("a_to_c", "b_to_d"))
})

context("compare independent constraints to merged constraints")
test_that("merging constraints yields the same result as independent constraints", {
	# fx_constraint line
	first_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,0,0,0), bounds_tuple_of_numeric)
	# fy_constraint line
	second_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(0,1,0,0), bounds_tuple_of_numeric)
	# go back to fx line
	third_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,0,0,0), bounds_tuple_of_numeric)
	list_of_constraints <- list(first_constraint, second_constraint,third_constraint,third_constraint,third_constraint,third_constraint)
	context('basecase')
	expect_equal(list_of_constraints[[1]],diagonal_merge_constraint_list(list_of_constraints[1]))
	expect_equal(list_of_constraints[[2]],diagonal_merge_constraint_list(list_of_constraints[2]))
	expect_equal(list_of_constraints[[3]],diagonal_merge_constraint_list(list_of_constraints[3]))
	diagonal_merge_constraint_list(list_of_constraints[1:2])
	diagonal_merge_constraint_list(list_of_constraints[1:3])

	big <- diagonal_merge_constraint_list(list_of_constraints)
	num_muscles <- 7
	indices <- muscle_and_lambda_indices(big, num_muscles)
	conglomerate_constraint <- lpsolve_force_in_dir("max", big, indices_for_muscles=indices$indices_for_muscles)
	standalone_constraint   <- lpsolve_force_in_dir("max", first_constraint, indices_for_muscles=1:7)
	standalone_constraint2  <- lpsolve_force_in_dir("max", second_constraint, indices_for_muscles=1:7)
	expect_equal(conglomerate_constraint$output_vector_per_task[[1]], standalone_constraint$output_vector_per_task[[1]])
	expect_equal(conglomerate_constraint$output_vector_per_task[[2]], standalone_constraint2$output_vector_per_task[[1]])
	colnames(big$constr) <- colnames(big$constr)
	multiconstraint <- big
	devtools::use_data(multiconstraint, overwrite=TRUE)
})

context("har on independent constraints w/o velocity")
test_that("we can generate and har upon each task polytope independently", {
    positive_fx_direction_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,
        0, 0, 0), bounds_tuple_of_numeric)
    indices_for_muscles <- 1:7
    fmax_info <- lpsolve_force_in_dir("max", positive_fx_direction_constraint, indices_for_muscles)
    tasks_and_constraints <- generate_tasks_and_corresponding_constraints(H_matrix=H_matrix, vector_out = fmax_info$output_vector_per_task[[1]] *
        (1 - 1e-05), n_task_values = 5, cycles_per_second = 60, cyclical_function = force_cos_ramp,
        bounds_tuple_of_numeric=bounds_tuple_of_numeric)

	inequality_constraints <- diagonal_merge_constraint_list(tasks_and_constraints$constraint)
	st_constr <- generate_and_add_velocity_constraint(inequality_constraints, 0.042, 0.040, 7)
    a <- plot_constraint_matrix(st_constr)
    st_task_and_constraint <- list(st_constr = st_constr, tasks_and_independent_constraints = tasks_and_constraints)
    devtools::use_data(st_task_and_constraint, overwrite = TRUE)

        tasks_and_constraints <- generate_tasks_and_corresponding_constraints(H_matrix=H_matrix, vector_out = fmax_info$output_vector_per_task[[1]] *
        (1 - 1e-05), n_task_values = 10, cycles_per_second = 60, cyclical_function = force_cos_ramp,
        bounds_tuple_of_numeric=bounds_tuple_of_numeric)

	inequality_constraints <- diagonal_merge_constraint_list(tasks_and_constraints$constraint)
	st_constr <- generate_and_add_velocity_constraint(inequality_constraints, 0.042, 0.040, 7)
    a <- plot_constraint_matrix(st_constr)
    st_task_and_constraint <- list(st_constr = st_constr, tasks_and_independent_constraints = tasks_and_constraints)
    devtools::use_data(st_task_and_constraint, overwrite = TRUE)
    print(microbenchmark("50"={ b <- st_task_and_constraint[[1]] %>% eliminate_redundant}, times=1))
    fmax_info$output_vector_per_task[[1]]

	inequality_constraints <- diagonal_merge_constraint_list(tasks_and_constraints$constraint)
	st_constr <- generate_and_add_velocity_constraint(inequality_constraints, 0.042, 0.040, 7)
    a <- plot_constraint_matrix(st_constr)
    st_task_and_constraint <- list(st_constr = st_constr, tasks_and_independent_constraints = tasks_and_constraints)
    devtools::use_data(st_task_and_constraint, overwrite = TRUE)
    mbm <- microbenchmark("100"={
    	c <- st_task_and_constraint[[1]] %>% eliminate_redundant
    },
     times=1)
   })

test_that("force_cos_ramp_constraint", {

	fmax_info <- maximize_wrench(H_matrix, bounds_tuple_of_numeric, direction=c(1,0,0,0))
	st_constr_str <- force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 1.0,1.0, n_task_values=10)
	list_of_constraints <- st_constr_str[[2]]$constraints
	 har_constraint_pairs_velocity_constrained <- har_and_split_trajectory_constraint(st_constr_str$nonredundant_constr, list_of_constraints, list_of_tasks,
    num_muscles=ncol(H_matrix), har_samples=1e4, mc.cores=8, tol=1e-11)
	mbm <- microbenchmark(
		"8 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=3);print('Ø')},
		"9 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=4);print('Ø')},
		"10 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=4);print('Ø')},
		"11 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=5);print('Ø')},
		times=1
	)
	print(mbm)
	print(summary(mbm))
	plot(mbm)
	print('NEXT')

	mbm <- microbenchmark(
		"12 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=12);print('Ø')},
		"13 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=13);print('Ø')},
		"14 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=14);print('Ø')},
		"15 task_v_constr" = {force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, fmax_info$output_vector_per_task[[1]], 0.8,0.8, n_task_values=15);print('Ø')},
		times=1
	)
	print(mbm)
	print(summary(mbm))
	plot(mbm)
})


install.packages()
library()
read_graph()
V()
upgrade_graph()
as_adjacency_matrix()
plot()
rnorm()
ecount()
induced.subgraph()
round()
page_rank()
walktrap.community()
degree()
hist()
cliques()
simplify()
delete.vertices()
set_vertex_attr()
is_connected()
eigen_centrality()
make_line_graph()
decompose()
cohesive_blocks()
max_flow()
mean_distance()
neighbors()
intersection()
sort()
induced_subgraph()
dfs()
ego_size()
power_centrality()


setwd('C:\\temp\\CryptoHistory\\Analytics\\integration')

library(quantmod);
library(forecast)
library(tseries)

setSymbolLookup(
  KrakenBtcUsd  = list(src="csv"), format="yyyy-MM-ddTHH:mm:ss.fffZ");

trades <-  getSymbols("KrakenBtcUsd", auto.assign=FALSE);


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1

#Add Year column
dftrain[,"Year"] <- (as.numeric(format(as.Date(dftrain$Date), "%Y")))

#adjust sales in weeks 47, 48 and 49 in 2010 to have same number of sale days in week 49 than in 2012
dfchristmas <- dftrain %>% filter(Year == 2010) %>% filter((Seasonality == 47) | (Seasonality == 48) | (Seasonality == 49))

# for every store (45)
for (i in 1:45)
{
	#for every department (99)
	for (j in 1:99)
	{
			#do we have train data?
			dfsample <- dfchristmas %>%
				filter(Store == i) %>%
				filter(Dept == j)
			if(nrow(dfsample) < 3) next
			inc_sales <- sum(dfsample$Weekly_Sales) * 3 / 21
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 47)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 47)&(dftrain$Year == 2010)] <- old - (inc_sales / 2)
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 48)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 48)&(dftrain$Year == 2010)] <- old - (inc_sales / 2)
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 49)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 49)&(dftrain$Year == 2010)] <- old + inc_sales
	}
}

#adjust sales in weeks 47, 48 and 49 in 2011 to have same number of sale days in week 49 than in 2012
dfchristmas <- dftrain %>% filter(Year == 2011) %>% filter((Seasonality == 47) | (Seasonality == 48) | (Seasonality == 49))

# for every store (45)
for (i in 1:45)
{
	#for every department (99)
	for (j in 1:99)
	{
			#do we have train data?
			dfsample <- dfchristmas %>%
				filter(Store == i) %>%
				filter(Dept == j)
			if(nrow(dfsample) < 3) next
			inc_sales <- sum(dfsample$Weekly_Sales) * 2 / 21
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 47)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 47)&(dftrain$Year == 2011)] <- old - (inc_sales / 2)
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 48)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 48)&(dftrain$Year == 2011)] <- old - (inc_sales / 2)
			old <- dfsample$Weekly_Sales[(dfsample$Seasonality == 49)]
			dftrain$Weekly_Sales[(dftrain$Store==i)&(dftrain$Dept == j)&(dftrain$Seasonality == 49)&(dftrain$Year == 2011)] <- old + inc_sales
	}
}

#save results in a csv file
write.csv(file = "massagedtrain.csv", x = subset(dftrain, select = c(Store, Dept, Date, Weekly_Sales, IsHoliday)), row.names=FALSE)


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("randomForest")
# install.packages("ROCR")
# install.packages("caret")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(randomForest) # This package is specifically loaded for imports85 dataset shipped within it.
library(ROCR)
library(caret)

# Here we directly load the imports85 dataset installed with the "randomForest" package.
data(imports85)

# rename column names in imports85 dataset from randomForest package
importsOriginal <- setNames(imports85, c("Symboling","Normalized_Losses","Make","Fuel_Type","Aspiration","Num_Of_Doors","Body_Style","Drive_Wheels","Engine_Location",
"Wheel_Base","Length","Width","Height","Curb_Weight","Engine_Type","Num_Of_Cylinders","Engine_Size","Fuel_System","Bore","Stroke","Compression_Ratio",
"Horse_Power","Peak_Rpm","City_Mpg","Highway_Mpg","Price"))

# Omit rows with missing values
importsOriginal <- na.omit(importsOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# imports<- read.csv("Imports.csv")

# Randomizing data
imports<-importsOriginal[sample(nrow(importsOriginal)),]

# Divide dataset for training and test
trainData <- imports[1:124, ]
testData  <- imports[125:155, ]

# Set predicted field in formula
formula = formula(Fuel_Type ~ .)

# Create model for training set using naiveBayes
importsTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "fuelType" column for test data set
importsTestPrediction <- predict(importsTrainingModel, testData)
# Display predicted values
importsTestPrediction

# Create cross table to check on accuracy.

CrossTable(importsTestPrediction, testData$Fuel_Type,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# PMML generation
saveXML(pmml(importsTrainingModel, predictedField = "Fuel_Type"), "Imports.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original imports data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(importsTrainingModel, newdata = importsOriginal, threshold = 0, type = "class")
probabilities = predict(importsTrainingModel, newdata = importsOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file)
{
	result = NULL
	if(is.null(probabilities))
	{
		result = data.frame(classes)
		names(result) = c("fuelType")
	}
	else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("fuelType", "DieselFuelTypeProbability","GasFuelTypeProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")