# A set of "pluggable" R functions for automated model fitting of glm models to presence/absence data #
#
# Modified 12-2-09 to:  remove categorical covariates from consideration if they only contain one level
#                       ID factor variables based on "categorical" prefix and look for tifs in subdir
#                       Give progress reports
#                       write large output tif files in blocks to alleviate memory issues
#                       various bug fixes
#
#
# Modified 3-4-09 to use a list object for passing of arguements and data
#

# Libraries required to run this program #
#   PresenceAbsence - for ROC plots
#   XML - for XML i/o
#   rgdal - for geotiff i/o
#   sp - used by rdgal library
#   raster for geotiff o
options(error=NULL)

fit.mars.fct <- function(ma.name,tif.dir=NULL,output.dir=NULL,response.col="^response.binary",make.p.tif=T,make.binary.tif=T,
      mars.degree=1,mars.penalty=2,responseCurveForm=NULL,debug.mode=T,script.name="mars.r",opt.methods=2,save.model=TRUE,UnitTest=FALSE,MESS=FALSE){
    # This function fits a stepwise GLM model to presence-absence data.
    # written by Alan Swanson, 2008-2009
    # # Maintained and edited by Marian Talbert September 2010-
    # Arguements.
    # ma.name: is the name of a .csv file with a model array.  full path must be included unless it is in the current
    #  R working directory # THIS FILE CAN NOW INCLUDE AN OPTIONAL COLUMN OF SITE WEIGHTS WHICH MUST BE LABELED "site.weights"
    # tif.dir: is the directory containing geotiffs for each covariate.  only required if geotiffs output of the
    #   response surface is requested #    # cov.list.name: is the name of a text file with the names of covariates to be included in models (one per line).
    # output.dir: is the directory that output files will be stored in.  if not given, files will go to the current working directory.
    # response.col: column number of the model array containing a binary 0/1 response.  all other columns will be considered explanatory variables.
    # make.p.tif: T if a geotiff of the response surface is desired.
    # make.binary.tif: T if a geotiff of the response surface is desired.
    # simp.method: model simplification method.  valid methods include: "AIC" and "BIC". NOT CURRENTLY FUNCTIONAL
    # debug.mode: if T, output is directed to the console during the run.  also, a pdf is generated which contains response curve plots and perspective plots
    #    showing the effects of interactions deemed important.  if F, output is diverted to a text file and the console is kept clear
    #    except for final output of an xml file.  in either case, a set of standard output files are created in the output directory.
    #

    # Value:
    # returns nothing but generates a number of output files in the directory
    # "output.dir" named above.  These output files consist of:
    #
    # glm_output.txt:  a text file with fairly detailed results of the final model.
    # glm_output.xml:  an xml-formatted text file with results from the final model.
    # glm_response_curves.xml:  an xml-formatted text file with response curves for
    #   each covariate in the final model.
    # glm_prob_map.tif:  a geotiff of the response surface
    # glm_bin_map.tif:  a geotiff of the binary response surface.  threhold is based on the roc curve at the point where sensitivity=specificity.
    # glm_log.txt:   a file containing text output diverted from the console when debug.mode=F
    # glm_auc_plot.jpg:  a jpg file of a ROC plot.
    # glm_response_curves.pdf:  an pdf file with response curves for
    #   each covariate in the final model and perspective plots showing the effect of interactions deemed significant.
    #   only produced when debug.mode=T
    # #  seed=NULL                                 # sets a seed for the algorithm, any inegeger is acceptable
    #  opt.methods=2                             # sets the method used for threshold optimization used in the
    #                                            # the evaluation statistics module
    #  save.model=FALSE                          # whether the model will be used to later produce tifs
    # when debug.mode is true, these filenames will include a number in them so that they will not overwrite preexisting files. eg brt_1_output.txt.
    #
    times <- as.data.frame(matrix(NA,nrow=7,ncol=1,dimnames=list(c("start","read data","model fit",
            "model summary","response curves","tif output","done"),c("time"))))
    times[1,1] <- unclass(Sys.time())
    t0 <- unclass(Sys.time())
    #simp.method <- match.arg(simp.method)

    out <- list(
      input=list(ma.name=ma.name,
                 tif.dir=tif.dir,
                 output.dir=output.dir,
                 response.col=response.col,
                 make.p.tif=make.p.tif,
                 make.binary.tif=make.binary.tif,
                 site.weights=NULL,
                 save.model=save.model,
                 mars.degree=mars.degree,
                 mars.penalty=mars.penalty,
                 model.type="stepwise with pruning",
                 model.source.file=script.name,
                 model.fitting.subset=NULL, # not used.
                 model.family="binomial",
                 run.time=paste(c(format(Sys.time(),"%Y-%m-%d"),format(Sys.time(),"%H:%M:%S")),collapse="T"),
                 sig.test="chi-squared anova p-value",
                 MESS=MESS),
      dat = list(missing.libs=NULL,
                 output.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tif.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tif.ind=NULL,
                 tif.names=NULL,
                 bname=NULL,
                 bad.factor.covs=NULL, # factorchange
                 ma=list( status=c(exists=F,readable=F),
                          dims=c(NA,NA),
                          n.pres=c(all=NA,complete=NA,subset=NA),
                          n.abs=c(all=NA,complete=NA,subset=NA),
                          ratio=NA,
                          resp.name=NULL,
                          train.weights=NULL,
                          test.weights=NULL,
                          train.xy=NULL,
                          test.xy=NULL,
                          factor.levels=NA,
                          used.covs=NULL,
                          ma=NULL,
                          ma.subset=NULL,
                          ma.test=NULL)),
      mods=list(final.mod=NULL,
                r.curves=NULL,
                tif.output=list(prob=NULL,bin=NULL),
                auc.output=NULL,
                interactions=NULL,  # not used #
                summary=NULL),
      time=list(strt=unclass(Sys.time()),end=NULL),
      error.mssg=list(NULL),
      ec=0    # error count #
      )

      # load libaries #
      out <- check.libs(list("PresenceAbsence","rgdal","XML","sp","survival","mda","raster","tcltk2","foreign","ade4"),out)

      # exit program now if there are missing libraries #
      if(!is.null(out$error.mssg[[1]])){
          cat(saveXML(mars.to.xml(out),indent=T),'\n')
          return()
          }

    # check output dir #
    out$dat$output.dir <- check.dir(output.dir)
    if(out$dat$output.dir$writable==F) {out$ec<-out$ec+1
              out$error.mssg[[out$ec]] <- paste("ERROR: output directory",output.dir,"is not writable")
              out$dat$output.dir$dname <- getwd()
              }

    # generate a filename for output #
          if(debug.mode==T){
            outfile <- paste(bname<-paste(out$dat$output.dir$dname,"/mars_",n<-1,sep=""),"_output.txt",sep="")
            while(file.access(outfile)==0) outfile<-paste(bname<-paste(out$dat$output.dir$dname,"/mars_",n<-n+1,sep=""),"_output.txt",sep="")
            capture.output(cat("temp"),file=outfile) # reserve the new basename #
            } else bname<-paste(out$dat$output.dir$dname,"/mars",sep="")
            out$dat$bname <- bname

    # sink console output to log file #
    if(!debug.mode) {sink(logname <- paste(bname,"_log.txt",sep=""));on.exit(sink)} else logname<-NULL
    options(warn=1)

    # check tif dir #
        # check tif dir #
    if(!is.null(tif.dir)){
      out$dat$tif.dir <- check.dir(tif.dir)
      if(out$dat$tif.dir$readable==F & (out$input$make.binary.tif | out$input$make.p.tif)) {
                out$ec<-out$ec+1
                out$error.mssg[[out$ec]] <- paste("ERROR: tif directory",tif.dir,"is not readable")
                if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
              cat(saveXML(brt.to.xml(out),indent=T),'\n')
              return()
              }
            }

    # find .tif files in tif dir #
    if(out$dat$tif.dir$readable)  out$dat$tif.names <- list.files(out$dat$tif.dir$dname,pattern=".tif",recursive=T)

    # check for model array #
    out$input$ma.name <- check.dir(out$input$ma.name)$dname

    if(UnitTest!=FALSE) options(warn=2)
    out <- read.ma(out)
    if(UnitTest==1) return(out)

    # exit program now if there are errors in the input data #
    if(!is.null(out$error.mssg[[1]])){
          if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
          cat(saveXML(mars.to.xml(out),indent=T),'\n')
          return()
          }

    cat("\nbegin processing of model array:",out$input$ma.name,"\n")
    cat("\nfile basename set to:",out$dat$bname,"\n")
    assign("out",out,envir=.GlobalEnv)
    if(!debug.mode) {sink();cat("Progress:20%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("20%\n")}  ### print time
    ##############################################################################################################
    #  Begin model fitting #
    ##############################################################################################################

    # Fit null GLM and run stepwise, then print results #
    cat("\n","Fitting MARS model","\n")
    flush.console()

    fit <- mars.glm(data=out$dat$ma$ma, mars.x=c(2:ncol(out$dat$ma$ma)), mars.y=1, mars.degree=out$input$mars.degree, family=out$input$model.family,
          site.weights=out$dat$ma$train.weights, penalty=out$input$mars.penalty)

    out$mods$final.mod <- fit

  out$mods$final.mod$contributions$var<-names(out$dat$ma$ma)[-1]

    assign("out",out,envir=.GlobalEnv)
    t3 <- unclass(Sys.time())
    fit_contribs <- try(mars.contribs(fit))
    if(class(fit_contribs)=="try-error"){
          if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
          out$ec<-out$ec+1
          out$error.mssg[[out$ec]]<- paste("Error summarizing MARS model:",fit_contribs)
          cat(saveXML(mars.to.xml(out),indent=T),'\n')
          return()
          }

    x<-fit_contribs$deviance.table
    x <- x[x[,2]!=0,]
    x <- x[order(x[,4]),]
    row.names(x) <- x[,1]
    x$df <- -1*x$df
    x <- x[,-1]

     txt0 <- paste("\nMARS Model Results\n","\n","Data:\n",ma.name,"\n","\n\t n(pres)=",
        out$dat$ma$n.pres[2],"\n\t n(abs)=",out$dat$ma$n.abs[2],"\n\t n covariates considered=",length(out$dat$ma$used.covs),
        "\n",
        "\n   total time for model fitting=",round((unclass(Sys.time())-t0)/60,2),"min\n",sep="")

    capture.output(cat(txt0),file=paste(bname,"_output.txt",sep=""))

    cat("\n","Finished with MARS","\n")
    cat("Summary of Model:","\n")
    print(out$mods$summary <- x)
    if(!is.null(out$dat$bad.factor.cols)){
        cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n\n")
        }
    cat("\n","Storing output...","\n","\n")
    #flush.console()
    capture.output(cat("\n\nSummary of Model:\n"),file=paste(bname,"_output.txt",sep=""),append=TRUE)
    capture.output(print(out$mods$summary),file=paste(bname,"_output.txt",sep=""),append=TRUE)
    if(!is.null(out$dat$bad.factor.cols)){
        capture.output(cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n"),
            file=paste(bname,"_output.txt",sep=""),append=T)
        }

    if(!debug.mode) {sink();cat("Progress:40%\n");flush.console();sink(logname,append=T)} else cat("40%\n")

    ##############################################################################################################
    #  Begin model output #
    ##############################################################################################################

    # Store .jpg ROC plot #
      auc.output <- make.auc.plot.jpg(out$dat$ma$ma,pred=mars.predict(fit,out$dat$ma$ma)$prediction[,1],
      plotname=paste(bname,"_auc_plot.jpg",sep=""),modelname="MARS",opt.methods=opt.methods,
            weight=out$dat$ma$train.weights,out=out)
      out$mods$auc.output<-auc.output

    if(!debug.mode) {sink();cat("Progress:70%\n");flush.console();sink(logname,append=T)} else cat("70%\n")

    # Response curves #

    if(is.null(responseCurveForm)){
    responseCurveForm<-0}

    if(debug.mode | responseCurveForm=="pdf"){
        nvar <- nrow(out$mods$summary)
        pcol <- min(ceiling(sqrt(nvar)),4)
        prow <- min(ceiling(nvar/pcol),3)
        r.curves <- try(mars.plot(fit,plot.layout=c(prow,pcol),file.name=paste(bname,"_response_curves.pdf",sep="")))

        } else r.curves<-try(mars.plot(fit,plot.it=F))

        if(class(r.curves)!="try-error") {
            out$mods$r.curves <- r.curves
                } else {
            out$ec<-out$ec+1
            out$error.mssg[[out$ec]] <- paste("ERROR: problem fitting response curves",r.curves)
            }

        pred.fct<-pred.mars

     assign("out",out,envir=.GlobalEnv)

 save.image(paste(output.dir,"modelWorkspace",sep="\\"))
    t4 <- unclass(Sys.time())
    cat("\nfinished with final model summarization, t=",round(t4-t3,2),"sec\n");flush.console()
    if(!debug.mode) {sink();cat("Progress:80%\n");flush.console();sink(logname,append=T)} else cat("70%\n")
    # Make .tif of predictions #

    if(out$input$make.p.tif==T | out$input$make.binary.tif==T){
        if((n.var <- nrow(out$mods$summary))<1){
            mssg <- "Error producing geotiff output:  null model selected by stepwise procedure - pointless to make maps"
            class(mssg)<-"try-error"
            } else {
            cat("\nproducing prediction maps...","\n","\n");flush.console()
            mssg <- try(proc.tiff(model=out$mods$final.mod,vnames=names(out$dat$ma$ma)[-1],
                tif.dir=out$dat$tif.dir$dname,filenames=out$dat$tif.ind,pred.fct=pred.mars,factor.levels=out$dat$ma$factor.levels,make.binary.tif=make.binary.tif,
                thresh=out$mods$auc.output$thresh,make.p.tif=make.p.tif,outfile.p=paste(out$dat$bname,"_prob_map.tif",sep=""),
                outfile.bin=paste(out$dat$bname,"_bin_map.tif",sep=""),tsize=50.0,NAval=-3000,
                fnames=out$dat$tif.names,logname=logname,out=out))     #"brt.prob.map.tif"
            }

        if(class(mssg)=="try-error"){
          if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
          out$ec<-out$ec+1
          out$error.mssg[[out$ec]] <- paste("Error producing prediction maps:",mssg)
          cat(saveXML(mars.to.xml(out),indent=T),'\n')
          return()
        }  else {
            if(make.p.tif) out$mods$tif.output$prob <- paste(out$dat$bname,"_prob_map.tif",sep="")
            if(make.binary.tif) out$mods$tif.output$bin <- paste(out$dat$bname,"_bin_map.tif",sep="")
            t5 <- unclass(Sys.time())
            cat("\nfinished with prediction maps, t=",round(t5-t4,2),"sec\n");flush.console()
          }
        }
    if(!debug.mode) {sink();cat("Progress:90%\n");flush.console();sink(logname,append=T)} else cat("90%\n")

     # Evaluation Statistics on Test Data#

    if(!is.null(out$dat$ma$ma.test)) Eval.Stat<-EvaluationStats(out,thresh=auc.output$thresh,train=out$dat$ma$ma,
          train.pred=mars.predict(fit,out$dat$ma$ma)$prediction[,1],opt.methods)

    # Write summaries to xml #
    if(debug.mode) assign("out",out,envir=.GlobalEnv)
    doc <- mars.to.xml(out)

    cat(paste("\ntotal time=",round((unclass(Sys.time())-t0)/60,2),"min\n\n\n",sep=""))
    if(!debug.mode) {
        sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))
        cat("Progress:100%\n");flush.console()
        #cat(saveXML(doc,indent=T),'\n')
        } else #unlink(outfile)
    capture.output(cat(saveXML(doc,indent=T)),file=paste(out$dat$bname,"_output.xml",sep=""))
    if(debug.mode) assign("fit",out$mods$final.mod,envir=.GlobalEnv)
    invisible(out)
    }
