.packageName <- "bim"
#####################################################################
##
## $Id: bim.r,v 1.1 2004/04/30 14:04:18 jgentry Exp $
##
##     Copyright (C) 2002 Brian S. Yandell
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################
read.bim <- function( dir, bimfile, nvalfile = "nval.dat", na.strings = "." )
{
  if (!missing(dir)) {
    n <- nchar(dir)
    if (substring(dir, n, n) == "/") 
      dir <- substring(dir, 0, n - 1)
    bimfile <- file.path(dir, bimfile)
    nvalfile <- file.path(dir, nvalfile)
  }
  cat( "reading", bimfile, "created by Bmapqtl\n" )
  
  bmapqtl <- read.bmapqtl( nvalfile = nvalfile )
  cat( "MCMC prior for number of QTL assumed to be", bmapqtl$prior.nqtl,
      "with mean", bmapqtl$mean.nqtl, "\n" )

  tbl <- read.table( bimfile, header = TRUE, na.strings = na.strings )
  burnin <- tbl[ tbl$niter < 0 & tbl$iqtl == 1,
    c("niter","nqtl","LOD","mu","sigmasq","addvar","domvar","esth") ]
  iter <- tbl[ tbl$niter >= 0 & tbl$iqtl == 1,
    c("niter","nqtl","LOD","mu","sigmasq","addvar","domvar","esth") ]
  names( burnin ) <- names( iter ) <- 
    c("niter","nqtl","LOD","mean","envvar","addvar","domvar","herit")
  no.dom <- all( is.na( iter$domvar ))
  if( no.dom )
    iter$domvar <- NULL
  cols <- c("niter","nqtl","chrom","locus","add")
  if( !no.dom)
    cols <- c(cols,"dom")
  loci <- tbl[ tbl$niter >= 0, cols ]
  sim <- list( bmapqtl = bmapqtl, burnin = burnin, iter = iter, loci = loci )
  class( sim ) <- "bim"
  sim
}
##############################################################################
summary.bim <- function( object, ... )
{
  cat ("Bayesian interval mapping object", substitute( object ), "\n" )
  cat( "had", as.integer( object$bmapqtl$inter ), "iterations recorded at each",
      as.integer( object$bmapqtl$by ), "steps\n" )
  burnin <- round( object$bmapqtl$burnin * object$bmapqtl$niter )
  cat( "with", as.integer( round( object$bmapqtl$preburn * burnin )),
      "pre-burn-in and", as.integer( burnin ), "burn-in steps.\n" )
  cat( paste( "Prior for number of QTL was ", object$bmapqtl$prior.nqtl,
             "(", object$bmapqtl$mean.nqtl, ").\n\n", sep = "" ))
  cat( "Percentages for number of QTL detected:" )
  print( round( 100 * table( object$iter$nqtl ) / nrow( object$iter )))
  cat( "\nDiagnostic summaries:\n" )
  print( summary( object$iter[,1] ))
  invisible( )
}
##############################################################################
bim.legacy <- function( bim )
{
  if( !is.null( bim$bmapqtl ))
    return( bim )
  bim$bmapqtl <- read.bmapqtl()
  bim$bmapqtl$prior.nqtl <- switch( bim$prior,
                                   exp =, geo =, geometric = "geometric",
                                   pois =, poisson = "poisson",
                                   unif =, uniform = "uniform" )
  bim$bmapqtl$mean.nqtl <- bim$mean.prior
  bim$prior <- NULL
  bim$mean.prior <- NULL
  bim
}
##############################################################################
bim.prior <- function( bim, range )
{
  ## legacy code
  if( is.null( bim$bmapqtl )) {
    warning( "legacy data: please run > bim <- bim.legacy( bim )" )
    bim <- bim.legacy( bim )
  }
  prior <- bim$bmapqtl$prior.nqtl
  mean <- bim$bmapqtl$mean.nqtl
  pr <- switch( prior,
         geometric = ( 1 / mean ) ^ range / ( 1 - ( 1 / mean )),
         poisson   = dpois( range, mean ),
         uniform   = rep( 1 / ( 1 + mean ), length( range )))
  if( is.null( pr ))
    stop( "only geometric, poisson, and uniform priors recognized\n" )
  names( pr ) <- range
  pr
}
##############################################################################
subset.bim <- function( x, cross = bim.cross( x ),
                       nqtl = 1, pattern = NULL, exact = FALSE, chr, ... )
{
  nqt <- nqtl[1]
  if( !is.null( pattern )) {
    nqtl <- max( nqtl, length( pattern ))
    if( is.character( pattern ))
      stop( "pattern must be numeric, not character" )
  }
  if( exact ) {
    x$iter <- x$iter[ x$iter$nqtl == nqtl, ]
    if( !nrow( x$iter ))
      stop( paste( "empty object: no iterations with number of QTL =", nqtl ))
    x$loci <- x$loci[ x$loci$nqtl == nqtl, ]
  }
  else {
    x$iter <- x$iter[ x$iter$nqtl >= nqtl, ]
    if( !nrow( x$iter ))
      stop( paste( "empty object: no iterations with number of QTL >=", nqtl ))
    x$loci <- x$loci[ x$loci$nqtl >= nqtl, ]
  }
  if( !is.null( pattern )) {
    mypat <- table( pattern )
    if( exact ) {
      mypat <- c( mypat, extra = 0 )
      patfn <- function( x, mypat, yourpat ) {
        tbl <- table( x )
        tmp <- match( names( tbl ), names( mypat ), nomatch = length( mypat ))
        yourpat[tmp] <- tbl[ tmp > 0 ]
        all( yourpat == mypat )
      }
    }
    else {
      patfn <- function( x, mypat, yourpat ) {
        tbl <- table( x )
        tmp <-  match( names( tbl ), names( mypat ), nomatch = 0 )
        yourpat[tmp] <- tbl[ tmp > 0 ]
        all( yourpat >= mypat )
      }
    }
    blank <- rep( 0, length( mypat ))
    names( blank ) <- names( mypat )
    iters <- unlist( tapply( x$loci$chrom, x$loci$niter, patfn,
                            mypat, blank, simplify = FALSE ))
    x$iter <- x$iter[iters,]
    if( !nrow( x$iter ))
      stop( paste( "empty object: no patterns like", pattern ))
    iters <- x$iter$niter
    x$loci <- x$loci[ !is.na( match( x$loci$niter, iters )), ]
  }
  if (!missing(chr)) {
    n.chr <- nchr( cross )
    if (is.logical(chr)) {
      if (length(chr) != n.chr) 
        stop(paste("If logical, chr argument must have length", 
                   n.chr))
      chr <- (1:n.chr)[chr]
    }
    if (is.numeric(chr)) {
      if (all(chr < 1)) 
        chr <- (1:n.chr)[chr]
      if (any(chr < 1 | chr > n.chr)) 
        stop("Chromosome numbers out of range.")
    }
    else {
      if (any(is.na(match(chr, names(x$geno))))) 
        stop("Not all chromosome names found.")
      chr <- match(chr, names(cross$geno))
    }
    chr <- sort( unique( chr ))
    kept <- match( seq( length( cross$geno )), chr, nomatch = 0)
    x$loci$chrom <- kept[x$loci$chrom]
    x$loci <- x$loci[x$loci$chrom > 0, ]
  }
  x
}
##############################################################################
bim.match <- function( bim, pattern )
{
  patfn <- function(x) {
    tmp <- paste( ifelse( x > 1,
                         paste( x, "*", sep=""),
                         "" ),
                 names( x ), collapse = ",", sep = "" )
    if( length( x ) > 1 )
      tmp <- paste( sum( x ), tmp, sep = ":" )
    tmp
  }
  mypat <- patfn( table( pattern ))
  counts <- tapply( bim$loci$chrom, bim$loci$niter, function( x ) table( x ),
    simplify = FALSE )
  patterns <- unlist( lapply( counts, patfn ))
  as.numeric( names( counts )[ !is.na( match( patterns, mypat )) ] )
}
##############################################################################
bim.cross <- function( bim )
{
  ## fake a cross based on bim object
  cross <- list( geno = tapply( bim$loci$locus, bim$loci$chrom,
                   function( x ) list( data = matrix(NA,0,0),
                                      map = c(0, max( x ))),
                   simplify = FALSE ),
                pheno = matrix( NA, 0, 0 ))
  for(i in seq(length(cross$geno)))
    class(cross$geno[[i]]) <- "A"
  class( cross ) <- c("f2","cross")
  names( cross$geno ) <- as.numeric( seq( along = cross$geno ))
  cross  
}
##############################################################################
bim.cex <- function( bim )
{
  2 ^ ( 2 - min( 4, max( 2, ( log10( nrow( bim$loci ))))))
}
##############################################################################
##############################################################################
plot.bim <- function( x, cross = bim.cross( x ),
                     nqtl = 1, pattern = NULL, exact = FALSE,
                     ... )
{
  cat( "time series of burnin and mcmc runs\n" )
  plot.bim.mcmc( x, ... )
  cat( "jittered plot of quantitative trait loci by chromosome...\n" )
  plot.bim.loci( x, cross, nqtl, pattern, exact, ... )
  cat( "model selection plots: number of QTL and chromosome pattern...\n" )
  model <- bim.model( x, cross, nqtl, pattern, exact, ... )
  summary( model )
  plot( model )
  cat( "quantitative trait loci (histogram) and effects (scatter plot)...\n" )
  qtl <- plot.bim.effects( x, cross, nqtl, pattern, exact, ... )
  summary( qtl )
  cat( "summary diagnostics as histograms and boxplots by number of QTL\n" )
  plot.bim.diag( x, nqtl, ... )
  invisible()
}
##############################################################################
plot.bim.mcmc <- function( x, element = c("burnin","iter"),
                          xlab = c("burnin sequence","mcmc sequence"),
                          items = names( x$iter )[-1],
                          ylabs = items,
                          types = c("b",rep("l", length( items ) - 1 )),
                          ... )
{
  tmpar <- par( mfcol = c( length( items ), length( element )),
               mar = c(3.1,3.1,0.1,0.1) )
  on.exit( par( tmpar ))

  for( s in seq( element )) for( i in seq( items )) {
    plot( x[[ element[s] ]]$niter, x[[ element[s] ]][[ items[i] ]],
         type = types[i], col = "grey20", xlab = "", ylab = "", ... )
    tmp <- bim.smooth( x[[ element[s] ]]$niter,
                      x[[ element[s] ]][[ items[i] ]] )
    lines( tmp$x, tmp$y, lwd = 3, col = "blue" )
    mtext( xlab[s], 1, 2, cex = 1 )
    mtext( ylabs[i], 2, 2, cex = 1 )
  }
  invisible()
}
##############################################################################
bim.smooth <- function( x, y )
{
  ux <- unique( x )
  if( length( ux ) < 50 ) {
#    smo <- list( x = sort( ux ),
#                y = rep( mean( y ), length( ux )))
#    smo$sd <- rep( mad( y ), length( smo$x ))
    lmy <- lm( y ~ x )
    smo <- list( x = sort( ux ),
                y = predict( lmy, data.frame( x = sort( ux ))),
                sd = rep( sqrt( sum( resid( lmy ) ^ 2 ) / lmy$df.resid ), length( ux )))
  }
  else {
    smo <- smooth.spline( x, y )
    smo$sd <- sqrt( pmax( 0, smooth.spline( x, ( y - predict( smo, x )$y ) ^ 2 )$y ))
  }
  smo  
}
##############################################################################
plot.bim.loci <- function( x, cross = bim.cross( x ),
                          nqtl = 1, pattern = NULL, exact = FALSE,
                          chr, labels = TRUE, amount = .35,
                          cex = bim.cex( x ), ... )
{
  amount <- max( 0, min( 0.45, amount ))
  x <- subset( x, cross, nqtl, pattern, exact, chr )
  
  cross <- subset( cross, chr )
  map <- pull.map( cross )
  nmap <- names( map )

  loci <- x$loci[ , c("chrom","locus") ]
  if( 0 == nrow( loci )) {
    warning( "no mcmc samples on chosen chromosomes: ",
      paste( chr, collapse = "," ))
    return( )
  }
  plot( range( loci$chrom ) + c(-.5,.5), range( loci$locus ),
       type = "n", xaxt = "n", xlab = "", ylab = "", ... )
  points( jitter( loci$chrom, , amount ), loci$locus, cex = cex )
  uchrom <- unique( loci$chrom )
  axis( 1, uchrom, nmap[uchrom] )
  mtext( "chromosome", 1, 2 )
  mtext( "MCMC sampled loci", 2, 2 )
  cxy <- par( "cxy" )[2] / 4

  if( !is.null( cross )) {
    for( i in uchrom ) {
      tmp <- map[[ nmap[i] ]]
      text( rep( i-.5, length( tmp )), cxy + tmp, names( tmp ),
        adj = 0, cex = 0.5, col = "blue" )
      for( j in tmp )
        lines( i + c(-.5,.5), rep( j, 2 ), col = "blue",
              lwd = 2 )
    }
  }
}
##############################################################################
bim.nqtl <- function( bim )
{
  ## posterior number of QTL
  posterior <- table( bim$iter$nqtl )
  ntrial <- sum( posterior )
  posterior <- posterior / ntrial
  ## prior number of QTL
  prior <- bim.prior( bim, as.numeric( names( posterior )))

  ## posterior/prior ratios for Bayes factor
  bf <- posterior / prior
  if( bf[1] > 0 & prior[1] > 0 )
    bf <- bf / bf[1]
  
  ## bfse = approximate Monte Carlo standard error for bf (actually binomial error )
  ## note that this is rescaled since bf[1] forced to be 1
  list( nqtl = 
       list( posterior = posterior, prior = prior, bf = bf,
            bfse = sqrt(( 1 - posterior ) / ( posterior * ntrial )) * bf ))
}
##############################################################################
bim.pattern <- function( bim, cross = bim.cross( bim ),
                        nqtl = 1, pattern = NULL, exact = FALSE,
                        cutoff = 1 )
{
  bim <- subset( bim, cross, nqtl, pattern, exact )
  loci <- bim$loci
  counts <- tapply( loci$chrom, loci$niter, function( x ) table( x ),
    simplify = FALSE )
  pattern <- unlist( lapply( counts, function(x) {
    tmp <- paste( ifelse( x > 1,
                         paste( x, "*", sep=""),
                         "" ),
                 names( x ), collapse = ",", sep = "" )
    if( length( x ) > 1 )
      tmp <- paste( sum( x ), tmp, sep = ":" )
    tmp
  } ))
  posterior <- rev( sort( table( pattern )))
  posterior <- posterior / sum( posterior )
  tmp <- posterior >= cutoff / 100
  if( sum( tmp ))
  posterior <- posterior[tmp]
  else {
    cat( "warning: posterior cutoff of ", cutoff,
        "is too large and is being ignored\n",
        "posterior range is", range( posterior ), "\n" )
  }
  if( length( posterior ) > 15 )
    posterior <- posterior[1:15]
  ucount <- match( names( posterior ), pattern )

  ## prior for pattern
  rng <- max( bim$iter$nqtl )
  pr <- bim.prior( bim, 0:rng )
  bf <- posterior
  map <- pull.map( cross )
  chrlen <- unlist( lapply( map, max ))
  nchrom <- length( chrlen )
  chrlen <- chrlen / sum( chrlen )
  
  names( chrlen ) <- seq( nchrom )
  fact <- rep( 1, rng )
  for( i in 2:(rng+1) ) 
    fact[i] <- fact[i-1] * i
  for( i in seq( posterior )) {
    ct <- counts[[ ucount[i] ]]
    st <- sum( ct )
    bf[i] <- pr[st] * prod( chrlen[ names( ct ) ] ^ ct ) *
      fact[st] / prod( fact[ct] )
  }

  ntrial <- length( pattern )
  prior <- bf
  bf <- posterior / prior
  if( bf[1] > 0 & prior[1] > 0 )
    bf <- bf / bf[1]

  ## bfse = approximate Monte Carlo standard error for bf (actually binomial error )
  ## note that this is rescaled since bf[1] forced to be 1
  list( pattern = 
       list( posterior = posterior, prior = prior, bf = bf,
            bfse = sqrt(( 1 - posterior ) / ( posterior * ntrial )) * bf ))
}
##############################################################################
bim.model <- function( bim, cross = bim.cross( bim ),
                      nqtl = 1, pattern = NULL, exact = FALSE,
                      cutoff = 1 )
{
  bim <- subset( bim, cross, nqtl, pattern, exact )
  assess <- list( )
  assess$nqtl <- bim.nqtl( bim )$nqtl
  assess$pattern <- bim.pattern( bim, cross, cutoff = cutoff )$pattern
  assess$param <- list( nqtl = nqtl, pattern = pattern, exact = exact,
                       cutoff = cutoff )
  class( assess ) <- "bim.model"
  assess
}
##############################################################################
summary.bim.model <- function( object, ... )
{
  if( !is.null( object$nqtl )) {
    cat( "posterior for number of QTL as %" )
    print( round( 100 * object$nqtl$posterior ))
    cat( "Bayes factor ratios for number of QTL")
    print( round( object$nqtl$bf, 1 ))
  }
  if( !is.null( object$pattern )) {
    cat( "model posterior above cutoff", object$param$cutoff, "as %\n" )
    print( round( 100 * object$pattern$posterior))
    cat( "Bayes factor ratios for chromosome pattern\n")
    print( round( object$pattern$bf, 1 ))
  }
  invisible()
}
##############################################################################
plot.bim.model <- function( x, cross = bim.cross( x ),
                           nqtl = 1, pattern = NULL, exact = FALSE,
                           cutoff = 1 ,
                           assess = bim.model( x, cross, nqtl, pattern, exact, cutoff ), ... )
{
  if( inherits( x, "bim.model" ))
    assess <- x
  is.nqtl <- !is.null( assess$nqtl )
  is.pattern <- !is.null( assess$pattern )
  tmpar <- par( mfrow = c( is.nqtl + is.pattern, 2 ))
  on.exit( par( tmpar ))
  if( is.nqtl )
    plot.bim.pattern( assess$nqtl, as.numeric( names( assess$nqtl$posterior )),
                     c("number of QTL","QTL posterior","QTL posterior"), NULL, ... )
  if( is.pattern )
    plot.bim.pattern( assess$pattern, ... )
  assess
}
##############################################################################
plot.bim.pattern <- function( x,
                             bars = seq( x$posterior ),
                             labels = c("model index","model posterior","pattern posterior"),
                             barlabels = names(x$posterior),
                             threshold = c( weak=3, moderate=10, strong=30 ),
                             units = 2, rescale = TRUE, ... )
{
  ## plot posterior
  bar <- barplot( x$posterior, col = "white", names = bars, ... )
  tmp <- if( rescale )
    x$prior * max( x$posterior ) / max( x$prior )
  else
    x$prior
  lines( bar, tmp, type = "b", col = "blue", lwd = 2 )
  if( !is.null( barlabels )) {
    cex <- 1
    usr <- par("usr")
    tmp <- as.numeric( 2 * ( x$posterior - usr[3] ) >= diff( usr[3:4] ))
    for( i in 0:1 ) {
      ii <- i == tmp
      if( any( ii ))
        text( bar[ii], x$posterior[ii], barlabels[ii], srt=90,
             adj= i, cex = cex )
    }
  }
  mtext( labels[1], 1, 2 )
  mtext( labels[2], 2, 2 )
  mtext( labels[3], 3, 0.5 )

  x$bf[ x$bf == 0 | x$prior == 0 ] <- NA

  plot( seq( bars ), x$bf, log = "y", xaxt = "n", xlim = c( 0.5, length( bars )),
    xlab = "", ylab = "", ... )
  mtext( labels[1], 1, 2 )
  mtext( "posterior / prior", 2, 2 )
  mtext( "Bayes factor ratios", 3, 0.5 )
  axis( 1, seq( bars ), bars )

  if( !is.null( barlabels )) {
    cxy <- par( "cxy" )[1] * cex / 2
    ## decypher number of QTL from pattern--kludge!
    nqtl <- strsplit( barlabels, "" )
    nqtl <- lapply( nqtl, function( x ) {
      colon <- seq( x )[ x == ":" | x == "*" ][1]
      x <- if( is.na( colon ))
        "1"
      else
        x[ seq( colon - 1 ) ]
      paste( x, collapse = "" )
    } )
    text( seq( barlabels ) - cxy, x$bf, nqtl, srt = 90, cex = cex )
  }

  usr <- 10^par( "usr" )[3:4]
  for( i in seq( bars ) ) {
    if( x$bfse[i] > 0 ) {
      bfbar <- x$bf[i] + c(-units,units) * x$bfse[i]
      bfbar[1] <- max( usr[1], bfbar[1] )
      bfbar[2] <- min( usr[2], bfbar[2] )
    }
    else
      bfbar <- usr
    lines( rep(i,2), bfbar )
  }
  ## put threshold yardstick on plot
  if( length( threshold )) {
    bars <- floor( mean( bars ) / 2 ) + 0.5
    maxusr <- usr[2]
    usr <- prod( usr ^ c(.95,.05) )
    lines( bars + c(-.25,.25), rep( usr, 2 ), lwd = 3, col = "blue" )
    texusr <- usr
    for( i in seq( length( threshold ))) {
      sigusr <- min( maxusr, usr * threshold[i] )
      if( texusr < maxusr )
        text( bars + 0.5, sqrt( texusr * sigusr ), names( threshold )[i],
             col = "blue", adj = 0 )
      arrows( bars, usr, bars, sigusr, 0.1, lwd = 3, col = "blue" )
      texusr <- sigusr
    }
  }
  invisible( x )
}
##############################################################################
### marginal histograms
##############################################################################
plot.bim.diag <- function( x,
                     nqtl = 1, pattern = NULL, exact = FALSE,
                     items= names( x$iter )[-(1:2)],
                     mains = items,
                     mfrow = c(nhist,2), ... )
{
  x <- subset( x,, nqtl, pattern, exact )
  nhist <- length( items )
  tmpar <- if( !is.null( mfrow ))
    par( mfrow = mfrow, mar=c(3.6,4.1,0.6,0.1) )
  else
    par( mar=c(3.6,4.1,0.6,0.1) )
  on.exit( par( tmpar ))
  mains[ match( "herit", mains, nomatch = 0 ) ] <- "heritability"
  for( i in seq( nhist )) {
    ## marginal histogram
    main <- as.expression( substitute( paste( "marginal ", main, ", ",
        italic(m) >=  nqtl),
        list( nqtl = nqtl, main = mains[i] )))
    tmp <- x$iter[ , items[i] ]
    tmp <- tmp[ !is.na( tmp ) ]
    med <- quantile( tmp, c(.25,.5,.75) )
    plot( density(tmp ), main = "", xlab = "", ylab = "", ... )
    mtext( "density", 2, 2.5 )
    mtext( main, 1, 2.5 )
    ## hand-made boxplot on its side
    b <- boxplot( tmp, plot = FALSE )
    tmp <- par("usr")[4] / 8
    up <- tmp * 1.5
    polygon( b$stats[c(2,4,4,2)], up+c(0,0,tmp,tmp))
    lines( rep(b$stats[3],2), up+c(0,tmp) )
    lines( b$stats[1:2], up+rep(tmp/2,2), lty = 2 )
    lines( b$stats[4:5], up+rep(tmp/2,2), lty = 2 )
    lines( rep(b$stats[1],2), up+tmp*c(1,3)/4 )
    lines( rep(b$stats[5],2), up+tmp*c(1,3)/4 )

    ## conditional boxplots
    tmp <- split( x$iter[[ items[i] ]], x$iter$nqtl )
    boxplot( tmp )
    mtext( paste( mains[i], "conditional on number of QTL" ), 1, 2.5 )
    mtext( mains[i], 2, 2.5 )

    cat( items[i], round( med[2], 3 ), "\n" )
    cat( "conditional", mains[i], "\n" )
    print( round( unlist( lapply( tmp, median, na.rm = TRUE )), 3 ))
  }
}
#####################################################################
##
## bmapqtl.options.R, 08/14/2003, hao@jax.org
##
##     Copyright (C) 2002 Brian S. Yandell
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################

