> # LOADING PACKAGES BY C. MOREFIELD
> if (!requireNamespace("BiocManager", quietly = TRUE))
+        install.packages("BiocManager")
Installing package into ‘/Users/jcma/Library/R/3.6/library’
(as ‘lib’ is unspecified)
--- Please select a CRAN mirror for use in this session ---
trying URL 'https://cran.mtu.edu/bin/macosx/el-capitan/contrib/3.6/BiocManager_1.30.10.tgz'
Content type 'application/x-gzip' length 94951 bytes (92 KB)
==================================================
downloaded 92 KB

The downloaded binary packages are in
	/var/folders/hw/9_s9ccyj1vgc6cj45649jt7w0000gq/T//RtmpbIiv9T/downloaded_packages
> BiocManager::install()
Bioconductor version 3.10 (BiocManager 1.30.10), R 3.6.2 (2019-12-12)
Installing package(s) 'BiocVersion'
trying URL 'https://bioconductor.org/packages/3.10/bioc/bin/macosx/el-capitan/contrib/3.6/BiocVersion_3.10.1.tgz'
Content type 'application/x-gzip' length 5574 bytes
==================================================
downloaded 5574 bytes

The downloaded binary packages are in
	/var/folders/hw/9_s9ccyj1vgc6cj45649jt7w0000gq/T//RtmpbIiv9T/downloaded_packages
Installation path not writeable, unable to update packages: boot, foreign, lattice, MASS, nlme, nnet, survival
> BiocManager::install("MASS")
Bioconductor version 3.10 (BiocManager 1.30.10), R 3.6.2 (2019-12-12)
Installing package(s) 'MASS'
trying URL 'https://cran.mtu.edu/bin/macosx/el-capitan/contrib/3.6/MASS_7.3-51.5.tgz'
Content type 'application/x-gzip' length 1160968 bytes (1.1 MB)
==================================================
downloaded 1.1 MB

The downloaded binary packages are in
	/var/folders/hw/9_s9ccyj1vgc6cj45649jt7w0000gq/T//RtmpbIiv9T/downloaded_packages
Installation path not writeable, unable to update packages: boot, foreign, lattice, MASS, nlme, nnet, survival
> install.packages("R0")
Installing package into ‘/Users/jcma/Library/R/3.6/library’
(as ‘lib’ is unspecified)
trying URL 'https://cran.mtu.edu/bin/macosx/el-capitan/contrib/3.6/R0_1.2-6.tgz'
Content type 'application/x-gzip' length 219977 bytes (214 KB)
==================================================
downloaded 214 KB

The downloaded binary packages are in
	/var/folders/hw/9_s9ccyj1vgc6cj45649jt7w0000gq/T//RtmpbIiv9T/downloaded_packages