################################################################################
###########          End fit.mars.fct       ####################################

pred.mars <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictionss.
    y <- rep(NA,nrow(x))
    y[complete.cases(x)] <- as.vector(mars.predict(model,x[complete.cases(x),])$prediction[,1])

#if(sum(is.na(x))/dim(x)[2]!=sum(is.na(y)))
#h<-is.na(x)
#h<-apply(h,1,sum)
#h=h/35
#f<-is.na(y)
#which((h-f)!=0,arr.ind=TRUE)
#b<-cbind(x[which((h-f)!=0,arr.ind=TRUE),],y[which((h-f)!=0,arr.ind=TRUE)])

#which(is.na(y)
    # encode missing values as -1.
    y[is.na(y)]<- NaN

    # return predictions.
    return(y)
    }

logit <- function(x) 1/(1+exp(-x))

file_path_as_absolute <- function (x){
    if (!file.exists(epath <- path.expand(x)))
        stop(gettextf("file '%s' does not exist", x), domain = NA)
    cwd <- getwd()
    on.exit(setwd(cwd))
    if (file_test("-d", epath)) {
        setwd(epath)
        getwd()
    }
    else {
        setwd(dirname(epath))
        file.path(getwd(), basename(epath))
    }
}
#file_path_as_absolute(".")

mars.to.xml <- function(out){
    require(XML)
    schema.http="http://www.w3.org/2001/XMLSchema-instance"
    schema.fname="file:/Users/isfs2/Desktop/Source/2008-04-09/src/gov/nasa/gsfc/quickmap/ModelBuilder/modelRun_output_v2.xsd"
    xml.out <- newXMLDoc()
    mr <- newXMLNode("modelRunOutput",doc=xml.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))#,parent=xml.out
    sm <- newXMLNode("singleModel",parent=mr)
    bg <- newXMLNode("background",parent=sm)
        newXMLNode("mdsName",out$input$ma.name,parent=bg)
        newXMLNode("runDate",out$input$run.time,parent=bg)
        lc <- newXMLNode("layersConsidered",parent=bg)#, parent = xml.out)
        kids <- lapply(paste(out$dat$tif.dir$dname,"/",out$dat$tif.names,sep=""),function(x) newXMLNode("layer", x))
        addChildren(lc, kids)
    mo <- newXMLNode("modelOutput",parent=sm)
        newXMLNode("modelType",out$input$model.type,parent=mo)
        newXMLNode("modelSourceFile",out$input$model.source.file,parent=mo)
        newXMLNode("devianceExplained",out$mods$auc.output$pct_dev_exp,parent=mo,attrs=list(type="percentage"))
        newXMLNode("nativeOutput",paste(out$dat$bname,"_output.txt",sep=""),parent=mo)
        newXMLNode("binaryOutputFile",out$mods$tif.output[[2]],parent=mo)
        newXMLNode("probOutputFile",out$mods$tif.output[[1]],parent=mo)
        newXMLNode("auc",out$mods$auc.output$auc,parent=mo)
        newXMLNode("rocGraphic",out$mods$auc.output$plotname,parent=mo)
        newXMLNode("rocThresh",out$mods$auc.output$thresh,parent=mo)
        newXMLNode("modelDeviance",out$mods$auc.output$dev_fit,parent=mo)
        newXMLNode("nullDeviance",out$mods$auc.output$null_dev,parent=mo)
        if(is.null(out$mods$r.curves)) rc.name <- NULL else rc.name <- paste(out$dat$bname,"_response_curves.xml",sep="")
        newXMLNode("responsePlotsFile",rc.name,parent=mo)
        newXMLNode("significanceDescription",out$input$sig.test,parent=mo)
        mfp <- newXMLNode("modelFitParmas",parent=mo)
            newXMLNode("marsDegree",out$input$mars.degree,parent=mfp)
            newXMLNode("marsPenalty",out$input$mars.penalty,parent=mfp)

        sv <- newXMLNode("significantVariables",parent=mo)
        if(!is.null(out$mods$summary)) {
            t.table <- out$mods$summary#$coefficients
            names(t.table)[3]<-"significanceMeasurement"
            for(i in 1:nrow(t.table)){
                x <- newXMLNode("sigVar",parent=sv)
                newXMLNode(name="name", row.names(t.table)[i],parent=x)
                kids <- lapply(1:ncol(t.table),function(j) newXMLNode(name=names(t.table)[j], t.table[i,j]))
                addChildren(x, kids)
                }
            }

    if(!is.null(out$mods$r.curves)){
        r.curves <-  out$mods$r.curves
        factor.levels <- out$dat$ma$factor.levels
        rc.out <- newXMLDoc()
        root <- newXMLNode("responseCurves",doc=rc.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))
        for(i in 1:length(r.curves$names)){
            if(!is.na(f.index<-match(r.curves$names[i],names(factor.levels)))){
                  vartype <- "factor"} else vartype="continuous"
            x <- newXMLNode("responseCurve",attrs=list(covariate=r.curves$names[i],type=vartype),parent=root)
            kids <- lapply(1:length(r.curves$preds[[i]]),function(j){
                    newXMLNode(name="responsePt",parent=x,.children=list(
                        newXMLNode(name="explanatory",as.character(r.curves$preds[[i]])[j]),
                        newXMLNode(name="response",r.curves$resp[[i]][j])))})
            addChildren(x, kids)
            }
        saveXML(rc.out,rc.name,indent=T)

        }
    if(!is.null(out$error.mssg[[1]])) {
        kids <- lapply(out$error.mssg,function(j) newXMLNode(name="error",j))
        addChildren(mo,kids)
        }
    return(xml.out)
    }

get.cov.names <- function(model){
    return(attr(terms(formula(model)),"term.labels"))
    }

check.dir <- function(dname){
    if(is.null(dname)) dname <- getwd()
    dname <- gsub("[\\]","/",dname)
    end.char <- substr(dname,nchar(dname),nchar(dname))
    if(end.char == "/") dname <- substr(dname,1,nchar(dname)-1)
    exist <- suppressWarnings(as.numeric(file.access(dname,mode=0))==0) # -1 if bad, 0 if ok #
    if(exist) dname <- file_path_as_absolute(dname)
    readable <- suppressWarnings(as.numeric(file.access(dname,mode=4))==0) # -1 if bad, 0 if ok #
    writable <- suppressWarnings(as.numeric(file.access(dname,mode=2))==0) # -1 if bad, 0 if ok #
    return(list(dname=dname,exist=exist,readable=readable,writable=writable))
    }

get.image.info <- function(image.names){
    # this function creates a data.frame with summary image info for a set of images #
    require(rgdal)
    n.images <- length(image.names)

    full.names <- image.names
    out <- data.frame(image=full.names,available=rep(F,n.images),size=rep(NA,n.images),
        type=factor(rep("unk",n.images),levels=c("asc","envi","tif","unk")))
    out$type[grep(".tif",image.names)]<-"tif"
    out$type[grep(".asc",image.names)]<-"asc"
    for(i in 1:n.images){
        if(out$type[i]=="tif"){
            x <-try(GDAL.open(full.names[1],read.only=T))
            suppressMessages(try(GDAL.close(x)))
            if(class(x)!="try-error") out$available[i]<-T
            x<-try(file.info(full.names[i]))
        } else {
            x<-try(file.info(full.names[i]))
            if(!is.na(x$size)) out$available[i]<-T
        }
        if(out$available[i]==T){
            out$size[i]<-x$size
            if(out$type[i]=="unk"){
                # if extension not known, look for envi .hdr file in same directory #
                if(file.access(paste(file_path_sans_ext(full.names[i]),".hdr",sep=""))==0)
                    out$type[i]<-"envi"
                }
        }
    }
    return(out)
}

###########################################################################################
#  The following functions are from Elith et al.
###########################################################################################

