#------------------------------------------------------------------------------
# The threshold value of nuber of rows by which calculate.residual() method
# separates large and small dataset.
#------------------------------------------------------------------------------
THRESHOLD_NROW_FOR_SMALL_DATASET = 1000

#------------------------------------------------------------------------------
#'	(Internal) A reference class calculate partial residuals.
#'
#'	@field settings
#'		pp.settings object having settings of the class.
#'
#'	@field data
#'		a numeric vector having calculated partial residual data.
#'
#'	@include pp.settings.r
#------------------------------------------------------------------------------
partial.residual <- setRefClass(
	"partial.residual",
	fields = list(settings = "pp.settings", data = "numeric")
)

#------------------------------------------------------------------------------
partial.residual$methods(
	initialize = function(settings) {
		"
		Initialize class and calculate residuals.

		\\describe{
			\\item{\\code{settings}}{\\code{\\link{pp.settings}} object.}
		}
		"
		# Initialize settings.
		if (missing(settings)) {
			return()
		}
		initFields(settings = settings)
		# Calculate partial residual if possible.
		if (identical(settings$adapter$link, binomial()$linkfun)) {
			message <- paste(
				"Currently, partial residual can't be calculated",
				"for logit link function."
			)
			warning(message)
		} else {
			lsmeans.compatible <- !any(
				class(settings$model) %in% LSMEANS_INCOMPATIBLE_MODELS
			)
			if (lsmeans.compatible) {
				.self$calculate.residuals.lsmeans()
			} else {
				.self$calculate.residuals()
			}
			settings$set.residual(.self)
		}
	}
)

#------------------------------------------------------------------------------
#	Assume that creating a model predicts petal length (PL) by petal width (PW)
#	and sepal length (SL) and species (SP) and their interactions.
#		i: intercept			r: residual
#
#	PL      = i + PW + SL + SP + PW:SP + SL:SP + r		# Response variable
#	PL      = i + PW + SL + SP + PW:SP + SL:SP			# FULL MODEL
#	PL      =                                  + r		# Residual
#	predict = i + PW + SL + SP + PW:SP + SL:SP			# Result of predict()
#
#	To see the partial relationship between PL and SL...
#
#	If we want to plot contrast plot, partial residual is:
#	PL      = i + PW    0 + SP + PW:SP       0 + r
#
#	To see this, we need to remove:
#	PL      =        + SL              + SL:SP		    # Remove these effects
#
#	lsmeans() calculates:
#	LSMEANS = i + MM + SL + SP + MM:SP + SL:SP
#		where MM is mean of petal width (PW).
#
#	So when using lsmeans(), i.e., conditional plot, partial residual is:
#	LSMEANS = i + MM + SL + SP + MM:SP + SL:SP + r
#
#	This can be achieved using predict() with using mean values for
#	petal width (PW) and adding residual for it.
#	However, becase MCMCglmm show deviated values from this calculation,
#	currently partial residual for MCMCglmm (and models compatible with
#	lsmeans) are calculated by special method.
#
#	For non-linear models with interaction such as Random Forest, population
#	predicted values for given value of focal explanatory variable cannot be
#	calculated by fixing values of other explanatory variables to their
#	mean/median.
#	Therefore, the predicted values for given set of values of focal
#	explanatory variable are calculated using all dataset as similar way to
#	calculate partial relationship.
#
#	For performance issue, this method change the method used for calculating
#	fitted value. For small dataset, get.fit.for.small.data() method is called.
#	For large dataset, get.fit.for.large.data() method is called.
#------------------------------------------------------------------------------
partial.residual$methods(
	calculate.residuals = function() {
		"
		Calculate partial residuals.
		"
		# Prepare data for partial residual.
		newdata <- lapply(
			1:nrow(.self$settings$data), "[.data.frame",
			x = .self$settings$data,
		)
		# Change calculation method based on the sample size.
		if (nrow(.self$settings$data) < THRESHOLD_NROW_FOR_SMALL_DATASET) {
			fit <- .self$settings$cluster.apply(
				newdata, .self$get.fit.for.small.data
			)
		} else {
			relationship <- .self$extended.partial.relationship()
			fit <- .self$settings$cluster.apply(
				newdata, .self$get.fit.for.large.data, relationship
			)
		}
		fit <- unlist(fit)
		residual <- fit + .self$settings$adapter$residuals(.self$settings$type)
		if (.self$settings$type == "response") {
			residual <- .self$settings$adapter$linkinv(residual)
		}
		.self$data <- residual
	}
)

#------------------------------------------------------------------------------
partial.residual$methods(
	get.fit.for.small.data = function(x) {
		"
		Calculate fitted value for a observation.

		\\describe{
			\\item{x}{a data.frame of one row representing one observation.}
		}
		"
		on.exit(gc())
		newdata <- .self$settings$data
		for (i in .self$settings$x.names) {
			newdata[[i]] <- x[[i]]
		}
		fit <- .self$settings$adapter$predict(newdata = newdata, type = "link")
		fit <- mean(fit$fit[, "fit"])
		return(fit)
	}
)

#------------------------------------------------------------------------------
partial.residual$methods(
	get.fit.for.large.data = function(x, relationship) {
		"
		Calculate fitted value for a observation.

		This function uses approximation using estimated relationship
		for calculating fitted value.

		\\describe{
			\\item{x}{a data.frame of one row representing one observation.}
			\\item{relationship}{a data.frame having predicted relationship.}
		}
		"
		on.exit(gc())
		for (i in .self$settings$x.names.factor) {
			relationship <- relationship[relationship[[i]] == x[[i]], ]
		}
		index <- relationship[.self$settings$x.names.numeric]
		for (i in .self$settings$x.names.numeric) {
			index[[i]] <- index[[i]] > x[[i]]
		}
		index <- Position(function(x) x, apply(index, 1, all))
		if (length(settings$x.names.numeric) == 1) {
			f <- as.formula(sprintf("fit ~ %s", .self$settings$x.names.numeric))
			d <- relationship[c(index - 1, index),]
		} else {
			x.names <- paste(.self$settings$x.names.numeric, collapse = "+")
			f <- as.formula(sprintf("fit ~ %s", x.names))
			res <- .self$settings$resolution
			d <- relationship[
				c(index, index - 1, index - res, index - res - 1),
			]
		}
		r <- lm(f, data = d)
		fit <- predict(r, newdata = x)
		return(fit)
	}
)

#------------------------------------------------------------------------------
partial.residual$methods(
	extended.partial.relationship = function() {
		sequences <- .self$extend.sequences(.self$settings$numeric.sequences)
		grid <- do.call(
			expand.grid, c(sequences, .self$settings$factor.levels)
		)
		new.settings <- .self$settings$copy()
		pr <- partial.relationship(new.settings)
		result <- pr$calculate.relationship(grid)
		return(result)
	}
)

#------------------------------------------------------------------------------
partial.residual$methods(
	extend.sequences = function(sequences) {
		"
		Return extended 'numeric.sequences' of pp.settings.
		"
		for (i in names(sequences)) {
			len <- length(sequences[[i]])
			new.value <-  2 * sequences[[i]][len] - sequences[[i]][len - 1]
			sequences[[i]] <- c(sequences[[i]], new.value)
		}
		return(sequences)
	}
)

#------------------------------------------------------------------------------
partial.residual$methods(
	calculate.residuals.lsmeans = function() {
		"
		Calculate partial residuals for lsmeans compatible models.
		"
		# Prepare names of numeric variables.
		x.names <- .self$settings$adapter$x.names(type = "base")
		all.numerics <- x.names[
			sapply(.self$settings$data[x.names], is.numeric)
		]
		other.numerics <- all.numerics[
			!all.numerics %in% .self$settings$x.names.numeric
		]
		# Calculate prediction 1.
		data1 <- .self$settings$data
		for (i in other.numerics) {
			data1[[i]] <- data1[[i]] - mean(data1[[i]])
		}
		data1[.self$settings$x.names.numeric] <- 0
		pred1 <- .self$settings$adapter$predict(
		  newdata = data1, type = "link", interval = "prediction"
		)
		pred1 <- pred1$fit[, "fit"]
		# Calculate prediction 2.
		data2 <- .self$settings$data
		data2[all.numerics] <- 0
		pred2 <- .self$settings$adapter$predict(
		  newdata = data2, type = "link", interval = "prediction"
		)
		pred2 <- pred2$fit[, "fit"]
		# Calculate partial residual.
		result <- (
			.self$settings$adapter$link(
				.self$settings$data[[.self$settings$adapter$y.names()]]
			)
			- (pred1 - pred2)
		)
		if (.self$settings$type == "response") {
			result <- .self$settings$adapter$linkinv(result)
		}
		.self$data <- result
	}
)


#SNOPSIS
#calculates genomic estimated breeding values (GEBVs) using rrBLUP,
#GBLUP method

#AUTHOR
# Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(methods)
library(rrBLUP)
library(plyr)
library(stringr)
#library(lme4)
library(randomForest)
library(parallel)
library(genoDataFilter)
library(phenoAnalysis)
library(caret)
library(dplyr)
library(tibble)
library(rlang)
library(jsonlite)
library(data.table)

allArgs <- commandArgs()

inputFiles  <- scan(grep("input_files", allArgs, value = TRUE),
                   what = "character")

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

traitsFile <- grep("traits", inputFiles,  value = TRUE)
modelInfoFile  <- grep("model_info", inputFiles, value = TRUE)
message('model_info_file ', modelInfoFile)

modelInfo  <- read.table(modelInfoFile,
                         header=TRUE, sep ="\t",
                         as.is = c('Value'))

modelInfo  <- column_to_rownames(modelInfo, var="Name")
traitId    <- modelInfo["trait_id", 1]
traitAbbr  <- modelInfo["trait_abbr", 1]
modelId    <- modelInfo["model_id", 1]
protocolId <- modelInfo["protocol_id", 1]

message('class ', class(traitAbbr))
message('trait_id ', traitId)
message('trait_abbr ', traitAbbr)
message('protocol_id ', protocolId)
message('model_id ', modelId)

datasetInfoFile <- grep("dataset_info", inputFiles, value = TRUE)
datasetInfo     <- c()

if (length(datasetInfoFile) != 0 ) {
    datasetInfo <- scan(datasetInfoFile, what = "character")
    datasetInfo <- paste(datasetInfo, collapse = " ")
  } else {
    datasetInfo <- c('single population')
  }

#validationTrait <- paste("validation", trait, sep = "_")
validationFile  <- grep('validation', outputFiles, value = TRUE)

if (is.null(validationFile)) {
  stop("Validation output file is missing.")
}

#kinshipTrait <- paste("rrblup_training_gebvs", trait, sep = "_")
blupFile     <- grep('rrblup_training_gebvs', outputFiles, value = TRUE)

if (is.null(blupFile)) {
  stop("GEBVs file is missing.")
}

#markerTrait <- paste("marker_effects", trait, sep = "_")
markerFile  <- grep('marker_effects', outputFiles, value = TRUE)

#traitPhenoFile <- paste("trait_phenotype_data", traitId, sep = "_")
modelPhenoFile <- grep('model_phenodata', outputFiles, value = TRUE)
message('model input trait pheno file ', modelPhenoFile)
traitRawPhenoFile <- grep('trait_raw_phenodata', outputFiles, value = TRUE)
varianceComponentsFile <- grep("variance_components", outputFiles, value = TRUE)
filteredGenoFile       <- grep("filtered_genotype_data", outputFiles, value = TRUE)
formattedPhenoFile     <- grep("formatted_phenotype_data", inputFiles, value = TRUE)

genoFile <- grep("genotype_data_", inputFiles, value = TRUE)

if (is.null(genoFile)) {
  stop("genotype data file is missing.")
}

if (file.info(genoFile)$size == 0) {
  stop("genotype data file is empty.")
}

readFilteredGenoData <- c()
filteredGenoData <- c()
formattedPhenoData <- c()
phenoData          <- c()
genoData           <- c()

if (length(filteredGenoFile) != 0 && file.info(filteredGenoFile)$size != 0) {
    filteredGenoData     <- fread(filteredGenoFile,
                                  na.strings = c("NA", "", "--", "-"),
                                  header = TRUE)

    genoData <-  data.frame(filteredGenoData)
    genoData <- column_to_rownames(genoData, 'V1')
    readFilteredGenoData <- 1
}

if (is.null(filteredGenoData)) {
    genoData <- fread(genoFile,
                      na.strings = c("NA", "", "--", "-"),
                      header = TRUE)

    genoData <- unique(genoData, by='V1')
    genoData <- data.frame(genoData)
    genoData <- column_to_rownames(genoData, 'V1')

  #genoDataFilter::filterGenoData
    genoData <- convertToNumeric(genoData)
    genoData <- filterGenoData(genoData, maf=0.01)
    genoData <- roundAlleleDosage(genoData)

    filteredGenoData   <- genoData

}

genoData <- genoData[order(row.names(genoData)), ]

if (length(formattedPhenoFile) != 0 && file.info(formattedPhenoFile)$size != 0) {
    formattedPhenoData <- data.frame(fread(formattedPhenoFile,
                                           header = TRUE,
                                           na.strings = c("NA", "", "--", "-", ".")
                                            ))

} else {

    if (datasetInfo == 'combined populations') {

         phenoFile <- grep("model_phenodata", inputFiles, value = TRUE)
    } else {

        phenoFile <- grep("\\/phenotype_data", inputFiles, value = TRUE)
    }

    if (is.null(phenoFile)) {
        stop("phenotype data file is missing.")
    }

    if (file.info(phenoFile)$size == 0) {
        stop("phenotype data file is empty.")
    }

    phenoData <- data.frame(fread(phenoFile,
                                  sep = "\t",
                                  na.strings = c("NA", "", "--", "-", "."),
                                  header = TRUE))

}

phenoTrait <- c()
traitRawPhenoData <- c()

