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

#' MVP, Memory-efficient, Visualization-enhanced, Parallel-accelerated
#'
#' Object 1: To perform GWAS using General Linear Model (GLM), Mixed Linear Model (MLM), and FarmCPU model
#' Object 2: To calculate kinship among individuals using Varaden method
#' Object 3: Estimate variance components using EMMA, FaST-LMM, and HE regression
#' Object 4: Generate high-quality figures
#'
#' Build date: Aug 30, 2017
#' Last update: Dec 14, 2018
#'
#' @author Lilin Yin, Haohao Zhang, and Xiaolei Liu
#'
#' @param phe phenotype, n * 2 matrix, n is sample size
#' @param geno Genotype in bigmatrix format; m * n, m is marker size, n is sample size
#' @param map SNP map information, SNP name, Chr, Pos
#' @param K Kinship, Covariance matrix(n * n) for random effects, must be positive semi-definite
#' @param nPC.GLM number of PCs added as fixed effects in GLM
#' @param nPC.MLM number of PCs added as fixed effects in MLM
#' @param nPC.FarmCPU number of PCs added as fixed effects in FarmCPU
#' @param CV.GLM covariates added in GLM
#' @param CV.MLM covariates added in MLM
#' @param CV.FarmCPU covariates added in FarmCPU
#' @param REML a list contains ve and vg
#' @param priority speed or memory
#' @param ncpus number of cpus used for parallel
#' @param vc.method methods for estimating variance component("EMMA" or "HE" or "BRENT")
#' @param method the GWAS model, "GLM", "MLM", and "FarmCPU", models can be selected simutaneously, i.e. c("GLM", "MLM", "FarmCPU")
#' @param p.threshold if all p values generated in the first iteration are bigger than p.threshold, FarmCPU stops
#' @param QTN.threshold in second and later iterations, only SNPs with lower p-values than QTN.threshold have chances to be selected as pseudo QTNs
#' @param method.bin 'static' or 'FaST-LMM'
#' @param bin.size window size in genome
#' @param bin.selection a vector, how many windows selected
#' @param maxLoop maximum number of iterations
#' @param permutation.threshold if use a permutation cutoff or not (bonferroni cutoff)
#' @param permutation.rep number of permutation replicates
#' @param col for color of points in each chromosome on manhattan plot
#' @param memo Character. A text marker on output files
#' @param outpath Effective only when file.output = TRUE, determines the path of the output file
#' @param file.output whether to output files or not
#' @param file.type figure formats, "jpg", "tiff"
#' @param dpi resolution for output figures
#' @param threshold a cutoff line on manhattan plot, 0.05/marker size
#' @param verbose whether to print detail.
#'
#' @export
#' @return a m * 2 matrix, the first column is the SNP effect, the second column is the P values
#' Output: MVP.return$map - SNP map information, SNP name, Chr, Pos
#' Output: MVP.return$glm.results - p-values obtained by GLM method
#' Output: MVP.return$mlm.results - p-values obtained by MLM method
#' Output: MVP.return$farmcpu.results - p-values obtained by FarmCPU method
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' print(dim(genotype))
#' mapPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.map", package = "rMVP")
#' map <- read.table(mapPath , head = TRUE)
#'
#' opts <- options(rMVP.OutputLog2File = FALSE)
#'
#' mvp <- MVP(phe=phenotype, geno=genotype, map=map, maxLoop=3,
#'   method=c("GLM", "MLM", "FarmCPU"), file.output=FALSE, ncpus=1)
#' str(mvp)
#'
#' options(opts)
MVP <-
function(phe, geno, map, K=NULL, nPC.GLM=NULL, nPC.MLM=NULL, nPC.FarmCPU=NULL,
         CV.GLM=NULL, CV.MLM=NULL, CV.FarmCPU=NULL, REML=NULL, priority="speed",
         ncpus=detectCores(logical = FALSE), vc.method=c("BRENT", "EMMA", "HE"),
         method=c("GLM", "MLM", "FarmCPU"), p.threshold=NA,
         QTN.threshold=0.01, method.bin="static", bin.size=c(5e5,5e6,5e7),
         bin.selection=seq(10,100,10), maxLoop=10, permutation.threshold=FALSE,
         permutation.rep=100, memo=NULL, outpath=getwd(),
         col=c("#4197d8", "#f8c120", "#413496", "#495226", "#d60b6f", "#e66519",
         "#d581b7", "#83d3ad", "#7c162c", "#26755d"), file.output=TRUE,
         file.type="jpg", dpi=300, threshold=0.05, verbose=TRUE
) {

    # Compatible with old ways
    if (file.output == TRUE) {
      file.output <- c("pmap", "pmap.signal", "plot", "log")
    } else if (file.output == FALSE) {
      file.output <- c()
    }

    for(mt in method){
        if(!mt %in% c("GLM", "MLM", "FarmCPU"))
            stop("Unknow method: ", mt)
    }

    # Set output path of log file
    logging.outpath <- NULL
    if ("log" %in% file.output) {
      logging.outpath <- outpath
    }
    logging.initialize("MVP", logging.outpath)

    MVP.Version(width = 60, verbose = verbose)
    logging.log("Start:", as.character(Sys.time()), "\n", verbose = verbose)
    if ("log" %in% file.output) {
        logging.log("The log has been output to the file:", get("logging.file", envir = package.env), "\n", verbose = verbose)
    }
    vc.method <- match.arg(vc.method)
    if (nrow(phe) != ncol(geno)) stop("The number of individuals in phenotype and genotype doesn't match!")
    if (nrow(geno) != nrow(map)) stop("The number of markers in genotype and map doesn't match!")
    if (!is.big.matrix(geno))    stop("genotype should be in 'big.matrix' format.")
    if(hasNA(geno@address))   stop("NA is not allowed in genotype, use 'MVP.Data.impute' to impute.")

    #list -> matrix
    map <- as.data.frame(map)
    for(i in 1 : ncol(map)){
        if(is.factor(map[, i])) map[, i] <- as.character.factor(map[, i])
    }

    na.index <- NULL
    if (!is.null(CV.GLM)) {
        CV.GLM <- as.matrix(CV.GLM)
    if (nrow(CV.GLM) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
        na.index <- c(na.index, which(is.na(CV.GLM), arr.ind = TRUE)[, 1])
    }
    if (!is.null(CV.MLM)) {
        CV.MLM <- as.matrix(CV.MLM)
        if (nrow(CV.MLM) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
       na.index <- c(na.index, which(is.na(CV.MLM), arr.ind = TRUE)[, 1])
    }
    if (!is.null(CV.FarmCPU)) {
        CV.FarmCPU <- as.matrix(CV.FarmCPU)
        if (nrow(CV.FarmCPU) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
        na.index <- c(na.index, which(is.na(CV.FarmCPU), arr.ind = TRUE)[, 1])
    }
    na.index <- unique(na.index)

    #Data information
    m <- nrow(geno)
    n <- ncol(geno)
    logging.log(paste("Input data has", n, "individuals,", m, "markers"), "\n", verbose = verbose)
    logging.log("Analyzed trait:", colnames(phe)[2], "\n", verbose = verbose)
    logging.log("Number of threads used:", ncpus, "\n", verbose = verbose)

    #remove samples with missing phenotype
    seqTaxa = which(!is.na(phe[,2]))
    if (length(na.index) != 0) seqTaxa <- intersect(seqTaxa, c(1:n)[-na.index])
    if (length(seqTaxa) != n) {
        logging.log("Total", n - length(seqTaxa), "individuals removed due to missings", "\n", verbose = verbose)
        geno = deepcopy(
          x = geno,
          cols = seqTaxa
        )
        phe = phe[seqTaxa,]
        if (!is.null(K)) { K = K[seqTaxa, seqTaxa] }
        if (!is.null(CV.GLM)) { CV.GLM = CV.GLM[seqTaxa,] }
        if (!is.null(CV.MLM)) { CV.MLM = CV.MLM[seqTaxa,] }
        if (!is.null(CV.FarmCPU)) { CV.FarmCPU = CV.FarmCPU[seqTaxa,] }
    }

    m <- nrow(geno)
    n <- ncol(geno)

    #initial results
    glm.results <- NULL
    mlm.results <- NULL
    farmcpu.results <- NULL

    #indicators for models
    glm.run <- "GLM" %in% method
    mlm.run <- "MLM" %in% method
    farmcpu.run <- "FarmCPU" %in% method

    nPC <- suppressWarnings(max(nPC.GLM, nPC.MLM, nPC.FarmCPU, na.rm = TRUE))
    if (nPC <= 0) {
        nPC <- NULL
    } else if (nPC < 3) {
        nPC <- 3
    }

    if (!is.null(K)) { K <- as.matrix(K) }
    if (!is.null(nPC) | "MLM" %in% method) {
        if (is.null(K)) {
            K <- MVP.K.VanRaden(
              M = geno,
              priority = priority,
              cpu = ncpus,
              verbose = verbose
            )
        }
        logging.log("Eigen Decomposition on GRM", "\n", verbose = verbose)
        eigenK <- eigen(K, symmetric = TRUE)
        if (!is.null(nPC)) {
            ipca <- eigenK$vectors[, 1:nPC]
            logging.log("Deriving PCs successfully", "\n", verbose = verbose)
        }
        if (("MLM" %in% method) & vc.method == "BRENT") { K <- NULL; gc()}
        if (!"MLM" %in% method) { rm(eigenK); rm(K); gc() }
    }

    if (!is.null(nPC)) {
        #CV for GLM
        if (glm.run) {
            if (!is.null(CV.GLM)) {
                logging.log("Number of provided covariates of GLM:", ncol(CV.GLM), "\n", verbose = verbose)
                if (!is.null(nPC.GLM)) {
                    logging.log("Number of PCs included:", nPC.GLM, "\n", verbose = verbose)
                    CV.GLM <- cbind(ipca[,1:nPC.GLM], CV.GLM)
                }
            } else if (!is.null(nPC.GLM)) {
                logging.log("Number of PCs included in GLM:", nPC.GLM, "\n", verbose = verbose)
                CV.GLM <- ipca[,1:nPC.GLM]
            }
        }

        #CV for MLM
        if (mlm.run) {
            if (!is.null(CV.MLM)) {
                logging.log("Number of provided covariates of MLM:", ncol(CV.MLM), "\n", verbose = verbose)
                if (!is.null(nPC.MLM)) {
                    logging.log("Number of PCs included:", nPC.MLM, "\n", verbose = verbose)
                    CV.MLM <- cbind(ipca[,1:nPC.MLM], CV.MLM)
                }
            } else if (!is.null(nPC.MLM)) {
                logging.log("Number of PCs included in MLM:", nPC.MLM, "\n", verbose = verbose)
                CV.MLM <- ipca[,1:nPC.MLM]
            }
        }

        #CV for FarmCPU
        if (farmcpu.run) {
            if (!is.null(CV.FarmCPU)) {
                logging.log("Number of provided covariates of FarmCPU:", ncol(CV.FarmCPU), "\n", verbose = verbose)
                if (!is.null(nPC.FarmCPU)) {
                    logging.log("Number of PCs included:", nPC.FarmCPU, "\n", verbose = verbose)
                    CV.FarmCPU <- cbind(ipca[,1:nPC.FarmCPU], CV.FarmCPU)
                }
            }else if (!is.null(nPC.FarmCPU)) {
                logging.log("Number of PCs included in FarmCPU:", nPC.FarmCPU, "\n", verbose = verbose)
                CV.FarmCPU <- ipca[,1:nPC.FarmCPU]
            }
        }
    }else{
        if (glm.run) {
            if (!is.null(CV.GLM)) {
                logging.log("Number of provided covariates of GLM:", ncol(CV.GLM), "\n", verbose = verbose)
            }
        }
        if (mlm.run) {
            if (!is.null(CV.MLM)) {
                logging.log("Number of provided covariates of MLM:", ncol(CV.MLM), "\n", verbose = verbose)
            }
        }
        if (farmcpu.run) {
            if (!is.null(CV.FarmCPU)) {
                logging.log("Number of provided covariates of FarmCPU:", ncol(CV.FarmCPU), "\n", verbose = verbose)
            }
        }
    }

    #GWAS
    logging.log("-------------------------GWAS Start-------------------------", "\n", verbose = verbose)
    if (glm.run) {
        logging.log("General Linear Model (GLM) Start...", "\n", verbose = verbose)
        glm.results <- MVP.GLM(phe=phe, geno=geno, CV=CV.GLM, cpu=ncpus, verbose = verbose);gc()
        colnames(glm.results) <- c("Effect", "SE", paste(colnames(phe)[2],"GLM",sep="."))
        z = glm.results[, 1]/glm.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map, glm.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".GLM.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    if (mlm.run) {
        logging.log("Mixed Linear Model (MLM) Start...", "\n", verbose = verbose)
        mlm.results <- MVP.MLM(phe=phe, geno=geno, K=K, eigenK=eigenK, CV=CV.MLM, cpu=ncpus, vc.method=vc.method, verbose = verbose);gc()
        colnames(mlm.results) <- c("Effect", "SE", paste(colnames(phe)[2],"MLM",sep="."))
        z = mlm.results[, 1]/mlm.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map, mlm.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".MLM.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    if (farmcpu.run) {
        logging.log("FarmCPU Start...", "\n", verbose = verbose)
        farmcpu.results <- MVP.FarmCPU(phe=phe, geno=geno, map=map[,1:3], CV=CV.FarmCPU, ncpus=ncpus, memo="MVP.FarmCPU", p.threshold=p.threshold, QTN.threshold=QTN.threshold, method.bin=method.bin, bin.size=bin.size, bin.selection=bin.selection, maxLoop=maxLoop, verbose = verbose)
        colnames(farmcpu.results) <- c("Effect", "SE", paste(colnames(phe)[2],"FarmCPU",sep="."))
        z = farmcpu.results[, 1]/farmcpu.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map,farmcpu.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".FarmCPU.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    MVP.return <- list(map=map, glm.results=glm.results, mlm.results=mlm.results, farmcpu.results=farmcpu.results)

    if(permutation.threshold){
        # set.seed(12345)
        i=1
        for(i in 1:permutation.rep){
            index = 1:nrow(phe)
            index.shuffle = sample(index,length(index),replace=FALSE)
            myY.shuffle = phe
            myY.shuffle[,2] = myY.shuffle[index.shuffle,2]
            #GWAS using t.test...
            myPermutation = MVP.GLM(phe=myY.shuffle[,c(1,2)], geno=geno, cpu=ncpus)
            pvalue = min(myPermutation[,2],na.rm=TRUE)
            if(i==1){
                    pvalue.final=pvalue
               }else{
                    pvalue.final=c(pvalue.final,pvalue)
            }
        }#end of permutation.rep
        permutation.cutoff = sort(pvalue.final)[ceiling(permutation.rep*0.05)]
        threshold = permutation.cutoff * m
    }
    logging.log(paste0("Significant level: ", formatC(threshold/m, format = "e", digits = 2)), "\n", verbose = verbose)
    if ("pmap.signal" %in% file.output) {
        if (glm.run) {
            index <- which(glm.results[, ncol(glm.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, glm.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".GLM_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
        if (mlm.run) {
            index <- which(mlm.results[, ncol(mlm.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, mlm.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".MLM_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
        if (farmcpu.run) {
            index <- which(farmcpu.results[, ncol(farmcpu.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, farmcpu.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".FarmCPU_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
    }
    if ("plot" %in% file.output) {
        logging.log("---------------------Visualization Start--------------------", "\n", verbose = verbose)
        logging.log("Phenotype distribution Plotting", "\n", verbose = verbose)
        MVP.Hist(memo=memo, outpath=outpath, file.output=TRUE, phe=phe, file.type=file.type, col=col, dpi=dpi)
        #plot3D <- !is(try(library("rgl"),silent=TRUE), "try-error")
        plot3D <- FALSE
        if(!is.null(nPC)){
          MVP.PCAplot(
            ipca[,1:3],
            col=col,
            plot3D=plot3D,
            file.output=TRUE,
            file.type=file.type,
            outpath=outpath,
            memo = ifelse(is.null(memo), colnames(phe)[2], paste(colnames(phe)[2], memo, sep=".")),
            dpi=dpi,
          )
        }

        MVP.Report(
            MVP.return,
            col=col,
            plot.type=c("c","m","q","d"),
            file.output=TRUE,
            file.type=file.type,
            outpath=outpath,
            memo = memo,
            chr.den.col=c("darkgreen", "yellow", "red"),
            dpi=dpi,
            threshold=threshold/m,
        )

        if(sum(c(is.null(glm.results), is.null(mlm.results), is.null(farmcpu.results))) < 2) {
            MVP.Report(
                MVP.return,
                col=col,
                plot.type=c("m","q"),
                multracks=TRUE,
                file.output=TRUE,
                file.type=file.type,
                outpath=outpath,
                memo = memo,
                dpi=dpi,
                threshold=threshold/m
            )
        }
    }
    now <- Sys.time()
    if (length(file.output) > 0) {
      logging.log("Results are stored at Working Directory:", outpath, "\n", verbose = verbose)
    }
    logging.log("End:", as.character(now), "\n", verbose = verbose)
    print_accomplished(width = 60, verbose = verbose)

    return(invisible(MVP.return))
}#end of MVP function


##SNOPSIS

#Qtl analysis based on rqtl.

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

options(echo = FALSE)

library(qtl)

allargs <- commandArgs()

infile   <- grep("infile_list", allargs, value=TRUE)
outfile  <- grep("outfile_list", allargs, value=TRUE)

infile   <- scan(infile, what="character")
statfile <- grep("stat", infile, value=TRUE)

##### stat files
statfiles <- scan(statfile, what="character")

###### QTL mapping method ############
qtlmethodfile <- grep("stat_qtl_method", statfiles, value=TRUE)
qtlmethod <- scan(qtlmethodfile, what="character", sep="\n")

if (qtlmethod == "Maximum Likelihood") {
  qtlmethod <- c("em")
} else if (qtlmethod == "Haley-Knott Regression") {
  qtlmethod <- c("hk")
} else if (qtlmethod == "Multiple Imputation") {
  qtlmethod <- c("imp")
} else if (qtlmethod == "Marker Regression") {
  qtlmethod <- c("mr")
}

###### QTL model ############
qtlmodelfile <- grep("stat_qtl_model",  statfiles, value=TRUE)
qtlmodel <- scan(qtlmodelfile, what="character", sep="\n")

if (qtlmodel == "Single-QTL Scan") {
  qtlmodel <- c("scanone")
} else if  (qtlmodel == "Two-QTL Scan") {
  qtlmodel<-c("scantwo")
}

###### permutation############
userpermufile  <- grep("stat_permu_test", statfiles, value=TRUE)
userpermuvalue <- scan(userpermufile, what="numeric", dec= ".", sep="\n")

if (userpermuvalue == "None") {
  userpermuvalue<-c(0)
}

userpermuvalue <- as.numeric(userpermuvalue)

#####for test only
#userpermuvalue<-c(100)
#####

######genome step size############
stepsizefile <- grep("stat_step_size",  statfiles, value=TRUE)

stepsize <- scan(stepsizefile, what="numeric", dec = ".", sep="\n")

if (qtlmethod == 'mr') {
    stepsize <- c(0)
} else if (qtlmethod != 'mr' & stepsize == "zero") {
      stepsize <- c(0)
  }

stepsize <- as.numeric(stepsize)

######genotype calculation method############
genoprobmethodfile <- grep("stat_prob_method", statfiles, value=TRUE)

genoprobmethod <- scan(genoprobmethodfile, what="character", dec=".", sep="\n")

########No. of draws for sim.geno method###########
drawsnofile <- c()
drawsno <- c()
if (qtlmethod == 'imp') {
    if (is.null(grep("stat_no_draws", statfiles))==FALSE) {
        drawsnofile <- grep("stat_no_draws", statfiles, value=TRUE)
    }

    if (is.null(drawsnofile)==FALSE) {
        drawsno <- scan(drawsnofile, what="numeric", dec = ".", sep="\n")
        drawsno <- as.numeric(drawsno)
      }
  }
########significance level for genotype
#######probablity calculation
genoproblevelfile <- grep("stat_prob_level", statfiles, value=TRUE)
genoproblevel     <- scan(genoproblevelfile, what="numeric", dec = ".", sep="\n")

if (qtlmethod == 'mr') {
    if (is.logical(genoproblevel) == FALSE) {
        genoproblevel <- c(0)
    }

    if (is.logical(genoprobmethod) ==FALSE) {
        genoprobmethod <- c('Calculate')
      }
  }

genoproblevel <- as.numeric(genoproblevel)

########significance level for permutation test
permuproblevelfile <- grep("stat_permu_level", statfiles, value=TRUE)

permuproblevel <- scan(permuproblevelfile, what="numeric", dec = ".", sep="\n")

permuproblevel <- as.numeric(permuproblevel)

#########
cvtermfile <- grep("cvterm", infile, value=TRUE)

popidfile <- grep("popid", infile, value=TRUE)

genodata <- grep("genodata", infile, value=TRUE)

phenodata <- grep("phenodata", infile, value=TRUE)

permufile <- grep("permu", infile, value=TRUE)

crossfile <- grep("cross", infile, value=TRUE)

popid <- scan(popidfile, what="integer", sep="\n")

cross <- scan(crossfile,what="character", sep="\n")

popdata<-c()

if (cross == "f2")
{
  popdata <- read.cross("csvs",
                       genfile=genodata,
                       phefile=phenodata,
                       na.strings=c("NA", "-"),
                       genotypes=c("1", "2", "3", "4", "5"),
                       )

  popdata <-jittermap(popdata)
} else if (cross == "bc" | cross == "rilsib" | cross == "rilself") {

  popdata <- read.cross("csvs",
                       genfile=genodata,
                       phefile=phenodata,
                       na.strings=c("NA", "-"),
                       genotypes=c("1", "2"),
                       )

  popdata<-jittermap(popdata)
}

if (cross == "rilself") {
    popdata<-convert2riself(popdata)
} else if (cross == "rilsib") {
    popdata<-convert2risib(popdata)
}

#calculates the qtl genotype probablity at
#the specififed step size and probability level
genotypetype <- c()

if (genoprobmethod == "Calculate") {
    popdata <- calc.genoprob(popdata,
                           step=stepsize,
                           error.prob=genoproblevel
                           )
    genotypetype<-c('prob')
} else if (genoprobmethod == "Simulate") {
    popdata <- sim.geno(popdata,
                      n.draws=drawsno,
                      step=stepsize,
                      error.prob=genoproblevel,
                      stepwidth="fixed"
                        )

    genotypetype <- c('draws')
}

cvterm <- scan(cvtermfile, what="character") #reads the cvterm

cv <- find.pheno(popdata, cvterm)#returns the col no. of the cvterm

permuvalues <- scan(permufile, what="character")

permuvalue1 <- permuvalues[1]
permuvalue2 <- permuvalues[2]
permu <- c()

if (is.logical(permuvalue1) == FALSE) {
  if (qtlmodel == "scanone") {
    if (userpermuvalue == 0 ) {
      popdataperm <- scanone(popdata,
                             pheno.col=cv,
                             model="normal",
                             method=qtlmethod
                             )

    } else if (userpermuvalue != 0) {
        popdataperm <- scanone(popdata,
                               pheno.col=cv,
                               model="normal",
                               n.perm = userpermuvalue,
                               method=qtlmethod
                               )

        permu <- summary(popdataperm, alpha=permuproblevel)
    }
  } else if (qtlmethod != "mr") {
    if (qtlmodel == "scantwo") {
      if (userpermuvalue == 0 ) {
        popdataperm <- scantwo(popdata,
                               pheno.col=cv,
                               model="normal",
                               method=qtlmethod
                               )
      } else if (userpermuvalue != 0) {
          popdataperm <- scantwo(popdata,
                                 pheno.col=cv,
                                 model="normal",
                                 n.perm=userpermuvalue,
                                 method=qtlmethod
                                 )

        permu <- summary(popdataperm, alpha=permuproblevel)

      }
    }
  }
}

##########set the LOD cut-off for singificant qtls ##############
LodThreshold <- c()

if(is.null(permu) == FALSE) {
  LodThreshold <- permu[1,1]
}
##########QTL EFFECTS ##############

chrlist <- c("chr1")

for (no in 2:12) {
    chr <- paste("chr", no, sep="")

    chrlist <- append(chrlist, chr)
}

chrdata <- paste(cvterm, popid, "chr1", sep="_")

chrtest <- c("chr1")

for (ch in chrlist) {
  if (ch=="chr1") {
    chrdata <- paste(cvterm, popid, ch, sep="_")
  } else {
    n <- paste(cvterm, popid, ch, sep="_")
    chrdata <- append(chrdata, n)
  }
}

chrno <- 1

datasummary <- c()
confidenceints <- c()
lodconfidenceints <- c()
QtlChrs <- c()
QtlPositions <- c()
QtlLods <- c()

for (i in chrdata) {
  filedata <- paste(cvterm, popid, chrno, sep="_")
  filedata <- paste(filedata,"txt",sep=".")

  i <- scanone(popdata,
               chr=chrno,
               pheno.col=cv,
               model = "normal",
               method= qtlmethod
               )

  position <- max(i,chr=chrno)

  p <- position[["pos"]]
  LodScore <- position[["lod"]]
  QtlChr <- levels(position[["chr"]])

      if ( is.null(LodThreshold)==FALSE ) {
          if (LodScore >=LodThreshold ) {
              QtlChrs <- append(QtlChrs, QtlChr)
              QtlLods <- append(QtlLods, LodScore)
              QtlPositions <- append(QtlPositions, round(p, 0))
            }
        }

  peakmarker <- find.marker(popdata, chr=chrno, pos=p)

  lodpeakmarker <- i[peakmarker, ]

  lodconfidenceint <- bayesint(i, chr=chrno, prob=0.95, expandtomarkers=TRUE)

  if (is.na(lodconfidenceint[peakmarker, ])){
      lodconfidenceint <- rbind(lodconfidenceint, lodpeakmarker)
    }

  peakmarker <- c(chrno, peakmarker)

  if (chrno==1) {
    datasummary <- i
    peakmarkers <- peakmarker
    lodconfidenceints <- lodconfidenceint
  }

  if (chrno > 1 ) {
      datasummary <- rbind(datasummary, i)
      peakmarkers <- rbind(peakmarkers, peakmarker)
      lodconfidenceints <- rbind(lodconfidenceints, lodconfidenceint)
  }

chrno <- chrno + 1;

}

##########QTL EFFECTS ##############
 ResultDrop <- c()
 ResultFull <- c()
 Effects <- c()

if (is.null(LodThreshold) == FALSE) {
    if ( max(QtlLods) >= LodThreshold ) {
        QtlObj <- makeqtl(popdata,
                          QtlChrs,
                          QtlPositions,
                          what=genotypetype
                          )

        QtlsNo <- length(QtlPositions)
        Eq <- c("y~")

        for (i in 1:QtlsNo) {
                q <- paste("Q", i, sep="")

                if (i==1) {
                    Eq <- paste(Eq, q, sep="")
                  } else if (i>1) {
                      Eq <- paste(Eq, q, sep="*")
                  }
              }

        QtlEffects <- try(fitqtl(popdata,
                                 pheno.col=cv,
                                 QtlObj,
                                 formula=Eq,
                                 method="hk",
                                 get.ests=TRUE
                                 )
                          )

        if(class(QtlEffects) != 'try-error') {

                ResultModel <- attr(QtlEffects, "formula")
                Effects     <- QtlEffects$ests$ests
                QtlLodAnova <- QtlEffects$lod
                ResultFull  <- QtlEffects$result.full
                ResultDrop  <- QtlEffects$result.drop

                if (is.numeric(Effects)) {
                    Effects <- round(Effects, 2)
                }

                if (is.numeric(ResultFull)) {
                    ResultFull <- round(ResultFull,2)
                }

                if (is.numeric(ResultDrop)) {
                    ResultDrop<-round(ResultDrop, 2)
                }
            }
    }
}

##########creating vectors for the outfiles##############

outfiles <- scan(file=outfile, what="character")

qtlfile           <- grep("qtl_summary", outfiles, value=TRUE)
peakmarkersfile   <- grep("peak_marker", outfiles, value=TRUE)
confidencelodfile <- grep("confidence", outfiles, value=TRUE)
QtlEffectsFile    <- grep("qtl_effects", outfiles, value=TRUE)
VariationFile     <- grep("explained_variation", outfiles, value=TRUE)

##### writing outputs to their respective files

write.table(datasummary,
            file=qtlfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(peakmarkers,
            file=peakmarkersfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(lodconfidenceints,
            file=confidencelodfile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

if (is.null(ResultDrop)==FALSE) {
  write.table(ResultDrop,
              file=VariationFile,
              sep="\t",
              col.names=NA,
              quote=FALSE,
              append=FALSE
              )
} else {
  if (is.null(ResultFull)==FALSE) {
      write.table(ResultFull,
              file=VariationFile,
              sep="\t",
              col.names=NA,
              quote=FALSE,
              append=FALSE
              )
    }
}

write.table(Effects,
            file=QtlEffectsFile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
            )

write.table(permu,
            file=permufile,
            sep="\t",
            col.names=NA,
            quote=FALSE,
            append=FALSE
                )

q(runLast = FALSE)


# refine_spillover.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

#' Refine spillover coefficients
#'
#' Refines spillover coefficients iteratively.
#'
#' @param marker.spillover.unco.untr List of two matrices, with regressions
#'     intercepts and coefficients, resulting from the initial spillover
#'     calculation in untransformed scale.
#' @param marker.spillover.unco.tran List of two matrices, with regressions
#'     intercepts and coefficients, resulting from the initial spillover
#'     calculation in transformed scale. Optional parameter used only in
#'     scatter plots, it can be \code{NULL}.
#' @param flow.gate List of vectors with ids of gated events per sample.
#' @param flow.control List with data and metadata of a set of controls.
#' @param asp List with AutoSpill parameters.
#'
#' @return List with four elements:
#'     \itemize{
#'         \item{Spillover matrix at final step.}
#'         \item{Compensation matrix at final step.}
#'         \item{Compensation error at final step, a list with four matrices:
#'             intercepts, coefficients, slopes, and skewness.}
#'         \item{Dataframe with convergence data.}
#'     }
#'
#' @references Roca \emph{et al}:
#'     AutoSpill: A method for calculating spillover coefficients to compensate
#'     or unmix high-parameter flow cytometry data.
#'     \emph{bioRxiv} 2020.06.29.177196;
#'     \href{https://doi.org/10.1101/2020.06.29.177196}{doi:10.1101/2020.06.29.177196}
#'     (2020).
#'
#' @seealso \code{\link{get.marker.spillover}}, \code{\link{gate.flow.data}},
#'     \code{\link{read.flow.control}}, and \code{\link{get.autospill.param}}.
#'
#' @export

refine.spillover <- function( marker.spillover.unco.untr,
    marker.spillover.unco.tran, flow.gate, flow.control, asp )
{
    # set initial values for iteration variables

    rs.convergence <- FALSE
    rs.exit <- FALSE

    rs.iter <- 0
    rs.iter.last <- FALSE
    rs.iter.width <- floor( log10( asp$rs.iter.max ) ) + 1

    rs.lambda <- asp$rs.lambda.coarse

    rs.delta <- -1.0
    rs.delta.threshold <- asp$rs.delta.threshold.untr

    rs.delta.history <- rep( -1, asp$rs.delta.history.n )

    rs.scale.untransformed <- TRUE

    rs.convergence.log <- data.frame(
        iter = numeric(),
        scale = character(),
        lambda = numeric(),
        delta = numeric(),
        delta.max = numeric(),
        delta.change = numeric(),
        stringsAsFactors = FALSE
    )

    # set initial values for spillover calculation

    spillover.curr <- diag( flow.control$marker.n )
    spillover.update <- marker.spillover.unco.untr$coef -
        diag( flow.control$marker.n )

    while ( ! rs.exit )
    {
        # update spillover matrix and calculate compensation matrix

        spillover.curr <- spillover.curr + spillover.update
        spillover.curr <- sweep( spillover.curr, 1,
            diag( spillover.curr ), "/" )

        compensation.curr <- solve( spillover.curr )

        spillover.curr.original <- spillover.curr
        rownames( spillover.curr.original ) <- flow.control$marker.original
        colnames( spillover.curr.original ) <- flow.control$marker.original

        compensation.curr.original <- compensation.curr
        rownames( compensation.curr.original ) <- flow.control$marker.original
        colnames( compensation.curr.original ) <- flow.control$marker.original

        if ( ( rs.iter == 0 && asp$rs.save.table.initial ) ||
            ( asp$rs.save.table.every > 0 &&
                    rs.iter %% asp$rs.save.table.every == 0 ) ||
            rs.iter.last )
        {
            # save spillover and compensation matrices

            if( ! is.null( asp$table.spillover.dir ) )
            {
                table.spillover.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$spillover.file.name ),
                    sprintf( "%s_%0*d.csv", asp$spillover.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( spillover.curr.original,
                    file = file.path( asp$table.spillover.dir,
                        table.spillover.file.name ) )
            }

            if( ! is.null( asp$table.compensation.dir ) )
            {
                table.compensation.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$compensation.file.name ),
                    sprintf( "%s_%0*d.csv", asp$compensation.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( compensation.curr.original,
                    file = file.path( asp$table.compensation.dir,
                        table.compensation.file.name ) )
            }

            # plot spillover and compensation matrices, by rows and columns
            # respectively

            if( ! is.null( asp$figure.spillover.dir ) )
            {
                figure.spillover.file.label <- ifelse( rs.iter.last, "",
                    sprintf( "_%0*d", rs.iter.width, rs.iter ) )

                plot.matrix( spillover.curr, TRUE, asp$figure.spillover.dir,
                    figure.spillover.file.label, flow.control, asp )
            }

            if( ! is.null( asp$figure.compensation.dir ) )
            {
                figure.compensation.file.label <- ifelse( rs.iter.last, "",
                    sprintf( "_%0*d", rs.iter.width, rs.iter ) )

                plot.matrix( compensation.curr, FALSE,
                    asp$figure.compensation.dir,
                    figure.compensation.file.label, flow.control, asp )
            }
        }

        # set uncompensated expresion data and spillover

        if ( rs.scale.untransformed ) {
            expr.data.unco <- flow.control$expr.data.untr
            marker.spillover.unco <- marker.spillover.unco.untr
        }
        else {
            expr.data.unco <- flow.control$expr.data.tran
            marker.spillover.unco <- marker.spillover.unco.tran
        }

        # get compensated expression data

        flow.set.comp <- lapply( flow.control$flow.set, compensate,
            compensation( spillover.curr.original ) )

        if ( ! rs.scale.untransformed )
            flow.set.comp <- lapply( flow.set.comp, transform,
                transformList( names( flow.control$transform ),
                    flow.control$transform ) )

        expr.data.comp <- get.flow.expression.data( flow.set.comp,
            flow.control )

        check.critical(
            identical( dimnames( expr.data.comp ),
                dimnames( expr.data.unco ) ),
            "internal error: inconsistent event or dye names in compensated data"
        )

        # get compensation error in compensated data

        if ( ( rs.iter == 0 && asp$rs.plot.figure.initial ) ||
            ( asp$rs.plot.figure.every > 0 &&
                    rs.iter %% asp$rs.plot.figure.every == 0 ) ||
            rs.iter.last )
        {
            plot.scatter.figure <- TRUE
            figure.scatter.file.label <- ifelse( rs.iter.last, "final",
                sprintf( "%0*d", rs.iter.width, rs.iter ) )
        }
        else
        {
            plot.scatter.figure <- FALSE
            figure.scatter.file.label <- NULL
        }

        compensation.error <- get.compensation.error(
            expr.data.unco, expr.data.comp, marker.spillover.unco,
            rs.scale.untransformed, plot.scatter.figure,
            figure.scatter.file.label, flow.gate, flow.control, asp
        )

        # get slope error and update delta variables

        slope.error <- compensation.error$slop - diag( flow.control$marker.n )

        rs.delta.prev <- rs.delta
        rs.delta <- sd( slope.error )

        rs.delta.max <- max( abs( slope.error ) )

        if ( rs.delta.prev >= 0 )
            rs.delta.history[ rs.iter %% asp$rs.delta.history.n + 1 ] <-
            rs.delta - rs.delta.prev
        else
            rs.delta.history[ rs.iter %% asp$rs.delta.history.n + 1 ] <- -1

        rs.delta.change <- mean( rs.delta.history )

        rs.convergence.log[ rs.iter + 1, ] <- list( rs.iter,
            ifelse( rs.scale.untransformed, "linear", "bi-exp" ),
            rs.lambda, rs.delta, rs.delta.max, rs.delta.change )

        if ( asp$verbose )
        {
            cat( sprintf(
                "iter %0*d, %s scale, lambda %.1f, delta %g, delta.max %g, delta.change %g\n",
                rs.iter.width, rs.iter,
                ifelse( rs.scale.untransformed, "linear", "bi-exp" ),
                rs.lambda, rs.delta, rs.delta.max, rs.delta.change ) )
        }

        if ( ( rs.iter == 0 && asp$rs.save.table.initial ) ||
                ( asp$rs.save.table.every > 0 &&
                        rs.iter %% asp$rs.save.table.every == 0 ) ||
                rs.iter.last )
        {
            # save and plot slope error

            if( ! is.null( asp$table.slope.error.dir ) )
            {
                table.slope.error.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$slope.error.file.name ),
                    sprintf( "%s_%0*d.csv", asp$slope.error.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( slope.error,
                    file = file.path( asp$table.slope.error.dir,
                        table.slope.error.file.name ) )
            }

            if( ! is.null( asp$figure.slope.error.dir ) )
            {
                figure.slope.error.file.name <- sprintf( "%s%s.png",
                    asp$slope.error.file.name,
                    ifelse( rs.iter.last, "",
                        sprintf( "_%0*d", rs.iter.width, rs.iter ) ) )

                plot.density.log( slope.error, "compensation error",
                    file.path( asp$figure.slope.error.dir,
                        figure.slope.error.file.name ),
                    asp )
            }

            # save and plot skewness

            if( ! is.null( asp$table.skewness.dir ) )
            {
                table.skewness.file.name <- ifelse( rs.iter.last,
                    sprintf( "%s.csv", asp$skewness.file.name ),
                    sprintf( "%s_%0*d.csv", asp$skewness.file.name,
                        rs.iter.width, rs.iter ) )

                write.csv( compensation.error$skew,
                    file = file.path( asp$table.skewness.dir,
                        table.skewness.file.name ) )
            }

            if( ! is.null( asp$figure.skewness.dir ) )
            {
                if ( ! is.null( flow.control$autof.marker.idx ) )
                    spillover.skewness <- compensation.error$skew[
                        - flow.control$autof.marker.idx,
                        - flow.control$autof.marker.idx ]
                else
                    spillover.skewness <- compensation.error$skew

                figure.skewness.file.name <- sprintf( "%s%s.png",
                    asp$skewness.file.name,
                    ifelse( rs.iter.last, "",
                        sprintf( "_%0*d", rs.iter.width, rs.iter ) ) )

                plot.density.log( spillover.skewness, "spillover skewness",
                    file.path( asp$figure.skewness.dir,
                        figure.skewness.file.name ),
                    asp )
            }
        }

        # update iteration variables

        if( rs.scale.untransformed && rs.delta.max < rs.delta.threshold )
        {
            # switch to bi-exponential scale and reset lambda and delta history
            rs.scale.untransformed <- FALSE
            rs.delta.threshold <- asp$rs.delta.threshold.tran
            rs.lambda <- asp$rs.lambda.coarse
            rs.delta <- -1.0
            rs.delta.history <- rep( -1, asp$rs.delta.history.n )
            rs.delta.change <- -1
        }

        if ( rs.delta.change > - asp$rs.delta.threshold.change &&
                rs.lambda == asp$rs.lambda.coarse )
        {
            # reduce lambda and reset delta history
            rs.lambda <- asp$rs.lambda.fine
            rs.delta <- -1.0
            rs.delta.history <- rep( -1, asp$rs.delta.history.n )
            rs.delta.change <- -1
        }

        rs.convergence <- ! rs.scale.untransformed &&
            ( rs.delta.max < rs.delta.threshold ||
                    rs.delta.change > - asp$rs.delta.threshold.change )

        rs.exit <- ( rs.convergence && rs.iter.last ) ||
            ( rs.delta.change > - asp$rs.delta.threshold.change &&
                    rs.scale.untransformed ) ||
            ( ! rs.convergence && rs.iter == asp$rs.iter.max ) ||
            rs.iter > asp$rs.iter.max

        rs.iter.last <- rs.convergence

        rs.iter <- rs.iter + 1

        # update spillover matrix

        spillover.update <- rs.lambda * ( slope.error %*% spillover.curr )
    }

    # save and plot convergence

    if ( ! is.null( asp$table.convergence.dir ) )
        write.csv( rs.convergence.log,
            file = file.path( asp$table.convergence.dir,
                sprintf( "%s.csv", asp$convergence.file.name ) ),
            row.names = FALSE )

    if ( ! is.null( asp$figure.convergence.dir ) )
        plot_convergence( rs.convergence.log, NULL, asp )

    # check convergence

    check.critical( rs.convergence,
        "no convergence in refinement of spillover matrix" )

    list(
        spillover = spillover.curr,
        compensation = compensation.curr,
        error = compensation.error,
        convergence = rs.convergence.log
    )
}


#' Arithmetic Operators
#'
#' Some binary arithmetic operations for shaqs.  All operations are
#' vector-shaq or shaq-vector, but not shaq-shaq.  See details section for more
#' information.
#'
#' @details
#' For binary operations involving two shaqs, they must be distributed
#' \emph{identically}.
#'
#' @section Communication:
#' Each operation is completely local.
#'
#' @param e1,e2
#' A shaq or a numeric vector.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' y = ranshaq(runif, 10, 3)
#'
#' x + y
#' x / 2
#' y + 1
#'
#' finalize()
#' }
#'
#' @name arithmetic
#' @rdname arithmetic
NULL

bounds.check = function(shaq, vec)
{
  if (length(vec) != 1)
    comm.stop("invalid shaq-vector operation: vector must be length 1")
}

shaqshaq.check = function(s1, s2)
{
  if (nrow(s1) != nrow(s1)  ||  ncol(s1) != ncol(s2))
    stop("non-conformable arrays")

  if (nrow(Data(s1)) != nrow(Data(s2))  ||  ncol(Data(s1)) != ncol(Data(s2)))
    stop("shaqs not distributed identically")
}

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) + Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) + e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    e2 + e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) - Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) - e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    bounds.check(e2, e1)

    DATA(e2) = e1 - Data(e2)
    e2
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) * Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) * e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    e2 * e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) / Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) / e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    bounds.check(e2, e1)

    DATA(e2) = e1 / Data(e2)
    e2
  }
)


## lines that SDSS tracks

speclines <- c(3727.092,3729.875,3869.857,3890.151,3971.123,4102.892,4341.684,4364.435,
4686.991,4862.683,4960.295,5008.240,5413.024,5578.888,6302.046,6313.806,
6365.535,6549.859,6564.614,6585.268,6718.294,6732.678,7137.757)

names(speclines) <- c("O_II_3725","O_II_3727","Ne_III_3868","H_epsilon",
"Ne_III_3970","H_delta","H_gamma","O_III_4363",
"He_II_4685","H_beta","O_III_4959","O_III_5007",
"He_II_5411","O_I_5577","O_I_6300","S_III_6312",
"O_I_6363","N_II_6548","H_alpha","N_II_6583",
"S_II_6716","S_II_6730","Ar_III_7135")

## major emission lines

lambda_f <- c(3727.092,3729.875,3869.857,3971.123,4960.295,
              5008.240,6302.046,6365.535,6549.859,6585.268,
              6718.294,6732.678)
names(lambda_f) <- c("oii_3727","oii_3729","neiii_3869",
                     "neiii_3970","oiii_4959","oiii_5007",
                     "oi_6300","oi_6363","nii_6548","nii_6584",
                     "sii_6717","sii_6730")

lambda_balmer <- c(3890.151,3970.072,4102.892,4341.684,4862.683,6564.614)
names(lambda_balmer) <- c("h_zeta","h_epsilon","h_delta","h_gamma","h_beta","h_alpha")

lambda_em <- sort(c(lambda_f, lambda_balmer))

## forbidden & recombination lines that are usually weak

lambda_weak <- c(4364.435, 4686.991, 5413.024, 5578.888, 6313.806, 7137.757)
names(lambda_weak) <- c("oiii_4363", "heii_4685", "heii_5411", "oi_5577", "siii_6312", "ariii_7135")

## legacy support for reading an sdss spectrum in a csv file

readsdsspec <- function(fname, z, dname="spectra") {
  gdat <- read.csv(file.path(dname,fname), header=TRUE)
  gdat$lambda <- gdat$lambda/(1+z)
  gdat$flux[gdat$ivar==0] <- NA
  gdat$flux[gdat$flux== -9999.] <- NA
  gdat$ivar[gdat$ivar==0] <- NA
  gdat$ivar[gdat$ivar== -9999.] <- NA
  gdat
}

regrid <- function(lambda.out, lib) {
    lambda.in <- lib$lambda
    nc <- ncol(lib)
    lib.out <- matrix(NA, length(lambda.out), nc)
    lib.out[,1] <- lambda.out
    for (i in 2:nc) {
        lib.out[,i] <- approx(lambda.in, lib[,i], xout=lambda.out)$y
    }
    colnames(lib.out) <- colnames(lib)
    data.frame(lib.out)
}

closest <- function(x, vec) which.min(abs(x-vec))

vactoair <- function(lambda) lambda/(1+2.735182e-4+131.4182/lambda^2+2.76249E8/lambda^4)

airtovac <- function(lambda) {
  s2 <- (1e4/lambda)^2
  fac <- 1 + 5.792105e-2/(238.0185-s2)+1.67917e-3/(57.362-s2)
  lambda*fac
}

## Galactic extinction correction from Fitzpatrick (1998): http://arxiv.org/abs/astro-ph/9809387v1
## This is spline fit portion valid from near-UV to near-IR and R=3.1

elaw <- function(lambda, ebv) {
  il <- c(0,0.377,0.820,1.667,1.828,2.141,2.433,3.704,3.846)
  al <- c(0,0.265,0.829,2.688,3.055,3.806,4.315,6.265,6.591)
  fai <- splinefun(il,al)
  10^(0.4*fai(10000/lambda)*ebv)
}

fitz <- function(lambda, tauv) {
  il <- c(0,0.377,0.820,1.667,1.828,2.141,2.433,3.704,3.846)
  al <- c(0,0.265,0.829,2.688,3.055,3.806,4.315,6.265,6.591)
  fai <- splinefun(il,al)
  exp(-fai(10000/lambda)*tauv)
}

## Calzetti et al. (2000-2001) extinction curve

calzetti.orig <- function(lambda, tauv) {
  lambda <- lambda/10000
  kl <- numeric(length(lambda))
  lb <- lambda < 0.63
  kl[lb] <- 1+(2.659/4.05)*(-2.151285+1.509/lambda[lb]-0.198/(lambda[lb]^2)+0.011/(lambda[lb]^3))
  kl[!lb] <- 1+(2.659/4.05)*(-1.8561715+1.04/lambda[!lb])
  exp(-kl*tauv)
}

## approximation to above using a single function

calzetti <- function(lambda, tauv) {
  ls <- lambda/10000
  k <- -0.2688+0.7958/ls-4.785e-2/(ls^2)-6.033e-3/(ls^3)+7.163e-04/(ls^4)
  exp(-k*tauv)
}

## modified calzetti relation from Salim et al. 2018

calzetti_mod <- function(lambda, tauv, delta=0) {
  ls <- 5500./lambda
  kl <- -0.101771 + 0.549882 * ls + 1.393039 * ls^2 - 1.098615 * ls^3 + 0.260618 * ls^4
  kl <- kl * ls^delta
  exp(-tauv * kl)
}

## galactic extinction law of Cardelli, Clayton, & Mathis 1989, ApJ 345, 245

ccm <- function(lambda, tauv, rv=3.1) {
  x <- 10000/lambda
  y <- x-1.82

  kl <- numeric(length(lambda))
  a <- numeric(length(lambda))
  b <- numeric(length(lambda))

  lb <- (x <= 1.1)

  a[lb] <- 0.574*x[lb]^1.61
  b[lb] <- -0.527*x[lb]^1.61

  a[!lb] <- 1 + 0.17699*y[!lb] - 0.50447*y[!lb]^2 - 0.02427*y[!lb]^3 + 0.72085*y[!lb]^4 +
            0.01979*y[!lb]^5 - 0.7753*y[!lb]^6  + 0.32999*y[!lb]^7
  b[!lb] <- 1.41338*y[!lb] + 2.28305*y[!lb]^2 + 1.07233*y[!lb]^3 - 5.38434*y[!lb]^4 -
            0.62251*y[!lb]^5 + 5.30260*y[!lb]^6 - 2.09002*y[!lb]^7
  kl <- a + b/rv
  exp(-tauv * kl)
}

simplescreen <- function(lambda, tauv, delta = 0.) {
    exp(-tauv*(5500./lambda)^(0.7 + delta))
}

## make a fake emission line library

make_emlib <- function(lambda_em, vdisp_em, loglambda, isok, sthresh=5000) {
    vdisp_p <- vdisp_em/(299792.458*log(10))
    n_em <- length(lambda_em)
    nl <- length(loglambda)
    x_em <- matrix(0, nl, n_em)
    for (i in 1:n_em) {
        x_em[,i] <- dnorm(loglambda, mean=log10(lambda_em[i]), sd=vdisp_p)
    }
    in_em <- which(colSums(x_em[isok, ]) >= sthresh)
    x_em <- x_em[,in_em]/10000
    list(x_em=x_em, in_em=in_em)
}

blur.lib <- function(lib.ssp, vdisp, dlogl=1.e-4) {
  c <- 299792.458
  sigma.p <- vdisp/(dlogl*c*log(10))
  kw <- max(round(6*sigma.p), 3)
  if ((kw%%2)==0) kw <- kw+1
  k0 <- (kw %/% 2) + 1
  kernel <- dnorm((1:kw)-k0, sd=sigma.p)
  kernel <- kernel/sum(kernel)
  sp.st <- filter(lib.ssp[,-1], kernel, method="convolution")
  as.matrix(sp.st)
}

dblineratios <- function(db, dthresh=3) {
    o3hbeta <- log10(db$oiii_flux) - log10(db$h_beta_flux)
    o3hbeta[(db$oiii_flux/db$oiii_flux_err < dthresh) | (db$h_beta_flux/db$h_beta_flux_err < dthresh)] <- NA
    n2halpha <- log10(db$nii_6584_flux) -log10(db$h_alpha_flux)
    n2halpha[(db$nii_6584_flux/db$nii_6584_flux_err < dthresh) | (db$h_alpha_flux/db$h_alpha_flux_err < dthresh)] <- NA
    db <- cbind(db, o3hbeta, n2halpha)
    return(db)
}

## galaxy class by emission line strengths, from Kewley et al. 2006 and Schawinski et al. 2007
## only using n2halpha and o3hbeta for now.

emclass <- function(db=NULL, snthresh=3, PLOT=TRUE) {

  if (!is.null(db)) {
    attach(db)
    class <- as.factor(rep("no em.",length(n2halpha)))
    levels(class) <- c("no em.", "SF", "Comp.", "AGN", "LINER", "EL")

    #starforming

    class[(o3hbeta <= 0.61/(n2halpha-0.05)+1.3) & (n2halpha <= 0.05)] <- "SF"

    # composite

    class[((o3hbeta > 0.61/(n2halpha-0.05)+1.3) | (n2halpha > 0.05)) &
    (o3hbeta <= .61/(n2halpha-0.47)+1.19)] <- "Comp."

    # Seyfert == AGN

    class[(o3hbeta > .61/(n2halpha-0.47)+1.19) & (o3hbeta > 1.05*n2halpha+0.45)] <- "AGN"
    class[(n2halpha > 0.47) & (o3hbeta > 1.05*n2halpha+0.45)] <- "AGN"

    # Liners

    class[(o3hbeta > .61/(n2halpha-0.47)+1.19) & (o3hbeta <= 1.05*n2halpha+0.45)] <- "LINER"
    class[(n2halpha > 0.47) & (o3hbeta <= 1.05*n2halpha+0.45)] <- "LINER"

    # weak emission line

    class[((is.na(n2halpha) | is.na(o3hbeta)) & ((oii_flux/oii_flux_err > snthresh) |
    (oiii_flux/oiii_flux_err > snthresh) |
    (h_alpha_flux/h_alpha_flux_err > snthresh) |
    (nii_6584_flux/nii_6584_flux_err > snthresh)))] <- "EL"

    class <- as.factor(class)
    if (PLOT) {
      plot(n2halpha, o3hbeta, pch=20, col=unclass(class))
    }
    detach(db)
  }

  if (PLOT) {

    #kauffmann et al. curve

    curve(1.3+.61/(x-0.05),from= -1.5,to= -0.2,lty=2,add=TRUE)

    #kewley 2001 curve

    curve(.61/(x-0.47)+1.19, from= -1.5, to= 0.22, add=TRUE)

    #Shawinski et al. curve

    curve(0.45+1.05*x, from=-0.2, to= 1, add=TRUE)
  }

  if (!is.null(db)) return(class)
}

## flux ratio at the 4000 A discontinuity. Note 20130908 - weights have been dropped; improves
## correlation with MPA-JHU pipeline estimates. Also corrected lambda weighting

## d4000_n index

d4000n <- function(lambda, flux, ivar, wl4000=c(3850,3950,4000,4100)) {
    wl4000 <- airtovac(wl4000)
    ni <- which(lambda>=wl4000[3] & lambda<=wl4000[4])
    di <- which(lambda>=wl4000[1] & lambda<=wl4000[2])
    dln <- diff(lambda)[ni]
    dld <- diff(lambda)[di]
    fn <- flux[ni]
    if (length(which(!is.na(fn))) < 2) {
        return(list(d4000_n=NA, d4000_n_err=NA))
    }
    if (any(is.na(fn))) {
        fn <- approx(lambda[ni], fn, xout=lambda[ni])$y
    }
    fd <- flux[di]
    if (length(which(!is.na(fd)))<2) {
        return(list(d4000_n=NA, d4000_n_err=NA))
    }
    if (any(is.na(fd))) {
        fd <- approx(lambda[di], fd, xout=lambda[di])$y
    }
    num <- sum(fn*dln*(lambda[ni]^2))
    vn <- sum((dln^2)*(lambda[ni]^4)/ivar[ni])
    den <- sum(fd*dld*(lambda[di]^2))
    vd <- sum((dld^2)*(lambda[di]^4)/ivar[di])
    d4000_n <- num/den
    d4000_n_err <- sqrt(num^2/den^2*(vn/den^2+vd/num^2))
    list(d4000_n=d4000_n, d4000_n_err=d4000_n_err)
}

## lick indices

lickew <- function(lambda, flux, ivar, which.index=1) {

  wl <- t(matrix(airtovac(c(4083.5,4122.25,4041.6,4079.75,4128.5,4161,
                                      4142.125,4177.125,4080.125,4117.625,4244.125,4284.125,
                                      4142.125,4177.125,4083.875,4096.375,4244.125,4284.125,
                                      4222.250,4234.750,4211.000,4219.750,4241.000,4251.000,
                                      4281.375,4316.375,4266.375,4282.625,4318.875,4335.125,
                                      4369.125,4420.375,4359.125,4370.375,4442.875,4455.375,
                                      4452.125,4474.625,4445.875,4454.625,4477.125,4492.125,
                                      4514.250,4559.250,4504.250,4514.250,4560.500,4579.250,
                                      4634.000,4720.250,4611.500,4630.250,4742.750,4756.500,
                                      4758.500,4800.000,4742.750,4756.500,4827.875,4847.875,
                                      5069.125,5134.125,4895.125,4957.625,5301.125,5366.125,
                                      5154.125,5196.625,4895.125,4957.625,5301.125,5366.125,
                                      5160.125,5192.625,5142.625,5161.375,5191.375,5206.375,
                                      5245.650,5285.650,5233.150,5248.150,5285.650,5318.150,
                                      5312.125,5352.125,5304.625,5315.875,5353.375,5363.375,
                                      5387.500,5415.000,5376.250,5387.500,5415.000,5425.000,
                                      5445.000,5600.000,5420.000,5442.000,5630.000,5655.000,
                                      5696.625,5720.375,5672.875,5696.625,5722.875,5736.625,
                                      5776.625,5796.625,5765.375,5775.375,5797.875,5811.625,
                                      5876.875,5909.375,5860.625,5875.625,5922.125,5948.125,
                                      5936.625,5994.125,5816.625,5849.125,6038.625,6103.625,
                                      6189.625,6272.125,6066.625,6141.625,6372.625,6415.125,
                                      6357.500,6401.750,6342.125,6356.500,6408.500,6429.750,
                                      6775.000,6900.000,6510.000,6539.250,7017.000,7064.000)),6,24))
  inames <- c("HdeltaA","CN_1","CN_2","Ca4227","G4300",
              "Fe4383","Ca4455","Fe4531","Fe4668","bTiO",
              "Mg_1","Mg_2","Mg_b","Fe5270","Fe5335",
              "Fe5406","aTiO","Fe5709","Fe5782","Na_D",
              "TiO_1","TiO_2","CaH1", "CaH2")
  imag <- rep(FALSE, length(inames))
  imag[c(2,3,11,12,21,22)] <- TRUE
  imag <- imag[which.index]
  wl <- matrix(wl[which.index,], length(which.index), 6)
  ni <- nrow(wl)
  ew <- rep(NA,ni)
  ew_sd <- rep(NA,ni)
  df <- data.frame(lambda=lambda, flux=flux, ivar=ivar)
  for (j in 1:ni) {
    pb <- which(lambda>=wl[j,1] & lambda<=wl[j,2])
    bsb <- which(lambda>=wl[j,3] & lambda<=wl[j,4])
    rsb <- which(lambda>=wl[j,5] & lambda<=wl[j,6])
    if (all(is.na(flux[pb])) || all(is.na(flux[bsb])) || all(is.na(flux[rsb]))) next
    cfit <- lm(flux~lambda, data=df, subset=union(bsb,rsb))
    cont <- predict(cfit, newdata=df[pb,], interval="prediction", level=0.7)
    sd.cont <- (cont[,3]-cont[,2])/2
    dl <- (diff(lambda))[pb]
    num <- flux[pb]
    den <- cont[,1]
    if (imag[j]) {
      ewd <- sum(num/den*dl)
      ew[j] <- -2.5*log10(ewd/(wl[j,2]-wl[j,1]))
      ew_sd[j] <- sqrt(sum(num^2/den^2*(1/(ivar[pb]*num^2)+sd.cont^2/den^2)*dl^2))/
      ewd*2.5/log(10)
    } else {
      ew[j] <- sum((1-num/den)*dl)
      ew_sd[j] <- sqrt(sum(num^2/den^2*(1/(ivar[pb]*num^2)+sd.cont^2/den^2)*dl^2))
    }
  }
  in_names <- inames[which.index]
  in_err_names <- paste(in_names, "err", sep="_")
  retdat <- c(ew, ew_sd)
  names(retdat) <- c(in_names, in_err_names)
  retdat
}