"calc.deviance" <-
function(obs.values, fitted.values, weights = rep(1,length(obs.values)), family=family, calc.mean = TRUE)
{
# j. leathwick/j. elith
#
# version 2.1 - 5th Sept 2005
#
# function to calculate deviance given two vectors of raw and fitted values
# requires a family argument which is set to binomial by default
#
#

if (length(obs.values) != length(fitted.values))
   stop("observations and predictions must be of equal length")

y_i <- obs.values

u_i <- fitted.values

if (family == "binomial" | family == "bernoulli") {

   deviance.contribs <- (y_i * log(u_i)) + ((1-y_i) * log(1 - u_i))
   deviance <- -2 * sum(deviance.contribs * weights)

}

if (family == "poisson" | family == "Poisson") {

    deviance.contribs <- ifelse(y_i == 0, 0, (y_i * log(y_i/u_i))) - (y_i - u_i)
    deviance <- 2 * sum(deviance.contribs * weights)

}

if (family == "laplace") {
    deviance <- sum(abs(y_i - u_i))
    }

if (family == "gaussian") {
    deviance <- sum((y_i - u_i) * (y_i - u_i))
    }

if (calc.mean) deviance <- deviance/length(obs.values)

return(deviance)

}

"calibration" <-
function(obs, preds, family = family)
{
#
# j elith/j leathwick 17th March 2005
# calculates calibration statistics for either binomial or count data
# but the family argument must be specified for the latter
# a conditional test for the latter will catch most failures to specify
# the family
#

if (family == "bernoulli") family <- "binomial"
pred.range <- max(preds) - min(preds)
if(pred.range > 1.2 & family == "binomial") {
print(paste("range of response variable is ", round(pred.range, 2)), sep = "", quote = F)
print("check family specification", quote = F)
return()
}
if(family == "binomial") {
pred <- preds + 1e-005
pred[pred >= 1] <- 0.99999
mod <- glm(obs ~ log((pred)/(1 - (pred))), family = binomial)
lp <- log((pred)/(1 - (pred)))
a0b1 <- glm(obs ~ offset(lp) - 1, family = binomial)
miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
ab1 <- glm(obs ~ offset(lp), family = binomial)
miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
}
if(family == "poisson") {
mod <- glm(obs ~ log(preds), family = poisson)
lp <- log(preds)
a0b1 <- glm(obs ~ offset(lp) - 1, family = poisson)
miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
ab1 <- glm(obs ~ offset(lp), family = poisson)
miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
}
calibration.result <- c(mod$coef, miller1, miller2, miller3)
names(calibration.result) <- c("intercept", "slope", "testa0b1", "testa0|b1", "testb1|a")
return(calibration.result)
}

"mars.contribs" <-
function (mars.glm.object,sp.no = 1, verbose = TRUE)
{

# j leathwick/j elith August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# takes a mars/glm model and uses the updated mars export table
# stored as the second list item from mars.binomial
# assessing the contribution of the fitted functions,
# amalgamating terms for variables as required
#
# amended 29/9/04 to pass original mars model details
# and to return f-statistics
#
# amended 7th January to accommodate any glm model family
#
# modified 050609 by aks to output a numeric deviance table #

  mars.detail <- mars.glm.object$mars.call
  pred.names <- mars.detail$predictor.base.names #get the names from the original data
  n.preds <- length(pred.names)

  spp.names <- mars.detail$y.names
  family <- mars.detail$family

  m.table <- mars.glm.object$mars.table[-1,]
  m.table$names1 <- as.character(m.table$names1)   #convert from a factor

  x.data <- as.data.frame(eval(mars.glm.object$basis.functions))
  y.data <- as.data.frame(eval(mars.glm.object$y.values))

  assign("x.data", x.data, pos = 1)
  assign("y.data", y.data, pos = 1)
  assign("sp.no", sp.no, pos = 1)

  glm.model <- glm(y.data[,sp.no] ~ .,data = x.data,family = family)

  print(paste("performing backwards drops for mars/glm model for",
       spp.names[sp.no]),quote=F)

  n.bfs <- length(m.table[,1])

  delta.deviance <- rep(0,n.preds)
  df <- rep(0,n.preds)
  signif <- rep(0,n.preds)

  for (i in 1:n.preds) {   #start at two because first line is the constant

    # look for variable names in the table matching those in the var list

    var.nos <- grep(as.character(pred.names[i]),m.table$names1)

    #drop.list stores numbers of basis functions to be dropped
    if (length(var.nos) > 0) {
      drop.list <- 0 - var.nos
      x.data.new <- x.data[,drop.list]
      assign("x.data.new",x.data.new,pos=1)

      if (verbose) {
 	  print(paste("Dropping ",pred.names[i],"...",sep=""),
	             quote=FALSE)
      }
      x.data.new<-as.data.frame(x.data.new)
      if(dim(x.data.new)[2]==0){
           new.model <- glm(y.data[,sp.no] ~ 1, family = family)
           }else new.model <- glm(y.data[,sp.no] ~ ., data=x.data.new, family = family)

      comparison <- anova(glm.model,new.model,test="Chisq")

      df[i] <- comparison[2,3]
      delta.deviance[i] <- zapsmall(comparison[2,4],4)
      signif[i] <- zapsmall(comparison[2,5],6)
    }

  }

  rm(x.data,y.data,sp.no,pos=1)  # tidy up temporary files

  #deviance.table <- as.data.frame(cbind(pred.names,delta.deviance,df,signif))
  #names(deviance.table) <- c("variable","delta_dev","deg. free.","p-value")
  deviance.table <- data.frame(variable=pred.names,delta_dev=delta.deviance,df=df,p_value=signif)#aks
  return(list(mars.call=mars.detail,deviance.table=deviance.table))
}

"mars.cv" <-
function (mars.glm.object, nk = 10, sp.no = 1, prev.stratify = F)
{
#
# j. leathwick/j. elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# function to perform k-fold cross validation
# with full model perturbation for each subset
#
# requires mda library from Cran
# requires functions mw and calibration
#
# takes a mars/glm object produced by mars.glm
# and first assesses the full model, and then
# randomly subsets the dataset into nk folds and drops
# each subset in turn, fitting on remaining data
# and predicting for withheld data
#
# caters for both single species and community models via the argument sp.no
# for the first, sp.no can be left on its default of 1
# for community models, sp.no can be varied from 1 to n.spp
#
# modified 29/9/04 to
#   1. return mars analysis details for audit trail
#   2. calculate roc and calibration on subsets as well as full data
#      returning the mean and se of the ROC scores
#      and the mean calibration statistics
#
# modified 8/10/04 to add prevalence stratification
# modified 7th January to test for binomial family and return if not
#
# updated 15th March to cater for both binomial and poisson families
#
# updated 16th June 2005 to calculate residual deviance
#

  data <- mars.glm.object$mars.call$dataframe    #get the dataframe name
  dataframe.name <- deparse(substitute(data))

  data <- as.data.frame(eval(parse(text=data)))   #and now the data
  n.cases <- nrow(data)

  mars.call <- mars.glm.object$mars.call          #and the mars call details
  mars.x <- mars.call$mars.x
  mars.y <- mars.call$mars.y
  mars.degree <- mars.call$degree
  mars.penalty <- mars.call$penalty
  family <- mars.call$family
  site.weights <- eval(mars.glm.object$weights$site.weights)

  n.spp <- length(mars.y)

  if (sp.no > n.spp) {
    print(paste("the value specified for sp.no of",sp.no),quote=F)
    print(paste("exceeds the total number of species, which is ",n.spp),quote=F)
    return()
  }

  xdat <- as.data.frame(data[,mars.x])
  xdat <- mars.new.dataframe(xdat)[[1]]
  ydat <- mars.glm.object$y.values[,sp.no]
  target.sp <- names(data)[mars.y[sp.no]]

  if (prev.stratify) {
    presence.mask <- ydat == 1
    absence.mask <- ydat == 0
    n.pres <- sum(presence.mask)
    n.abs <- sum(absence.mask)
  }

  print(paste("Calculating ROC and calibration from full model for",target.sp),quote=F)

  u_i <- mars.glm.object$fitted.values[,sp.no]
  y_i <- ydat

  if (family == "binomial") {
    full.resid.deviance <- calc.deviance(y_i,u_i, weights = site.weights, family="binomial")
    full.test <- roc(y_i, u_i)
    full.calib <- calibration(y_i, u_i)
  }

  if (family=="poisson") {
    full.resid.deviance <- calc.deviance(y_i,u_i, weights = site.weights, family="poisson")
    full.test <- cor(y_i, u_i)
    full.calib <- calibration(y_i, u_i, family = "poisson")
  }

# set up for results storage

  subset.test <- rep(0,nk)
  subset.calib <- as.data.frame(matrix(0,ncol=5,nrow=nk))
  names(subset.calib) <- c("intercept","slope","test1","test2","test3")
  subset.resid.deviance <- rep(0,nk)

# now setup for withholding random subsets

  pred.values <- rep(0, n.cases)
  fitted.values <- rep(0, n.cases)

  if (prev.stratify) {

    selector <- rep(0,n.cases)

#create a vector of randomised numbers and feed into presences

    temp <- rep(seq(1, nk, by = 1), length = n.pres)
    temp <- temp[order(runif(n.pres, 1, 100))]
    selector[presence.mask] <- temp

# and then do the same for absences

    temp <- rep(seq(1, nk, by = 1), length = n.abs)
    temp <- temp[order(runif(n.abs, 1, 100))]
    selector[absence.mask] <- temp

  }
  else {  #otherwise make them random with respect to presence/absence

    selector <- rep(seq(1, nk, by = 1), length = n.cases)
    selector <- selector[order(runif(n.cases, 1, 100))]
  }

  print("", quote = FALSE)
  print("Creating predictions for subsets...", quote = F)

  for (i in 1:nk) {
    cat(i," ")
    model.mask <- selector != i  #used to fit model on majority of data
    pred.mask <- selector == i   #used to identify the with-held subset
    assign("species.subset", ydat[model.mask], pos = 1)
    assign("predictor.subset", xdat[model.mask, ], pos = 1)

    # fit new mars model

    mars.object <- mars(y = species.subset, x = predictor.subset,
      degree = mars.degree, penalty = mars.penalty)

    # and extract basis functions

    n.bfs <- length(mars.object$selected.terms)
    bf.data <- as.data.frame(mars.object$x)
    names(bf.data) <- paste("bf",1:n.bfs,sep="")
    assign("bf.data", bf.data, pos=1)

    # then fit a binomial model to them

    mars.binomial <- glm(species.subset ~ .,data=bf.data[,-1], family= family, maxit = 100)

    pred.basis.functions <- as.data.frame(mda:::model.matrix.mars(mars.object,
      xdat[pred.mask, ]))

    #now name the bfs to match the approach used in mars.binomial

    names(pred.basis.functions) <- paste("bf",1:n.bfs,sep="")

    # and form predictions for them and evaluate performance

    fitted.values[pred.mask] <- predict(mars.binomial,
      pred.basis.functions, type = "response")

    y_i <- ydat[pred.mask]
    u_i <- fitted.values[pred.mask]
    weights.subset <- site.weights[pred.mask]

    if (family == "binomial") {
      subset.resid.deviance[i] <- calc.deviance(y_i,u_i,weights = weights.subset, family="binomial")
      subset.test[i] <- roc(y_i,u_i)
      subset.calib[i,] <- calibration(y_i, u_i)
    }

    if (family=="poisson"){
      subset.resid.deviance[i] <- calc.deviance(y_i,u_i,weights = weights.subset, family="poisson")
      subset.test[i] <- cor(y_i, u_i)
      subset.calib[i,] <- calibration(y_i, u_i, family = family)
    }
  }

  cat("","\n")

# tidy up temporary files

  rm(species.subset,predictor.subset,bf.data,pos=1)

# and assemble results for return

#  mars.detail <- list(dataframe = dataframe.name,
#    x = mars.x, x.names = names(xdat),
#    y = mars.y, y.names = names(data)[mars.y],
#    target.sp = target.sp, degree=mars.degree, penalty = mars.penalty, family = family)

  y_i <- ydat
  u_i <- fitted.values

  if (family=="binomial") {
    cv.resid.deviance <- calc.deviance(y_i,u_i,weights = site.weights, family="binomial")
    cv.test <- roc(y_i, u_i)
    cv.calib <- calibration(y_i, u_i)
  }

  if (family=="poisson"){
    cv.resid.deviance <- calc.deviance(y_i,u_i,weights = site.weights, family="poisson")
    cv.test <- cor(y_i, u_i)
    cv.calib <- calibration(y_i, u_i, family = "poisson")
  }

  subset.test.mean <- mean(subset.test)
  subset.test.se <- sqrt(var(subset.test))/sqrt(nk)

  subset.test <- list(test.scores = subset.test, subset.test.mean = subset.test.mean,
    subset.test.se = subset.test.se)

  subset.calib.mean <- apply(subset.calib[,c(1:2)],2,mean)
  names(subset.calib.mean) <- names(subset.calib)[c(1:2)] #mean only of parameters

  subset.calib <- list(subset.calib = subset.calib,
    subset.calib.mean = subset.calib.mean)

  subset.deviance.mean <- mean(subset.resid.deviance)
  subset.deviance.se <- sqrt(var(subset.resid.deviance))/sqrt(nk)

  subset.deviance <- list(subset.deviances = subset.resid.deviance, subset.deviance.mean = subset.deviance.mean,
    subset.deviance.se = subset.deviance.se)

  return(list(mars.call = mars.call, full.resid.deviance = full.resid.deviance,
    full.test = full.test, full.calib = full.calib, pooled.deviance = cv.resid.deviance, pooled.test = cv.test,
    pooled.calib = cv.calib,subset.deviance = subset.deviance, subset.test = subset.test, subset.calib = subset.calib))
}