if (datasetInfo == 'combined populations') {

   if (!is.null(formattedPhenoData)) {
      phenoTrait <- subset(formattedPhenoData, select = traitAbbr)
      phenoTrait <- na.omit(phenoTrait)

  } else {

      if (any(grepl('Average', names(phenoData)))) {
          phenoTrait <- phenoData %>% select(V1, Average) %>% data.frame
      } else {
          phenoTrait <- phenoData
      }

      colnames(phenoTrait)  <- c('genotypes', traitAbbr)
  }
 } else {

     if (!is.null(formattedPhenoData)) {
         phenoTrait <- subset(formattedPhenoData, select = c('V1', traitAbbr))
         phenoTrait <- as.data.frame(phenoTrait)
         phenoTrait <- na.omit(phenoTrait)
         print(head(phenoTrait))
         colnames(phenoTrait)[1] <- 'genotypes'

     } else if (length(grep('list', phenoFile)) != 0) {
 message('phenoTrait traitAbbr ', traitAbbr)
         phenoTrait <- averageTrait(phenoData, traitAbbr)

     } else {
         print(head(phenoTrait))
          print(head(phenoData))
         message('phenoTrait trait_abbr ', traitAbbr)
         print(class(traitAbbr))
         print(traitAbbr)
         phenoTrait <- getAdjMeans(phenoData,
                                   traitName = traitAbbr,
                                   calcAverages = TRUE)
     }

     keepMetaCols <- c('observationUnitName', 'germplasmName', 'studyDbId', 'locationName',
                    'studyYear', 'replicate', 'blockNumber')

      traitRawPhenoData <- phenoData %>%
                                          select(c(keepMetaCols, traitAbbr))

}

print('phenoTrait')
print(head(phenoTrait))
meanType <- names(phenoTrait)[2]
names(phenoTrait)  <- c('genotypes', traitAbbr)

selectionTempFile <- grep("selection_population", inputFiles, value = TRUE)

selectionFile       <- c()
filteredPredGenoFile <- c()
selectionAllFiles   <- c()

if (length(selectionTempFile) !=0 ) {
  selectionAllFiles <- scan(selectionTempFile, what = "character")

  selectionFile <- grep("\\/genotype_data", selectionAllFiles, value = TRUE)

  #filteredPredGenoFile   <- grep("filtered_genotype_data_",  selectionAllFiles, value = TRUE)
}

selectionPopGEBVsFile <- grep("rrblup_selection_gebvs", outputFiles, value = TRUE)

selectionData            <- c()
readFilteredPredGenoData <- c()
filteredPredGenoData     <- c()

## if (length(filteredPredGenoFile) != 0 && file.info(filteredPredGenoFile)$size != 0) {
##   selectionData <- fread(filteredPredGenoFile, na.strings = c("NA", " ", "--", "-"),)
##   readFilteredPredGenoData <- 1

##   selectionData           <- data.frame(selectionData)
##   rownames(selectionData) <- selectionData[, 1]
##   selectionData[, 1]      <- NULL

## } else
if (length(selectionFile) != 0) {

    selectionData <- fread(selectionFile,
                           header = TRUE,
                           na.strings = c("NA", "", "--", "-"))

    selectionData <- unique(selectionData, by='V1')
    selectionData <- data.frame(selectionData)
    selectionData <- column_to_rownames(selectionData, 'V1')

    selectionData <- convertToNumeric(selectionData)
    selectionData <- filterGenoData(selectionData, maf=0.01)
    selectionData <- roundAlleleDosage(selectionData)

    filteredPredGenoData <- selectionData
}

#impute genotype values for obs with missing values,
genoDataMissing <- c()

if (sum(is.na(genoData)) > 0) {
  genoDataMissing<- c('yes')

  genoData <- na.roughfix(genoData)
  genoData <- data.frame(genoData)
}

#create phenotype and genotype datasets with
#common stocks only

#extract observation lines with both
#phenotype and genotype data only.
commonObs           <- intersect(phenoTrait$genotypes, row.names(genoData))
commonObs           <- data.frame(commonObs)
rownames(commonObs) <- commonObs[, 1]

#include in the genotype dataset only phenotyped lines
genoDataFilteredObs <- genoData[(rownames(genoData) %in% rownames(commonObs)), ]

#drop phenotyped lines without genotype data
phenoTrait <- phenoTrait[(phenoTrait$genotypes %in% rownames(commonObs)), ]

phenoTraitMarker           <- data.frame(phenoTrait)
rownames(phenoTraitMarker) <- phenoTraitMarker[, 1]
phenoTraitMarker[, 1]      <- NULL

#impute missing data in prediction data
selectionDataMissing <- c()
if (length(selectionData) != 0) {
  #purge markers unique to both populations
  commonMarkers       <- intersect(names(data.frame(genoDataFilteredObs)), names(selectionData))
  selectionData      <- subset(selectionData, select = commonMarkers)
  genoDataFilteredObs <- subset(genoDataFilteredObs, select= commonMarkers)

  if (sum(is.na(selectionData)) > 0) {
    selectionDataMissing <- c('yes')
    selectionData <- na.roughfix(selectionData)
    selectionData <- data.frame(selectionData)
  }
}

#change genotype coding to [-1, 0, 1], to use the A.mat ) if  [0, 1, 2]
genoTrCode <- grep("2", genoDataFilteredObs[1, ], value = TRUE)
if(length(genoTrCode) != 0) {
  genoData            <- genoData - 1
  genoDataFilteredObs <- genoDataFilteredObs - 1
}

if (length(selectionData) != 0 ) {
  genoSlCode <- grep("2", selectionData[1, ], value = TRUE)
  if (length(genoSlCode) != 0 ) {
    selectionData <- selectionData - 1
  }
}

ordered.markerEffects <- c()
trGEBV                <- c()
validationAll         <- c()
combinedGebvsFile     <- c()
allGebvs              <- c()
modelPhenoData        <- c()
relationshipMatrix    <- c()

#additive relationship model
#calculate the inner products for
#genotypes (realized relationship matrix)
relationshipMatrixFile <- grep("relationship_matrix_table", outputFiles, value = TRUE)
relationshipMatrixJsonFile <- grep("relationship_matrix_json", outputFiles, value = TRUE)

traitRelationshipMatrixFile <- grep("relationship_matrix_adjusted_table", outputFiles, value = TRUE)
traitRelationshipMatrixJsonFile <- grep("relationship_matrix_adjusted_json", outputFiles, value = TRUE)

inbreedingFile <- grep('inbreeding_coefficients', outputFiles, value=TRUE)
aveKinshipFile <- grep('average_kinship', outputFiles, value=TRUE)

inbreeding <- c()
aveKinship <- c()

if (length(relationshipMatrixFile) != 0) {
  if (file.info(relationshipMatrixFile)$size > 0 ) {
      relationshipMatrix <- data.frame(fread(relationshipMatrixFile,
      			 header = TRUE))

      rownames(relationshipMatrix) <- relationshipMatrix[, 1]
      relationshipMatrix[, 1]      <- NULL
      colnames(relationshipMatrix) <- rownames(relationshipMatrix)
      relationshipMatrix           <- data.matrix(relationshipMatrix)

  } else {
    relationshipMatrix           <- A.mat(genoData)
    diag(relationshipMatrix)     <- diag(relationshipMatrix) + 1e-6

    inbreeding <- diag(relationshipMatrix)
    inbreeding <- inbreeding - 1

    inbreeding <- inbreeding %>% replace(., . < 0, 0)
    inbreeding <- data.frame(inbreeding)

    inbreeding <- inbreeding %>%
        rownames_to_column('genotypes') %>%
        rename(Inbreeding = inbreeding) %>%
        arrange(Inbreeding) %>%
        mutate_at('Inbreeding', round, 3) %>%
        column_to_rownames('genotypes')
  }
}

relationshipMatrix <- data.frame(relationshipMatrix)
colnames(relationshipMatrix) <- rownames(relationshipMatrix)

relationshipMatrix <- rownames_to_column(relationshipMatrix, var="genotypes")
relationshipMatrix <- relationshipMatrix %>% mutate_if(is.numeric, round, 3)
relationshipMatrix <- column_to_rownames(relationshipMatrix, var="genotypes")

traitRelationshipMatrix <- relationshipMatrix[(rownames(relationshipMatrix) %in% rownames(commonObs)), ]
traitRelationshipMatrix <- traitRelationshipMatrix[, (colnames(traitRelationshipMatrix) %in% rownames(commonObs))]

traitRelationshipMatrix <- data.matrix(traitRelationshipMatrix)

#relationshipMatrixFiltered <- relationshipMatrixFiltered + 1e-3

nCores <- detectCores()

if (nCores > 1) {
  nCores <- (nCores %/% 2)
} else {
  nCores <- 1
}

if (length(selectionData) == 0) {

  trModel  <- kin.blup(data   = phenoTrait,
                      geno   = 'genotypes',
                      pheno  = traitAbbr,
                      K      = traitRelationshipMatrix,
                      n.core = nCores,
                      PEV    = TRUE
                     )

  trGEBV    <- trModel$g
  trGEBVPEV <- trModel$PEV
  trGEBVSE  <- sqrt(trGEBVPEV)
  trGEBVSE  <- data.frame(round(trGEBVSE, 2))

  trGEBV <- data.frame(round(trGEBV, 2))

  colnames(trGEBVSE) <- c('SE')
  colnames(trGEBV) <- traitAbbr

  trGEBVSE <- rownames_to_column(trGEBVSE, var="genotypes")
  trGEBV   <- rownames_to_column(trGEBV, var="genotypes")

  trGEBVSE <- full_join(trGEBV, trGEBVSE)

  trGEBVSE <-  trGEBVSE %>% arrange_(.dots= paste0('desc(', traitAbbr, ')'))

  trGEBVSE <- column_to_rownames(trGEBVSE, var="genotypes")

  trGEBV <- trGEBV %>% arrange_(.dots = paste0('desc(', traitAbbr, ')'))
  trGEBV <- column_to_rownames(trGEBV, var="genotypes")

  phenoTraitMarker    <- data.matrix(phenoTraitMarker)
  genoDataFilteredObs <- data.matrix(genoDataFilteredObs)

  markerEffects <- mixed.solve(y = phenoTraitMarker,
                               Z = genoDataFilteredObs
                               )

  ordered.markerEffects <- data.matrix(markerEffects$u)
  ordered.markerEffects <- data.matrix(ordered.markerEffects [order (-ordered.markerEffects[, 1]), ])
  ordered.markerEffects <- round(ordered.markerEffects, 5)

  colnames(ordered.markerEffects) <- c("Marker Effects")
  ordered.markerEffects <- data.frame(ordered.markerEffects)

  modelPhenoData   <- data.frame(round(phenoTraitMarker, 2))

  heritability  <- round((trModel$Vg/(trModel$Ve + trModel$Vg)), 2)
  additiveVar <- round(trModel$Vg, 2)
  errorVar <- round(trModel$Ve, 2)

  cat("\n", file = varianceComponentsFile,  append = FALSE)
  cat('Additive genetic variance', additiveVar , file = varianceComponentsFile, sep = '\t', append = TRUE)
  cat("\n", file = varianceComponentsFile,  append = TRUE)
  cat('Error variance', errorVar, file = varianceComponentsFile, sep = "\t", append = TRUE)
  cat("\n", file = varianceComponentsFile,  append = TRUE)
  cat('SNP heritability (h)', heritability, file = varianceComponentsFile, sep = '\t', append = TRUE)

  combinedGebvsFile <- grep('selected_traits_gebv', outputFiles, ignore.case = TRUE,value = TRUE)

  if (length(combinedGebvsFile) != 0) {
      fileSize <- file.info(combinedGebvsFile)$size
      if (fileSize != 0 ) {
          combinedGebvs <- data.frame(fread(combinedGebvsFile,
                                            header = TRUE))

        rownames(combinedGebvs) <- combinedGebvs[,1]
          combinedGebvs[,1]       <- NULL

          allGebvs <- merge(combinedGebvs, trGEBV,
                            by = 0,
                            all = TRUE
                            )

          rownames(allGebvs) <- allGebvs[,1]
          allGebvs[,1] <- NULL
      }
  }

#cross-validation

  if (is.null(selectionFile)) {
      genoNum <- nrow(phenoTrait)

      if (genoNum < 20 ) {
          warning(genoNum, " is too small number of genotypes.")
      }

      set.seed(4567)

      k <- 10
      times <- 2
      cvFolds <- createMultiFolds(phenoTrait[, 2], k=k, times=times)

      for ( r in 1:times) {
          re <- paste0('Rep', r)

          for (i in 1:k) {
              fo <- ifelse(i < 10, 'Fold0', 'Fold')

              trFoRe <- paste0(fo, i, '.', re)
              trG <- cvFolds[[trFoRe]]
              slG <- as.numeric(rownames(phenoTrait[-trG,]))

              kblup <- paste("rKblup", i, sep = ".")

              result <- kin.blup(data  = phenoTrait[trG,],
                                 geno  = 'genotypes',
                                 pheno = traitAbbr,
                                 K     = traitRelationshipMatrix,
                                 n.core = nCores,
                                 PEV    = TRUE
                                 )

              assign(kblup, result)

                                        #calculate cross-validation accuracy
              valBlups   <- result$g

              valBlups   <- data.frame(valBlups)

              slG <- slG[which(slG <= nrow(phenoTrait))]

              slGDf <- phenoTrait[(rownames(phenoTrait) %in% slG),]
              rownames(slGDf) <- slGDf[, 1]
              slGDf[, 1] <- NULL

              valBlups <-  rownames_to_column(valBlups, var="genotypes")
              slGDf    <-  rownames_to_column(slGDf, var="genotypes")

              valCorData <- inner_join(slGDf, valBlups, by="genotypes")
              valCorData$genotypes <- NULL

              accuracy   <- try(cor(valCorData))
              validation <- paste("validation", trFoRe, sep = ".")
              cvTest <- paste("CV", trFoRe, sep = " ")

              if ( class(accuracy) != "try-error")
              {
                  accuracy <- round(accuracy[1,2], digits = 3)
                  accuracy <- data.matrix(accuracy)

                  colnames(accuracy) <- c("correlation")
                  rownames(accuracy) <- cvTest

                  assign(validation, accuracy)

                  if (!is.na(accuracy[1,1])) {
                      validationAll <- rbind(validationAll, accuracy)
                  }
              }
          }
      }

      validationAll <- data.frame(validationAll[order(-validationAll[, 1]), ])
      colnames(validationAll) <- c('Correlation')
  }
}