> ## Demo file
> library(R0)
Loading required package: MASS
>
> # Generating an epidemic with given parameters
> mGT <- generation.time("gamma", c(3,1.5))
> mEpid <- sim.epid(epid.nb=1, GT=mGT, epid.length=30, family="poisson", R0=1.67, peak.value=500)
> mEpid <- mEpid[,1]
> # Running estimations
> est <- estimate.R(epid=mEpid, GT=mGT, methods=c("EG","ML","TD"))
Waiting for profiling to be done...
Warning messages:
1: In est.R0.TD(epid = c(1, 1, 1, 1, 1, 3, 1, 2, 1, 6, 2, 6, 4, 12,  :
  Simulations may take several minutes.
2: In est.R0.TD(epid = c(1, 1, 1, 1, 1, 3, 1, 2, 1, 6, 2, 6, 4, 12,  :
  Using initial incidence as initial number of cases.
>
> # Model estimates and goodness of fit can be plotted
> plot(est)
> plotfit(est)
# Sensitivity analysis for the EG estimation; influence of begin/end dates
s.a <- sensitivity.analysis(res=est$estimates$EG, begin=1:15, end=16:30, sa.type="time")
# This sensitivity analysis can be plotted
plot(s.a)

# RUN PATTERN DEVELOPED BY C. MOREFIELD and ABSTRACTED by J. Mallery

fetch_JHU_Data <- function() {
	csv <- getURL("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_19-covid-Confirmed.csv")
	data <- read.csv(text = csv, check.names = F)
	names(data)[1] <- "ProvinceState"
	names(data)[2] <- "CountryRegion"
	numberColumns <- length(names(data))
	data.table(data) }

trimLeading <- function(x, value=0) {
	w <- which.max(cummax(x != value))
	x[seq.int(w, length(x))] }

extract_country_data <- function (name, data) {
	cdata <- data[CountryRegion == name]
	cdata}

extract_ProvinceState_data <- function (name, data) {data[ProvinceState == name] }

prepare_data <- function (cdata) {
	cdata <- cdata[,5:numberColumns]
	names(cdata) <- NULL
	cdata <- unlist(c(cdata))
	cdata <- append(cdata[1], diff(cdata))
	cdata <- trimLeading(cdata, value = 0)
	cdata}

# SERIAL TIME INTERVAL
GT.cov2 <- generation.time("gamma", c(3.96, 0.41))
# EUROPE
epid.count <- prepare_data(extract_ProvinceState_data("France", my_data))
R.France <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.France

epid.count <- prepare_data(extract_country_data("Germany", my_data))
R.Germany <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Germany

epid.count <- prepare_data(extract_country_data("Italy", my_data))
R.Italy <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Italy

epid.count <- prepare_data(extract_country_data("Spain", my_data))
R.Spain <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Spain

epid.count <- prepare_data(extract_ProvinceState_data("United Kingdom", my_data))
R.UK <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.UK

# MIDDLE EAST
epid.count <- prepare_data(extract_country_data("Iran", my_data))
R.Iran<- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Iran

# ASIA
epid.count <- prepare_data(extract_country_data("Korea, South", my_data))
R.SouthKorea <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.SouthKorea

epid.count <- prepare_data(extract_country_data("Singapore", my_data))
R.Singapore <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Singapore

# US States and Regions
epid.count <- prepare_data(extract_ProvinceState_data("New York", my_data))
R.NewYork <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.NewYork

epid.count <- prepare_data(extract_ProvinceState_data("New Hampshire", my_data))
R.NewHampshire <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.NewHampshire

epid.count <- prepare_data(extract_ProvinceState_data("Illinois", my_data))
R.Illinois <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Illinois


pdf_file<-"pdf/timeseries_missing_values.pdf"
cairo_pdf(bg="grey98", pdf_file,width=13,height=9)

par(omi=c(0.65,0.75,0.95,0.75),mai=c(0.9,0.85,0.25,0.02),bg="antiquewhite2",family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
myData<-read.xls("myData/Work_hours_data.xls", encoding="latin1")
myColour<-rgb(139,35,35,maxColorValue=255)
y<-ts(myData$v1,start=1850,frequency=1)

# Define chart

plot(y,typ="n",axes=F,xlim=c(1850,2010),ylim=c(35,85),xlab="",ylab="Hours")

# Other elements

axis(1,cex.axis=1.25)
axis(2,cex.axis=1.25,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

myHeights<-c(40,50,60,70,80)
n<-length(myHeights)
for (i in 1:n) segments(1850,myHeights[i],2000,myHeights[i],col="white")
text(1905,68,"Great Britain",col=myColour,cex=1.5)

ptyp <- 19
source("scripts/inc_missing_values.r")

myColour<-rgb(39,139,16,maxColorValue=255)
y<-ts(myData$v2,start=1850,frequency=1)
source("scripts/inc_missing_values.r")
text(1960,38,"France",col=myColour,cex=1.5)

myColour<-rgb(0,0,139,maxColorValue=255)
y<-ts(myData$v3,start=1850,frequency=1)
source("scripts/inc_missing_values.r")
text(1872,52,"Germany",col=myColour,cex=1.5)

myColour<-rgb(205,149,12,maxColorValue=255)
y<-ts(myData$v4,start=1850,frequency=1)
source("scripts/inc_missing_values.r")
text(1990,44,"Belgium",col=myColour,cex=1.5)

# Titling

mtext("Development of weekly working time 1850-2010",3,line=0.2,adj=0,cex=2.6,family="Lato Black",outer=T)
mtext("Annual values ",3,line=-2,adj=0,cex=2,font=3,outer=T)
mtext("Source: Special analysis",1,line=0,adj=1,cex=1.25,font=3,outer=T)
dev.off()


#obter o maior entre dois números
maiorDe2Numeros <- function(x, y) {
  if(x > y) {
    return(x)
  } else {
    return(y)
  }
}

maiorDe3Numeros <- function(x, y, z) {
  return(maiorDe2Numeros(maiorDe2Numeros(x, y), z))
}


rm(list=ls())

library(readr)
library(plyr)
library(data.table)
library(lmerTest)

d<-read_csv('../../../empowermentexploration/resources/playerdata/data/alchemy2HumanDataMemory.csv')
emp<-read_csv('../../../empowermentexploration/data/gametree/element_empowerment/alchemy2_element_empowerment_dataframe.csv')

#d<-read_csv('../../../empowermentexploration/resources/playerdata/data/tinyalchemyHumanDataMemory.csv')
#emp<-read_csv('../../../empowermentexploration/data/gametree/element_empowerment/tinyalchemy_element_empowerment_dataframe.csv')

#d<-read_csv('../../../empowermentexploration/resources/playerdata/data/tinypixelsHumanDataMemory.csv')
#emp<-read_csv('../../../empowermentexploration/data/gametree/element_empowerment/tinypixels_element_empowerment_dataframe.csv')

d$results<-as.numeric(ifelse(d$results=='-1', '-1', gsub("\\[|\\]", "",d$results)))

#can also use predicted here.
d$empowerment<-0
for (i in 1:nrow(emp)){
  d$empowerment[d$results==emp$index[i]]<-emp$emp_value_true[i]
}

#calculate average success of last two rounds (0, 0.5 or 1) and scale it.
d$succ<-as.numeric(scale(ave(d$success, d$id, FUN=function(x){frollmean(x, n=2)})))

#calculate average true empowerment of last two rounds and scale it.
d$emp<-as.numeric(scale(ave(log(d$empowerment+1), d$id, FUN=function(x){frollmean(x, n=2)})))

#set variable to 0 if player's stop after current trial, else set to 1.
d$continue<-ifelse(d$trial==ave(d$trial, d$id, FUN=length)-1, 0, 1)

#assign uncertainty value 1 if at least one elment of combination hasn't been used before, otherwise 0

# for(i in 0:max(d$id)){
#   subsetid <- subset(d, id == i)
#   subsetid$ uncertainty <-0
#   subsetid$uncertainty[1] <- 1
#   if(nrow(subsetid)<2){
#     next
#   }
#   for(j in 2: nrow(subsetid)){
#     firstused = FALSE
#     secondused=FALSE
#     for(k in 1: (j-1)){
#       if(subsetid$first[j]==subsetid$first[k] | subsetid$first[j]==subsetid$second[k]){
#         firstused = TRUE
#       }
#       if(subsetid$second[j]==subsetid$first[k] | subsetid$second[j]==subsetid$second[k]){
#         secondused = TRUE
#       }
#     }
#     if(secondused == FALSE | firstused == FALSE){
#       subsetid$uncertainty[j] = 1
#     }
#   }
#   if(i == 0){
#     dwithuncertainty <- subsetid
#   }
#   else{
#     dwithuncertainty <- rbind(dwithuncertainty,subsetid)
#   }
# }

m1<-glmer(continue~succ+(1|id), family='binomial', data=d, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(m1)
AIC(m1)

m2<-glmer(continue~emp+(1|id), family='binomial', data=d, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(m2)
AIC(m2)

m3<-glmer(continue~emp+succ+(1|id), family='binomial', data=d, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(m3)
AIC(m3)

#m4<-glmer(continue~uncertainty+(1|id), family='binomial', data=dwithuncertainty, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#summary(m4)
#AIC(m4)

#m5<-glmer(continue~uncertainty+emp+(1|id), family='binomial', data=dwithuncertainty, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#summary(m5)
#AIC(m5)

#m6<-glmer(continue~uncertainty+succ+(1|id), family='binomial', data=dwithuncertainty, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#summary(m6)
#AIC(m6)

#m7<-glmer(continue~uncertainty+emp+succ+(1|id), family='binomial', data=dwithuncertainty, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#summary(m7)
#AIC(m7)


#!/usr/bin/env Rscript

library(ggplot2)
library(gridExtra)
library(reshape2)

X <- read.delim("./output/test.csv", sep=",", header=FALSE)
colnames(X) <- c("mthd","parameter","error","time")
X$method <- as.factor(X$mthd)

summary(X)

p <-ggplot(data=X, aes(parameter, error)) +
	geom_point(aes(color=method)) +
	geom_line(aes(color=method)) +
	scale_y_log10() +
	xlab("Parameter") +
	ylab("Normalized Error")
ggsave(file="./img/test_errors.png", width=5, height=4, dpi=100)

p1 <-ggplot(data=X, aes(parameter, time)) +
	geom_point(aes(color = method)) +
	geom_line(aes(color = method)) +
	xlab("Parameter") +
	ylab("Time")
ggsave(file="./img/test_times.png", width=5, height=4, dpi=100)

p2 <-ggplot(data=X, aes(error, time)) +
	geom_point(aes(color = method)) +
	#geom_line(aes(color = method)) +
	geom_smooth(aes(color=method), method = "lm") +
	scale_y_log10() +
	scale_x_log10() +
	xlab("Error") +
	ylab("Time")
ggsave(file="./img/test_times-error.png", width=5, height=4, dpi=100)


library(Cairo)

G1Cells = function( wellPath, G1, DNAChannel=1, zCutoff=2.5 ){
  DNA    = read.table( paste( wellPath, '-', DNAChannel, '.csv',sep='' ), stringsAsFactors=F, header=T, sep=',')
  cvs    = DNA$std_nucleus / DNA$mean_nucleus
  keep   = cvs < G1$CV.max & cvs > G1$CV.min

  logDNA = log( DNA$sum_nucleus )
  keep   = keep & logDNA < G1$mean.1 + zCutoff*G1$sd.1 & logDNA > G1$mean.1 - zCutoff*G1$sd.1

  return( keep )
}

CairoSVG('ligandInformation',width=5,height=5)
par(mfrow=c(2,2))

#### Plot distributions from TI01/3 to show MI of TGFB3 or BMP4

##### The following file will only exist after this script has been
##### run, followed by the mutual_information_readouts.m script
mutualInfoFile  = 'data/ligandInformation.csv'
#####

data        = read.table('W:/2013_06_wnt_tgfb_crosstalk/TI03/TI03_summaryStats.csv',header=T,sep=',',stringsAsFactors=F)

segRoot     = paste( 'W:/2013_06_wnt_tgfb_crosstalk/plates/',
                     '20140317_TI03',
                    '/segmentation/NUCLEI_DATA/',sep='')
G1          = read.table("W:/2013_06_wnt_tgfb_crosstalk/plates/20140317_TI03/segmentation/SKMEL2_G1.csv",header=T,sep=',',stringsAsFactors=F)
incol       = 'blue'
readout     = 'Smad23'
features    = c('sum_nucleus')
channel     = '2'
bins        = 20
concentrations = c(0,12.15)

for( feature in features){
  subdata    = data[data$celltype=='SKMEL2' &
                      data[,paste('marker',channel,sep='.')]==readout,]
  wells = c()
  xlims = c(Inf,-Inf)
  treatment = unique(subdata$treatment)
  for( concentration in concentrations ){
    # Find well with median well-level value
    wells  = c(wells,subdata$well[subdata$concentration==concentration])
  }
  wells    = matrix(wells,nrow=3)
  colnames(wells) = as.character(concentrations)

  hists = c()
  xlims = c(Inf,-Inf)
  for( concentration in concentrations ){
    allVals = c()
    for( well in wells[,as.character(concentration)]){
      wellpath    = paste(segRoot,well,sep='')
      singleCells = read.table( paste( wellpath,'-',channel,'.csv',sep='' ),
                                sep=',', header=T, stringsAsFactors=F )
      dna         = read.table( paste( wellpath,'-1.csv',sep='' ),
                                sep=',', header=T, stringsAsFactors=F )
      keepers     = G1Cells(wellpath,G1)
      singleCells = singleCells[keepers,paste(feature)]
      dna         = dna[keepers, paste(feature)]
      # Normalize!
      fit         = lm( log2(singleCells) ~ log2(dna) )
      singleCells = 2^(median(log2(singleCells)) + fit$residuals)
      allVals     = c(allVals,singleCells)

    }
    allVals = log2(allVals)
    # Trim the outliers
    allVals = allVals[allVals<(median(allVals)+3*mad(allVals)) &
                        allVals>(median(allVals)-3*mad(allVals))]
    # Write to file for idiot-Matlab
    write.csv(allVals,paste('data/',treatment,concentration,feature,'csv',sep='.'),
              row.names=F)
    hists[[as.character(concentration)]] = hist(allVals,breaks=bins,plot=F)
    xlims = c(min(xlims[1],hists[[as.character(concentration)]]$mids),
              max(xlims[2],hists[[as.character(concentration)]]$mids))
  }

  # Set up a plot
  plot(NA,NA,ylim=c(0,1),xlim=2^xlims, main=feature,
       xlab=readout,
       ylab='Frequency', yaxt='n')
  cols = c('black',incol)
  names(cols) = as.character(concentrations)
  for( concentration in concentrations ){
    lines( 2^hists[[as.character(concentration)]]$mids,
           hists[[as.character(concentration)]]$density/max(hists[[as.character(concentration)]]$density),
           col=cols[as.character(concentration)],lwd=2)
  }
  legend('topright',treatment,text.col=cols[as.character(concentration)],bty='n')
  if( file.exists(mutualInfoFile) ){
    mutualInfo = read.table(mutualInfoFile,header=T,sep=',')
    miMean     = mutualInfo[paste(treatment,feature,'meanMI',sep='.')]
    miSd       = mutualInfo[paste(treatment,feature,'sdMI',sep='.')]
    legend('right',c(paste(round(miMean,2),'+/-',
                           round(miSd,  2)),
                     paste('n=(',sum(hists[[1]]$counts),',',
                           sum(hists[[2]]$counts),')',sep='')),
           bty='n')
  }

}

data   = read.table('W:/2013_06_wnt_tgfb_crosstalk/TI01/TI01.1_summaryStats.csv',header=T,sep=',',stringsAsFactors=F)
data   = rbind(data,
               read.table('W:/2013_06_wnt_tgfb_crosstalk/TI01/TI01.2_summaryStats.csv',header=T,sep=',',stringsAsFactors=F))

segRoots    = paste( 'W:/2013_06_wnt_tgfb_crosstalk/plates/20140317_TI01.',
                     1:2,
                     '/segmentation/NUCLEI_DATA/',sep='')

G1          = read.table("W:/2013_06_wnt_tgfb_crosstalk/plates/20140317_TI01.1/segmentation/SKMEL2_G1.csv",
                         header=T,sep=',',stringsAsFactors=F)
readouts    = c('Smad23','pSmad158','CTNNB1')
incols      = c('blue','darkgreen','darkred')
names(incols) = readouts
channels    = c('2','2','3')
names(channels) = readouts
bins        = 20
allConcentrations = matrix(c(0,12.15,
                          0,8.1,
                          0,729 ),nrow=2)
colnames( allConcentrations ) = readouts

for( readout in readouts ){
  for( feature in features){
    channel    = channels[readout]
    subdata    = data[data$celltype=='SKMEL2' &
                        data[,paste('marker',channel,sep='.')]==readout,]
    treatment  = unique(subdata$treatment)
    wells = c()
    xlims = c(Inf,-Inf)
    concentrations = allConcentrations[,readout]
    names(segRoots) = as.character(concentrations)

    for( concentration in concentrations ){
      # Find well with median well-level value
      wells  = c(wells,subdata$well[subdata$concentration==concentration])
    }
    wells    = matrix(wells,nrow=3)
    colnames(wells) = as.character(concentrations)

    hists = c()
    xlims = c(Inf,-Inf)
    for( concentration in concentrations ){
      allVals = c()
      for( well in wells[,as.character(concentration)]){
        wellpath    = paste(segRoots[as.character(concentration)],well,sep='')
        singleCells = read.table( paste( wellpath,'-',channel,'.csv',sep='' ),
                                  sep=',', header=T, stringsAsFactors=F )
        dna         = read.table( paste( wellpath,'-1.csv',sep='' ),
                                  sep=',', header=T, stringsAsFactors=F )
        keepers     = G1Cells(wellpath,G1)
        singleCells = singleCells[keepers,paste(feature)]
        dna         = dna[keepers, paste(feature)]
        # Normalize!
        fit         = lm( log2(singleCells) ~ log2(dna) )
        singleCells = 2^(median(log2(singleCells)) + fit$residuals)
        allVals     = c(allVals,singleCells)

      }
      allVals = log2(allVals)
      # Trim the outliers
      allVals = allVals[allVals<(median(allVals)+3*mad(allVals)) &
                          allVals>(median(allVals)-3*mad(allVals))]
      # Write to file for idiot-Matlab
      write.csv(allVals,paste('data/',treatment,concentration,feature,'csv',sep='.'),
                row.names=F)
      hists[[as.character(concentration)]] = hist(allVals,breaks=bins,plot=F)
      xlims = c(min(xlims[1],hists[[as.character(concentration)]]$mids),
                max(xlims[2],hists[[as.character(concentration)]]$mids))
    }

    # Set up a plot
    plot(NA,NA,ylim=c(0,1),xlim=2^xlims, main=feature,
         xlab=readout,
         ylab='Frequency', yaxt='n')
    cols = c('black',incols[readout])
    names(cols) = as.character(concentrations)
    for( concentration in concentrations ){
      lines( 2^hists[[as.character(concentration)]]$mids,
             hists[[as.character(concentration)]]$density/max(hists[[as.character(concentration)]]$density),
             col=cols[as.character(concentration)],lwd=2)
    }
    legend('topright',treatment,text.col=cols[as.character(concentration)],bty='n')
    if( file.exists(mutualInfoFile) ){
      mutualInfo = read.table(mutualInfoFile,header=T,sep=',')
      miMean     = mutualInfo[paste(treatment,feature,'meanMI',sep='.')]
      miSd       = mutualInfo[paste(treatment,feature,'sdMI',sep='.')]
      legend('right',c(paste(round(miMean,2),'+/-',
                             round(miSd,  2)),
                       paste('n=(',sum(hists[[1]]$counts),',',
                             sum(hists[[2]]$counts),')',sep='')),
             bty='n')
    }
  }
}

dev.off()


emma.kinship <- function(snps, method="additive", use="all") {
  n0 <- sum(snps==0,na.rm=TRUE)
  nh <- sum(snps==0.5,na.rm=TRUE)
  n1 <- sum(snps==1,na.rm=TRUE)
  nNA <- sum(is.na(snps))

  stopifnot(n0+nh+n1+nNA == length(snps))

  if ( method == "dominant" ) {
    flags <- matrix(as.double(rowMeans(snps,na.rm=TRUE) > 0.5),nrow(snps),ncol(snps))
    snps[!is.na(snps) & (snps == 0.5)] <- flags[!is.na(snps) & (snps == 0.5)]
  }
  else if ( method == "recessive" ) {
    flags <- matrix(as.double(rowMeans(snps,na.rm=TRUE) < 0.5),nrow(snps),ncol(snps))
    snps[!is.na(snps) & (snps == 0.5)] <- flags[!is.na(snps) & (snps == 0.5)]
  }
  else if ( ( method == "additive" ) && ( nh > 0 ) ) {
    dsnps <- snps
    rsnps <- snps
    flags <- matrix(as.double(rowMeans(snps,na.rm=TRUE) > 0.5),nrow(snps),ncol(snps))
    dsnps[!is.na(snps) & (snps==0.5)] <- flags[!is.na(snps) & (snps==0.5)]
    flags <- matrix(as.double(rowMeans(snps,na.rm=TRUE) < 0.5),nrow(snps),ncol(snps))
    rsnps[!is.na(snps) & (snps==0.5)] <- flags[!is.na(snps) & (snps==0.5)]
    snps <- rbind(dsnps,rsnps)
  }

  if ( use == "all" ) {
    mafs <- matrix(rowMeans(snps,na.rm=TRUE),nrow(snps),ncol(snps))
    snps[is.na(snps)] <- mafs[is.na(snps)]
  }
  else if ( use == "complete.obs" ) {
    snps <- snps[rowSums(is.na(snps))==0,]
  }

  n <- ncol(snps)
  K <- matrix(nrow=n,ncol=n)
  diag(K) <- 1

  for(i in 2:n) {
    for(j in 1:(i-1)) {
      x <- snps[,i]*snps[,j] + (1-snps[,i])*(1-snps[,j])
      K[i,j] <- sum(x,na.rm=TRUE)/sum(!is.na(x))
      K[j,i] <- K[i,j]
    }
  }
  return(K)
}

emma.eigen.L <- function(Z,K,complete=TRUE) {
  if ( is.null(Z) ) {
    return(emma.eigen.L.wo.Z(K))
  }
  else {
    return(emma.eigen.L.w.Z(Z,K,complete))
  }
}

emma.eigen.L.wo.Z <- function(K) {
  eig <- eigen(K,symmetric=TRUE)
  return(list(values=eig$values,vectors=eig$vectors))
}

emma.eigen.L.w.Z <- function(Z,K,complete=TRUE) {
  if ( complete == FALSE ) {
    vids <- colSums(Z)>0
    Z <- Z[,vids]
    K <- K[vids,vids]
  }
  eig <- eigen(K%*%crossprod(Z,Z),symmetric=FALSE,EISPACK=TRUE)
  return(list(values=eig$values,vectors=qr.Q(qr(Z%*%eig$vectors),complete=TRUE)))
}

emma.eigen.R <- function(Z,K,X,complete=TRUE) {
  if ( ncol(X) == 0 ) {
    return(emma.eigen.L(Z,K))
  }
  else if ( is.null(Z) ) {
    return(emma.eigen.R.wo.Z(K,X))
  }
  else {
    return(emma.eigen.R.w.Z(Z,K,X,complete))
  }
}

emma.eigen.R.wo.Z <- function(K, X) {
  n <- nrow(X)
  q <- ncol(X)
  S <- diag(n)-X%*%solve(crossprod(X,X))%*%t(X)
  eig <- eigen(S%*%(K+diag(1,n))%*%S,symmetric=TRUE)
  stopifnot(!is.complex(eig$values))
  return(list(values=eig$values[1:(n-q)]-1,vectors=eig$vectors[,1:(n-q)]))
}

emma.eigen.R.w.Z <- function(Z, K, X, complete = TRUE) {
  if ( complete == FALSE ) {
    vids <-  colSums(Z) > 0
    Z <- Z[,vids]
    K <- K[vids,vids]
  }
  n <- nrow(Z)
  t <- ncol(Z)
  q <- ncol(X)

  SZ <- Z - X%*%solve(crossprod(X,X))%*%crossprod(X,Z)
  eig <- eigen(K%*%crossprod(Z,SZ),symmetric=FALSE,EISPACK=TRUE)
  if ( is.complex(eig$values) ) {
    eig$values <- Re(eig$values)
    eig$vectors <- Re(eig$vectors)
  }
  qr.X <- qr.Q(qr(X))
  return(list(values=eig$values[1:(t-q)],
              vectors=qr.Q(qr(cbind(SZ%*%eig$vectors[,1:(t-q)],qr.X)),
                complete=TRUE)[,c(1:(t-q),(t+1):n)]))
}

emma.delta.ML.LL.wo.Z <- function(logdelta, lambda, etas, xi) {
  n <- length(xi)
  delta <- exp(logdelta)
  return( 0.5*(n*(log(n/(2*pi))-1-log(sum((etas*etas)/(lambda+delta))))-sum(log(xi+delta))) )
}

emma.delta.ML.LL.w.Z <- function(logdelta, lambda, etas.1, xi.1, n, etas.2.sq ) {
  t <- length(xi.1)
  delta <- exp(logdelta)
#  stopifnot(length(lambda) == length(etas.1))
  return( 0.5*(n*(log(n/(2*pi))-1-log(sum(etas.1*etas.1/(lambda+delta))+etas.2.sq/delta))-(sum(log(xi.1+delta))+(n-t)*logdelta)) )
}

emma.delta.ML.dLL.wo.Z <- function(logdelta, lambda, etas, xi) {
  n <- length(xi)
  delta <- exp(logdelta)
  etasq <- etas*etas
  ldelta <- lambda+delta
  return( 0.5*(n*sum(etasq/(ldelta*ldelta))/sum(etasq/ldelta)-sum(1/(xi+delta))) )
}

emma.delta.ML.dLL.w.Z <- function(logdelta, lambda, etas.1, xi.1, n, etas.2.sq ) {
  t <- length(xi.1)
  delta <- exp(logdelta)
  etasq <- etas.1*etas.1
  ldelta <- lambda+delta
  return( 0.5*(n*(sum(etasq/(ldelta*ldelta))+etas.2.sq/(delta*delta))/(sum(etasq/ldelta)+etas.2.sq/delta)-(sum(1/(xi.1+delta))+(n-t)/delta) ) )
}

emma.delta.REML.LL.wo.Z <- function(logdelta, lambda, etas) {
  nq <- length(etas)
  delta <-  exp(logdelta)
  return( 0.5*(nq*(log(nq/(2*pi))-1-log(sum(etas*etas/(lambda+delta))))-sum(log(lambda+delta))) )
}

emma.delta.REML.LL.w.Z <- function(logdelta, lambda, etas.1, n, t, etas.2.sq ) {
  tq <- length(etas.1)
  nq <- n - t + tq
  delta <-  exp(logdelta)
  return( 0.5*(nq*(log(nq/(2*pi))-1-log(sum(etas.1*etas.1/(lambda+delta))+etas.2.sq/delta))-(sum(log(lambda+delta))+(n-t)*logdelta)) )
}

emma.delta.REML.dLL.wo.Z <- function(logdelta, lambda, etas) {
  nq <- length(etas)
  delta <- exp(logdelta)
  etasq <- etas*etas
  ldelta <- lambda+delta
  return( 0.5*(nq*sum(etasq/(ldelta*ldelta))/sum(etasq/ldelta)-sum(1/ldelta)) )
}

emma.delta.REML.dLL.w.Z <- function(logdelta, lambda, etas.1, n, t1, etas.2.sq ) {
  t <- t1
  tq <- length(etas.1)
  nq <- n - t + tq
  delta <- exp(logdelta)
  etasq <- etas.1*etas.1
  ldelta <- lambda+delta
  return( 0.5*(nq*(sum(etasq/(ldelta*ldelta))+etas.2.sq/(delta*delta))/(sum(etasq/ldelta)+etas.2.sq/delta)-(sum(1/ldelta)+(n-t)/delta)) )
}

emma.MLE <- function(y, X, K, Z=NULL, ngrids=100, llim=-10, ulim=10,
  esp=1e-10, eig.L = NULL, eig.R = NULL)
{
  n <- length(y)
  t <- nrow(K)
  q <- ncol(X)

#  stopifnot(nrow(K) == t)
  stopifnot(ncol(K) == t)
  stopifnot(nrow(X) == n)

  if ( det(crossprod(X,X)) == 0 ) {
    warning("X is singular")
    return (list(ML=0,delta=0,ve=0,vg=0))
  }

  if ( is.null(Z) ) {
    if ( is.null(eig.L) ) {
      eig.L <- emma.eigen.L.wo.Z(K)
    }
    if ( is.null(eig.R) ) {
      eig.R <- emma.eigen.R.wo.Z(K,X)
    }
    etas <- crossprod(eig.R$vectors,y)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim
    m <- length(logdelta)
    delta <- exp(logdelta)
    Lambdas <- matrix(eig.R$values,n-q,m) + matrix(delta,n-q,m,byrow=TRUE)
    Xis <- matrix(eig.L$values,n,m) + matrix(delta,n,m,byrow=TRUE)
    Etasq <- matrix(etas*etas,n-q,m)
    LL <- 0.5*(n*(log(n/(2*pi))-1-log(colSums(Etasq/Lambdas)))-colSums(log(Xis)))
    dLL <- 0.5*delta*(n*colSums(Etasq/(Lambdas*Lambdas))/colSums(Etasq/Lambdas)-colSums(1/Xis))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.ML.LL.wo.Z(llim,eig.R$values,etas,eig.L$values))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.ML.LL.wo.Z(ulim,eig.R$values,etas,eig.L$values))
    }

    for( i in 1:(m-1) )
      {
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.ML.dLL.wo.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.R$values, etas=etas, xi=eig.L$values)
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.ML.LL.wo.Z(r$root,eig.R$values, etas, eig.L$values))
        }
      }
#    optdelta <- exp(optlogdelta)
  }
  else {
    if ( is.null(eig.L) ) {
      eig.L <- emma.eigen.L.w.Z(Z,K)
    }
    if ( is.null(eig.R) ) {
      eig.R <- emma.eigen.R.w.Z(Z,K,X)
    }
    etas <- crossprod(eig.R$vectors,y)
    etas.1 <- etas[1:(t-q)]
    etas.2 <- etas[(t-q+1):(n-q)]
    etas.2.sq <- sum(etas.2*etas.2)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim

    m <- length(logdelta)
    delta <- exp(logdelta)
    Lambdas <- matrix(eig.R$values,t-q,m) + matrix(delta,t-q,m,byrow=TRUE)
    Xis <- matrix(eig.L$values,t,m) + matrix(delta,t,m,byrow=TRUE)
    Etasq <- matrix(etas.1*etas.1,t-q,m)
    #LL <- 0.5*(n*(log(n/(2*pi))-1-log(colSums(Etasq/Lambdas)+etas.2.sq/delta))-colSums(log(Xis))+(n-t)*log(deltas))
    dLL <- 0.5*delta*(n*(colSums(Etasq/(Lambdas*Lambdas))+etas.2.sq/(delta*delta))/(colSums(Etasq/Lambdas)+etas.2.sq/delta)-(colSums(1/Xis)+(n-t)/delta))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.ML.LL.w.Z(llim,eig.R$values,etas.1,eig.L$values,n,etas.2.sq))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.ML.LL.w.Z(ulim,eig.R$values,etas.1,eig.L$values,n,etas.2.sq))
    }

    for( i in 1:(m-1) )
      {
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.ML.dLL.w.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.R$values, etas.1=etas.1, xi.1=eig.L$values, n=n, etas.2.sq = etas.2.sq )
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.ML.LL.w.Z(r$root,eig.R$values, etas.1, eig.L$values, n, etas.2.sq ))
        }
      }