## default values for options, these are global variables
bmapqtl.options.init <- function() {
.bmapqtl.options <<- NULL
.bmapqtl.options$prior.nqtl <<- "geometric"
.bmapqtl.options$mean.nqtl <<- 3 # prior for number of QTL
.bmapqtl.options$niter <<- 400000
.bmapqtl.options$by <<- 400 # number of iterations, recorded by
.bmapqtl.options$burnin <<- 0.05
.bmapqtl.options$preburn <<- 0.05 # burn-in and pre-burn-in
.bmapqtl.options$nqtl <<- 0 # initial number of QTL
.bmapqtl.options$init <<- c(0.5, -1) # normal(0,.5*s^2)
.bmapqtl.options$prior.mean <<-  c(1,-1) # normal(0,s^2)
.bmapqtl.options$prior.var <<- c(3,-1) # IG(3,s^2)
.bmapqtl.options$prior.add <<- c(0,0) # Beta(2,10)
.bmapqtl.options$prior.dom <<- c(0,0) # Beta(2,10)
.bmapqtl.options$seed <<- 0 # random seed
assign(".bmapqtl.options",.bmapqtl.options,1)
}
bmapqtl.options <- function(...,reset=FALSE)
{
  # take the arguments
  args <- list(...)
  nargu <- length(args)

  # return variable
  if( reset |!exists(".bmapqtl.options")) {
      bmapqtl.options.init()
    result <- .bmapqtl.options
  }
  else
    result <- list(NULL)
  # assign values
  if(nargu&!reset) {
    for (i in 1:nargu) {
      argname <- names(args)[i] # argument name
      argvalue <- args[[i]] # argument value
      if(is.null(argname)) { # trying to get an option
        result[[i]] <- .bmapqtl.options[[argvalue]]
        names(result)[i] <- argvalue
      }
      else {
        # trying to assign an option
        # error checking stuff here
        switch( argname,
               "mean.nqtl" = {
                 if(any(argvalue < 0))
                   stop("Prior for number of QTL need to be greater than or equal to zero")
               },
               "niter" = {
                 if(any(argvalue <= 0))
                   stop("Number of iterations need to be greater than zero")
               },
               "seed" = {
                 if(any(argvalue < 0))
                   stop("Random number seed need to be greater than or equal to zero")
               },
               "prior.nqtl" = {
                 priors = c("geometric","poisson","uniform")
                 argvalue <- priors[ pmatch( tolower( argvalue ), priors, nomatch = 1 ) ]
               }
               )
        # assign values
        .bmapqtl.options[[argname]] <<- argvalue
        result[[i]] <- .bmapqtl.options[[argname]]
        names(result)[i] <- argname
      }
    }
    # if nqtl is bigger than zero, need to add chrom and locus fields
    #if( .bmapqtl.options$nqtl > 0 ) {
    #  .bmapqtl.options$chrom <<- rep(1, .bmapqtl.options$nqtl)
    #  .bmapqtl.options$locus <<- rep(1, .bmapqtl.options$nqtl)
    #}
  }
  cat( "simulate", as.integer( .bmapqtl.options$niter ), "MCMC steps, recording by",
      as.integer( .bmapqtl.options$by ), "with", .bmapqtl.options$burnin,
      "burnin and", .bmapqtl.options$preburn, "pre-burnin\n" )
  cat( paste( "prior for number of QTL: ", .bmapqtl.options$prior.nqtl, "(",
             .bmapqtl.options$mean.nqtl, ")\n", sep = "" ))
  cat( "initial number of QTL:", .bmapqtl.options$nqtl, "\n" )
  cat( "hyperparameters for priors:\n" )
  print(t(data.frame(.bmapqtl.options[8:12])))
  cat( "random seed:", .bmapqtl.options$seed, "\n" )
  invisible(result)
}