"mars.export" <-
function (object,lineage)
{
#
# j leathwick/j elith August 2006
#
# takes a mars model fitted using library mda
# and extracts the basis functions and their
# coefficients, returning them as a table
# caters for models with degree up to 2
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1

  which <- object$selected.terms
  nterms <- length(which)
  nspp <- ncol(eval(object$call$y))
  dir <- object$factor
  cut <- object$cuts
  var.names <- dimnames(object$factor)[[2]]
  p <- length(var.names)
  coefs <- as.data.frame(object$coefficients)
  names(coefs) <- names(eval(object$call$y))

# setup storage for results

  names1 <- rep("null", length = nterms)
  types1 <- rep("null", length = nterms)
  levels1 <- rep("null", length = nterms)
  signs1 <- rep(0, length = nterms)
  cuts1 <- rep(0, length = nterms)

  names2 <- rep("null", length = nterms)
  types2 <- rep("null", length = nterms)
  levels2 <- rep("null", length = nterms)
  signs2 <- rep(0, length = nterms)
  cuts2 <- rep(0, length = nterms)
  names1[1] <- "constant"
  signs1[1] <- 1

# now cycle through the terms
if(nterms>1){
  for (i in seq(2, nterms)) {
    j <- which[i]
      term.count = 1
      for (k in 1:p) {
        if (dir[j, k] != 0) {
          if (term.count == 1) {
            n <- match(var.names[k],lineage$full.name)
            names1[i] <- lineage$base.name[n] #var.names[k]
            types1[i] <- lineage$type[n]
            levels1[i] <- lineage$level[n]
            signs1[i] <- dir[j, k]
            cuts1[i] <- cut[j, k]
            term.count <- term.count + 1
          }
          else {
            names2[i] <- var.names[k]
            n <- match(var.names[k],lineage$full.name)
            names2[i] <- lineage$base.name[n] #var.names[k]
            types2[i] <- lineage$type[n]
            levels2[i] <- lineage$level[n]
            signs2[i] <- dir[j, k]
            cuts2[i] <- cut[j, k]
          }
        }
      }
    }
    }
  mars.export.table <- data.frame(names1, types1, levels1, signs1, cuts1,
       names2, types2, levels2, signs2, cuts2, coefs)

  return(mars.export.table)
}

"mars.glm" <-
function (data,                         # the input data frame
  mars.x,                               # column numbers of the predictors
  mars.y,                               # column number(s) of the response variable(s)
  mars.degree = 1,                      # level of interactions - 1 = zero, 2 = 1st order, etc
  site.weights = rep(1, nrow(data)),    # one weight per site
  spp.weights = rep(1,length(mars.y)),  # one wieght per species
  penalty = 2,                          # the default penaly for a mars model
  family =family)                  # the family for the glm model
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# calculates a mars/glm object in which basis functions are calculated
# using an initial mars model with single or multiple responses
# data for individual species are then fitted as glms using the
# common set of mars basis functions with results returned as a list
#
# takes as input a dataset and args selecting x and y variables, and degree of interaction
# along with site and species weights, the CV penalty, and the glm family argument
# the latter would normally be one of "binomial" or "poisson" - "gaussian" could be used
# but in this case the model shouldn't differ from that fitted using mars on its own
#
# requires mda and leathwick/elith's mars.export
#
# modified 3/11/04 to store information on glm phase convergence
# and with number of iterations raised to 100 to encourage convergence for low prevalence species
# modified 4/11/04 to accommodate observation weights in both mars and glm steps
# modified 12/04 to accommodate non-binomial families
# modified 11/05 to accommodate factor variables
# these are done as 0/1 dummy variables in a new dataframe
# created using mars.new.dataframe

  require(mda)

  n.spp <- length(mars.y)

# setup input data and assign to position one

  dataframe.name <- deparse(substitute(data))  # get the dataframe name

  xdat <- as.data.frame(eval(data[, mars.x]))                 #form the temporary datasets
  predictor.base.names <- names(xdat)

# create the new dataframe with dummy vars for factor predictors
  xdat <- mars.new.dataframe(xdat)
  lineage <- xdat[[2]]   # tracks which variables have had dummy's created
  xdat <- xdat[[1]]
  predictor.dummy.names <- names(xdat)

  ydat <- as.data.frame(eval(data[, mars.y]))
  names(ydat) <- names(data)[mars.y]

  assign("xdat", xdat, pos = 1)               #and assign them for later use
  assign("ydat", ydat, pos = 1)

# create storage space for glm model results

  n.cases <- nrow(xdat)

  fitted.values <- matrix(0,ncol = n.spp, nrow = n.cases)
  model.residuals <- matrix(0,ncol = n.spp, nrow = n.cases)
  null.deviances <- rep(0,n.spp)
  residual.deviances <- rep(0,n.spp)
  null.dfs <- rep(0,n.spp)
  residual.dfs <- rep(0,n.spp)
  converged <- rep(TRUE,n.spp)

# fit the mars model and extract the basis functions

  cat("fitting initial mars model for",n.spp,"responses","\n")
  cat("followed by a glm model with a family of",family,"\n")

  mars.object <- mars(x = xdat, y = ydat, degree = mars.degree, w = site.weights,
       wp = spp.weights, penalty = penalty)
  if(length(mars.object$coefficients)==1) stop("MARS has fit the null model (intercept only) \n new predictors are required")
  bf.data <- as.data.frame(eval(mars.object$x))
  n.bfs <- ncol(bf.data)
  bf.names <- paste("bf", 1:n.bfs, sep = "")
  names(bf.data) <- bf.names
  bf.data <- as.data.frame(bf.data[,-1])

  m.table <- as.data.frame(mars.export(mars.object,lineage))
  names(m.table)[(10 + 1):(10 + n.spp)] <- names(ydat)

  p.values <- matrix(0, ncol = n.spp, nrow = n.bfs)
  rownames(p.values) <- paste("bf", 1:n.bfs, sep = "")
  colnames(p.values) <- names(ydat)

# now cycle through the species fitting glm models

  cat("fitting glms for individual responses","\n")

  for (i in 1:n.spp) {

    cat(names(ydat)[i],"\n")
    model.glm <- glm(ydat[, i] ~ ., data = bf.data, weights = site.weights,
  	  family = family, maxit = 100)

# update the coefficients and other results

    # then match names and insert as appropriate
    m.table[ , i + 10] <- 0   					# set all values to zero
    m.table[ , i + 10] <- model.glm$coefficients  	      # update all the constant
    sum.table <- summary(model.glm)$coefficients
    p.values[,i] <- sum.table[,4]
    fitted.values[,i] <- model.glm$fitted
    model.residuals[,i] <- resid(model.glm)
    null.deviances[i] <- model.glm$null.deviance
    residual.deviances[i] <- model.glm$deviance
    null.dfs[i] <- model.glm$df.null
    residual.dfs[i] <- model.glm$df.residual
    converged[i] <- model.glm$converged
  }

# now assemble data to be returned

  fitted.values <- as.data.frame(fitted.values)
  names(fitted.values) <- names(ydat)

  model.residuals <- as.data.frame(model.residuals)
  names(model.residuals) <- names(ydat)

  deviances <- data.frame(names(ydat),null.deviances,null.dfs,residual.deviances,residual.dfs,converged)
  names(deviances) <- c("species","null.dev","null.df","resid.dev","resid.df","converged")

  weights = list(site.weights = site.weights, spp.weights = spp.weights)

  mars.detail <- list(dataframe = dataframe.name, mars.x = mars.x,
    predictor.base.names = predictor.base.names, predictor.dummy.names = predictor.dummy.names,
    mars.y = mars.y, y.names = names(ydat), degree=mars.degree, penalty = penalty,
    family = family)

  rm(xdat,ydat,pos=1)           #finally, clean up the temporary dataframes

  return(list(mars.table = m.table, basis.functions = bf.data, y.values = ydat,
    fitted.values = fitted.values, residuals = model.residuals, weights = weights, deviances = deviances,
    p.values = p.values, mars.call = mars.detail,mars.object=mars.object))
}

"mars.new.dataframe" <-
function (input.data)
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# takes an input data frame and checks for factor variables
# converting these to dummy variables, one each for each factor level
# returning it for use with mars.glm so that factor vars can be included
# in a mars analysis
#

  if (!is.data.frame(input.data)) {
    print("input data must be a dataframe..",quote = FALSE)
    return()
  }

  n <- 1
  for (i in 1:ncol(input.data)) {  #first transfer the vector variables
    if (is.vector(input.data[,i])) {
      if (n == 1) {
        output.data <- as.data.frame(input.data[,i])
        names.list <- names(input.data)[i]
        var.type <- "vector"
        factor.level <- "na"
      }
      else {
        output.data[,n] <- input.data[,i]
        names.list <- c(names.list,names(input.data)[i])
        var.type <- c(var.type,"vector")
        factor.level <- c(factor.level,"na")
      }
      names(output.data)[n] <- names(input.data)[i]
      n <- n + 1
    }
  }

  for (i in 1:ncol(input.data)) {  # and then the factor variables
    if (is.factor(input.data[,i])) {
      temp.table <- summary(input.data[,i])
      for (j in 1:length(temp.table)) {
        names.list <- c(names.list,names(input.data)[i])
        var.type <- c(var.type,"factor")
        factor.level <- c(factor.level,names(temp.table)[j])
        output.data[,n] <- ifelse(input.data[,i] == names(temp.table)[j],1,0)
        names(output.data)[n] <- paste(names(input.data)[i],".",names(temp.table)[j],sep="")
        n <- n + 1
      }
    }
  }

  lineage <- data.frame(names(output.data),names.list,var.type,factor.level)
  for (i in 1:4) lineage[,i] <- as.character(lineage[,i])
  names(lineage) <- c("full.name","base.name","type","level")

  return(list(dataframe = output.data, lineage = lineage))
}