#    optdelta <- exp(optlogdelta)
  }

  maxdelta <- exp(optlogdelta[which.max(optLL)])
  maxLL <- max(optLL)
  if ( is.null(Z) ) {
    maxva <- sum(etas*etas/(eig.R$values+maxdelta))/n
  }
  else {
    maxva <- (sum(etas.1*etas.1/(eig.R$values+maxdelta))+etas.2.sq/maxdelta)/n
  }
  maxve <- maxva*maxdelta

  return (list(ML=maxLL,delta=maxdelta,ve=maxve,vg=maxva))
}

emma.MLE.noX <- function(y, K, Z=NULL, ngrids=100, llim=-10, ulim=10,
  esp=1e-10, eig.L = NULL)
{
  n <- length(y)
  t <- nrow(K)

#  stopifnot(nrow(K) == t)
  stopifnot(ncol(K) == t)

  if ( is.null(Z) ) {
    if ( is.null(eig.L) ) {
      eig.L <- emma.eigen.L.wo.Z(K)
    }
    etas <- crossprod(eig.L$vectors,y)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim
    m <- length(logdelta)
    delta <- exp(logdelta)
    Xis <- matrix(eig.L$values,n,m) + matrix(delta,n,m,byrow=TRUE)
    Etasq <- matrix(etas*etas,n,m)
    LL <- 0.5*(n*(log(n/(2*pi))-1-log(colSums(Etasq/Xis)))-colSums(log(Xis)))
    dLL <- 0.5*delta*(n*colSums(Etasq/(Xis*Xis))/colSums(Etasq/Xis)-colSums(1/Xis))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    #print(dLL)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.ML.LL.wo.Z(llim,eig.L$values,etas,eig.L$values))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.ML.LL.wo.Z(ulim,eig.L$values,etas,eig.L$values))
    }

    for( i in 1:(m-1) )
      {
        #if ( ( dLL[i]*dLL[i+1] < 0 ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.ML.dLL.wo.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.L$values, etas=etas, xi=eig.L$values)
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.ML.LL.wo.Z(r$root,eig.L$values, etas, eig.L$values))
        }
      }
#    optdelta <- exp(optlogdelta)
  }
  else {
    if ( is.null(eig.L) ) {
      eig.L <- emma.eigen.L.w.Z(Z,K)
    }
    etas <- crossprod(eig.L$vectors,y)
    etas.1 <- etas[1:t]
    etas.2 <- etas[(t+1):n]
    etas.2.sq <- sum(etas.2*etas.2)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim

    m <- length(logdelta)
    delta <- exp(logdelta)
    Xis <- matrix(eig.L$values,t,m) + matrix(delta,t,m,byrow=TRUE)
    Etasq <- matrix(etas.1*etas.1,t,m)
    #LL <- 0.5*(n*(log(n/(2*pi))-1-log(colSums(Etasq/Lambdas)+etas.2.sq/delta))-colSums(log(Xis))+(n-t)*log(deltas))
    dLL <- 0.5*delta*(n*(colSums(Etasq/(Xis*Xis))+etas.2.sq/(delta*delta))/(colSums(Etasq/Xis)+etas.2.sq/delta)-(colSums(1/Xis)+(n-t)/delta))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.ML.LL.w.Z(llim,eig.L$values,etas.1,eig.L$values,n,etas.2.sq))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.ML.LL.w.Z(ulim,eig.L$values,etas.1,eig.L$values,n,etas.2.sq))
    }

    for( i in 1:(m-1) )
      {
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.ML.dLL.w.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.L$values, etas.1=etas.1, xi.1=eig.L$values, n=n, etas.2.sq = etas.2.sq )
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.ML.LL.w.Z(r$root,eig.L$values, etas.1, eig.L$values, n, etas.2.sq ))
        }
      }
#    optdelta <- exp(optlogdelta)
  }

  maxdelta <- exp(optlogdelta[which.max(optLL)])
  maxLL <- max(optLL)
  if ( is.null(Z) ) {
    maxva <- sum(etas*etas/(eig.L$values+maxdelta))/n
  }
  else {
    maxva <- (sum(etas.1*etas.1/(eig.L$values+maxdelta))+etas.2.sq/maxdelta)/n
  }
  maxve <- maxva*maxdelta

  return (list(ML=maxLL,delta=maxdelta,ve=maxve,vg=maxva))
}

emma.REMLE <- function(y, X, K, Z=NULL, ngrids=100, llim=-10, ulim=10,
  esp=1e-10, eig.L = NULL, eig.R = NULL) {
  n <- length(y)
  t <- nrow(K)
  q <- ncol(X)

#  stopifnot(nrow(K) == t)
  stopifnot(ncol(K) == t)
  stopifnot(nrow(X) == n)

  if ( det(crossprod(X,X)) == 0 ) {
    warning("X is singular")
    return (list(REML=0,delta=0,ve=0,vg=0))
  }

  if ( is.null(Z) ) {
    if ( is.null(eig.R) ) {
      eig.R <- emma.eigen.R.wo.Z(K,X)
    }
    etas <- crossprod(eig.R$vectors,y)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim
    m <- length(logdelta)
    delta <- exp(logdelta)
    Lambdas <- matrix(eig.R$values,n-q,m) + matrix(delta,n-q,m,byrow=TRUE)
    Etasq <- matrix(etas*etas,n-q,m)
    LL <- 0.5*((n-q)*(log((n-q)/(2*pi))-1-log(colSums(Etasq/Lambdas)))-colSums(log(Lambdas)))
    dLL <- 0.5*delta*((n-q)*colSums(Etasq/(Lambdas*Lambdas))/colSums(Etasq/Lambdas)-colSums(1/Lambdas))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.REML.LL.wo.Z(llim,eig.R$values,etas))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.REML.LL.wo.Z(ulim,eig.R$values,etas))
    }

    for( i in 1:(m-1) )
      {
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.REML.dLL.wo.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.R$values, etas=etas)
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.REML.LL.wo.Z(r$root,eig.R$values, etas))
        }
      }
#    optdelta <- exp(optlogdelta)
  }
  else {
    if ( is.null(eig.R) ) {
      eig.R <- emma.eigen.R.w.Z(Z,K,X)
    }
    etas <- crossprod(eig.R$vectors,y)
    etas.1 <- etas[1:(t-q)]
    etas.2 <- etas[(t-q+1):(n-q)]
    etas.2.sq <- sum(etas.2*etas.2)

    logdelta <- (0:ngrids)/ngrids*(ulim-llim)+llim
    m <- length(logdelta)
    delta <- exp(logdelta)
    Lambdas <- matrix(eig.R$values,t-q,m) + matrix(delta,t-q,m,byrow=TRUE)
    Etasq <- matrix(etas.1*etas.1,t-q,m)
    dLL <- 0.5*delta*((n-q)*(colSums(Etasq/(Lambdas*Lambdas))+etas.2.sq/(delta*delta))/(colSums(Etasq/Lambdas)+etas.2.sq/delta)-(colSums(1/Lambdas)+(n-t)/delta))

    optlogdelta <- vector(length=0)
    optLL <- vector(length=0)
    if ( dLL[1] < esp ) {
      optlogdelta <- append(optlogdelta, llim)
      optLL <- append(optLL, emma.delta.REML.LL.w.Z(llim,eig.R$values,etas.1,n,t,etas.2.sq))
    }
    if ( dLL[m-1] > 0-esp ) {
      optlogdelta <- append(optlogdelta, ulim)
      optLL <- append(optLL, emma.delta.REML.LL.w.Z(ulim,eig.R$values,etas.1,n,t,etas.2.sq))
    }

    for( i in 1:(m-1) )
      {
        if ( ( dLL[i]*dLL[i+1] < 0-esp*esp ) && ( dLL[i] > 0 ) && ( dLL[i+1] < 0 ) )
        {
          r <- uniroot(emma.delta.REML.dLL.w.Z, lower=logdelta[i], upper=logdelta[i+1], lambda=eig.R$values, etas.1=etas.1, n=n, t1=t, etas.2.sq = etas.2.sq )
          optlogdelta <- append(optlogdelta, r$root)
          optLL <- append(optLL, emma.delta.REML.LL.w.Z(r$root,eig.R$values, etas.1, n, t, etas.2.sq ))
        }
      }
#    optdelta <- exp(optlogdelta)
  }

  maxdelta <- exp(optlogdelta[which.max(optLL)])
  maxLL <- max(optLL)
  if ( is.null(Z) ) {
    maxva <- sum(etas*etas/(eig.R$values+maxdelta))/(n-q)
  }
  else {
    maxva <- (sum(etas.1*etas.1/(eig.R$values+maxdelta))+etas.2.sq/maxdelta)/(n-q)
  }
  maxve <- maxva*maxdelta

  return (list(REML=maxLL,delta=maxdelta,ve=maxve,vg=maxva))
}