#####################################################################
##
## $Id: bmapqtl.r,v 1.1 2004/04/30 14:04:18 jgentry Exp $
##
##     Copyright (C) 2002 Brian S. Yandell
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################


read.bmapqtl <- function( dir = ".",
                         nvalfile = "nval.dat" )
{
  cat( "Bmapqtl parameter file is", nvalfile, "in directory", dir,  "\n" )
  if (!missing(dir)) {
    n <- nchar(dir)
    if (substring(dir, n, n) == "/") 
      dir <- substring(dir, 0, n - 1)
    nvalfile <- file.path(dir, nvalfile )
  }
  nvals <- scan( nvalfile, 0, nmax = 6, quiet = TRUE )
  nval1 <- nvals[1]
  prior <- c("poisson","geometric","uniform")
  if( nval1 < 1 | nval1 > 3 )
    stop( paste( "can only handle these priors:", paste( prior, collapse = ", " )))
  nval1 <- prior[nval1]
  name.vals <- c( nval1,"burnin","preburn","niter","by","nqtl")
  nqtl <- nvals[6]
  
  nvals <- scan( nvalfile, 0, nmax = 6 + 2 * nqtl + 11, quiet = TRUE )
  
  if( nqtl > 0 ) {
    name.vals <- c( name.vals,
                   paste( "chrom", seq( nqtl ), sep = "" ),
                   paste( "locus", seq( nqtl ), sep = "" ))
  }
  bmapqtl <- list( prior.nqtl = nval1, mean.nqtl = nvals[17+2*nqtl],
                  niter = nvals[4], by = nvals[5],
                  burnin = nvals[2], preburn = nvals[3],
                  nqtl = nvals[6] )
  if( nqtl > 0 ) {
    bmapqtl$chrom <- nvals[6+seq(nqtl)]
    bmapqtl$locus <- nvals[6+nqtl+seq(nqtl)]
  }
  bmapqtl$init <- nvals[6+2*nqtl+1:2]
  bmapqtl$prior.mean <- nvals[8+2*nqtl+1:2]
  bmapqtl$prior.var <- nvals[10+2*nqtl+1:2]
  bmapqtl$prior.add <- nvals[12+2*nqtl+1:2]
  bmapqtl$prior.dom <- nvals[14+2*nqtl+1:2]
  bmapqtl$runfile <- nvalfile
  for( i in names(bmapqtl))
    .bmapqtl.options[[i]] <<- bmapqtl[[i]]
  bmapqtl
}