"mars.plot" <-
function (mars.glm.object,  #the input mars object
   sp.no = 0,               # the species number for multi-response models
   plot.rug=T,              # plot a rug of deciles
   plot.layout = c(3,4),    # the plot layout to use
   file.name = NA,          # giving a file name will send results to a pdf
   plot.it=T)               # option for making curves but no plots (aks)
{

# j leathwick/j elith August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# requires mars.export of leathwick/elith
#
# takes a mars or mars/glm model and either
# creates a mars export table (vanilla mars object)
# and works from this or uses the updated mars export table
# stored as the first list item from mars.binomial
# plotting out the fitted functions, amalgamating terms
# for variables and naming the pages as required
#
# caters for multispecies mars models by successively plotting
# all species unless a value other than zero is given for sp.no
#
# modified by aks 050609 to only open one plot window and use the record=T option.

  max.plots <- plot.layout[1] * plot.layout[2]
  if(plot.it){ #aks
      if (is.na(file.name)) {
        use.windows = TRUE
        windows(width = 11, height = 8, record=T) #AKS
        par(mfrow = plot.layout) #AKS
               }
      else {
        use.windows = FALSE
        pdf(file=file.name,width = 11, height=8)
        par(mfrow = plot.layout) #AKS
      }
  } else use.windows = FALSE

  if (class(mars.glm.object) == "mars") {  #then we have a mars object
    mars.binomial = FALSE
    model <- mars.glm.object
    xdat <- eval(model$call$x)
    Y <- as.data.frame(eval(model$call$y))
    n.env <- ncol(xdat)
    m.table <- mars.export(mars.glm.object)
  }
  else {
    mars.binomial = TRUE

    dat <- mars.glm.object$mars.call$dataframe
    mars.x <- mars.glm.object$mars.call$mars.x
    xdat <- as.data.frame(eval(parse(text=dat)))
    xdat <- xdat[,mars.x]

    m.table <- mars.glm.object[[1]]

  }

  n.bfs <- length(m.table[,1])
  n.spp <- length(m.table[1,]) - 10
  r.curves <- list(names=NULL,preds=list(),resp=list()) #aks
  spp.names <- names(m.table)[(10+1):(10+n.spp)]

  if (sp.no == 0) {
    wanted.species <- seq(1:n.spp)
  }
  else {
    wanted.species <- sp.no
  }

  xrange <- matrix(0,nrow = 2,ncol = ncol(xdat))
  factor.filter <- rep(FALSE,ncol(xdat))
  for (i in 1:ncol(xdat)) factor.filter[i] <- is.vector(xdat[,i])

  if(sum(factor.filter>1)) {
  xrange[,factor.filter] <- sapply(xdat[,factor.filter], range)
  } else  xrange[,factor.filter]<-range(xdat[,factor.filter])

  for (i in wanted.species) {
    n.pages <- 1
    plotit <- rep(TRUE, n.bfs)
    print(paste("plotting responses for ",spp.names[i]),quote=F)
    nplots <- 0
    cntr <- 1 #aks
    for (j in 2:n.bfs) {
      if (m.table$names2[j] == "null") {
        if (plotit[j]) {
          varno <- pmatch(as.character(m.table$names1[j]),
          names(xdat))
          if (factor.filter[varno]) {
            Xi <- seq(xrange[1, varno], xrange[2, varno],
               length = 100)
            bf <- pmax(0, m.table$signs1[j] * (Xi - m.table$cuts1[j]))
            bf <- bf * m.table[j, i + 10]
            bf <- bf - mean(bf)
          }
          else {
            factor.table <- as.data.frame(table(xdat[,varno]))
            names(factor.table) <- c("levels","coefficients")
            factor.table$coefficients <- 0
            level.no <- match(m.table$levels1[j],factor.table$levels)
            factor.table$coefficients[level.no] <- m.table[j, i + 10]
          }
          if (j < n.bfs) {
            for (k in ((j + 1):n.bfs)) {
              if (m.table$names1[j] == m.table$names1[k] & m.table$names2[k] == "null") {
                    if (factor.filter[varno]) {
                      bf.add <- pmax(0, m.table$signs1[k] *
                          (Xi - m.table$cuts1[k]))
                      bf.add <- bf.add * m.table[k, i + 10]
                      bf <- bf + bf.add
                    }
                    else {
                      level.no <- match(m.table$levels1[k],factor.table$levels)
                      factor.table$coefficients[level.no] <- m.table[k, i + 10]
                    }
                    plotit[k] <- FALSE
              }
            }
          }
          #if (nplots == 0) { #AKS
#            if (use.windows) windows(width = 11, height = 8)
#              par(mfrow = plot.layout)
#            }
            if (factor.filter[varno]) {
              if(plot.it) plot(Xi, bf, type = "l", xlab = names(xdat)[varno], ylab = "response") #aks
              if (plot.rug & plot.it) rug(quantile(xdat[,varno], probs = seq(0, 1, 0.1), na.rm = FALSE))
              r.curves$preds[[cntr]] <- Xi #aks
              r.curves$resp[[cntr]] <- bf #aks
            }
            else {
              if(plot.it) plot(factor.table$levels, factor.table$coefficients, xlab = names(xdat)[varno]) #aks
              r.curves$preds[[cntr]] <- factor.table$levels #aks
              r.curves$resp[[cntr]] <- factor.table$coefficients #aks

            }
            r.curves$names <- c(r.curves$names,names(xdat)[varno])  #aks
            cntr <- cntr + 1  #aks
            nplots = nplots + 1
            plotit[j] <- FALSE
          }
        }
        else {  # case where there is an interaction #
          if (plotit[j]) {
            varno1 <- pmatch(as.character(m.table$names1[j]), names(xdat))
            X1 <- seq(xrange[1, varno1], xrange[2, varno1], length = 20)
            bf1 <- pmax(0, m.table$signs1[j] * (X1 - m.table$cuts1[j]))
            varno2 <- pmatch(as.character(m.table$names2[j]), names(xdat))
            X2 <- seq(xrange[1, varno2], xrange[2, varno2], length = 20)
            bf2 <- pmax(0, m.table$signs2[j] * (X2 - m.table$cuts2[j]))
            if(factor.filter[varno1] & factor.filter[varno2]){ #aks
                zmat <- bf1 %o% bf2
                zmat <- zmat * m.table[j, i + 10]
                if (j < n.bfs) {
                  for (k in ((j + 1):n.bfs)) {
                    if (m.table$names1[j] == m.table$names1[k] & m.table$names2[j] == m.table$names2[k]) {
                      bf1 <- pmax(0, m.table$signs1[k] * (X1 - m.table$cuts1[k]))
                      bf2 <- pmax(0, m.table$signs2[j] * (X2 - m.table$cuts2[j]))
                      zmat2 <- bf1 %o% bf2
                      zmat2 <- zmat2 * m.table[j, i + 10]
                      zmat = zmat + zmat2
                      plotit[k] <- FALSE
                    }
                  }
                }
              #if (nplots == 0) {  #AKS
    #            if (use.windows) windows(width = 11, height = 8)
    #            par(mfrow = plot.layout)
    #          }
                if(plot.it){
                    persp(x = X1, y = X2, z = zmat, xlab = names(xdat)[varno1],
                              ylab = names(xdat)[varno2], theta = 45, phi = 25) }
                r.curves$preds[[cntr]] <- X1 #aks
                r.curves$resp[[cntr]] <- apply(zmat,1,mean,na.rm=T) #aks
                nplots = nplots + 1
                } else {
                    r.curves$preds[[cntr]] <- NA #aks
                    r.curves$resp[[cntr]] <- NA #aks

                }
        r.curves$names <- c(r.curves$names,names(xdat)[varno]) #aks
        cntr <- cntr + 1 #aks
        }
      }
      if (nplots == 1 & plot.it) {
        title(paste(spp.names[i], " - page ", n.pages, sep = ""))
      }
      if (nplots == max.plots) {
        nplots = 0
        n.pages <- n.pages + 1
      }
    }
  }
  if (!use.windows & plot.it) dev.off()
  invisible(r.curves) #aks
}

"mars.plot.fits" <-
function(mars.glm.object,    # the input mars object
   sp.no = 0,                # allows selection of individual spp for multiresponse models
   mask.presence = FALSE,    # plots out just presence records
   use.factor = FALSE,       # draws plots as factors for faster printing
   plot.layout = c(4,2),     # the default plot layout
   file.name = NA)           # allows plotting to a pdf file
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# to plot distribution of fitted values in relation to ydat from mars or other p/a models
# allows masking out of absences to enable focus on sites with high predicted values
# fitted values = those from model; raw.values = original y values
# label = text species name; ydat = predictor dataset
# mask.presence forces function to only plot fitted values for presences
# use.factor forces to use quicker printing box and whisker plot
# file.name routes to a pdf file of this name
#

  max.plots <- plot.layout[1] * plot.layout[2]

  if (is.na(file.name)) {    #setup for windows or file output
    use.windows = TRUE
  }
  else {
    pdf(file.name, width=8, height = 11)
    par(mfrow = plot.layout)
    par(cex = 0.5)
    use.windows = FALSE
  }

  dat <- mars.glm.object$mars.call$dataframe    #get the dataframe name
  dat <- as.data.frame(eval(parse(text=dat)))   #and now the data

  n.cases <- nrow(dat)

  mars.call <- mars.glm.object$mars.call	#and the mars call details
  mars.x <- mars.call$mars.x
  mars.y <- mars.call$mars.y
  family <- mars.call$family

  xdat <- as.data.frame(dat[,mars.x])
  ydat <- as.data.frame(dat[,mars.y])

  n.spp <- ncol(ydat)
  n.preds <- ncol(xdat)

  fitted.values <- mars.glm.object$fitted.values

  pred.names <- names(dat)[mars.x]
  spp.names <- names(dat)[mars.y]

  if (sp.no == 0) {
    wanted.species <- seq(1:n.spp)
    }
  else {
    wanted.species <- sp.no
    }

  for (i in wanted.species) {

    if (mask.presence) {
	mask <- ydat[,i] == 1 }
    else {
      mask <- rep(TRUE, length = n.cases)
    }

    robust.max.fit <- approx(ppoints(fitted.values[mask,i]), sort(fitted.values[mask,i]), 0.99) #find 99%ile value
    nplots <- 0

    for (j in 1:n.preds) {
      if (use.windows & nplots == 0) {
        windows(width = 8, height = 11)
        par(mfrow = plot.layout)
        par(cex = 0.5)
      }
	nplots <- nplots + 1
      if (is.vector(xdat[,j])) wt.mean <- mean((xdat[mask, j] * fitted.values[mask, i]^5)/mean(fitted.values[mask, i]^5))
        else wt.mean <- 0
	if (use.factor) {
	temp <- factor(cut(xdat[mask, j], breaks = 12))
	if (family == "binomial") {
	  plot(temp, fitted.values[mask,i], xlab = pred.names[j], ylab = "fitted values", ylim = c(0, 1))
      }
	else {
	  plot(temp, fitted.values[mask,i], xlab = pred.names[j], ylab = "fitted values")}
	}
	else {
	  if (family == "binomial") {
	    plot(xdat[mask, j], fitted.values[mask,i], xlab = pred.names[j], ylab = "fitted values",
					ylim = c(0, 1))
        }
	  else {
          plot(xdat[mask, j], fitted.values[mask,i], xlab = pred.names[j], ylab = "fitted values")
        }
	}
	abline(h = (0.333 * robust.max.fit$y), lty = 2.)
	if (nplots == 1) {
  	  title(paste(spp.names[i], ", wtm = ", zapsmall(wt.mean, 4.)))}
	else {
	  title(paste("wtm = ", zapsmall(wt.mean, 4.)))}
	  nplots <- ifelse(nplots == max.plots, 0, nplots)
	}
    }
  if (!use.windows) dev.off()
}