emma.ML.LRT <- function(ys, xs, K, Z=NULL, X0 = NULL, ngrids=100, llim=-10, ulim=10, esp=1e-10, ponly = FALSE) {
  if ( is.null(dim(ys)) || ncol(ys) == 1 ) {
    ys <- matrix(ys,1,length(ys))
  }
  if ( is.null(dim(xs)) || ncol(xs) == 1 ) {
    xs <- matrix(xs,1,length(xs))
  }
  if ( is.null(X0) ) {
    X0 <- matrix(1,ncol(ys),1)
  }

  g <- nrow(ys)
  n <- ncol(ys)
  m <- nrow(xs)
  t <- ncol(xs)
  q0 <- ncol(X0)
  q1 <- q0 + 1

  if ( !ponly ) {
    ML1s <- matrix(nrow=m,ncol=g)
    ML0s <- matrix(nrow=m,ncol=g)
    vgs <- matrix(nrow=m,ncol=g)
    ves <- matrix(nrow=m,ncol=g)
  }
  stats <- matrix(nrow=m,ncol=g)
  ps <- matrix(nrow=m,ncol=g)
  ML0 <- vector(length=g)

  stopifnot(nrow(K) == t)
  stopifnot(ncol(K) == t)
  stopifnot(nrow(X0) == n)

  if ( sum(is.na(ys)) == 0 ) {
    eig.L <- emma.eigen.L(Z,K)
    eig.R0 <- emma.eigen.R(Z,K,X0)

    for(i in 1:g) {
      ML0[i] <- emma.MLE(ys[i,],X0,K,Z,ngrids,llim,ulim,esp,eig.L,eig.R0)$ML
    }

    x.prev <- vector(length=0)

    for(i in 1:m) {
      vids <- !is.na(xs[i,])
      nv <- sum(vids)
      xv <- xs[i,vids]

      if ( ( mean(xv) <= 0 ) || ( mean(xv) >= 1 ) ) {
        if (!ponly) {
          stats[i,] <- rep(NA,g)
          vgs[i,] <- rep(NA,g)
          ves[i,] <- rep(NA,g)
          ML1s[i,] <- rep(NA,g)
          ML0s[i,] <- rep(NA,g)
        }
        ps[i,] = rep(1,g)
      }
      else if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          stats[i,] <- stats[i-1,]
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          ML1s[i,] <- ML1s[i-1,]
          ML0s[i,] <- ML0s[i-1,]
        }
        ps[i,] <- ps[i-1,]
      }
      else {
        if ( is.null(Z) ) {
          X <- cbind(X0[vids,,drop=FALSE],xs[i,vids])
          eig.R1 = emma.eigen.R.wo.Z(K[vids,vids],X)
        }
        else {
          vrows <- as.logical(rowSums(Z[,vids]))
          nr <- sum(vrows)
          X <- cbind(X0[vrows,,drop=FALSE],Z[vrows,vids]%*%t(xs[i,vids,drop=FALSE]))
          eig.R1 = emma.eigen.R.w.Z(Z[vrows,vids],K[vids,vids],X)
        }

        for(j in 1:g) {
          if ( nv == t ) {
            MLE <- emma.MLE(ys[j,],X,K,Z,ngrids,llim,ulim,esp,eig.L,eig.R1)
#            MLE <- emma.MLE(ys[j,],X,K,Z,ngrids,llim,ulim,esp,eig.L,eig.R1)
            if (!ponly) {
              ML1s[i,j] <- MLE$ML
              vgs[i,j] <- MLE$vg
              ves[i,j] <- MLE$ve
            }
            stats[i,j] <- 2*(MLE$ML-ML0[j])

          }
          else {
            if ( is.null(Z) ) {
              eig.L0 <- emma.eigen.L.wo.Z(K[vids,vids])
              MLE0 <- emma.MLE(ys[j,vids],X0[vids,,drop=FALSE],K[vids,vids],NULL,ngrids,llim,ulim,esp,eig.L0)
              MLE1 <- emma.MLE(ys[j,vids],X,K[vids,vids],NULL,ngrids,llim,ulim,esp,eig.L0)
            }
            else {
              if ( nr == n ) {
                MLE1 <- emma.MLE(ys[j,],X,K,Z,ngrids,llim,ulim,esp,eig.L)
              }
              else {
                eig.L0 <- emma.eigen.L.w.Z(Z[vrows,vids],K[vids,vids])
                MLE0 <- emma.MLE(ys[j,vrows],X0[vrows,,drop=FALSE],K[vids,vids],Z[vrows,vids],ngrids,llim,ulim,esp,eig.L0)
                MLE1 <- emma.MLE(ys[j,vrows],X,K[vids,vids],Z[vrows,vids],ngrids,llim,ulim,esp,eig.L0)
              }
            }
            if (!ponly) {
              ML1s[i,j] <- MLE1$ML
              ML0s[i,j] <- MLE0$ML
              vgs[i,j] <- MLE1$vg
              ves[i,j] <- MLE1$ve
            }
            stats[i,j] <- 2*(MLE1$ML-MLE0$ML)
          }
        }
        if ( ( nv == t ) && ( !ponly ) ) {
          ML0s[i,] <- ML0
        }
        ps[i,] <- pchisq(stats[i,],1,lower.tail=FALSE)
      }
    }
  }
  else {
    eig.L <- emma.eigen.L(Z,K)
    eig.R0 <- emma.eigen.R(Z,K,X0)

    for(i in 1:g) {
      vrows <- !is.na(ys[i,])
      if ( is.null(Z) ) {
        ML0[i] <- emma.MLE(ys[i,vrows],X0[vrows,,drop=FALSE],K[vrows,vrows],NULL,ngrids,llim,ulim,esp)$ML
      }
      else {
        vids <- colSums(Z[vrows,]>0)

        ML0[i] <- emma.MLE(ys[i,vrows],X0[vrows,,drop=FALSE],K[vids,vids],Z[vrows,vids],ngrids,llim,ulim,esp)$ML
      }
    }

    x.prev <- vector(length=0)

    for(i in 1:m) {
      vids <- !is.na(xs[i,])
      nv <- sum(vids)
      xv <- xs[i,vids]

      if ( ( mean(xv) <= 0 ) || ( mean(xv) >= 1 ) ) {
        if (!ponly) {
          stats[i,] <- rep(NA,g)
          vgs[i,] <- rep(NA,g)
          ves[i,] <- rep(NA,g)
          ML1s[i,] <- rep(NA,g)
          ML0s[,i] <- rep(NA,g)
        }
        ps[i,] = rep(1,g)
      }
      else if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          stats[i,] <- stats[i-1,]
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          ML1s[i,] <- ML1s[i-1,]
        }
        ps[i,] = ps[i-1,]
      }
      else {
        if ( is.null(Z) ) {
          X <- cbind(X0,xs[i,])
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.wo.Z(K,X)
          }
        }
        else {
          vrows <- as.logical(rowSums(Z[,vids]))
          X <- cbind(X0,Z[,vids,drop=FALSE]%*%t(xs[i,vids,drop=FALSE]))
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.w.Z(Z,K,X)
          }
        }

        for(j in 1:g) {
#          print(j)
          vrows <- !is.na(ys[j,])
          if ( nv == t ) {
            nr <- sum(vrows)
            if ( is.null(Z) ) {
              if ( nr == n ) {
                MLE <- emma.MLE(ys[j,],X,K,NULL,ngrids,llim,ulim,esp,eig.L,eig.R1)
              }
              else {
                MLE <- emma.MLE(ys[j,vrows],X[vrows,],K[vrows,vrows],NULL,ngrids,llim,ulim,esp)
              }
            }
            else {
              if ( nr == n ) {
                MLE <- emma.MLE(ys[j,],X,K,Z,ngrids,llim,ulim,esp,eig.L,eig.R1)
              }
              else {
                vtids <- as.logical(colSums(Z[vrows,,drop=FALSE]))
                MLE <- emma.MLE(ys[j,vrows],X[vrows,],K[vtids,vtids],Z[vrows,vtids],ngrids,llim,ulim,esp)
              }
            }

            if (!ponly) {
              ML1s[i,j] <- MLE$ML
              vgs[i,j] <- MLE$vg
              ves[i,j] <- MLE$ve
            }
            stats[i,j] <- 2*(MLE$ML-ML0[j])
          }
          else {
            if ( is.null(Z) ) {
              vtids <- vrows & vids
              eig.L0 <- emma.eigen.L(NULL,K[vtids,vtids])
              MLE0 <- emma.MLE(ys[j,vtids],X0[vtids,,drop=FALSE],K[vtids,vtids],NULL,ngrids,llim,ulim,esp,eig.L0)
              MLE1 <- emma.MLE(ys[j,vtids],X[vtids,],K[vtids,vtids],NULL,ngrids,llim,ulim,esp,eig.L0)
            }
            else {
              vtids <- as.logical(colSums(Z[vrows,])) & vids
              vtrows <- vrows & as.logical(rowSums(Z[,vids]))
              eig.L0 <- emma.eigen.L(Z[vtrows,vtids],K[vtids,vtids])
              MLE0 <- emma.MLE(ys[j,vtrows],X0[vtrows,,drop=FALSE],K[vtids,vtids],Z[vtrows,vtids],ngrids,llim,ulim,esp,eig.L0)
              MLE1 <- emma.MLE(ys[j,vtrows],X[vtrows,],K[vtids,vtids],Z[vtrows,vtids],ngrids,llim,ulim,esp,eig.L0)
            }
            if (!ponly) {
              ML1s[i,j] <- MLE1$ML
              vgs[i,j] <- MLE1$vg
              ves[i,j] <- MLE1$ve
              ML0s[i,j] <- MLE0$ML
            }
            stats[i,j] <- 2*(MLE1$ML-MLE0$ML)
          }
        }
        if ( ( nv == t ) && ( !ponly ) ) {
          ML0s[i,] <- ML0
        }
        ps[i,] <- pchisq(stats[i,],1,lower.tail=FALSE)
      }
    }
  }
  if ( ponly ) {
    return (ps)
  }
  else {
    return (list(ps=ps,ML1s=ML1s,ML0s=ML0s,stats=stats,vgs=vgs,ves=ves))
  }
}