selectionPopResult <- c()
selectionPopGEBVs  <- c()
selectionPopGEBVSE <- c()

if (length(selectionData) != 0) {

    genoDataTrSl <- rbind(genoDataFilteredObs, selectionData)
    rTrSl <- A.mat(genoDataTrSl)

    selectionPopResult <- kin.blup(data   = phenoTrait,
                                    geno   = 'genotypes',
                                    pheno  = traitAbbr,
                                    K      = rTrSl,
                                    n.core = nCores,
                                    PEV    = TRUE
                                    )

    selectionPopGEBVs <- round(data.frame(selectionPopResult$g), 2)
    colnames(selectionPopGEBVs) <- traitAbbr
    selectionPopGEBVs <- rownames_to_column(selectionPopGEBVs, var="genotypes")

    selectionPopPEV <- selectionPopResult$PEV
    selectionPopSE  <- sqrt(selectionPopPEV)
    selectionPopSE  <- data.frame(round(selectionPopSE, 2))
    colnames(selectionPopSE) <- 'SE'
    genotypesSl     <- rownames(selectionData)

    selectionPopSE <- rownames_to_column(selectionPopSE, var="genotypes")
    selectionPopSE <-  selectionPopSE %>% filter(genotypes %in% genotypesSl)

    selectionPopGEBVs <-  selectionPopGEBVs %>% filter(genotypes %in% genotypesSl)

    selectionPopGEBVSE <- inner_join(selectionPopGEBVs, selectionPopSE, by="genotypes")

    sortVar <- parse_quosure(traitAbbr)
    selectionPopGEBVs <- selectionPopGEBVs %>% arrange(desc((!!sortVar)))
    selectionPopGEBVs <- column_to_rownames(selectionPopGEBVs, var="genotypes")

    selectionPopGEBVSE <-  selectionPopGEBVSE %>% arrange(desc((!!sortVar)))
    selectionPopGEBVSE <- column_to_rownames(selectionPopGEBVSE, var="genotypes")
}