"mars.predict" <-
function (mars.glm.object,new.data)
{
#
# j leathwick, j elith - August 2006
#
# version 3.1 - developed in R 2.3.1 using mda 0.3-1
#
# calculates a mars/glm object in which basis functions are calculated
# using an initial mars model with single or multiple responses
# data for individual species are then fitted as glms using the
# common set of mars basis functions with results returned as a list
#
# takes as input a dataset and args selecting x and y variables, and degree of interaction
# along with site and species weights, the CV penalty, and the glm family argument
# the latter would normally be one of "binomial" or "poisson" - "gaussian" could be used
# but in this case the model shouldn't differ from that fitted using mars on its own
#
# naming problem for dataframes fixed - je - 15/12/06
#
# requires mda and leathwick/elith's mars.export
#
  require(mda)

# first recreate both the original mars model and the glm model

# setup input data and create original temporary data

  dataframe.name <- mars.glm.object$mars.call$dataframe  # get the dataframe name
  mars.x <- mars.glm.object$mars.call$mars.x
  mars.y <- mars.glm.object$mars.call$mars.y
  n.spp <- length(mars.y)
  family <- mars.glm.object$mars.call$family
  mars.degree <- mars.glm.object$mars.call$degree
  penalty <- mars.glm.object$mars.call$penalty
  site.weights <- mars.glm.object$weights[[1]]
  spp.weights <- mars.glm.object$weights[[2]]

  print("creating original data frame...",quote=FALSE)

  base.data <- as.data.frame(eval.parent(parse(text = dataframe.name))) #aks

  x.temp <- eval(base.data[, mars.x])                 #form the temporary datasets
  base.names <- names(x.temp)

  xdat <- mars.new.dataframe(x.temp)[[1]]

  ydat <- as.data.frame(base.data[, mars.y])
  names(ydat) <- names(base.data)[mars.y]

  assign("xdat", xdat, pos = 1)               #and assign them for later use
  assign("ydat", ydat, pos = 1)

# now create the temporary dataframe for the new data

  print("checking variable matching with new data",quote = FALSE)

  new.names <- names(new.data)

  for (i in 1:length(base.names)) {

    name <- base.names[i]

    if (!(name %in% new.names)) {
      print(paste("Variable ",name," missing from new data",sep=""),quote = FALSE)  #aks
      return()
    }
  }

  print("and creating temporary dataframe for new data...",quote=FALSE)

  selector <- match(names(x.temp),names(new.data))

  pred.dat <- mars.new.dataframe(new.data[,selector])[[1]]

  assign("pred.dat", pred.dat, pos = 1)               #and assign them for later use

# fit the mars model and extract the basis functions

  print(paste("re-fitting initial mars model for",n.spp,"responses"),quote = FALSE)
  print(paste("using glm family of",family),quote = FALSE)

  #mars.fit <- mars(x = xdat, y = ydat, degree = mars.degree, w = site.weights,
  #  wp = spp.weights, penalty = penalty)

  mars.fit <- mars.glm.object$mars.object  #AKS

  old.bf.data <- as.data.frame(eval(mars.fit$x))
  n.bfs <- ncol(old.bf.data)
  bf.names <- paste("bf", 1:n.bfs, sep = "")
  old.bf.data <- as.data.frame(old.bf.data[,-1])
  names(old.bf.data) <- bf.names[-1]

  new.bf.data <- as.data.frame(mda:::model.matrix.mars(mars.fit,pred.dat))
  new.bf.data <- as.data.frame(new.bf.data[,-1])
  names(new.bf.data) <- bf.names[-1]

# now cycle through the species fitting glm models

  print("fitting glms for individual responses", quote = F)

  prediction <- as.data.frame(matrix(0, ncol = n.spp, nrow = nrow(pred.dat)))
  names(prediction) <- names(ydat)
  standard.errors <- as.data.frame(matrix(0, ncol = n.spp, nrow = nrow(pred.dat)))
  names(standard.errors) <- names(ydat)

  for (i in 1:n.spp) {

    print(names(ydat)[i], quote = FALSE)
    model.glm <- glm(ydat[, i] ~ ., data = old.bf.data, weights = site.weights,
      family = family, maxit = 100)
    temp <- predict.glm(model.glm,new.bf.data,type="response",se.fit=TRUE)
    prediction[,i] <- temp[[1]]
    standard.errors[,i] <- temp[[2]]

    }

  return(list("prediction"=prediction,"ses"=standard.errors))
}

"roc" <-
function (obsdat, preddat)
{
# code adapted from Ferrier, Pearce and Watson's code, by J.Elith
#
# see:
# Hanley, J.A. & McNeil, B.J. (1982) The meaning and use of the area
# under a Receiver Operating Characteristic (ROC) curve.
# Radiology, 143, 29-36
#
# Pearce, J. & Ferrier, S. (2000) Evaluating the predictive performance
# of habitat models developed using logistic regression.
# Ecological Modelling, 133, 225-245.
# this is the non-parametric calculation for area under the ROC curve,
# using the fact that a MannWhitney U statistic is closely related to
# the area
#
    if (length(obsdat) != length(preddat))
        stop("obs and preds must be equal lengths")
    n.x <- length(obsdat[obsdat == 0])
    n.y <- length(obsdat[obsdat == 1])
    xy <- c(preddat[obsdat == 0], preddat[obsdat == 1])
    rnk <- rank(xy)
    wilc <- ((n.x * n.y) + ((n.x * (n.x + 1))/2) - sum(rnk[1:n.x]))/(n.x *
        n.y)
    return(round(wilc, 4))
}

#set defaults
make.p.tif=T
make.binary.tif=T
mars.degree=1
mars.penalty=2
script.name="mars.r"
opt.methods=2
save.model=TRUE
MESS=FALSE

# Interpret command line argurments #
# Make Function Call #
Args <- commandArgs(trailingOnly=FALSE)

    for (i in 1:length(Args)){
     if(Args[i]=="-f") ScriptPath<-Args[i+1]
     }

    print(Args)
    for (arg in Args) {
    	argSplit <- strsplit(arg, "=")
    	argSplit[[1]][1]
    	argSplit[[1]][2]
    	if(argSplit[[1]][1]=="c") csv <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="o") output <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="rc") responseCol <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="mpt") make.p.tif <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="mbt")  make.binary.tif <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="deg") mars.degree <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="pen") mars.penalty <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="om")  opt.methods <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="savm")  save.model <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="mes")  MESS <- argSplit[[1]][2]
    }
	print(csv)
	print(output)
	print(responseCol)

ScriptPath<-dirname(ScriptPath)
source(paste(ScriptPath,"LoadRequiredCode.r",sep="\\"))
print(ScriptPath)

make.p.tif<-as.logical(make.p.tif)
make.binary.tif<-as.logical(make.binary.tif)
save.model<-make.p.tif | make.binary.tif
opt.methods<-as.numeric(opt.methods)
MESS<-as.logical(MESS)

fit.mars.fct(ma.name=csv,
        tif.dir=NULL,output.dir=output,
        response.col=responseCol,make.p.tif=make.p.tif,make.binary.tif=make.binary.tif,
            mars.degree=mars.degree,mars.penalty=mars.penalty,debug.mode=F,responseCurveForm="pdf",
            script.name="mars.r",save.model=save.model,opt.methods=as.numeric(opt.methods),MESS=MESS)


fit.loop <- function(methylation, design, dependent.variable, independent.variable, fit.function, stats.function, ...) {
    ret <- rep(NA,4)
    dep.idx <- which(colnames(design) == dependent.variable)

    do.call(rbind, mclapply(1:nrow(methylation), function(i) {
        design[,"methylation"] <- methylation[i,]   ## assign CpG site methylation
        idx <- which(!is.na(design[,"methylation"]))
        try({
            fit <- fit.function(x=design[idx,-dep.idx,drop=F], ## independent variables
                                y=design[idx,dep.idx],         ## dependent variable
                                ...)
            ret <- stats.function(fit, independent.variable)
        }, silent=T)
        ret
    }))
}


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/viscous")

library(xlsx)

# 比较tfor和tp
# tfor下，liquid1和liquid2的比较
# 2.2kv下的比较
# 18nl/min和180nl/min
# 18nl/min-liquid1，18nl/min-liquid2, 180nl/min-liquid1,180nl/min-liquid2

# legend: 18nl/min-l1,18nl/min-l2,180nl/min-l1,180nl/min-liquid2

k1<-read.xlsx("liquid1.xlsx",sheetName="2kv-18",header=TRUE)
k2<-read.xlsx("liquid1.xlsx",sheetName="2.2kv-18",header=TRUE)
k3<-read.xlsx("liquid2.xlsx",sheetName="2.2kv-18",header=TRUE)
k4<-read.xlsx("liquid1.xlsx",sheetName="2.2kv-180",header=TRUE)

# errorbar
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
stop("vectors must be same length")
arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

# color setting

yan<-c("red","blue","black","green3")
pcc<-c(0,1,2,5)