emma.test <- function(ys, xs, K, Z=NULL, x0s = NULL, X0 = NULL, dfxs = 1, dfx0s = 1, use.MLE = FALSE, use.LRT = FALSE, ngrids = 100, llim = -10, ulim = 10, esp=1e-10, ponly = FALSE)
{
  stopifnot (dfxs > 0)

  if ( is.null(dim(ys)) || ncol(ys) == 1 ) {
    ys <- matrix(ys,1,length(ys))
  }

  if ( is.null(dim(xs)) || ncol(xs) == 1 ) {
    xs <- matrix(xs,1,length(xs))
  }
  nx <- nrow(xs)/dfxs

  if ( is.null(x0s) ) {
    dfx0s = 0
    x0s <- matrix(NA,0,ncol(xs))
  }
  # X0 automatically contains intercept. If no intercept is to be used,
  #    X0 should be matrix(nrow=ncol(ys),ncol=0)
  if ( is.null(X0) ) {
    X0 <- matrix(1,ncol(ys),1)
  }

  stopifnot(Z == NULL) # The case where Z is not null is not implemented

  ny <- nrow(ys)
  iy <- ncol(ys)
  ix <- ncol(xs)

  stopifnot(nrow(K) == ix)
  stopifnot(ncol(K) == ix)
  stopifnot(nrow(X0) == iy)

  if ( !ponly ) {
    LLs <- matrix(nrow=m,ncol=g)
    vgs <- matrix(nrow=m,ncol=g)
    ves <- matrix(nrow=m,ncol=g)
  }
  dfs <- matrix(nrow=m,ncol=g)
  stats <- matrix(nrow=m,ncol=g)
  ps <- matrix(nrow=m,ncol=g)

  # The case with no missing phenotypes
  if ( sum(is.na(ys)) == 0 ) {
    if ( ( use.MLE ) || ( !use.LRT ) ) {
      eig.L0 <- emma.eigen.L(Z,K)
    }
    if ( dfx0s == 0 ) {
      eig.R0 <- emma.eigen.R(Z,K,X0)
    }
    x.prev <- NULL

    for(i in 1:ix) {
      x1 <- t(xs[(dfxs*(i-1)+1):(dfxs*i),,drop=FALSE])
      if ( dfxs0 == 0 ) {
        x0 <- X0
      }
      else {
        x0 <- cbind(t(x0s[(dfx0s*(i-1)+1):(dfx0s*i),,drop=FALSE]),X0)
      }
      x <-  cbind(x1,x0)
      xvids <- rowSums(is.na(x) == 0)
      nxv <- sum(xvids)
      xv <- x[xvids,,drop=FALSE]
      Kv <- K[xvids,xvids,drop=FALSE]
      yv <- ys[j,xvids]

      if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          dfs[i,] <- dfs[i-1,]
          REMLs[i,] <- REMLs[i-1,]
          stats[i,] <- stats[i-1,]
        }
        ps[i,] <- ps[i-1,]
      }
      else {
        eig.R1 = emma.eigen.R.wo.Z(Kv,xv)

        for(j in 1:iy) {
          if ( ( use.MLE ) || ( !use.LRT ) ) {
            if ( nxv < t ) {
              # NOTE: this complexity can be improved by avoiding eigen computation for identical missing patterns
              eig.L0v <- emma.eigen.L.wo.Z(Kv)
            }
            else {
              eig.L0v <- eig.L0
            }
          }

          if ( use.MLE ) {
            MLE <- emma.REMLE(yv,xv,Kv,NULL,ngrids,llim,ulim,esp,eig.R1)
            stop("Not implemented yet")
          }
          else {
            REMLE <- emma.REMLE(yv,xv,Kv,NULL,ngrids,llim,ulim,esp,eig.R1)
            if ( use.LRT ) {
              stop("Not implemented yet")
            }
            else {
              U <- eig.L0v$vectors * matrix(sqrt(1/(eig.L0v$values+REMLE$delta)),t,t,byrow=TRUE)
              dfs[i,j] <- length(eig.R1$values)
              yt <- crossprod(U,yv)
              xt <- crossprod(U,xv)
              ixx <- solve(crossprod(xt,xt))
              beta <- ixx%*%crossprod(xt,yt)
              if ( dfxs == 1 ) {
                stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)
              }
              else {
                model.m <- c(rep(1,dfxs),rep(0,ncol(xv)-dfxs))
                stats[i,j] <-
                  crossprod(crossprod(solve(crossprod(crossprod(iXX,model.m),
                                                      model.m)),
                                      model.m*beta),model.m*beta)

              }
              if ( !ponly ) {
                vgs[i,j] <- REMLE$vg
                ves[i,j] <- REMLE$ve
                REMLs[i,j] <- REMLE$REML
              }
            }
          }
        }
        if ( dfxs == 1 ) {
          ps[i,] <- 2*pt(abs(stats[i,]),dfs[i,],lower.tail=FALSE)
        }
        else {
          ps[i,] <- pf(abs(stats[i,]),dfs[i,],lower.tail=FALSE)
        }
      }
    }
  }
  # The case with missing genotypes - not implemented yet
  else {
    stop("Not implemented yet")
    eig.L <- emma.eigen.L(Z,K)
    eig.R0 <- emma.eigen.R(Z,K,X0)

    x.prev <- vector(length=0)

    for(i in 1:m) {
      vids <- !is.na(xs[i,])
      nv <- sum(vids)
      xv <- xs[i,vids]

      if ( ( mean(xv) <= 0 ) || ( mean(xv) >= 1 ) ) {
        if (!ponly) {
          vgs[i,] <- rep(NA,g)
          ves[i,] <- rep(NA,g)
          REMLs[i,] <- rep(NA,g)
          dfs[i,] <- rep(NA,g)
        }
        ps[i,] = rep(1,g)
      }
      else if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          stats[i,] <- stats[i-1,]
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          REMLs[i,] <- REMLs[i-1,]
          dfs[i,] <- dfs[i-1,]
        }
        ps[i,] = ps[i-1,]
      }
      else {
        if ( is.null(Z) ) {
          X <- cbind(X0,xs[i,])
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.wo.Z(K,X)
          }
        }
        else {
          vrows <- as.logical(rowSums(Z[,vids,drop=FALSE]))
          X <- cbind(X0,Z[,vids,drop=FALSE]%*%t(xs[i,vids,drop=FALSE]))
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.w.Z(Z,K,X)
          }
        }

        for(j in 1:g) {
          vrows <- !is.na(ys[j,])
          if ( nv == t ) {
            yv <- ys[j,vrows]
            nr <- sum(vrows)
            if ( is.null(Z) ) {
              if ( nr == n ) {
                REMLE <- emma.REMLE(yv,X,K,NULL,ngrids,llim,ulim,esp,eig.R1)
                U <- eig.L$vectors * matrix(sqrt(1/(eig.L$values+REMLE$delta)),n,n,byrow=TRUE)
              }
              else {
                eig.L0 <- emma.eigen.L.wo.Z(K[vrows,vrows,drop=FALSE])
                REMLE <- emma.REMLE(yv,X[vrows,,drop=FALSE],K[vrows,vrows,drop=FALSE],NULL,ngrids,llim,ulim,esp)
                U <- eig.L0$vectors * matrix(sqrt(1/(eig.L0$values+REMLE$delta)),nr,nr,byrow=TRUE)
              }
              dfs[i,j] <- nr-q1
            }
            else {
              if ( nr == n ) {
                REMLE <- emma.REMLE(yv,X,K,Z,ngrids,llim,ulim,esp,eig.R1)
                U <- eig.L$vectors * matrix(c(sqrt(1/(eig.L$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),n-t)),n,n,byrow=TRUE)
              }
              else {
                vtids <- as.logical(colSums(Z[vrows,,drop=FALSE]))
                eig.L0 <- emma.eigen.L.w.Z(Z[vrows,vtids,drop=FALSE],K[vtids,vtids,drop=FALSE])
                REMLE <- emma.REMLE(yv,X[vrows,,drop=FALSE],K[vtids,vtids,drop=FALSE],Z[vrows,vtids,drop=FALSE],ngrids,llim,ulim,esp)
                U <- eig.L0$vectors * matrix(c(sqrt(1/(eig.L0$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),nr-sum(vtids))),nr,nr,byrow=TRUE)
              }
              dfs[i,j] <- nr-q1
            }

            yt <- crossprod(U,yv)
            Xt <- crossprod(U,X[vrows,,drop=FALSE])
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)
            if ( !ponly ) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)
          }
          else {
            if ( is.null(Z) ) {
              vtids <- vrows & vids
              eig.L0 <- emma.eigen.L.wo.Z(K[vtids,vtids,drop=FALSE])
              yv <- ys[j,vtids]
              nr <- sum(vtids)
              REMLE <- emma.REMLE(yv,X[vtids,,drop=FALSE],K[vtids,vtids,drop=FALSE],NULL,ngrids,llim,ulim,esp)
              U <- eig.L0$vectors * matrix(sqrt(1/(eig.L0$values+REMLE$delta)),nr,nr,byrow=TRUE)
              Xt <- crossprod(U,X[vtids,,drop=FALSE])
              dfs[i,j] <- nr-q1
            }
            else {
              vtids <- as.logical(colSums(Z[vrows,,drop=FALSE])) & vids
              vtrows <- vrows & as.logical(rowSums(Z[,vids,drop=FALSE]))
              eig.L0 <- emma.eigen.L.w.Z(Z[vtrows,vtids,drop=FALSE],K[vtids,vtids,drop=FALSE])
              yv <- ys[j,vtrows]
              nr <- sum(vtrows)
              REMLE <- emma.REMLE(yv,X[vtrows,,drop=FALSE],K[vtids,vtids,drop=FALSE],Z[vtrows,vtids,drop=FALSE],ngrids,llim,ulim,esp)
              U <- eig.L0$vectors * matrix(c(sqrt(1/(eig.L0$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),nr-sum(vtids))),nr,nr,byrow=TRUE)
              Xt <- crossprod(U,X[vtrows,,drop=FALSE])
              dfs[i,j] <- nr-q1
            }
            yt <- crossprod(U,yv)
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)
            if ( !ponly ) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)

          }
        }
        ps[i,] <- 2*pt(abs(stats[i,]),dfs[i,],lower.tail=FALSE)
      }
    }
  }
  if ( ponly ) {
    return (ps)
  }
  else {
    return (list(ps=ps,REMLs=REMLs,stats=stats,dfs=dfs,vgs=vgs,ves=ves))
  }
}

emma.REML.t <- function(ys, xs, K, Z=NULL, X0 = NULL, ngrids=100, llim=-10, ulim=10, esp=1e-10, ponly = FALSE) {
  if ( is.null(dim(ys)) || ncol(ys) == 1 ) {
    ys <- matrix(ys,1,length(ys))
  }
  if ( is.null(dim(xs)) || ncol(xs) == 1 ) {
    xs <- matrix(xs,1,length(xs))
  }
  if ( is.null(X0) ) {
    X0 <- matrix(1,ncol(ys),1)
  }

  g <- nrow(ys)
  n <- ncol(ys)
  m <- nrow(xs)
  t <- ncol(xs)
  q0 <- ncol(X0)
  q1 <- q0 + 1

  stopifnot(nrow(K) == t)
  stopifnot(ncol(K) == t)
  stopifnot(nrow(X0) == n)

  if ( !ponly ) {
    REMLs <- matrix(nrow=m,ncol=g)
    vgs <- matrix(nrow=m,ncol=g)
    ves <- matrix(nrow=m,ncol=g)
  }
  dfs <- matrix(nrow=m,ncol=g)
  stats <- matrix(nrow=m,ncol=g)
  ps <- matrix(nrow=m,ncol=g)

  if ( sum(is.na(ys)) == 0 ) {
    eig.L <- emma.eigen.L(Z,K)

    x.prev <- vector(length=0)

    for(i in 1:m) {
      vids <- !is.na(xs[i,])
      nv <- sum(vids)
      xv <- xs[i,vids]

      if ( ( mean(xv) <= 0 ) || ( mean(xv) >= 1 ) ) {
        if ( !ponly ) {
          vgs[i,] <- rep(NA,g)
          ves[i,] <- rep(NA,g)
          dfs[i,] <- rep(NA,g)
          REMLs[i,] <- rep(NA,g)
          stats[i,] <- rep(NA,g)
        }
        ps[i,] = rep(1,g)

      }
      else if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          dfs[i,] <- dfs[i-1,]
          REMLs[i,] <- REMLs[i-1,]
          stats[i,] <- stats[i-1,]
        }
        ps[i,] <- ps[i-1,]
      }
      else {
        if ( is.null(Z) ) {
          X <- cbind(X0[vids,,drop=FALSE],xs[i,vids])
          eig.R1 = emma.eigen.R.wo.Z(K[vids,vids],X)
        }
        else {
          vrows <- as.logical(rowSums(Z[,vids]))
          X <- cbind(X0[vrows,,drop=FALSE],Z[vrows,vids,drop=FALSE]%*%t(xs[i,vids,drop=FALSE]))
          eig.R1 = emma.eigen.R.w.Z(Z[vrows,vids],K[vids,vids],X)
        }

        for(j in 1:g) {
          if ( nv == t ) {
            REMLE <- emma.REMLE(ys[j,],X,K,Z,ngrids,llim,ulim,esp,eig.R1)
            if ( is.null(Z) ) {
              U <- eig.L$vectors * matrix(sqrt(1/(eig.L$values+REMLE$delta)),t,t,byrow=TRUE)
              dfs[i,j] <- nv - q1
            }
            else {
              U <- eig.L$vectors * matrix(c(sqrt(1/(eig.L$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),n-t)),n,n,byrow=TRUE)
              dfs[i,j] <- n - q1
            }
            yt <- crossprod(U,ys[j,])
            Xt <- crossprod(U,X)
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)

            if ( !ponly ) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)
          }
          else {
            if ( is.null(Z) ) {
              eig.L0 <- emma.eigen.L.wo.Z(K[vids,vids])
              nr <- sum(vids)
              yv <- ys[j,vids]
              REMLE <- emma.REMLE(yv,X,K[vids,vids,drop=FALSE],NULL,ngrids,llim,ulim,esp,eig.R1)
              U <- eig.L0$vectors * matrix(sqrt(1/(eig.L0$values+REMLE$delta)),nr,nr,byrow=TRUE)
              dfs[i,j] <- nr - q1
            }
            else {
              eig.L0 <- emma.eigen.L.w.Z(Z[vrows,vids,drop=FALSE],K[vids,vids])
              yv <- ys[j,vrows]
              nr <- sum(vrows)
              tv <- sum(vids)
              REMLE <- emma.REMLE(yv,X,K[vids,vids,drop=FALSE],Z[vrows,vids,drop=FALSE],ngrids,llim,ulim,esp,eig.R1)
              U <- eig.L0$vectors * matrix(c(sqrt(1/(eig.L0$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),nr-tv)),nr,nr,byrow=TRUE)
              dfs[i,j] <- nr - q1
            }
            yt <- crossprod(U,yv)
            Xt <- crossprod(U,X)
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)
            if (!ponly) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)
          }
        }
        ps[i,] <- 2*pt(abs(stats[i,]),dfs[i,],lower.tail=FALSE)
      }
    }
  }
  else {
    eig.L <- emma.eigen.L(Z,K)
    eig.R0 <- emma.eigen.R(Z,K,X0)

    x.prev <- vector(length=0)

    for(i in 1:m) {
      vids <- !is.na(xs[i,])
      nv <- sum(vids)
      xv <- xs[i,vids]

      if ( ( mean(xv) <= 0 ) || ( mean(xv) >= 1 ) ) {
        if (!ponly) {
          vgs[i,] <- rep(NA,g)
          ves[i,] <- rep(NA,g)
          REMLs[i,] <- rep(NA,g)
          dfs[i,] <- rep(NA,g)
        }
        ps[i,] = rep(1,g)
      }
      else if ( identical(x.prev, xv) ) {
        if ( !ponly ) {
          stats[i,] <- stats[i-1,]
          vgs[i,] <- vgs[i-1,]
          ves[i,] <- ves[i-1,]
          REMLs[i,] <- REMLs[i-1,]
          dfs[i,] <- dfs[i-1,]
        }
        ps[i,] = ps[i-1,]
      }
      else {
        if ( is.null(Z) ) {
          X <- cbind(X0,xs[i,])
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.wo.Z(K,X)
          }
        }
        else {
          vrows <- as.logical(rowSums(Z[,vids,drop=FALSE]))
          X <- cbind(X0,Z[,vids,drop=FALSE]%*%t(xs[i,vids,drop=FALSE]))
          if ( nv == t ) {
            eig.R1 = emma.eigen.R.w.Z(Z,K,X)
          }
        }

        for(j in 1:g) {
          vrows <- !is.na(ys[j,])
          if ( nv == t ) {
            yv <- ys[j,vrows]
            nr <- sum(vrows)
            if ( is.null(Z) ) {
              if ( nr == n ) {
                REMLE <- emma.REMLE(yv,X,K,NULL,ngrids,llim,ulim,esp,eig.R1)
                U <- eig.L$vectors * matrix(sqrt(1/(eig.L$values+REMLE$delta)),n,n,byrow=TRUE)
              }
              else {
                eig.L0 <- emma.eigen.L.wo.Z(K[vrows,vrows,drop=FALSE])
                REMLE <- emma.REMLE(yv,X[vrows,,drop=FALSE],K[vrows,vrows,drop=FALSE],NULL,ngrids,llim,ulim,esp)
                U <- eig.L0$vectors * matrix(sqrt(1/(eig.L0$values+REMLE$delta)),nr,nr,byrow=TRUE)
              }
              dfs[i,j] <- nr-q1
            }
            else {
              if ( nr == n ) {
                REMLE <- emma.REMLE(yv,X,K,Z,ngrids,llim,ulim,esp,eig.R1)
                U <- eig.L$vectors * matrix(c(sqrt(1/(eig.L$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),n-t)),n,n,byrow=TRUE)
              }
              else {
                vtids <- as.logical(colSums(Z[vrows,,drop=FALSE]))
                eig.L0 <- emma.eigen.L.w.Z(Z[vrows,vtids,drop=FALSE],K[vtids,vtids,drop=FALSE])
                REMLE <- emma.REMLE(yv,X[vrows,,drop=FALSE],K[vtids,vtids,drop=FALSE],Z[vrows,vtids,drop=FALSE],ngrids,llim,ulim,esp)
                U <- eig.L0$vectors * matrix(c(sqrt(1/(eig.L0$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),nr-sum(vtids))),nr,nr,byrow=TRUE)
              }
              dfs[i,j] <- nr-q1
            }

            yt <- crossprod(U,yv)
            Xt <- crossprod(U,X[vrows,,drop=FALSE])
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)
            if ( !ponly ) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)
          }
          else {
            if ( is.null(Z) ) {
              vtids <- vrows & vids
              eig.L0 <- emma.eigen.L.wo.Z(K[vtids,vtids,drop=FALSE])
              yv <- ys[j,vtids]
              nr <- sum(vtids)
              REMLE <- emma.REMLE(yv,X[vtids,,drop=FALSE],K[vtids,vtids,drop=FALSE],NULL,ngrids,llim,ulim,esp)
              U <- eig.L0$vectors * matrix(sqrt(1/(eig.L0$values+REMLE$delta)),nr,nr,byrow=TRUE)
              Xt <- crossprod(U,X[vtids,,drop=FALSE])
              dfs[i,j] <- nr-q1
            }
            else {
              vtids <- as.logical(colSums(Z[vrows,,drop=FALSE])) & vids
              vtrows <- vrows & as.logical(rowSums(Z[,vids,drop=FALSE]))
              eig.L0 <- emma.eigen.L.w.Z(Z[vtrows,vtids,drop=FALSE],K[vtids,vtids,drop=FALSE])
              yv <- ys[j,vtrows]
              nr <- sum(vtrows)
              REMLE <- emma.REMLE(yv,X[vtrows,,drop=FALSE],K[vtids,vtids,drop=FALSE],Z[vtrows,vtids,drop=FALSE],ngrids,llim,ulim,esp)
              U <- eig.L0$vectors * matrix(c(sqrt(1/(eig.L0$values+REMLE$delta)),rep(sqrt(1/REMLE$delta),nr-sum(vtids))),nr,nr,byrow=TRUE)
              Xt <- crossprod(U,X[vtrows,,drop=FALSE])
              dfs[i,j] <- nr-q1
            }
            yt <- crossprod(U,yv)
            iXX <- solve(crossprod(Xt,Xt))
            beta <- iXX%*%crossprod(Xt,yt)
            if ( !ponly ) {
              vgs[i,j] <- REMLE$vg
              ves[i,j] <- REMLE$ve
              REMLs[i,j] <- REMLE$REML
            }
            stats[i,j] <- beta[q1]/sqrt(iXX[q1,q1]*REMLE$vg)

          }
        }
        ps[i,] <- 2*pt(abs(stats[i,]),dfs[i,],lower.tail=FALSE)
      }
    }
  }
  if ( ponly ) {
    return (ps)
  }
  else {
    return (list(ps=ps,REMLs=REMLs,stats=stats,dfs=dfs,vgs=vgs,ves=ves))
  }
}