if (!is.null(selectionPopGEBVs) & length(selectionPopGEBVsFile) != 0)  {
    fwrite(selectionPopGEBVs,
           file  = selectionPopGEBVsFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if(!is.null(validationAll)) {
    fwrite(validationAll,
           file  = validationFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if (!is.null(ordered.markerEffects)) {
    fwrite(ordered.markerEffects,
           file  = markerFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if (!is.null(trGEBV)) {
    fwrite(trGEBV,
           file  = blupFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if (length(combinedGebvsFile) != 0 ) {
    if(file.info(combinedGebvsFile)$size == 0) {
        fwrite(trGEBV,
               file  = combinedGebvsFile,
               row.names = TRUE,
               sep   = "\t",
               quote = FALSE,
               )
      } else {
      fwrite(allGebvs,
             file  = combinedGebvsFile,
             row.names = TRUE,
             sep   = "\t",
             quote = FALSE,
             )
    }
}

if (!is.null(modelPhenoData) & length(modelPhenoFile) != 0) {

    if (!is.null(meanType)) {
        colnames(modelPhenoData) <- meanType
    }

    fwrite(modelPhenoData,
           file  = modelPhenoFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if (!is.null(traitRawPhenoData) & length(traitRawPhenoFile) != 0) {

    fwrite(traitRawPhenoData,
           file  = traitRawPhenoFile,
           row.names = FALSE,
           sep   = "\t",
           na = 'NA',
           quote = FALSE,
           )
}

if (!is.null(filteredGenoData) && is.null(readFilteredGenoData)) {
  fwrite(filteredGenoData,
         file  = filteredGenoFile,
         row.names = TRUE,
         sep   = "\t",
         quote = FALSE,
         )

}

## if (length(filteredPredGenoFile) != 0 && is.null(readFilteredPredGenoData)) {
##   fwrite(filteredPredGenoData,
##          file  = filteredPredGenoFile,
##          row.names = TRUE,
##          sep   = "\t",
##          quote = FALSE,
##          )
## }

## if (!is.null(genoDataMissing)) {
##   write.table(genoData,
##               file = genoFile,
##               sep = "\t",
##               col.names = NA,
##               quote = FALSE,
##             )

## }

## if (!is.null(predictionDataMissing)) {
##   write.table(predictionData,
##               file = predictionFile,
##               sep = "\t",
##               col.names = NA,
##               quote = FALSE,
##               )
## }

if (file.info(relationshipMatrixFile)$size == 0) {

  fwrite(relationshipMatrix,
         file  = relationshipMatrixFile,
         row.names = TRUE,
         sep   = "\t",
         quote = FALSE,
         )
}

if (file.info(relationshipMatrixJsonFile)$size == 0) {

    relationshipMatrixJson <- relationshipMatrix
    relationshipMatrixJson[upper.tri(relationshipMatrixJson)] <- NA

    relationshipMatrixJson <- data.frame(relationshipMatrixJson)

    relationshipMatrixList <- list(labels = names(relationshipMatrixJson),
                                       values = relationshipMatrixJson)

    relationshipMatrixJson <- jsonlite::toJSON(relationshipMatrixList)

    write(relationshipMatrixJson,
                    file  = relationshipMatrixJsonFile,
                    )
}

if (file.info(traitRelationshipMatrixFile)$size == 0) {

    inbre <- diag(traitRelationshipMatrix)
    inbre <- inbre - 1

    diag(traitRelationshipMatrix) <- inbre

    traitRelationshipMatrix <- data.frame(traitRelationshipMatrix) %>% replace(., . < 0, 0)

    fwrite(traitRelationshipMatrix,
           file  = traitRelationshipMatrixFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )

    if (file.info(traitRelationshipMatrixJsonFile)$size == 0) {

        traitRelationshipMatrixJson <- traitRelationshipMatrix
        traitRelationshipMatrixJson[upper.tri(traitRelationshipMatrixJson)] <- NA

        traitRelationshipMatrixJson <- data.frame(traitRelationshipMatrixJson)

        traitRelationshipMatrixList <- list(labels = names(traitRelationshipMatrixJson),
                                            values = traitRelationshipMatrixJson)

        traitRelationshipMatrixJson <- jsonlite::toJSON(traitRelationshipMatrixList)

        write(traitRelationshipMatrixJson,
              file  = traitRelationshipMatrixJsonFile,
              )
    }
}

if (file.info(inbreedingFile)$size == 0) {

  fwrite(inbreeding,
         file  = inbreedingFile,
         row.names = TRUE,
         sep   = "\t",
         quote = FALSE,
         )
}

if (file.info(aveKinshipFile)$size == 0) {

    aveKinship <- data.frame(apply(traitRelationshipMatrix, 1, mean))

    aveKinship<- aveKinship %>%
        rownames_to_column('genotypes') %>%
        rename(Mean_kinship = contains('traitRe')) %>%
        arrange(Mean_kinship) %>%
        mutate_at('Mean_kinship', round, 3) %>%
        column_to_rownames('genotypes')

    fwrite(aveKinship,
           file  = aveKinshipFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
}

if (file.info(formattedPhenoFile)$size == 0 && !is.null(formattedPhenoData) ) {
  fwrite(formattedPhenoData,
         file = formattedPhenoFile,
         row.names = TRUE,
         sep = "\t",
         quote = FALSE,
         )
}

message("Done.")

q(save = "no", runLast = FALSE)


library(cummeRbund)

args = commandArgs(trailingOnly=TRUE)

setwd(args[1])

cuff = readCufflinks(args[2])

pdf(file="density-19f-dapto-t1.pdf")
csDensity(genes(cuff))
dev.off()

pdf(file="scatter-19f-dapto-t1.pdf")
csScatter(genes(cuff), 'X19f_dapto','X19f_t1')
dev.off()

pdf(file="scatter-matrix-19f-dapto-t1.pdf")
csScatterMatrix(genes(cuff))
dev.off()

pdf(file="volcano-19f-dapto-t1.pdf")
csVolcanoMatrix(genes(cuff))
dev.off()

gene_diff_data=diffData(genes(cuff))
sig_gene_data = subset(gene_diff_data,significant=='yes')
sig_genes = getGenes(cuff,sig_gene_data$gene_id)

write.table(sig_gene_data,'sig-diff-genes.csv',sep=',',quote=F)

pdf(file="sig-gene-diff-barplot-19f-dapto-t1.pdf")
expressionBarplot(sig_genes,logMode=T,showErrorbars=T)
dev.off()

pdf(file="sig-gene-diff-heatmap-19f-dapto-t1.pdf")
csHeatmap(sig_genes,cluster='both')
dev.off()

plot_list = list()
for (i in 1:length(sig_gene_data$gene_id)) {
    ex_gene = getGene(cuff,sig_gene_data$gene_id[i])
    plot_list[[i]] = expressionBarplot(ex_gene,logMode=T,showErrorbars=T)
}

pdf(file="sig-genes-individual.pdf")
for (i in 1:length(sig_gene_data$gene_id)) {
    print(plot_list[[i]])
}
dev.off()


library(tidyverse)
library(reticulate)
library(ggbeeswarm)
source('config.r')
np <- import("numpy")

data <- np$load(
  "./outputs/all_scores_models_fieldtrip_spoc_test.npy",
# "all_scores_mag_models_mnecommonsubjects.npy",
  allow_pickle = T)[[1]]$'neg_mean_absolute_error-10folds' %>%
  as.data.frame()

data_ <- data[, (names(data) %in% c("sensor_logdiag",
                                   "sup_logdiag",
                                   "sensor_naivevec",
                                   "sensor_riemannwass",
                                   "sensor_riemanngeo"))]

data_long <- data_ %>% gather(key = "estimator", value = "score")
# move to long format
data_long$estimator <- factor(data_long$estimator)

# set distance types
est_types <- c(
  "log-diag",
  "log-diag",
  "euclidean",
  "Wasserstein",
  "geometric"
)

# categorical colors based on: https://jfly.uni-koeln.de/color/

my_color_cats <- with(
  color_cats,
  c(`blueish green`, `blueish green`, `sky blue`, vermillon, orange))

# beef up long data
data_long$est_type <- rep(est_types, each = 10) %>%
  factor(., levels = c("log-diag", "euclidean", "Wasserstein", "geometric"))
data_long$fold <- rep(1:10, times = length(est_types))

# prepare properly sorted x labels
sort_idx <- apply(data_, 2, mean) %>% order()
levels_est <- c(
  "identity",
  "supervised",
  "identity",
  "identity",
  "identity"
)[rev(sort_idx)]

ggplot(data = data_long %>% subset(estimator != "dummy"),
       mapping = aes(y = score, x = reorder(estimator, I(-score)))) +
  geom_beeswarm(
    priority = 'density',
    mapping = aes(color = est_type, size = 1 - score,
                  alpha = 1 - score),
    show.legend = T, cex = 0.65) +
  scale_size_continuous(range = c(0.5, 2)) +
  scale_alpha_continuous(range = c(0.4, 0.7)) +
  geom_boxplot(mapping = aes(fill = est_type, color = est_type),
               alpha = 0.4,
               outlier.fill = NA, outlier.colour = NA) +
  stat_summary(geom = 'text',
               mapping = aes(label  = sprintf("%1.2f",
                                              ..y..)),
               fun.y= mean, size = 3.2, show.legend = FALSE,
               position = position_nudge(x=-0.49)) +
  my_theme +
  labs(y = expression(MAE), x = NULL, parse = T) +
  guides(size = F, alpha = F) +
  theme(text = element_text(family = "Helvetica", size = 18),
        legend.position = "top", legend.text = element_text(size = 18)) +
  coord_flip() +
  scale_fill_manual(values = my_color_cats[2:6], name = NULL) +
  scale_color_manual(values = my_color_cats[2:6], name = NULL) +
  scale_x_discrete(labels = parse(text = levels_est))

fname <- "./figures_nimg_2019/fig_fieldtrip_model_comp_testMAE"
ggsave(paste0(fname, ".png"),
       width = 8, height = 4, dpi = 300)
ggsave(paste0(fname, ".pdf"),
       useDingbats = F,
       width = 8, height = 4, dpi = 300)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))


# Exercise 8
> library(ISLR)

# Locad College
>


library(readr)
library(ggplot2)
library(tidyr)
library(xtable)

load_file <- function(bmName){
  df <- read_csv(paste("aws-scripts/results-",bmName,"-knarr-z3.csv",sep = ""))
  df['successRate.charHint'] <- 100*df['inputsSavedBy_CharHint']/df['inputsCreatedBy_CharHint']
  df['successRate.singleStringHint'] <- 100*df['inputsSavedBy_StrHint']/df['inputsCreatedBy_StrHint']
  df['successRate.multiStringHint'] <- 100*df['inputsSavedBy_MultipleStrHint']/df['inputsCreatedBy_MultipleStrHint']
  df['successRate.extendedDictionary'] <- 100*df['countOfSavedInputsWithExtendedDictionaryHints']/df['countOfCreatedInputsWithExtendedDictionaryHints']
  df['successRate.random'] <- 100*df['inputsSavedBy_Random']/df['inputsCreatedBy_Random']
  df['successRate.z3'] <- 100*df['inputsSavedBy_Z3']/df['inputsCreatedBy_Z3']

  return(df)
}
getLastRow <- function(dat){
  return(subset(dat,`# unix_time` == max(dat$`# unix_time`)))
}
bms <- c('ant', 'bcelgen', 'maven', 'closure', 'rhino')

#data <- lapply(bms,load_file)
final_stats <- as.data.frame(t(sapply(data,getLastRow)), row.names=bms)
# successStats <- pivot_longer(final_stats, cols=starts_with("successRate"), names_to="measure", values_to = "successRate", names_prefix="successRate.")


#' mdi_index
#'
#' Modified discomfort index MDI.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @param wind numeric Windspeed in meters per second.
#' @param pair numeric Air pressure in hPa.
#' @return mdi_index
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  mdi_index
#' @references Moran DS, Shitzer A, Pandolf KB , 1998, A physiological strain index to evaluate heat stress. Am J Physiol 275, R 129 34.
#'
#'
#'
#'
#' @export

mdi_index<-function(t,rh,wind=0.2,pair=1010)  {
                          ct$assign("t", as.array(t))
                          ct$assign("rh", as.array(rh))
                          ct$assign("wind", as.array(wind))
                          ct$assign("pair", as.array(pair))
                          ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=mdi_index(t[i],rh[i],wind[0],pair[0])};")
                          res=ct$get("res")
                          return(ifelse(res==9999,NA,res))
}


[2, 1 -> 2]
[3, 2 -> 3]
[4, 2 -> 4]
[5, 7 -> 5]
[1, 3 -> 1]
[6, 4 -> 6]
[7, 5 -> 7]
[8, 7 -> 8]


context("irep iterator")

test_that("irep matches first example from base::rep", {
  it <- irep(1:4, 2)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 4)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 4)
  expect_error(nextElem(it), "StopIteration")
})

test_that("irep matches second example from base::rep", {
  it <- irep(1:4, each=2)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 3)
  expect_equal(nextElem(it), 4)
  expect_equal(nextElem(it), 4)
  expect_error(nextElem(it), "StopIteration")
})

test_that("irep matches fifth example from base::rep", {
  it <- irep(1:4, each=2, length.out=4)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 2)
  expect_error(nextElem(it), "StopIteration")
})

test_that("irep replicates a list and matches tenth example from base::rep", {
  # 8 integers plus two recycled 1's.
  fred <- list(happy=1:10, name="squash")
  it <- irep(fred, times=5)
  expect_equal(nextElem(it), 1:10)
  expect_equal(nextElem(it), "squash")
  expect_equal(nextElem(it), 1:10)
  expect_equal(nextElem(it), "squash")
  expect_equal(nextElem(it), 1:10)
  expect_equal(nextElem(it), "squash")
  expect_equal(nextElem(it), 1:10)
  expect_equal(nextElem(it), "squash")
  expect_equal(nextElem(it), 1:10)
  expect_equal(nextElem(it), "squash")
  expect_error(nextElem(it), "StopIteration")
})

test_that("irep replicates a factor and matches last example from base::rep", {
  # 8 integers plus two recycled 1's.
  x <- factor(LETTERS[1:4])
  it <- irep(x, 2)
  expect_equal(nextElem(it), x[1])
  expect_equal(nextElem(it), x[2])
  expect_equal(nextElem(it), x[3])
  expect_equal(nextElem(it), x[4])
  expect_equal(nextElem(it), x[1])
  expect_equal(nextElem(it), x[2])
  expect_equal(nextElem(it), x[3])
  expect_equal(nextElem(it), x[4])
  expect_error(nextElem(it), "StopIteration")
})

test_that("irep_len works on numeric vectors", {
  it <- irep_len(1:4, length.out=3)
  expect_equal(nextElem(it), 1)
  expect_equal(nextElem(it), 2)
  expect_equal(nextElem(it), 3)
  expect_error(nextElem(it), "StopIteration")
})

# Related to Issue #33
test_that("irep matches base::rep() when both times and each args are given", {
  it <- irep(1:4, times=2, each=3)
  expected_vector <- rep(1:4, times=2, each=3)
  expect_equal(unlist(as.list(it)), expected_vector)
})


#V2 for Final
search()
library(igraph)
library(rgexf)

writing.dir <- c("/home/sdal/mann2/mann/analysis/")
wd <- c("/home/sdal/mann2/mann/multidisciplinary-diffusion-model-experiments/results/simulations")
setwd(wd)

#ITERATION LISTS
batch.dir.list <- c("02-lens_batch_2015-11-30_16-09-28_457_750",
                    "02-lens_batch_2015-12-01_19-09-26_495_750",
                    "02-lens_batch_2015-12-02_08-30-37_740_750",
                    "02-lens_batch_2015-12-02_17-25-33_776_750",
                    "02-lens_batch_2015-12-02_22-45-10_646_750",
                    "02-lens_batch_2015-12-04_19-59-57_776_750",
                    "02-lens_batch_2015-12-05_15-26-02_776_750",
                    "02-lens_batch_2015-12-06_02-25-29_756_750",
                    "02-lens_batch_2015-12-06_13-14-04_770_750",
                    "02-lens_batch_2015-12-07_13-38-26",
                    "02-lens_batch_2015-12-07_23-06-53",
                    "02-lens_batch_2015-12-08_21-42-32")

btwn.list <- c(21:29,3,31:39,4,41:45)

wn.list <- c(5,51:59,6,61:69,7,71:79,8)

master.matrix <- matrix(rep(NA,(length(btwn.list)*length(wn.list))),nrow=length(btwn.list),ncol=length(wn.list))

for(i in 1:length(btwn.list)){ #BETWEEN

    for(j in 1:length(wn.list)){ #WITHIN

        rm(catch.across.runs)
        catch.across.runs <- rep(NA,length(batch.dir.list))

        for(k in 1:length(batch.dir.list)){
            setwd(wd)
            if (file.exists(paste(batch.dir.list[k],"/a250_bm-0.",btwn.list[i],"_bs0.1_wm0.",wn.list[j],"_ws0.2_c0.25_r000/output",sep=""))) { #IF N0 1

                setwd(paste(batch.dir.list[k],"/a250_bm-0.",btwn.list[i],"_bs0.1_wm0.",wn.list[j],"_ws0.2_c0.25_r000/output",sep=""))

                if (file.exists("network_of_agents.pout")) { #IF NO 2
                    d <- read.csv("./network_of_agents.pout",header=F)

                    if(tail(d$V1,n=1)==99 & tail(d$V2,n=1)==249) { #IF NO 3
                         #GET MEAN, SD AND RANGE
                        mean.for.d <- apply(d[,4:13],1,mean)
                        sd.for.d <- apply(d[,4:13],1,sd)
                        min.for.d <- apply(d[,4:13],1,min)
                        max.for.d <- apply(d[,4:13],1,max)
                        mean.for.d.neg <- apply(d[,4:8],1,mean)
                        mean.for.d.pos <- apply(d[,9:13],1,mean)

                        d <- cbind(d,mean.for.d,mean.for.d.neg,mean.for.d.pos,sd.for.d,min.for.d,max.for.d)

                        d$diff.means.pos.neg <- d$mean.for.d.pos-d$mean.for.d.neg

                        d$node.name <- NA
                        d$node.name <- paste("A",d$V2,sep="")

                        for(v in 99:99){ #v is tick number
                            assign(paste("d.t.",v,sep=""), d[d$V1==v,])

                            #LOAD NETWORK
                            e.list.in <- read.table(gzfile("edge_list.gz"))
                            e.list.use <- e.list.in[,1:2]
                            gg <- graph.data.frame(e.list.use,directed=FALSE)

                            V(gg)$state <- get(paste("d.t.",v,sep=""))$diff.means.pos.neg[match(V(gg)$name,get(paste("d.t.",v,sep=""))$node.name)]

                            #DATA WRITING HERE #WITNIN RUNS
                            write(c(date(),"",c(i,"",j,"",k),"ERR: NONE"),file=paste(writing.dir,"AnalysisTracker.txt",sep=""),ncolumns=8,append=TRUE)
                            catch.across.runs[k] <- assortativity(gg,V(gg)$state,directed=FALSE)
                        } #v

                    } #IF NO 3
                    else {
                        write(c(date(),"",c(i,"",j,"",k),"ERR: NO 3"),file=paste(writing.dir,"AnalysisTracker.txt",sep=""),ncolumns=8,append=TRUE)
                    } #ELSE NO 3
                } #IF NO 2

                else {
                    write(c(date(),"",c(i,"",j,"",k),"ERR: NO 2"),file=paste(writing.dir,"AnalysisTracker.txt",sep=""),ncolumns=8,append=TRUE)
                } #ELSE NO 2

            } #IF NO 1

            else {
                write(c(date(),"",c(i,"",j,"",k),"ERR: NO 1"),file=paste(writing.dir,"AnalysisTracker.txt",sep=""),ncolumns=8,append=TRUE)
            } #ELSE NO 1

        } #k

        master.matrix[i,j] <- mean(catch.across.runs,na.rm=TRUE)

    } #j
} #i

setwd(writing.dir)
save.image()

#EOF


source("http://www.bioconductor.org/biocLite.R")
library("affy")
library("simpleaffy")
library("scales")
library("R.utils")

setwd("~/work/abe516/project1")
cwd = getwd()

dat = ReadAffy(celfile.path = "data")
featureNames(dat)[1:10]
num_samples = length(dat)
printf("There are %s features in %s samples\n", len(featureNames(dat)), num_samples)

head(pm(dat, "172682_x_at"))
head(mm(dat, "172682_x_at"))
hist(dat)

snames = c('c1', 'c2', 'bs1', 'bs2', 'bs3', 'efs1', 'efs2', 'efs3', 'efm1', 'efm2', 'efm3', 'c3', 'c4')
groups = paste0("G", unlist(strsplit("3311100022233", '')))
ngroups = len(unique(groups))

groups = c("C", "Bs", "Efs", "Efm")
fl <- factor(c(rep('0', 2), rep('1', 3), rep('2', 3), rep('3', 3), rep('0', 2)),
             labels=groups)
palette(brewer_pal(type = "seq", palette = "Set2")(len(groups)))
boxplot(dat, names = fl, main = "Raw", las = 2, col = fl)
plot(probeset(dat, geneNames(dat)[1]) [[1]])

RNAdeg = AffyRNAdeg(dat)
plotAffyRNAdeg(RNAdeg)

png(filename = file.path(cwd, "ma-raw.png"), width = 600, height = 800)
par(mfrow = c(5,3))
MAplot(dat, plot.method = "smoothScatter")
dev.off()

dat.rmabg = bg.correct(dat, "rma")
png(filename = file.path(cwd, "ma-bg-corrected.png"), width = 600, height = 800)
par(mfrow = c(5,3))
MAplot(dat.rmabg, plot.method = "smoothScatter")
dev.off()

dat.norm = normalize(dat.rmabg, "quantiles")
png(filename = file.path(cwd, "ma-normalized.png"), width = 600, height = 800)
par(mfrow = c(5,3))
MAplot(dat.norm, plot.method = "smoothScatter")
dev.off()

boxplot(dat.norm,
        names = snames,
        main = "Normalized",
        las = 2,
        col = as.factor(groups))

# Nothing from here on works
# what can I do with this?
expr.dat <- expresso(dat,
                     bgcorrect.method = "rma",
                     normalize.method = "constant",
                     pmcorrect.method = "pmonly",
                     summary.method   = "avgdiff")

# does not compute
hist(expr.dat)
MAplot(expr.dat, plot.method = "smoothScatter")
#top250 = read.table("top250.txt", header = T)


#' sun_data
#'
#' Calculate sun parameters for specific location and time.
#'
#' @param datetime character     Datetime as in YYYY-MM-DDTHH:MM:SS considering local time
#' @param lat  numeric           Latitude in decimal degrees
#' @param lon  numeric           Longitude in decimal degrees
#' @param parameter character    Six solar parameter are available by name "azimuth","zenith","solarZenith","elevation","declination"or "JD"
#' @param tz character           time zone.
#' @return value of parameter indicated
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  sun parameters
#'
#' @export
#'
#'
#'
#'

sun_data=function(datetime,lat,lon,parameter="azimuth",tz="GMT") {
                         ct$assign("datetime", as.array(datetime))
                         ct$assign("lat", as.array(lat))
                         ct$assign("lon", as.array(lon))
                         ct$assign("parameter", as.array(parameter))
                         ct$eval("var res=[]; for(var i=0, len=lat.length; i < len; i++){ res[i]=sun_data(datetime[0],lat[i],lon[i],parameter[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


r-pkgconfig
r-knitr
r-plyr
r-stringr
r-rgl
r-data.table
r-ggplot2
r-lme4
r-reshape
r-rcolorbrewer
r-gplots
r-png
r-lattice
r-tm
r-igraph
r-rjsonio
r-curl
r-devtools


stanfit_one <- function(gdat, dz, nnfits, which.spax,
                        prep_data = prep_data_mod,
                        init_opt = init_opt_mod,
                        init_sampler = init_sampler_mod,
                        stan_model=NULL,
                        stan_file="spm_dust_mod_simpl.stan", stan_filedir="~/spmcode/",
                        iter_opt=5000,
                        jv=1.e-4,
                        iter=1000, warmup=250, thin=1, chains=4,
                        OP=FALSE, ...) {

    require(rstan)
    if (is.null(stan_model)) {
      stan_model <- rstan::stan_model(file=file.path(stan_filedir, stan_file))
    }

    spm_data <- prep_data(gdat, dz, nnfits, which.spax)
    inits <- init_opt(spm_data, nnfits, which.spax, jv)
    spm_opt <- optimizing(stan_model, data=spm_data, init=inits, as_vector=FALSE, verbose=TRUE, iter=iter_opt)

    init_pars <- lapply(X=1:chains, init_sampler, stan_opt=spm_opt$par, jv=jv)

    stanfit <- sampling(stan_model, data=spm_data,
                     chains=chains, iter=iter, warmup=warmup, thin=thin,
                     cores=min(chains, getOption("mc.cores")),
                     init=init_pars, open_progress=OP, ...)

    list(spm_data=spm_data, stanfit=stanfit,
         norm_g=spm_data$norm_g, norm_st=spm_data$norm_st, norm_em=spm_data$norm_em, in_em=spm_data$in_em)
}

stanfit_batch <- function(gdat, dz, nnfits,
                        init_tracked = init_tracked_mod,
                        update_tracked = update_tracked_mod,
                        return_tracked = return_tracked_mod,
                        prep_data = prep_data_mod,
                        init_opt = init_opt_mod,
                        init_sampler = init_sampler_mod,
                        stan_file="spm_dust_mod_simpl.stan", stan_filedir="~/spmcode/",
                        iter_opt=5000,
                        jv=1.e-4,
                        iter=1000, warmup=250, chains=4,
                        OP=FALSE,
                        start=NULL, end=NULL, fpart="bfits.rda", ...) {
    dims <- dim(gdat$flux)
    dz <- dz$dz
    nsim <- (iter-warmup)*chains
    nt <- length(ages)
    nr <- dims[1]
    n_st <- ncol(lib.ssp)-1
    n_em <- length(emlines)
    nl <- length(gdat$lambda)
    smodel <- rstan::stan_model(file.path(stan_filedir, stan_file))
    if (is.null(start) || !file.exists(fpart)) {
      init_tracked(nsim, n_st, n_em, nr)
      start <- 1
    } else {
        load(fpart)
    }
    if (is.null(end)) {
      end <- nr
    }
    for (i in start:end) {
        if (is.na(dz[i]) || is.na(nnfits$Mstar[i])) next
        sfit <- stanfit_one(gdat, dz, nnfits, which.spax=i,
                            prep_data,
                            init_opt,
                            init_sampler,
                            stan_model=smodel,
                            iter_opt=iter_opt, jv=jv,
                            iter = iter, warmup = warmup, chains = chains,
                            OP=OP, ...)
        plot(plotpp(sfit)+ggtitle(paste("fiber =", i)))
        update_tracked(i, sfit, fpart)
        rm(sfit)
    }
    return_tracked()
}

## star formation history, mass growth history, etc.

get_sfh <- function(..., z, fibersinbin=1, density=TRUE, tsf=0.1) {
  ins <- list(...)
  if (is.list(ins[[1]])) {
    ins <- ins[[1]]
    post <- rstan::extract(ins$stanfit)
    b_st <- post$b_st
    norm_st <- ins$norm_st
    if (exists("norm_g", ins)) {
      b_st <- b_st*ins$norm_g
      norm_st <- 1/norm_st
    }
  } else {
    b_st <- ins$b_st
    norm_st <- ins$norm_st
  }
  nsim <- nrow(b_st)
  nt <- length(ages)
  nz <- ncol(b_st)/nt
  T.gyr <- 10^(ages-9)
  isf <- which.min(abs(tsf-T.gyr))
  if (density) {
    binarea <- log10(pi*fibersinbin*cosmo::ascale(z)^2)
  } else {
    binarea <- 0
  }
  b_st <- t(t(b_st)*norm_st)*cosmo::lum.sol(1, z)
  rmass <- t(t(b_st) * mstar)
  sfh_post <- matrix(0, nsim, nt)
  mgh_post <- matrix(0, nsim, nt)
  for (i in 1:nz) {
    sfh_post <- sfh_post + b_st[,((i-1)*nt+1):(i*nt)]
    mgh_post <- mgh_post + rmass[,((i-1)*nt+1):(i*nt)]
  }
  totalmg_post <- cbind(rowSums(mgh_post), rowSums(mgh_post) - t(apply(mgh_post, 1, cumsum)))
  mgh_post <- cbind(rep(1, nsim), 1 - (t(apply(mgh_post, 1, cumsum))/rowSums(mgh_post)))
  sfr <- log10(rowSums(sfh_post[,1:isf])/T.gyr[isf])-9.
  relsfr <- sfr - log10(rowSums(sfh_post)/(cosmo::dcos(Inf)$dT-cosmo::dcos(z)$dT)) + 6
  sigma_sfr <- sfr - binarea
  sigma_mstar <- log10(b_st %*% mstar) - binarea
  ssfr <- sigma_sfr - sigma_mstar
  list(sfh_post=sfh_post, mgh_post=mgh_post, totalmg_post=totalmg_post,
       sigma_mstar=sigma_mstar, sigma_sfr=sigma_sfr, ssfr=ssfr, relsfr=relsfr)
}

batch_sfh <- function(gdat, sfits, tsf=0.1) {
  b_st <- sfits$b_st
  norm_st <- sfits$norm_st
  dims <- dim(b_st)
  nsim <- dims[1]
  nt <- length(ages)
  nz <- dims[2]/nt
  nf <- dims[3]
  if (exists("norm_g", sfits)) {
    norm_g <- sfits$norm_g
    norm_st <- 1/norm_st
  } else {
    norm_g <- rep(1, nf)
  }
  z <- gdat$meta$z
  if (!exists("fibersinbin", gdat)) {
    fibersinbin <- rep(1, nf)
  } else {
    fibersinbin <- gdat$fibersinbin
  }

  sfh_post <- array(NA, dim=c(nsim, nt, nf))
  mgh_post <- array(0, dim=c(nsim, nt+1, nf))
  totalmg_post <- matrix(0, nsim, nt+1)
  sigma_mstar <- matrix(NA, nsim, nf)
  sigma_sfr <- matrix(NA, nsim, nf)
  ssfr <- matrix(NA, nsim, nf)
  relsfr <- matrix(NA, nsim, nf)

  for (i in 1:nf) {
    if (is.na(b_st[1, 1, i])) next
    sfi <- get_sfh(b_st=b_st[,,i]*norm_g[i], norm_st=norm_st[,i], z=z, fibersinbin=fibersinbin[i])
    sfh_post[,,i] <- sfi$sfh_post
    mgh_post[,,i] <- sfi$mgh_post
    totalmg_post <- totalmg_post + sfi$totalmg_post
    sigma_mstar[, i] <- sfi$sigma_mstar
    sigma_sfr[, i] <- sfi$sigma_sfr
    ssfr[, i] <- sfi$ssfr
    relsfr[,i] <- sfi$relsfr
  }
  list(sfh_post=sfh_post, mgh_post=mgh_post, totalmg_post=totalmg_post,
       sigma_mstar=sigma_mstar, sigma_sfr=sigma_sfr, ssfr=ssfr, relsfr=relsfr)
}

## some sorta useful summary measures

get_proxies <- function(...) {
  ins <- list(...)
  if (is.list(ins[[1]])) {
    ins <- ins[[1]]
    post <- rstan::extract(ins$stanfit)
    b_st <- post$b_st
    norm_st <- ins$norm_st
    if (exists("a", post)) {
      b_st <- b_st*ins$norm_g
      norm_st <- 1/norm_st
    }
  } else {
    b_st <- ins$b_st
    norm_st <- ins$norm_st
  }
  b_st <- t(t(b_st)*norm_st)
  nz <- length(Z)
  nt <- length(ages)
  T.gyr <- 10^(ages-9)
  tbar <- log10((b_st %*% rep(T.gyr, nz))/rowSums(b_st)) + 9
  tbar_lum <- log10((b_st %*% (rep(T.gyr, nz) * gri.ssp["r",]))/
                   ((b_st %*% gri.ssp["r",]))) + 9
  g_i <- 2.5*log10(b_st %*% gri.ssp["i",]) - 2.5*log10(b_st %*% gri.ssp["g",])
  data.frame(tbar=tbar, tbar_lum=tbar_lum, g_i=g_i)
}

## emission line fluxes, luminosity density, equivalent width

get_em <- function(..., z, fibersinbin=1, ew_width=15) {
  ins <- list(...)
  if (is.list(ins[[1]])) {
    ins <- ins[[1]]
    post <- rstan::extract(ins$stanfit)
    b_st <- post$b_st
    b_em <- post$b_em
    norm_st <- ins$norm_st
    norm_em <- ins$norm_em
    if (exists("norm_g", ins)) {
      b_st <- b_st*ins$norm_g
      b_em <- b_em*ins$norm_g
      norm_st <- 1/norm_st
    }
 } else {
    b_st <- ins$b_st
    b_em <- ins$b_em
    norm_st <- ins$norm_st
    norm_em <- ins$norm_em
  }
  emlines <- emlines[ins$in.em]
  b_st <- t(t(b_st)*norm_st)
  ne <- ncol(b_em)
  nsim <- nrow(b_em)
  binarea <- log10(pi*fibersinbin*cosmo::ascale(z)^2)
  em.mult <- emlines*log(10)/10000

  flux_em <- matrix(NA, nsim, ne)
  sigma_logl_em <- matrix(NA, nsim, ne)
  ew_em <- matrix(NA, nsim, ne)

  flux_em <- t(t(b_em)*em.mult)*norm_em
  sigma_logl_em <- cosmo::loglum.ergs(flux_em, z) - binarea

  mu_st <- tcrossprod(b_st, as.matrix(lib.ssp[, -1]))
  il_em <- findInterval(emlines, lib.ssp$lambda)
  for (i in 1:ne) {
    intvl <- (il_em[i]-ew_width):(il_em[i]+ew_width)
    fc <- rowMeans(mu_st[, intvl])
    ew_em[, i] <- flux_em[, i]/fc
  }
  colnames(flux_em) <- names(emlines)
  colnames(sigma_logl_em) <- names(emlines)
  colnames(ew_em) <- names(emlines)
  list(flux_em=flux_em, sigma_logl_em=sigma_logl_em, ew_em=ew_em)
}

batch_em <- function(gdat, sfits, ew_width=15) {
  nsim <- dim(sfits$b_em)[1]
  ne <- length(emlines)
  nf <- length(gdat$xpos)
  norm_st <- sfits$norm_st
  if (exists("norm_g", sfits)) {
    norm_g <- sfits$norm_g
    norm_st <- 1/sfits$norm_st
  } else {
    norm_g <- rep(1, nf)
  }

  flux_em <- array(NA, dim=c(nsim, ne, nf))
  sigma_logl_em <- array(NA, dim=c(nsim, ne, nf))
  ew_em <- array(NA, dim=c(nsim, ne, nf))

  for (i in 1:nf) {
    if (is.na(sfits$b_st[1, 1, i])) next
    in.em <- sfits$in_em[!is.na(sfits$in_em[,i]), i]
    if(is.null(dim(norm_st))) {
      nst <- norm_st[i]
    } else {
      nst <- norm_st[,i]
    }
    emi <- get_em(b_em=sfits$b_em[,in.em,i]*norm_g[i], b_st=sfits$b_st[,,i]*norm_g[i],
                  norm_em=sfits$norm_em[i], norm_st=nst,
                  in.em=in.em, z=gdat$meta$z,
                  fibersinbin=gdat$fibersinbin[i], ew_width=ew_width)
    flux_em[,in.em,i] <- emi$flux_em
    sigma_logl_em[,in.em,i] <- emi$sigma_logl_em
    ew_em[,in.em,i] <- emi$ew_em
  }
  dimnames(flux_em)[[2]] <- names(emlines)
  dimnames(sigma_logl_em)[[2]] <- names(emlines)
  dimnames(ew_em)[[2]] <- names(emlines)
  list(flux_em=flux_em, sigma_logl_em=sigma_logl_em, ew_em=ew_em)
}

## bpt class from [N II]/Halpha

batch_bptclass <- function(flux_em, snthresh=3) {
  nb <- dim(flux_em)[3]
  bpt <- as.factor(rep("NO EM", nb))
  levels(bpt) <- c("NO EM", "EL", "SF", "COMP", "LINER", "AGN")
  f_m <- apply(flux_em, c(2, 3), mean)
  f_sd <- apply(flux_em, c(2, 3), sd)
  for (i in 1:nb) {
    if (all(is.na(f_m[, i]))) {
      bpt[i] <- NA
      next
    }
    if(any(f_m[, i]/f_sd[, i] > snthresh, na.rm=TRUE)) bpt[i] <- "EL"
    if (any(is.na(f_m[c("h_beta", "oiii_5007", "h_alpha", "nii_6584"), i]))) next
    if (f_m["h_beta", i]/f_sd["h_beta", i] > snthresh &&
        f_m["oiii_5007", i]/f_sd["oiii_5007", i] > snthresh &&
        f_m["h_alpha", i]/f_sd["h_alpha", i] > snthresh &&
        f_m["nii_6584", i]/f_sd["nii_6584", i] > snthresh) {
      o3hbeta <- log10(f_m["oiii_5007", i]/f_m["h_beta", i])
      n2halpha <- log10(f_m["nii_6584", i]/f_m["h_alpha", i])
      if ((o3hbeta <= 0.61/(n2halpha-0.05)+1.3) &&
         (n2halpha <= 0.05)) {
        bpt[i] <- "SF"
        next
      }
      if ((o3hbeta > 0.61/(n2halpha-0.05)+1.3 || n2halpha > 0.05) &&
          (o3hbeta <= 0.61/(n2halpha-0.47)+1.19)) {
        bpt[i] <- "COMP"
        next
      }
      if ((o3hbeta > 0.61/(n2halpha-0.47)+1.19 || n2halpha > 0.47) &&
          (o3hbeta > 1.05*n2halpha+0.45)) {
        bpt[i] <- "AGN"
      } else {
        bpt[i] <- "LINER"
      }
    }
  }
  bpt
}

## emission line ratios and various "strong line" metallicity calibrations

get_lineratios <- function(flux_em, tauv, delta=0, tauv_mult=1, alaw=calzetti_mod) {
  o3hbeta <- log10(flux_em[,"oiii_5007"]/flux_em[,"h_beta"])
  o1halpha <- log10(flux_em[,"oi_6300"]/flux_em[,"h_alpha"])
  n2halpha <- log10(flux_em[,"nii_6584"]/flux_em[,"h_alpha"])
  s2halpha <- log10((flux_em[,"sii_6717"]+flux_em[,"sii_6730"])/flux_em[,"h_alpha"])

  o2 <- (flux_em[,"oii_3727"]+flux_em[,"oii_3729"])*alaw(3728., -tauv*tauv_mult, delta)
  o3 <- (flux_em[,"oiii_4959"]+flux_em[,"oiii_5007"])*alaw(4980., -tauv*tauv_mult, delta)
  hb <- flux_em[,"h_beta"]*alaw(4863., -tauv*tauv_mult, delta)

  r23 <- log10((o2+o3)/hb)
  o3n2 <- o3hbeta-n2halpha

  ## log(O/H) estimates from Pettini & Pagel 2004, Tremonti et al. 2004, or Dopita et al. 2016

  oh_n2 <- 9.37+2.03*n2halpha+1.26*n2halpha^2+0.32*n2halpha^3
  oh_o3n2 <- 8.73-0.32*o3n2
  oh_r23 <- 9.185-0.313*r23-0.264*r23^2-0.321*r23^3
  oh_n2s2ha <- 8.77+n2halpha-s2halpha+0.264*n2halpha

  data.frame(o3hbeta=o3hbeta, o1halpha=o1halpha, n2halpha=n2halpha, s2halpha=s2halpha,
             r23=r23, o3n2=o3n2,
             oh_n2=oh_n2, oh_o3n2=oh_o3n2, oh_r23=oh_r23, oh_n2s2ha=oh_n2s2ha)
}

sum_batchfits <- function(gdat, nnfits, sfits, drpcat, alaw=calzetti_mod, intr_bd=2.86, clim=0.95) {

    tauv.bd <- function(flux_em, intr_bd, delta=0, alaw) {
      bd <- flux_em[,'h_alpha']/flux_em[,'h_beta']
      bd[!is.finite(bd)] <- NA
      tauv <- log(bd/intr_bd)/(log(alaw(6562.8,1, delta))-log(alaw(4861.3,1, delta)))
      tauv[tauv<0] <- 0
      tauv
    }

    logl.ha.cor <- function(logl.halpha, tauv, delta=0, alaw) {
      att <- alaw(lambda=6562.8, tauv, delta)
      logl.halpha - log10(att)
    }

    nf <- length(gdat$xpos)
    fibersinbin <- rep(1, nf)
    if (exists("bin.fiber", gdat)) {
      if (!exists("fibersinbin", gdat)) {
        bin.fiber <- gdat$bin.fiber
        bin.no <- unique(bin.fiber[!is.na(bin.fiber)])
        for (i in seq_along(bin.no)) {
          fibersinbin[i] <- length(which(bin.fiber == bin.no[i]))
        }
      } else {
        fibersinbin <- gdat$fibersinbin
      }
    }

    nsim <- nrow(sfits$b_st)
    nt <- length(ages)
    fiberarea <- pi*cosmo::ascale(gdat$meta$z)^2
    plateifu <- rep(gdat$meta$plateifu, nf)

    ## projected distance in kpc and relative to effective radius

    d_kpc <- cosmo::ascale(gdat$meta$z)*sqrt(gdat$xpos^2+gdat$ypos^2)
    d_re <- sqrt(gdat$xpos^2+gdat$ypos^2)/
    drpcat$nsa_petro_th50[match(gdat$meta$plateifu,drpcat$plateifu)]

    ## stuff taken from nnfits

    d4000_n <- nnfits$d4000_n
    d4000_n_err <- nnfits$d4000_n_err
    lick_hd_a <- nnfits$lick[,'HdeltaA']
    lick_hd_a_err <- nnfits$lick.err[,'HdeltaA_err']
    mgfe <- sqrt(nnfits$lick[,'Mg_b']*(0.72*nnfits$lick[,'Fe5270']+0.28*nnfits$lick[,'Fe5335']))
    mgfe[is.nan(mgfe)] <- NA

    ## tauv from batch fits

    tauv_m <- colMeans(sfits$tauv)
    tauv_std <- apply(sfits$tauv, 2, sd)

    if (exists("delta", sfits)) {
      delta <- sfits$delta
    } else {
      delta <- matrix(0, nsim, nf)
    }
    delta_m <- colMeans(delta)
    delta_std <- apply(delta, 2, sd)

    if (exists("ll", sfits)) {
      ll_m <- colMeans(sfits$ll)
    } else {
      ll_m <- rep(NA, nf)
    }

    mgh_post <- array(NA, dim=c(nsim, nt+1, nf))
    sfh_post <- array(NA, dim=c(nsim, nt, nf))
    totalmg_post <- matrix(0, nsim, nt+1)

    varnames <- c("sigma_mstar", "sigma_sfr", "ssfr", "relsfr",
                  "tbar", "tbar_lum", "g_i",
                  "tauv_bd", "sigma_logl_ha", "sigma_logl_ha_ctauv", "sigma_logl_ha_ctauv_bd",
                  "eqw_ha", "o3hbeta", "o1halpha", "n2halpha", "s2halpha",
                  "r23", "o3n2", "oh_n2", "oh_o3n2", "oh_r23", "oh_n2s2ha")
    suffixes <- c("m", "std", "lo", "hi")

    for (i in seq_along(varnames)) {
      for (j in seq_along(suffixes)) {
        assign(paste(varnames[i], suffixes[j], sep="_"), numeric(nf))
      }
    }

    sfh_all <- batch_sfh(gdat, sfits)

    for (i in 1:4) {
      assign(paste(varnames[i], suffixes[1], sep="_"), colMeans(sfh_all[[varnames[i]]]))
      assign(paste(varnames[i], suffixes[2], sep="_"), apply(sfh_all[[varnames[i]]], 2, sd))
    }

    em_all <- batch_em(gdat, sfits)
    bpt <- batch_bptclass(em_all$flux_em)

    for (i in 1:nf) {

      ## star formation history, etc.

      quants <- hdiofmcmc(sfh_all$sigma_mstar[,i])
      sigma_mstar_lo[i] <- quants[1]
      sigma_mstar_hi[i] <- quants[2]

      quants <- hdiofmcmc(sfh_all$sigma_sfr[,i])
      sigma_sfr_lo[i] <- quants[1]
      sigma_sfr_hi[i] <- quants[2]

      quants <- hdiofmcmc(sfh_all$ssfr[,i])
      ssfr_lo[i] <- quants[1]
      ssfr_hi[i] <- quants[2]

      quants <- hdiofmcmc(sfh_all$relsfr[,i])
      relsfr_lo[i] <- quants[1]
      relsfr_hi[i] <- quants[2]

      if (is.null(dim(sfits$norm_st))) {
        norm_st <- sfits$norm_st[i]
      } else {
        norm_st <- 1/sfits$norm_st[,i]
      }
      proxi <- get_proxies(b_st=sfits$b_st[,,i], norm_st=norm_st)

      tbar_m[i] <- mean(proxi$tbar)
      tbar_std[i] <- sd(proxi$tbar)
      quants <- hdiofmcmc(proxi$tbar, credmass=clim)
      tbar_lo[i] <- quants[1]
      tbar_hi[i] <- quants[2]

      tbar_lum_m[i] <- mean(proxi$tbar_lum)
      tbar_lum_std[i] <- sd(proxi$tbar_lum)
      quants <- hdiofmcmc(proxi$tbar_lum, credmass=clim)
      tbar_lum_lo[i] <- quants[1]
      tbar_lum_hi[i] <- quants[2]

      g_i_m[i] <- mean(proxi$g_i)
      g_i_std[i] <- sd(proxi$g_i)
      quants <- hdiofmcmc(proxi$g_i, credmass=clim)
      g_i_lo[i] <- quants[1]
      g_i_hi[i] <- quants[2]

      linesi <- get_lineratios(em_all$flux_em[,,i], sfits$tauv[,i], delta[,i], alaw=alaw)

      tauv_bd <- tauv.bd(em_all$flux_em[,,i], intr_bd=intr_bd, delta[,i], alaw=alaw)

      tauv_bd_m[i] <- mean(tauv_bd)
      tauv_bd_std[i] <- sd(tauv_bd)
      quants <- hdiofmcmc(tauv_bd, credmass=clim)
      tauv_bd_lo[i] <- quants[1]
      tauv_bd_hi[i] <- quants[2]

      ## uncorrected Halpha luminosity from stan fits

      sigma_logl_ha_m[i] <- mean(em_all$sigma_logl_em[,"h_alpha", i])
      sigma_logl_ha_std[i] <- sd(em_all$sigma_logl_em[,"h_alpha", i])
      quants <- hdiofmcmc(em_all$sigma_logl_em[,"h_alpha", i], credmass=clim)
      sigma_logl_ha_lo[i] <- quants[1]
      sigma_logl_ha_hi[i] <- quants[2]

      ## correct from stan fit estimate of tauv

      logl_ha_c <- logl.ha.cor(em_all$sigma_logl_em[, "h_alpha", i], sfits$tauv[,i], delta[,i], alaw=alaw)

      sigma_logl_ha_ctauv_m[i] <- mean(logl_ha_c)
      sigma_logl_ha_ctauv_std[i] <- sd(logl_ha_c)
      quants <- hdiofmcmc(logl_ha_c, credmass=clim)
      sigma_logl_ha_ctauv_lo[i] <- quants[1]
      sigma_logl_ha_ctauv_hi[i] <- quants[2]

      ## correct from balmer decrement

      logl_ha_c <- logl.ha.cor(em_all$sigma_logl_em[, "h_alpha", i], tauv_bd, delta[,i], alaw=alaw)

      sigma_logl_ha_ctauv_bd_m[i] <- mean(logl_ha_c)
      sigma_logl_ha_ctauv_bd_std[i] <- sd(logl_ha_c)
      quants <- hdiofmcmc(logl_ha_c, credmass=clim)
      sigma_logl_ha_ctauv_bd_lo[i] <- quants[1]
      sigma_logl_ha_ctauv_bd_hi[i] <- quants[2]

      eqw_ha_m[i] <- mean(em_all$ew_em[,"h_alpha", i])
      eqw_ha_std[i] <- sd(em_all$ew_em[,"h_alpha", i])
      quants <- hdiofmcmc(em_all$ew_em[,"h_alpha", i], credmass=clim)
      eqw_ha_lo[i] <- quants[1]
      eqw_ha_hi[i] <- quants[2]

      ## some emission line ratios

      o3hbeta_m[i] <- mean(linesi$o3hbeta)
      o3hbeta_std[i] <- sd(linesi$o3hbeta)
      quants <- hdiofmcmc(linesi$o3hbeta, credmass=clim)
      o3hbeta_lo[i] <- quants[1]
      o3hbeta_hi[i] <- quants[2]

      o1halpha_m[i] <- mean(linesi$o1halpha)
      o1halpha_std[i] <- sd(linesi$o1halpha)
      quants <- hdiofmcmc(linesi$o1halpha, credmass=clim)
      o1halpha_lo[i] <- quants[1]
      o1halpha_hi[i] <- quants[2]

      n2halpha_m[i] <- mean(linesi$n2halpha)
      n2halpha_std[i] <- sd(linesi$n2halpha)
      quants <- hdiofmcmc(linesi$n2halpha, credmass=clim)
      n2halpha_lo[i] <- quants[1]
      n2halpha_hi[i] <- quants[2]

      s2halpha_m[i] <- mean(linesi$s2halpha)
      s2halpha_std[i] <- sd(linesi$s2halpha)
      quants <- hdiofmcmc(linesi$s2halpha, credmass=clim)
      s2halpha_lo[i] <- quants[1]
      s2halpha_hi[i] <- quants[2]

      r23_m[i] <- mean(linesi$r23)
      r23_std[i] <- sd(linesi$r23)
      quants <- hdiofmcmc(linesi$r23, credmass=clim)
      r23_lo[i] <- quants[1]
      r23_hi[i] <- quants[2]

      o3n2_m[i] <- mean(linesi$o3n2)
      o3n2_std[i] <- sd(linesi$o3n2)
      quants <- hdiofmcmc(linesi$o3n2, credmass=clim)
      o3n2_lo[i] <- quants[1]
      o3n2_hi[i] <- quants[2]

      oh_n2_m[i] <- mean(linesi$oh_n2)
      oh_n2_std[i] <- sd(linesi$oh_n2)
      quants <- hdiofmcmc(linesi$oh_n2, credmass=clim)
      oh_n2_lo[i] <- quants[1]
      oh_n2_hi[i] <- quants[2]

      oh_o3n2_m[i] <- mean(linesi$oh_o3n2)
      oh_o3n2_std[i] <- sd(linesi$oh_o3n2)
      quants <- hdiofmcmc(linesi$oh_o3n2, credmass=clim)
      oh_o3n2_lo[i] <- quants[1]
      oh_o3n2_hi[i] <- quants[2]

      oh_r23_m[i] <- mean(linesi$oh_r23)
      oh_r23_std[i] <- sd(linesi$oh_r23)
      quants <- hdiofmcmc(linesi$oh_r23, credmass=clim)
      oh_r23_lo[i] <- quants[1]
      oh_r23_hi[i] <- quants[2]

      oh_n2s2ha_m[i] <- mean(linesi$oh_n2s2ha)
      oh_n2s2ha_std[i] <- sd(linesi$oh_n2s2ha)
      quants <- hdiofmcmc(linesi$oh_n2s2ha, credmass=clim)
      oh_n2s2ha_lo[i] <- quants[1]
      oh_n2s2ha_hi[i] <- quants[2]
    }

    data.frame(plateifu, d4000_n, d4000_n_err,
               lick_hd_a, lick_hd_a_err, mgfe,
               d_kpc, d_re,
               tauv_m, tauv_std,
               delta_m, delta_std, ll_m=ll_m,
               sigma_mstar_m , sigma_mstar_std , sigma_mstar_lo , sigma_mstar_hi ,
               sigma_sfr_m , sigma_sfr_std , sigma_sfr_lo , sigma_sfr_hi ,
               ssfr_m , ssfr_std , ssfr_lo , ssfr_hi ,
               relsfr_m , relsfr_std , relsfr_lo , relsfr_hi ,
               tbar_m , tbar_std , tbar_lo , tbar_hi ,
               tbar_lum_m , tbar_lum_std , tbar_lum_lo , tbar_lum_hi ,
               g_i_m , g_i_std , g_i_lo , g_i_hi ,
               tauv_bd_m , tauv_bd_std , tauv_bd_lo , tauv_bd_hi ,
               sigma_logl_ha_m , sigma_logl_ha_std , sigma_logl_ha_lo , sigma_logl_ha_hi ,
               sigma_logl_ha_ctauv_m , sigma_logl_ha_ctauv_std , sigma_logl_ha_ctauv_lo , sigma_logl_ha_ctauv_hi ,
               sigma_logl_ha_ctauv_bd_m , sigma_logl_ha_ctauv_bd_std , sigma_logl_ha_ctauv_bd_lo , sigma_logl_ha_ctauv_bd_hi ,
               eqw_ha_m, eqw_ha_std, eqw_ha_lo, eqw_ha_hi,
               o3hbeta_m , o3hbeta_std , o3hbeta_lo , o3hbeta_hi ,
               o1halpha_m , o1halpha_std , o1halpha_lo , o1halpha_hi ,
               n2halpha_m , n2halpha_std , n2halpha_lo , n2halpha_hi ,
               s2halpha_m , s2halpha_std , s2halpha_lo , s2halpha_hi ,
               r23_m , r23_std , r23_lo , r23_hi ,
               o3n2_m , o3n2_std , o3n2_lo , o3n2_hi ,
               oh_n2_m , oh_n2_std , oh_n2_lo , oh_n2_hi ,
               oh_o3n2_m , oh_o3n2_std , oh_o3n2_lo , oh_o3n2_hi ,
               oh_r23_m , oh_r23_std , oh_r23_lo , oh_r23_hi ,
               oh_n2s2ha_m , oh_n2s2ha_std , oh_n2s2ha_lo , oh_n2s2ha_hi ,
               bpt=bpt)
}

## estimated mean mass fraction in broad ages bins

sum_binnedmass <- function(mgh_post, ages, ages.bins = c(0.1, 2.5, 5)) {
  T.gyr <- 10^(ages-9)
  ind.bins <- findInterval(ages.bins, T.gyr)
  dims <- dim(mgh_post)
  nsim <- dims[1]
  nfib <- dims[3]
  nt <- length(ages.bins)+2
  mgh.binned <- mgh_post[, c(1, ind.bins, dims[2]), ]
  mdiff <- mgh.binned[, 1:(nt-1),] - mgh.binned[, 2:nt, ]
  mb_m <- apply(mdiff, c(2, 3), mean)
  mb_sd <- apply(mdiff, c(2, 3), sd)
  df <- data.frame(cbind(t(mb_m), t(mb_sd)))
  df[df==0] <- NA
  T.ind <- c(0, T.gyr[ind.bins], T.gyr[length(T.gyr)])
  nt <- length(T.ind)
  bnames <- paste(formatC(T.ind[1:(nt-1)], format="f", digits=1), " < T < ",
                     formatC(T.ind[2:nt], format="f", digits=1), sep="")
  names(df) <- c(paste(bnames, "_m", sep=""), paste(bnames, "_sd", sep=""))
  df
}

## computes highest density interval from a sample of representative values,
##   estimated as shortest credible interval.
## arguments:
##   samplevec
##     is a vector of representative values from a probability distribution.
##   credmass
##     is a scalar between 0 and 1, indicating the mass within the credible
##     interval that is to be estimated.
## value:
##   hdilim is a vector containing the limits of the hdi

hdiofmcmc <- function(samplevec , credmass=0.95) {
    sortedpts <- sort(samplevec)
    ciidxinc <- floor(credmass * length(sortedpts))
    ncis <- length(sortedpts) - ciidxinc
    ciwidth <- rep(0 , ncis)
    for (i in 1:ncis) {
        ciwidth[i] <- sortedpts[i + ciidxinc] - sortedpts[i]
    }
    hdimin <- sortedpts[which.min(ciwidth)]
    hdimax <- sortedpts[which.min(ciwidth) + ciidxinc]
    hdilim <- c(hdimin , hdimax)
    return(hdilim)
}


hanoimove <- function(ndisks, from, to, via) {
  if (ndisks == 1) {
    cat("move disk from", from, "to", to, "\n")
  } else {
    hanoimove(ndisks - 1, from, via, to)
    hanoimove(1, from, to, via)
    hanoimove(ndisks - 1, via, to, from)
  }
}

hanoimove(4, 1, 2, 3)


#!/usr/bin/Rscript

library(optparse)
library(DESeq2)
library(BiocParallel)

###############################################################################
### SCRIPT ARGUMENTS

# arguments
rda.opt <- make_option( c("-r", "--rda-se"), type="character", default=NULL )
fml.opt <- make_option( c("-f", "--formula"), type="character", default="~ 1" )
cor.opt <- make_option( c("-c", "--ncores"), type="integer", default=30 )
out.opt <- make_option( c("-o", "--rda-out"), type="character", default=NULL )

# parsing
options <- list(rda.opt, fml.opt, cor.opt, out.opt)
parser <- OptionParser(option_list=options)
args <- parse_args(parser)

# affectation
rda_se <- args[["rda-se"]]
formula <- args[["formula"]]
ncores <- args[["ncores"]]
rda_out <- args[["rda-out"]]

###############################################################################
### PARALLELIZATION

register(MulticoreParam(ncores))

###############################################################################
### LOADING DATA

load(rda_se)
se <- data

###############################################################################
### DESEQ2 MODELING

SummarizedExperiment::assay(se) <- round( SummarizedExperiment::assay(se) )
dds <- DESeq2::DESeqDataSet(se, design=as.formula(formula))
dds <- DESeq2::estimateSizeFactors(dds)
dds <- DESeq2::DESeq(dds, parallel=T)

###############################################################################
### SAVING

data <- dds
save(data, file=rda_out)


#' oxford_index
#'
#' Computes the oxford index of thermal discomfort.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @param wind numeric Windspeed in meters per second.
#' @param pair numeric Air pressure in hPa.
#' @return oxford index
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  oxford_index
#' @references  Lind AR, Hallon RF,1957, Assessment of physiologic severity of hot climate. J Appl Physiol 11, 35 40.
#' @export
#'
#'
#'
#'

oxford_index=function(t,rh,wind=0.2,pair=1010) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$assign("pair", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=oxford_index(t[i],rh[i],wind[0],pair[0])};")
                         res=ct$get("res")
                         return(res)
}


#' Calculate mass based on MT3D Model Run
#'
#' This function reads in a btn file, hds file, and ucn file to calculate
#' the total mass (in units of lbs) in the model at each times step.
#'
#' @param BTN This is the name of the .btn file (without the file extension)
#' @param HDS This is the name of the .hds file (without the file extension)
#' @param UCN This is the name of the .ucn file (without the file extension)
#' @export
#' @examples
#' masscalc(BTN = "T04", HDS = "F95", UCN = "T041")
#'
#' # A tibble: 32,325,120 x 7
#'    YEARS   LAY   ROW   COL THICK  CONC  MASS
#'    <dbl> <int> <int> <int> <dbl> <dbl> <dbl>
#' 1      1     1     1     1     0     0     0
#' 2      1     1     1     2     0     0     0
#' 3      1     1     1     3     0     0     0
#' 4      1     1     1     4     0     0     0
#' 5      1     1     1     5     0     0     0
#' 6      1     1     1     6     0     0     0
#' 7      1     1     1     7     0     0     0
#' 8      1     1     1     8     0     0     0
#' 9      1     1     1     9     0     0     0
#' 10     1     1     1    10     0     0     0
#' # ... with 32,325,110 more rows
#'
#' # Determine the total mass in the top layer of model for each timestep:
#' m <- masscalc(BTN = "T04", HDS = "F95", UCN = "T041")
#' m %>% filter(LAY == 1) %>%
#'       group_by(YEARS) %>%
#'       summarise(TOT = sum(MASS))
#' # A tibble: 16 x 2
#'    YEARS      TOT
#'    <dbl>    <dbl>
#' 1      1 4866.663
#' 2      2 4896.831
#' 3      3 4926.615
#' 4      4 4954.909
#' 5      5 4981.363
#' 6      6 5005.803
#' 7      7 5028.133
#' 8      8 5048.347
#' 9      9 5066.414
#' 10    10 5082.366
#' 11    11 5096.217
#' 12    12 5107.996
#' 13    13 5117.772
#' 14    14 5125.564
#' 15    15 5101.810
#' 16   100 1442.831
#'
#' # Note: the total mass is in units of lbs

masscalc <- function(BTN, HDS, UCN){
    b <- readbtn(BTN)
    NLAY  <- b$NLAY
    NCOL  <- b$NCOL
    NROW  <- b$NROW
    NSP   <- b$NPER
    NPRS  <- b$NPRS
    POR   <- b$TRANS$PRSITY
    THICK <- b$TRANS$dZ
    dX    <- b$dX
    dY    <- b$dY
    dZ    <- b$TRANS %>% select(LAY, ROW, COL, dZ)
    TOP   <- b$TOP$TOP
    BOTL1 <- b$TOP$TOP - dZ[dZ$LAY == 1, ]$dZ
    rm(TOP)
    gc()
    if(toupper(b$LUNIT) == "FT"){
        from_L <- 1000. / 2.54^3 / 12^3
    } else if(toupper(b$LUNIT) == "FEET"){
        from_L <- 1000. / 2.54^3 / 12^3
    } else if(toupper(b$LUNIT) == "FOOT"){
        from_L <- 1000. / 2.54^3 / 12^3
    } else if(toupper(b$LUNIT) == "M"){
        from_L_ <- 1000. / 100^3
    } else if(toupper(b$LUNIT) == "METER"){
        from_L_ <- 1000. / 100^3
    } else if(toupper(b$LUNIT) == "METERS"){
        from_L_ <- 1000. / 100^3
    } else if(toupper(b$LUNIT) == "CM"){
        from_L_ <- 1000.
    } else{
        print("LENGTH UNITS CAN BE ft, m, cm")
        stop("LENGTH UNITS DON'T MATCH\n CHECK THE BTN FILE")
        }

    if(toupper(b$MUNIT) == "MG"){
        to_lbs <- 1. / 1000 * 2.2046226218
    } else if(toupper(b$MUNIT) == "LB"){
        to_lbs <- 1.
    } else if(toupper(b$MUNIT) == "LBS"){
        to_lbs <- 1.
    } else{
        to_lbs <- 1. / 10^6 / 1000. * 2.2046226218
        print("MASS UNITS ARE ASSUMED TO BE micrograms")
        print("IF THIS IS NOT THE CASE, MAKE THE CORRECTION")
        print("IN THE MASS DATA FRAME")
    }

    if(toupper(b$TUNIT) == "D"){
        to_yrs <- 1. / 365
    } else if(toupper(b$TUNIT) == "DAYS"){
        to_yrs <- 1. / 365
    } else if(toupper(b$TUNIT) == "DAY"){
        to_yrs <- 1. / 365
    } else if(toupper(b$TUNIT) == "H"){
        to_yrs <- 1. / 24 / 365
    } else if(toupper(b$TUNIT) == "HOUR"){
        to_yrs <- 1. / 24 / 365
    } else if(toupper(b$MUNIT) == "HOURS"){
        to_yrs <- 1. / 24 / 365
    } else if(toupper(b$TUNIT) == "S"){
        to_yrs <- 1. / 60 / 24 / 365
    } else if(toupper(b$TUNIT) == "SEC"){
        to_yrs <- 1. / 60 / 24 / 365
    } else if(toupper(b$MUNIT) == "SECS"){
        to_yrs <- 1. / 60 / 24 / 365
    } else if(toupper(b$TUNIT) == "Y"){
        to_yrs <- 1.
    } else if(toupper(b$TUNIT) == "YRS"){
        to_yrs <- 1.
    } else if(toupper(b$MUNIT) == "YEAR"){
        to_yrs <- 1.
    } else{
        stop("TIME UNITS DON'T MATCH\n CHECK THE BTN FILE")
    }

    TIMPRS_YEARS <- b$TIMPRS * to_yrs
    rm(b)
    gc()
    h <- MFtools::readhds(HDS, NLAY, NSP) %>%
         dplyr::mutate(YEARS = TIME * to_yrs)

    h$GWE[h$GWE == 999] <- -10^6                        # Index and filter this way to improve speed

    h %<>% dplyr::mutate(THICK = ifelse(LAY == 1, GWE - BOTL1, dZ$dZ)) %>%
           dplyr::mutate(THICK = ifelse(THICK < 0, 0, THICK))

    FLWYRS <- h %>% dplyr::group_by(YEARS) %>% dplyr::summarise(TIME = mean(YEARS)) %>% dplyr::select(YEARS)
    h %<>% dplyr::select(STP, LAY, ROW, COL, THICK) %>% dplyr::rename(PER = STP)

    TRANSYRS <- TIMPRS_YEARS %>% tibble::data_frame(YEARS = .)
    NTTS <- dplyr::full_join(FLWYRS, TRANSYRS, by = "YEARS") %>% nrow() %>% as.integer()
    dX <- dX %>% rep(NROW) %>% rep(NLAY) %>% rep(NTTS)
    dY <- dY %>% rep(each = NCOL) %>% rep(NLAY) %>% rep(NTTS)
    POR <- POR %>% rep(NTTS)

    MASS <- MFtools::readucn(UCN, NLAY, NTTS) %>%
            dplyr::mutate(YEARS = TIME * to_yrs) %>%
            dplyr::left_join(h, by = c("PER", "LAY", "ROW", "COL")) %>%
            dplyr::mutate(dX = dX) %>%
            dplyr::mutate(dY = dY) %>%
            dplyr::mutate(POR = POR) %>%
            dplyr::mutate(CONC = ifelse(CONC < 0 , 0, CONC)) %>%
            dplyr::mutate(MASS = dX * dY * POR * THICK * CONC / from_L * to_lbs) %>%
            dplyr::select(YEARS, LAY, ROW, COL, THICK, CONC, MASS)

    rm(h)
    rm(dX)
    rm(dY)
    rm(POR)
    rm(BOTL1)
    rm(THICK)
    gc()
    return(MASS)
    }


#!/usr/bin/Rscript
library(ggplot2)
library(Rsubread)
library(limma)
library(edgeR)

# read in target file
options(digits=2)
targets <- readTargets("../../data/rnaseq/Targets.txt")

# create a design matrix
celltype <- factor(targets$CellType)
design <- model.matrix(~celltype)

# build an index for reference sequence (Chr1 in hg19)
# buildindex(basename="chr1",reference="../../data/rnaseq/hg19_chr1.fa")
#
# # align reads
# align(
#   ndex="chr1",readfile1=targets$InputFile,input_format="gzFASTQ",
#   output_format="BAM",output_file=targets$OutputFile,unique=TRUE,indels=5
# )

# count numbers of reads mapped to NCBI Refseq genes
# the file is obtained from:
#   https://ftp.ncbi.nlm.nih.gov/genomes/refseq/vertebrate_mammalian/Homo_sapiens/all_assembly_versions/GCF_000001405.25_GRCh37.p13/GCF_000001405.25_GRCh37.p13_genomic.gtf.gz
# our version is slightly modified from the original gtf version
# gzip -cd "${INFILE_DIR}/GCF_000001405.25_GRCh37.p13_genomic.gtf.gz" | \
#   grep -P "^#|^NC_000001.10\t" | sed "s|NC_000001.10	|chr1	|" > \
#   "${INFILE_DIR}/hg19_chr1.gtf"
fc <- featureCounts(
  files=paste(
    "../../data/rnaseq/", c("A_1.bam", "A_2.bam", "B_1.bam", "B_2.bam"), sep=""
  ),
  isGTFAnnotationFile=TRUE,
  annot.ext="../../data/rnaseq/hg19_chr1.gtf.gz"
)
# write.table(fc$counts, sep="\t", quote=F, "original.tsv")
x <- DGEList(counts=fc$counts, genes=fc$annotation[,c("GeneID","Length")])

# filter out low-count genes
isexpr <- rowSums(cpm(x) > 10) >= 2
x <- x[isexpr,]

# generate CPM values for plotting
x_cpm <- cpm(x)

# make pca plots
y <- prcomp(t(x_cpm), scale=TRUE)
df_out <- as.data.frame(y$x)
df_out$group <- sapply(
  strsplit(as.character(row.names(df_out)), ".", fixed=TRUE), "[[", 8
)
df_out$group <- sapply( strsplit(df_out$group, "_", fixed=TRUE), "[[", 1 )

p <- ggplot(df_out, aes(x=PC1, y=PC2, color=group)) + geom_point(size=8) + theme_bw()
ggsave("../../results/ismb_plots_2021/original.pca.pdf", p)

# clear environment to avoid variable clash
rm(list=ls())

# read in target file
targets <- readTargets("../../data/rnaseq/Targets.txt")

# create a design matrix
celltype <- factor(targets$CellType)
design <- model.matrix(~celltype)

# make pca plot from reformatted data
# data was reformatted by passing it through our pipeline
x <- read.table("../../results/rnaseq/24000.joined.tsv")
x <- DGEList(x)

# filter out low-count genes
isexpr <- rowSums(cpm(x) > 10) >= 2
x <- x[isexpr,]

# generate CPM values for plotting
x_cpm <- cpm(x)

# make pca plots
y <- prcomp(t(x_cpm), scale=TRUE)
df_out <- as.data.frame(y$x)
df_out$group <- sapply( strsplit(row.names(df_out), "_", fixed=TRUE), "[[", 1 )

p <- ggplot(df_out, aes(x=PC1, y=PC2, color=group)) + geom_point(size=8) + theme_bw()
ggsave("../../results/ismb_plots_2021/reformat.pca.pdf", p)


Portrait<-F                 # graphical output orientation

first.year<- 1963                #first year on plot, negative value means value defined by data
last.year<- 2100               #last year on plot

HindcastModel<-T; # plot values from the hindcast
ForecastModel<-F; # plot values from the scenarios

redefine.scenario.manually<-T  # Define the scenario dir used explecitely in this script or do it externally

op.dir<-data.path
if (ForecastModel==T & redefine.scenario.manually)  {
   scenario<-"Opti-2_HCR_4_stoch_penBlim_atAgeW__";
   output.dir<-data.path
   op.dir<-file.path(data.path,scenario)
} else if (ForecastModel==T ) {
   output.dir<-scenario.dir
   op.dir<-scenario.dir
}

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

my.dev<-'png'   # output device:  'screen', 'wmf', 'png', 'pdf'

#my.dev<-'screen'
cleanup()
file.name<-'summary'

nox<-3; noy<-1;
noxy<-nox*noy

ref<-Read.reference.points()

Init.function()

pel.bio<<-NULL
dem.bio<-NULL
deadM<-NULL
deadM1<-NULL
deadM2<-NULL
CWsum<-NULL
Expectancy<-NULL
LFI<-NULL

if (HindcastModel) {
  dat1<-Read.summary.data(dir=data.path)

  dat1<-subset(dat1,Year<=last.year )
  if (first.year>0) dat1<-subset(dat1,Year>=first.year )
  bio<-subset(dat1,select=c(Species.n,Year,Age,BIO),Quarter==1)

  round(tapply(bio$BIO,list(bio$Year,bio$Species.n),sum)/1000)

  MSFD<-read.FLOP.MSFD.control(file=file.path(op.dir,"op_msfd.dat"),n.VPA=nsp-first.VPA+1,n.other.pred=first.VPA-1)

  pl<-strmacro(opt,out,n1=1,
       expr={
        incl<-NULL
        for (s in (n1:nsp)) {
          fa.i<-MSFD@opt['first.age',s]
          la.i<-MSFD@opt['last.age',s]
          if (la.i>=fa.i) incl<-rbind(incl,data.frame(Species.n=s,Age=seq(fa.i,la.i)))
        }
        out<-merge(incl,bio)
        out<-tapply(out$BIO,list(out$Year),sum)
      } )

  pl(community.biomass.pelagic.ages,pel.bio)    # creates pel.bio
  pl(community.biomass.demersal.ages,dem.bio)   # creates dem.bio
  pl(community.biomass.forage.ages,forage.bio)   # creates forage.bio

  bio2<-subset(bio,Species.n>=first.VPA)
  tot.bio<-tapply(bio2$BIO,list(bio2$Year),sum)

  #community M and F
  bio<-subset(dat1,select=c(Species.n,Year,Quarter,Age,BIO,M,M1,M2,CWsum,west, N.bar ))
  incl<-data.frame(Species.n=first.VPA:nsp,incl=c(MSFD@community.M.sp))
  a<-merge(incl,bio)
  a<-subset(a,incl==1)
  a[a$M1==-1,'M1']<-a[a$M1==-1,'M']
  a$deadM1<-a$N.bar*a$west*a$M1
  a$deadM2<-a$N.bar*a$west*a$M2
  bio2<-subset(a,Quarter==1);
  bio2<-tapply(bio2$BIO,list(bio2$Year),sum)
  deadM1<-tapply(a$deadM1,list(a$Year),sum)/bio2
  deadM2<-tapply(a$deadM2,list(a$Year),sum)/bio2

  incl<-data.frame(Species.n=first.VPA:nsp,incl=c(MSFD@community.F.sp))
  a<-merge(incl,bio)
  a<-subset(a,incl==1)
  bio2<-subset(a,Quarter==1);
  bio2<-tapply(bio2$BIO,list(bio2$Year),sum)
  CWsum<-tapply(a$CWsum,list(a$Year),sum)/bio2

  # life expectancy
  bio<-subset(dat1,select=c(Species.n,Year,Quarter,Age,Z))
  incl<-data.frame(Species.n=first.VPA:nsp,incl=c(MSFD@community.life.expectancy.options['first.age',]))
  incl<-NULL
  for (s in (first.VPA:nsp)) {
          fa.i<-MSFD@community.life.expectancy.options['first.age',s-first.VPA+1]
          la.i<-SMS.control@species.info[s,'last-age']
          if (la.i>=fa.i) incl<-rbind(incl,data.frame(Species.n=s,Age=seq(fa.i,la.i)))
   }
  bio<-merge(bio,incl)
  a<-data.frame(Species.n=first.VPA:nsp,w=c(MSFD@community.life.expectancy.options['weighting',]))
  bio<-merge(bio,a)

  bio<-bio[order(bio$Species.n,bio$Year,bio$Age,bio$Quarter),]
  min.Year<-min(bio$Year)
  bio$first<- !duplicated(paste(bio$Species.n,bio$Year))

  a<-unique(subset(bio,first,select=c(Species.n,Age,Quarter)))
  a$ini.age<-a$Age+(a$Quarter-1)*0.25
  a<-subset(a,select=c(Species.n,ini.age))

  bio<-merge(bio,a)
  bio$sumZ<-bio$Z
  bio<-bio[order(bio$Species.n,bio$Year,bio$Age,bio$Quarter),]

  for (x in (1:dim(bio)[1])) {
   if (!bio[x,'first']) bio[x,'sumZ']<-bio[x,'sumZ']+(bio[x-1,'sumZ'])
  }
  bio$p<-exp(-bio$sumZ)

  a<-aggregate(p~Year+Species.n+ini.age+w,sum,na.rm=T,data=bio)
  a$p<-a$p/4 + a$ini.age+0.25/2  # to expected life in years (from quarters)
  a$pw<-a$p*a$w

  a<-aggregate(cbind(pw, w)~Year,sum,na.rm=T,data=a)
  a$Expectancy<-a$pw/a$w
  Expectancy<-tapply(a$Expectancy,list(a$Year),sum)

  # LFI
  bio<-subset(dat1,Quarter==1,select=c(Species.n,Year,Age,BIO))
  incl<-data.frame(Species.n=1:nsp,incl=MSFD@LFI.sp['include',])
  bio<-merge(bio,incl)
  bio<-subset(bio,incl==1,select=-incl)
  NW.all<-tapply(bio$BIO,list(bio$Year),sum)

  incl<-NULL
  for (s in (1:nsp)) {
          fa.i<-MSFD@LFI.age['first.age',s]
          la.i<-SMS.control@species.info[s,'last-age']
          if (la.i>=fa.i) incl<-rbind(incl,data.frame(Species.n=s,Age=seq(fa.i,la.i)))
   }
  bio<-merge(bio,incl)
  NW.LFI<-tapply(bio$BIO,list(bio$Year),sum)

  LFI<-NW.LFI/NW.all

}

if (ForecastModel) {
 dat<-Read.OP.community.indicator(dir=op.dir)
} else  dat<-NULL

add.set<-strmacro(in1,in2,out,
   expr={
    if (HindcastModel & ForecastModel) out<-c(in1,in2) else if (HindcastModel) out<-c(in1)  else if (ForecastModel) out<-c(in2)
  } )

# biomass plot
b.factor<-1000
if (ForecastModel) {
   pel.b<-tapply(dat$bio.pelag,list(dat$Year),mean)
   dem.b<-tapply(dat$bio.demer,list(dat$Year),mean)
}
add.set(in1=pel.bio,in2=pel.b,pel.b)
add.set(in1=dem.bio,in2=dem.b,dem.b)
add.set(in1=forage.bio,in2=forage.b,forage.b)
add.set(in1=tot.bio,in2=tot.b,tot.b)
tot.b<-tot.b/b.factor
pel.b<-pel.b/b.factor
dem.b<-dem.b/b.factor
forage.b<-forage.b/b.factor
max.bio<-max(c(pel.b,dem.b,forage.b))
min.bio<-min(c(pel.b,dem.b,forage.b))
ratio<-pel.b/dem.b
year<-as.numeric(unlist(names(ratio)))

cleanup()
plotfile<-function(dev='screen',out) {
  if (dev=='screen') X11(width=8, height=12, pointsize=12)
  if (dev=='wmf') win.metafile(filename = paste(out,'.wmf',sep=''), width=8, height=10, pointsize=12)
  if (dev=='png') png(filename =paste(out,'.png',sep=''), width = 1000, height = 1400,units = "px", pointsize = 30, bg = "white")
  if (dev=='pdf') pdf(file =paste(out,'.pdf',sep=''), width = 8, height = 10,pointsize = 12,onefile=FALSE)
}

plotfile(dev=my.dev,out=file.path(op.dir,'community_indicator_year'));
par(mfcol=c(nox,noy))
par(mar=c(3,4,3,2))  # bottom, left, top, right
par(mar=c(2,4,3,5)+.1)  #bottom, left, top, right

plot(year,dem.b, ylim=c(min.bio,max.bio),type='b',xlab='Year',ylab='1000 t',lty=1,pch='d',lwd=2,main='Biomass: Pelagic (p), Demersal (d) and p:d ratio(r)')
lines(year,pel.b,lty=2,pch='p',lwd=2,type='b',col=2)
#lines(year,forage.b,lty=2,pch='f',lwd=2,type='b',col=3)

#legend('topright',
#     c('Pelagic','Demersal','Ratio'),
#     pch="pdr",lty=c(0,0,0),col=c(1,2,3),lwd=rep(2,3))

par(new=T)
plot(year,ratio,lty=3,pch='r',lwd=2,ylab=' ',xlab=' ',type='b',axes=F,col=4)
axis(side=4)
mtext(side=4,line=3.0,"Ratio Pelagic:Demersal",cex=0.65)
par(xaxs="r")

# community F and M2

if (ForecastModel) {
  FF<-tapply(dat$comm.Fall,list(dat$Year),mean)
  M<-tapply(dat$comm.M,list(dat$Year),mean)
  M2<-tapply(dat$comm.M2,list(dat$Year),mean)
}
add.set(in1=CWsum,in2=FF,FF)
add.set(in1=deadM1,in2=M,M1)
add.set(in1=deadM2,in2=M2,M2)

max.D<-max(c(FF,M1,M2))
min.D<-min(c(FF,M1,M2))
year<-as.numeric(unlist(names(M1)))

plot(year,FF,ylim=c(min.D,max.D),lty=1,pch='F',lwd=2,ylab='',xlab=' ',type='b',axes=T,col=1,main='Removed biomass relative to TSB 1. January')

legend('topright',
     c('Fishing','M2 predation','M1 residual mort.'),
     pch="F21",lty=c(0,0,0),col=c(1,2,4),lwd=rep(2,3))

lines(year,M1,lty=2,pch='1',lwd=2,type='b',col=4)
lines(year,M2,lty=3,pch='2',lwd=2,type='b',col=2)

#  community.life.expect
if (ForecastModel) {
  ex<-tapply(dat$community.life.expect,list(dat$Year),mean)
}
add.set(in1=Expectancy,in2=ex,ex)
year<-as.numeric(unlist(names(ex)))
plot(year,ex,type='b',xlab=' ',pch='e',ylab='Life expectancy (year)',lty=1,lwd=2,main='Life expectancy (e) and LFI (l)')

#  LFI
if (ForecastModel) {
  LFI2<-tapply(dat$LFI,list(dat$Year),mean)
}
add.set(in1=LFI,in2=LFI2,LFI)
LFI<-LFI*100
year<-as.numeric(unlist(names(LFI)))

par(new=T)
plot(year,LFI,lty=3,pch='l',lwd=2,ylab=' ',xlab=' ',type='b',axes=F,col=4)
axis(side=4)
mtext(side=4,line=3.0,"LFI (%)",cex=0.65)
par(xaxs="r")

if (my.dev %in% c('png','wmf','pdf')) dev.off()