##############################################################################
write.bmapqtl <- function( dir = ".", nvalfile = "nval.dat" )
{
  # get variables from options
  prior.nqtl <- .bmapqtl.options$prior.nqtl
  mean.nqtl <- .bmapqtl.options$mean.nqtl
  mean.nqtl <- .bmapqtl.options$mean.nqtl
  niter <- .bmapqtl.options$niter
  by <- .bmapqtl.options$by
  burnin <- .bmapqtl.options$burnin
  preburn <- .bmapqtl.options$preburn
  nqtl <- .bmapqtl.options$nqtl
  init <- .bmapqtl.options$init
  prior.mean <- .bmapqtl.options$prior.mean
  prior.var <- .bmapqtl.options$prior.var
  prior.add <- .bmapqtl.options$prior.add
  prior.dom <- .bmapqtl.options$prior.dom
  # make chrom and locus from nqtl
  chrom <- rep( 1, nqtl )
  locus <- rep( 1, nqtl )
  
  cat( "Creating Bmapqtl parameter file", nvalfile, "in directory", dir,  "\n" )
  if (!missing(dir)) {
    n <- nchar(dir)
    if (substring(dir, n, n) == "/") 
      dir <- substring(dir, 0, n - 1)
    nvalfile <- file.path(dir, nvalfile )
  }
  if( file.exists( nvalfile )) {
    warning( paste( "previous file", nvalfile, "moved to *.mov" ))
    file.rename( nvalfile, paste( nvalfile, "mov", sep = "." ))
  }
  ## choice of prior for number of QTL
  priors <- c("poisson","geometric","uniform","exponential")
  prior.nqtl <- pmatch( tolower( prior.nqtl ), priors )
  if( is.na( prior.nqtl ))
    stop( paste( "prior must be one of", paste( priors[1:3], collapse = ", " )))
  if( prior.nqtl == 4 )
    prior.nqtl <- 2
  ## burnin and preburn
  write( prior.nqtl, nvalfile, append=FALSE)
  write( paste( burnin, preburn ), nvalfile, append=TRUE)
  write( paste( as.integer( c( niter, by )), collapse = " " ), nvalfile, append=TRUE)
  write( nqtl, nvalfile, append=TRUE)
  if( nqtl > 0 ) {
    write( paste( chrom, collapse = " " ), nvalfile, append=TRUE)
    write( paste( locus, collapse = " " ), nvalfile, append=TRUE)
  }
  write( paste( init, collapse = " " ), nvalfile, append=TRUE)
  write( paste( prior.mean, collapse = " " ), nvalfile, append=TRUE)
  write( paste( prior.var, collapse = " " ), nvalfile, append=TRUE)
  write( paste( prior.add, collapse = " " ), nvalfile, append=TRUE)
  write( paste( prior.dom, collapse = " " ), nvalfile, append=TRUE)
  write( mean.nqtl, nvalfile, append = TRUE )

  read.bmapqtl( nvalfile = nvalfile )
}
#####################################################################
##
## $Id: effects.r,v 1.1 2004/04/30 14:04:18 jgentry Exp $
##
##     Copyright (C) 2002 Brian S. Yandell
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################
bim.qtl <- function( x, cross = bim.cross( x ),
                    nqtl=1, pattern=NULL, exact = FALSE, chr,
                    bw = 2, levels = seq( 0.5, 0.95, by = 0.05 ))
{
  ## subset x and cross
  if (!is.null(pattern)) 
    nqtl <- max(nqtl, length(pattern))
  x <- subset(x, cross, nqtl, pattern, exact, chr )
  if( is.numeric( pattern ))
    pattern <- names( cross$geno )[pattern]
  cross <- subset( cross, chr )
  map <- pull.map( cross )
  pattern <- match( pattern, names( map ))
  pattern <- pattern[ !is.na( pattern ) ]

  ## smooth estimate of loci density by chromosome
  dens <- tapply( x$loci$locus, x$loci$chrom,
                 function( data, bw, len ) {
                   tmp <- density( data, bw = bw )
                   ## need to rescale height so total area is 1
                   tmp$y <- tmp$y * length( data ) / len
                   tmp
                 }, bw, length( x$loci$locus ),
                 simplify = FALSE )
  
  ## HPD region across genome: find density critical values
  y <- unlist( lapply( dens, function( chr ) chr$y ))
  o <- order( -y )
  p <- cumsum( unlist( lapply( dens, function( chr ) chr$y / ( chr$x[2] - chr$x[1] )))[o] )
  p <- p / max( p )

  hpd <- numeric( length( levels ))
  names( hpd ) <- levels
  for (i in seq(along = levels)) {
    tmp <- p <= levels[i]
    if( !any( tmp ))
      tmp <- 1
    hpd[i] <- min(y[o][tmp])
  }

  smo <- lapply( dens, function( tmp, nqtl ) {
    ## find where density peaks by downturn on both sides
    n <- length(tmp$y)
    index <- (tmp$y >= c(0, tmp$y[-n])) & (tmp$y >= c(tmp$y[-1], 0))
    index <- seq(n)[index]
    o <- order(-tmp$y[index])
    x <- tmp$x[index][o][seq(nqtl)]
    y <- tmp$y[index][o][seq(nqtl)]
    data.frame( x = x, y = y ) }, nqtl )

  findpeaks <- function( smo, nqtl )
  {
    peaks <- data.frame(chr = rep( names( smo ), rep(nqtl,length(smo))),
                        x = unlist( lapply( smo, function( chr ) chr$x )),
                        y = unlist( lapply( smo, function( chr ) chr$y )))
    peaks <- peaks[ !is.na( peaks$x ), ]
    peaks <- peaks[ order( -peaks$y )[ seq( nqtl ) ], ]
    peaks
  }
  if( !is.null( pattern )) {
    tbl <- table( pattern )
    ## estimate density across genome and find putative QTL peaks
    toploci <- data.frame( chr = ordered( character( nqtl ), names( smo )),
                          x = numeric( nqtl ), y = numeric( nqtl ))
    nloci <- 0
    for( i in names( tbl )) {
      toploci[ nloci + seq( tbl[i] ), c("x","y") ] <- smo[[i]][ seq( tbl[i] ), ]
      toploci[ nloci + seq( tbl[i] ), "chr" ] <- i
      smo[[i]][ seq( tbl[i] ), ] <- rep( NA, 2 )
      nloci <- nloci + tbl[i]
    }
    ## if nqtl larger than pattern, find next highest peaks
    if( nloci < nqtl )
      toploci[ nloci + seq( nqtl - nloci ), ] <-
        findpeaks( smo, nqtl )[ seq( nqtl - nloci ), ]
  }
  else
    toploci <- findpeaks( smo, nqtl )
  names( dens ) <- names( map )[ as.numeric( names( dens )) ]
  toploci$chr <- ordered( names( map )[ as.numeric( as.character( toploci$chr )) ],
                         names( map ))
  names( toploci ) <- c("chr","loci","dens")
  qtl <- list( loci = toploci, dens = dens, hpd = hpd )
  class( qtl ) <- "bim.qtl"
  qtl
}
##############################################################################
bim.effects <- function (x, cross = bim.cross( x ),
                         nqtl = 1, pattern = NULL, exact = FALSE, chr,
                         bw = 2, 
                         qtl = bim.qtl( x, cross, nqtl, pattern, exact,, bw ))
{
  estfn <- function(locus, add, chrom, loci, nchr ) {
    nloci <- names(loci)
    est <- sd <- double(length(nloci))
    names(est) <- nloci
    smo <- list()
    for (i in sort( unique(chrom))) {
      ii <- i == chrom
      esti <- nchr[i] == nloci
      smo[[ nchr[i] ]] <- bim.smooth(locus[ii], add[ii])
      ## now find estimate where this overlaps with loci!
      if (any(esti)) 
        for (j in seq(esti)[esti]) {
          x <- abs( smo[[ nchr[i] ]]$x - loci[j])
          est[j] <- mean( smo[[ nchr[i] ]]$y[x == min(x)])
          sd[j] <- sqrt( mean(smo[[ nchr[i] ]]$sd[x == min(x)]^2))
        }
    }
    list( smo = smo, est = est, sd = sd )
  }
  
  ## subset bim and cross
  if (!is.null(pattern)) 
    nqtl <- max(nqtl, length(pattern))
  x <- subset(x, cross, nqtl, pattern, exact, chr )
  if( !is.null( pattern ) & is.numeric( pattern ))
    pattern <- names( cross$geno )[pattern]
  cross <- subset( cross, chr )
  nchr <- names( cross$geno )
  if( !is.null( pattern )) {
    pattern <- match( pattern, nchr )
    pattern <- pattern[ !is.na( pattern ) ]
  }
  domhere <- !is.na(match("dom", names(x$loci)))

  ## grand mean
  mean <- mean( x$iter$mean )
  mean.sd <- sqrt( var( x$iter$mean ))
  loci <- qtl$loci$loci
  names( loci ) <- as.character( qtl$loci$chr )
  
  ## additive effect
  est <- estfn(x$loci$locus, x$loci$add, x$loci$chrom, loci, nchr )
  qtl$add <- est$smo

  tmp <- data.frame(chrom = c(names(loci),"mean"),
                    loci = c(qtl$loci$loci,NA),
                    add = c(est$est,mean),
                    add.sd = c(est$sd,mean.sd) )
  
  ## dominance effect if present
  if (domhere) {
    est <- estfn(x$loci$locus, x$loci$dom, x$loci$chrom, loci, nchr )
    tmp$dom <- c(est$est,NA)
    tmp$dom.sd <- c(est$sd,NA)
    qtl$dom <- est$smo
  }
  qtl$est <- tmp
  ## make sure object is of class bim.qtl
  class( qtl ) <- "bim.qtl"
  invisible( qtl )
}
##############################################################################
summary.bim.qtl <- function( object, ... )
{
  if( !is.null( object$loci )) {
    cat( "\nQTL loci and density peaks:\n" )
    print( object$loci )
  }
  if( !is.null( object$hpd )) {
    cat( "\nHPD region density cutoffs:\n" )
    print( object$hpd )
  }
  if( !is.null( object$est )) {
    cat( "\nQTL loci and effect estimates:\n" )
    print( object$est )
  }
  if( !is.null( object$dens )) {
    cat( "\nQTL density estimates by chromosome at",
        length( object$dens[[1]]$x ), "grid points with bw =",
        object$dens[[1]]$bw, "\n" )
  }
  if( !is.null( object$add )) {
    cat( "\nSmoothing spline parameters for additive effects:\n" )
    print( unlist(lapply( object$add, function(x) x$spar )))
  }
  if( !is.null( object$dom )) {
    cat( "\nSmoothing spline parameters for dominance effects:\n" )
    print( unlist(lapply( object$add, function(x) x$spar )))
  }
  invisible()
}
##############################################################################
plot.bim.effects <- function (x, cross = bim.cross( x ),
                              nqtl = 1, pattern = NULL, exact = FALSE, chr,
                              bw = 2,
                              qtl = bim.effects(x, cross,
                                nqtl, pattern, exact,, bw ),
                              cex = bim.cex(x), level = .80,
                              project = substitute(x), main = mains,
                              mfcol = c(2 + domhere, 1), ...) 
{
  project <- project
  mpos <- function(cross, cumchrlen, loci, est = rep(0, length(loci))) {
    ## place marker positions on map
    map <- pull.map( cross )
    usr <- par("usr")[3]
    for (i in seq(length(cumchrlen) - 1))
      points(cumchrlen[i] + map[[i]], rep(usr, length( map[[i]])), 
             pch = 2, col = "purple", lwd = 3)

    if (length(cumchrlen) > 2) 
      abline(v = cumchrlen - 2.5)
    points(loci, est, col = "red", lwd = 3, cex = 2)
    abline(v = loci, lty = 2, col = "red", lwd = 3)
    cchrlen <- cumchrlen
    cchrlen <- (cchrlen[-length(cchrlen)] + cchrlen[-1] - 
                5)/2
    mtext( names( cchrlen ), 1, 0.25, at = cchrlen,
          cex = 1 / ceiling( length( cchrlen ) / 15 ))
  }
  plotfn <- function(locus, add, chrom, main, ylab, smo, cumchrlen, cex, ...) {
    plot(locus, add, cex = cex, bty = "l", col = "grey40", 
         xlim = par( "usr" )[1:2], xaxs = "i", xlab = "", ylab = "", ...)
    mtext(ylab, 2, 2, cex = 1)
    mtext(main, 3, 1)

    for (i in names( smo )) {
      lines(cumchrlen[i] + smo[[i]]$x, smo[[i]]$y, lwd = 3, col = "blue")
      lines(cumchrlen[i] + smo[[i]]$x, smo[[i]]$y + 2 * smo[[i]]$sd, lwd = 3, col = "blue", lty = 2 )
      lines(cumchrlen[i] + smo[[i]]$x, smo[[i]]$y - 2 * smo[[i]]$sd, lwd = 3, col = "blue", lty = 2 )
    }
    abline(h = 0)
  }
  ## subset bim and cross
  x <- subset(x, cross, nqtl, pattern, exact, chr )
  if( !is.null( pattern ) & is.numeric( pattern ))
    pattern <- names( cross$geno )[pattern]
  cross <- subset( cross, chr )
  if( !is.null( pattern )) {
    fullpattern <- pattern
    pattern <- match( pattern, names( cross$geno ))
    pattern <- pattern[ !is.na( pattern ) ]
    nqtl <- length(pattern)
  }
  else
    fullpattern <- NULL
  domhere <- !is.na(match("dom", names(x$loci)))

  ## string chromosomes together with 5cM gap between
  map <- pull.map( cross )
  chrlen <- unlist(lapply(map, max))
  cumchrlen <- c(0, cumsum(5 + chrlen))
  names(cumchrlen) <- c(names(chrlen), "xxx")
  locus <- x$loci$locus + cumchrlen[x$loci$chrom]

  ## QTL loci
  loci <- qtl$loci$loci
  names( loci ) <- as.character( qtl$loci$chr )
  loci <- loci + cumchrlen[names(loci)]

  ## titles and plot setup
  if( is.null( pattern )) {
    mains <- paste( project, "summaries with number or QTL" )
    tmp <- nqtl
  }
  else {
    mains <- paste( project, "summaries with pattern" )
    tmp <- paste( as.character( fullpattern ), collapse = "," )
  }
  mains <- if( exact )
    as.expression( substitute( paste( main, dum == nqtl ),
        list( main = mains, dum = "", nqtl = tmp )))
    else
      as.expression( substitute( paste( main, dum >= nqtl ),
        list( main = mains, dum = "", nqtl = tmp )))
  tmp <- length(main)
  if (tmp < 3) 
    main[(1 + tmp):3] <- ""
  tmpar <- if (!is.null(mfcol)) 
    par(mfcol = mfcol, mar = c(3.1, 3.1, 3.1, 0.1))
  else par(mar = c(3.1, 3.1, 3.1, 0.1))
  on.exit(par(tmpar))

  ## conditional loci histogram and effect scatter plot
  aa <- hist(locus, breaks = seq(0, ceiling(max(cumchrlen)), 1),
             prob = TRUE, xlab = "", main = "", ylab = "", ...)
  mtext("loci histogram", 2, 2, cex = 1)
  mtext(main[1], 3, 1)
  ## HPD region (set level to 0.80 if no match)
  level <- match( round( level, 2 ), names( qtl$hpd ), nomatch = 7 )
  hpd <- qtl$hpd[level]
  for( i in names( chrlen )) {
    if( length( qtl$dens[[i]]$x )) {
    ## density lines
      lines( cumchrlen[i] + qtl$dens[[i]]$x, qtl$dens[[i]]$y, col = "blue",
            lwd = 3 )
      ## HPD regions
      in.hpd <- qtl$dens[[i]]$y > hpd
      points( cumchrlen[i] + qtl$dens[[i]]$x[in.hpd], rep( 0, sum( in.hpd )),
             col = "red" )
    }
  }
  mpos(cross, cumchrlen, loci)

  ## additive effects
  plotfn(locus, x$loci$add, x$loci$chrom, 
                main[2], "additive", qtl$add, cumchrlen, cex, ...)
  mpos(cross, cumchrlen, loci, qtl$est$add[ seq( nqtl ) ] )

  ## dominance effects if present
  if (domhere) {
    plotfn(locus, x$loci$dom, x$loci$chrom, 
                  main[3], "dominance", qtl$dom, cumchrlen, cex, ...)
    mpos(cross, cumchrlen, loci, qtl$est$dom[ seq( nqtl ) ] )
  }
  invisible( qtl )
}
##############################################################################
plot.bim.qtl <- function (x, cross = bim.cross( x ),
                          nqtl = 1, pattern = NULL, exact = FALSE, chr, bw = 2,
                          qtl = bim.qtl( x, cross, nqtl, pattern, exact,, bw ),
                          level = .8, col = "black", add = FALSE, ...) 
{
  mpos <- function(cross, cumchrlen ) {
    ## place marker positions on map
    map <- pull.map( cross )
    usr <- par("usr")[3]
    for (i in seq(length(cumchrlen) - 1))
      points(cumchrlen[i] + map[[i]], rep(usr, length( map[[i]])), 
             pch = 2, col = "purple", lwd = 3)

    if (length(cumchrlen) > 2) 
      abline(v = cumchrlen - 2.5)
    cchrlen <- cumchrlen
    cchrlen <- (cchrlen[-length(cchrlen)] + cchrlen[-1] - 
                5)/2
    mtext( names( cchrlen ), 1, 0.25, at = cchrlen,
          cex = 1 / ceiling( length( cchrlen ) / 15 ))
  }
  ## subset bim and cross
  x <- subset(x, cross, nqtl, pattern, exact, chr )
  cross <- subset( cross, chr )

  ## string chromosomes together with 5cM gap between
  map <- pull.map( cross )
  chrlen <- unlist(lapply(map, max))
  cumchrlen <- c(0, cumsum(5 + chrlen))
  names(cumchrlen) <- c(names(chrlen), "xxx")

  ## new plot?
  if( !add ) {
    tmpar <- par(mar = c(3.1, 3.1, 3.1, 0.1))
    rangey <- range( unlist( lapply( qtl$dens, function( chr ) chr$y )))
    plot( c(0,max( cumchrlen )), rangey,
         type = "n", xlab = "", ylab = "" )
    mtext("loci histogram", 2, 2, cex = 1)
    mtext("position in cM along genome", 1,2)
    mpos(cross, cumchrlen )
  }
  ## density lines
  for (i in names(chrlen))
    lines(qtl$dens[[i]]$x + cumchrlen[i], qtl$dens[[i]]$y, col = col, lwd = 3)
  ## HPD region (set level to 0.80 if no match)
  level <- match( round( level, 2 ), names( qtl$hpd ), nomatch = 7 )
  hpd <- qtl$hpd[level]
  abline( h = hpd, col = col, lty = 2 )

  invisible( qtl )
}
#####################################################################
##
## $Id: fdr.r,v 1.1 2004/04/30 14:04:19 jgentry Exp $
##
##     Copyright (C) 2003 Brian S. Yandell
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################
bim.fdr <- function( x, cross, nqtl = 1, pattern=NULL, exact=FALSE, chr, ...,
                    levels = seq( 0.01, 0.99, by = 0.01 ), df = 3,
                    qtl = bim.qtl( x, cross, nqtl, pattern, exact, ..., levels = levels ))
{
  levels <- names( qtl$hpd )

  ## subset bim and cross
  if (!is.null(pattern)) 
    nqtl <- max(nqtl, length(pattern))
  x <- subset(x, cross, nqtl, pattern, exact, chr )
  if( is.numeric( pattern ))
    pattern <- names( cross$geno )[pattern]
  if( !missing( chr ))
    cross <- subset( cross, chr )
  map <- pull.map( cross )
  pattern <- match( pattern, names( map ))
  pattern <- pattern[ !is.na( pattern ) ]

  ## collapse map for internal use
  map <- unlist( lapply( map, function( x ) diff( range( x ))))
  ## size under H0: no QTL at any locus
  size <- lapply( qtl$dens, function( ch, hpd, levels ) {
    width <- diff( ch$x[1:2] )
    size <- numeric( length( levels ))
    names( size ) <- levels
    for( i in levels )
      size[i] <- width * sum( ch$y > hpd[i] )
    size
  }, qtl$hpd, levels )
  size <- as.data.frame( size )
  nal <- names( size )
  size$all <- size[[1]] * 0
  for( i in nal) {
    tmp <- pmin( map[i], size[[i]] )
    size[[i]] <- pmin( 1, tmp / map[i] )
    size$all <- size$all + tmp
  }
  size$all <- size$all / sum( map )
  ## power under H1: QTL at locus = HPD levels
  levels <- as.numeric( levels )
  
  ## prior probability of no QTL at locus
  prob <- ( 1 - levels ) / ( 1 - size$all )
  prob[ prob == Inf ] <- NA
  tmp <- !is.na( prob )
  spline <- smooth.spline( size$all[tmp], prob[tmp], df = df )
  hyp <- c( H0 = min( spline$y ), M0 = mean( x$iter$nqtl == 0 ))
  hyp["M1"] <- 1 - hyp["M0"]
  print( hyp )
  
  ## positive false discovery rate (my Bayesian spin)
  pfdr <- size
  for( i in nal) {
    pfdr[[i]] <- hyp["H0"] * size[[i]] /
      ( hyp["M0"] * size[[i]] + hyp["M1"] * levels )
  }
  pfdr$all <- size$all / ( hyp["M0"] * size$all + hyp["M1"] * levels )
  invisible( list( levels = levels, size = size, fdr = pfdr,
                  hyp = hyp, prob = prob, spline = spline ))
}
################################################################################
plot.bim.fdr <- function( x, cross, ..., fdr = bim.fdr( x, cross, ... ),
                          critical.value = seq(0.05,0.25,by=.05), hpd = NULL )
{
  par( mfrow = c(1,2), mar = c(3.1,3.1,0.2,3.1))
  ## plot estimate prior of no QTL at any given locus
  ## as limit as size -> 0
  plot(fdr$size$all,fdr$prob, xlab = "", ylab = "", ylim=c(0,1))
  mtext( "relative size of HPD region", 1, 2 )
  mtext( "pr( H=0 | p>size )", 2, 2 )
  lines( fdr$spline$x, fdr$spline$y,col="blue",lwd = 3)
  ## plot pFDR and size vs. power
  plot( range( fdr$levels ), c(0,1), type = "n", xlab = "", ylab = "" )
  mtext( "pr( locus in HPD | m>0 )",1,2)
  mtext( "BH pFDR(-) and size(.)", 2, 2 )
  tmp <- pretty( c(0,fdr$hyp["H0"]) )
  axis( 4, tmp/fdr$hyp["H0"], as.character(tmp ))
  mtext( "Storey pFDR(-)", 4, 2 )
  lines( fdr$levels, fdr$size$all, lwd = 3, lty = 3 )
  lines( fdr$levels, fdr$fdr$all, lwd = 3 )
  if( is.null( hpd )) {
    ncrit <- length( critical.value )
    power <- numeric( ncrit )
    for( i in seq( ncrit )) {
      tmp <- critical.value[i] / fdr$hyp["H0"]
      power[i] <- max( fdr$levels[ fdr$fdr$all <= tmp ] )
      lines( c( rep( power[i], 2 ), 1 ), c( 0, rep( tmp, 2 )), col = "red", lwd = 3 )
    }
  }
  else {
    ncrit <- length( hpd )
    power <- critical.value <- numeric( ncrit )
    for( i in seq( ncrit )) {
      tmp <- fdr$levels <= hpd[i]
      power[i] <- max( fdr$levels[tmp] )
      critical.value[i] <- max( fdr$fdr$all[tmp] )
      lines( c( rep( power[i], 2 ), 1 ), c( 0, rep( critical.value[i], 2 )), col = "red", lwd = 3 )
    }
    critical.value <- critical.value * fdr$hyp["H0"]
  }
  names( power ) <- as.character( round( critical.value, 3 ))
  list(hyp = round( fdr$hyp, 3 ), fdr = power )
}
#####################################################################
##
## $Id: run.bmapqtl.r,v 1.1 2004/04/30 14:04:19 jgentry Exp $
## run.bmapqtl.R, 08/14/2003 hao@jax.org
##
## Part of the R/bim package
##
## run.bmapqtl calls MCMC simulation
##
##     Copyright (C) 2003 Hao Wu, The Jackson Lab, & Brian S. Yandell, UW-Madison
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################