chart_dfv <- reactiveValues(chart_dfv = data.frame(Data = "no"))
chart_dfv2 <- reactiveValues(chart_dfv2 = data.frame(Data = "No historical data to display"))

output$plotly_control_ui_v <- renderUI ({
	if(length(ticker_df$ticker_df[[3]]) > 1) {
		df1 <- data.frame(matrix(unlist(ticker_df$ticker_df[[3]]), nrow=length(ticker_df$ticker_df[[3]]), byrow=TRUE),stringsAsFactors=FALSE)
		colnames(df1) <- names(ticker_df$ticker_df[[3]][[1]])
		chart_dfv2$chart_dfv2 <- df1
		dateRangeInput("chart_datesv", "Select Date Range", start = df1[1,10], end = df1[nrow(df1),10], min = df1[1,10], max = df1[nrow(df1),10])
	} else {
		HTML("No historical data to chart")
	}
})

output$plotly_control_ui2_v <- renderUI ({
	if(length(ticker_df$ticker_df[[3]]) > 1) {
		checkboxGroupInput("plotly_options_v", label="Volatility Measures", choices = c("OHLC Yang and Zhang", "Close-to-Close","OHLC Garman and Klass","HL Parkinson","OHLC Rogers and Satchell","OHLC Garman and Klass (Yang and Zhang modification)"), selected = c("OHLC Yang and Zhang"), inline = TRUE)
	} else {
		HTML("")
	}
})

observeEvent(input$chart_datesv, {
	temp1 <- chart_dfv2$chart_dfv2[chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1],]
	temp1 <- temp1[temp1[,10] <= input$chart_datesv[2],]
	chart_dfv$chart_dfv <- temp1
})