plot(k1$fv,k1$deva, col=0,xlab = expression(italic(f["v"]) (Hz)),
          ylab = expression(italic(d["d"]) (um)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "", xlim = c(0,800),ylim=c(0,60))

   mtext("Small droplet",3,line=-1,font=2,cex=1)

   points(k1$fv,k1$deva,col=yan[1],lty=2,pch=pcc[1],cex=0.8)
   points(k2$fv,k2$deva,col=yan[2],lty=2,pch=pcc[2],cex=0.8)
   points(k3$fv,k3$deva,col=yan[3],lty=2,pch=pcc[3],cex=0.8)
   points(k4$fv,k4$deva,col=yan[4],lty=2,pch=pcc[4],cex=0.8)

   error.bar(k1$fv,k1$deva,k1$stdd/2,col=yan[1])
   error.bar(k2$fv,k2$deva,k2$stdd/2,col=yan[2])
   error.bar(k3$fv,k3$deva,k3$stdd/2,col=yan[3])
   error.bar(k4$fv,k4$deva,k4$stdd/2,col=yan[4])

   fit1=lm(k1$deva~k1$fv)
   fit2=lm(k2$deva~k2$fv)
   fit3=lm(k3$deva~k3$fv)
   fit4=lm(k4$deva~k4$fv)

   abline(fit1,col=yan[1],lwd=1.5,lty=2)
   abline(fit2,col=yan[2],lwd=1.5,lty=2)
   abline(fit3,col=yan[3],lwd=1.5,lty=2)
   abline(fit4,col=yan[4],lwd=1.5,lty=2)

   leg<-c("18nl/min-2kv(liquid1)","18nl/min-2.2kv(liquid1)","18nl/min-2.2kv(liquid2)","180nl/min-2.2kv(liquid1)")

   legend("topright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,
   inset=.01,bty="n",cex=0.8)

   inter<-c(coef(fit1)[1],coef(fit2)[1],coef(fit3)[1],coef(fit4)[1])
   slope<-c(coef(fit1)[2],coef(fit2)[2],coef(fit3)[2],coef(fit4)[2])


#!/usr/bin/env Rscript

# R scripts for convert the Rdata output file from phantompeakqualtools for strand-shift plot
# Author @chuan-wang https://github.com/chuan-wang

# Command line argument processing
args <- commandArgs(trailingOnly=TRUE)

# Check input args
if (length(args) != 2) {
  stop("Usage: processSppRdata.r [ input.Rdata ] [ output.csv ]", call.=FALSE)
}

load(args[1])
data<-crosscorr$cross.correlation

write.table(data, file=args[2], sep=",", quote=FALSE, row.names=FALSE, col.names=FALSE)


library(ggplot2)
library(reshape2)
library(sandwich)
library(lmtest)
library(tseries)
library(dplyr)
library(urca)
library(forecast)
library(data.table)
library(stringr)
library(xtable)
library(fixest)

rm(list=ls())
gc()

source("startest.r")
source("lstar.r")
source("estar.r")

## load the data
load("forecast80.RData")
load("subset.RData")

c_num <- ncol(subset_dt)-1

c_names <- names(subset_dt)[1:c_num]

commodities <- c("Aluminum","Bananas","Cotton","Diammonium Phosphate","Fishmeal",
                 "Groundnut Oil","Groundnuts","Gold","Hides","Lamb",
                 "Lead","Soft Logs","Oranges","Olive Oil","Platinum",
                 "Plywood","Palm Oil","Rice","Rapeseed Oil","Rubber",
                 "Soybean Oil","Hard Sawnwood","Soft Sawnwood","Uran","Urea")

sub_dt$cmd <- commodities

## this is sort of arbitrary, but
# in general: agricultural(1)--forestry(2,3)--metals & minerals(4,5)
grp_order <- c(5,.9,1,4,2,
               2,2,5,1.9,1.8,
               5,3,.9,2,5,
               3,2,1,2,2.5,
               2,3,3,5,4)
sub_dt$grp <- grp_order
sub_dt <- sub_dt[order(grp,cmd)]

count_fn <- function(x,crit=.05){
  sum(x < crit)/length(x)
}

# table 1
tab1_dt <- as.data.table(t(round(apply(array_pval,c(1,3),count_fn),2)))
colnames(tab1_dt) <- paste0("h",1:12)
tab1_dt$cmd <- commodities
tab1_dt$grp <- grp_order
tab1_dt <- tab1_dt[order(grp,cmd)]

tab1_dt$grp <- NULL
tab1_dt <- setcolorder(tab1_dt,c("cmd",paste0("h",1:12)))
print(xtable(tab1_dt),include.rownames=FALSE)
write.table(tab1_dt,file="Paper/table_1.txt",sep=",",quote=F,row.names=F)

# appendix table 1
taba1_dt <- sub_dt[,.(Commodity=cmd,p,l,d,t)]
print(xtable(taba1_dt),include.rownames=FALSE)
write.table(taba1_dt,file="Paper/table_a1.txt",sep=",",quote=F,row.names=F)


library(Seurat)
library(CellChat)
library(pheatmap)
library(ComplexHeatmap)

object.list<-readRDS('./project/merge_sle_immunonolgy_communication_cellchat.rds')

names(object.list)<-c('HD','aSLE','cSLE')

cellchat <- mergeCellChat(object.list, add.names = names(object.list))

cellchat

dir.create("./sle_picture/Fig4/")
options(repr.plot.width=6,repr.plot.height=4)
gg1<-compareInteractions(cellchat, show.legend = F, group = c(1,2,2))+scale_fill_manual(values=c('#d86363','#2f7fc1'))
gg2 <- compareInteractions(cellchat, show.legend = F, group = c(1,2,2), measure = "weight")+scale_fill_manual(values=c('#d86363','#2f7fc1'))
p<-gg1 + gg2
p
#ggsave(p,file="./sle_picture/Fig4/cellchat_bar.pdf",width = 6, height =4)

options(repr.plot.width=12,repr.plot.height=6)
weight.max <- getMaxWeight(object.list, attribute = c("idents","count"))
par(mfrow = c(1,3), xpd=TRUE)

for (i in c(1,2,3)) {
  netVisual_circle(object.list[[i]]@net$count, weight.scale = T, label.edge= F, edge.weight.max = weight.max[2], edge.width.max = 12, title.name = paste0("Number of interactions - ", names(object.list)[i]))
}

options(repr.plot.width=20)
#options(repr.plot.width=25,repr.plot.height=15)
i = 1
# combining all the identified signaling pathways from different datasets
pathway.union <- union(object.list[[i]]@netP$pathways, object.list[[i+1]]@netP$pathways)
ht1 = netAnalysis_signalingRole_heatmap(object.list[[i]], pattern = "all", signaling = pathway.union, title = names(object.list)[i], width = 7, height = 10, color.heatmap = "OrRd")
ht2 = netAnalysis_signalingRole_heatmap(object.list[[i+2]], pattern = "all", signaling = pathway.union, title = names(object.list)[i+1], width = 7, height = 10, color.heatmap = "OrRd")
ht3 = netAnalysis_signalingRole_heatmap(object.list[[i+1]], pattern = "all", signaling = pathway.union, title = names(object.list)[i+2], width = 7, height = 10, color.heatmap = "OrRd")
ht1+ht2+ht3

nPatterns = 3
object.list$HD <- identifyCommunicationPatterns(object.list$HD, pattern = "outgoing", k = nPatterns)
object.list$aSLE <- identifyCommunicationPatterns(object.list$aSLE, pattern = "outgoing", k = nPatterns)
object.list$cSLE <- identifyCommunicationPatterns(object.list$cSLE , pattern = "outgoing", k = nPatterns)
nPatterns = 2
object.list$HD <- identifyCommunicationPatterns(object.list$HD, pattern = "incoming", k = nPatterns)
object.list$aSLE <- identifyCommunicationPatterns(object.list$aSLE, pattern = "incoming", k = nPatterns)
object.list$cSLE <- identifyCommunicationPatterns(object.list$cSLE , pattern = "incoming", k = nPatterns)

p1 <- netAnalysis_dot(object.list$HD, pattern = "outgoing",font.size=15)+labs(title='',legend="")+theme(
      axis.text.x=element_text(angle=90))
p1
#ggsave(filename='./sle_picture/Fig4/netdotHD.pdf',plot=p1,width=9.9,height=3.7)
p2 <- netAnalysis_dot(object.list$aSLE, pattern = "outgoing",font.size=15)+labs(title='',legend="")+theme(
      axis.text.x=element_text(angle=90))
p2
#ggsave(filename='./sle_picture/Fig4/netdotaSLE.pdf',plot=p2,width=9.9,height=3.7)
p3 <- netAnalysis_dot(object.list$cSLE, pattern = "outgoing",font.size=15)+labs(title='')+theme(
      axis.text.x=element_text(angle=90))
p3
#ggsave(filename='./sle_picture/Fig4/netdotcSLE.pdf',plot=p3,width=9.9,height=3.7)

p1 <- netAnalysis_dot(object.list$HD, pattern = "incoming",font.size=15)+labs(title='',legend="")+theme(
      axis.text.x=element_text(angle=90))
p1
#ggsave(filename='./sle_picture/Fig4/netdot_incoming_HD.pdf',plot=p1,width=9.9,height=3.7)
p2 <- netAnalysis_dot(object.list$aSLE, pattern = "incoming",font.size=15)+labs(title='',legend="")+theme(
      axis.text.x=element_text(angle=90))
p2
#ggsave(filename='./sle_picture/Fig4/netdot_incoming_aSLE.pdf',plot=p2,width=9.9,height=3.7)
p3 <- netAnalysis_dot(object.list$cSLE, pattern = "incoming",font.size=15)+labs(title='')+theme(
      axis.text.x=element_text(angle=90))
p3
#ggsave(filename='./sle_picture/Fig4/netdot_incoming_cSLE.pdf',plot=p3,width=9.9,height=3.7)

dir.create("./sle_picture/Fig5/")
options(repr.plot.width=15,repr.plot.height=6)
p1 <- netVisual_bubble(cellchat, sources.use = 2, targets.use = c(1,3,4,5),max.dataset = 1,min.dataset = c(2,3),
                 comparison = c(1, 2,3), angle.x = 45,font.size=15)+coord_flip()+theme(axis.text.x=element_text(angle=90, hjust=1))
p1
ggsave(filename='./sle_picture/Fig5/netbub_1.pdf',plot=p1,width=15,height=6)

options(repr.plot.width=15,repr.plot.height=6)
p2 <- netVisual_bubble(cellchat, sources.use = 3, targets.use = c(1,2,4,5),max.dataset = 1,min.dataset = c(2,3),
                 comparison = c(1, 2,3), angle.x = 45,font.size=15)+coord_flip()+theme(axis.text.x=element_text(angle=90, hjust=1))
p2
ggsave(filename='./sle_picture/Fig5/netbub_2.pdf',plot=p2,width=15,height=6)

options(repr.plot.width=15,repr.plot.height=6)
p3 <- netVisual_bubble(cellchat, sources.use = 1, targets.use = c(2,3,4,5),max.dataset = 1,min.dataset = c(2,3),
                 comparison = c(1, 2,3), angle.x = 45,font.size=15)+coord_flip()+theme(axis.text.x=element_text(angle=90, hjust=1))
p3
ggsave(filename='./sle_picture/Fig5/netbub_3.pdf',plot=p3,width=15,height=6)

options(repr.plot.width=15,repr.plot.height=6)
p4 <- netVisual_bubble(cellchat, sources.use =4, targets.use = c(1,2,3,5),max.dataset = 1,min.dataset = c(2,3),
                 comparison = c(1, 2,3), angle.x = 45,font.size=15)+coord_flip()+theme(axis.text.x=element_text(angle=90, hjust=1))
p4
ggsave(filename='./sle_picture/Fig5/netbub_4.pdf',plot=p4,width=15,height=6)

options(repr.plot.width=15,repr.plot.height=6)
p5 <- netVisual_bubble(cellchat, sources.use = 5, targets.use = c(1,2,3,4),max.dataset = 1,min.dataset = c(2,3),
                 comparison = c(1, 2,3), angle.x = 45,font.size=15)+coord_flip()+theme(axis.text.x=element_text(angle=90, hjust=1))
p5
ggsave(filename='./sle_picture/Fig5/netbub_5.pdf',plot=p5,width=15,height=6)


# 3. faza: Izdelava zemljevida

# Uvozimo funkcijo za pobiranje in uvoz zemljevida.
source("lib/uvozi.zemljevid.r")

# Uvozimo zemljevid.
cat("Uvažam zemljevid...\n")
svet <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/ne_110m_admin_0_countries.zip",
                          "svet", "ne_110m_admin_0_countries.shp", mapa = "zemljevid",
                          encoding = "Windows-1250")

t <- table(Dirkalisca$Country)
names(t)[names(t) == "GREAT BRITAIN"] <- "UNITED KINGDOM"
names(t)[names(t) == "YUGOSLAVIA"] <- "CROATIA"
m <- match(toupper(svet$name_long), names(t))

# Izračunamo povprečno velikost družine.
min.dirke <- min(t)
max.dirke <- max(t)

# Narišimo zemljevid v PDF.
cat("Rišem zemljevid...\n")
pdf("slike/dirkaliscasvet.pdf")

n = max(t)
barve = topo.colors(n)[1+(n-1)*(t-min.dirke)/(max.dirke-min.dirke)]
plot(svet, col = barve[m])
u <- unique(t)
u <- u[order(u)]
legend("left", legend = u, fill = topo.colors(n)[u], bg="white")

dev.off()


# Source: https://shirinsplayground.netlify.com/2018/06/keras_fruits_lime/
# Author: Dr. Shirin Elsinghorst - https://github.com/ShirinG
# Data: https://www.kaggle.com/moltean/fruits/data

library(keras)   # for working with neural nets
library(lime)    # for explaining models
library(magick)  # for preprocessing images
library(ggplot2) # for additional plotting

# Loading model
model <- application_vgg16(weights = "imagenet", include_top = TRUE)
model

# Include our own model
path_prefix <- paste(getwd(), "/data/fruit/", sep="")
model2 <- load_model_hdf5(paste(path_prefix, "fruit_checkpoints.h5", sep=""))
model2

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

# Load images
test_image_files_path <- paste(path_prefix, "validation/", sep="")

img <- image_read('https://upload.wikimedia.org/wikipedia/commons/thumb/8/8a/Banana-Single.jpg/272px-Banana-Single.jpg')
img_path <- file.path(test_image_files_path, "Banana", 'banana.jpg')
image_write(img, img_path)
#plot(as.raster(img))

img2 <- image_read('https://cdn.pixabay.com/photo/2010/12/13/09/51/clementine-1792_1280.jpg')
img_path2 <- file.path(test_image_files_path, "Clementine", 'clementine.jpg')
image_write(img2, img_path2)
#plot(as.raster(img2))

plot_superpixels(img_path, n_superpixels = 35, weight = 10)
plot_superpixels(img_path2, n_superpixels = 50, weight = 20)

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

# Prepare images for image net
image_prep <- function(x) {
  arrays <- lapply(x, function(path) {
    img <- image_load(path, target_size = c(224,224))
    x <- image_to_array(img)
    x <- array_reshape(x, c(1, dim(x)))
    x <- imagenet_preprocess_input(x)
  })
  do.call(abind::abind, c(arrays, list(along = 1)))
}

# Test predictions
res <- predict(model, image_prep(c(img_path, img_path2)))
imagenet_decode_predictions(res)

# Load labels and train explainer

model_labels <- readRDS(system.file('extdata', 'imagenet_labels.rds', package = 'lime'))
explainer <- lime(c(img_path, img_path2), as_classifier(model, model_labels), image_prep)

# Train model
explanation <- explain(c(img_path, img_path2), explainer,
                       n_labels = 2, n_features = 35,
                       n_superpixels = 35, weight = 10,
                       background = "white")

plot_image_explanation(explanation)

clementine <- explanation[explanation$case == "clementine.jpg",]
plot_image_explanation(clementine)

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

# Make predictions

test_datagen <- image_data_generator(rescale = 1/255)

test_generator <- flow_images_from_directory(
  test_image_files_path,
  test_datagen,
  target_size = c(20, 20),
  class_mode = 'categorical')

predictions <- as.data.frame(predict_generator(model2, test_generator, steps = 1))