run.bmapqtl <- function(cross, pheno=1, chrom=0, result.file="")

{
  if( !exists( ".bmapqtl.options" ))
    bmapqtl.options()
  ## error checking stuff
  if (class(cross)[2] != "cross")
    stop("The first input variable is not an object of class cross.")
  if(is.character(pheno))
    pheno <- pmatch(pheno,names(cross$pheno),nomatch=0)
  if(pheno <= 0)
    stop("Phenotype column number need to be positive")
  if(chrom < 0)
    stop("Chromosome number cannot be negative")

  # prepare data
  # number of chromosomes
  if(chrom == 0)
    chrom <- 1:nchr(cross)
  
  # map data
  chr.array <- NULL
  nmar.array <- NULL
  pos.array <- NULL
  dist.array <- NULL
  # loop thru chromosomes
  for(i in chrom) {
    # marker position
    pos.i <- cross$geno[[i]]$map
    pos.array <- c(pos.array, pos.i)
    # chromosome
    chr.i <- rep(i, length(pos.i))
    chr.array <- c(chr.array, chr.i)
    # marker order
    nmar.i <- 1:length(pos.i)
    nmar.array <- c(nmar.array, nmar.i)
    # distance
    dist.i <- c( (pos.i[-1]-pos.i[-max(nmar.i)]), 0)
    dist.array <- c(dist.array, dist.i)
  }

  ## find the index for individuals with missing phenotypes
  ## and exclude them later
  idx.missing <- which(is.na(cross$pheno[,pheno]))
  
  ## there are more cross types in QTLCart than in R/qtl
  ## need to extend that in R/qtl (add one more class?)
  cross.str <- class(cross)[1]

  ## make genotype matrix
  genodata <- NULL
  for(i in chrom) {
    if(length(idx.missing) != 0)
      tmp <- as.matrix(cross$geno[[i]]$data[-idx.missing,])
    else
      tmp <- as.matrix(cross$geno[[i]]$data)
    
    ## change the coding to:
    ## AA -> 1, AB -> 0, BB -> -1, missing -> -3
    ## not AA -> -2, not BB -> 2
    ## but R/qtl's riself and risib changed BB to AB, so change back
    
    #tmp[is.na(tmp)] <- -3 # missing
    #tmp[tmp==2] <- 0 # AB
    #tmp[tmp==3] <- -1 #BB
    #tmp[tmp==4] <- 2 # not BB
    #tmp[tmp==5] <- -2 # not AA
    #tmp[is.na(tmp)] <- -3 # missing

    tmp[is.na(tmp)] <- -3 # missing
### tmp[tmp==1] <- 1 # AA
    tmp[tmp==2] <- ifelse(cross.str=="riself"|cross.str=="risib",1,0) # 0 AB
    tmp[tmp==3] <- -1 #BB
    tmp[tmp==4] <- 2 # not BB
    tmp[tmp==5] <- -2 # not AA

    ## bind to genodata
    genodata <- cbind(genodata, tmp)
  }
  
  ## make a seed if the input one is zero
  if(.bmapqtl.options$seed == 0) {
    if(exists(".Random.seed",1))
      rm(.Random.seed,pos=1)
    runif(1)
    seed <- .Random.seed[2]
  }
  else 
    seed <- .bmapqtl.options$seed

  ## make cross type parameters
  ## translation of R/qtl cross types
  cross.str <- switch( cross.str,
                      bc = "B1",
                      f2 = "RF2",
                      riself = "RI1",
                      risib = "RI2",
                      cross.str)

  switch( cross.str,
         "B1"= {
           crosstype.1 <- 1
           crosstype.2 <- 1
         },
         "B2"= {
           crosstype.1 <- 2
           crosstype.2 <- 1
         },
         "RF2"= {
           crosstype.1 <- 4
           crosstype.2 <- 2
         },
         { switch(substr(cross.str,1,2),
                  "SF"= {
                    crosstype.1 <- 3
                    crosstype.2 <- as.integer(substr(cross.str,3,10000))
                  },
                  "RI"= {
                    crosstype.1 <- 5
                    crosstype.2 <- as.integer(substr(cross.str,3,10000))
                  },
                  stop(paste("cross type", cross.str,"not recognized"))
                  )
         })
  
### should check that cross type is consistent with data
### otherwise call below will give many "denom = 0.0 in cond_prob..." messages
  
  ## call engine function
  nind <- nind(cross)-length(idx.missing)
  nchr <- length(chrom)
  nmark <- nmar(cross)[chrom]
  if(length(idx.missing) != 0)
    y <- cross$pheno[-idx.missing,pheno]
  else
    y <- cross$pheno[,pheno]

  # size for return variable
  nret <- ceiling((.bmapqtl.options$niter * (1+.bmapqtl.options$burnin)) /
    .bmapqtl.options$by * 30)

  cat("Bayesian interval mapping MCMC run in progress.",
      "\nCount of 1000 iterations shown separated by dots (negative for burnin):\n")
  z <- .C("R_mcmc",
          # input variables
          as.integer(nind), # number of individuals
          as.integer(nchr), # number of chromosomes
          # the following four items are for genetic map
          as.integer(chr.array),
          as.integer(nmar.array),
          as.double(pos.array),
          as.double(dist.array),
          # genotype data matrix
          as.integer(genodata),
          # number of markers per chromosome
          as.integer(nmark),
          # selected phenotype values
          as.double(y),
          # parameters for cross type
          as.integer(crosstype.1),
          as.integer(crosstype.2),
          # the following are parameters
          as.double(.bmapqtl.options$burnin), # burnin
          as.double(.bmapqtl.options$preburn), # pre burnin
          as.integer(.bmapqtl.options$niter), # iterations
          as.integer(.bmapqtl.options$by), # increment
          as.integer(seed), # random seed
          # the following are priors
          as.double(.bmapqtl.options$prior.add[1]), # mean add
          as.double(.bmapqtl.options$prior.add[2]), # var add
          as.double(.bmapqtl.options$prior.dom[1]), # mean dom
          as.double(.bmapqtl.options$prior.dom[2]), # var dom
          as.double(.bmapqtl.options$prior.mean[1]), # mean of mean
          as.double(.bmapqtl.options$prior.mean[2]), # var of mean
          as.double(.bmapqtl.options$prior.var[1]), # mean of var
          as.double(.bmapqtl.options$prior.var[2]), # var of var
          as.character(.bmapqtl.options$prior.nqtl), # prior type of QTL
          # parameter for QTL, mean for poisson, range for uniform
          as.double(.bmapqtl.options$mean.nqtl),
          # initial values for chain
          as.double(.bmapqtl.options$init[1]), # init mu
          as.double(.bmapqtl.options$init[2]), # init s2
   
          # return variables
          result=as.double(rep(0, 13*nret)),
          PACKAGE="bim"
          )

  tbl <- as.data.frame(matrix(z$result, ncol=13, byrow=T))
  # get rid of zeros
  idx <- apply(tbl, 1, function(x) all(x==0))
  tmp <- min(which(idx))
  tbl <- tbl[1:(tmp-1),]
  colnames(tbl) <- c("niter", "nqtl", "iqtl", "chrom",
                     "LOD", "mu", "sigmasq", "addvar",
                     "domvar", "add", "dom", "locus", "esth")

  # write result to a file if specified
  if(nchar(result.file) != 0)
    write.table(tbl, file=result.file, quote=F, sep=" ",
                na=".", row.name=F)

  # make output object
  burnin <- tbl[tbl$niter < 0 & tbl$iqtl == 1,
                c("niter", "nqtl","LOD", "mu", "sigmasq", "addvar", "domvar", "esth")]
  iter <- tbl[tbl$niter >= 0 & tbl$iqtl == 1, c("niter", "nqtl",
        "LOD", "mu", "sigmasq", "addvar", "domvar", "esth")]
  names(burnin) <- names(iter) <- c("niter", "nqtl", "LOD",
        "mean", "envvar", "addvar", "domvar", "herit")
  no.dom <- all(is.na(iter$domvar))
  if (no.dom)
    iter$domvar <- NULL
  cols <- c("niter", "nqtl", "chrom", "locus", "add")
  if (!no.dom)
    cols <- c(cols, "dom")
  loci <- tbl[tbl$niter >= 0, cols]
  sim <- list(burnin = burnin, iter = iter,
              loci = loci, bmapqtl = .bmapqtl.options)
  class(sim) <- "bim"
  sim

}
#####################################################################
##
## $Id: zzz.r,v 1.1 2004/04/30 14:04:19 jgentry Exp $
##
## Part of the R/bim package
##
## .First.lib is run when the package is loaded with library(bim)
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
##############################################################################

.First.lib <- function(lib, pkg) {
  library.dynam("bim", pkg, lib)
#  require(qtl)
#  if(version$major=="1" & as.numeric(version$minor) < 9 ) {
#    require(modreg)
#    require(mva)
#  }
#  else
#    require(stats)
}

# end of zzz.R