output$table_title <- renderUI ({
	HTML(paste("
Percentage of time the selected historical range was higher than the end date
"))
})

output$plotly_chart_ui_v_p <- renderUI ({
	if(length(ticker_df$ticker_df[[3]]) > 1) {
		df1 <- chart_dfv$chart_dfv
		temp1 <- chart_dfv2$chart_dfv2[chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1],]
		temp1 <- temp1[temp1[,10] <= input$chart_datesv[2],]
		OHLC <- cbind(as.numeric(chart_dfv2$chart_dfv2[,4]), as.numeric(chart_dfv2$chart_dfv2[,2]), as.numeric(chart_dfv2$chart_dfv2[,3]), as.numeric(chart_dfv2$chart_dfv2[,1]))
		OHLC_V1 <- volatility(OHLC = OHLC, calc = "yang.zhang")
		OHLC_V1 <- OHLC_V1[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V1 <- OHLC_V1[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V2 <- volatility(OHLC = OHLC, calc = "close")
		OHLC_V2 <- OHLC_V2[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V2 <- OHLC_V2[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V3 <- volatility(OHLC = OHLC, calc = "garman.klass")
		OHLC_V3 <- OHLC_V3[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V3 <- OHLC_V3[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V4 <- volatility(OHLC = OHLC, calc = "parkinson")
		OHLC_V4 <- OHLC_V4[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V4 <- OHLC_V4[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V5 <- volatility(OHLC = OHLC, calc = "rogers.satchell")
		OHLC_V5 <- OHLC_V5[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V5 <- OHLC_V5[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V6 <- volatility(OHLC = OHLC, calc = "gk.yz")
		OHLC_V6 <- OHLC_V6[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V6 <- OHLC_V6[which(temp1[,10] <= input$chart_datesv[2])]
		output$table_vol_p <- renderTable(colnames=TRUE, rownames=FALSE, width="100%", striped = TRUE,{
			HVC <- data.frame(data="Please select a volatility measure above")
			HVC_1 <- 0
			for(o in input$plotly_options_v) {
				if(o == "OHLC Yang and Zhang") {
					total_num <- length(OHLC_V1)
					last <- OHLC_V1[total_num]
					above_num <- length(OHLC_V1[OHLC_V1 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "OHLC Yang and Zhang"
				}
				if(o == "Close-to-Close") {
					total_num <- length(OHLC_V2)
					last <- OHLC_V2[total_num]
					above_num <- length(OHLC_V2[OHLC_V2 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "Close-to-Close"
				}
				if(o == "OHLC Garman and Klass") {
					total_num <- length(OHLC_V3)
					last <- OHLC_V3[total_num]
					above_num <- length(OHLC_V3[OHLC_V3 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "OHLC Garman and Klass"
				}
				if(o == "HL Parkinson") {
					total_num <- length(OHLC_V4)
					last <- OHLC_V4[total_num]
					above_num <- length(OHLC_V4[OHLC_V4 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "HL Parkinson"
				}
				if(o == "OHLC Rogers and Satchell") {
					total_num <- length(OHLC_V5)
					last <- OHLC_V5[total_num]
					above_num <- length(OHLC_V5[OHLC_V5 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "OHLC Rogers and Satchell"
				}
				if(o == "OHLC Garman and Klass (Yang and Zhang modification)") {
					total_num <- length(OHLC_V6)
					last <- OHLC_V6[total_num]
					above_num <- length(OHLC_V6[OHLC_V6 > last])
					percent <- round((100 * (above_num / total_num)),digits=1)
					HVC <- cbind(HVC, data.frame(paste(percent, "%", sep="")))
					colnames(HVC)[ncol(HVC)] <- "OHLC Garman and Klass (Yang and Zhang modification)"
				}
			}
			HVC_l <- length(HVC)
			if(HVC_l == 1) {
				return(HVC)
			}
			if(HVC_l == 2) {
				cn <- colnames(HVC)
				HVC <- HVC[,-1]
				names(HVC) <- cn[2]
			}
			if(HVC_l > 2) {
				HVC <- HVC[,-1]
			}
			if(length(HVC) == 1) {
				return(t(data.frame(HVC)))
			} else {
				return(HVC)
			}
		})

		tableOutput("table_vol_p")
	}
})

output$plotly_chart_ui_v <- renderUI ({
	if(length(ticker_df$ticker_df[[3]]) > 1) {
		df1 <- chart_dfv$chart_dfv
		temp1 <- chart_dfv2$chart_dfv2[chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1],]
		temp1 <- temp1[temp1[,10] <= input$chart_datesv[2],]
		OHLC <- cbind(as.numeric(chart_dfv2$chart_dfv2[,4]), as.numeric(chart_dfv2$chart_dfv2[,2]), as.numeric(chart_dfv2$chart_dfv2[,3]), as.numeric(chart_dfv2$chart_dfv2[,1]))
		fig <- plot_ly()
		OHLC_V1 <- volatility(OHLC = OHLC, calc = "yang.zhang")
		OHLC_V1 <- OHLC_V1[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V1 <- OHLC_V1[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V2 <- volatility(OHLC = OHLC, calc = "close")
		OHLC_V2 <- OHLC_V2[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V2 <- OHLC_V2[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V3 <- volatility(OHLC = OHLC, calc = "garman.klass")
		OHLC_V3 <- OHLC_V3[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V3 <- OHLC_V3[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V4 <- volatility(OHLC = OHLC, calc = "parkinson")
		OHLC_V4 <- OHLC_V4[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V4 <- OHLC_V4[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V5 <- volatility(OHLC = OHLC, calc = "rogers.satchell")
		OHLC_V5 <- OHLC_V5[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V5 <- OHLC_V5[which(temp1[,10] <= input$chart_datesv[2])]
		OHLC_V6 <- volatility(OHLC = OHLC, calc = "gk.yz")
		OHLC_V6 <- OHLC_V6[which(chart_dfv2$chart_dfv2[,10] >= input$chart_datesv[1])]
		OHLC_V6 <- OHLC_V6[which(temp1[,10] <= input$chart_datesv[2])]

		output$plotly_chartv <- renderPlotly({
			for(o in input$plotly_options_v) {
				if(o == "OHLC Yang and Zhang") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "black",
							width = 1.3
						),
						mode = "lines",
						name = "OHLC Yang and Zhang",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V1
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
				if(o == "Close-to-Close") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "red",
							width = 1.3
						),
						mode = "lines",
						name = "Close-to-Close",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V2
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
				if(o == "OHLC Garman and Klass") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "blue",
							width = 1.3
						),
						mode = "lines",
						name = "OHLC Garman and Klass",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V3
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
				if(o == "HL Parkinson") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "green",
							width = 1.3
						),
						mode = "lines",
						name = "HL Parkinson",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V4
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
				if(o == "OHLC Rogers and Satchell") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "orange",
							width = 1.3
						),
						mode = "lines",
						name = "OHLC Rogers and Satchell",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V5
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
				if(o == "OHLC Garman and Klass (Yang and Zhang modification)") {
					trace1 <- list(
						line = list(
							dash = "solid",
							color = "purple",
							width = 1.3
						),
						mode = "lines",
						name = "OHLC Garman and Klass (Yang and Zhang modification)",
						text = "",
						type = "scatter",
						x = df1[,10],
						y = OHLC_V6
					)
					fig <- add_trace(fig, line=trace1$line, mode=trace1$mode, name=trace1$name, text=trace1$text, type=trace1$type, x=trace1$x, y=trace1$y)
				}
			}
			fig <- fig %>% layout(showlegend = FALSE, plot_bgcolor="#f5f5f5", paper_bgcolor="#f5f5f5", xaxis = list(rangeslider = list(visible = F)))
			return(fig)
		})
		plotlyOutput("plotly_chartv")
	} else {
		HTML("No historical data to chart")
	}
})

chart_data_table_v <- reactiveValues(chart_data_table_v = data.frame(Data = "No historical data to display"))

update_table_chart_v <- function() {
	if(length(ticker_df$ticker_df[[3]]) > 1) {
		df1 <- data.frame(matrix(unlist(ticker_df$ticker_df[[3]]), nrow=length(ticker_df$ticker_df[[3]]), byrow=TRUE),stringsAsFactors=FALSE)
		colnames(df1) <- names(ticker_df$ticker_df[[3]][[1]])
		OHLC <- cbind(as.numeric(df1[,4]), as.numeric(df1[,2]), as.numeric(df1[,3]), as.numeric(df1[,1]))
		V1 <- volatility(OHLC = OHLC, calc = "yang.zhang")
		V2 <- volatility(OHLC = OHLC, calc = "close")
		V3 <- volatility(OHLC = OHLC, calc = "garman.klass")
		V4 <- volatility(OHLC = OHLC, calc = "parkinson")
		V5 <- volatility(OHLC = OHLC, calc = "rogers.satchell")
		V6 <- volatility(OHLC = OHLC, calc = "gk.yz")
		dfv <- data.frame(yang.zhang = V1, close = V2, german.klass = V3, parkinson = V4, rogers.satchell = V5, gk.yz = V6)
		rownames(dfv) <- df1[,10]
		colnames(dfv) <- c("yang.zhang", "close", "german.klass", "parkinson", "rogers.satchell","gk.yz")
		chart_data_table_v$chart_data_table_v <- dfv
		colnames(chart_data_table_v$chart_data_table_v) <- colnames(dfv)
		rownames(chart_data_table_v$chart_data_table_v) <- rownames(dfv)
	} else {
		chart_data_table_v$chart_data_table_v <- data.frame(Data = "No historical data to display")
	}
}

output$chart_table_v <- DT::renderDataTable ({
	DT::datatable(chart_data_table_v$chart_data_table_v, extensions = 'Buttons', options = list(dom = "Blfrtip", buttons = list("copy", list(extend = "collection", buttons = c("csv","excel","pdf"), text = "Download")), lengthMenu = c(5,10,15,20,25,50,100,nrow(chart_data_table_v$chart_data_table_v)), pageLength = 15, scrollX=TRUE), rowname = TRUE)
})


#' @title getCols
#' @description get color vector for plot
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
getCols <- function(n){
 N <- 6

 X <- seq(N^2)-0.5
 Y <- seq(N)-0.5
 Z <- matrix(0, nrow=length(X), ncol=length(Y))

 LEV <- seq(0,1,,N)
 R <- rep(LEV, each=N^2)
 G <- rep(rep(LEV, each=N), N)
 B <- rep(LEV, N^2)

 plot.new(width=6, height=6)
 layout(matrix(1:2, nrow=2, ncol=1), widths=c(6), heights=c(1.5,4.5))
 op <- par(mar=c(1,3,2,1))

 image(X,Y,Z, col=NA, xlab="", ylab="", xaxt="n", yaxt="n")
 for(i in seq(Z)){
  xs <- c(((i-1) %% N^2), ((i-1) %% N^2), ((i-1) %% N^2) + 1, ((i-1) %% N^2) + 1)
  ys <- c(((i-1) %/% N^2), ((i-1) %/% N^2)+1, ((i-1) %/% N^2) + 1, ((i-1) %/% N^2))
  polygon(xs, ys, col=rgb(R[i], G[i], B[i]), border=NA)
 }
 mtext(paste("Click on", n, "colors [please]"), side=3, line=0.5)
 box()

 COLS <- NA*seq(n)
 for(i in seq(n)){
  coord <- locator(1)
  red <- coord$y / N
  green <- coord$x / N^2
  blue <- (coord$x %% N) / N
  #pos <- (round(coord$y-1) * N^2) + round(coord$x)
  COLS[i] <- rgb(red, green, blue)
 }

 par(mar=c(1,3,0,1))
 pal <- colorRampPalette(c("black", "white"))
 image(x=1:100, y=seq(n), z=matrix(rep(1:100,n), nrow=100, ncol=n), col=pal(100), xlab="", ylab="", xaxt="n", yaxt="n")
 box()
 for(i in seq(n)){
  lines(x=c(1,100), y=c(i,i), col=COLS[i], lwd=4)
 }
 axis(2, at=seq(n))

 par(op)

 COLS
}
#usage getCols(5)


#' PVS
#'
#' Broad range formula to estimate saturation vapor pressure.
#'
#' @param t numeric Air temperature in degC.
#' @return Saturaion vapor pressure (hPa)
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords   PVS
#' @references Hardy B, 1998,"ITS-90 Formulations for Vapor Pressure, Frostpoint Temperature,Dewpoint Temperature, and Enhancement Factors in the Range 100 to +100 C".Proceedings of the Third International Symposium on Humidity & Moisture",Teddington, London, England, April 1998.
#' @export
#'
#'
#'
#'

PVS=function(t) {
                         ct$assign("T", as.array(t))
                         ct$eval("var res=[]; for(var i=0, len=T.length; i < len; i++){ rel[i]=PVS(T[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# INITIALISE:
source("Init.r")

case.file = "Data/Full MOLIS dataset minus PII 20200918.xlsx"

tmp = ranScanInit(case.file)
ranScanCreateObservationMatrices(case.file, tmp$emmtypes[1:4])

postcode2coord = ranScanPostcodeMap(observation.matrix)
load("Data/1.0_obs.Rdata")
baseline.matrix = ranScanCreateBaselineMatrix(case.file)
emmtype.factor = ranScanEmmtypeFactor(case.file)
time.factor = ranScanTimeFactor(case.file)

#
sum(baseline.matrix * emmtype.factor[['1.0']], na.rm=T)
sum(observation.matrix, na.rm=T)

load("Data/12.0_obs.Rdata")
sum(baseline.matrix * emmtype.factor[['12.0']], na.rm=T)
sum(observation.matrix, na.rm=T)

source("ranScanEvaluate.r")

ranScanCreateObservationMatrices(case.file, c('33.0', '108.1', '12.0'))

ranScanCreateObservationMatrices(case.file, c('44.0'))

#for (n_cyl in c(20000, 30000)){

A = list()

for(sizefactor in c(1.3)){
  for (emmtype in c('94.0')){
    t1 = Sys.time()
    load(paste0("~/Outbreak/Data/", emmtype, "_obs.Rdata"))
    # cylinders = ranScanCreateCylinders(observation.matrix, baseline.matrix * emmtype.factor[[emmtype]], emmtype,
    #                                  starting.week=100, n.cylinders=2000)
    cylinders = ranScanCreateCylinders(observation.matrix,
                                       baseline.matrix * emmtype.factor[[emmtype]], emmtype, week.range,
                                       n_cyl, postcode2coord,  size_factor = sizefactor)

    basename = paste('Movie/largecyl', 'n', as.character(n_cyl), as.character(sizefactor), sep='_')
#    ranScanMovie(cylinders, observation.matrix, postcode2coord, basename, emmtype)

    case.df.tmp = ranScanEvaluate(case.file, cylinders, emmtype, p.val.threshold=0.05)

    # A[[paste0(emmtype, as.character(sizefactor), sep='_')]] = case.df.tmp[case.df.tmp$emmtype == emmtype, ]

    tmp = ranScanCluster(case.df.tmp, emmtype)

    png(paste('Cluster/largecyl', as.character(n_cyl),as.character(sizefactor), emmtype, '.png', sep='_'),
        res=600, width=5, height=4, units="in")
    ranScanPlotCluster(tmp, case.df.tmp, emmtype)
    dev.off()

    png(paste('Cluster/largecyl', as.character(n_cyl),as.character(sizefactor), emmtype, 'thresh.png', sep='_'),
        res=600, width=5, height=4, units="in")
    ranScanPlotCluster(tmp, case.df.tmp, emmtype, threshold=0.9)
    dev.off()

    png(paste('Cluster/largecyl', as.character(n_cyl), as.character(sizefactor), emmtype, 'regions.png', sep='_'),
        res=600, width=5, height=4, units="in")
    ranScanPlotCluster3(tmp, case.df.tmp, emmtype, threshold=0.7, Area2region_list=Area2Region_list)
    dev.off()

    # ranScanSaveCylinders(cylinders, paste0('Data/cylinders_for_', emmtype, '.csv'))
    # mutcylinders = ranScanMutateCylinders(observation.matrix, baseline.matrix* emmtype.factor[[emmtype]], cylinders, n.cylinders=40000)
    # ranScanSaveCylinders(mutcylinders, paste0('Data/mutcylinders_for_', emmtype, '.csv'))
    # case.df = ranScanEvaluate(case.file, cylinders, emmtype, p.val.threshold=0.05)
    # write.csv(case.df[case.df$emmtype==emmtype,], file = paste0('Data/cases_', emmtype, '_with_warnings.csv'))
    # write.csv(case.df,file = paste0('Data/cases_full_', emmtype, '_with_warnings.csv'))
    cat("n_cyl", n_cyl, "emmtype", emmtype)
    print(Sys.time() - t1)
  }
}

emmtype = '33.0'
load(paste0("~/Outbreak/Data/", emmtype, "_obs.Rdata"))
#load(paste0("~/Outbreak/Data/mutcylinders_for_",emmtype,".csv.Rdata"))
cidx = !(row.names(observation.matrix) == 'NA')
ranScanMovie(cylinders, observation.matrix[idx,], postcode2coord, 'Fig/2Dec', emmtype)

# East of England 33	         ? - 18-08-2019  44
# South West 21	30-01-2017 - 05-03-2018  94
# Midlands 18	26-11-2018 - 07-04-2020 108.1
# West Yorkshire 36	23-02-2018 - 07-05-2019 108.1

date2week<-function(date){
  date = as.POSIXct(paste0(as.character(date), " UTC"), tz = "UTC")
  return(
    as.integer(difftime(date, as.POSIXct("2015-01-01 UTC", tz = "UTC"), units = "weeks"))
  )
}

cat('-- ', date2week("2019-08-18"))
cat(date2week("2017-01-30"), date2week("2018-03-05"))
cat(date2week("2018-11-26"), date2week("2020-04-07"))
cat(date2week("2018-02-23"), date2week("2019-05-07"))
# data,range emmtype
# --  241 44
# 108-165 94
# 203-274 108.1
# 164-226 108.1

png('Fig/prevalence_.png', res=600, width=5 * 2, height=4, units="in")
cols = c("#1f77b4", "#ff7f0e", "#2ca02c",
         "#d62728","#9467bd", "#8c564b", "#e377c2", "#7f7f7f", "#bcbd22", "#17becf")
par(mfrow=c(1, 2)) #, mar=c(0.9,0.9,0.9,0.7))
plot.emm.fraction(tmp$case.df, c('1.0', '89.0', '12.0'), cols=cols[1:3], 'topleft', ylim=c(0,0.51), xlab=expression(tau))
mtext('A', 3, at = max(tmp$case.df$SAMPLE_DT), cex=2, padj=1.5)
plot.emm.fraction(tmp$case.df, c('33.0', '108.1', '44.0', '94.0'),cols=cols[c(4,5,6,8)], 'topleft', ylim=c(0,0.06),xlab=expression(tau))
mtext('B', 3, at = max(tmp$case.df$SAMPLE_DT), cex=2, padj=1.5)
dev.off()


> x <- c(hello=1, world=2, "!"=3)
> print(x["!"])


#' Y axis scale bar for stacked plots
#'
#' In stacked plots the standard y axis doesn't really work - it is vertical
#' lengths of line segments that correspond to data values, not the absolute y
#' positions. This function draws a scale bar in the space where the yaxis
#' would normally be.
#'
#' @param length (Optional) if not supplied, the length will be the distance
#' between two ticks if the y axis had been plotted in the standard way (uses
#' \code{par('yaxp')}).
#' @param pos Vertical location for scale bar where 0 is at the bottom, 1 is at
#' the top, and 0.5 (default) is in the middle.
#' @param las Controls orientation of axis label text (See \code{par('las')})
#' @param ... Other arguments to pass to axis (See \code{par()})
#'
#' @seealso \code{\link{stack.plot}} for drawing stacked plots
#' @export
y.scale.bar <- function(length, pos=0.5, abs.pos, las=par('las'), ...) {
  if ( missing(length) )
    length <- diff(par('yaxp')[1:2])/par('yaxp')[3]

  if ( missing(abs.pos) )
    start <- par('usr')[3]+(diff(par('usr')[3:4])-length)*pos
  else
    start <- abs.pos

  end <- start+length
  mid <- start+length/2

  axis(2, c(start, end), label=FALSE, lwd=0, lwd.ticks=1, mgp=c(0, 0, par('tcl')), ...)
  axis(2, c(start, end), label=FALSE, lwd=1, lwd.ticks=0, mgp=c(0, 0, 0), ...)
  axis(2, mid, label=length, lwd=0, las=las, mgp=c(0, -par('tcl'), 0), ...)
}

#' Stacked plots
#'
#' Stacked plots allow plotting multiple vectors of data without overlap in
#' minimal space.
#'
#' @param y a matrix of values. Each row of the matrix will be one line in the
#' plot.
#' @param x (Optional) x axis values - length should correspond to columns in y matrix
#' @param spacing Spacing between lines
#' @param style normal or zero
#'
#' @export
stackplot <- function(y, x, spacing=0.5, style='normal', las=1, y.scale=TRUE,
                         lwd, lty, col, bty='n', xaxt=par('xaxt'),
                         yaxt='n', yaxs='i', xlab='', ylab='') {
  if ( missing(x) )
    x <- 1:ncol(y)

  recognized.styles <- c('normal', 'zero')
  if ( ! style %in% recognized.styles ) {
    warning('style ', style, ' not recognized. Using default (normal).')
  }

  nl <- nrow(y)
  y <- y[nl:1, ]

  if ( missing(col) ) {
    col <- hcl(1:nl/nl*300, 60, 40)
  } else if ( length(col) != nl ) {
    col <- rep(col, length.out=nl)
  } else {
    col <- col[nl:1]
  }

  if ( missing(lwd) ) {
    lwd <- rep(par('lwd'), nl)
  } else if ( length(lwd) != nl ) {
    lwd <- rep(lwd, length.out=nl)
  } else {
    lwd <- lwd[nl:1]
  }

  if ( missing(lty) ) {
    lty <- rep(par('lwd'), nl)
  } else if ( length(lty) != nl ) {
    lty <- rep(lty, length.out=nl)
  } else {
    lty <- lty[nl:1]
  }

  if ( style=='zero' ) {
    ymins <- pmin(0, apply(y, 1, min))
    ymaxs <- pmax(0, apply(y, 1, max))
  } else {
    ymins <- apply(y, 1, min)
    ymaxs <- apply(y, 1, max)
  }

  yheight <- ymaxs-ymins

  add.space <- sum(yheight)*spacing/nl
  offset <- c(0, cumsum(yheight) + cumsum(rep(add.space, nl))) - c(ymins, 0)

  plot(rep(x, each=nl), as.vector(y)+offset[1:nl], type='n', bty=bty, yaxt=yaxt, xlab=xlab, ylab=ylab, xaxt=xaxt, yaxs=yaxs)
  if ( style=='zero'  ) {
    sapply(1:nl, function (i) segments(x, offset[i], x, offset[i]+y[i, ], col=col[i], lty=lty[i], lwd=lwd[i]))
    segments(min(x), offset[1:nl], max(x), offset[1:nl], col=col, lty=lty, lwd=lwd)
  } else {
    sapply(1:nl, function (i) lines(x, y[i, ]+offset[i], col=col[i], lty=lty[i], lwd=lwd[i]))
  }

  if ( y.scale ) y.scale.bar(las=las)
  invisible(offset)
}

y <- matrix(rchisq(10*150, 1), 10)*rchisq(10, 1)

stackplot(y, style='zero', lwd=2, spacing=0.2, y.scale=FALSE)
y.scale.bar(pos=1.1, xpd=NA)
#
#
# simple.stack(y, style='zero', lwd=2, spacing=0.2)


## ---
## title: "Fitting of multiple time series using function 'multiFit'"
## author: " "
## date: "04/13/2021"
## output:
## ---
packs <- c('SoilR', 'sidb', 'yaml', 'parallel','R.utils')
sapply(packs, require, character.only = TRUE) ## be sure all the outputs are TRUE

userLocation <- '/home/wilar/Documents' # Path to local sidb folder
source.R <- file.path(userLocation, 'sidb/scripts/multiSidbFit')
sourceDirectory(source.R, modifiedOnly = TRUE, verbose = TRUE)

## Data entry example:
load_entries <- loadEntries(file.path(userLocation, 'sidb/data/'))
db <- load_entries[["Crow2019a"]]

tmp <- MultiFit(db, model = c('twoppFit',
                              'twopsFit',
                              'twopfFit',
                              'threeppFit',
                              'threepsFit'),
                inipars = list(c(0.01, 0.001, 0.1),
                               c(0.05, 0.00001, 0.1, 0.01),
                               c(0.005, 0.00001, 0.1, 0.01, 0.01),
                               c(0.05, 0.01, 0.001, 0.1, 0.1),
                               c(0.9,0.01, 0.000001, 0.01, 0.01, 0.01, 0.1)),
                ic.col = list(78),
                ts.col = list(75:79))
                ## ts.col = list(NULL)) # replace previous line with this one if you aim to evaluate the whole 'ts.col' instances

names(tmp)
names(tmp$'twoppFit')
names(tmp$'twoppFit'$'75')

## The example if based on the following routines
M1=twoppFit(timeSeries = incubation$timeSeries[,c(1,79)], initialCarbon=incubation$initConditions[78,"carbonMean"]*10000, inipars=c(0.01, 0.001, 0.1))
M2=twopsFit(timeSeries = incubation$timeSeries[,c(1,79)], initialCarbon=incubation$initConditions[78,"carbonMean"]*10000, inipars=c(0.005, 0.00001, 0.1, 0.01))
M3=twopfFit(timeSeries = incubation$timeSeries[,c(1,79)], initialCarbon=incubation$initConditions[78,"carbonMean"]*10000, inipars=c(0.005, 0.00001, 0.1, 0.01, 0.01))

M4=threeppFit(timeSeries = incubation$timeSeries[,c(1,79)], initialCarbon=incubation$initConditions[78,"carbonMean"]*10000, inipars = c(0.05, 0.01, 0.001, 0.1, 0.1))
M5=threepsFit(timeSeries = incubation$timeSeries[,c(1,79)], initialCarbon=incubation$initConditions[78,"carbonMean"]*10000, inipars=c(0.9,0.01, 0.000001, 0.01, 0.01, 0.01, 0.1))

names(tmp)

## twopsFit_model <- multiSidbFit(db,
##                        model = 'twopsFit',
##                        ic.col = 1,
##                        ts.col = 15:20,
##                        inipars=c(0.05, 0.00001, 0.1, 0.01))

## threeppFit_model <- multiSidbFit(db,
##                     model = 'threeppFit',
##                     ts.col = 2:10,
##                     inipars=c(0.05, 0.01, 0.001, 0.1, 0.1))


plot_tcga_by_cohort <- function(df) {
  ggplot(
    df,
    aes(x = cohort_id, y = log2(normalized_counts + 1), color = sample_type)
  ) +
    facet_grid(symbol ~ .) +
    geom_boxplot(fill = NA) +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0)) +
    labs(
      x = "",
      y = "log2 normalized counts"
    )
}

plot_tcga_isoform_by_cohort <- function(df) {
  ggplot(
    df,
    aes(x = cohort_id, y = log2(as.numeric(normalized_counts) + 1), color = sample_type)
  ) +
    facet_grid(symbol + isoform_id ~ .) +
    geom_boxplot(fill = NA) +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0)) +
    labs(
      x = "",
      y = "log2 normalized counts"
    )
}

plot_tcga_expr_immune_subtype <- function(df) {
  ggplot(
    df,
    aes(x = immune_subtype, y = log2(normalized_counts + 1))
  ) +
    facet_grid(symbol ~ cohort_id, scales = "free_y") +
    geom_boxplot(fill = NA) +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0)) +
    labs(
      x = "",
      y = "log2 normalized counts"
    )
}

plot_tcga_expr_immune_composition <- function(df) {
  ggplot(
    df,
    aes(x = fraction, y = log2(normalized_counts + 1), color = cohort_id)
  ) +
    facet_grid(symbol ~ component, scales = "free") +
    geom_point() +
    theme_bw() +
    labs(
      x = "tumor fraction",
      y = "log2 normalized counts"
    )
}

plot_tcga_expr_signature_score <- function(df) {
  ggplot(
    df,
    aes(x = signature_score, y = log2(normalized_counts + 1), color = cohort_id)
  ) +
    facet_grid(symbol ~ signature, scales = "free") +
    geom_point() +
    theme_bw() +
    labs(
      x = "signature score",
      y = "log2 normalized counts"
    )
}

plot_gtex_by_tissue <- function(df) {
  ggplot(
    df,
    aes(x = tissue_id, y = log2(median_tpm + 1))
  ) +
    facet_grid(symbol ~ .) +
    geom_point() +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1)) +
    labs(
      x = "",
      y = "log2 median TPM"
    )
}

plot_gtex_isoform_by_tissue <- function(df) {
  ggplot(
    df,
    aes(x = tissue_id, y = log2(median_tpm + 1))
  ) +
    facet_grid(symbol + isoform_id ~ .) +
    geom_point() +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1)) +
    labs(
      x = "",
      y = "log2 median TPM"
    )
}

plot_tcga_mutations <- function(df) {
  df %>%
    ggplot(aes(x = cohort_id, fill = `variant classification`)) +
    facet_grid(symbol ~ .) +
    geom_bar() +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1)) +
    labs(
      x = "",
      y = "Number of patients"
    )
}

plot_hpa_by_cell_type <- function(df) {
  ggplot(df, aes(x = cell_type_id, y = `detection level`)) +
    facet_grid(symbol ~ .) +
    geom_point() +
    theme_bw() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1)) +
    labs(
      x = "",
      y = "Detection level"
    )
}

plot_gtex_vs_hpa <- function(df) {
  ggplot(df, aes(x = log2(GTEx + 1), y = log2(HPA + 1), color = tissue)) +
    facet_wrap(~symbol, scales = "free") +
    geom_jitter(aes(text = paste0(tissue, " - ", subtype))) +
    theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1),
      legend.position = "none"
    ) +
    labs(
      x = "GTEx expression (median TPM)",
      y = "HPA expression (TPM)"
    )
}

plot_hpa_prot_vs_expr <- function(df) {
  ggplot(df, aes(x = `detection level`, y = log2(TPM + 1), color = tissue)) +
    facet_wrap(~symbol, scales = "free") +
    geom_jitter(
      aes(text = paste0(tissue, " - ", subtype)),
      position=position_jitter(width=0.2, height=0)) +
    theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1),
      legend.position = "none"
    ) +
    labs(
      x = "HPA protein level",
      y = "HPA expression (TPM)"
    )
}

plot_tcga_expr_pair <- function(df, gene_x, gene_y) {
  ggplot(
    df,
    aes(x = get(gene_x), y = get(gene_y), color = cohort_id, shape = sample_type)
  ) +
    geom_point(aes(text = paste0(cohort_id, ": ", sample_id)), alpha = 0.5) +
    theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1)
    ) +
    labs(
      x = paste0(gene_x, " log2(normalized counts)"),
      y = paste0(gene_y, " log2(normalized counts)"),
      color = "",
      shape = ""
    )
}

plot_tcga_expr_by_clinical <- function(df, gene, clinical_attr) {
  p <- ggplot(df, aes(x = get(clinical_attr), y = get(gene)), color = cohort_id)
  if (class(df[[clinical_attr]]) == "character") {
    p <- p + geom_boxplot() +
      geom_jitter(
        alpha = 0.5,
        position = position_jitter(width = 0.1, height = 0)
      )
    legend_position <- "none"
  } else {
    p <- p + geom_point(
      aes(text = paste0(cohort_id, ": ", patient_id)),
      alpha = 0.5
    )
    legend_position <- "right"
  }

  p + theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1),
      legend.position = legend_position
    ) +
    labs(
      x = clinical_attr,
      y = paste0(gene, " log2(normalized counts)")
    )
}

plot_gtex_expr_pair <- function(df, gene_x, gene_y) {
  ggplot(df, aes(x = get(gene_x), y = get(gene_y), color = tissue_id)) +
    geom_point(aes(text = paste0(tissue, ": ", subtype)), alpha = 0.5) +
    theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1),
      legend.position = "none"
    ) +
    labs(
      x = paste0(gene_x, " log2(median TPM)"),
      y = paste0(gene_y, " log2(median TPM)")
    )
}

plot_hpa_expr_pair <- function(df, gene_x, gene_y) {
  ggplot(df, aes(x = get(gene_x), y = get(gene_y), color = tissue)) +
    geom_point(aes(text = paste0(tissue, ": ", subtype)), alpha = 0.5) +
    theme_bw() +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1),
      legend.position = "none"
    ) +
    labs(
      x = paste0(gene_x, " log2(TPM)"),
      y = paste0(gene_y, " log2(TPM)")
    )
}


# The tic-tac-toe matrix has already been defined for you
ttt <- matrix(c("O", NA, "X", NA, "O", NA, "X", "O", "X"), nrow = 3, ncol = 3)

# define the double for loop
for (i in 1:nrow(ttt)) {
    for (j in 1:ncol(ttt)) {
        print(paste("On row",i,"and column",j,"board contains",ttt[i,j]))
    }
}


# PlotCD

library(scmamp)
library(dplyr)

input <- read.csv("./results.csv", sep='\t')
data = input %>% group_by(dataset) %>% summarise(auc_challenger = mean(auc_challenger), auc_baseline = mean(auc_baseline), auc_offline = mean(auc_offline))
plotCD(input[,4:6], alpha=0.05)


 ZHPRFS Example Program Results

 Solution(s)
                    1                 2
 1  ( 1.0000,-1.0000) ( 3.0000,-4.0000)
 2  (-1.0000, 2.0000) (-1.0000, 5.0000)
 3  ( 3.0000,-2.0000) ( 7.0000,-2.0000)
 4  ( 2.0000, 1.0000) (-8.0000, 6.0000)

 Backward errors (machine-dependent)
         7.9E-17           7.2E-17
 Estimated forward error bounds (machine-dependent)
         2.6E-15           3.1E-15


#!/usr/bin/Rscript
mod <- "11/09/12 9:33 AM";
version <- "0.1";
author <- "Nick Youngblut";
#--------------------- version log ---------------------#
#
#
#-------------------------------------------------------#

### start-up
rm(list=ls())

### packages
suppressPackageStartupMessages(library(Hmisc))
pkgs <- Cs(
	optparse
	)
for(i in 1:length(pkgs)){
	tmp <- pkgs[i]
	suppressPackageStartupMessages(library(pkgs[i], character.only=TRUE))
	}

### I/O
# initialize options
option_list <- list(
	make_option(c("-o", "--outname"), type="character", default="histo.pdf", help="Output file name. [default: modified input file name]"),
	make_option(c("-u", "--upper"), type="integer", help="Upper bound allowed for distribution (<= -u)"),
	make_option(c("-l", "--lower"), type="integer", help="Lower bound allowed for distribution (>= -l)"),
	make_option(c("-r", "--round"), type="integer", default=1, help="Number of digits to round to. [1]"),
	make_option(c("--category"), type="store_false", help="pipe in list of values to get basic stats on the distribution of values"),
	make_option(c("-v", "--verbose"), action="store_false", default=TRUE, help="Print extra output")
	)
# get command line options, if help option encountered print help and exit, # otherwise if options not found on command line then set defaults,
opt <- parse_args(OptionParser(option_list=option_list))

### data processing
f <- file("stdin")
open(f)
tbl <- data.frame()
while(length(line <- readLines(f, n=1)) > 0){
	tbl <- rbind(tbl, as.numeric(line))
	}
tbl <- as.data.frame(tbl[which(! is.na(tbl[,1]) ), ])		# removing NAs
	#print(df[,1]); stop();
if(! is.null(opt$lower)){
	tbl <- as.data.frame(tbl[tbl[,1] >= opt$lower, ])
	}
if(! is.null(opt$upper)){
	tbl <- as.data.frame(tbl[tbl[,1] <= opt$upper, ])
	}

colnames(tbl) <- c("Summary")
print(summary(tbl, digits=opt$round))
msg <- paste( c(" Stdev  : ", round( sd(tbl[,1]), digits=opt$round)), collapse="")
message(msg)


library(gWidgets)
options(guiToolkit="RGtk2") ## using gWidgtsRGtk2

w <- gwindow("Interaction")

g <- ggroup(cont=w, horizontal=FALSE)
e <- gedit(0, cont=g, coerce.with=as.numeric)
bg <- ggroup(cont=g)

inc_btn <- gbutton("increment", cont=bg)
rdm_btn <- gbutton("random", cont=bg)

addHandlerChanged(e, handler=function(h,...) {
  val <- svalue(e)
  if(is.na(val))
    galert("You need to enter a number", parent=w)
})

addHandlerChanged(inc_btn, handler=function(h,...) {
  val <- svalue(e)
  if(is.na(val))
    galert("Can't increment if not a number", parent=w)
  else
    svalue(e) <- val + 1
})

addHandlerChanged(rdm_btn, handler=function(h,...) {
  if(gconfirm("Really replace value?"))
    svalue(e) <- sample(1:1000, 1)
})