load(paste(path_prefix, "fruits_classes_indices.RData", sep=""))
fruits_classes_indices_df <- data.frame(indices = unlist(fruits_classes_indices))
fruits_classes_indices_df <- fruits_classes_indices_df[order(fruits_classes_indices_df$indices), , drop = FALSE]
colnames(predictions) <- rownames(fruits_classes_indices_df)

t(round(predictions, digits = 2))

for (i in 1:nrow(predictions)) {
  cat(i, ":")
  print(unlist(which.max(predictions[i, ])))
}

image_prep2 <- function(x) {
  arrays <- lapply(x, function(path) {
    img <- image_load(path, target_size = c(20, 20))
    x <- image_to_array(img)
    x <- reticulate::array_reshape(x, c(1, dim(x)))
    x <- x / 255
  })
  do.call(abind::abind, c(arrays, list(along = 1)))
}

fruits_classes_indices_l <- rownames(fruits_classes_indices_df)
names(fruits_classes_indices_l) <- unlist(fruits_classes_indices)
fruits_classes_indices_l

explainer2 <- lime(c(img_path, img_path2), as_classifier(model2, fruits_classes_indices_l), image_prep2)
explanation2 <- explain(c(img_path, img_path2), explainer2,
                        n_labels = 1, n_features = 20,
                        n_superpixels = 35, weight = 10,
                        background = "white")

# plot results
explanation2 %>%
  ggplot(aes(x = feature_weight)) +
  facet_wrap(~ case, scales = "free") +
  geom_density()


  cummulative.landings = function(x) {

    x$uniqueid = paste(x$gridid, x$yr, sep="~")
    ids = sort(unique(x$uniqueid))
    x$dyear = lubridate::decimal_year(x$timestamp) - lubridate::year(x$timestamp)

    v = "landings"
    ti = "week"
    for (i in ids) {
      j = x[ which(x$uniqueid==i),]
      y = as.data.frame(xtabs( as.integer(x[,v]) ~ as.factor(x[,
                ti]), exclude="" ))
      names(y) = c(ti, v)
      y$Csum = cumsum(y[, v])
# --- must add a flexible model that can do convex/concave relationships (log relationshpi may be sufficient)

#      extract params (t0, t50, t100, slope parameter)

    }
#    redo for total effort as well

  }


### CCM analysis to determine causality
# Spatial CV ~ Age diversity, Abundance, AMO, SBT/SST, CV of SBT/SST

########## Warning!
# This step takes much time.
# One can skip this step if the pre-run CCM results are provided.
# Please see the loading code below.
########## Warning!
# run CCM several times to find the best lag for each variable
EDM_lib_var = lapply(EDM_lib_var, function(item, lib_var=library_var, lag=lags, t_ccm=time_ccm){
    data = item[[dataset]]
    data = subset(data, select=names(data) %ni% c("Year", "Quarter"))
    data = cbind(data[lib_var], subset(data, select=names(data) %ni% lib_var))

    item$ccm = data.frame(matrix(0, nrow = 0, ncol = 10))
    for (i in 1:t_ccm){
        seed = 1234 + i * 10
        ccm_result = determineCausality(data = data,
                                        dim.list = item$E,
                                        species = item$species,
                                        lags = lag,
                                        seed = seed)
        item$ccm = rbind(item$ccm, ccm_result)
    }

    return(item)
})

# save ccm results
lapply(EDM_lib_var, function(item){
    write.csv(item$ccm,
              file = paste0(wd, ccm_path, item$species, ".csv"),
              row.names = FALSE)
})


# user options
nox<-2; noy<-3;
paper<-F   # if paper==T output on file, else screen
cleanup()

first.year.in.mean<-2049    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2050

do.simulation<-F     # do the simulations and create data files for plots
do.plots<-T            # do the plots

######### end user options #########
do.HCR.batch<-function() {

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'

if (do.simulation) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat.gem')

  sp.name<-control@species.names

   xlab.title<-'Implentation bias'

  # headers in output files
  cat('codF cluF Species.n SSB025 SSB250 SSB500 SSB750 SSB975 \n',file=ssb.out)
  cat('codF cluF Species.n y025 y050 y500 y750 y975 \n',file=yield.out)
  cat('codF cluF Species.n F025 F050 F500 F750 F975 \n',file=F.out)

  iter<-0

  BaseF<-HCR@constant.F
  print (BaseF)
  codF<-seq(0.01,1,0.1)
  ClupoidF<-seq(0.01,0.8,0.1)

  percentiles<-c(0.025,0.25,0.50,0.75,0.975)

  for (CODF in (codF)) for (CLUF in (ClupoidF)) {
      iter<-iter+1

      HCR@constant.F[1]<-BaseF[1]*CODF
      HCR@constant.F[2]<-BaseF[2]*CLUF*0.5
      HCR@constant.F[3]<-BaseF[3]*CLUF

      write.FLSMS.predict.control(HCR,file='HCR_options.dat')

      #run SMS
      shell(paste( file.path(root,"program","sms.exe"),"-mceval",sep=" "), invisible = TRUE)

      a<-Read.MCMC.SSB.rec.data()
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)

      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=ssb.out,append=TRUE)
         cat(b[[i]],file=ssb.out,append=TRUE)
         cat('\n',file=ssb.out,append=TRUE)
      }

      a<-Read.MCMC.F.yield.data(dir=data.path)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=yield.out,append=TRUE)
         cat(b[[i]],file=yield.out,append=TRUE)
         cat('\n',file=yield.out,append=TRUE)
      }

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(CODF,' ',CLUF,' ',i,' '),file=F.out,append=TRUE)
         cat(b[[i]],file=F.out,append=TRUE)
         cat('\n',file=F.out,append=TRUE)
      }
  }
}   # end do.simulations

if (do.plots) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,fi)
  b<-subset(a,select=c(Species.n,codF,cluF,SSB500,y500))

  make.plots<-function(variable='SSB') {
  by(b,list(b$Species.n),function(x) {
    xx<-sort(unique(x$codF))
    y<-sort(unique(x$cluF))
    if (variable=="SSB") z<-tapply(x$SSB500/1000,list(x$codF,x$cluF),mean)
    if (variable=="Yield") z<-tapply(x$y500/1000,list(x$codF,x$cluF),mean)

    sp<-sp.name[x[1,"Species.n"]]
     if ((i %% (nox*noy))==0) {
       if (paper) dev<-"wmf" else dev<-"screen"
       newplot(dev,nox,noy,dir=data.path,filename=paste("Batch_",sep=''),Portrait=T);
       par(mar=c(4,5,3,2))
     }
    i<<-i+1
    contour(xx,y,z,xlab="Cod F",ylab="Clupeid F",nlevels = 10)
    title(main=paste(sp,variable))
  })
  }

  i<<-0
  make.plots(variable="SSB")
  make.plots(variable="Yield")

  if (paper) cleanup()

} #end do.plots

}
do.HCR.batch()


## script to develop neural cell type deconvolution algorithm
## uses houseman method with new ref data for purified brain cell populations
## editted original code from minfi to take a matrix rather than RGset - this means data is not preprocessed together.

source("FunctionsForBrainCellProportionsPrediction.r")
library(minfi)
library(genefilter)
library(rafalib)
library(IlluminaHumanMethylationEPICanno.ilm10b4.hg19)
source("rmdConfig.bdr")
setwd(dataDir)
load(normData)

pheno$Cell.type<-gsub(" \\+ve", "", pheno$Cell.type) ## need to remove the "+" and "-"
pheno$Cell.type<-gsub(" -ve", "", pheno$Cell.type) ## need to remove the "+" and "-"
cellInd<-pheno$Cell.type

## parameters
probeSelect = "any" ## options "both" (select equal number of probes associated with hyper and hypo methylation) or "any" (just select probes based on significance regardless of direction)
cellTypes = c("Double","NeuN", "Sox10", "IRF8")
cellTypes<-sort(cellTypes)
numProbes<-100

## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=celltypenormbeta, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataForCellCompEstimation.rdata")

## re run to select coef probes with 450K data
annoObj <-  minfi::getAnnotationObject("IlluminaHumanMethylationEPICanno.ilm10b4.hg19")
all <- minfi:::.availableAnnotation(annoObj)$defaults
newfData <- do.call(cbind, lapply(all, function(wh) {
        minfi:::.annoGet(wh, envir = annoObj@data)
}))
newfData<-newfData[rownames(celltypenormbeta),]

compData <- pickCompProbes(rawbetas=celltypenormbeta[which(newfData$Methyl450_Loci == "TRUE"),], cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)

braincelldata450K<-compData$coefEsts
save(braincelldata450K, file = "RefDataForCellCompEstimation450K.rdata")


library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# ANALYSIS:  Per-locus statistics only, no classification data

log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "per-locus-only-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda")
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda", args = clargs)
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-tasampled-data.rda", args = clargs)
}

load(pop_data_file)
load(ta_sampled_data_file)
flog.info("Loaded data file: %s", pop_data_file, name='cl')
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-4 data sets for per-locus only predictors", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
# dev = TRUE gets ignored on a Linux server and uses the full set of cores
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (2:10)*50,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# set up combined_results data frames
experiment_names <- c("Per-Locus Population Census")
perlocus_results <- data.frame()
perlocus_results_roc <- NULL
perlocus_results_model <- NULL
perlocus_results_cm <- NULL

###### Population Data ######

flog.info("Starting analysis of population data without per-locus values only", name='cl')

# first row of combined_results
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq4_pop_df$two_class_label <- factor(ifelse(eq4_pop_df$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "configuration_slatkin", "num_trait_configurations")

#model <- train_randomforest(eq4_pop_df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq4_pop_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

perlocus_results_model[["perlocus_pop"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
perlocus_results_cm[["perlocus_pop"]] <- cm

# All other analyses record these
results$sample_size <- 0
results$ta_duration <- 0

# calculate a ROC curve
perlocus_pop_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(perlocus_pop_roc$auc@y.values)
perlocus_results_roc[["perlocus_pop"]] <- perlocus_pop_roc

perlocus_results <- rbind(perlocus_results, results)

############## Complete Processing and Save combined_results ##########3

# save objects from the environment
if(length(clargs) == 0) {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "per-locus-analysis-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "per-locus-analysis-gbm-dfonly.RData")

} else {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "per-locus-analysis-gbm.RData",
                              args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "per-locus-analysis-gbm-dfonly.RData", args = clargs)

}

flog.info("Saving combined_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(perlocus_results, perlocus_results_model, perlocus_results_cm, perlocus_results_roc, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(perlocus_results, file=image_file_results)

# End
flog.info("Analysis complete", name='cl')


root = 'C:/Users/oxc140530/Documents/Google Drive/UTDALLAS/CS 6301 - Soft. Comprehension and Analysis/Project/BRE/Results/terms/'
systems = c('jabref', 'ofbiz', 'openbravo')

system = systems[1]
terms_file = paste(root, 'terms_', system, '.csv', sep = "")

#read the csv
data_terms = read.csv(terms_file, sep = ";", header = TRUE)

freq = table(data_terms$Lemma)
freq_frame = as.data.frame(freq)
barplot(freq[freq > quantile(freq_frame$Freq, .75) ])

barplot(freq[freq > 5000 ])

#--------------------------------

freq2 = table(data_terms$Lemma, data_terms$File)
freq2 = as.data.frame(freq2)
colnames(freq2) <- c("Lemma", "File", "Frequencies")
freq2 = subset(freq2, Frequencies!=0)
freq2  = table(freq2$Lemma)
freq2 = as.data.frame(freq2)
colnames(freq2) <- c("Lemma", "Frequencies")
freq2 = subset(freq2, Frequencies!=0)
freq2 = freq2[!duplicated(freq2[,]), ]

sort_freq2 = freq2[with(freq2, order(-Frequencies)), ]
sort_freq21 = freq2[with(freq2, order( Frequencies)), ]

#--------------------------------
#dummy
View(freq_frame[with(freq_frame, order(-Freq)), ])

summary(freq_frame$Freq)

boxplot(freq_frame$Freq)

View(freq2)