.packageName <- "qtl"
######################################################################
#
# argmax.geno.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Nov, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: argmax.geno
#
######################################################################

######################################################################
#
# argmax.geno: Use Viterbi algorithm to find most likely sequence of
#              underlying genotypes, given observed marker data
#
######################################################################

argmax.geno <-
function(cross, step=0, off.end=0, error.prob=0,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  # map function
  map.function <- match.arg(map.function)
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h

  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  n.ind <- nind(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)
  type <- class(cross)[1]

  # loop over chromosomes
  for(i in 1:n.chr) {
    if(n.mar[i]==1) temp.offend <- max(c(off.end,5))
    else temp.offend <- off.end

    # which type of cross is this?
    if(type=="f2") {
      one.map <- TRUE
      if(class(cross$geno[[i]]) == "A") # autosomal
        cfunc <- "argmax_geno_f2"
      else                              # X chromsome 
        cfunc <- "argmax_geno_bc"
    }
    else if(type=="bc" || type=="riself" || type=="risib") {
      cfunc <- "argmax_geno_bc"
      one.map <- TRUE
    }
    else if(type == "4way") {
      cfunc <- "argmax_geno_4way"
      one.map <- FALSE
    }
    else if(type == "f2ss") {
      cfunc <- "argmax_geno_f2ss"
      one.map <- FALSE
    }
    else {
      err <- paste("argmax.geno not available for cross type",
                   type, ".")
      stop(err)
    }

    # genotype data
    gen <- cross$geno[[i]]$data
    gen[is.na(gen)] <- 0
    
    # recombination fractions
    if(one.map) {
      # recombination fractions
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map))
      if(type=="risib" || type=="riself")
        rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),class(cross$geno[[i]]))
      rf[rf < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=length(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,names(map))
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
    }
    else {
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map[1,]))
      rf[rf < 1e-14] <- 1e-14
      rf2 <- mf(diff(map[2,]))
      rf2[rf2 < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=ncol(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,dimnames(map)[[2]])
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
    }
    if(any(is.na(rf))) { # this occurs when there is only one marker
      rf <- rf2 <- 0 
      warn <- paste("Only one marker on chr ", names(cross$geno)[i],
                    ": argmax results tenuous.", sep="")
      warning(warn)
    }


    # call the C function
    if(one.map) {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(error.prob),     
              argmax=as.integer(newgen), # the output
              PACKAGE="qtl")

      cross$geno[[i]]$argmax <- matrix(z$argmax,ncol=n.pos)
      dimnames(cross$geno[[i]]$argmax) <- list(NULL, names(map))
    }
    else {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(rf2),            # recombination fractions
              as.double(error.prob),      
              argmax=as.integer(newgen), # the output
              PACKAGE="qtl")

      cross$geno[[i]]$argmax <- matrix(z$argmax,ncol=n.pos)
      dimnames(cross$geno[[i]]$argmax) <- list(NULL, colnames(map))
    }

    # attribute set to the error.prob value used, for later
    #     reference
    attr(cross$geno[[i]]$argmax,"error.prob") <- error.prob
    attr(cross$geno[[i]]$argmax,"step") <- step
    attr(cross$geno[[i]]$argmax,"off.end") <- temp.offend
  }

  # store argmax values as integers
  for(i in 1:nchr(cross))
    storage.mode(cross$geno[[i]]$argmax) <- "integer"

  cross
}

# end of argmax.geno.R
######################################################################
#
# calc.genoprob.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: calc.genoprob
#
######################################################################

######################################################################
#
# calc.genoprob: calculate genotype probabilities conditional on 
#                observed marker genotypes
#
######################################################################

calc.genoprob <-
function(cross, step=0, off.end=0, error.prob=0,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  # map function
  map.function <- match.arg(map.function)
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h
 
  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  n.ind <- nind(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)

  type <- class(cross)[1]

  # calculate genotype probabilities one chromosome at a time
  for(i in 1:n.chr) {
    if(n.mar[i]==1) temp.offend <- max(c(off.end,5))
    else temp.offend <- off.end
    
    # which type of cross is this?
    if(type == "f2") {
      one.map <- TRUE
      if(class(cross$geno[[i]]) == "A") { # autosomal
        cfunc <- "calc_genoprob_f2"
        n.gen <- 3
        gen.names <- c("A","H","B")
      }
      else {                             # X chromsome 
        cfunc <- "calc_genoprob_bc"
        n.gen <- 2
        gen.names <- c("A","H")
      }
    }
    else if(type == "bc") {
      cfunc <- "calc_genoprob_bc"
      n.gen <- 2
      gen.names <- c("A","H")
      one.map <- TRUE
    }
    else if(type == "riself" || type=="risib") {
      cfunc <- "calc_genoprob_bc"
      n.gen <- 2
      gen.names <- c("A","B")
      one.map <- TRUE
    }
    else if(type == "4way") {
      cfunc <- "calc_genoprob_4way"
      n.gen <- 4
      one.map <- FALSE
      gen.names <- c("AC","BC","AD","BD")
    }
    else {
      err <- paste("calc.genoprob not available for cross type",
                    type, ".")
      stop(err)
    }

    # genotype data
    gen <- cross$geno[[i]]$data
    gen[is.na(gen)] <- 0
    
    # recombination fractions
    if(one.map) {
      # recombination fractions
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map))
      if(type=="risib" || type=="riself")
        rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),class(cross$geno[[i]]))
      rf[rf < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=length(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,names(map))
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
      marnames <- names(map)
    }
    else {
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map[1,]))
      rf[rf < 1e-14] <- 1e-14
      rf2 <- mf(diff(map[2,]))
      rf2[rf2 < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=ncol(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,dimnames(map)[[2]])
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
      marnames <- colnames(map)
    }

    # call the C function
    if(one.map) {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(error.prob),     # 
              genoprob=as.double(rep(0,n.gen*n.ind*n.pos)),
              PACKAGE="qtl")
    }
    else {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(rf2),            # recombination fractions
              as.double(error.prob),     # 
              genoprob=as.double(rep(0,n.gen*n.ind*n.pos)),
              PACKAGE="qtl")
    }

    # re-arrange marginal probabilites
    cross$geno[[i]]$prob <- array(z$genoprob,dim=c(n.ind,n.pos,n.gen))
    dimnames(cross$geno[[i]]$prob) <- list(NULL, marnames, gen.names)
    # attribute set to the error.prob value used, for later
    #     reference, especially by calc.errorlod()
    attr(cross$geno[[i]]$prob,"error.prob") <- error.prob
    attr(cross$geno[[i]]$prob,"step") <- step
    attr(cross$geno[[i]]$prob,"off.end") <- temp.offend
    attr(cross$geno[[i]]$prob,"map.function") <- map.function
  } # end loop over chromosomes

  cross
}

# end of calc.genoprob.R
######################################################################
#
# calc.pairprob.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Nov, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: calc.pairprob
#
######################################################################

######################################################################
#
# calc.pairprob: calculate joint genotype probabilities for all pairs
#                of putative QTLs, conditional on the observed marker
#                data
#
# This is an *internal* function, not to be called by the user.
#
# The input argument cross is assumed to have just one chromosome.
#
######################################################################

calc.pairprob <-
function(cross, step=0, off.end=0, error.prob=0, 
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  if(step==0 && off.end > 0) step <- off.end*2

  # map function
  map.function <- match.arg(map.function)
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h
 
  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }
  n.ind <- nind(cross)
  n.chr <- nchr(cross)

  # which type of cross is this?
  type <- class(cross)[1]
  if(type == "f2") {
    one.map <- TRUE
    if(class(cross$geno[[1]]) == "A") { # autosomal
      cfunc <- "calc_pairprob_f2"
      n.gen <- 3
      gen.names <- c("A","H","B")
    }
    else {                             # X chromsome 
      cfunc <- "calc_pairprob_bc"
      n.gen <- 2
      gen.names <- c("A","H")
    }
  }
  else if(type == "bc") {
    cfunc <- "calc_pairprob_bc"
    n.gen <- 2
    gen.names <- c("A","H")
    one.map <- TRUE
  }
  else if(type == "riself" || type=="risib") {
    cfunc <- "calc_genoprob_bc"
    n.gen <- 2
    gen.names <- c("A","B")
    one.map <- TRUE
  }
  else if(type == "4way") {
    cfunc <- "calc_pairprob_4way"
    n.gen <- 4
    one.map <- FALSE
    gen.names <- c("AC","BC","AD","BD")
  }
  else {
    err <- paste("calc.pairprob not available for cross type",
                  type, ".")
    stop(err)
  }
  
  # genotype data
  gen <- cross$geno[[1]]$data
  gen[is.na(gen)] <- 0
  
  # get recombination fractions
  if(one.map) {
    map <- create.map(cross$geno[[1]]$map,step,off.end)
    rf <- mf(diff(map))
    if(type=="risib" || type=="riself")
      rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),class(cross$geno[[1]]))
    rf[rf < 1e-14] <- 1e-14
    
    # new genotype matrix with pseudomarkers filled in
    newgen <- matrix(ncol=length(map),nrow=nrow(gen))
    colnames(newgen) <- names(map)
    newgen[,colnames(gen)] <- gen
    newgen[is.na(newgen)] <- 0
    n.pos <- ncol(newgen)
    marnames <- names(map)
  }
  else {
    map <- create.map(cross$geno[[1]]$map,step,off.end)
    rf <- mf(diff(map[1,]))
    rf[rf < 1e-14] <- 1e-14
    rf2 <- mf(diff(map[2,]))
    rf2[rf2 < 1e-14] <- 1e-14
    
    # new genotype matrix with pseudomarkers filled in
    newgen <- matrix(ncol=ncol(map),nrow=nrow(gen))
    colnames(newgen) <- colnames(map)
    newgen[,colnames(gen)] <- gen
    newgen[is.na(newgen)] <- 0
    n.pos <- ncol(newgen)
    marnames <- colnames(map)
  }
  
  if(n.pos < 2) return(NULL)

  # below: at least two positions
  # call the C function
  if(one.map) {
    z <- .C(cfunc,
            as.integer(n.ind),         # number of individuals
            as.integer(n.pos),         # number of markers
            as.integer(newgen),        # genotype data
            as.double(rf),             # recombination fractions
            as.double(error.prob),     # 
            as.double(rep(0,n.gen*n.ind*n.pos)),
            pairprob=as.double(rep(0,n.ind*n.pos*(n.pos-1)/2*n.gen^2)),
            PACKAGE="qtl")
  }
  else {
    z <- .C(cfunc,
            as.integer(n.ind),         # number of individuals
            as.integer(n.pos),         # number of markers
            as.integer(newgen),        # genotype data
            as.double(rf),             # recombination fractions
            as.double(rf2),            # recombination fractions
            as.double(error.prob),     # 
            as.double(rep(0,n.gen*n.ind*n.pos)),
            pairprob=as.double(rep(0,n.ind*n.pos*(n.pos-1)/2*n.gen^2)),
            PACKAGE="qtl")
  }
  
  array(z$pairprob, dim=c(n.ind,n.pos*(n.pos-1)/2,n.gen,n.gen))
}

# end of calc.pairprob.R
######################################################################
#
# discan.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Aug, 2004
# first written Oct, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: discan
#
######################################################################

######################################################################
#
# discan: scan genome, calculating LOD scores with single QTL model
#         for a dichotomous trait 
#
######################################################################

discan <-
function(cross, pheno.col=1, method=c("em","mr"),
         maxit=4000, tol=1e-4)
{
  method <- match.arg(method)

  # check phenotypes
  if(length(pheno.col) > 1) pheno.col <- pheno.col[1]
  if(pheno.col < 1 || pheno.col > nphe(cross))
    stop("Specified phenotype column is invalid.")

  pheno <- cross$pheno[,pheno.col]
  keep.ind <- (1:length(pheno))[!is.na(pheno)]
  pheno <- pheno[keep.ind]
  n.ind <- length(keep.ind)
  n.chr <- nchr(cross)
  type <- class(cross)[1]

  u <- unique(pheno)
  if(any(u != 0 && u != 1))
    stop("Phenotypes must be either 0 or 1.")

  if(method == "em") {
    p <- mean(pheno)
    n1 <- sum(pheno==1)
    n0 <- sum(pheno==0)
    if(n1==0 || n0==0) llik0 <- 0
    else llik0 <- n1*log10(p) + n0*log10(1-p)
  }

  results <- NULL

  # calculate genotype probabilities one chromosome at a time
  for(i in 1:n.chr) {

    chrtype <- class(cross$geno[[i]])
    if(chrtype=="X") sexpgm <- getsex(cross)
    else sexpgm <- NULL

    # get genotype names
    gen.names <- getgenonames(type,chrtype,"full",sexpgm)
    n.gen <- length(gen.names)

    # pull out genotype data (mr)
    # or genotype probabilities (em)
    if(method == "mr") {
      cfunc <- "R_discan_mr"
      newgeno <- cross$geno[[i]]$data
      newgeno <- newgeno[keep.ind,]
      newgeno[is.na(newgeno)] <- 0 

      # discard partially informative genotypes
      if(type=="f2" || type=="f2ss") newgeno[newgeno>3] <- 0
      if(type=="4way") newgeno[newgeno>4] <- 0

      # revise X chromosome genotypes
      if(chrtype=="X" && (type=="bc" || type=="f2" || type=="f2ss"))
         newgeno <- reviseXdata(type, "full", sexpgm, geno=newgeno)

      n.pos <- ncol(newgeno)
      map <- cross$geno[[i]]$map
      if(is.matrix(map)) map <- map[1,]
    }
    else {
      if(is.na(match("prob",names(cross$geno[[i]])))) { # need to run calc.genoprob
        warning("First running calc.genoprob.")
        cross <- calc.genoprob(cross)
      }
      genoprob <- cross$geno[[i]]$prob
      n.pos <- ncol(genoprob)
      genoprob <- genoprob[keep.ind,,]

      # revise X chromosome genotypes
      if(chrtype=="X" && (type=="bc" || type=="f2" || type=="f2ss"))
         genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob)

      map <- create.map(cross$geno[[i]]$map,
                        attr(cross$geno[[i]]$prob,"step"),
                        attr(cross$geno[[i]]$prob,"off.end"))
      if(is.matrix(map)) map <- map[1,]

      cfunc <- "R_discan_im"
    }

    # call the C function
    if(method == "mr") 
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.integer(newgeno),       # genotype data
              as.integer(pheno),          # phenotype data
              result=as.double(rep(0,n.pos*(n.gen+1))),
              PACKAGE="qtl")

    else  # interval mapping
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.double(genoprob),       # genotype probabilities
              as.integer(pheno),          # phenotype data
              result=as.double(rep(0,n.pos*(n.gen+1))),
              as.integer(maxit),
              as.double(tol),
              PACKAGE="qtl")
    z <- matrix(z$result,nrow=n.pos)

    if(method == "em") z[,1] <- z[,1] - llik0
    z[is.na(z[,1]),1] <- 0
    colnames(z) <- c("lod",gen.names)
      
    w <- names(map)
    o <- grep("^loc\-*[0-9]+",w)
    if(length(o) > 0) # inter-marker locations cited as "c*.loc*"
      w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="")
    rownames(z) <- w
    
    z <- as.data.frame(z)
    z <- cbind(chr=rep(names(cross$geno)[i],length(map)), pos=map, z)
    rownames(z) <- w


    # get null log10 likelihood for the X chromosome
    if(chrtype=="X") {

      # determine which covariates belong in null hypothesis
      temp <- scanoneXnull(type, sexpgm)
      adjustX <- temp$adjustX
      dfX <- temp$dfX
      sexpgmcovar <- temp$sexpgmcovar
      sexpgmcovar.alt <- temp$sexpgmcovar.alt      

      if(adjustX) { # get LOD-score adjustment
        n.gen <- ncol(sexpgmcovar)+1

        nullz <- .C("R_discan_mr",
            as.integer(n.ind),
            as.integer(1),
            as.integer(n.gen),
            as.integer(sexpgmcovar.alt),
            as.integer(pheno),
            result=as.double(rep(0,n.gen+1)),
            PACKAGE="qtl")

        # adjust LOD curve
        z[,3] <- z[,3] - nullz$result[1]
      }
    } 

    # if different number of columns from other chromosomes,
    #     expand to match
    if(!is.null(results) && ncol(z) != ncol(results)) {
      cnz <- colnames(z)
      cnr <- colnames(results)
      wh.zr <- match(cnz,cnr)
      wh.rz <- match(cnr,cnz)
      if(all(!is.na(wh.rz))) {
        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=ncol(z)))
        dimnames(newresults) <- list(rownames(results), cnz)
        newresults[,cnr] <- results
        results <- newresults
        for(i in 2:ncol(results))
          if(is.factor(results[,i])) results[,i] <- as.numeric(results[,i])
      }
      else if(all(!is.na(wh.zr))) {
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=ncol(results)))
        dimnames(newz) <- list(rownames(z), cnr)
        newz[,cnz] <- z
        z <- newz
        for(i in 2:ncol(z))
          if(is.factor(z[,i])) z[,i] <- as.numeric(z[,i])
      }
      else {
        newnames <- c(cnr, cnz[is.na(wh.zr)])

        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=length(newnames)))
        dimnames(newresults) <- list(rownames(results), newnames)
        newresults[,cnr] <- results
        results <- newresults
        for(i in 2:ncol(results))
          if(is.factor(results[,i])) results[,i] <- as.numeric(results[,i])
        
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=length(newnames)))
        dimnames(newz) <- list(rownames(z), newnames)
        newz[,cnz] <- z
        z <- newz
        for(i in 2:ncol(z))
          if(is.factor(z[,i])) z[,i] <- as.numeric(z[,i])
      }
    }

    results <- rbind(results, z)
  }

  # sort the later columns
  neworder <- c(colnames(results)[1:3],sort(colnames(results)[-(1:3)]))
  results <- results[,neworder]

  class(results) <- c("scanone","data.frame")
  attr(results,"method") <- method
  attr(results,"type") <- type
  attr(results,"model") <- "binary"
  results
}

# end of discan.R
######################################################################
#
# effectplot.R
#
# copyright (c) 2002-4, Hao Wu, The Jackson Laboratory
#                     and Karl W. Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Jul, 2002
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: effectplot
#
######################################################################

effectplot <-
function (cross, pheno.col = 1, mname1, mark1, geno1, mname2, 
          mark2, geno2, main, ylim, add.legend = TRUE) 
{
  if(!sum(class(cross) == "cross")) 
    stop("The first input variable must be  an object of class cross")
  if(pheno.col > nphe(cross)) 
    stop("Input pheno.col is wrong")

  # local variables
  n.ind <- nind(cross)
  pheno <- cross$pheno[, pheno.col]
  type <- class(cross)[1]
  chrtype1 <- chrtype2 <- "A"
  gennames1 <- gennames2 <- NULL

  # Get marker 1 genotype data
  if(missing(mark1)) { # no data given
    if(missing(mname1)) 
      stop("Either mname1 or mark1 must be specified.")

    # find chromosome containing marker
    o <- sapply(cross$geno, function(a, b)
                !is.na(match(b, colnames(a$data))), mname1)

    if(!any(o)) {
      err <- paste("Marker", mname1, "not found")
      stop(err)
    }
    chr1 <- names(cross$geno)[o]
    chrtype1 <- class(cross$geno[[chr1]])

    # get genotype data
    if(!any(colnames(cross$geno[[chr1]]$data) == mname1)) {
      err <- paste("Marker", mname1, "not found.")
      stop(err)
    }
    mark1 <- cross$geno[[chr1]]$data[, mname1]

    # if X chr and backcross or intercross, get sex/dir data + revise data
    if(chrtype1 == "X" && (type == "bc" || type == "f2" || type == "f2ss")) {
      sexpgm <- getsex(cross)
      mark1 <- as.numeric(reviseXdata(type, "standard", sexpgm, 
                                      geno = as.matrix(mark1)))
      gennames1 <- getgenonames(type, chrtype1, "standard", sexpgm)
    }
  }
  else {
    if(length(mark1) != n.ind) 
      stop("Marker 1 data is the wrong length")
    if(missing(mname1)) 
      mname1 <- "Marker 1"
  }

  # Deal with marker 2
  if(!missing(mname2) || !missing(mark2)) {
    if(missing(mark2)) {

      # find chromosome containing marker
      o <- sapply(cross$geno, function(a, b)
                  !is.na(match(b, colnames(a$data))), mname2)
      if(!any(o)) {
        err <- paste("Marker", mname2, "not found")
        stop(err)
      }
      chr2 <- names(cross$geno)[o]
      chrtype2 <- class(cross$geno[[chr2]])

      # get genotype data
      if(!any(colnames(cross$geno[[chr2]]$data) == mname2)) {
        err <- paste("Marker", mname2, "not found.")
        stop(err)
      }
      mark2 <- cross$geno[[chr2]]$data[, mname2]

      # if X chr and backcross or intercross, get sex/dir data + revise data
      if(chrtype2 == "X" && (type == "bc" || type == "f2" || type == "f2ss")) {
        sexpgm <- getsex(cross)
        mark2 <- as.numeric(reviseXdata(type, "standard", sexpgm, 
                                        geno = as.matrix(mark2)))
        gennames2 <- getgenonames(type, chrtype2, "standard", sexpgm)
      }
    }
    else {
      if(length(mark2) != n.ind) 
        stop("Marker 2 data is the wrong length")
      if(missing(mname2)) 
        mname2 <- "Marker 2"
    }
  }
  else mark2 <- NULL

  # drop data for individuals with missing phenotypes or genotypes
  if(is.null(mark2)) {
    keepind <- !is.na(pheno) & !is.na(mark1)
    mark1 <- mark1[keepind]
    pheno <- pheno[keepind]
  }
  else {
    keepind <- !is.na(pheno) & !is.na(mark1) & !is.na(mark2)
    mark1 <- mark1[keepind]
    mark2 <- mark2[keepind]
    pheno <- pheno[keepind]
  }

  # adjust marker data and get level names
  if(!missing(geno1)) {
    if(length(unique(mark1)) > length(geno1)) 
      stop("geno1 is too short.")
    mark1 <- as.numeric(factor(mark1), levels = sort(unique(mark1)))
  }
  else {
    if(!is.null(gennames1)) 
      geno1 <- gennames1
    else if(is.factor(mark1)) {
      geno1 <- levels(mark1)
      mark1 <- as.numeric(mark1)
    }
    else {
      if(type == "bc") 
        geno1 <- c("AA", "AB")
      else if(type == "f2" || type == "f2ss") 
        geno1 <- c("AA", "AB", "BB")
      else if(type == "riself" || type == "risib") 
        geno1 <- c("AA", "BB")
      else if(type == "4way") 
        geno1 <- c("AC", "BC", "AD", "BD")
      if(length(unique(mark1)) > length(geno1)) 
        geno1 <- c(geno1, rep("?", length(unique(mark1)) - 
                              length(geno1)))
    }
  }
  if(!is.null(mark2)) {
    if(!missing(geno2)) {
      if(length(unique(mark2)) > length(geno2)) 
        stop("geno2 is too short.")
      mark2 <- as.numeric(factor(mark2), levels = sort(unique(mark2)))
    }
    else {
      if(!is.null(gennames2)) 
        geno2 <- gennames2
      else if(is.factor(mark2)) {
        geno2 <- levels(mark2)
        mark2 <- as.numeric(mark2)
      }
      else {
        if(type == "bc") 
          geno2 <- c("AA", "AB")
        else if(type == "f2" || type == "f2ss") 
          geno2 <- c("AA", "AB", "BB")
        else if(type == "riself" || type == "risib") 
          geno2 <- c("AA", "BB")
        else if(type == "4way") 
          geno2 <- c("AC", "BC", "AD", "BD")
        if(length(unique(mark2)) > length(geno2)) 
          geno2 <- c(geno2, rep("?", length(unique(mark2)) - 
                                length(geno2)))
      }
    }
  }
  ngen1 <- length(geno1)
  if(!is.null(mark2)) 
    ngen2 <- length(geno2)

  # calculate means and stds for interaction
  # and make output object
  # the output will be a data frame. For two-marker case,
  # the rows corresponding to the first marker and the columns
  # corresponding to the second marker
  result <- NULL
  if(is.null(mark2)) {
    means <- tapply(pheno, mark1, mean, na.rm = TRUE)
    ses <- tapply(pheno, mark1, function(a) sd(a, na.rm = TRUE)/sqrt(sum(!is.na(a))))
    lo <- means - ses
    hi <- means + ses
    # Note: rows are marker 1 and columns are marker 2

    if(length(means) != length(geno1)) {
      warning("Number of genotypes is different than length(geno1).")
      if(length(means) < length(geno1)) 
        geno1 <- geno1[1:length(means)]
      else geno1 <- c(geno1, rep("?", length(means) - length(geno1)))
      ngen1 <- length(geno1)
    }
    result$Means <- means
    names(result$Means) <- paste(mname1, geno1, sep = ".")
    result$SDs <- ses
    names(result$SDs) <- paste(mname1, geno1, sep = ".")
  }
  else {
    means <- tapply(pheno, list(mark1, mark2), mean, na.rm = TRUE)
    ses <- tapply(pheno, list(mark1, mark2), function(a) sd(a, 
                                                            na.rm = TRUE)/sqrt(sum(!is.na(a))))
    lo <- means - ses
    hi <- means + ses
    if(nrow(means) != length(geno1)) {
      warning("Number of genotypes in marker 1 is different than length(geno1).")
      if(nrow(means) < length(geno1)) 
        geno1 <- geno1[1:nrow(means)]
      else geno1 <- c(geno1, rep("?", nrow(means) - length(geno1)))
      ngen1 <- length(geno1)
    }
    if(ncol(means) != length(geno2)) {
      warning("Number of genotypes in marker 2 is different than length(geno2).")
      if(ncol(means) < length(geno2)) 
        geno2 <- geno2[1:ncol(means)]
      else geno2 <- c(geno2, rep("?", ncol(means) - length(geno2)))
      ngen2 <- length(geno2)
    }
    result$Means <- as.data.frame(means)
    rownames(result$Means) <- paste(mname1, geno1, sep = ".")
    colnames(result$Means) <- paste(mname2, geno2, sep = ".")
    result$SDs <- as.data.frame(ses)
    rownames(result$SDs) <- paste(mname1, geno1, sep = ".")
    colnames(result$SDs) <- paste(mname2, geno2, sep = ".")
  }

  ######### Draw the figure ############
  # graphics parameters
  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd = FALSE, las = 1)
  on.exit(par(xpd = old.xpd, las = old.las))

  # colors (for case of two markers)
  if(ngen1 <= 5) 
    int.color <- c("black", "red", "blue", "orange", "green")[1:ngen1]
  else int.color <- c("black", rainbow(ngen1 - 1, start = 0, 
                                       end = 2/3))
  # plot title
  if(missing(main)) {
    if(is.null(mark2)) 
      main <- paste("Effect plot for", mname1)
    else main <- paste("Interaction plot for", mname1, "and", 
                       mname2)
  }

  # y axis limits
  if(missing(ylim)) {
    ylimits <- range(c(lo, means, hi), na.rm = TRUE)
    ylimits[2] <- ylimits[2] + diff(ylimits) * 0.1
  }
  else ylimits <- ylim

  # x axis limits
  if(is.null(mark2)) { # one marker
    u <- sort(unique(mark1))
    d <- diff(u[1:2])
    xlimits <- c(min(mark1) - d/4, max(mark1) + d/4)
  }
  else { # two markers
    u <- sort(unique(mark2))
    d <- diff(u[1:2])
    xlimits <- c(min(mark2) - d/4, max(mark2) + d/4)
  }

  ## fix of x limits
  d <- 1
  xlimits <- c(1 - d/4, length(u) + d/4)

  if(is.null(mark2)) { # single marker
    # plot the means
    plot(1:ngen1, means, main = main, xlab = mname1, ylab = names(cross$pheno)[pheno.col], 
         pch = 1, col = "black", ylim = ylimits, xaxt = "n", 
         type = "b", xlim = xlimits)
    # confidence limits
    for(i in 1:ngen1) {
      if(!is.na(lo[i]) && !is.na(hi[i])) 
        lines(c(i, i), c(lo[i], hi[i]), pch = 3, col = "black", 
              type = "b", lty = 3)
    }

    # X-axis ticks
    a <- par("usr")
    ystart <- a[3]
    yend <- ystart - diff(a[3:4]) * 0.02
    ytext <- ystart - diff(a[3:4]) * 0.05
    for(i in 1:ngen1) {
      lines(x = c(i, i), y = c(ystart, yend), xpd = TRUE)
      text(i, ytext, geno1[i], xpd = TRUE)
    }
  }
  else { # two markers
    # plot the first genotype of marker 1
    plot(1:ngen2, means[1, ], main = main, xlab = mname2, 
         ylab = names(cross$pheno)[pheno.col], pch = 1, col = int.color[1], 
         ylim = ylimits, xaxt = "n", type = "b", xlim = xlimits)
    # confidence limits
    for(i in 1:ngen2) {
      if(!is.na(lo[1, i]) && !is.na(hi[1, i])) 
        lines(c(i, i), c(lo[1, i], hi[1, i]), pch = 3, 
              col = int.color[1], type = "b", lty = 3)
    }
    for(j in 2:ngen1) { # for the rest of genotypes for Marker 1
      lines(1:ngen2, means[j, ], col = int.color[j], pch = 1, 
            type = "b")
      # confidence limits
      for(i in 1:ngen2) {
        if(!is.na(lo[j, i]) && !is.na(hi[j, i])) 
          lines(c(i, i), c(lo[j, i], hi[j, i]), pch = 3, 
                col = int.color[j], type = "b", lty = 3)
      }
    }

    # draw X-axis ticks
    a <- par("usr")
    ystart <- a[3]
    yend <- ystart - diff(a[3:4]) * 0.02
    ytext <- ystart - diff(a[3:4]) * 0.05
    for(i in 1:ngen2) {
      lines(x = c(i, i), y = c(ystart, yend), xpd = TRUE)
      text(i, ytext, geno2[i], xpd = TRUE)
    }

    # add legend
    if(add.legend) {
      col <- int.color[1:ngen1]
      u <- sort(unique(mark2))
      x.leg <- mean(u[ngen2 - (0:1)])
      y.leg <- a[4] - diff(a[3:4]) * 0.05
      y.leg2 <- a[4] - diff(a[3:4]) * 0.03
      legend(x.leg, y.leg, geno1, lty = 1, pch = 1, col = col, 
             cex = 1, xjust = 0.5)
      text(x.leg, y.leg2, mname1)
    }
  }

  return(invisible(result))
}

# end of effectplot.R

######################################################################
#
# effectscan.R
#
# copyright (c) 2003-4, Hao Wu, The Jackson Laboratory
#                    with modifications by Karl W. Broman
# last modified Sep, 2004
# first written Jan, 2003
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: effectscan
#
######################################################################

effectscan <-
function(cross, pheno.col=1, chr, ylim, gap=25,
         col=c("black","blue","red"), lty=c(1,2,3), lwd=2,
         mtick=c("line", "triangle"), main, add.legend=TRUE,
         ...)
{
  mtick <- match.arg(mtick)

  if(!missing(chr)) cross <- subset(cross,chr=chr)

  # remove individuals with missing phenotype (added by Karl)
  cross <- subset(cross, ind=!is.na(cross$pheno[,pheno.col]))

  pheno <- cross$pheno[,pheno.col]
  
  # loop thru all markers on all chromosomes
  # chromosome number
  chr <- NULL
  # x axis value for plot
  xvalue <- NULL
  # x-axis ticks and tick labels
  xtick <- NULL
  xticklabel <- NULL
  # y axis values, there're additive effect for bc
  # and additive and dominace effects for f2
  addeff <- NULL
  domeff <- NULL
  
  for(i in 1:nchr(cross)) {
    if(i != 1) tmp <- cross$geno[[i]]$map + max(xvalue) + gap
    else tmp <- cross$geno[[i]]$map
    xvalue <- c(xvalue, tmp)
    chr <- c(chr, rep(i, length(tmp)))
    xtick <- c(xtick, mean(c(min(tmp), max(tmp))))
    xticklabel <- c(xticklabel, names(cross$geno)[i])
    
    # find the y axis value in plot
    for(j in 1:dim(cross$geno[[i]]$data)[2]) {
      # the genotype for this marker
      geno <- cross$geno[[i]]$data[,j]
      if(class(cross)[1]=="bc") {
        # if this is back cross, 1 is A, 2 is H
        idx.1 <- which(geno==1)
        idx.2 <- which(geno==2)
        addeff <- c(addeff, mean(pheno[idx.1])-mean(pheno[idx.2]))
      }
      else if(class(cross)[1]=="f2"){
        # if this is F1, 1 is AA, 2 is AB, 3 is BB
        idx.1 <- which(geno==1)
        idx.2 <- which(geno==2)
        idx.3 <- which(geno==3)
        if(names(cross$geno[i]) != "X") {
          # automosomes 
          addeff <- c(addeff, mean(pheno[idx.1])-mean(pheno[idx.3]))
          # there's no dominance effect for X chromosome (only 2 genotypes)
          domeff <- c(domeff, mean(pheno[idx.2]) -
                      (mean(pheno[idx.1])+mean(pheno[idx.3]))/2)
        }
        else {
          # X chromosome, only 2 genotypes
          # there's no dominance effect, only additive effect
          addeff <- c(addeff, mean(pheno[idx.1])-mean(pheno[idx.2]))
        }
      }
      else {
        # other cross, implement later
      }
    }
  }

  # plot it
  # graphics parameters
  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd=FALSE,las=1)
  on.exit(par(xpd=old.xpd,las=old.las))
  # line type, width, color
  if(length(lty)==1) lty <- rep(lty,3)
  if(length(lwd)==1) lwd <- rep(lwd,3)
  if(length(col)==1) col <- rep(col,3)

  if(missing(ylim)) {
    tmp <- c(addeff, domeff)
    tmp <- tmp[!is.na(tmp)]
    ylim <- range(tmp)
  }
  if(missing(main)) main <- "Effect scan plot"
  plot(0, 0, ylim=ylim, xlim=range(xvalue),type="n", xaxt="n", xlab="",
       ylab="", main=main, ...)
  for(i in 1:nchr(cross)) {
    # draw additive effects for this chromosome
    lines(xvalue[chr==i], addeff[chr==i], lwd=lwd[1],
          lty=lty[1], col=col[1])
    # if cross type is "f2" or others, add lines
    if(class(cross)[1]=="f2") {
      if(names(cross$geno[i]) != "X")
        lines(xvalue[chr==i], domeff[chr==i], lwd=lwd[2],
              lty=lty[2], col=col[2])
    }
  }

  # draw x axis ticks
  if(nchr(cross)>1) {
    axis(1, at=xtick, labels=xticklabel)
  }
  else {
    axis(1)
    title(xlab="Map position (cM)")
  }
  
  # add tick marker
  a <- par("usr")
  if(mtick=="line")
    rug(xvalue, 0.02, quiet=TRUE)
  else
    points(xvalue, rep(a[3]+diff(a[3:4])*0.04, length(xvalue)), pch=17, cex=1.5)

  # add legend (if requested and there are more than 2 lines)
  if(add.legend & !is.null(domeff)) {
    a <- par("usr")
    x.leg <- 0.15*a[1]+0.85*a[2]
    y.leg <- 0.05*a[3]+0.95*a[4]
    leg <- c("Additive", "Dominance")
    legend(x.leg, y.leg, leg, lty=lty[1:2], 
           col=col[1:2], cex=1, xjust=0.5)
  }

}

# end of effectscan.R
######################################################################
#
# errorlod.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: calc.errorlod, plot.errorlod, top.errorlod
#
######################################################################

######################################################################
#
# calc.errorlod: Calculate LOD scores indicating likely genotyping
#                errors.
#
######################################################################

calc.errorlod <-
function(cross, error.prob=0.01,
         map.function=c("haldane","kosambi","c-f","morgan"))
{

  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  # map function
  map.function <- match.arg(map.function)

  n.ind <- nind(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)
  type <- class(cross)[1]
  
  # calculate genotype probabilities one chromosome at a time
  for(i in 1:n.chr) {

    chr.type <- class(cross$geno[[i]])
    if(type=="bc" || type=="risib" || type=="riself")
      cfunc <- "calc_errorlod_bc"
    else if(type=="f2") {
      if(chr.type=="A") cfunc <- "calc_errorlod_f2"
      else cfunc <- "calc_errorlod_bc"
    }
    else if(type=="4way") cfunc <- "calc_errorlod_4way"
    else {
      err <- paste("calc.errorlod not available for cross type",
                   type,".")
      stop(err)
    }

    # skip chromosomes with only 1 marker
    if(n.mar[i] < 2) next

    if(is.na(match("prob",names(cross$geno[[i]])))) {
      # need to run calc.genoprob
      warning("First running calc.genoprob.")
      cross <- calc.genoprob(cross,error.prob=error.prob,
                             map.function=map.function)
      Pr <- cross$geno[[i]]$prob
    }
    else {
      # if error.prob doesn't correspond to what was used when
      #     running calc.genoprob(), re-run calc.genoprob()
      if(abs(attr(cross$geno[[i]]$prob,"error.prob")
             - error.prob) > 1e-9) {
        warning("Re-running calc.genoprob()")
        cross <-
          calc.genoprob(cross,error.prob=error.prob,
                        step=attr(cross$geno[[i]]$prob,"step"),
                        off.end=attr(cross$geno[[i]]$prob,"off.end"),
                        map.function=attr(cross$geno[[i]]$prob,"map.function"))
      }
         
      Pr <- cross$geno[[i]]$prob
      u <- grep("^loc\-*[0-9]+",colnames(Pr))

      if(length(u) > 0) Pr <- Pr[,-u,]
    }
    
    nm <- dim(Pr)[2]
    dat <- cross$geno[[i]]$data
    dat[is.na(dat)] <- 0
    
    z <- .C(cfunc,
            as.integer(n.ind),
            as.integer(nm),
            as.integer(dat),
            as.double(error.prob),
            as.double(Pr),
            errlod=as.double(rep(0,n.ind*nm)),
            PACKAGE="qtl")

    errlod <- array(z$errlod, dim=dim(Pr)[1:2])

    dimnames(errlod) <- list(NULL,colnames(cross$geno[[i]]$data))
    cross$geno[[i]]$errorlod <- errlod

    # attribute set to the error.prob value used, for later
    #     reference.
    attr(cross$geno[[i]]$errorlod,"error.prob") <- error.prob
  }

  cross
}

  

  

######################################################################
#
# plot.errorlod
#
######################################################################

plot.errorlod <-
function(x, chr, ind, breaks=c(-1,2,3,4.5,Inf),
         col=c("white","gray85","hotpink","purple3"), ...)
{
  if(length(breaks) < length(col)+1)
    stop("Length of breaks should be length(col)+1.")
  if(length(breaks) != length(col)+1)
    col <- col[1:(length(breaks)+1)]

  cross <- x
  if(!missing(chr)) cross <- subset(cross,chr=chr)
  if(!missing(ind)) cross <- subset(cross,ind=ind)

  # remove chromosomes with < 2 markers
  n.mar <- nmar(cross)
  cross <- subset(cross,chr=names(n.mar)[n.mar >= 2])
  n.chr <- nchr(cross)

  errlod <- NULL
  for(i in 1:n.chr) {
    if(is.na(match("errorlod",names(cross$geno[[i]])))) { # need to run calc.errorlod
      warning("First running calc.errorlod.")
      cross <- calc.errorlod(cross,error.prob=0.01,map.function="haldane")
    }
    errlod <- cbind(errlod,cross$geno[[i]]$errorlod)
  }

  errlod <- t(errlod)

  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd=TRUE,las=1)
  on.exit(par(xpd=old.xpd,las=old.las))

  # plot grid 
  breaks[breaks==Inf] <- max(errlod)
  image(1:nrow(errlod),1:ncol(errlod),errlod,
        ylab="Individuals",xlab="Markers",col=col,
        breaks=breaks)

  # plot lines at the chromosome boundaries
  n.mar <- nmar(cross)
  n.chr <- nchr(cross)
  chr.names <- names(cross$geno)
  a <- c(0.5,cumsum(n.mar)+0.5)

  # the following makes the lines go slightly above the plotting region
  b <- par("usr")
  segments(a,b[3],a,b[4]+diff(b[3:4])*0.02)

  # this line adds a line above and below the image
  #     (the image function seems to leave these out)
  abline(h=0.5+c(0,ncol(errlod)),xpd=FALSE)

  # add chromosome numbers
  a <- par("usr")
  wh <- cumsum(c(0.5,n.mar))
  for(i in 1:n.chr) 
    text(mean(wh[i+c(0,1)]),a[4]+(a[4]-a[3])*0.025,chr.names[i])

  title(main="Genotyping error LOD scores")

}


######################################################################
#
# top.errorlod
#
# Picks out the genotypes having errorlod values above some cutoff
#
######################################################################

top.errorlod <-
function(cross, chr, cutoff=3, msg=TRUE)  
{
  if(!missing(chr)) cross <- subset(cross,chr=chr)

  mar <- ind <- lod <- chr <- NULL

  # remove chromosomes with < 2 markers
  n.mar <- nmar(cross)
  cross <- subset(cross,chr=names(n.mar)[n.mar >= 2])

  flag <- 0
  for(i in 1:nchr(cross)) {
    
    if(is.na(match("errorlod",names(cross$geno[[i]])))) 
      stop("You first need to run calc.errorlod.")

    el <- cross$geno[[i]]$errorlod

    if(any(el > cutoff)) {
      o <- (el > cutoff)
      mar <- c(mar,colnames(el)[col(el)[o]])
      ind <- c(ind,row(el)[o])
      lod <- c(lod,el[o])
      chr <- c(chr,rep(names(cross$geno)[i],sum(o)))
      flag <- 1
    }
  }
  if(!flag) {
    if(msg) cat("\tNo errorlods above cutoff.\n")
    return(invisible(NULL))
  }
  o <- data.frame(chr=chr,ind=ind,marker=mar,errorlod=lod)[order(-lod,ind),]
  rownames(o) <- 1:nrow(o)
  o
}

# end of errorlod.R
######################################################################
#
# est.map.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Apr, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: est.map
#
######################################################################

######################################################################
#
# est.map: re-estimate the genetic map for an experimental cross
#
######################################################################

est.map <- 
function(cross, error.prob=0, map.function=c("haldane","kosambi","c-f","morgan"),
         maxit=4000, tol=1e-4, sex.sp=TRUE, trace=FALSE)
{

  # map function
  map.function <- match.arg(map.function)
  if(map.function=="kosambi") {
    mf <- mf.k; imf <- imf.k
  }
  else if(map.function=="c-f") {
    mf <- mf.cf; imf <- imf.cf
  }
  else if(map.function=="morgan") {
    mf <- mf.m; imf <- imf.m
  }
  else {
    mf <- mf.h; imf <- imf.h
  }

  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  n.ind <- nind(cross)
  n.mar <- nmar(cross)
  n.chr <- nchr(cross)

  newmap <- vector("list",n.chr)
  names(newmap) <- names(cross$geno)
  type <- class(cross)[1]

  # calculate genotype probabilities one chromosome at a time
  for(i in 1:n.chr) {

    if(n.mar[i] < 2) {
      newmap[[i]] <- cross$geno[[i]]$map
      next
    }

    # which type of cross is this?
    if(type == "f2") {
      one.map <- TRUE
      if(class(cross$geno[[i]]) == "A") # autosomal
        cfunc <- "est_map_f2"
      else                              # X chromsome 
        cfunc <- "est_map_bc"
    }
    else if(type == "bc" || type=="riself" || type=="risib") {
      one.map <- TRUE
      cfunc <- "est_map_bc"
    }
    else if(type == "4way") {
      one.map <- FALSE
      cfunc <- "est_map_4way"
    }
    else if(type == "f2ss") {
      one.map <- FALSE
      cfunc <- "est_map_f2ss"
    }
    else {
      err <- paste("est.map not available for cross type",
                   type, ".")
      stop(err)
    }

    # genotype data
    gen <- cross$geno[[i]]$data
    gen[is.na(gen)] <- 0

    # remove individuals that have less than one typed marker
    o <- apply(gen,1,function(a) sum(a!=0)>1)
    gen <- gen[o,,drop=FALSE]
    
    # recombination fractions
    if(one.map) {
      # recombination fractions
      rf <- mf(diff(cross$geno[[i]]$map))
      if(type=="risib" || type=="riself")
        rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),class(cross$geno[[i]]))
      rf[rf < 1e-14] <- 1e-14
    }
    else {
      # randomize the maps a bit
      cross$geno[[i]]$map <- cross$geno[[i]]$map +
        runif(length(cross$geno[[i]]$map), -0.2, 0.2)

      rf <- mf(diff(cross$geno[[i]]$map[1,]))
      rf[rf < 1e-14] <- 1e-14
      rf2 <- mf(diff(cross$geno[[i]]$map[2,]))
      rf2[rf2 < 1e-14] <- 1e-14
      if(!sex.sp && class(cross$geno[[i]])=="X")
        temp.sex.sp <- TRUE
      else temp.sex.sp <- sex.sp
    }


    if(trace) cat(paste("Chr ", names(cross$geno)[i], ":\n",sep="")) 

    # call the C function
    if(one.map) {
      z <- .C(cfunc,
              as.integer(nrow(gen)),         # number of individuals
              as.integer(n.mar[i]),      # number of markers
              as.integer(gen),           # genotype data
              rf=as.double(rf),          # recombination fractions
              as.double(error.prob),     
              loglik=as.double(0),       # log likelihood
              as.integer(maxit),
              as.double(tol),
              as.integer(trace),
              PACKAGE="qtl")

      if(type=="riself" || type=="risib") 
        z$rf <- adjust.rf.ri(z$rf, substr(type, 3, nchar(type)),
                             class(cross$geno[[i]]), expand=FALSE)
      newmap[[i]] <- cumsum(c(min(cross$geno[[i]]$map),imf(z$rf)))
      names(newmap[[i]]) <- names(cross$geno[[i]]$map)
      attr(newmap[[i]],"loglik") <- z$loglik
    }
    else {
      z <- .C(cfunc,
              as.integer(nrow(gen)),         # number of individuals
              as.integer(n.mar[i]),      # number of markers
              as.integer(gen),           # genotype data
              rf=as.double(rf),          # recombination fractions
              rf2=as.double(rf2),        # recombination fractions
              as.double(error.prob),
              loglik=as.double(0),       # log likelihood
              as.integer(maxit),
              as.double(tol),
              as.integer(temp.sex.sp),
              as.integer(trace),
              PACKAGE="qtl")
              
      if(!temp.sex.sp) z$rf2 <- z$rf

      newmap[[i]] <- rbind(cumsum(c(min(cross$geno[[i]]$map[1,]),imf(z$rf))),
                           cumsum(c(min(cross$geno[[i]]$map[2,]),imf(z$rf2))))
      dimnames(newmap[[i]]) <- dimnames(cross$geno[[i]]$map)
      attr(newmap[[i]],"loglik") <- z$loglik
    }

  } # end loop over chromosomes

  class(newmap) <- "map"
  newmap
}

# end of est.map.R
######################################################################
#
# est.rf.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: est.rf, plot.rf, checkrf
#
######################################################################

######################################################################
#
# est.rf: Estimate sex-averaged recombination fractions between
#         all pairs of markers
#
######################################################################

est.rf <-
function(cross, maxit=4000, tol=1e-4) 
{
  n.chr <- nchr(cross)
  n.mar <- totmar(cross)
  n.ind <- nind(cross)
  mar.names <- unlist(lapply(cross$geno,function(a) colnames(a$data)))
  
  Geno <- NULL
  # create full genotype matrix
  for(i in 1:n.chr) 
    Geno <- cbind(Geno,cross$geno[[i]]$data)

  # which type of cross is this?
  type <- class(cross)[1]
  if(type == "f2" || type=="f2ss") 
    cfunc <- "est_rf_f2"
  else if(type == "bc" || type=="risib" || type=="riself") 
    cfunc <- "est_rf_bc"
  else if(type == "4way") 
    cfunc <- "est_rf_4way"
  else {
    err <- paste("est.rf not available for cross type",
                 type, ".")
    stop(err)
  }

  Geno[is.na(Geno)] <- 0
  
  if(type=="bc" || type=="risib" || type=="riself")
    z <- .C(cfunc,
            as.integer(n.ind),         # number of individuals
            as.integer(n.mar),         # number of markers
            as.integer(Geno),
            rf = as.double(rep(0,n.mar*n.mar)),
            PACKAGE="qtl")
  else
    z <- .C(cfunc,
            as.integer(n.ind),         # number of individuals
            as.integer(n.mar),         # number of markers
            as.integer(Geno),
            rf = as.double(rep(0,n.mar*n.mar)),
            as.integer(maxit),
            as.double(tol),
            PACKAGE="qtl")

  cross$rf <- matrix(z$rf,ncol=n.mar)
  dimnames(cross$rf) <- list(mar.names,mar.names)

  checkrf(cross, 3)
  cross
}

  

plot.rf <-
function(x, chr, which=c("both","lod","rf"), ...)
{
  which <- match.arg(which)
  
  if(!missing(chr)) x <- subset(x,chr=chr)
  
  if(is.na(match("rf",names(x)))) stop("You must run est.rf first.")
  g <- x$rf
  
  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd=TRUE,las=1)
  on.exit(par(xpd=old.xpd,las=old.las))

  # if any of the rf's are NA (ie no data), put NAs in corresponding LODs
  if(any(is.na(g))) g[is.na(t(g))] <- NA

  # convert rf to -2*(log2(rf)+1); place 12's on the diagonal;
  #    anything above 12 replaced by 12;
  #    NA's replaced by -1
  g[row(g) > col(g) & g > 0.5] <- 0.5
  g[row(g) > col(g)] <- -4*(log2(g[row(g) > col(g)])+1)
  diag(g) <- 12
  g[!is.na(g) & g>12] <- 12
  
  g[is.na(g)] <- -1

  if(which=="lod") { # plot LOD scores 
    # copy upper triangle (LODs) to lower triangle (rec fracs)
    g[row(g) > col(g)] <- t(g)[row(g) > col(g)]
  }
  else if(which=="rf") { # plot recombination fractions
    # copy lower triangle (rec fracs) to upper triangle (LODs)
    g[row(g) < col(g)] <- t(g)[row(g) < col(g)]
  }
  br <- c(-1, seq(-1e-6, 12, length=65))


  image(1:ncol(g),1:nrow(g),t(g),ylab="Markers",xlab="Markers",breaks=br,
        col=c("lightgray",rev(rainbow(64,start=0,end=2/3))))
  
  # plot lines at the chromosome boundaries
  n.mar <- nmar(x)
  n.chr <- nchr(x)
  a <- c(0.5,cumsum(n.mar)+0.5)
  abline(v=a,xpd=FALSE)
  abline(h=a,xpd=FALSE)

  # this line adds a line above the image
  #     (the image function leaves it out)
  abline(h=0.5+nrow(g),xpd=FALSE)
  abline(v=0.5+nrow(g),xpd=FALSE)

  # add chromosome numbers
  a <- par("usr")
  wh <- cumsum(c(0.5,n.mar))
  for(i in 1:n.chr) 
    text(mean(wh[i+c(0,1)]),a[4]+(a[4]-a[3])*0.025,names(x$geno)[i])
  for(i in 1:n.chr) 
    text(a[2]+(a[2]-a[1])*0.025,mean(wh[i+c(0,1)]),names(x$geno)[i])

  if(which=="lod") title(main="Pairwise LOD scores")
  else if(which=="rf") title(main="Recombination fractions")
  else title("Pairwise recombination fractions and LOD scores")
  
}

######################################################################
# check for apparent errors in the recombination fractions
######################################################################
checkrf <-
function(cross, threshold=3)
{
  rf <- cross$rf
  n.mar <- nmar(cross)
  map <- pull.map(cross)
  n <- ncol(rf)
  mnam <- colnames(rf)
  whpos <- unlist(lapply(map,function(a) 1:length(a)))
  whchr <- rep(names(map),sapply(map,length))

  # first check whether a locus has "significant" pairwise recombination
  #     with rf > 0.5
  for(i in 1:n) {
    if(i == 1) {
      lod <- rf[1,-1]
      r <- rf[-1,1]
    }
    else if(i == n) {
      lod <- rf[-n,n]
      r <- rf[n,-n]
    }
    else {
      lod <- c(rf[1:(i-1),i],rf[i,(i+1):n])
      r <- c(rf[i,1:(i-1)],rf[(i+1):n,i])
    }

    # if rf > 1/2 and LOD > threshold for more than two other markers
    if(sum(!is.na(lod) & !is.na(r) & lod > threshold & r > 0.5) >= 2)
      warning("Genotypes potentially switched for marker ", mnam[i],
          paste(" (",whpos[i],")",sep=""), " on chr ", whchr[i], "\n")
    
  }

}

# end of est.rf.R
######################################################################
#
# fitqtl.R
#
# copyright (c) 2002-4, Hao Wu, The Jackson Laboratory
#                     and Karl W. Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2002
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: fitqtl, parseformula, summary.fitqtl,
#           print.summary.fitqtl
#
######################################################################

######################################################################
#
# This is the function to fit a model and generate some tables
#
# Now only imputation method is implemented
#
#
######################################################################

fitqtl <-
function(pheno, qtl, covar=NULL, formula, method=c("imp"),
         dropone=TRUE)
{
  # some input checking stuff in here
  if( !sum(class(qtl) == "qtl") )
    stop("The second input variable must be an object of class qtl.")

  method <- match.arg(method)

  if(method=="imp" && is.na(match("geno", names(qtl))))
    stop("You need to run sim.geno() before creating the qtl object.")
  
  # check the input phenotypes and covarariates; drop individuals
  # with missing values.
  keep.ind <- !is.na(pheno)
  if(!is.null(covar)) { # loop thru covarariates
    for(i in 1:ncol(covar))
      keep.ind <- keep.ind & (!is.na(covar[,i]))
  }
  # if there IS missing data, do some subset
  if(any(!keep.ind)) {
    # subset pheno data
    pheno <- pheno[keep.ind]
    # subset covarariate
    covar.tmp <- as.data.frame(covar[keep.ind,])
    colnames(covar.tmp) <- colnames(covar)
    covar <- covar.tmp
    # hack input qtl object to drop individuals with missing data
    qtl$n.ind <- sum(keep.ind)
    qtl$geno <- qtl$geno[keep.ind,,]
  }
  
  # local variables
  n.ind <- qtl$n.ind # number of individuals
  n.qtl <- qtl$n.qtl # number of selected markers
  n.draws <- dim(qtl$geno)[3] # number of draws
  n.gen <- qtl$n.gen # number of genotypes
  
  if( is.null(covar) ){  # number of covarariates
    n.covar <- 0
  }
  else {
    n.covar <- ncol(covar)
  }
  
  # if formula is missing, build one
  # all QTLs and covarariates will be additive by default
  if(missing(formula)) {
    tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names
    formula <- "y~Q1"
    if(n.qtl > 1) 
      for (i in 2:n.qtl) 
        formula <- paste(formula, tmp.Q[i], sep="+")
    if (n.covar) { # if covarariate is not empty
      tmp.C <- dimnames(covar)[[2]] # covarariate term names
      for(i in 1:n.covar)
        formula <- paste(formula, tmp.C[i], sep="+")
    }
    formula <- as.formula(formula)
  }

  # parse the input formula
  p <- parseformula(formula, dimnames(qtl$geno)[[2]], dimnames(covar)[[2]])

  # make an array n.gen.QC to represent the genotype numbers
  # for all input QTLs and covarariates. For covarariates the
  # number of genotyps is 1. This makes programming easier
  n.gen.QC <- c(n.gen[p$idx.qtl]-1, rep(1, p$n.covar))

  # covarariates to be passed to C function
  # This is done in case of that user input covar but has no covar in formula
  covar.C <- NULL
  if(!is.null(p$idx.covar))
    covar.C <- as.matrix(covar[,p$idx.covar])
  
  # call C function to do the genome scan
  if(method == "imp") {
    z <- .C("R_fitqtl_imp",
            as.integer(n.ind), # number of individuals
            as.integer(p$n.qtl), # number of qtls
            as.integer(n.gen.QC), # number of genotypes QTLs and covarariates
            as.integer(n.draws), # number of draws
            as.integer(qtl$geno[,p$idx.qtl,]), # genotypes for selected marker
            as.integer(p$n.covar), # number of covarariate
            as.double(covar.C), # covarariate
            as.integer(p$formula.intmtx),  # formula matrix for interactive terms
            as.integer(p$n.int), # number of interactions in the formula
            as.double(pheno), # phenotype
            # return variables
            lod=as.double(0), # LOD score
            df=as.integer(0), # degree of freedom
            PACKAGE="qtl")
  }

  ##### output ANOVA table for full model #####
  result.full <- matrix(NA, 3, 7)
  colnames(result.full) <- c("df", "SS", "MS", "LOD", "%var", "Pvalue(Chi2)",
                             "Pvalue(F)")
  rownames(result.full) <- c("Model", "Error", "Total")
  result.full[1,1] <- z$df # model degree of freedom
  # compute the SS for total
  Rss0 <- 0
  mpheno <- mean(pheno)
  for(i in 1:length(pheno)) {
    Rss0 <- Rss0 + (pheno[i]-mpheno)^2
  }
  # third row, for Total
  result.full[3,1] <- length(pheno) - 1 # total degree of freedom
  result.full[3,2] <- Rss0 # total sum of squares
    
  # first row, for Model
  result.full[1,1] <- z$df # df for Model
  # Variance explained by model
  result.full[1,5] <- 100 * (1 - exp(-2*z$lod*log(10)/n.ind))
  result.full[1,2] <- Rss0 * result.full[1,5]/100  # SS for model
  result.full[1,3] <- result.full[1,2]/z$df # MS for model
  result.full[1,4] <- z$lod # Model LOD score

  # Second row, for Error
  # df
  result.full[2,1] <- result.full[3,1] - result.full[1,1]
  # SS
  result.full[2,2] <- result.full[3,2] - result.full[1,2]
  # MS
  result.full[2,3] <- result.full[2,2] / result.full[2,1]

  # first row, P values
  # P value (chi2) for model
  result.full[1,6] <- 1 - pchisq(2*log(10)*z$lod, z$df)
  # P value (F statistics) for model
  df0 <- result.full[3,1]; df1 <- result.full[2,1];
  Rss1 <- result.full[2,2]
  Fstat <- ((Rss0-Rss1)/(df0-df1)) / (Rss1/df1)
  result.full[1,7] <- 1 - pf(Fstat, df0-df1, df1)

  ############# Finish ANOVA table for full model
  
  # initialize output object
  output <- NULL
  output$result.full <- result.full

  # drop one at a time?
  if(dropone & p$n.qtl > 1) { 
    # user wants to do drop one term at a time and output anova table

    # get the terms etc. for input formula
    f.terms <- terms(formula)
    f.order <- attr(f.terms, "order")
    f.label <- attr(f.terms, "term.labels")

    # initialize output matrix
    # ANOVA table will have five columns, e.g., df,Type III SS,
    # LOD, %var, Pvalue for each dropping term
    # Full model result will not be in this table
    result <- matrix(0, length(f.order), 7)
    colnames(result) <- c("df", "Type III SS", "LOD", "%var", "F value",
                          "Pvalue(Chi2)", "Pvalue(F)")
    rownames(result) <- rep("",length(f.order))

    # record the result for full model
#    result[1,1] <- z$df
#    result[1,3] <- z$lod
#    result[1,4] <-  100 * (1 - exp(-2*z$lod*log(10)/n.ind))
#    result[1,5] <- 1 - pchisq(2*log(10)*z$lod, z$df)
#    rownames(result)[1] <- "Full"
      
    drop.term.name <- NULL
    for( i in (1:length(f.order)) ) {
      # loop thru all terms in formula, from the highest order
      # the label of the term to be droped
      label.term.drop <- f.label[i]
      
      ### find the corresponding QTL name for this term ###
      # This is used for output ANOVA table
      if(f.order[i] == 1) {
        # this is a first order term
        # if the term label is like Q(q)1, Q(q)2, etc., then it's a QTL
        if( length(grep("Q[0-9]", label.term.drop, ignore.case=TRUE)) != 0) {
          idx.qtlname <- as.integer(substr(label.term.drop, 2, 10))
          drop.term.name[i] <- qtl$name[idx.qtlname]
        }
        else { # this is a covarariate
          drop.term.name[i] <- label.term.drop
        }
      }
      else {
        # this is a 2nd (or higher)order and the term is a string like "Q2:Q3:C1"
        # I use strsplit to split it to a string vector "Q2" "Q3" "C1".
        # then take out 2 and 3 as integer. Then find out the
        # QTL name from the input QTL object and concatenate them
        tmp.str <- strsplit(label.term.drop,":")[[1]]
        for(j in 1:length(tmp.str)) {
          if( length(grep("Q[0-9]", tmp.str[j], ignore.case=TRUE)) != 0 ) {
            # this is a QTL
            idx.qtlname <- as.integer(substr(tmp.str[j], 2, 100))
            tmp.str[j] <- qtl$name[idx.qtlname]
          }
          if(j == 1) # first term
            drop.term.name[i] <- tmp.str[j]
          else # not the first term
            drop.term.name[i] <- paste(drop.term.name[i], tmp.str[j], sep=":")
        }
      }
      ### Finish QLT name ###
                          
      # find the indices of the term(s) to be dropped
      # All terms contain label.term.drop will be dropped
      idx.term.drop <- NULL
      tmp.str.drop <- tolower(strsplit(label.term.drop,":")[[1]])
      for(j in 1:length(f.label)) {
        tmp.str.label <- tolower(strsplit(f.label[j], ":")[[1]])
        if(all(tmp.str.drop %in% tmp.str.label))
          idx.term.drop <- c(idx.term.drop, j)
      }
                                  
      # the indices of term(s) to be kept
      idx.term.kept <- setdiff(1:length(f.order), idx.term.drop)
      
      #### regenerate a formula with the kept terms additive ###
      if(length(idx.term.kept) == 0) { # nothing left after drop label.term.drop
        msg <- paste("There will be nothing left if drop ", drop.term.name[i])
        stop(msg)
      }
      else {
        # All terms for idx.term.kept will be additive
        # Why it's so awkward? paste can't concatenate a list of strings?
        formula.new <- NULL
        for(j in 1:length(idx.term.kept)) {
          formula.new <- paste(formula.new, f.label[idx.term.kept[j]], sep="+")
        }
        formula.new <- as.formula(paste("y~", substr(formula.new, 2, 100000), sep=""))
      }
      ### Finish generating a new formula

      ### Start fitting model again
      # parse the input formula
      p.new <- parseformula(formula.new, dimnames(qtl$geno)[[2]], dimnames(covar)[[2]])
      n.gen.QC <- c(n.gen[p.new$idx.qtl]-1, rep(1, p.new$n.covar))

      # covarariate to be passed to C function
      covar.C <- NULL
      if(!is.null(p.new$idx.covar))
        covar.C <- as.matrix(covar[,p.new$idx.covar])
      
      # call C function to do the genome scan
      if(method == "imp") {
        z <- .C("R_fitqtl_imp",
                as.integer(n.ind), # number of individuals
                as.integer(p.new$n.qtl), # number of qtls
                as.integer(n.gen.QC), # number of genotypes QTLs and covarariates
                as.integer(n.draws), # number of draws
                as.integer(qtl$geno[,p.new$idx.qtl,]), # genotypes for selected marker
                as.integer(p.new$n.covar), # number of covarariate
                as.double(covar.C), # covarariate
                as.integer(p.new$formula.intmtx),  # formula matrix for interactive terms
                as.integer(p.new$n.int), # number of interactions in the formula
                as.double(pheno), # phenotype
                # return variables
                lod=as.double(0), # LOD score
                df=as.integer(0), # degree of freedom
                PACKAGE="qtl")
      }

      # record the result for dropping this term
      # df
      result[i,1] <- result.full[1,1] - z$df
      # LOD score
      result[i,3] <- result.full[1,4] - z$lod
      # % variance explained
      result[i,4] <- result.full[1,5] - 100*(1 - exp(-2*z$lod*log(10)/n.ind))
      # Type III SS for this term - computed from %var
      result[i,2] <- result.full[3,2] * result[i,4] / 100
      # F value
      df0 <- length(pheno) - z$df - 1; df1 <- result.full[2,1];
      Rss0 <- result.full[2,2] + result[i,2];
      Rss1 <- result.full[2,2]
      Fstat <- ((Rss0-Rss1)/(df0-df1)) / (Rss1/df1)
      result[i,5] <- Fstat
      # P value (chi2)
      result[i,6] <- 1 - pchisq(2*log(10)*result[i,3], result[i,1])
      # P value (F)
      result[i,7] <- 1 - pf(Fstat, df0-df1, df1)
      # assign row name
      rownames(result)[i] <- drop.term.name[i]
    } # finish dropping terms loop

    # assign output object
    output$result.drop <- result
    
  }  ## if(dropone)
      
#  else {
    # don't do drop one at at time
    # output the lod, pvar and df for this model
#    result <- matrix(rep(0,4),1,4)
#    result[1] <- z$lod
#    result[2] <- 100*(1 - exp(-2*z$lod*log(10)/n.ind))
#    result[3] <- z$df
#    result[4] <- 1 - pchisq(2*log(10)*z$lod, z$df)
#    rownames(result) <- "Full"
#    colnames(result) <- c("LOD", "%var", "df", "Pvalue")
#  }

  
  class(output) <- "fitqtl"
  attr(output, "method") <- method
  attr(output, "formula") <- formula
  attr(output, "type") <- qtl$type
  attr(output, "nind") <- length(pheno)
  output

}


#####################################################################
#
# parseformula
#
# Function to be called by fitqtl. It's used to
# parse the input formula
#
# This is the internal function and not supposed to be used by user
#
#####################################################################

parseformula <- function(formula, qtl.dimname, covar.dimname)
{
  # The terms for input formula
  f.formula <- terms(formula)
  order.term <- attr(f.formula, "order") # get the order of the terms
  idx.term <- which(order.term==1) # get the first order terms
  label.term <- attr(f.formula, "term.labels")[idx.term]
  formula.mtx <- attr(f.formula, "factors") # formula matrix
 
  idx.qtl <- NULL
  idx.covar <- NULL

  # loop thru all terms and find out how many QTLs and covarariates
  # are there in the formula. Construct idx.qtl and idx.covar at the same time
  for (i in 1:length(idx.term)) {
    # find out if there term is a QTL or a covarariate
    # ignore the case for QTLs, e.g., Q1 is equivalent to q1
    idx.tmp <- grep(paste(label.term[i],"$", sep=""),
                    qtl.dimname, ignore.case=TRUE)
    if( length(idx.tmp) )  # it's a QTL
      idx.qtl <- c(idx.qtl, idx.tmp)
    else if(label.term[i] %in% covar.dimname) # it's a covarariate
      idx.covar <- c(idx.covar, which(label.term[i]==covar.dimname))
    else {
      err <- paste("Unrecognized term", label.term[i], "in formula")
      stop(err)
    }
  }
  n.qtl <- length(idx.qtl) # number of QTLs in formula
  n.covar <- length(idx.covar) # number of covarariates in formula
  # now idx.qtl and idx.covar are the indices for genotype
  # and covarariate matrices according to input formula
 
  # loop thru all terms again and reorganize formula.mtx
  formula.idx <- NULL
  ii <- 1
  jj <- 1
  for (i in 1:length(idx.term)) {
    if(label.term[i] %in% qtl.dimname) {  # it's a QTL
      formula.idx <- c(formula.idx, ii)
      ii <- ii+1
    }
    else { # it's a covarariate
      formula.idx <- c(formula.idx, jj+n.qtl)
      jj <- jj+1
    }
  }

  # reorganize formula.mtx according to formula.idx
  # remove the first row (for y)
  formula.mtx <- formula.mtx[2:nrow(formula.mtx),]
  # rearrange the rows according to formula.idx if there's more than one row
  if(length(formula.idx) > 1)
    formula.mtx <- formula.mtx[order(formula.idx),]
  # take out only part of the matrix for interactions and pass to C function
  # all the input QTLs and covarariates for C function will be additive
  n.int <- length(order.term) - length(idx.term) # number of interactions
  if(n.int != 0)
    formula.intmtx <- formula.mtx[,(length(idx.term)+1):length(order.term)]
  else # no interaction terms
    formula.intmtx <- NULL
  

  # return object
  result <- NULL
  result$idx.qtl <- idx.qtl
  result$n.qtl <- n.qtl
  result$idx.covar <- idx.covar
  result$n.covar <- n.covar
  result$formula.intmtx <- formula.intmtx
  result$n.int <- n.int

  result

}


#####################################################################
#
# summary.fitqtl
#
#####################################################################
summary.fitqtl <- function(object, ...)
{
  # this is just an interface.
  class(object) <- "summary.fitqtl"
  object
}


#####################################################################
#
# print.summary.fitqtl
#
#####################################################################
print.summary.fitqtl <- function(x, ...)
{
  cat("\n")
  cat("\t\tSummary for fit QTL\n\n")
  cat( paste("Method is: ", attr(x, "method"), "\n") )
  cat( paste("Number of observations: ", attr(x, "nind"), "\n\n") )

  # print ANOVA table for full model
  cat("Full model result\n")
  cat("----------------------------------  \n")
  cat( paste("Model formula is: ", deparse(attr(x, "formula")), "\n\n") )
  print(x$result.full, quote=FALSE, na.print="")
  cat("\n\n")
  
  # print ANOVA table for dropping one at a time analysis (if any)
  if("result.drop" %in% names(x)) {
    cat("Drop one QTL at a time ANOVA table: \n")
    cat("----------------------------------  \n")
    # use printCoefmat instead of print.data.frame
    # make sure the last column is P value
    printCoefmat(x$result.drop, digits=4, cs.ind=1, P.values=TRUE, has.Pvalue=TRUE)
    cat("\n")
  }

}
######################################################################
#
# makeqtl.R
#
# copyright (c) 2002-4, Hao Wu, The Jackson Laboratory
#                     and Karl W. Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2002
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: makeqtl, replaceqtl, addqtl, dropqtl, locatemarker
#
######################################################################

######################################################################
#
# This is the function to construct an object of class "qtl"
# The phenotype data and genotype data for a given list of
# chromosome and locations will be extracted from the input
# "cross" object
#
######################################################################

######################################################################
#
# Notes/Question:
#  1. Do we want to pull out draws and prob at the same time?
#     If user specifed pos is far from the real marker, there
#     might be some problem for pulling out genoprob
#  2. The utility functions can be put in util.R
#
######################################################################

makeqtl <-
  function(cross, chr, pos, qtl.name)
{
  if( !sum(class(cross) == "cross") )
    stop("The first input variable must be  an object of class cross")

  # cross type
  type <- class(cross)[1]
  
  # check phenotypes
#  if(length(pheno.col) > 1) pheno.col <- pheno.col[1]
#  if(pheno.col < 1 || pheno.col > nphe(cross))
#    stop("Specified phenotype column is invalid.")
  
  # chr, pos and qtl.name must have the same length
  if(length(chr) != length(pos))
    stop("Input chr and pos must have the same length.")
  else if( !missing(qtl.name) )
    if( length(chr) != length(qtl.name) )
      stop("Input chr and qtl.name must have the same length.")

  # local variables
  n.ind <- nrow(cross$pheno) # number of individuals
  n.pos <- length(chr) # number of selected markers
  n.gen <- NULL

  # initialize output object
  qtl <- NULL
  
  # take out the imputed genotypes and/or genoprobs for the
  # selected markers (if there are there)
  if("draws" %in% names(cross$geno[[1]])) { # draws is there
    # take out imputed genotype data
    n.draws <- dim(cross$geno[[1]]$draws)[3] # number of draws
    # initialize geno matrix for selected markers
    geno <- array(rep(0, n.ind*n.pos*n.draws),
                  dim=c(n.ind, n.pos, n.draws))
    for(i in 1:n.pos) {
      # get the index for this chromosome
      i.chr <- which(chr[i]==names(cross$geno))
      if(length(i.chr) == 0) { # no this chromosome in cross 
        err <- paste("There's no chromosome number ", chr[i], "in input cross object")
        stop(err)
      }
      i.pos <- pos[i] # marker position
      # make the genetic map for this chromosome
      map <- create.map(cross$geno[[i.chr]]$map,
                        attr(cross$geno[[i.chr]]$draws,"step"),
                        attr(cross$geno[[i.chr]]$draws,"off.end"))
      # pull out the female map if there are sex-specific maps
      if(is.matrix(map)) map <- map[1,]

      # locate this marker (given chromosome and position)
      marker.idx <- locatemarker(map, i.pos, i.chr, flag="draws")
      
      # if everything is all right, take the genotype
      geno[,i,] <- cross$geno[[i.chr]]$draws[,marker.idx,]

      ### Fix up X chromsome here, and relace stuff below ###

      # get the number of genotypes for this marker
      if(type == "f2") {
        if(class(cross$geno[[i.chr]]) == "A") # autosomal
          n.gen[i] <- 3
        else                             # X chromsome 
          n.gen[i] <- 2
      }
      else if(type == "bc" || type=="riself" || type=="risib") 
        n.gen[i] <- 2
      else if(type == "4way") 
        n.gen[i] <- 4
      else {
        err <- paste("makeqtl not available for cross", type)
        stop(err)
      }
    }
    # give geno dimension names
    # the 2nd dimension called "Q1", "Q2", etc.
    dimnames(geno) <- list(NULL, paste("Q", 1:n.pos, sep=""), NULL)
    # output 
    qtl$geno <- geno
  }
  
  if("prob" %in% names(cross$geno[[1]])) { # prob is there
    # take out the genotype probabilities
    ngens <- dim(cross$geno[[1]]$prob)[3]
    # initialize prob matrix
    prob <- array(rep(0,n.ind*n.pos*ngens),
                  dim=c(n.ind, n.pos, ngens))
    # locate the marker
    for(i in 1:n.pos) {
      # get the index for this chromosome
      i.chr <- which(chr[i]==names(cross$geno))
      if(length(i.chr) == 0) { # no this chromosome in cross
        err <- paste("There's no chromosome number ", chr[i], "in input cross object")
        stop(err)
      }
      i.pos <- pos[i] # marker position
      # locate this marker (given chromosome and position)
      marker.idx <- locatemarker(cross$geno[[i.chr]]$map, i.pos, i.chr, flag="prob")
      # take genoprob
      prob[,i,] <- cross$geno[[i.chr]]$prob[,marker.idx,]

      ### Fix up X chromsome here ###
    }
    qtl$prob <- prob
  }

  if( sum(c("draws","prob") %in% names(cross$geno[[1]]))==0 ) 
    stop("You need to run calc.genoprob() or sim.geno() first.")

  if(missing(qtl.name))  # no given qtl names
    # make qtl names
    qtl.name <- paste( paste("Chr",chr,sep=""), pos, sep="@")

  # output object
  qtl$name <- qtl.name
  qtl$chr <- chr
  qtl$pos <- pos
  qtl$n.qtl <- n.pos
  qtl$n.ind <- nind(cross)
  qtl$n.gen <- n.gen

  class(qtl) <- "qtl"
  
  qtl
}
  


######################################################################
#
# This is the function to replace one QTL by another.
# This is the internal function and not supposed to be used by user
#
######################################################################
replaceqtl <-
  function(cross, qtl, replace, by.chr, by.pos, by.name, map)
{
  # update QTL name
  if(missing(by.name))
    by.name <- paste(paste("Chr",by.chr,sep=""), by.pos, sep="@")
  qtl$name[replace] <- by.name

  # update chr and pos
  qtl$chr[replace] <- by.chr
  qtl$pos[replace] <- by.pos
  
  # update the imputed genotype and n.gen vector (if any)
  if("geno" %in% names(qtl)) {
    if(missing(map))  { # make genetic map on this chromosome
      # pull out female map in case that there are sex-specific maps
      if(is.matrix(map)) map <- map[1,]

      map <- create.map(cross$geno[[by.chr]]$map,
                        attr(cross$geno[[by.chr]]$draws,"step"),
                        attr(cross$geno[[by.chr]]$draws,"off.end"))
    }

    # locate this marker (given chromosome and position)
    marker.idx <- locatemarker(map, by.pos, by.chr, "draws")

    # replace the genotypes
    qtl$geno[,replace,] <- cross$geno[[by.chr]]$draws[,marker.idx,]

     # update number of genotypes
    type <- class(cross)[[1]]
    if(type == "f2") {
      if(class(cross$geno[[by.chr]]) == "A") # autosomal
        qtl$n.gen[replace] <- 3
      else                             # X chromsome 
        qtl$n.gen[replace] <- 2
    }
    else if(type == "bc" || type=="risib" || type=="riself") 
      qtl$n.gen[replace] <- 2
    else if(type == "4way") 
      qtl$n.gen[replace] <- 4
    else {
      err <- paste("replaceqtl not available for cross", type)
      stop(err)
    }
  }
  
  # update the genoprob (if any)
  if("prob" %in% names(qtl)) {
    #locate the marker
    marker.idx <- locatemarker(cross$geno[[by.chr]]$map,
                                by.pos, by.chr, "prob")
    # replace genoprob
    qtl$prob[,replace,] <- cross$geno[[by.chr]]$prob[,marker.idx,]
  }

  # done
  
  qtl
}


######################################################################
#
# This is the function to add a QTL to given qtl object
# This is the internal function and not supposed to be used by user
#
######################################################################

addqtl <-
  function(cross, qtl, add.chr, add.pos, add.name, map)
{
  # update number of QTLs
  qtl$n.qtl <- qtl$n.qtl + 1

  # update chr and pos
  qtl$chr <- c(qtl$chr, add.chr)
  qtl$pos <- c(qtl$pos, add.pos)
  
  # add QTL name
  if(missing(add.name))
    add.name <- paste(paste("Chr",add.chr,sep=""), add.pos, sep="@")
  qtl$name[qtl$n.qtl] <- add.name
  
  # add new entry to the imputed genotype and n.gen vector (if any)
  if("geno" %in% names(qtl)) {
    # update number of genotypes
    type <- class(cross)[[1]]
    if(type == "f2") {
      if(class(cross$geno[[add.chr]]) == "A") # autosomal
        n.gen <- 3
      else                             # X chromsome 
        n.gen <- 2
    }
    else if(type == "bc" || type=="risib" || type=="riself") 
      n.gen <- 2
    else if(type == "4way") 
      n.gen <- 4
    else {
      err <- paste("addqtl not available for cross", type)
      stop(err)
    }
    qtl$n.gen <- c(qtl$n.gen, n.gen)
  
    # add the imputed genotype
    if(missing(map)) { # make genetic map on this chromosome, if missing
      # pull out female map in case that there are sex-specific maps
      if(is.matrix(map)) map <- map[1,]

      map <- create.map(cross$geno[[add.chr]]$map,
                        attr(cross$geno[[add.chr]]$draws,"step"),
                        attr(cross$geno[[add.chr]]$draws,"off.end"))
    }

    # locate this marker (given chromosome and position)
    marker.idx <- locatemarker(map, add.pos, add.chr, "draws")

    # reallocate memory for geno array
    n.ind <- dim(qtl$geno)[1]
    n.draw <- dim(qtl$geno)[3]
    geno <- array( rep(0, n.ind*n.draw*qtl$n.qtl),
                  c(n.ind, qtl$n.qtl, n.draw) )
  
    geno[,1:(qtl$n.qtl-1),] <- qtl$geno
    geno[,qtl$n.qtl,] <- cross$geno[[add.chr]]$draws[,marker.idx,]
    dimnames(geno) <- list(NULL, paste("Q", 1:qtl$n.qtl, sep=""), NULL)

    # replace geno in qtl
    qtl$geno <- geno
  }

  # add new entry to prob (if any)
  if("prob" %in% names(qtl)) {
    marker.idx <- locatemarker(cross$geno[[add.chr]]$map,
                                add.pos, add.chr, "prob")
    # reallocate memory for prob array
    n.ind <- dim(qtl$prob)[1]
    ngen <- dim(qtl$prob)[3]
    prob <- array( rep(0, n.ind*ngen*qtl$n.qtl),
                  c(n.ind, qtl$n.qtl, ngen))
    prob[,1:(qtl$n.qtl-1),] <- qtl$prob
    prob[,qtl$n.qtl,] <- cross$geno[[add.chr]]$prob[,marker.idx,]

    # replace prob in qtl
    qtl$prob <- prob
  }

  # done
  qtl
}

######################################################################
#
# This is the function to drop a QTL for a given qtl object
# This is the internal function and not supposed to be used by user
#
######################################################################
dropqtl <-
  function(qtl, drop)
{
  # input drop is an integer index
  # get the index for exclusing drop QTL
  idx <- setdiff(1:qtl$n.qtl, drop)
  
  # result object
  result <- NULL
  result$name <- qtl$name[idx]
  result$chr <- qtl$chr[idx]
  result$pos <- qtl$pos[idx]
  result$n.qtl <- qtl$n.qtl - 1
  result$n.ind <- qtl$n.ind
  result$n.gen <- qtl$n.gen[idx]
  result$geno <- qtl$geno[,idx,]
  result$prob <- qtl$prob[,idx,]
  result$type <- type
  dimnames(result$geno) <- list(NULL, paste("Q", 1:result$n.qtl, sep=""),
                                NULL)

  class(result) <- "qtl"

  result
}


##################################################################
#
# locate the marker on a genetic map. Choose the nearest
# one if there's no marker or pseudomarker one the given
# location
#
# This is the internal function and not supposed to be used by user
#
###################################################################

locatemarker <-
  function(map, pos, chr, flag)
{  
  marker.idx <- which(map == pos)
  if( length(marker.idx)==0 ) {
    # there's no this marker, take the nearest marker instead
    # if there's a tie, take the first nearst one
    m.tmp <- abs(pos-map)
    marker.idx <- which(m.tmp==min(m.tmp))[[1]]
#    if(flag == "draws") {
#      msg <- "For draws: "
#    }
#    else if(flag == "prob") {
#      msg <- "For prob: "
#    }
#    msg <- paste(msg, "there's no marker on Chr ", chr, ", at ",
#                 pos,"cM.", sep="")
#    msg <- paste(msg, " Take marker at ", map[[marker.idx]], "cM instead.",
#                 sep="")
#    warning(msg)
  }

  marker.idx
}

# end of makeqtl.R
######################################################################
#
# plot.R
#
# copyright (c) 2000-4, Karl W Broman, Johns Hopkins University
#       [modifications of plot.cross from Brian Yandell]
# last modified Jul, 2004
# first written Mar, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: plot.missing, plot.map, plot.cross, plot.geno, plot.info,
#           plot.pxg
#
######################################################################

plot.missing <-
function(x, chr, reorder=FALSE, main="Missing genotypes", ...) 
{
  cross <- x
  if(!missing(chr)) cross <- subset(cross,chr=chr)
  
  # get full genotype data into one matrix
  Geno <- cross$geno[[1]]$data
  if(length(cross$geno) > 1) 
    for(i in 2:length(cross$geno))
      Geno <- cbind(Geno,cross$geno[[i]]$data)

  # reorder the individuals according to their phenotype
  o <- 1:nrow(Geno)
  if(reorder) {
    # if reorder is a number, use the corresponding phenotype
    if(is.numeric(reorder)) {
      if(reorder < 1 || reorder > nphe(cross)) 
        stop("reorder should be TRUE, FALSE, or an integer between 1 and", nphe(cross))

      o <- order(cross$pheno[,reorder])
    }

    # otherwise, order according to the sum of the phenotypes
    else o <- order(apply(cross$pheno,1,sum))
  }

  # make matrix with  0 where genotype data is missing
  #                   1 where data is not missing
  #                 0.5 where data is partially missing
  type <- class(cross)[1]
  g <- t(Geno[o,])
  g[is.na(g)] <- 0
  if(type == "bc" || type=="risib" || type=="riself") 
    g[g > 0] <- 1
  else if(type=="f2") {
    g[g > 0 & g < 4] <- 1
    g[g > 3] <- 0.5
  }
  else if(type=="4way") {
    g[g > 0 & g < 5] <- 1
    g[g > 4] <- 0.5
  }
  else {
    g[g > 0] <- 1
  }

  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd=TRUE,las=1)
  on.exit(par(xpd=old.xpd,las=old.las))

  colors <- c("#000000", "gray80", "#FFFFFF")

  # plot grid with black pixels where there is missing data
  image(1:nrow(g),1:ncol(g),g,ylab="Individuals",xlab="Markers",col=colors,zlim=c(0,1))

  # plot lines at the chromosome boundaries
  n.mar <- nmar(cross)
  n.chr <- nchr(cross)
  a <- c(0.5,cumsum(n.mar)+0.5)

  # the following makes the lines go slightly above the plotting region
  b <- par("usr")
  segments(a,b[3],a,b[4]+diff(b[3:4])*0.02)

  # this line adds a line above the image
  #     (the image function seems to leave it out)
  abline(h=0.5+c(0,ncol(g)),xpd=FALSE)

  # add chromosome numbers
  a <- par("usr")
  wh <- cumsum(c(0.5,n.mar))
  for(i in 1:n.chr)
    text(mean(wh[i+c(0,1)]),a[4]+(a[4]-a[3])*0.025,names(cross$geno)[i])

  title(main=main)
  invisible()
}

plot.map <-
function(x,map2,horizontal=FALSE,...) 
{
  map <- x
  # figure out if the input is a cross (containing a map)
  #    or is the map itself
  if(!is.na(match("geno",names(map)))) 
    map <- pull.map(map)

  sex.sp <- FALSE

  if(is.matrix(map[[1]])) { # sex-specific map
    one.map <- FALSE
    sex.sp <- TRUE
    if(!missing(map2)) {
      if(is.logical(map2)) {
        horizontal <- map2
        map2 <- lapply(map,function(a) a[2,])
        map <- lapply(map,function(a) a[1,])
      }
      else {
        if(!is.na(match("geno",names(map2))))
          map2 <- pull.map(map2)
        Map1 <- lapply(map,function(a) a[1,,drop=TRUE])
        Map2 <- lapply(map,function(a) a[2,,drop=TRUE])
        Map3 <- lapply(map2,function(a) a[1,,drop=TRUE])
        Map4 <- lapply(map2,function(a) a[2,,drop=TRUE])
        old.mfrow <- par("mfrow")
        on.exit(par(mfrow=old.mfrow))
        par(mfrow=c(2,1))
        plot.map(Map1,Map3,horizontal)
        plot.map(Map2,Map4,horizontal)
        return(invisible())
      }
    }
    else {
      map2 <- lapply(map,function(a) a[2,])
      map <- lapply(map,function(a) a[1,])
    }
  }
  else { # single map
    # determine whether a second map was given
    if(!missing(map2)) {
      if(is.logical(map2)) { # assume "map2" should be "horizontal"
        horizontal <- map2
        map2 <- NULL
        one.map <- TRUE
      }
      else { # determine if it is a cross object
        if(!is.na(match("geno",names(map2))))
          map2 <- pull.map(map2)
        one.map <- FALSE
      }
    }
    else one.map <- TRUE
  }
       
  if(one.map) {
    n.chr <- length(map)
    map <- lapply(map, function(a) a-min(a))
    maxlen <- max(unlist(lapply(map,max)))

    if(horizontal) {
      old.xpd <- par("xpd")
      old.yaxt <- par("yaxt")
      par(xpd=TRUE,yaxt="n")
      on.exit(par(xpd=old.xpd,yaxt=old.yaxt))
      
      plot(0,0,type="n",xlim=c(0,maxlen),ylim=c(0.5,n.chr+0.5),
	   xlab="Location (cM)", ylab="Chromosome")
      a <- par("usr")
      
      for(i in 1:n.chr) {
	lines(c(min(map[[i]]),max(map[[i]])),n.chr+1-c(i,i))
	nmar <- length(map[[i]])
	for(j in 1:nmar)
	  lines(rep(map[[i]][j],2),n.chr+1-i+c(-1/4,1/4))

	# add chromosome label
	text(a[1]-(a[2]-a[1])*0.02,n.chr+1-i,names(map)[i],adj=1)
	lines(c(a[1],a[1]-(a[2]-a[1])*0.01),rep(n.chr+1-i,2))
      }
    }
    else {
      old.xpd <- par("xpd")
      old.xaxt <- par("xaxt")
      old.las <- par("las")
      par(xpd=TRUE,xaxt="n",las=1)
      on.exit(par(xpd=old.xpd,xaxt=old.xaxt,las=old.las))
      
      plot(0,0,type="n",ylim=c(maxlen,0),xlim=c(0.5,n.chr+0.5),
	   ylab="Location (cM)", xlab="Chromosome")
      
      a <- par("usr")
      
      for(i in 1:n.chr) {
	lines(c(i,i), c(min(map[[i]]),max(map[[i]])))
	nmar <- length(map[[i]])
	for(j in 1:nmar)
	  lines(i+c(-1/4,1/4),rep(map[[i]][j],2))

        # add chromosome label
	text(i,a[3]-(a[4]-a[3])*0.04,names(map)[i])
	lines(rep(i,2),c(a[3],a[3]-(a[4]-a[3])*0.02))
      }
    }
    title(main="Genetic map")
  }
  else {
    # check that maps conform
    if(is.matrix(map2[[1]]))
      stop("Second map appears to be a sex-specific map.")
    if(length(map) != length(map2))
      stop("Maps have different numbers of chromosomes.")
    if(any(sapply(map,length) != sapply(map2,length)))
      stop("Maps have different numbers of markers.")

    map1 <- lapply(map,function(a) a-a[1])
    map2 <- lapply(map2,function(a) a-a[1])

    n.chr <- length(map1)
    maxloc <- max(c(unlist(lapply(map1,max)),unlist(lapply(map2,max))))

    if(!horizontal) {
      old.xpd <- par("xpd")
      old.xaxt <- par("xaxt")
      old.las <- par("las")
      par(xpd=TRUE,xaxt="n",las=1)
      on.exit(par(xpd=old.xpd,xaxt=old.xaxt,las=old.las))

      plot(0,0,type="n",ylim=c(maxloc,0),xlim=c(0.5,n.chr+0.5),
           ylab="Location (cM)", xlab="Chromosome")

      a <- par("usr")
    
      for(i in 1:n.chr) {
      
        if(max(map2[[i]]) < max(map1[[i]])) 
          map2[[i]] <- map2[[i]] + (max(map1[[i]])-max(map2[[i]]))/2
        else 
          map1[[i]] <- map1[[i]] + (max(map2[[i]])-max(map1[[i]]))/2
        
        lines(c(i-0.3,i-0.3), c(min(map1[[i]]),max(map1[[i]])))
        lines(c(i+0.3,i+0.3), c(min(map2[[i]]),max(map2[[i]])))
        
        nmar <- length(map1[[i]])
        for(j in 1:nmar)
          lines(c(i-0.3,i+0.3),c(map1[[i]][j],map2[[i]][j]))

        # add chromosome label
        text(i,a[3]-(a[4]-a[3])*0.04,names(map1)[i])
        lines(rep(i,2),c(a[3],a[3]-(a[4]-a[3])*0.02))
      }
    }
    else {
      old.xpd <- par("xpd")
      old.yaxt <- par("yaxt")
      old.las <- par("las")
      par(xpd=TRUE,yaxt="n",las=1)
      on.exit(par(xpd=old.xpd,yaxt=old.yaxt,las=old.las))

      plot(0,0,type="n",xlim=c(0,maxloc),ylim=c(0.5,n.chr+0.5),
           xlab="Location (cM)", ylab="Chromosome")

      a <- par("usr")
    
      for(i in 1:n.chr) {
      
        if(max(map2[[i]]) < max(map1[[i]])) 
          map2[[i]] <- map2[[i]] + (max(map1[[i]])-max(map2[[i]]))/2
        else 
          map1[[i]] <- map1[[i]] + (max(map2[[i]])-max(map1[[i]]))/2
        
        lines(c(min(map2[[i]]),max(map2[[i]])), c(n.chr-i-0.3+1,n.chr-i+1-0.3))
        lines(c(min(map1[[i]]),max(map1[[i]])), c(n.chr-i+1+0.3,n.chr+1-i+0.3))
        
        nmar <- length(map1[[i]])
        for(j in 1:nmar)
          lines(c(map2[[i]][j],map1[[i]][j]), c(n.chr+1-i-0.3,n.chr+1-i+0.3))

        # add chromosome label
        text(a[1]-diff(a[1:2])*0.04,n.chr+1-i, names(map1)[i])
        lines(c(a[1],a[1]-diff(a[1:2])*0.02), rep(n.chr+1-i,2))
      }

    }
    if(!sex.sp) title(main="Comparison of genetic maps")
    else title(main="Genetic map")
  }    
  invisible()
}


plot.cross <-
function (x, auto.layout = TRUE, pheno, ...) 
{
  old.yaxt <- par("yaxt")
  old.mfrow <- par("mfrow")
  on.exit(par(yaxt = old.yaxt, mfrow = old.mfrow))

  n.phe <- nphe(x)
  if(missing(pheno)) pheno <- 1:n.phe
  n.plot = length(pheno) + 2

  # automatically choose row/column structure for the plots
  if(auto.layout) {
    nr <- ceiling(sqrt(n.plot))
    nc <- ceiling((n.plot)/nr)
    par(mfrow = c(nr, nc))
  }

  plot.missing(x)
  plot.map(x)

  if( is.numeric(pheno) )
    pheno = names(x$pheno)[pheno]

  for(i in pheno) {
    if(!is.numeric(x$pheno[[i]])) {
      par(yaxt = "s")
      barplot(c(table(x$pheno[[i]])), axes = FALSE, xlab = i, ylab = "",
              main = i, col = "white")
    }
    else hist(x$pheno[[i]], breaks = round(sqrt(nrow(x$pheno)) + 5),
              xlab = i, prob = TRUE, ylab = "", main = i, yaxt = "n")
  }
  invisible()
}


##################################################r####################
#
# plot.geno: Plot genotypes for a specified chromosome, with likely
#           genotyping errors indicated. 
#
######################################################################

plot.geno <-
function(x, chr, ind, horizontal=FALSE, cutoff=3.5, min.sep=2, cex=1.2, ...)
{
  cross <- x  
  cross <- subset(cross,chr=chr)
  type <- class(cross)[1]
  
  if(type != "bc" && type != "f2" && type != "riself" && type != "risib")
    stop("Only available for backcross, intercross or RI strains.")

  if(is.na(match("errorlod",names(cross$geno[[1]])))) {
    warning("First running calc.errorlod.")
    cross <- calc.errorlod(cross,error.prob=0.01)
  }
  
  # indicators for apparent errors
  errors <- matrix(0,ncol=ncol(cross$geno[[1]]$data),
                   nrow=nrow(cross$geno[[1]]$data))
  dimnames(errors) <- dimnames(cross$geno[[1]]$data)

  top <- top.errorlod(cross,1,cutoff,FALSE)
  if(length(top) > 0)
    for(i in 1:nrow(top))
      errors[top[i,2],as.character(top[i,3])] <- 1

  # map, data, errors
  map <- cross$geno[[1]]$map
  if(is.matrix(map)) map <- map[1,] # if sex-specific map
  L <- diff(range(map))
  min.d <- L*min.sep/100
  d <- diff(map)
  d[d < min.d] <- min.d
  map <- cumsum(c(0,d))

  data <- cross$geno[[1]]$data
  if(!missing(ind)) {
    data <- data[ind,]
    errors <- errors[ind,]
  }
  n.ind <- nrow(errors)

  color <- c("white","gray60","black","green","orange","red")

  if(horizontal==TRUE) {
    plot(0,0,type="n",xlab="Position (cM)",ylab="Individual",
         main=paste("Chromosome",names(cross$geno)[1]),
         ylim=c(0.5,n.ind+0.5),xlim=c(0,max(map)))
    segments(0,1:n.ind,max(map),1:n.ind)

    # AA genotypes
    tind <- rep(1:n.ind,length(map));tind[is.na(data)] <- NA
    ind <- tind; ind[!is.na(data) & data!=1] <- NA
    x <- rep(map,rep(n.ind,length(map)))
    points(x,ind,pch=16,col=color[1],cex=cex)
    points(x,ind,pch=1,cex=cex)

    # AB genotypes
    ind <- tind; ind[!is.na(data) & data!=2] <- NA
    if(type=="f2") {
      points(x,ind,pch=16,col=color[2],cex=cex)
      points(x,ind,pch=1,cex=cex)
    }
    else points(x,ind,pch=16,col=color[3],cex=cex) 

    if(type=="f2") {
      # BB genotypes
      ind <- tind; ind[!is.na(data) & data!=3] <- NA
      points(x,ind,pch=16,col=color[3],cex=cex)

      # not BB (D in mapmaker/qtl) genotypes
      ind <- tind; ind[!is.na(data) & data!=4] <- NA
      points(x,ind,pch=16,col=color[4],cex=cex)
      points(x,ind,pch=1,cex=cex)

      # not AA (C in mapmaker/qtl) genotypes
      ind <- tind; ind[!is.na(data) & data!=5] <- NA
      points(x,ind,pch=16,col=color[5],cex=cex)
      points(x,ind,pch=1,cex=cex)
    }

    # plot map
    u <- par("usr")
    segments(map,u[3],map,(u[3]+1)/2)
    segments(map,u[4],map,(n.ind+u[4])/2)

    if(any(errors)) {
      ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA
      points(x,ind,pch=0,col=color[6],cex=cex+0.4,lwd=2)
    }

  }
  else {
    plot(0,0,type="n",ylab="Position (cM)",xlab="Individual",
         main=paste("Chromosome",names(cross$geno)[1]),
         xlim=c(0.5,n.ind+0.5),ylim=c(max(map),0))
    segments(1:n.ind,0,1:n.ind,max(map))
    
    # AA genotypes
    tind <- rep(1:n.ind,length(map));tind[is.na(data)] <- NA
    ind <- tind; ind[!is.na(data) & data!=1] <- NA
    y <- rep(map,rep(n.ind,length(map)))
    points(ind,y,pch=16,col="white",cex=cex)
    points(ind,y,pch=1,cex=cex)

    # AB genotypes
    ind <- tind; ind[!is.na(data) & data!=2] <- NA
    if(type=="f2") {
      points(ind,y,pch=16,col=color[2],cex=cex)
      points(ind,y,pch=1,cex=cex)
    }
    else points(ind,y,pch=16,col=color[3],cex=cex)

    if(type=="f2") {
      # BB genotypes
      ind <- tind; ind[!is.na(data) & data!=3] <- NA
      points(ind,y,pch=16,col=color[3],cex=cex)

      # not BB genotypes
      ind <- tind; ind[!is.na(data) & data!=4] <- NA
      points(ind,y,pch=16,col=color[4],cex=cex)
      points(ind,y,pch=1,cex=cex)

      # not AA genotypes
      ind <- tind; ind[!is.na(data) & data!=5] <- NA
      points(ind,y,pch=16,col=color[5],cex=cex)
      points(ind,y,pch=1,cex=cex)
    }

    # plot map
    u <- par("usr")
    segments(u[1],map,(u[1]+1)/2,map)
    segments(u[2],map,(n.ind+u[2])/2,map)

    if(any(errors)) {
      ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA
      points(ind,y,pch=0,col=color[6],cex=cex+0.4,lwd=2)
    }
  }
  invisible()
}
    
######################################################################
#
# plot.info: Plot the proportion of missing information in the
#            genotype data.
#
######################################################################
plot.info <-
function(x,chr,method=c("both","entropy","variance"),...)
{
  cross <- x
  method <- match(match.arg(method),c("entropy","variance","both"))-1

  if(!missing(chr)) cross <- subset(cross,chr=chr)

  n.chr <- nchr(cross)
  results <- NULL

  if(is.na(match("prob",names(cross$geno[[1]])))) { # need to run calc.genoprob
    warning("First running calc.genoprob.")
    cross <- calc.genoprob(cross)
  }

  gap <- attr(cross$geno[[1]]$prob,"off.end")*2+10 # gap between chr in plot

  n.ind <- nind(cross)
  for(i in 1:n.chr) {
    n.gen <- dim(cross$geno[[i]]$prob)[3]
    n.pos <- ncol(cross$geno[[i]]$prob)

    # calculate information (between 0 and 1)
    info <- .C("R_info",
               as.integer(n.ind),
               as.integer(n.pos),
               as.integer(n.gen),
               as.double(cross$geno[[i]]$prob),
               info1=as.double(rep(0,n.pos)),
               info2=as.double(rep(0,n.pos)),
               as.integer(method),
               PACKAGE="qtl")

    if(method != 1) { # rescale entropy version
      if(n.gen==3) maxent <- 1.5*log(2)
      else maxent <- log(n.gen)
      info$info1 <- -info$info1/maxent
    }
    if(method != 0) { # rescale variance version
      maxvar <- c(0.25,0.5,1.25)[n.gen-1]
      info$info2 <- info$info2/maxvar
    }

    # reconstruct map
    map <- create.map(cross$geno[[i]]$map,
                      attr(cross$geno[[i]]$prob,"step"),
                      attr(cross$geno[[i]]$prob,"off.end"))
    if(is.matrix(map)) map <- map[1,]

    z <- data.frame(chr=rep(names(cross$geno)[i],length(map)),pos=map,
                    "Missing information"=info$info1,
                    "Missing information"=info$info2)
    w <- names(map)
    o <- grep("^loc\-*[0-9]+",w)
    if(length(o) > 0) # inter-marker locations cited as "c*.loc*"
      w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="")
    rownames(z) <- w
    results <- rbind(results, z)
  }

  # check whether gap was included as an argument
  args <- list(...)
  if(is.na(match("gap",names(args)))) {
    if(method==0)
      plot.scanone(results,ylim=c(0,1),gap=gap,
                   main="Missing information",...)
    else if(method==1)
      plot.scanone(results,lodcolumn=4,ylim=c(0,1),gap=gap,
                   main="Missing information",...)
    else if(method==2)
      plot.scanone(results,results,lodcolumn=3:4,ylim=c(0,1),gap=gap,
                   main="Missing information",...)
  }
  else { # gap was included in ...
    if(method==0)
      plot.scanone(results,ylim=c(0,1),
                   main="Missing information",...)
    else if(method==1)
      plot.scanone(results,lodcolumn=4,ylim=c(0,1),
                   main="Missing information",...)
    else if(method==2)
      plot.scanone(results,results,lodcolumn=3:4,ylim=c(0,1),
                   main="Missing information",...)
  }

  colnames(results)[3:4] <- c("misinfo.entropy","misinfo.variance")

  class(results) <- c("scanone","data.frame")
  invisible(results)
}


# plot phenotypes against one or more markers
plot.pxg <-
function(x, marker, pheno.col = 1, jitter = 1, infer = TRUE, 
         pch, ylab, ...) 
{
  cross <- x
  type <- class(cross)[1]

  if(missing(pch)) pch <- par("pch")
  if(missing(ylab)) ylab <-  colnames(cross$pheno)[pheno.col] 

  oldlas <- par("las")
  on.exit(par(las = oldlas))
  par(las = 1)

  # find chromosome containing the markers
  o <- sapply(cross$geno, function(a, b) !is.na(match(b, colnames(a$data))), 
              marker)
  if(length(marker)==1) o <- matrix(o,nrow=1)
  if(!all(apply(o,1,any))) {
    oo <- apply(o,1,any)
    err <- paste("Marker", marker[!oo], "not found")
    stop(err)
  }
  n.mark <- length(marker)
  o <- apply(o, 1, which)
  chr <- names(cross$geno)[o]

  cross <- subset(cross, chr)
  map <- pull.map(cross)
  pos <- NULL
  for(i in seq(length(chr))) pos[i] <- map[[chr[i]]][marker[i]]
  chrtype <- sapply(cross$geno, class)

  # if X chromosome and backcross or intercross, get sex/direction data
  if(any(chrtype == "X") && (type == "bc" || type == "f2" || 
            type == "f2ss")) 
    sexpgm <- getsex(cross)
  else sexpgm <- NULL

  # number of possible genotypes
  gen.names <- list()
  for(i in seq(length(chr)))
    gen.names[[i]] <- getgenonames(type, chrtype[i], "standard", sexpgm)
  n.gen <- sapply(gen.names, length)

  jitter <- jitter/10
  if(any(n.gen == 2)) jitter <- jitter * 0.75

  # function to determine whether genotype is fully known
  tempf <-
    function(x, type)
      {
        tmp <- is.na(x)
        if(type=="f2" || type=="f2ss") tmp[!is.na(x) & x>3] <- TRUE
        if(type=="4way") tmp[!is.na(x) & x>4] <- TRUE
        tmp
      }

  # if infer=TRUE, fill in genotype data by a single imputation
  if(infer) {
    which.missing <- tempf(cross$geno[[chr[1]]]$data[, marker[1]],type)
    if(n.mark > 1) 
      for(i in 2:n.mark)
        which.missing <- which.missing | tempf(cross$geno[[chr[i]]]$data[,marker[i]],type)
    which.missing <- as.numeric(which.missing)

    cross <- fill.geno(cross, method = "imp")
  }
  else which.missing <- rep(1,nind(cross))

  # data to plot
  x <- cross$geno[[chr[1]]]$data[, marker[1]]
  if(n.mark > 1) 
    for(i in 2:n.mark)
      x <- cbind(x, cross$geno[[chr[i]]]$data[, marker[i]])
  else x <- as.matrix(x)
  y <- cross$pheno[, pheno.col]

  if(!infer) { # replace partially informative genotypes with NAs
    if(type == "f2" || type == "f2ss") x[x > 3] <- NA
    if(type == "4way") x[x > 4] <- NA
  }

  # in case of X chromosome, recode some genotypes
  if(any(chrtype == "X") && (type == "bc" || type == "f2" || 
           type == "f2ss")) {
    ix = seq(n.mark)[chrtype == "X"]
    for(i in ix)
      x[, i] <- as.numeric(reviseXdata(type, "standard", sexpgm,
                                       geno = as.matrix(x[, i])))
  }

  # save all of the data, returned invisibly
  data <- as.data.frame(x)
  names(data) <- marker
  for(i in marker) data[[i]] <- ordered(data[[i]])
  data$pheno <- y
  data$inferred <- which.missing

  # re-code the multi-marker genotypes
  if(n.mark > 1) {
    for(i in 2:n.mark)
      x[, 1] <- n.gen[i] * (x[, 1] - 1) + x[, i]
  }
  x <- x[, 1]

  # amount of jitter 
  u <- runif(nind(cross), -jitter, jitter)
  r <- (1 - 2 * jitter)/2

  # create plot
  plot(x + u, y, xlab = "Genotype", ylab = ylab, type = "n", 
       main = "", xlim = c(1 - r + jitter, prod(n.gen) + r + 
                    jitter), xaxt = "n")

  # marker names at top
  mtext(paste(marker, collapse = "\n"), , 0.5, cex = max(2/n.mark, 
                                                 0.75))
#  mtext(paste("ch", chr, ":", round(pos,1), "cM", sep = "", collapse = "\n"), 
#        , 0.5, adj = 0, cex = max(2/n.mark, 0.75))

  abline(v = 1:prod(n.gen), col = "gray", lty = 3)

  if(length(pch) == 1) 
    pch = rep(pch, length(x))
  if(infer) {
    points((x + u)[which.missing == 1], y[which.missing == 
                     1], col = "red", pch = pch[which.missing == 1])
    points((x + u)[which.missing == 0], y[which.missing == 
                     0], pch = pch[which.missing == 0])
  }
  else points(x + u, y, pch = pch)
  sux = sort(unique(x))

  # add confidence intervals
  me <- se <- array(NA, prod(n.gen))
  me[sux] <- tapply(y, x, mean, na.rm = TRUE)
  se[sux] <- tapply(y, x, function(a) sd(a, na.rm = TRUE)/sqrt(sum(!is.na(a))))
  cols <- "blue"
  if(n.gen[n.mark] == 3) 
    cols <- c("blue", "purple", "red")
  else if(n.gen[n.mark] == 2) 
    cols <- c("blue", "red")
  segments(seq(prod(n.gen)) + jitter * 2, me, seq(prod(n.gen)) + 
           jitter * 4, me, lwd = 2, col = cols)
  segments(seq(prod(n.gen)) + jitter * 3, me - se, seq(prod(n.gen)) + 
           jitter * 3, me + se, lwd = 2, col = cols)
  segments(seq(prod(n.gen)) + jitter * 2.5, me - se, seq(prod(n.gen)) + 
           jitter * 3.5, me - se, lwd = 2, col = cols)
  segments(seq(prod(n.gen)) + jitter * 2.5, me + se, seq(prod(n.gen)) + 
           jitter * 3.5, me + se, lwd = 2, col = cols)

  # add genotypes below
  u <- par("usr")
  segments(1:prod(n.gen), u[3], 1:prod(n.gen), u[3] - diff(u[3:4]) * 
           0.015, xpd = TRUE)
  if(n.mark == 1) 
    tmp <- gen.names[[1]]
  else {
    tmp <- array(gen.names[[n.mark]], c(prod(n.gen), n.mark))
    for(i in (n.mark - 1):1) {
      tmpi <- rep(gen.names[[i]], rep(prod(n.gen[(i + 1):n.mark]), 
                                      n.gen[i]))
      if(i > 1) 
        tmpi <- rep(tmpi, prod(n.gen[1:(i - 1)]))
      tmp[, i] <- tmpi
    }
    tmp <- apply(tmp, 1, function(x) paste(x, collapse = "\n"))
  }
  text(1:prod(n.gen), u[3] - diff(u[3:4]) * 0.05, tmp, xpd = TRUE, 
       cex = max(0.5, 1.5/n.mark))

  # calculate return values?
  if(any(which.missing == 0)) 
    p.value <- anova(aov(y ~ x, subset = (which.missing == 
                                          0)))[1, 5]
  else p.value <- NA
  names(p.value) <- NULL
  tmp <- options(warn = -1)
  form <- formula(paste("y ~", paste(marker, collapse = "*")))
  if(any(is.na(me)) & n.mark > 2) {
    formadd <- formula(paste("y ~", paste(marker, collapse = "+")))
    fit <- aov(formadd, data, subset = (data$inferred == 
                                        0))
    full <- aov(form, data, subset = (data$inferred == 0))
  }
  else fit <- aov(form, data, subset = (data$inferred == 0))
  tbl <- anova(fit, type = "marginal")
  options(tmp)
  p.value <- round(tbl$P[-nrow(tbl)], 4)
  tmp = summary.lm(fit)
  Rsq = tmp$r.sq
  fstat = tmp$fstatistic
  p.value = c(pf(fstat[1], fstat[2], fstat[3], lower = FALSE), 
    p.value)
  names(p.value) <- c("overall", dimnames(tbl)[[1]][-nrow(tbl)])
  if(any(is.na(me)) & n.mark > 2) {
    p.value["inter"] <- round(anova(fit, full)$P[2], 4)
    fit = full
  }
  invisible(list(Rsq = Rsq, p.value = p.value, me = me, se = se, 
                 fit = fit, data = data))
}

# end of plot.R
######################################################################
#
# plot.scantwo.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University,
#                       Hao Wu and Brian Yandell
# last modified Sep, 2004
# first written Nov, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Hao Wu (The Jackson Lab) wrote the initial code
#
# Part of the R/qtl package
# Contains: plot.scantwo, subset.scantwo
#
######################################################################

plot.scantwo <-
function(x, chr, incl.markers = FALSE, zlim,
         lower = c("cond-int", "cond-add", "joint"), nodiag = TRUE,
         contours = FALSE, main, zscale = TRUE,
         col.scheme = c("redblue","cm","gray","heat","terrain","topo"),
         gamma = 1, ...)
{
  col.scheme <- match.arg(col.scheme)

  if(!missing(chr)) 
    x <- subset(x, chr=chr)
  chr <- as.character(unique(x$map[,1]))

  lower <- match.arg(lower)
  if(!any(class(x) == "scantwo")) 
    stop("Input variable is not an object of class scantwo!")
  lod <- x$lod
  map <- x$map

  # backward compatibility for previous version of R/qtl
  if(is.na(match("scanoneX",names(x)))) {
    warning("It would be best to re-run scantwo() with the R/qtl version 0.98 or later.")
    scanoneX <- NULL
  }
  else scanoneX <- x$scanoneX

  # deal with bad LOD score values
  if(any(is.na(lod) | lod < -1e-06 | lod == Inf)) {
    warning("Some LOD scores NA, Inf or < 0; set to 0")
    lod[is.na(lod) | lod < 0 | lod == Inf] <- 0
  }

  # if incl.markers is FALSE, drop positions
  #     for which third column of map is 0
  if(!incl.markers && any(map[, 3] == 0)) {
    o <- (map[, 3] == 1)
    lod <- lod[o, o]
    map <- map[o, ]
    if(!is.null(scanoneX)) scanoneX <- scanoneX[o,]
  }

  if(all(diag(lod) < 1e-14) && lower != "joint") 
    stop("Need to run scantwo with run.scanone=TRUE.")

  # pull out single-QTL LODs
  if(lower=="cond-int" || lower=="cond-add") {
    d <- diag(lod)
    q1 <- matrix(rep(d,length(d)),ncol=length(d))
    q2 <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE)
    if(!is.null(scanoneX) && any(map[,4])) {
      d <- scanoneX
      q1X <- matrix(rep(d,length(d)),ncol=length(d))
      q2X <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE)
      q1[map[,4],] <- q1X[map[,4],]
      q2[,map[,4]] <- q2X[,map[,4]]
    }
    q1[q2>q1] <- q2[q2>q1]
  }

  # replace joint LOD with LOD[q1,q2] - max{LOD[q1],LOD[q2]}
  if(lower == "cond-int") {
    lod[lower.tri(lod)] <- lod[lower.tri(lod)] - q1[lower.tri(lod)]
  }
  else if(lower == "cond-add") {
    lod[lower.tri(lod)] <- lod[lower.tri(lod)]-t(lod)[lower.tri(lod)]-q1[lower.tri(lod)]
  }

  if(nodiag) diag(lod) <- 0

  if(missing(zlim)) { # no given zlim
    # calculate the zlim for interactive and joint
    zlim.int <- max(lod[row(lod) < col(lod)])
    zlim.jnt <- max(lod[row(lod) >= col(lod)])
  }
  else {
    zlim.int <- zlim[2]
    zlim.jnt <- zlim[1]
  }

  # rescale the data in upper triangle based on zlims.jnt
  lod[row(lod) < col(lod)] <- lod[row(lod) < col(lod)] * zlim.jnt/zlim.int
  if(missing(zlim)) 
    zlim.jnt <- max(lod)

  # make sure LOD values are below (0,zlim.jnt) or update zlim.jnt
  if(max(lod) > zlim.jnt) {
    warning("LOD values out of range; updating zlim.")
    temp <- max(lod)
    zlim.int <- zlim.int * temp/zlim.jnt
    zlim.jnt <- temp
  }

  # save old par parameters, to restore them on exit
  old.mar <- par("mar")
  old.las <- par("las")
  old.mfrow <- par("mfrow")
  on.exit(par(las = old.las, mar = old.mar, mfrow = old.mfrow))
  par(las = 1)
  if(zscale) {
    layout(cbind(1, 2), c(6, 1))
    par(mar = c(5, 4, 4, 2) + 0.1)
  }
  if( gamma < 0 && col.scheme == "redblue")
    stop( "gamma must be non-negative" )
  cols <- switch(col.scheme,
                 gray = if( gamma <= 0) rev(gray(seq(0,1,len=256)))
                   else rev(gray(log(seq(1,exp(gamma),len=256))/gamma)),
                 heat = heat.colors(256),
                 terrain = terrain.colors(256),
                 topo = topo.colors(256),
                 cm = cm.colors(256),
                 redblue = rev(rainbow(256, start = 0, end = 2/3,gamma=gamma)))

  image(1:ncol(lod), 1:nrow(lod), lod, ylab = "Chromosome", 
        xlab = "Chromosome", zlim = c(0, zlim.jnt), col = cols,
        xaxt = "n", yaxt = "n")

  # add contours if requested
  if(any(contours) > 0) {
    if(is.logical(contours))
      contours = 1.5
    tmp = lod
    tmp[row(lod) < col(lod)] <- NA
    contour(1:ncol(lod), 1:nrow(lod), tmp, add = TRUE,drawlabels=FALSE,
            levels = max(tmp,na.rm=TRUE) - contours, col = "blue", lwd = 2)
    tmp = lod
    tmp[row(lod) > col(lod)] <- NA
    contour(1:ncol(lod), 1:nrow(lod), tmp, add = TRUE,drawlabels=FALSE,
            levels = max(tmp,na.rm=TRUE) - contours * zlim.jnt/zlim.int,
            col = "blue", lwd = 2)
  }

  # calculate how many markers in each chromesome
  n.mar <- NULL
  for(i in 1:length(chr)) n.mar[i] <- sum(map[, 1] == chr[i])

  # plot lines at the chromosome boundaries
  wh <- c(0.5, cumsum(n.mar) + 0.5)
  abline(v = wh, xpd = FALSE)
  abline(h = wh, xpd = FALSE)

  # add chromesome numbers
  a <- par("usr")
  for(i in 1:length(n.mar)) {
    text(mean(wh[i + c(0, 1)]), a[3] - diff(a[3:4]) * 0.025, 
         chr[i], xpd = TRUE, adj = c(0.5, 1))
    segments(mean(wh[i + c(0, 1)]), a[3],
             mean(wh[i + c(0, 1)]), a[3] - diff(a[3:4]) * 0.01, xpd = TRUE)
    text(a[1] - diff(a[1:2]) * 0.025, mean(wh[i + c(0, 1)]), 
         chr[i], xpd = TRUE, adj = c(1, 0.5))
    segments(a[1], mean(wh[i + c(0, 1)]), a[1] - diff(a[1:2]) * 
             0.01, mean(wh[i + c(0, 1)]), xpd = TRUE)
  }

  # add title
  if(!missing(main)) 
    title(main = main)

  if(zscale) {
    # plot the colormap
    par(mar = c(5, 2, 4, 2) + 0.1)
    colorstep <- zlim.jnt/255
    image(x = 1:1, y = seq(0, zlim.jnt, colorstep), z = matrix(c(1:256), 1, 256),
          zlim = c(1, 256), ylab = "", xlab = "", 
          xaxt = "n", yaxt = "n", col = cols)

    # make sure there's a box around it
    u <- par("usr")
    abline(v = u[1:2], xpd = FALSE)
    abline(h = u[3:4], xpd = FALSE)
    if(any(contours) > 0) {
      for(i in seq(length(contours))) {
        segments(mean(u[1:2]),
                 max(lod[row(lod) > col(lod)]) - contours[i],
                 u[2], max(lod[row(lod) > col(lod)]) - contours[i], 
                 xpd = FALSE, col = "blue", lwd = 2)
        segments(u[1], max(lod[row(lod) < col(lod)]) - contours[i] * 
                 zlim.jnt/zlim.int, mean(u[1:2]),
                 max(lod[row(lod) < col(lod)]) - contours[i] * zlim.jnt / zlim.int,
                 xpd = FALSE, col = "blue", lwd = 2)
      }
    }

    # figure out how big the axis labels should be
    fin <- par("fin")[1] # figure width in inches
    pin <- par("pin")[1] # plot width in inches
    mai <- par("mai")[2] # margin width in inches
                         # note: pin + 2*mai = fin
    xlen.mar <- mai/pin * diff(u[1:2])

    # axis for joint LODs
    yloc <- pretty(c(0, zlim.jnt), 4)
    yloc <- yloc[yloc <= u[4]]
    segments(u[2], yloc, u[2] + xlen.mar/4, yloc, xpd = TRUE)
    text(u[2] + xlen.mar/3, yloc, as.character(yloc), xpd = TRUE, adj = 0)

    # axis for int've LODs
    yloc <- pretty(c(0, zlim.int), 4)
    yloc.rev <- yloc * zlim.jnt/zlim.int
    yloc <- yloc[yloc.rev <= u[4]]
    yloc.rev <- yloc.rev[yloc.rev <= u[4]]
    segments(u[1], yloc.rev, u[1] - xlen.mar/4, yloc.rev, xpd = TRUE)
    text(u[1] - xlen.mar/3, yloc.rev, as.character(yloc), xpd = TRUE, adj = 1)
  }
}

######################################################################
#
# subset.scantwo
#
######################################################################

#subset.scantwo <-
#function(x, chr, ...)   
#{
#  if(missing(chr) || length(chr) == 0) return(x)
#
#  a <- unique(x$map[,1])
#  if(is.numeric(chr) && all(chr < 0)) 
#    chr <- a[chr]
#  else chr <- a[match(chr,a)]
#
#  newgroups <- groups <- vector("list",length(chr))
#  curmax <- 0
#  for(i in 1:length(chr)) {
#    groups[[i]] <- which(x$map[,1]==chr[i])
#    newgroups[[i]] <- 1:length(groups[[i]]) + curmax
#    curmax <- curmax + length(groups[[i]])
#  }
#
#  g <- unlist(groups)
#  x$map <- x$map[g,]
#
#  lod <- matrix(ncol=length(g),nrow=length(g))
#  for(i in 1:length(chr)) {
#    lod[newgroups[[i]],newgroups[[i]]] <- x$lod[groups[[i]],groups[[i]]]
#    if(i < length(chr))
#      for(j in (i+1):length(chr)) {
#        if(groups[[i]][1] < groups[[j]][2]) {
#          lod[newgroups[[i]],newgroups[[j]]] <- x$lod[groups[[i]],groups[[j]]]
#          lod[newgroups[[j]],newgroups[[i]]] <- x$lod[groups[[j]],groups[[i]]]
#        }
#        else {
#          lod[newgroups[[j]],newgroups[[i]]] <- t(x$lod[groups[[i]],groups[[j]]])
#          lod[newgroups[[i]],newgroups[[j]]] <- t(x$lod[groups[[j]],groups[[i]]])
#        }
#      }
#  }
#  x$lod <- lod
#  x
#}

subset.scantwo <-
function(x, chr, ...)
{
  if(missing(chr) || length(chr)==0) return(x)

  a <- unique(x$map[,1])
  if(is.numeric(chr) && all(chr < 0)) 
    chr <- a[chr]
  else chr <- a[match(chr,a)]

  wh <- !is.na(match(x$map[,1],chr))

  if(length(wh) == 0) return(x)

  x$map <- x$map[wh,]
  x$lod <- x$lod[wh,wh]
  if(!is.null(x$scanoneX))
    x$scanoneX <- x$scanoneX[wh]

  x
}


# end of plot.scantwo.R
#####################################################################
#
# qtlcart_io.R
#
# copyright (c) 2002-4, Brian S. Yandell
#          [with some modifications by Karl W. Broman and Hao Wu]
# last modified Sep, 2004
# first written Jun, 2002
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.qtlcart, read.cro.qtlcart, read.map.qtlcart,
#           write.cross.qtlcart
#           [See read.cross.R for the main read.cross function, and
#            write.cross.R for the main write.cross function.]
#
##############################################################################

######################################################################
# read.cross.qtlcart
#
# read QTL cross object in QTL cartographer format
######################################################################
read.cross.qtlcart <-
function (dir, crofile, mapfile)
{
    if (missing(mapfile)) stop("Missing mapfile.")
    if (missing(crofile)) stop("Missing crofile.")

    if(!missing(dir) && dir != "") {
      mapfile <- file.path(dir, mapfile)
      crofile <- file.path(dir, crofile)
    }
    map <- read.map.qtlcart( mapfile )
    cro <- read.cro.qtlcart( crofile )

    cat(" --Read the following data:\n")
    cat("       Type of cross:         ", cro$cross, "\n")
    cat("       Number of individuals: ", nrow( cro$markers ), "\n")
    cat("       Number of markers:     ", ncol( cro$markers ), "\n")
    cat("       Number of phenotypes:  ", ncol( cro$traits ), "\n")

    maplen <- unlist(lapply(map,length))
    markers <- split( as.data.frame( t( cro$markers )),
                     ordered( rep(names( maplen ), maplen )))

    Geno <- list()
    for( i in names( map )) {
      name.markers <- names( map[[i]] )
      markers[[i]] <- t( markers[[i]] )
      colnames( markers[[i]] ) <- name.markers
      tmp <- list( data = markers[[i]], map = map[[i]] )

      # determine whether autosomal chromosome or X chromosome
      #     using the chromosome name
      class(tmp) <- ifelse(length(grep("[Xx]", i)), "X", "A")
      Geno[[i]] <- tmp
    }
    cross <- list(geno = Geno, pheno = cro$traits )
    class(cross) <- c( cro$cross, "cross")

    cross$pheno <- as.data.frame(cross$pheno)

    list(cross,FALSE)
}

######################################################################
# read.map.qtlcart
#
# read QTL Cartographer map file
######################################################################
read.map.qtlcart <-
function (file) 
{
  # only interested in chromosomes, marker IDs and positions
  f <- scan(file, what = "", blank.lines.skip = FALSE, sep = "\n", 
            quiet = TRUE)
  ctrl <- seq(f)[substring(f, 1, 1) == "-"]
  getvalue <- function(s, f, ctrl) {
    tmp <- unlist(strsplit(f[ctrl[substring(f[ctrl], 2, 3) == 
                                  s]], " "))
    as.numeric(tmp["" != tmp][2])
  }
  nchrom <- getvalue("c ", f, ctrl)
  nmarkers <- getvalue("i ", f, ctrl)

  # marker positions
  tmp <- range(seq(f)[substring(f, 1, 3) == "-l "])
  s <- strsplit(f[tmp[1]], "")[[1]]
  b <- grep("|", s, extended = FALSE)
  s <- grep("0", s)
  s <- ceiling((s[length(s)] - b - 1)/nchrom)
  position <- as.matrix(read.fwf(file, c(1 + b, rep(s, nchrom)), 
                                 skip = tmp[1] - 1, n = tmp[2])[, -1])
  tmp <- grep("-b", f)
  markers <- scan(file, list(1, 2, ""), skip = tmp[1], nlines = nmarkers, 
                  blank.lines.skip = FALSE, quiet = TRUE)
  chroms <- scan(file, list(1, ""), skip = tmp[2], nlines = nchrom, 
                 blank.lines.skip = FALSE, quiet = TRUE)[[2]]
  map <- list()
  for (i in seq(nchrom)) {
    tmp <- cumsum(position[!is.na(position[, i]), i])
    tmp <- tmp[-length(tmp)]
    names(tmp) <- markers[[3]][i == markers[[1]]]
    map[[chroms[i]]] <- tmp
  }
  map
}

######################################################################
# read.cro.qtlcart
# 
# read QTL cartographer CRO file
######################################################################
read.cro.qtlcart <-
function (file) 
{
  # translation from cro to R/qtl (see read.cross)
  # -1	NA	missing data
  #  0	1	AA
  #  1	2	AB
  #  2	3	BB
  # 10	4	AA or AB
  # 12	5	AB or BB
  #
  f <- scan(file, what = "", blank.lines.skip = FALSE, sep = "\n", 
            quiet = TRUE)
  ctrl <- seq(f)[substring(f, 1, 1) == "-"]
  s <- strsplit(f[ctrl], " ")
  ns <- character(length(ctrl))
  for (i in seq(ctrl)) {
    ns[i] <- substring(s[[i]][1], 2)
    s[[i]] <- s[[i]]["" != s[[i]]][-1]
  }
  names(s) <- ns
  size <- as.numeric(s$n[1])
  nmarkers <- as.numeric(s$p[1]) - 1
  ntraits <- as.numeric(s$traits[1])

  # cross type
  fix.bc1 <- fix.ridh <- FALSE # indicator of whether to fix genotypes
  cross <- s$cross[1]
  if (cross == "RI1") {
    cross <- "riself"
    fix.ridh <- TRUE
  }
  else if (cross == "RI2") {
    cross <- "risib"
    fix.ridh <- TRUE
  }
  else if (cross == "RI0") { 
    cross <- "bc" # doubled haploid
    fix.ridh <- TRUE
  }
  else if (cross == "B1" || cross == "B2") {
    fix.bc1 = cross == "B1"
    cross <- "bc"
  }
  else if (cross == "SF2" || cross == "RF2") 
    cross <- "f2"
  else if (cross != "f2" && cross != "bc" && cross != "f2ss" && 
           cross != "risib" && cross != "riself" && cross != "4way") {
    err <- paste("Cross type", cross, "not supported.")
    stop(err)
  }
  notraits <- as.numeric(s$otraits[1])
  skip <- ctrl["s" == ns]
  nlines <- ctrl["e" == ns] - skip - 1
  trait.names <- f[ctrl["Names" == ns][1] + 1:ntraits]
  if(notraits)
    trait.names <- c(trait.names, f[ctrl["Names" == ns][2] + 1:notraits] )
  ns <- strsplit(trait.names, " ")
  for (i in seq(ns)) ns[[i]] <- ns[[i]][length(ns[[i]])]
  trait.names <- unlist(ns)
  # kludge to handle factor phenos 
  f <- matrix(scan(file, "", skip = skip, nlines = nlines, na.strings = ".", 
                   blank.lines.skip = FALSE, quiet = TRUE), ncol = size)
  traits <- t(f[-(1:(2 + nmarkers)), ])
  traits = as.data.frame(traits)
  if (nrow(traits) == 1) 
    traits <- as.data.frame(t(traits))
  colnames(traits) <- trait.names

  tmp = options(warn=-1)
  for(i in names(traits)){
    tmp1 = as.numeric(as.character(traits[[i]]))
    if(!all(is.na(tmp1))) traits[[i]] = tmp1
  }
  options(tmp)
  f <- t(f[3:(2 + nmarkers), ])

  # here is the translation
  f = array(as.numeric(f),dim(f))
  f[!is.na(f)] <- c(NA, 1:3, rep(NA, 7), 4, NA, 5)[2 + f[!is.na(f)]]
  if (fix.ridh && all(is.na(f) || f == 1 || f == 3)) 
    f[!is.na(f) & f == 3] <- 2
  if (fix.bc1) { 
    f[!is.na(f) & f == 5] <- NA
    f[!is.na(f) & f == 2] <- 1
    f[!is.na(f) & f == 3] <- 2
  }
  list(traits = traits, markers = f, cross = cross)
}


######################################################################
# write.cross.qtlcart
#
# write a QTL cross object to files in QTL Cartographer format
######################################################################
write.cross.qtlcart <-
function( cross, filestem="data")
{
  n.ind <- nind(cross)
  tot.mar <- totmar(cross)
  n.phe <- nphe(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)

  type <- class(cross)[1]
  if(type=="bc") type <- "B1"
  else if(type=="f2" || type=="f2ss") type <- "RF2"
  else if(type=="riself") type <- "RI1"
  else if(type=="risib") type <- "RI2"
  else {
    warn <- paste("Cross type", type, "may not work with QTL Cartographer.")
    warning(warn)
  }

  # write genotype and phenotype data
  file <- paste(filestem, ".cro", sep="")
  if( file.exists( file )) {
    warning( paste( "previous file", file, "moved to *.mov" ))
    file.rename( file, paste( file, "mov", sep = "." ))
  }
  write("#  123456789 -filetype Rcross.out", file, append=FALSE)

  # write numbers of progeny, markers and phenotypes
  write( paste( "-n   ", n.ind ), file, append=TRUE)
  write( paste( "-p   ", 1 + tot.mar ), file, append=TRUE)
  # write experiment type
  write( paste( "-cross", type ), file, append=TRUE)

  # write numbers of progeny, markers and phenotypes
  write( paste( "-traits   ", n.phe ), file, append=TRUE)
  write( "-Names of traits...", file, append=TRUE)
  phe <- names( cross$pheno )
  for( i in seq( phe ))
    write( paste( i, phe[i] ), file, append=TRUE)
  write( paste( "-otraits   ", 0 ), file, append=TRUE)

  # write genotype and phenotype data by individual
  write( "-s", file, append=TRUE)
  for( ind in 1:n.ind ) {
    write( paste( ind, 1 ), file, append=TRUE)
    for(i in 1:n.chr) {
      g <- unlist( cross$geno[[i]]$data[ind,] )
      g[ is.na( g ) ] <- 0
      g <- c(-1,0,1,2,10,12)[ 1 + g ]

      if( length( g ) <= 40)
        write(paste( "      ", paste( g, collapse = " " )), file, append=TRUE)
      else {
        lo <- seq( 1, length(g), by=40)
        hi <- c( lo[-1]-1, length( g ))
        for(k in seq(along=lo)) {
          write( paste( "      ", paste( g[lo[k]:hi[k]], collapse = " " )),
                file, append=TRUE)
        }
      }
    } # end writing marker data
    p <- c( cross$pheno[ind,])
    tmp <- format( p )
    tmp[ is.na( p ) ] <- "."
    write( paste( "       ", tmp ), file, append = TRUE )
    # end of writing phenotype data
  }
  write( "-e", file, append = TRUE )
  write( "-q", file, append = TRUE )

  # make "prep" file with map information
  file <- paste(filestem, ".map", sep="")
  if( file.exists( file )) {
    warning( paste( "previous file", file, "moved to *.mov" ))
    file.rename( file, paste( file, "mov", sep = "." ))
  }
  write("#  123456789 -filetype Rmap.out", file, append=FALSE)

  # write numbers of progeny, markers and phenotypes
  write( "-s", file, append=TRUE)
  write( "-f 1", file, append=TRUE)
  write( "-p 0.0000", file, append=TRUE)
  write( "-u c", file, append=TRUE)
  write( "#", file, append=TRUE)

  write( paste( "-c", n.chr ), file, append=TRUE)
  write( paste( "-i", tot.mar ), file, append=TRUE)

  map <- lapply( cross$geno, function( x ) x$map )
  maplen <- unlist( lapply( map, length ))

  # mean and SD of number of markers
  write( paste( "-m", round( mean( maplen ), 3 )), file, append=TRUE)
  write( paste( "-vm", round( sqrt( var( maplen )), 3 )), file, append=TRUE)

  mapdif <- lapply( map, diff )
  # mean and SD of intermarker distances
  write( paste( "-d", round( mean( unlist( mapdif )), 3 )), file, append=TRUE)
  write( paste( "-vd", round( sqrt( var( unlist( mapdif ))), 3 )), file, append=TRUE)
  write( "-t 0.0000", file, append=TRUE)
  write( "#", file, append=TRUE)
  write( "          |   Chromosome----> ", file, append=TRUE)
  write( "--------------------------------------", file, append=TRUE)
  mapmat <- matrix( NA, 1 + max( maplen ), n.chr )
  mapmat[ 1, ] <- 0
  for( i in seq( along = maplen )) {
    tmp <- c( mapdif[[i]],0)
    mapmat[1 + seq( along = tmp ), i ] <- tmp
  }
  mapmat <- format( mapmat )
  ncmap <- nchar( mapmat[1] )
  mapmat[ grep( "NA", mapmat ) ] <- paste( rep( " ", ncmap ), collapse = "" )
  tmp <- format( seq( n.chr ))
  write( paste( "Marker    | ",
               paste( tmp, collapse =
                     paste( rep( " ", max( 1, ncmap - nchar( tmp ))), collapse = "" ))),
        file, append=TRUE)
  write( "--------------------------------------", file, append=TRUE)
  for( i in seq( nrow( mapmat )))
    write( paste( "-l     ", i - 1, "|",
                 paste( mapmat[i,], collapse = " " )),
          file, append=TRUE)

  write( "---------------------------------------", file, append=TRUE)
  write( paste( "-Number   |", paste( maplen, collapse = "  " )),
        file, append=TRUE)

  write( "Names and positions of the markers", file, append=TRUE)
  write( "Chrom  Mark  Name", file, append=TRUE)
  write( "-b MarkerNames", file, append=TRUE)
  for( i in 1:n.chr )
    for( j in seq( along = map[[i]] ))
      write( paste( i, j, names( map[[i]] )[j] ), file, append=TRUE)
  write( "-e MarkerNames", file, append=TRUE)
  write( "Names of the Chromosomes", file, append=TRUE)
  write( "-b ChromosomeNames", file, append=TRUE)
  for( i in 1:n.chr )
    write( paste( i, names( map )[i] ), file, append=TRUE)
  write( "-e ChromosomeNames", file, append=TRUE)
}

# end of qtlcart_io.R
######################################################################
#
# read.cross.R
#
# copyright (c) 2000-3, Karl W Broman, Johns Hopkins University
# last modified Nov, 2003
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross, fixXgeno.bc, fixXgeno.f2
#           [See read.cross.csv.R, read.cross.mm.R, read.cross.qtx.R,
#            qtlcart_io.R, read.cross.gary.R, and read.cross.karl.R
#            for the format-specific functions.]
#
######################################################################

######################################################################
#
# read.cross: read data from an experimental cross
#
######################################################################

read.cross <-
function(format=c("csv","mm","qtx","qtlcart","gary","karl"), dir="",
         file, genfile, mapfile, phefile, chridfile, mnamesfile, pnamesfile,
         na.strings=c("-","NA"), genotypes=c("A","H","B","D","C"),
         estimate.map=TRUE, convertXdata=TRUE, ...)
{
  format <- match.arg(format)

  if(format=="csv") { # comma-delimited format
    cross <- read.cross.csv(dir,file,na.strings,genotypes,
                            estimate.map,...)
  }
  else if(format=="qtx") { # Mapmanager QTX format
    cross <- read.cross.qtx(dir,file,estimate.map)
  }
  else if(format=="qtlcart") { # QTL Cartographer format
    # if missing mapfile but genfile is specified,
    #     use genfile as the map file.
    if(missing(mapfile) && !missing(genfile))
      mapfile <- genfile

    cross <- read.cross.qtlcart(dir, file, mapfile)
  }
  else if(format=="karl") { # karl's format
    # if missing file names, use standard ones
    if(missing(genfile)) genfile <- "gen.txt"
    if(missing(mapfile)) mapfile <- "map.txt"
    if(missing(phefile)) phefile <- "phe.txt"

    cross <- read.cross.karl(dir,genfile,mapfile,phefile)
  }
  else if(format=="mm") { # mapmaker format
    # if missing mapfile but genfile is specified,
    #     use genfile as the map file.
    if(missing(mapfile) && !missing(genfile))
      mapfile <- genfile

    cross <- read.cross.mm(dir,file,mapfile,estimate.map)
  }
  else if(format=="gary") { # gary's format
    # if missing file names, use the standard ones
    if(missing(genfile)) genfile <- "geno.dat"
    if(missing(mnamesfile)) mnamesfile <- "mnames.txt"
    if(missing(chridfile)) chridfile <- "chrid.dat"
    if(missing(phefile)) phefile <- "pheno.dat"
    if(missing(pnamesfile)) pnamesfile <- "pnames.txt"
    if(missing(mapfile)) mapfile <- "markerpos.txt"

    cross <- read.cross.gary(dir,genfile,mnamesfile,chridfile,
                             phefile,pnamesfile,mapfile,estimate.map,na.strings)
  }

  estimate.map <- cross[[2]]
  cross <- cross[[1]]

  # if chr names all start with "chr" or "Chr", remove that part
  chrnam <- names(cross$geno)
  if(all(regexpr("^[Cc][Hh][Rr]",chrnam)>0)){ 
    chrnam <- substr(chrnam,4,nchar(chrnam))
    if(all(regexpr("^[Oo][Mm][Oo][Ss][Oo][Mm][Ee]",chrnam)>0))
      chrnam <- substr(chrnam,8,nchar(chrnam))
  }
  # if chr named "x" make it "X"
  if(sum(chrnam=="x")>0) chrnam[chrnam=="x"] <- "X"
  names(cross$geno) <- chrnam
  # make sure the class of chromosomes named "X" is "X"
    for(i in 1:length(cross$geno)) 
      if(names(cross$geno)[i] == "X")
        class(cross$geno[[i]]) <- "X"

  # Fix up the X chromosome data for a backcross or intercross
  chrtype <- sapply(cross$geno,class)
  if(any(chrtype=="X") && convertXdata) {
    if(class(cross)[1]=="bc")
      cross <- fixXgeno.bc(cross)
    if(class(cross)[1]=="f2")
      cross <- fixXgeno.f2(cross)
  }

  # re-estimate map?
  if(estimate.map) {
    cat(" --Estimating genetic map\n")
    newmap <- est.map(cross)
    cross <- replace.map(cross, newmap)
  }

  # store genotype data as integers
  for(i in 1:nchr(cross))
    storage.mode(cross$geno[[i]]$data) <- "integer"

  # run checks
  summary(cross)

  cross
}




##############################
# fixXgeno.bc: fix up the X chromosome genotype data for backcross
##############################
fixXgeno.bc <-
function(cross)
{
  omitX <- FALSE

  # pull out X chr genotype data
  chrtype <- sapply(cross$geno,class)
  xchr <- which(chrtype=="X")
  Xgeno <- cross$geno[[xchr]]$data

  # find "sex" and "pgm" in the phenotype data
  sexpgm <- getsex(cross)

  if(!is.null(sexpgm$sex)) {     # "sex" is provided
    malegeno <- Xgeno[sexpgm$sex==1,]
    if(any(!is.na(malegeno) & malegeno==2)) {
      n.omit <- sum(!is.na(malegeno) & malegeno==2)
      warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.")
      malegeno[!is.na(malegeno) & malegeno==2] <- NA
    }
    malegeno[!is.na(malegeno) & malegeno==3] <- 2
    
    femalegeno <- Xgeno[sexpgm$sex==0,]
    if(any(!is.na(femalegeno) & femalegeno==3)) {
      n.omit <- sum(!is.na(femalegeno) & femalegeno==3)
      warning(" --Omitting ", n.omit, " BB genotypes from females on the X chromosome.")
      femalegeno[!is.na(femalegeno) & femalegeno==3] <- NA
    }

    Xgeno[sexpgm$sex==1,] <- malegeno
    Xgeno[sexpgm$sex==0,] <- femalegeno
    
  }
  else {
    # "sex" not provided

    if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males
      warning(" --Assuming that all individuals are male.\n")
      Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2
      cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m"))
    }
    else if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==2)) { # look like females A:H
      warning(" --Assuming that all individuals are female.\n")
      cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m"))
    }
    else { # have some of each of the three genotypes
      warning(" --Can't figure out the X chromosome genotypes.\n   You need to provide phenotypes \"sex\"\n   See the help file for read.cross() for details.\n   Omitting the X chr for now.\n  ")
      omitX <- TRUE
    }
  }

  if(!omitX) {
    wh <- !is.na(Xgeno) & Xgeno!=1 & Xgeno!=2
    if(any(wh)) {
      Xgeno[wh] <- NA
      n.omit <- sum(wh)
      warning(" --Omitted ", n.omit, " additional X chr genotype(s).")
    }

    cross$geno[[xchr]]$data <- Xgeno
  }
  else cross <- subset(cross,chr= -xchr) # <- omit the X chr completely

  cross
}


##############################
# fixXgeno.f2: fix up the X chromosome genotype data for intercross
##############################
fixXgeno.f2 <-
function(cross)
{
  omitX <- FALSE

  # pull out X chr genotype data
  chrtype <- sapply(cross$geno,class)
  xchr <- which(chrtype=="X")
  Xgeno <- cross$geno[[xchr]]$data

  # find "sex" and "pgm" in the phenotype data
  sexpgm <- getsex(cross)

  if(!is.null(sexpgm$sex) && !is.null(sexpgm$pgm)) {
    # both "sex" and "pgm" are provided

    if(any(sexpgm$sex == 1)) { # there are males
      malegeno <- Xgeno[sexpgm$sex==1,]
      if(any(!is.na(malegeno) & malegeno==2)) {
        n.omit <- sum(!is.na(malegeno) & malegeno==2)
        warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.")
        malegeno[!is.na(malegeno) & malegeno==2] <- NA
      }
      malegeno[!is.na(malegeno) & malegeno==3] <- 2
      Xgeno[sexpgm$sex==1,] <- malegeno
    }
    
    if(any(sexpgm$sex==0)) { # there are females
      femalegeno0 <- Xgeno[sexpgm$sex==0 & sexpgm$pgm==0,]
      femalegeno1 <- Xgeno[sexpgm$sex==0 & sexpgm$pgm==1,]

      if(any(!is.na(femalegeno0) & femalegeno0==3) &&
         !(any(!is.na(femalegeno1) & femalegeno1==3))) {
                                          # appear to switched the "pgm" values
        warning(" --The 0/1 values for \"pgm\" appear to be switched; switching back.")
        sexpgm$pgm[sexpgm$pgm==1] <- 2
        sexpgm$pgm[sexpgm$pgm==0] <- 1
        sexpgm$pgm[sexpgm$pgm==2] <- 0
        temp <- femalegeno0
        femalegeno0 <- femalegeno1
        femalegeno1 <- femalegeno0
      }
      if(any(!is.na(femalegeno0) & femalegeno0==3)) {
        n.omit <- sum(!is.na(femalegeno0) & femalegeno0==3)
        warning(" --Omitting ", n.omit, " BB genotypes from females from cross (AxB)x(AxB) on the X chr.\n")
        femalegeno0[!is.na(femalegeno0) & femalegeno0==3] <- NA
      }
      if(any(!is.na(femalegeno1) & femalegeno1==1)) {
        n.omit <- sum(!is.na(femalegeno1) & femalegeno1==1)
        warning(" --Omitting ", n.omit, " AA genotypes from females from cross (BxA)x(BxA) on the X chr.\n")
        femalegeno1[!is.na(femalegeno1) & femalegeno1==1] <- NA
      }
      femalegeno1[!is.na(femalegeno1) & femalegeno1==3] <- 1
      Xgeno[sexpgm$sex==0 & sexpgm$pgm==0,] <- femalegeno0
      Xgeno[sexpgm$sex==0 & sexpgm$pgm==1,] <- femalegeno1
    }
    
  }

  else if(!is.null(sexpgm$sex) && is.null(sexpgm$pgm)) {
    # "sex" is provided but not "pgm"

    if(any(sexpgm$sex == 1)) { # there are males
      malegeno <- Xgeno[sexpgm$sex==1,]
      if(any(!is.na(malegeno) & malegeno==2)) {
        n.omit <- sum(!is.na(malegeno) & malegeno==2)
        warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.")
        malegeno[!is.na(malegeno) & malegeno==2] <- NA
      }
      malegeno[!is.na(malegeno) & malegeno==3] <- 2
      Xgeno[sexpgm$sex==1,] <- malegeno
    }
    
    if(any(sexpgm$sex==0)) { # there are females
      femalegeno <- Xgeno[sexpgm$sex==0,]

      if(any(!is.na(femalegeno) & femalegeno==3) &
         !any(!is.na(femalegeno) & femalegeno==1)) { # looks like (BxA)x(BxA)
        cross$pheno$pgm <- rep(1,nind(cross))
        femalegeno[!is.na(femalegeno) & femalegeno==3] <- 1
      }
      else if(any(!is.na(femalegeno) & femalegeno==1) &
              !any(!is.na(femalegeno) & femalegeno==3)) { # looks like (AxB)x(AxB)
        cross$pheno$pgm <- rep(0,nind(cross))
      }
      else { # we have some 1's and some 3's
        warning(" --There appear to be some individuals of each cross direction, but \"pgm\" is not provided.\n   Check the X chr genotype data and include a \"pgm\" column in the phenotype data.\n   \"pgm\" was inferred (probably poorly).\n   ")

        cross$pheno$pgm <- rep(0,nind(cross))

        # females with no 3's -> assumed to be from (AxB)x(AxB)
        # females with both 3's and 1's -> assumed to be from (AxB)x(AxB); 3's tossed
        wh.have3 <- apply(femalegeno, 1, function(a) any(!is.na(a) & a==3))
        cross$pheno$pgm[sexpgm$sex==0][wh.have3] <- 1

        temp <- femalegeno[wh.have3,]
        temp[!is.na(temp) & temp==1] <- NA
        temp[!is.na(temp) & temp==3] <- 1
        femalegeno[wh.have3,] <- temp

      }

      Xgeno[sexpgm$sex==0,] <- femalegeno
    }
  }
  else if(is.null(sexpgm$sex) && !is.null(sexpgm$pgm)) {
    # "pgm" is provided but not "sex"

    if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males
      cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m"))
      Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2
    }
    else { # assume all females
      cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m"))
      Xgeno.pgm0 <- Xgeno[sexpgm$pgm==0,]
      Xgeno.pgm1 <- Xgeno[sexpgm$pgm==1,]
      if(all(is.na(Xgeno.pgm0) | Xgeno.pgm0==2 | Xgeno.pgm0==3) &&
         all(is.na(Xgeno.pgm1) | Xgeno.pgm1==1 | Xgeno.pgm1==2)) {
        cross$pheno$pgm <- 1 - sexpgm$pgm
        temp <- Xgeno.pgm0
        Xgeno.pgm0 <- Xgeno.pgm1
        Xgeno.pgm1 <- temp
      }
      Xgeno.pgm1[!is.na(Xgeno.pgm1) & Xgeno.pgm1==1] <- NA
      Xgeno.pgm1[!is.na(Xgeno.pgm1) & Xgeno.pgm1==3] <- 1
      Xgeno.pgm0[!is.na(Xgeno.pgm0) & Xgeno.pgm0==3] <- NA
      Xgeno[sexpgm$pgm==0,] <- Xgeno.pgm0
      Xgeno[sexpgm$pgm==1,] <- Xgeno.pgm1
    }
  }
  

  else {
    # Neither "sex" and "pgm" provided

    if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males
      warning(" --Assuming that all individuals are male.\n")
      Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2
      cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m"))
      cross$pheno$pgm <- rep(0,nind(cross))
    }
    else if(all(is.na(Xgeno) | Xgeno==2 | Xgeno==3)) { # look like females H:B
      warning(" --Assuming that all individuals are female.\n")
      Xgeno[!is.na(Xgeno) & Xgeno==3] <- 1
      cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m"))
      cross$pheno$pgm <- rep(1,nind(cross))
    }
    else if(all(is.na(Xgeno) | Xgeno==2 | Xgeno==1)) { # looks like females A:H
      warning(" --Assuming that all individuals are female.\n")
      cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m"))
      cross$pheno$pgm <- rep(0,nind(cross))
    }
    else { # have some of each of the three genotypes
      warning(" --Can't figure out the X chromosome genotypes.\n   You need to provide phenotypes \"sex\" and/or \"pgm\"\n   See the help file for read.cross() for details.\n   Omitting the X chr for now.\n  ")

      omitX <- TRUE

    }
  }


  if(!omitX) {
    wh <- !is.na(Xgeno) & Xgeno!=1 & Xgeno!=2
    if(any(wh)) {
      Xgeno[wh] <- NA
      n.omit <- sum(wh)
      warning(" --Omitted ", n.omit, " additional X chr genotype(s).")
    }

    cross$geno[[xchr]]$data <- Xgeno
  }
  else cross <- subset(cross,chr= -xchr) # <- omit the X chr completely

  cross
}

# end of read.cross.R
######################################################################
#
# read.cross.csv.R
#
# copyright (c) 2000-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.csv
#           [See read.cross.R for the main read.cross function.]
#
######################################################################

######################################################################
#
# read.cross.csv
#
# read data in comma-delimited format
#
######################################################################

read.cross.csv <-
function(dir, file, na.strings=c("-","NA"),
         genotypes=c("A","H","B","D","C"), estimate.map=TRUE, ...)
{
  # create file names
  if(missing(file)) file <- "data.csv"

  if(!missing(dir) && dir != "") {
    file <- file.path(dir, file)
  }

  args <- list(...)
  # read the data file
  if(length(args) < 1 || is.na( match("sep",names(args))))
    # "sep" not in the "..." argument and so take sep=","
    data <- read.table(file, sep=",", na.strings=na.strings,
                       colClasses="character", fill=TRUE,
                       blank.lines.skip=TRUE, ...)
  else 
    data <- read.table(file, na.strings=na.strings,
                       colClasses="character", fill=TRUE,
                       blank.lines.skip=TRUE, ...)

  # determine number of phenotypes based on initial blanks in row 2
  n <- ncol(data)
  temp <- rep(FALSE,n)
  for(i in 1:n) {
    temp[i] <- all(data[2,1:i]=="")
    if(!temp[i]) break
  }
  if(!any(temp)) # no phenotypes!
    stop("You must include at least one phenotype (e.g., an index).")
  n.phe <- max((1:n)[temp])

  # Is map included?  yes if first n.phe columns in row 3 are all blank
  if(all(!is.na(data[3,1:n.phe]) & data[3,1:n.phe]=="")) {
    map.included <- TRUE
    map <- as.numeric(unlist(data[3,-(1:n.phe)]))
    if(any(is.na(map))) 
      stop("There are missing marker positions.")
    nondatrow <- 3
  }
  else {
    map.included <- FALSE
    map <- rep(0,ncol(data)-n.phe)
    nondatrow <- 2 # last non-data row
  }
  pheno <- as.data.frame(data[-(1:nondatrow),1:n.phe,drop=FALSE])
  colnames(pheno) <- data[1,1:n.phe]

  # replace empty cells with NA
  data <- sapply(data,function(a) { a[!is.na(a) & a==""] <- NA; a })

  # pull apart phenotypes, genotypes and map
  mnames <- data[1,-(1:n.phe)]
  if(any(is.na(mnames)))  stop("There are missing marker names.")
  chr <- data[2,-(1:n.phe)]
  if(any(is.na(chr))) stop("There are missing chromosome IDs.")

  # look for strange entries in the genotype data
  temp <- unique(as.character(data[-(1:nondatrow),-(1:n.phe),drop=FALSE]))
  temp <- temp[!is.na(temp)]
  wh <- is.na(match(temp,genotypes))
  if(any(wh)) {
    warn <- "The following unexpected genotype codes were treated as missing.\n    "
    ge <- paste("|", paste(temp[wh],collapse="|"),"|",sep="")
    warn <- paste(warn,ge,"\n",sep="")
    warning(warn)
  }

  # convert genotype data
  if(length(genotypes) > 0)  
    allgeno <- matrix(match(data[-(1:nondatrow),-(1:n.phe)],genotypes),
                      ncol=ncol(data)-n.phe)
  else
    allgeno <- matrix(as.numeric(data[-(1:nondatrow),-(1:n.phe)]),
                      ncol=ncol(data)-n.phe)

  # Fix up phenotypes
  sw2numeric <-
    function(x) {
      pattern <- "^[ \t]*-*[0-9]*[.]*[0-9]*[ \t]*$"
      n <- sum(!is.na(x))
      if(length(grep(pattern,as.character(x[!is.na(x)])))==n)
        return(as.numeric(as.character(x)))
      else return(x)
    }
  pheno <- data.frame(lapply(pheno, sw2numeric))

  # re-order the markers by chr and position
  # try to figure out the chr labels
  if(all(!is.na(match(chr,c(1:999,"X","x"))))) { # 1...19 + X
    tempchr <- chr
    tempchr[chr=="X" | chr=="x"] <- 1000
    tempchr <- as.numeric(tempchr)
    if(map.included) neworder <- order(tempchr, map)
    else neworder <- order(tempchr)

    chr <- chr[neworder]
    map <- map[neworder]
    allgeno <- allgeno[,neworder,drop=FALSE]
    mnames <- mnames[neworder]
  }
  
  # fix up dummy map
  if(!map.included) {
    map <- split(rep(0,length(chr)),chr)[unique(chr)]
    map <- unlist(lapply(map,function(a) seq(0,length=length(a),by=5)))
    names(map) <- NULL
  }

  # fix up map information
  # number of chromosomes
  uchr <- unique(chr)
  n.chr <- length(uchr)
  geno <- vector("list",n.chr)
  names(geno) <- uchr
  min.mar <- 1
  allautogeno <- NULL  
  for(i in 1:n.chr) { # loop over chromosomes
    # create map
    temp.map <- map[chr==uchr[i]]
    names(temp.map) <- mnames[chr==uchr[i]]

    # pull out appropriate portion of genotype data
    data <- allgeno[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE]
    min.mar <- min.mar + length(temp.map)
    colnames(data) <- names(temp.map)

    geno[[i]] <- list(data=data,map=temp.map)
    if(uchr[i] == "X" || uchr[i] == "x")
      class(geno[[i]]) <- "X"
    else {
      class(geno[[i]]) <- "A"
      if(is.null(allautogeno)) allautogeno <- data 
      else allautogeno <- cbind(allautogeno,data) 
    }
  }

  if(is.null(allautogeno)) allautogeno <- allgeno 

  # check that data dimensions match
  n.mar1 <- sapply(geno,function(a) ncol(a$data))
  n.mar2 <- sapply(geno,function(a) length(a$map))
  n.phe <- ncol(pheno)
  n.ind1 <- nrow(pheno)
  n.ind2 <- sapply(geno,function(a) nrow(a$data))
  if(any(n.ind1 != n.ind2)) {
    print(c(n.ind1,n.ind2))
    stop("Number of individuals in genotypes and phenotypes do not match.");
  }
  if(any(n.mar1 != n.mar2)) {
    print(c(n.mar,n.mar2))
    stop("Numbers of markers in genotypes and marker names files do not match.");
  }

  # print some information about the amount of data read
  cat(" --Read the following data:\n");
  cat("\t", n.ind1, " individuals\n");
  cat("\t", sum(n.mar1), " markers\n");
  cat("\t", n.phe, " phenotypes\n");

  if(all(is.na(allgeno)))
    warning("There is no genotype data!\n")

  # determine map type: f2 or bc or 4way?
  if(all(is.na(allautogeno)) || max(allautogeno,na.rm=TRUE)<=2) type <- "bc"  
  else if(max(allautogeno,na.rm=TRUE)<=5) type <- "f2" 
  else type <- "4way"
  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c(type,"cross")

  # check that nothing is strange in the genotype data
  cross.type <- class(cross)[1]
  if(cross.type=="f2") max.gen <- 5
  else if(cross.type=="bc") max.gen <- 2
  else max.gen <- 10

#  u <- unique(as.numeric(allgeno))  #### rev 3/31 ####
#  if(any(!is.na(u) & (u > max.gen | u < 1))) {
#    err <- paste("There are strange values in the genotype data :",
#                 paste(sort(u),collapse=":"), ".")
#    stop(err)
#  }

  # check that markers are in proper order
  #     if not, fix up the order
  for(i in 1:n.chr) {
    if(any(diff(cross$geno[[i]]$map)<0)) {
      o <- order(cross$geno[[i]]$map)
      cross$geno[[i]]$map <- cross$geno[[i]]$map[o]
      cross$geno[[i]]$data <- cross$geno[[i]]$data[,o,drop=FALSE]
    }
  }

  # estimate genetic map
  if(estimate.map && !map.included) estmap <- TRUE
  else estmap <- FALSE

  # return cross + indicator of whether to run est.map
  list(cross,estmap)
}

# end of read.cross.csv.R
######################################################################
#
# read.cross.gary.R
#
# copyright (c) 2000-3, Karl W Broman, Johns Hopkins University
# last modified Nov, 2003
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.gary
#           [See read.cross.R for the main read.cross function.]
#
######################################################################

######################################################################
#
# read.cross.gary
#
# read data in Gary's format
#
######################################################################

read.cross.gary <-
function(dir,genfile,mnamesfile,chridfile,phefile,pnamesfile,mapfile,
         estimate.map,na.strings)
{
  # create file names
  if(missing(genfile)) genfile <- "geno.dat"
  if(missing(mnamesfile)) mnamesfile <- "mnames.txt"
  if(missing(chridfile)) chridfile <- "chrid.dat"
  if(missing(phefile)) phefile <- "pheno.dat"
  if(missing(pnamesfile)) pnamesfile <- "pnames.txt"
  if(missing(mapfile)) mapfile <- "markerpos.txt"

  if(!missing(dir) && dir != "") {
    genfile <- file.path(dir, genfile)
    mnamesfile <- file.path(dir, mnamesfile)
    chridfile <- file.path(dir, chridfile)
    phefile <- file.path(dir, phefile)
    if(!is.null(pnamesfile)) pnamesfile <- file.path(dir, pnamesfile)
    if(!is.null(mapfile)) mapfile <- file.path(dir, mapfile)
  }

  # read data
  allgeno <- as.matrix(read.table(genfile,na.strings="9"))+1
  pheno <- as.matrix(read.table(phefile,na.strings=na.strings,header=FALSE))
  chr <- scan(chridfile,what=character(),quiet=TRUE)
  mnames <- scan(mnamesfile,what=character(),quiet=TRUE)

  if(!is.null(mapfile)) {
    map <- read.table(mapfile,row.names=1)
    map <- map[mnames,1]
    map.included <- TRUE
  }
  else {
    map <- seq(0,by=5,len=length(mnames))
    map.included <- FALSE
  }

  if(!is.null(pnamesfile)) pnames <- scan(pnamesfile,what=character(),quiet=TRUE)
  else pnames <- paste("pheno",1:ncol(pheno),sep="")


  # fix up map information
  # number of chromosomes
  uchr <- unique(chr)
  n.chr <- length(uchr)
  geno <- vector("list",n.chr)
  names(geno) <- uchr
  min.mar <- 1
  for(i in 1:n.chr) { # loop over chromosomes
    # create map
    temp.map <- map[chr==uchr[i]]

    # deal with any markers that didn't appear in the marker pos file
    if(any(is.na(temp.map))) {
      o <- (seq(along=temp.map))[is.na(temp.map)]
      for(j in o) {
        if(j==1 || all(is.na(temp.map[1:(j-1)]))) {
          z <- min((seq(along=temp.map))[-o])
          temp.map[j] <- min(temp.map,na.rm=TRUE)-(z-j+1)
        }
        else if(j==length(temp.map) || all(is.na(temp.map[-(1:j)]))) {
          z <- max((seq(along=temp.map))[-o])
          temp.map[j] <- max(temp.map,na.rm=TRUE)+(j-z+1)
        }
        else {
          temp.map[j] <- (min(temp.map[-(1:j)],na.rm=TRUE)+
                          max(temp.map[1:(j-1)],na.rm=TRUE))/2
        }
      }
    }

    names(temp.map) <- mnames[chr==uchr[i]]

    # pull out appropriate portion of genotype data
    data <- allgeno[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE]
    min.mar <- min.mar + length(temp.map)
    colnames(data) <- names(temp.map)

    geno[[i]] <- list(data=data,map=temp.map)
    if(uchr[i] == "X" || uchr[i] == "x")
      class(geno[[i]]) <- "X"
    else class(geno[[i]]) <- "A"
  }
  colnames(pheno) <- pnames

  # fix up phenotype data: make things numeric that look numeric
  sw2numeric <-
    function(x) {
      pattern <- "^[ \t]*-*[0-9]*[.]*[0-9]*[ \t]*$"
      n <- sum(!is.na(x))
      if(length(grep(pattern,as.character(x[!is.na(x)])))==n)
        return(as.numeric(as.character(x)))
      else return(x)
    }
  pheno <- data.frame(lapply(as.data.frame(pheno), sw2numeric))

  # check that data dimensions match
  n.mar1 <- sapply(geno,function(a) ncol(a$data))
  n.mar2 <- sapply(geno,function(a) length(a$map))
  n.phe <- ncol(pheno)
  n.ind1 <- nrow(pheno)
  n.ind2 <- sapply(geno,function(a) nrow(a$data))
  if(any(n.ind1 != n.ind2)) {
    print(c(n.ind1,n.ind2))
    stop("Number of individuals in genotypes and phenotypes do not match.");
  }
  if(any(n.mar1 != n.mar2)) {
    print(c(n.mar,n.mar2))
    stop("Numbers of markers in genotypes and marker names files do not match.");
  }

  # print some information about the amount of data read
  cat(" --Read the following data:\n");
  cat("\t", n.ind1, " individuals\n");
  cat("\t", sum(n.mar1), " markers\n");
  cat("\t", n.phe, " phenotypes\n");

  # determine map type: f2 or bc or 4way?
  if(max(allgeno[!is.na(allgeno)])<=2) type <- "bc"
  else type <- "f2"
  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c(type,"cross")

  # check that nothing is strange in the genotype data
  cross.type <- class(cross)[1]
  if(cross.type=="f2") max.gen <- 5
  else max.gen <- 2

  u <- unique(allgeno)
  if(any(!is.na(u) & (u > max.gen | u < 1))) {
    err <- paste("There are stange values in the genotype data :",
                 paste(sort(u),collapse=":"), ".")
    stop(err)
  }

  cross$pheno <- as.data.frame(cross$pheno)

  # if map wasn't included, go through each chromosome and
  # make first marker at 0 cM.
  if(!map.included) {
    for(i in 1:nchr(cross))
      cross$geno[[i]]$map <- cross$geno[[i]]$map - min(cross$geno[[i]]$map)
  }

  # return cross + indicator of whether to run est.map
  # [run est.map if map not included and estimate.map == TRUE]
  list(cross, (!map.included && estimate.map) )
}

# end of read.cross.gary.R
######################################################################
#
# read.cross.karl.R
#
# copyright (c) 2000-3, Karl W Broman, Johns Hopkins University
# last modified Nov, 2003
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.karl
#           [See read.cross.R for the main read.cross function.]
#
######################################################################

######################################################################
#
# read.cross.karl
#
# read data in Karl's format
#
######################################################################

read.cross.karl <-
function(dir,genfile,mapfile,phefile)
{
  # create file names
  if(missing(genfile)) genfile <- "gen.txt"
  if(missing(mapfile)) mapfile <- "map.txt"
  if(missing(phefile)) phefile <- "phe.txt"

  if(!missing(dir) && dir != "") {
    genfile <- file.path(dir, genfile)
    mapfile <- file.path(dir, mapfile)
    phefile <- file.path(dir, phefile)
  }

  # read data
  geno <- as.matrix(read.table(genfile,na.strings="0"))
  pheno <- as.matrix(read.table(phefile,na.strings="-",header=TRUE))
  tempmap <- scan(mapfile, what=character(),quiet=TRUE)

  # fix up map information
  # number of chromosomes
  n.chr <- as.numeric(tempmap[1])
  n.mar <- 1:n.chr
  g <- map <- geno.data <- vector("list", n.chr)
  cur <- 2
  min.mar <- 1
  names(g) <- as.character(1:n.chr)
  for(i in 1:n.chr) { # loop over chromosomes
    # number of markers
    n.mar[i] <- as.numeric(tempmap[cur])
    cur <- cur+1

    # pull out appropriate portion of genotype data
    geno.data[[i]] <- geno[,min.mar:(min.mar+n.mar[i]-1)]
    min.mar <- min.mar + n.mar[i]

    # recombination fractions
    r <- as.numeric(tempmap[cur:(cur+n.mar[i]-2)])

    # convert to cM distances (w/ Kosambi map function)
    d <- 0.25*log((1+2*r)/(1-2*r))*100

    # convert to locations
    map[[i]] <- round(c(0,cumsum(d)),2)
    cur <- cur+n.mar[i]-1

    # marker names
    names(map[[i]]) <- tempmap[cur:(cur+n.mar[i]-1)]
    dimnames(geno.data[[i]]) <- list(NULL, names(map[[i]]))
    cur <- cur+n.mar[i]

    g[[i]] <- list(data=geno.data[[i]],map=map[[i]])

    # attempt to pull out chromosome number
    mar.names <- names(map[[i]])
    twodig <- grep("[Dd][1-9][0-9][Mm]", mar.names)
    onedig <- grep("[Dd][1-9][Mm]", mar.names)
    xchr <- grep("[Dd][Xx][Mm]", mar.names)

    chr.num <- NULL
    if(length(twodig) > 0)
      chr.num <- c(chr.num,substr(mar.names[twodig],2,3))
    if(length(onedig) > 0)
      chr.num <- c(chr.num,substr(mar.names[onedig],2,2))
    if(length(xchr) > 0)
      chr.num <- c(chr.num,rep("X",length(xchr)))

    # no marker names of the form above
    if(is.null(chr.num)) {
      chr.num <- length(mar.names)
      names(chr.num) <- "1"
    }
    else {
      chr.num <- table(chr.num)
    }

    m <- max(chr.num)
    if(m > sum(chr.num)/2 && m > 1)
      names(g)[i] <- names(chr.num)[chr.num==m][1]

    if(names(g)[i] == "X" || names(g)[i] == "x") class(g[[i]]) <- "X"
    else class(g[[i]]) <- "A"
  }

  # check that data dimensions match
  n.mar1 <- sapply(g,function(a) ncol(a$data))
  n.mar2 <- sapply(g,function(a) length(a$map))
  n.phe <- ncol(pheno)
  n.ind1 <- nrow(pheno)
  n.ind2 <- sapply(g,function(a) nrow(a$data))
  if(any(n.ind1 != n.ind2)) {
    print(c(n.ind1,n.ind2))
    stop("Number of individuals in genotypes and phenotypes do not match.");
  }
  if(any(n.mar1 != n.mar2)) {
    print(c(n.mar,n.mar2))
    stop("Numbers of markers in genotypes and marker names files do not match.");
  }

  # print some information about the amount of data read
  cat(" --Read the following data:\n");
  cat("\t", n.ind1, " individuals\n");
  cat("\t", sum(n.mar1), " markers\n");
  cat("\t", n.phe, " phenotypes\n");

  # add phenotype names, if missing
  if(is.null(colnames(pheno)))
    dimnames(pheno) <- list(NULL, paste("phenotype", 1:n.phe,sep=""))

  # determine map type: f2 or bc or 4way?
  if(max(geno[!is.na(geno)])<=2) type <- "bc"
  else if(max(geno[!is.na(geno)])<=5) type <- "f2"
  else type <- "4way"
  cross <- list(geno=g,pheno=pheno)
  class(cross) <- c(type,"cross")

  # check that nothing is strange in the genotype data
  cross.type <- class(cross)[1]
  if(cross.type=="f2") max.gen <- 5
  else if(cross.type=="bc") max.gen <- 2
  else max.gen <- 10

  u <- unique(geno)
  if(any(!is.na(u) & (u > max.gen | u < 1))) {
    err <- paste("There are stange values in the genotype data :",
                 paste(u,collapse=":"), ".")
    stop(err)
  }

  cross$pheno <- as.data.frame(cross$pheno)

  # return cross + indicator of whether to run est.map
  list(cross,FALSE)
}

# end of read.cross.karl.R
######################################################################
#
# read.cross.mm.R
#
# copyright (c) 2000-3, Karl W Broman, Johns Hopkins University
# last modified Nov, 2003
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.mm, read.maps.mm
#           [See read.cross.R for the main read.cross function.]
#
######################################################################

######################################################################
#
# read.cross.mm: read data from an experimental cross in mapmaker
#                format.
#
# We need two files: a "raw" file containing the genotype and
# phenotype data and a "map" file containing the chromosomes
# assignments and (optionally) map positions.
#
# The map file contains two or three columns, separated by white
# space, with the chromosome number, marker name (with markers in
# order along the chromosomes) and (optionally) the map position.
#
######################################################################

read.cross.mm <-
function(dir,rawfile,mapfile,estimate.map=TRUE)
{
  # create file names
  if(missing(mapfile)) stop("Missing mapfile.")
  if(missing(rawfile)) stop("Missing rawfile.")
  if(!missing(dir)  && dir != "") {
    mapfile <- file.path(dir, mapfile)
    rawfile <- file.path(dir, rawfile)
  }

  # count lines in rawfile
  n.lines <- length(scan(rawfile, what=character(), skip=0, nlines=0,
                         blank.lines.skip=FALSE,quiet=TRUE,sep="\n"))

  # read map file
  map <- read.table(mapfile,header=FALSE,colClasses="character",blank=FALSE)
  fixmap <- TRUE
  if(ncol(map) == 1)
    stop("Map file should contain the markers' chromosome IDs.")

  if(ncol(map) > 3) { # special maps format
    maps <- read.maps.mm(mapfile)
    chr <- rep(names(maps),sapply(maps,length))
    markers <- unlist(lapply(maps,names))
    includes.pos <- TRUE
    fixmap <- FALSE
  }

  if(fixmap) { # my map format: 2 or 3 column table
    # remove any rows lacking a chromosome ID
    o <- (1:nrow(map))[map[,1]==""]
    if(length(o) > 0) map <- map[-o,]

    # remove any leading *'s from the marker names
    g <- grep("^*",map[,2],extended=FALSE)
    if(length(g) > 0)
      map[g,2] <- substr(map[g,2],2,nchar(map[g,2]))
  }

  # begin reading/parsing the genotype data
  cur.mar <- 0
  cur.phe <- 0
  NEW.symb <- c("1","2","3","4","5","0")
  OLD.symb <- c("A","H","B","D","C","-")

  flag <- 0
  for(i in 1:n.lines) {
    a <- scan(rawfile,what=character(),skip=i-1,nlines=1,
              blank.lines.skip=TRUE,quiet=TRUE)

    if(length(a) == 0) next
    if(length(grep("#", a[1])) != 0) next

    if(flag == 0) {
      flag <- 1
      type <- a[4] # a[length(a)]
      if(type == "intercross") type <- "f2"
      else if(type == "backcross") type <- "bc"
      else {
        err <- paste("File indicates invalid cross type: ", type,
                     ".", sep="")
        stop(err)
      }
    }
    else if(flag == 1) {
      flag <- 2
      n.ind <- as.numeric(a[1])
      n.mar <- as.numeric(a[2])
      n.phe <- as.numeric(a[3])
      cat(" --Read the following data:\n")
      cat("\tType of cross:         ", type, "\n")
      cat("\tNumber of individuals: ", n.ind, "\n")
      cat("\tNumber of markers:     ", n.mar, "\n")
      cat("\tNumber of phenotypes:  ", n.phe, "\n")

      # if there's a set of "symbols" for non-standard symbols in
      #     the file, use them.
      if(length(a) > 3 && !is.na(match("symbols", a))) {
        o <- match("symbols",a)
        b <- a[-(1:o)]
        infile.symb <- substring(b,1,1)
        std.symb <- substring(b,3,3)

        wh <- rep(0,length(std.symb))
        fixed <- rep(0,length(OLD.symb))
        for(j in 1:length(std.symb))
          if(!is.na(match(std.symb[j], OLD.symb)))
            wh[j] <- match(std.symb[j],OLD.symb)
        for(j in 1:length(std.symb))
          if(wh[j] != 0) {
            OLD.symb[wh[j]] <- infile.symb[j]
            fixed[wh[j]] <- 1
          }

        temp <- table(OLD.symb)
        if(any(temp>1)) {
          for(j in names(temp)[temp>1]) {
            o <- OLD.symb==j & fixed==0
            if(any(o)) OLD.symb[o] <- paste(OLD.symb[o],"   ")
          }
        }
      }

      marnames <- rep("", n.mar)
      geno <- matrix(0,ncol=n.mar,nrow=n.ind)
      if(n.phe == 0) {
        pheno <- matrix(1:n.ind,ncol=1)
        phenames <- c("number")
      }
      else {
        pheno <- matrix(0,ncol=n.phe,nrow=n.ind)
        phenames <- rep("", n.phe)
      }

    }
    else {
      if(substring(a[1],1,1) == "*") {
        cur.mar <- cur.mar+1
        cur.row <- 1

        if(cur.mar > n.mar) { # now reading phenotypes
          cur.phe <- cur.phe+1
          if(cur.phe > n.phe) next
          phenames[cur.phe] <- substring(a[1],2)
          if(length(a) > 1) {
            p <- a[-1]
            p[p=="-"] <- NA
            n <- length(p)
            pheno[cur.row+(0:(n-1)),cur.phe] <- as.numeric(p)
          }
          else n <- 0 ## ?
          cur.row <- cur.row + n
        }

        else { # reading genotypes
          marnames[cur.mar] <- substring(a[1],2)
          if(length(a) > 1) {
            g <- paste(a[-1],collapse="")
            h <- g <- unlist(strsplit(g,""))
            for(j in seq(along=NEW.symb)) {
              if(any(h==OLD.symb[j]))
                g[h==OLD.symb[j]] <- NEW.symb[j]
            }

            n <- length(g)

            geno[cur.row+(0:(n-1)),cur.mar] <- as.numeric(g)
          }
          else n <- 0
          cur.row <- cur.row + n
        }

      }
      else { # continuation lines
        if(cur.mar > n.mar) { # now reading phenotypes
          a[a=="-"] <- NA
          n <- length(a)
          pheno[cur.row+(0:(n-1)),cur.phe] <- as.numeric(a)
          cur.row <- cur.row + n
        }
        else {
          g <- paste(a,collapse="")
          h <- g <- unlist(strsplit(g,""))
          for(j in seq(along=NEW.symb)) {
            if(any(h==OLD.symb[j]))
              g[h==OLD.symb[j]] <- NEW.symb[j]
          }
          n <- length(g)
          geno[cur.row+(0:(n-1)),cur.mar] <- as.numeric(g)
          cur.row <- cur.row + n
        }
      } # end continuation line
    } # end non-intro line
  }
  dimnames(pheno) <- list(NULL, phenames)
  # done reading the raw file

  if(fixmap) { # my map format: 2 or 3 column table
    # parse map file
    if(ncol(map) == 3) {
      includes.pos <- TRUE
      # make positions numeric 
      pos <- as.numeric(map[,3])
    }
    else includes.pos <- FALSE

    chr <- as.character(map[,1])
    markers <- map[,2]

    # reorder markers?
    if(all(!is.na(match(chr,c(1:999,"X","x"))))) { # 1...19 + X
      tempchr <- chr
      tempchr[chr=="X" | chr=="x"] <- 1000
      tempchr <- as.numeric(tempchr)
      if(includes.pos) neworder <- order(tempchr, pos)
      else neworder <- order(tempchr)

      chr <- chr[neworder]
      if(includes.pos) pos <- pos[neworder]
      markers <- markers[neworder]
    }
  }

  Geno <- vector("list",length(unique(chr)))
  names(Geno) <- unique(chr)

  for(i in unique(chr)) {
    mar <- markers[chr == i]

    if(fixmap) { # my map format: 2 or 3 column table
      # create map
      if(includes.pos) {
        map <- pos[chr == i]

        # reorder markers?
        if(any(diff(map)<0)) {
          o <- order(map)
          map <- map[o]
          mar <- mar[o]
        }
      }
      else map <- seq(0,by=5,length=length(mar))
      names(map) <- mar
    }
    else map <- maps[[i]]

    # pull out genotype data
    o <- match(mar,marnames)
    if(any(is.na(o))) {
      err <- paste("Cannot find markers in genotype data: ",
                   paste(mar[is.na(o)],collapse=" "), ".",sep="")
      stop(err)
    }

    if(length(o)==1) data <- matrix(geno[,o],ncol=1)
    else data <- geno[,o]
    # add marker names to data
    colnames(data) <- mar
    # changes 0's to NA's
    data[!is.na(data) & data==0] <- NA

    Geno[[i]] <- list(data=data,map=map)
    if(i=="X" || i=="x") class(Geno[[i]]) <- "X"
    else class(Geno[[i]]) <- "A"
  }

  cross <- list(geno=Geno,pheno=pheno)
  class(cross) <- c(type,"cross")

  if(estimate.map && !includes.pos) estmap <- TRUE
  else estmap <- FALSE

  cross$pheno <- as.data.frame(cross$pheno)

  # return cross + indicator of whether to run est.map
  list(cross,estmap)
}

######################################################################
#
# read.maps.mm: Read genetic map for a special Mapmaker format
# Written by Brian S Yandell; modified by Karl W Broman
#
######################################################################
read.maps.mm <-
function( mapsfile )
{
  if (missing(mapsfile)) stop("Missing mapsfile.")

  ## find where everything is
  f <- scan(mapsfile, what = "", blank.lines.skip = FALSE, sep = "\n",
            quiet = TRUE)
  start <- pmatch( paste( "*", c("OrderInfo","Classes","Chromosomes",
                                 "Assignments and Placements" ), ":", sep = "" ), f )

  ## marker names
  f <- scan( mapsfile, what = c("",rep(0,9)), skip = start[1],
            nlines = start[2] - start[1] - 1,
            blank.lines.skip = FALSE, quiet = TRUE)
  markers <- substring( f[ seq( 1, length( f ), by = 10 ) ], 2 )

  ## distances
  f <- scan( mapsfile, what = "", skip = start[3],
            nlines = start[4] - start[3] - 1,
            blank.lines.skip = FALSE, quiet = TRUE)
  chr <- grep( "^*", f, extended = FALSE )
  chrom <- substring( f[chr], 2 )
  nmark <- as.integer( f[ 1 + chr ] )
  chr <- c( chr[-1], 1 + length( f ))
  lo <- chr - 2 * nmark + 2
  hi <- chr - nmark
  map <- list()
  imark <- c( 0, cumsum( nmark ))
  for( i in seq( along = chrom )) {
    tmp <- cumsum( c(0,imf.h(as.numeric( f[ lo[i]:hi[i] ] ))))
    names( tmp ) <- markers[ imark[i] + seq( nmark[i] ) ]
    map[[ chrom[i] ]] <- tmp
  }
  map
}

# end of read.cross.mm.R
######################################################################
#
# read.cross.qtx.R
#
# copyright (c) 2000-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Aug, 2000
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: read.cross.qtx
#           [See read.cross.R for the main read.cross function.]
#
######################################################################

######################################################################
#
# read.cross.qtx
#
# read data in Map Manager QTX format
#
######################################################################

read.cross.qtx <-
function(dir, file, estimate.map=TRUE)
{
  if(!missing(dir) && dir != "") {
    file <- file.path(dir, file)
  }


  # This is a revised version of match which gives *all* matches
  # of x within the table
  mymatch <-
    function(x, table)
      {
        if(length(x) > 1) x <- x[1] # ignore any but the first element of x

        if(!any(x==table)) return(NA)
        seq(along=table)[x==table]
      }

  # read file into a big vector, each item one line
  cat(" --Read the following data:\n")
  x <- scan(file,what=character(0),sep="\n",quiet=TRUE)

  genoabbrev <- unlist(strsplit(x[9],""))
  if(length(genoabbrev) < 8)  # just in case, fill out to 8 chars
    genoabbrev <- c(genoabbrev,rep("H",8-length(genoabbrev)))
  myabbrev <- c(0,1,3,2,5,4,2,2)
  ugeno <- NULL

  # individuals
  ind.beg <- match("{pgy", x) # there should be just one
  ind.end <- match("}pgy", x)
  n.ind <- as.numeric(x[ind.beg+1])
  ind <- x[(ind.beg+2):(ind.end-1)]
  if(length(ind) != n.ind)
    stop("Problem with individual IDs ({pgy}).")
  cat(paste("\t", n.ind, "  individuals\n",sep=""))

  # determine if individuals can be viewed as numbers
  g <- grep("^[0-9\.]+$", ind)
  if(length(g) == n.ind)
    ind <- as.numeric(as.character(ind))

  # phenotypes
  phe.beg <- mymatch("{trt",x)
  phe.end <- mymatch("}trt",x)
  pheno <- NULL
  if(!is.na(phe.beg[1])) { # at least one phenotype
    pheno <- vector("list",length(phe.beg))
    names(pheno) <- paste(phe.beg)
    for(i in 1:length(phe.beg)) {
      z <- x[phe.beg[i]:phe.end[i]]
      names(pheno)[i] <- z[2]
      vals.beg <- match("{tvl", z)+1 # there should be just one match
      vals.end <- match("}tvl", z)-1

      # "X" or "x" is a missing phenotype
      temp <- unlist(strsplit(z[vals.beg[1]:vals.end[1]]," "))
      temp[temp=="X" | temp=="x"] <- NA
      pheno[[i]] <- as.numeric(temp)
    }
    pheno <- cbind(as.data.frame(pheno),ind=ind)
    cat(paste("\t", length(pheno), "  phenotypes\n",sep=""))
  }
  else {
    pheno <- data.frame(ind=ind)
    cat(paste("\t", 0, "  phenotypes\n",sep=""))
  }

  # chromosomes
  chr.beg <- mymatch("{chx",x)
  chr.end <- mymatch("}chx",x)

  if(is.na(chr.beg[1])) # no genotype data
    stop("There appears to be no genotype data!")
  geno <- vector("list", length(chr.beg))
  names(geno) <- paste(chr.beg)
  has.loci <- rep(TRUE,length(chr.beg))
  map.offset <- rep(0,length(chr.beg))

  cat(paste("\t", length(chr.beg), "  chromosomes\n",sep=""))

  for(i in 1:length(chr.beg)) {
    z <- x[chr.beg[i]:chr.end[i]]
    names(geno)[i] <- z[2]
    map.offset <- as.numeric(z[5])

    # loci
    loc.beg <- mymatch("{lox",z)
    loc.end <- mymatch("}lox",z)
    if(all(is.na(loc.beg))) {
      has.loci[i] <- FALSE
      next
    }
    data <- matrix(ncol=length(loc.beg),nrow=n.ind)
    loctype <- rep(NA,length(loc.beg)) ####
    colnames(data) <- paste(loc.beg)
    has.geno <- rep(TRUE,length(loc.beg))
    for(j in 1:length(loc.beg)) {
      zz <- z[loc.beg[j]:loc.end[j]]
      colnames(data)[j] <- zz[2]
      loctype[j] <- zz[5] ####
      geno.beg <- match("{sdp",zz)+1 # should be just one match
      geno.end <- match("}sdp",zz)-1
      if(all(is.na(geno.beg))) { # no genotype data
        has.geno[j] <- FALSE
        next
      }
      dat <- unlist(strsplit(paste(zz[geno.beg[1]:geno.end[1]],collapse=""),""))

      data[,j] <- myabbrev[match(dat,genoabbrev)]
    } # end loop over loci

    # check that all loci have the same code
    if(all(loctype == loctype[1])) 
      loctype <- loctype[1]
    # 0 = unknown
    # 1 = backcross codominant maternal unique
    # 2 = backcross codominant paternal unique
    # 3 = backcross maternal dominant
    # 4 = backcross paternal dominant
    # 5 = f2 codominant
    # 6 = f2 maternal dominant
    # 7 = f2 paternal dominant
    # 8 = doubled haploid
    # 9 = selfed RI
    # 10 = sib-mated RI
    # 11 = advanced backcross codominant maternal unique
    # 12 = advanced backcross codominant paternal udnique
    # 13 = advanced backcross maternal dominant
    # 14 = advanced backcross paternal dominant
    # 15 = AIL codominant
    # 16 = AIL maternal dominant
    # 17 = AIL paternal dominant
    # 18 = radiation hybrid data
    # 19 = radiation hybrid data
    # 20 = selfed RIX
    # 21 = sib-mated RIX

    # replace 0's with NA's
    data[!is.na(data) & data==0] <- NA

    # remove columns with no data
    data <- data[,has.geno,drop=FALSE]

    # temporary map
    map <- seq(0,length=ncol(data),by=5)+map.offset
    names(map) <- colnames(data)
    geno[[i]] <- list(data=data,map=map)
    if(length(grep("[Xx]", names(geno)[i]))>0) # X chromosome
      class(geno[[i]]) <- "X"
    else class(geno[[i]]) <- "A"
  } # end loop over chromosomes

  # unique genotypes
  for(i in 1:length(geno)) {
    ugeno <- unique(c(ugeno,unique(geno[[i]]$data)))
    ugeno <- ugeno[!is.na(ugeno)]
  }

  if(length(ugeno)==2) { # backcross
    # Fix if coded as A:B rather than A:H (RI lines)
    if(all(ugeno==1 || ugeno==3)) {
      for(i in 1:length(geno))
        geno[[i]]$data[geno[[i]]$data == 3] <- 2
    }
    # Fix if coded as H:B rather than A:H (other backcross)
    else if(all(ugeno==2 || ugeno==3)) {
      for(i in 1:length(geno))
        geno[[i]]$data[geno[[i]]$data == 3] <- 1
    }

    type <- "bc"
    for(i in 1:length(geno))
      geno[[i]]$data[geno[[i]]$data > 2] <- 1
  }
  else type <- "f2"

  totmar <- sum(sapply(geno,function(a) ncol(a$data)))
  cat(paste("\t", totmar, "  total markers\n",sep=""))

  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c(type,"cross")

  if(estimate.map) estmap <- TRUE
  else estmap <- FALSE

  # return cross + indicator of whether to run est.map
  list(cross,estmap)
}

# end of read.cross.qtx.R
######################################################################
#
# ripple.R
#
# copyright (c) 2001-3, Karl W Broman, Johns Hopkins University
# last modified Jun, 2003
# first written Oct, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: ripple, summary.ripple, print.summary.ripple
#           ripple.perm1, ripple.perm2, ripple.perm.sub
#
######################################################################

######################################################################
#
# ripple: Check marker orders for a given chromosome, comparing all
#         possible permutations of a sliding window of markers
#
######################################################################

ripple <-
function(cross, chr, window=4, method=c("countxo","likelihood"),
         error.prob=0, map.function=c("haldane","kosambi","c-f","morgan"),
         maxit=4000, tol=1e-4, sex.sp=TRUE)
{
  # pull out relevant chromosome
  if(length(chr) > 1)
    stop("ripple only works for one chromosome at a time.")
  cross <- subset(cross,chr=chr)
  chr.name <- names(cross$geno)[1]

  if(nmar(cross)[1] < 3) {
    warning("Less than three markers.")
    return(NULL)
  }

  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  # make sure window is an integer >= 2
  if(window < 2) {
    warning("The window argument must be > 1; using window=2.")
    window <- 2
  }
  window <- round(window)

  method <- match.arg(method)
  map.function <- match.arg(map.function)

  # get marker orders to test
  n.mar <- totmar(cross)
  if(n.mar <= window) # look at all possible orders
    orders <- ripple.perm2(n.mar)
  else { 
    temp <- ripple.perm1(window)
    n <- nrow(temp)
    orders <- cbind(temp,matrix(rep((window+1):n.mar,n),
                                  byrow=TRUE,ncol=n.mar-window))
    for(i in 2:(n.mar-window+1)) {
      left <- matrix(rep(1:(i-1),n),byrow=TRUE,ncol=i-1)
      if(i < n.mar-window+1)
        right <- matrix(rep((i+window):n.mar,n),byrow=TRUE,ncol=n.mar-window-i+1)
      else
        right <- NULL
      orders <- rbind(orders,cbind(left,temp+i-1,right))
    }
    # keep only distinct orders
    orders <- as.numeric(unlist(strsplit(unique(apply(orders,1,paste,collapse=":")),":")))
    orders <- matrix(orders,ncol=n.mar,byrow=TRUE)
  }
  n.orders <- nrow(orders)

  
  # how often to print information about current order being considered
  if(n.orders > 49) print.by <- 10
  else if(n.orders > 14) print.by <- 5
  else print.by <- 2

  if(method=="likelihood") {
    # calculate log likelihoods (and est'd chr length) for each marker order
    loglik <- 1:n.orders
    chrlen <- 1:n.orders

    # create temporary cross
    m <- seq(0,by=5,length=n.mar)
    temcross <- cross
    if(is.matrix(cross$geno[[1]]$map)) 
      temcross$geno[[1]]$map <- rbind(m,m)
    else temcross$geno[[1]]$map <- m

    for(i in 1:n.orders) {
      if(i==1) cat("  ", n.orders,"total orders\n")
      if((i %/% print.by)*print.by == i) cat("    --Order", i, "\n")
      temcross$geno[[1]]$data <- cross$geno[[1]]$data[,orders[i,]]
      newmap <- est.map(temcross,error.prob,map.function,maxit,tol,sex.sp)
      loglik[i] <- attr(newmap[[1]],"loglik")
      chrlen[i] <- diff(range(newmap[[1]]))
#      if(is.matrix(newmap[[1]])) chrlen[i] <- newmap[[1]][n.mar,1]
#      else chrlen[i] <- newmap[[1]][n.mar]
    }

    # re-scale log likelihoods and convert to lods
    loglik <- (loglik - loglik[1])/log(10)

    # sort orders by lod
    o <- rev(order(loglik[-1])+1)

    # create output 
    orders <- cbind(orders,LOD=loglik,chrlen)[c(1,o),]
  }
  else { # count obligate crossovers for each order
    # which type of cross is this?
    type <- class(cross)[1]
    if(type == "f2") {
      if(class(cross$geno[[1]]) == "A") # autosomal
        func <- "R_ripple_f2"
      else func <- "R_ripple_bc"        # X chromsome  
    }
    else if(type == "bc" || type=="riself" || type=="risib") func <- "R_ripple_bc"
    else if(type == "4way") func <- "R_ripple_4way"
    else {
      err <- paste("ripple not available for cross", type)
      stop(err)
    }

    # data to be input
    genodat <- cross$geno[[1]]$data
    genodat[is.na(genodat)] <- 0
    n.ind <- nind(cross)

    cat("  ", n.orders,"total orders\n")
    z <- .C(func,
            as.integer(n.ind),
            as.integer(n.mar),
            as.integer(genodat),
            as.integer(n.orders),
            as.integer(orders-1),
            oblxo=as.integer(rep(0,n.orders)),
            as.integer(print.by),
            PACKAGE="qtl")

    oblxo <- z$oblxo
    # sort orders by lod
    o <- order(oblxo[-1])+1

    # create output 
    orders <- cbind(orders,obligXO=oblxo)[c(1,o),]
  }
  
  rownames(orders) <- c("Initial", paste(1:(nrow(orders)-1)))
  class(orders) <- c("ripple","matrix")
  attr(orders,"chr") <- chr.name
  attr(orders,"window") <- window
  attr(orders,"error.prob") <- error.prob
  attr(orders,"method") <- method

  # make sure, for each order considered, that the proximal marker
  # (in the original order) is to the left of the distal marker
  # (in the original order) 
  orders[,1:n.mar] <- t(apply(orders[,1:n.mar,drop=FALSE],1,
                              function(a) {
                                n <- length(a)
                                if((1:n)[a==1] > (1:n)[a==n]) return(rev(a))
                                else return(a) }))

  orders
}

######################################################################
#
# summary.ripple: print top results from ripple().  We do this so
#                 that we can return *all* results but allow easy
#                 view of only the important ones
#
######################################################################

summary.ripple <-
function(object, lod.cutoff = -1, ...)
{
  n <- ncol(object)

  if(!is.na(match("obligXO",colnames(object)))) # counts of crossovers
    o <- (object[-1,n] <= (object[1,n] - lod.cutoff*2))
  else o <- (object[-1,n-1] >= lod.cutoff) # likelihood analysis

  if(!any(o)) object <- object[1:2,,drop=FALSE]
  else  # make sure first row is included
    object <- object[c(TRUE,o),,drop=FALSE]

  rownames(object) <- c("Initial ", paste(1:(nrow(object)-1)))
  class(object) <- c("summary.ripple","matrix")
  object
}

######################################################################
#
# print.summary.ripple
#
######################################################################

print.summary.ripple <-
function(x, ...)
{
  n <- ncol(x)
  x <- round(x,1)

  if(is.na(match("obligXO",colnames(x)))) 
    colnames(x)[n-1] <- "    LOD"

  if(nrow(x) > 20) {
    print.matrix(x[1:20,])
    n <- nrow(x)-20
    cat(paste("... [", n, " additional rows] ...\n",sep=""))
  }
  else print.matrix(x)
}

######################################################################
#
# ripple.perm1: Utility function for ripple().  Returns all possible
#               permutations of {1, 2, ..., n}
#
######################################################################

ripple.perm1 <-  
function(n)
{
  if(n == 1) return(rbind(1))
  o <- rbind(c(n-1,n),c(n,n-1))
  if(n > 2)
    for(i in (n-2):1)
      o <- ripple.perm.sub(i,o)
  dimnames(o) <- NULL
  o
}

######################################################################
#
# ripple.perm2: Utility function for ripple().  Returns all possible
#               permutations of {1, 2, ..., n}, up to orientation of
#               the entire group
#
######################################################################

ripple.perm2 <- 
function(n)
{
  if(n < 3) return(rbind(1:n))
  o <- rbind(c(n-2,n-1,n),c(n-1,n-2,n),c(n-1,n,n-2))
  if(n > 3)
    for(i in (n-3):1)
      o <- ripple.perm.sub(i,o)
  dimnames(o) <- NULL
  o
}

######################################################################
#
# ripple.perm.sub: Subroutine used for ripple().  I'm too tired to
#                  explain.
#
######################################################################

ripple.perm.sub <-
function(x,mat)
{
  res <- cbind(x,mat)
  if(ncol(mat) > 1) {
    for(i in 1:ncol(mat))
        res <- rbind(res,cbind(mat[,1:i],x,mat[,-(1:i)]))
  }
  res
}

# end of ripple.R
#####################################################################
#
# scanone.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Sep, 2004
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Hao Wu (The Jackson Lab) wrote the imputation method
#
# Part of the R/qtl package
# Contains: scanone, plot.scanone, scanone.perm,
#           summary.scanone, print.summary.scanone,
#           max.scanone
#
######################################################################

######################################################################
#
# scanone: scan genome, calculating LOD scores with single QTL model
#          (covariates are not allowed for models other than "normal")
#
######################################################################

scanone <-
function(cross, chr, pheno.col=1, model=c("normal","binary","2part","np"),
         method=c("em","imp","hk","mr","mr-imp","mr-argmax"),
         addcovar=NULL, intcovar=NULL, weights=NULL,
         upper=FALSE, ties.random=FALSE,
         start=NULL, maxit=4000, tol=1e-4, n.perm, trace=TRUE)
{
  model <- match.arg(model)
  method <- match.arg(method)

  if(!missing(chr)) cross <- subset(cross, chr)
  if(missing(n.perm)) n.perm <- 0

  # check phenotypes and covariates; drop individuals with missing values
  # in case of permutation test, only do checks once
  if(n.perm >= 0) {
    temp <- checkcovar(cross, pheno.col, addcovar, intcovar)
    cross <- temp[[1]]
    pheno <- temp[[2]]
    addcovar <- temp[[3]]
    intcovar <- temp[[4]]
    n.addcovar <- temp[[5]]
    n.intcovar <- temp[[6]]
  }
  else {
    pheno <- cross$pheno[,pheno.col]
    if(is.null(addcovar)) n.addcovar <- 0
    else n.addcovar <- ncol(addcovar)
    if(is.null(intcovar)) n.intcovar <- 0
    else n.intcovar <- ncol(intcovar)
  }
  n.chr <- nchr(cross)
  n.ind <- nind(cross)
  type <- class(cross)[1]

  # if n.perm specified, do a permutation test
  if(n.perm>0) {
    return(scanone.perm(cross, pheno.col, model, method, addcovar,
                        intcovar, weights, upper, ties.random,
                        start, maxit, tol, n.perm, trace))
  }

  # fill in missing genotypes with imputed values
  if(n.perm==0) { # not in the midst of permutations
    if(method=="mr-argmax")
      cross <- fill.geno(cross,method="argmax")
    if(method=="mr-imp")
      cross <- fill.geno(cross,method="imp")
  }

  # weights for model="normal"
  if(is.null(weights))
    weights <- rep(1, nind(cross))
  else if(model != "normal")
    warning("weights used only for normal model.")
  if(length(weights) != nind(cross))
    stop("weights should either be NULL or a vector of length n.ind")
  if(any(weights) <= 0)
    stop("weights should be entirely positive")
  weights <- sqrt(weights)

  if(model=="binary") {
    if(n.addcovar > 0 || n.intcovar > 0)
      warning("Covariates ignored for the binary model.")
    if(method=="imp" || method=="hk") {
      warning("Methods imp and hk not available for binary model; using em")
      method <- "em"
    }
    return(discan(cross,pheno.col, method, maxit, tol))
  }
  else if(model=="2part") {
    if(n.addcovar > 0 || n.intcovar > 0)
      warning("Covariates ignored for the two-part model.")
    if(method!="em") {
      warning("Only em method is available for the two-part model")
      method <- "em"
    }
    return(vbscan(cross, pheno.col, upper, method, maxit, tol))
  }
  else if(model=="np") {
    if(n.addcovar > 0 || n.intcovar > 0)
      warning("Covariates ignored for non-parametric interval mapping.")
    if(method!="em") {
      warning("Method argument ignored for non-parametric interval mapping.")
      method <- "em"
    }
  }
    
  # if non-parametric, convert phenotypes to ranks
  if(model=="np") {
    if(ties.random) {
      y <- pheno[!is.na(pheno)]
      y <- rank(y+runif(length(y))/(sd(y)*10^8))
      pheno[!is.na(pheno)] <- y
      correct <- 1
    }
    else {
      ties <- table(pheno)
      if(any(ties > 1)) {
        ties <- ties[ties>1]
        correct <- 1-sum(ties^3-ties)/(n.ind^3-n.ind)
      }
      else correct <- 1
      pheno <- rank(pheno)
    }
  }

  results <- NULL

  # starting points for interval mapping
  if(method=="em" && model=="normal") {
    if(is.null(start)) std.start <- 1
    else if(length(start)==1) std.start <- -1
    else std.start <- 0
  }

  # scan genome one chromosome at a time
  for(i in 1:n.chr) {

    chrtype <- class(cross$geno[[i]])
    if(chrtype=="X") sexpgm <- getsex(cross)
    else sexpgm <- NULL

    # get genotype names
    gen.names <- getgenonames(type,chrtype,"full",sexpgm)
    n.gen <- length(gen.names)

    # starting values for interval mapping
    if(method=="em" && model=="normal") {
      this.start <- rep(0,n.gen+1)
      if(std.start == 0) {
        if(length(start) < n.gen+1) 
          stop("Length of start argument should be 0, 1 or ", n.gen+1)
        this.start <- c(start[1:n.gen],start[length(start)])
      }
    }

    # pull out reconstructed genotypes (mr)
    # or imputations (imp)
    # or genotype probabilities (em or hk)
    if(method=="mr" || method=="mr-imp" || method=="mr-argmax") {
      newgeno <- cross$geno[[i]]$data
      newgeno[is.na(newgeno)] <- 0 

      # discard partially informative genotypes
      if(type=="f2" || type=="f2ss") newgeno[newgeno>3] <- 0
      if(type=="4way") newgeno[newgeno>4] <- 0

      # revise X chromosome genotypes
      if(chrtype=="X" && (type=="bc" || type=="f2" || type=="f2ss"))
         newgeno <- reviseXdata(type, "full", sexpgm, geno=newgeno)

      n.pos <- ncol(newgeno)
      map <- cross$geno[[i]]$map
      if(is.matrix(map)) {
        marnam <- colnames(map)
        map <- map[1,]
      }
      else marnam <- names(map)
    }
    else if(method == "imp") {
      if(is.na(match("draws",names(cross$geno[[i]])))) {
        # need to run sim.geno
        warning("First running sim.geno.")
        cross <- sim.geno(cross)
      }

      draws <- cross$geno[[i]]$draws
      n.pos <- ncol(draws)
      n.draws <- dim(draws)[3]

      # revise X chromosome genotypes
      if(chrtype=="X" && (type=="bc" || type=="f2" || type=="f2ss"))
         draws <- reviseXdata(type, "full", sexpgm, draws=draws)

      map <- create.map(cross$geno[[i]]$map,
                        attr(cross$geno[[i]]$draws,"step"),
                        attr(cross$geno[[i]]$draws,"off.end"))
      if(is.matrix(map)) {
        marnam <- colnames(map)
        map <- map[1,]
      }
      else marnam <- names(map)
    }
    else {
      if(is.na(match("prob",names(cross$geno[[i]])))) {
        # need to run calc.genoprob
        warning("First running calc.genoprob.")
        cross <- calc.genoprob(cross)
      }
      genoprob <- cross$geno[[i]]$prob
      n.pos <- ncol(genoprob)

      # revise X chromosome genotypes
      if(chrtype=="X" && (type=="bc" || type=="f2" || type=="f2ss"))
         genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob)

      map <- create.map(cross$geno[[i]]$map,
                        attr(cross$geno[[i]]$prob,"step"),
                        attr(cross$geno[[i]]$prob,"off.end"))
      if(is.matrix(map)) {
        marnam <- colnames(map)
        map <- map[1,]
      }
      else marnam <- names(map)
    }

    # call the C function
    if(method == "mr" || method=="mr-imp" || method=="mr-argmax") 
      z <- .C("R_scanone_mr",
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.integer(newgeno),       # genotype data
              as.double(addcovar),       # additive covariates
              as.integer(n.addcovar),
              as.double(intcovar),       # interactive covariates
              as.integer(n.intcovar),
              as.double(pheno),          # phenotype data
              as.double(weights),        # weights
              result=as.double(rep(0,n.pos*(n.gen+2))),
              PACKAGE="qtl")

    else if(method=="imp") 
      z <- .C("R_scanone_imp",
              as.integer(n.ind),
              as.integer(n.pos),
              as.integer(n.gen),
              as.integer(n.draws),
              as.integer(draws),
              as.double(addcovar),
              as.integer(n.addcovar),
              as.double(intcovar),
              as.integer(n.intcovar),
              as.double(pheno),
              as.double(weights),
              result=as.double(rep(0,n.pos)),
              as.integer(1), # trim (for debugging purposes)
              as.integer(0), # direct (for debugging purposes)
              PACKAGE="qtl")
    
    else if(method=="hk")  # Haley-Knott regression
      z <- .C("R_scanone_hk",
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.double(genoprob),       # genotype probabilities
              as.double(addcovar),         # additive covariates
              as.integer(n.addcovar),
              as.double(intcovar),         # interactive covariates
              as.integer(n.intcovar), 
              as.double(pheno),          # phenotype data
              as.double(weights),
              result=as.double(rep(0,n.pos*(n.gen+2))),
              PACKAGE="qtl")
   
    else if(method=="em" && model=="normal")  # interval mapping
      z <- .C("R_scanone_em",
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.double(genoprob),       # genotype probabilities
              as.double(addcovar),
              as.integer(n.addcovar),
              as.double(intcovar),
              as.integer(n.intcovar),
              as.double(pheno),          # phenotype data
              as.double(weights),
              result=as.double(rep(0,n.pos*(n.gen+2))),
              as.integer(std.start),
              as.double(this.start),
              as.integer(maxit),
              as.double(tol),
              as.integer(0), # debugging trace off 
              PACKAGE="qtl")

    else if(model=="np")  # non-parametric interval mapping
      z <- .C("R_scanone_np",
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.gen),         # number of possible genotypes
              as.double(genoprob),       # genotype probabilities
              as.double(pheno) ,         # phenotype data
              result=as.double(rep(0,n.pos)),
              PACKAGE="qtl")
    
    else  {
      err <- paste("Model", model, "with method", method, "not available")
      stop(err)
    }

    z <- matrix(z$result,nrow=n.pos)

    # interval mapping without covariates:
    #   rescale log likelihood
    if(method!="imp" && n.addcovar > 0)
      z <- z[,1,drop=FALSE]
    if(model == "np" && !ties.random)
      z <- z/correct  # correct for ties

    if(n.addcovar==0 && n.intcovar==0 && method != "imp"
       && model != "np") 
      colnames(z) <- c("lod",gen.names,"sigma")
    else colnames(z) <- c("lod")
      
    w <- marnam
    o <- grep("^loc\-*[0-9]+",w)
    if(length(o) > 0) # inter-marker locations cited as "c*.loc*"
      w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="")
    rownames(z) <- w
    
    z <- as.data.frame(z)
    z <- cbind(chr=rep(names(cross$geno)[i],length(map)),
               pos=as.numeric(map), z)
    rownames(z) <- w


    # get null log10 likelihood
    if(i==1 & model != "np") {
      if(n.addcovar > 0)
        resid0 <- lm(pheno ~ addcovar, weights=weights^2)$resid
      else 
        resid0 <- lm(pheno ~ 1, weights=weights^2)$resid
      if(method=="hk") nllik0 <- (n.ind/2)*log10(sum((resid0*weights)^2))
      else {
        sig0 <- sqrt(sum((resid0*weights)^2)/n.ind)
        nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10)
      }
    }

    # re-scale with null log10 likel for methods em and hk
    if((method=="em" && model=="normal") || method=="hk") 
      z[,3] <- nllik0 - z[,3]


    # get null log10 likelihood for the X chromosome
    if(chrtype=="X") {

      # determine which covariates belong in null hypothesis
      temp <- scanoneXnull(type, sexpgm)
      adjustX <- temp$adjustX
      dfX <- temp$dfX
      sexpgmcovar <- temp$sexpgmcovar
      
      if(adjustX) {
        if(model == "np") {
          sexpgmcovar <- factor(apply(sexpgmcovar,1,paste,collapse=":"))
          nllikX <- kruskal.test(pheno ~ sexpgmcovar)$stat/(2*log(10))
          z[,3] <- z[,3] - nllikX
        }
        else if(method=="mr") {
          for(s in 1:ncol(newgeno)) {
            wh <- newgeno[,s] != 0
            
            if(n.addcovar > 0) {
              residX <- lm(pheno ~ addcovar+sexpgmcovar, weights=weights^2,subset=wh)$resid
              resid0 <- lm(pheno ~ addcovar, weights=weights^2,subset=wh)$resid
            }
            else {
              residX <- lm(pheno ~ sexpgmcovar, weights=weights^2,subset=wh)$resid
              resid0 <- lm(pheno ~ 1, weights=weights^2,subset=wh)$resid
            }
            nllikX <- (sum(wh)/2)*log10(sum((residX*weights[wh])^2))
            nllik0 <- (sum(wh)/2)*log10(sum((resid0*weights[wh])^2))

            # rescale LOD score
            z[s,3] <- z[s,3] + nllikX - nllik0
          }
        }
        else {
          if(n.addcovar > 0) {
            outX <- lm(pheno ~ addcovar+sexpgmcovar, weights=weights^2)
            residX <- outX$resid
            # perhaps revise the dfX, if some columns got dropped
            dfX <- dfX - (ncol(sexpgmcovar)+n.addcovar - (outX$rank-1))
          }
          else 
            residX <- lm(pheno ~ sexpgmcovar, weights=weights^2)$resid

          if(method=="hk") nllikX <- (n.ind/2)*log10(sum((residX*weights)^2))
          else {
            sigX <- sqrt(sum((residX*weights)^2)/n.ind)
            nllikX <- -sum(dnorm(residX,0,sigX/weights,log=TRUE))/log(10)
          }
          # rescale LOD score
          z[,3] <- z[,3] + nllikX - nllik0
        }
      }
    }

    # replace missing or negative LODs with 0
    z[is.na(z[,3]) | z[,3]<0, 3] <- 0

    # if different number of columns from other chromosomes,
    #     expand to match
    if(!is.null(results) && ncol(z) != ncol(results)) {
      cnz <- colnames(z)
      cnr <- colnames(results)
      wh.zr <- match(cnz,cnr)
      wh.rz <- match(cnr,cnz)
      if(all(!is.na(wh.rz))) {
        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=ncol(z)))
        dimnames(newresults) <- list(rownames(results), cnz)
        newresults[,cnr] <- results
        results <- newresults
        for(s in 2:ncol(results))
          if(is.factor(results[,s])) results[,s] <- as.numeric(results[,s])
      }
      else if(all(!is.na(wh.zr))) {
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=ncol(results)))
        dimnames(newz) <- list(rownames(z), cnr)
        newz[,cnz] <- z
        z <- newz
        for(s in 2:ncol(z))
          if(is.factor(z[,s])) z[,s] <- as.numeric(z[,s])
      }
      else {
        newnames <- c(cnr, cnz[is.na(wh.zr)])

        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=length(newnames)))
        dimnames(newresults) <- list(rownames(results), newnames)
        newresults[,cnr] <- results
        results <- newresults
        for(s in 2:ncol(results))
          if(is.factor(results[,s])) results[,s] <- as.numeric(results[,s])
        
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=length(newnames)))
        dimnames(newz) <- list(rownames(z), newnames)
        newz[,cnz] <- z
        z <- newz
        for(s in 2:ncol(z))
          if(is.factor(z[,s])) z[,s] <- as.numeric(z[,s])
      }
    }

    results <- rbind(results,z)
  } # end loop over chromosomes

  # sort the later columns
  neworder <- c(colnames(results)[1:3],sort(colnames(results)[-(1:3)]))
  results <- results[,neworder]

  class(results) <- c("scanone","data.frame")
  attr(results,"method") <- method
  attr(results,"type") <- type
  attr(results,"model") <- model
  results
}


######################################################################
#
# plot.scanone: plot output from scanone
#
######################################################################

plot.scanone <- 
function(x,x2,x3,chr,lodcolumn=3,incl.markers=TRUE,xlim, ylim,
         lty=1,col=c("black","blue","red"),lwd=2,add=FALSE,gap=25,
         main, mtick=c("line", "triangle"), ...)
{
  mtick <- match.arg(mtick)

  if(length(dim(x))!=2)
    stop("Argument x must be a matrix or data.frame.")
  if(!missing(x2) && length(dim(x2))!=2)
    stop("Argument x2 must be a matrix or data.frame.")
  if(!missing(x3) && length(dim(x3))!=2)
    stop("Argument x3 must be a matrix or data.frame.")

  if(length(lodcolumn)==1) 
    lodcolumn <- rep(lodcolumn,3)[1:3]
  else if(length(lodcolumn)==2) {
    if(missing(x2)) x2 <- x
    lodcolumn <- lodcolumn[c(1,2,3)]
  }
  else {
    if(missing(x2)) x2 <- x
    if(missing(x3)) x3 <- x
  }

  second <- third <- TRUE
  if(missing(x2) && missing(x3)) 
     second <- third <- FALSE
  if(missing(x3))
    third <- FALSE
  if(missing(x2))
    second <- FALSE

  # rename things and turn into data frames
  out <- x[,c(1:2,lodcolumn[1])]
  if(second) out2 <- x2[,c(1:2,lodcolumn[2])]
  if(third) out3 <- x3[,c(1:2,lodcolumn[3])]
  if(length(lty)==1) lty <- rep(lty,3)
  if(length(lwd)==1) lwd <- rep(lwd,3)
  if(length(col)==1) col <- rep(col,3)

  # pull out desired chromosomes
  if(missing(chr) || length(chr)==0) 
    chr <- unique(as.character(out[,1]))
  else if(all(chr < 0)) { 
    a <- sort(unique(out[,1]))
    chr <- a[-match(-chr,a)]
  }

  u <- is.na(match(chr,unique(out[,1])))
  if(all(u))
    stop("Chromosome(s) to plot were not matched to those in the scanone output.")
  else if(any(u)) {
    warning(paste("Chromosome(s)",chr[u],"were not found.",sep=" "))
    chr <- chr[!u]
  }

  out <- out[!is.na(match(out[,1],chr)),]
  if(second) out2 <- out2[!is.na(match(out2[,1],chr)),]
  if(third) out3 <- out3[!is.na(match(out3[,1],chr)),]
  
  onechr <- FALSE
  if(length(chr) == 1) {
    gap <- 0
    onechr <- TRUE 
 }

  # beginning and end of chromosomes
  temp <- grep("^c[0-9A-Za-z]+\.loc\-*[0-9]+",rownames(out))
  if(length(temp)==0) temp <- out
  else temp <- out[-temp,]
  begend <- matrix(unlist(tapply(temp[,2],temp[,1],range)),ncol=2,byrow=TRUE)
  rownames(begend) <- unique(out[,1])
  begend <- begend[as.character(chr),,drop=FALSE]
  len <- begend[,2]-begend[,1]

  # locations to plot start of each chromosome
  start <- c(0,cumsum(len+gap))-c(begend[,1],0)

  maxx <- sum(len+gap)-gap
  maxy <- max(out[,3],na.rm=TRUE)
  if(second) maxy <- max(c(maxy,out2[,3]),na.rm=TRUE)
  if(third) maxy <- max(c(maxy,out3[,3]),na.rm=TRUE)

  # graphics parameters
  old.xpd <- par("xpd")
  old.las <- par("las")
  par(xpd=FALSE,las=1)
  on.exit(par(xpd=old.xpd,las=old.las))

  # make frame of plot
  if(missing(ylim)) ylim <- c(0,maxy)
  if(missing(xlim)) xlim <- c(0,maxx)
  
  if(!add) {
    if(onechr) {
      plot(0,0,ylim=ylim,xlim=xlim,type="n",
           xlab="Map position (cM)",ylab=dimnames(out)[[2]][3],
           ...)
    }
    else {
      plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n",
           xlab="",ylab=dimnames(out)[[2]][3],
           ...)
    }
    if(!missing(main)) title(main=main)
  }

  # initialize xtick and xtickmark
  xtick <- NULL
  xticklabel <- NULL
  for(i in 1:length(chr)) {
    # plot first out
    x <- out[out[,1]==chr[i],2]+start[i]
    y <- out[out[,1]==chr[i],3]
    if(length(x)==1) {
      g <- max(gap/10,2)
      x <- c(x-g,x,x+g)
      y <- rep(y,3)
    }
    lines(x,y,lwd=lwd[1],lty=lty[1],col=col[1])
    # plot chromosome number
#    a <- par("usr")
    if(!add && !onechr) {
      tloc <- mean(c(min(x),max(x)))
#      text(tloc,a[3]-(a[4]-a[3])*0.05,as.character(chr[i]))
#      lines(rep(tloc,2),c(a[3],a[3]-(a[4]-a[3])*0.015))
      xtick <- c(xtick, tloc)
      xticklabel <- c(xticklabel, as.character(chr[i]))
    }
    
    # plot second out
    if(second) {
      x <- out2[out2[,1]==chr[i],2]+start[i]
      y <- out2[out2[,1]==chr[i],3]
      if(length(x)==1) {
        g <- max(gap/10,2)
        x <- c(x-g,x,x+g)
        y <- rep(y,3)
      }
      lines(x,y,lty=lty[2],col=col[2],lwd=lwd[2])
    }

    if(third) {
      x <- out3[out3[,1]==chr[i],2]+start[i]
      y <- out3[out3[,1]==chr[i],3]
      if(length(x)==1) {
        g <- max(gap/10,2)
        x <- c(x-g,x,x+g)
        y <- rep(y,3)
      }
      lines(x,y,lty=lty[3],col=col[3],lwd=lwd[3])
    }

    # plot lines or triangles at marker positions
    if(incl.markers && !add) {
      nam <- dimnames(out)[[1]][out[,1]==chr[i]]
#      wh.genoprob <- (seq(along=nam))[grep("^loc\-*[0-9]+",nam)]
      wh.genoprob <- (seq(along=nam))[grep("^c[0-9A-Za-z]+\.loc\-*[0-9]+",nam)]
      if(length(wh.genoprob)==0) wh.genoprob <- seq(along=nam)
      else wh.genoprob <- (seq(along=nam))[-wh.genoprob]
      pos <- out[out[,1]==chr[i],2][wh.genoprob]+start[i]
      if(mtick=="line")
        rug(pos, 0.02, quiet=TRUE)
      else {
        a <- par("usr")
        points(pos, rep(a[3]+diff(a[3:4])*0.04, length(pos)), pch=17, cex=1.5)
      }
      #for(j in pos)
      #  lines(c(j,j),c(a[3],a[3]+(a[4]-a[3])*0.02))
    }
  }
  # draw the axis
  if(!add && !onechr) 
    axis(1, at=xtick, labels=xticklabel)
}

######################################################################
#
# scanone.perm: Permutation test of scanone
#
######################################################################

scanone.perm <-
function(cross, pheno.col=1, model=c("normal","binary","2part","np"),
         method=c("em","imp","hk","mr","mr-imp","mr-argmax"),
         addcovar=NULL, intcovar=NULL, weights=NULL,
         upper=FALSE, ties.random=FALSE,
         start=NULL, maxit=4000, tol=1e-4, n.perm=1000, trace=TRUE)
{
  method <- match.arg(method)
  model <- match.arg(model)

  if(model!="normal" && (!is.null(addcovar) || !is.null(intcovar))) {
    warning("Use of covariates not available for method np")
    addcovar <- intcovar <- NULL
  }

  n.ind <- nind(cross)

  addcovarp <- intcovarp <- NULL
  if(!is.null(addcovar)) addcovar <- as.matrix(addcovar)
  if(!is.null(intcovar)) intcovar <- as.matrix(intcovar)

  if(model=="2part") res <- matrix(ncol=3,nrow=n.perm)
  else res <- 1:n.perm

  if(trace) { # if trace, print out a tracing information
    # rnd: how often to print tracing information
    if(trace > 1) rnd <- 1
    else {
      if(n.perm >= 1000) rnd <- 20
      else if(n.perm >= 100) rnd <- 5
      else rnd <- 1
    }
  }

  if(method=="mr-imp") # save version with missing genotypes 
    tempcross <- cross
  if(method=="mr-argmax") # impute genotypes
    cross <- fill.geno(cross,method="argmax")

  for(i in 1:n.perm) {
    if(trace && i/rnd == round(i/rnd))
      cat("Permutation", i, "\n")

    # impute genotypes for method "mr-imp"
    if(method=="mr-imp") cross <- fill.geno(tempcross)

    o <- sample(1:n.ind)
    cross$pheno <- cross$pheno[o,,drop=FALSE]
    if(!is.null(addcovar)) addcovarp <- addcovar[o,,drop=FALSE]
    if(!is.null(intcovar)) intcovarp <- intcovar[o,,drop=FALSE]
    if(!is.null(weights)) weights <- weights[o]
    tem <- scanone(cross,,pheno.col,model,method,addcovarp,
                   intcovarp,weights,upper,ties.random,start,
                   maxit,tol,n.perm= -1)
    if(model=="2part")
      res[i,] <- apply(tem[,3:5], 2, max,na.rm=TRUE)
    else res[i] <- max(tem[,3],na.rm=TRUE)
  }

  if(model=="2part") colnames(res) <- c("LOD.p.mu", "LOD.p", "LOD.mu")

  attr(res,"method") <- method
  attr(res,"model") <- model
  attr(res,"type") <- class(cross)[1]
  res
}

# give, for each chromosome, the position with the maximum LOD
summary.scanone <-
function(object,threshold=0,...)
{
    
  # first, pick off the maximum from each chromosome
  # this is made complicated to avoid returning multiple rows
  #     from any one chromosome
  out <- lapply(split(object,object[,1]),
                   function(b) {
                     d <- which(b[,3]==max(b[,3]))
                     if(length(d) > 1) d <- median(d)
                     b[d,] }) 
  results <- out[[1]]
  if(length(out) > 1)
    for(i in 2:length(out))
      results <- rbind(results,out[[i]])
  class(results) <- c("summary.scanone","data.frame")

  results[results[,3] >= threshold,]
}

# print output of summary.scanone
print.summary.scanone <-
function(x,...)
{

  if(nrow(x) == 0) {
    cat("    There were no LOD peaks above the threshold.\n")
  }

  else {
    x[,-(1:2)] <- round(data.frame(x[,-(1:2)]),6)
    cat("\n")
    print.data.frame(x,digits=2)
    cat("\n")
  }
}

# pull out maximum LOD peak, genome-wide
max.scanone <-
function(..., chr, na.rm=TRUE)
{
  dots <- list(...)[[1]]
  if(missing(chr)) {
    maxlod <- max(dots[,3],na.rm=TRUE)
    dots <- dots[!is.na(dots[,3]) & dots[,3]==maxlod,]
    return(summary.scanone(dots,0))
  }
  else {
    res <- NULL
    for(i in seq(along=chr)) {
      temp <- dots[dots[,1]==chr[i],]
      maxlod <- max(temp[,3],na.rm=TRUE)
      temp <- temp[!is.na(temp[,3]) & temp[,3]==maxlod,]
      res <- rbind(res,temp)
    }
    return(summary.scanone(res,0))
  }
}

# end of scanone.R
######################################################################
#
# scanqtl.R
#
# copyright (c) 2002-4, Hao Wu, The Jackson Laboratory
#                       and Karl W. Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2002
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: scanqtl
#
######################################################################

scanqtl <-
  function(cross, pheno.col=1, chr, pos, covar=NULL, formula, method=c("imp"),
           incl.markers=FALSE)
{
  # input data checking
  if( !sum(class(cross) == "cross") )
    stop("The first input variable must be  an object of class cross")
  if( length(chr) != length(pos))
    stop("Input chr and pos must have the same length")
  # note that input chr is a vector and pos is a list

  # check the input covariate, if any
  if(!missing(covar)) {
    if(nrow(covar) != nind(cross))
      stop("Input covariate has wrong size")
  }
  # check the input pheno.col
  if(pheno.col>ncol(cross$pheno))
    stop("Wrong phenotype column number")
  
  method <- match.arg(method)

  # if formula is missing, make one.
  # All QTLs and covariates will be additive by default
  n.qtl <- length(chr)
  n.covar <- length(covar)
  if(missing(formula)) {
    tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names
    formula <- "y~Q1"
    if(n.qtl > 1) 
      for (i in 2:n.qtl) 
        formula <- paste(formula, tmp.Q[i], sep="+")
    if (n.covar) { # if covariate is not empty
      tmp.C <- names(covar) # covariate term names
      for(i in 1:n.covar)
        formula <- paste(formula, tmp.C[i], sep="+")
    }
    formula <- as.formula(formula)
  }
  else {
    # include all input QTLs and covariates in the formula additively
    formula.str <- deparse(formula) # deparse formula as a string
    for(i in 1:n.qtl) { # loop thru the QTLs
      qtl.term <- paste("Q", i, sep="")
      if( length(grep(qtl.term, formula.str, ignore.case=TRUE))==0 )
        # this term is not in the formula
        # add it to the formula
        formula.str <- paste(formula.str, qtl.term, sep="+")
    }
    if(n.covar) { # covariate is not empty
      for(i in 1:n.covar) {
        covar.term <- names(covar)[i]
        if( length(grep(covar.term, formula.str, ignore.case=TRUE))==0 )
        # this term is not in the formula
        # add it to the formula
          formula.str <- paste(formula.str, covar.term, sep="+")
      }
    }
    formula <- as.formula(formula.str)
  }
  
  # find the chromosome with multiple QTLs
  # indices for chromosomes with multiple QTLs
  idx.varied <- NULL
  for(i in 1:length(pos)) {
    l <- length(pos[[i]] )
    if( l >= 2 ) {
      # if there're more than two elements in pos, issue warning message
      if(l > 2) {
        msg <- "There are more than two elements in "
        msg <- paste(msg, i, "th input pos.")
        msg <- paste(msg, "The first two are taken as starting and ending position.")
        warning(msg)
      }

      # user specified a range
      # find all markers in this range
      idx.varied <- c(idx.varied, i) 
      # make the genetic map on this chromosome
      i.chr <- which(chr[i]==names(cross$geno))
      if(length(i.chr) == 0) { # no this chromosome in cross
        err <- paste("There's no chromosome number ", chr[i], "in input cross object")
        stop(err)
      }
      if(!("draws" %in% names(cross$geno[[1]]))) # there's no draw in input cross object
        stop("You need to first run sim.geno().")
      # make genetic map
      map <- create.map(cross$geno[[i.chr]]$map,
                        attr(cross$geno[[i.chr]]$draws,"step"),
                        attr(cross$geno[[i.chr]]$draws,"off.end"))
      if(!incl.markers) { # equally spaced positions
        step <- attr(cross$geno[[i.chr]]$draws,"step")
        eq.sp.pos <- seq(min(map), max(map), by=step)
        wh.eq.pos <- match(eq.sp.pos, map)
        map <- map[wh.eq.pos]
      }

      # locate the markers given starting and ending postion
      # we should do this before or after incl.markers?
      start <- pos[[i]][1]
      end <- pos[[i]][2]
      # replace pos[[i]] (a range) by the marker positions within the range
      # extend the position to the nearest markers outside the ranges
      tmp <- which( (map - start)<0 )
      if(length(tmp) != 0) # starting position is after the first marker
        start <- map[max(tmp)]
      tmp <- which( (end-map) < 0 )
      if(length(tmp) != 0) # ending position is before the last marker
        end <- map[min(tmp)]
      pos[[i]] <- as.vector( map[(map>=start)&(map<=end)] )


    }
    else { # fixed position rather than range
# Hao asked me to comment these two lines out      
#      pos[[i]] <- locatemarker(cross$geno[[as.character(chr[i])]]$map,
#                               pos[[i]], chr[i], "draws")
    }
  }
  # Now, pos contains all the marker positions for all chromosomes
                  
  #########################
  # Now start general scan
  #########################
  # There might be severl chromosomes with multiple QTLs
  # Use one loop
  
  # number of chromosomes with multiple positions to be scanned
  n.idx.varied <- length(idx.varied) 
  n.loop <- 1 # total number of loops
  if(n.idx.varied != 0) { # there IS some chromosomes with multiple QTL
    # vector to indicate the positions indices for those chromosomes
    idx.pos <- rep(0, n.idx.varied)
    l.varied <- NULL
    for(i in 1:n.idx.varied) {
      l.varied[i] <- length(pos[[idx.varied[i]]])
      n.loop <- n.loop * l.varied[i]
    }
    # initialize output variable
    result <- array(rep(0, n.loop), rev(l.varied))
  }
  else { # fixed QTL model (no scanning)
    qtl <- makeqtl(cross, chr=chr, pos=unlist(pos))
    result <- fitqtl(cross$pheno[,pheno.col], qtl, covar=covar,
                     formula=formula, method=method, dropone=FALSE)
    result <- result[1]
    names(result) <- "LOD"
    class(result) <- "scanqtl"
    attr(result, "method") <- method
    attr(result, "formula") <- formula
    return(result)
  }

  # loop thru all varied QTLs
  for(i in 1:n.loop) {
    # find the indices for positions
    remain <- i
    if(n.idx.varied > 1) {
      for(j in 1:(n.idx.varied-1)) {
        ns <- 1
        for( k in (j+1):n.idx.varied )
          ns <- ns * length(pos[[idx.varied[k]]])
        idx.pos[j] <- floor(remain / ns) + 1
        remain <- remain - (idx.pos[j]-1) * ns
        # remain cannot be zero
        if(remain == 0) {
          idx.pos[j] <- idx.pos[j] - 1
          remain <- remain + ns
        }
      }
    }
    idx.pos[n.idx.varied] <- remain

    # make an QTL object 
    pos.tmp <- NULL
    for(j in 1:length(pos)) {
      if(j %in% idx.varied) {
        idx.tmp <- which(j==idx.varied)
        pos.tmp <- c(pos.tmp, pos[[j]][idx.pos[idx.tmp]])
      }
      else
        pos.tmp <- c(pos.tmp, pos[[j]])
    }

    # make QTL object
    # currently we make a new qtl object for each iteration
    # makeqtl is ridiculously slow. Needs think to use
    # replace.qtl instead
    qtl.obj <- makeqtl(cross, chr, pos.tmp)
    # fit QTL, don't do drop one at a time

    fit <- fitqtl(cross$pheno[,pheno.col], qtl=qtl.obj, covar=covar,
                   formula=formula, method=method, dropone=FALSE)
  
    # assign to result matrix
    #     Note: [[1]][1,4] picks out the LOD score 
    result[i] <- fit[[1]][1,4]
  }

  # make the row and column names for the result matrix
  dnames <- list(NULL)
  for(i in 1:n.idx.varied) {
    i.chr <- chr[idx.varied[n.idx.varied-i+1]]
    i.pos <- pos[[idx.varied[n.idx.varied-i+1]]]
    dnames[[i]] <- paste( paste("Chr", i.chr,sep=""),
                            i.pos, sep="@")
  }
  dimnames(result) <- dnames
  
  class(result) <- "scanqtl"
  attr(result, "method") <- method
  attr(result, "formula") <- formula
  result
}


#summary.scanqtl <- function(object, ...)
#{
#}

#print.summary.qtl <- function(x, ...)
#{
#}

# end of scanqtl.R
######################################################################
#
# scantwo.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University,
#            Hao Wu, and Brian Yandell
# last modified Sep, 2004
# first written Nov, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Hao Wu (The Jackson Lab) wrote the initial code for the imputation
# method and summary.scantwo functions.  Brian Yandell made further
# modifications/enhancements to summary.scantwo, but Karl re-wrote
# most of it later.
#
# Part of the R/qtl package
# Contains: scantwo, scantwo.perm, summary.scantwo
#           print.summary.scantwo, max.scantwo
#
######################################################################

######################################################################
#
# scantwo: Do 2-dimensional genome scan with a two-QTL model,
#          calculating joint LOD scores and LOD scores testing
#          epistasis.
#
######################################################################

scantwo <-
function(cross, chr, pheno.col=1,
         method=c("em","imp","hk","mr","mr-imp","mr-argmax"),
         addcovar=NULL, intcovar=NULL, weights=NULL,
         run.scanone=TRUE, incl.markers=FALSE, maxit=4000, tol=1e-4,
         trace=TRUE, n.perm)
{
  method <- match.arg(method)
  
  origcross <- cross

  # pull out chromosomes to be scanned
  if(!missing(chr)) cross <- subset(cross,chr=chr)
  if(missing(n.perm)) n.perm <- 0

  # check phenotypes and covariates; drop individuals with missing values
  # in case of permutation test, only do checks once
  if(n.perm>=0) { 
    temp <- checkcovar(cross, pheno.col, addcovar, intcovar)
    cross <- temp[[1]]
    pheno <- temp[[2]]
    addcovar <- temp[[3]]
    intcovar <- temp[[4]]
    n.addcovar <- temp[[5]]
    n.intcovar <- temp[[6]]
  }
  else {
    pheno <- cross$pheno[,pheno.col]
    if(is.null(addcovar)) n.addcovar <- 0
    else n.addcovar <- ncol(addcovar)
    if(is.null(intcovar)) n.intcovar <- 0
    else n.intcovar <- ncol(intcovar)
  }
  n.chr <- nchr(cross)
  n.ind <- nind(cross)
  type <- class(cross)[1]
  chrtype <- sapply(cross$geno,class)

  # Problems with EX w/ X chromosome: just use H-K for now.
  if(any(chrtype=="X") && method=="em") {
    sexpgm <- getsex(cross)
    if(!is.null(sexpgm$sex) || !is.null(sexpgm$pgm)) {
      warning("EM not working for X chromosomes; using H-K instead.")
      method <- "hk"
    }
  }

  # if n.perm specified, do a permutation test
  if(n.perm>0) { 
    return(scantwo.perm(cross, pheno.col, method, addcovar,
                        intcovar, weights, incl.markers,
                        maxit, tol, trace, n.perm))
  }

  if(n.perm == 0) { # not in the midst of permutations
    if(method=="mr-argmax")
      cross <- fill.geno(cross,method="argmax")
    if(method=="mr-imp")
      cross <- fill.geno(cross,method="imp")
  }

  # weights of individuals
  if(is.null(weights))
    weights <- rep(1, nind(cross))
  if(length(weights) != nind(cross))
    stop("weights should either be NULL or a vector of length n.ind")
  if(any(weights) <= 0)
    stop("weights should be entirely positive")
  weights <- sqrt(weights)

  if(run.scanone) { # also do scanone
    if(trace) cat(" --Running scanone\n")
    temp <- scanone(cross, pheno.col=pheno.col, method=method,
                    addcovar=addcovar, intcovar=intcovar, weights=weights,
                    maxit=maxit, tol=tol, trace=FALSE)
    nam <- rownames(temp)
    out.scanone <- temp[,3]
    names(out.scanone) <- nam
    if(trace) cat(" --Running scantwo\n")
  }

  if(method=="mr" || method=="mr-imp" || method=="mr-argmax") { # marker regression
    # number of genotypes on each chromosome, 
    #     combine the genetic maps for all chromosomes
    map <- unlist(pull.map(cross))
    names(map) <- unlist(lapply(pull.map(cross),names))
    n.pos <- nmar(cross)
    gmap <- data.frame(chr=rep(names(cross$geno),n.pos),
                       pos=map,
                       eq.spacing=rep(1,sum(n.pos)),
                       xchr=rep(sapply(cross$geno,class)=="X",nmar(cross)))

    # number of possible genotypes for each chromosome
    n.gen <- 1:n.chr
    for(i in 1:n.chr) { 
      if(chrtype[i]=="X") sexpgm <- getsex(cross)
      else sexpgm <- NULL

      gen.names <- getgenonames(type, chrtype[i], "full", sexpgm)
      n.gen[i] <- length(gen.names)
    }
  } # end of if(method=="mr")

  else { # all methods except "mr"
    # check for genotype probabilities or simulated genotypes
    steps <- rep(0,n.chr) # step length on each chromosome
    if(method=="imp") {
      for(i in 1:n.chr) {
        if(is.na(match("draws",names(cross$geno[[i]])))) {
          # need to run sim.geno
          warning("First running sim.geno.")
          cross <- sim.geno(cross)
        }
        steps[i] <- attr(cross$geno[[i]]$draws,"step")
      }

      # make sure all chromosomes have the same number of imputations
      n.draws <- sapply(cross$geno, function(a) dim(a$draws)[3])
      if(length(unique(n.draws)) > 1) {
        warning("Re-running sim.geno to have a fixed number of imputations.")
        cross <- sim.geno(cross, n.draws=max(n.draws),
                          step=attr(cross$geno[[1]]$draws,"step"),
                          off.end=attr(cross$geno[[1]]$draws,"off.end"))
      }
      n.draws <- max(n.draws)
    }
    else { # H-K or EM
      for(i in 1:n.chr) {
        if(is.na(match("prob",names(cross$geno[[i]])))) {
          # need to run calc.genoprob
          warning("First running calc.genoprob.")
          cross <- calc.genoprob(cross)
        }
        steps[i] <- attr(cross$geno[[i]]$prob,"step")
      }
    }

    # number of genotypes on each chromosome, 
    #     construct the genetic map for all chromosomes
    #     and possibly drop marker positions
    gmap <- NULL
    n.pos <- n.gen <- rep(0,n.chr) 
    keep.pos <- vector("list",n.chr)
    some.dropped <- rep(FALSE,n.chr)

    for(i in 1:n.chr) { 
      if(chrtype[i]=="X") sexpgm <- getsex(cross)
      else sexpgm <- NULL

      gen.names <- getgenonames(type, chrtype[i], "full", sexpgm)
      n.gen[i] <- length(gen.names)

      # construct the genetic map for this chromesome
      if(method=="imp") 
        map <- create.map(cross$geno[[i]]$map,
                          attr(cross$geno[[i]]$draws,"step"),
                          attr(cross$geno[[i]]$draws,"off.end"))
      else
        map <- create.map(cross$geno[[i]]$map,
                          attr(cross$geno[[i]]$prob,"step"),
                          attr(cross$geno[[i]]$prob,"off.end"))

      if(is.matrix(map)) map <- map[1,] # in case of sex-specific map
  
      w <- names(map)
      o <- grep("^loc\-*[0-9]+",w)

      if(length(o) > 0) # inter-marker locations cited as "c*.loc*"
        w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="")
      map <- cbind(chr=rep(names(cross$geno)[i],length(map)),
                   pos=as.data.frame(map) )
      rownames(map) <- w 

      # equally spaced positions
      if(steps[i]==0)  # just use markers
        eq.sp.pos <- rep(1,nrow(map))
      else {
        eq.sp.pos <- seq(min(map[,2]),max(map[,2]),by=steps[i])
        wh.eq.sp <- match(eq.sp.pos,map[,2])
        if(any(is.na(wh.eq.sp))) { # this shouldn't happen
          warning("Possible error in determining the equally spaced positions.")
          wh.eq.sp <- wh.eq.sp[!is.na(wh.eq.sp)]
        }
        eq.sp.pos <- rep(0,nrow(map))
        eq.sp.pos[wh.eq.sp] <- 1
      }
      if(!incl.markers && any(eq.sp.pos==0)) {
        keep.pos[[i]] <- (seq(along=eq.sp.pos))[eq.sp.pos==1]
        map <- map[eq.sp.pos==1,]
        eq.sp.pos <- eq.sp.pos[eq.sp.pos==1]
        some.dropped[i] <- TRUE # indicates some positions were dropped
      }
      else keep.pos[[i]] <- seq(along=eq.sp.pos)
      gmap <- rbind(gmap, cbind(map,eq.spacing=eq.sp.pos,
                                xchr=(class(cross$geno[[i]])=="X")))
      n.pos[i] <- length(keep.pos[[i]])

      # Revise X chromosome genotype probabilities or imputations 
      if(chrtype[i]=="X" && (type=="bc" || type=="f2" || type=="f2ss")) {
        if(method=="imp") 
          cross$geno[[i]]$draws <-
            reviseXdata(type, "full", sexpgm, draws=cross$geno[[i]]$draws)
        else if(method=="hk" || method=="em") {
          oldXchr <- subset(cross, chr=i)
          cross$geno[[i]]$prob <-
            reviseXdata(type, "full", sexpgm, prob=cross$geno[[i]]$prob)
        }
        else 
          cross$geno[[i]]$data <-
            reviseXdata(type, "full", sexpgm, data=cross$geno[[i]]$data)
      }

    } # end loop over chromosomes
  } # end of if/else for method="mr" vs other 

  # columns in result matrix for each chromosome
  wh.col <- vector("list",n.chr)
  first.pos <- cumsum(c(1,n.pos))
  for(i in 1:n.chr)
    wh.col[[i]] <- seq(first.pos[i],by=1,length=n.pos[i])

  # initialize the results matrix
  results <- matrix(0,ncol=sum(n.pos), nrow=sum(n.pos))

  # do the 2-dimensional genome scan
  for(i in 1:n.chr) { # loop over the 1st chromosome
    for(j in i:n.chr) { # loop over the 2nd chromosome

      # print the current working pair
      if(trace) cat(paste(" (", names(cross$geno)[i], ",",
                          names(cross$geno)[j],")\n",sep=""))

      if(method=="imp") {
        z <- .C("R_scantwo_imp",
                as.integer(n.ind),
                as.integer(i==j),
                as.integer(n.pos[i]),
                as.integer(n.pos[j]),
                as.integer(n.gen[i]),
                as.integer(n.gen[j]),
                as.integer(n.draws),
                as.integer(cross$geno[[i]]$draws[,keep.pos[[i]],]),
                as.integer(cross$geno[[j]]$draws[,keep.pos[[j]],]),
                as.double(addcovar),
                as.integer(n.addcovar),
                as.double(intcovar),
                as.integer(n.intcovar),
                as.double(pheno),
                as.double(weights),
                result=as.double(rep(0,2*n.pos[i]*n.pos[j])),
                PACKAGE="qtl")
        z <- array(z$result,dim=c(n.pos[i], n.pos[j], 2)) # rearrange the result 

        # update the final result matrix
        results[wh.col[[i]],wh.col[[j]]] <- z[,,1]
        if(i != j) results[wh.col[[j]],wh.col[[i]]] <- t(z[,,2])
        else { # do this just once: do null model and get neg log10 likelihood
          if(i==1) { 
            if(n.addcovar > 0)
              resid0 <- lm(pheno ~ addcovar, weights=weights^2)$resid
            else
              resid0 <- lm(pheno ~ 1, weights=weights^2)$resid
            sig0 <- sqrt(sum((resid0*weights)^2)/n.ind)
            nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10)
          }
        }
      }
      else if(method=="hk" || method=="em") {
        if(i==j) { # same chromosome

          if(i==1) { # first time! do null model and get neg log10 likelihood
            if(n.addcovar > 0)
              resid0 <- lm(pheno ~ addcovar, weights=weights^2)$resid
            else
              resid0 <- lm(pheno ~ 1, weights=weights^2)$resid
            if(method=="hk") nllik0 <- (n.ind/2)*log10(sum((resid0*weights)^2))
            else {
              sig0 <- sqrt(sum((resid0*weights)^2)/n.ind)
              nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10)
            }
          }


          if(trace>1) cat("  --Calculating joint probs.\n")

          if(chrtype[i]=="X" && (type=="bc" || type=="f2" || type=="f2ss")) {
            # calculate joint genotype probabilities for all pairs of positions
            stp <- attr(oldXchr$geno[[1]]$prob, "step")
            oe <- attr(oldXchr$geno[[1]]$prob, "off.end")
            err <- attr(oldXchr$geno[[1]]$prob, "error.prob")
            mf <- attr(oldXchr$geno[[1]]$prob, "map.function")

            temp <- calc.pairprob(oldXchr,stp,oe,err,mf)
          }
          else {
            # calculate joint genotype probabilities for all pairs of positions
            stp <- attr(cross$geno[[i]]$prob, "step")
            oe <- attr(cross$geno[[i]]$prob, "off.end")
            err <- attr(cross$geno[[i]]$prob, "error.prob")
            mf <- attr(cross$geno[[i]]$prob, "map.function")

            temp <- calc.pairprob(subset(cross,chr=i),stp,oe,err,mf)
          }

          # pull out positions from genotype probs
          if(some.dropped[i]) {
            # figure out pos'ns corresponding to columns of temp
            nc <- ncol(cross$geno[[i]]$prob)
            ind <- matrix(rep(1:nc,nc),ncol=nc)
            w <- lower.tri(ind)
            ind <- cbind(first=t(ind)[w],second=ind[w])

            # which part to keep
            keep <- apply(ind,1,function(a,b) all(!is.na(match(a,b))),
                          keep.pos[[i]])
            temp <- temp[,keep,,]
          }

          # revise pair probilities for X chromosome
          if(chrtype[i]=="X" && (type=="bc" || type=="f2" || type=="f2ss")) {
            temp <- reviseXdata(type, "full", sexpgm, pairprob=temp)
            temp[temp==0] <- 1e-5 # << temp fix for problems with X chromosome
          }

          if(trace>1) cat("  --Done.\n")

          if(method=="hk") 
            z <- .C("R_scantwo_1chr_hk", 
                    as.integer(n.ind),
                    as.integer(n.pos[i]),
                    as.integer(n.gen[i]),
                    as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]),
                    as.double(temp),
                    as.double(addcovar),
                    as.integer(n.addcovar),
                    as.double(intcovar),
                    as.integer(n.intcovar),
                    as.double(pheno),
                    as.double(weights),
                    result=as.double(rep(0,n.pos[i]^2)),
                    PACKAGE="qtl")
          else
            z <- .C("R_scantwo_1chr_em", 
                    as.integer(n.ind),
                    as.integer(n.pos[i]),
                    as.integer(n.gen[i]),
                    as.double(temp),
                    as.double(addcovar),
                    as.integer(n.addcovar),
                    as.double(intcovar),
                    as.integer(n.intcovar),
                    as.double(pheno),
                    as.double(weights),
                    result=as.double(rep(0,n.pos[i]^2)),
                    as.integer(maxit),
                    as.double(tol),
                    as.integer(trace),
                    PACKAGE="qtl")

          rm(temp) # remove the joint genotype probabilities

          # re-organize results
          results[wh.col[[i]],wh.col[[i]]] <-
            matrix(z$result,ncol=n.pos[i])
        } # end same chromosome
        else {
          if(method=="hk")
            z <- .C("R_scantwo_2chr_hk",
                    as.integer(n.ind),
                    as.integer(n.pos[i]),
                    as.integer(n.pos[j]),
                    as.integer(n.gen[i]),
                    as.integer(n.gen[j]),
                    as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]),
                    as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]),
                    as.double(addcovar),
                    as.integer(n.addcovar),
                    as.double(intcovar),
                    as.integer(n.intcovar),
                    as.double(pheno),
                    as.double(weights),
                    full=as.double(rep(0,n.pos[i]*n.pos[j])),
                    int=as.double(rep(0,n.pos[i]*n.pos[j])),
                    PACKAGE="qtl")
          else 
            z <- .C("R_scantwo_2chr_em",
                    as.integer(n.ind),
                    as.integer(n.pos[i]),
                    as.integer(n.pos[j]),
                    as.integer(n.gen[i]),
                    as.integer(n.gen[j]),
                    as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]),
                    as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]),
                    as.double(addcovar),
                    as.integer(n.addcovar),
                    as.double(intcovar),
                    as.integer(n.intcovar),
                    as.double(pheno),
                    as.double(weights),
                    full=as.double(rep(0,n.pos[i]*n.pos[j])),
                    int=as.double(rep(0,n.pos[i]*n.pos[j])),
                    as.integer(maxit),
                    as.double(tol),
                    as.integer(trace),
                    PACKAGE="qtl")

          results[wh.col[[j]],wh.col[[i]]] <-
            t(matrix(z$full,ncol=n.pos[j]))
          results[wh.col[[i]],wh.col[[j]]] <-
            matrix(z$int,ncol=n.pos[j])
        } # end same chromosome
      }
      else { # marker regression
        # replace missing and partially informative genotypes with 0's
        datai <- cross$geno[[i]]$data
        datai[is.na(datai)] <- 0
        if(type=="f2" || type=="f2ss") datai[datai>3] <- 0
        else if(type=="4way") datai[datai>4] <- 0

        if(i==j) { # same chromosome

          z <- .C("R_scantwo_1chr_mr",
                  as.integer(n.ind),
                  as.integer(n.pos[i]),
                  as.integer(n.gen[i]),
                  as.integer(datai),
                  as.double(addcovar),
                  as.integer(n.addcovar),
                  as.double(intcovar),
                  as.integer(n.intcovar),
                  as.double(pheno),
                  as.double(weights),
                  result=as.double(rep(0,n.pos[i]^2)),
                  PACKAGE="qtl")

          # re-organize results
          results[wh.col[[i]],wh.col[[i]]] <-
            matrix(z$result,ncol=n.pos[i])
        } # end same chromosome
        else {
          
          # replace missing and partially informative genotypes with 0's
          dataj <- cross$geno[[j]]$data
          dataj[is.na(dataj)] <- 0
          if(type=="f2" || type=="f2ss") dataj[dataj>3] <- 0
          else if(type=="4way") dataj[dataj>4] <- 0

          z <- .C("R_scantwo_2chr_mr",
                  as.integer(n.ind),
                  as.integer(n.pos[i]),
                  as.integer(n.pos[j]),
                  as.integer(n.gen[i]),
                  as.integer(n.gen[j]),
                  as.integer(datai),
                  as.integer(dataj),
                  as.double(addcovar),
                  as.integer(n.addcovar),
                  as.double(intcovar),
                  as.integer(n.intcovar),
                  as.double(pheno),
                  as.double(weights),
                  full=as.double(rep(0,n.pos[i]*n.pos[j])),
                  int=as.double(rep(0,n.pos[i]*n.pos[j])),
                  PACKAGE="qtl")

          results[wh.col[[j]],wh.col[[i]]] <-
            t(matrix(z$full,ncol=n.pos[j]))
          results[wh.col[[i]],wh.col[[j]]] <-
            matrix(z$int,ncol=n.pos[j])
        } # end same chromosome
      }
    
    } # end loop over second chr
  } # end loop over first chromosome

  if(method=="hk" || method=="em") # subtr null neg log lik from lower tri
    results[lower.tri(results)] <- nllik0 - results[lower.tri(results)]


  # If the X chromosome was included, need to do an adjustment...
  scanoneX <- NULL
  if(any(gmap[,4])) { # the X chromosome was included

    # determine which covariates belong in null hypothesis
    temp <- scanoneXnull(type, sexpgm)
    adjustX <- temp$adjustX
    dfX <- temp$dfX
    sexpgmcovar <- temp$sexpgmcovar
      
    if(adjustX) {
      if(method=="mr") {
        warning("The X chr may not be working properly for scantwo with method mr.") 
      }
      else {
        if(n.addcovar > 0) {
          outX <- lm(pheno ~ addcovar+sexpgmcovar, weights=weights^2)
          residX <- outX$resid
          # perhaps revise the dfX, if some columns got dropped
          dfX <- dfX - (ncol(sexpgmcovar)+n.addcovar - (outX$rank-1))
        }
        else 
          residX <- lm(pheno ~ sexpgmcovar, weights=weights^2)$resid

        if(method=="hk") nllikX <- (n.ind/2)*log10(sum((residX*weights)^2))
        else {
          sigX <- sqrt(sum((residX*weights)^2)/n.ind)
          nllikX <- -sum(dnorm(residX,0,sigX/weights,log=TRUE))/log(10)
        }

        wh <- ((gmap[row(results),4] | gmap[col(results),4]) & lower.tri(results))
        results[wh] <- results[wh] + nllikX - nllik0

        if(run.scanone) {
          if(trace) cat(" --Running scanone with special X chr covariates\n")

          notxchr <- which(sapply(cross$geno,class)!="X")
          if(length(notxchr) > 0) {
            temp <- scanone(subset(cross,chr=notxchr),
                            pheno.col=pheno.col, method=method,
                            addcovar=cbind(addcovar,sexpgmcovar),
                            intcovar=intcovar, weights=weights,
                            maxit=maxit, tol=tol, trace=FALSE)


            nam <- rownames(temp)
            scanoneX <- temp[,3]
            names(scanoneX) <- nam

            scanoneX <- c(scanoneX,out.scanone[rownames(gmap)][gmap[,4]])
            scanoneX <- scanoneX[rownames(gmap)]
          }
          else {
            scanoneX <- out.scanone[rownames(gmap)][gmap[,4]]
            scanoneX <- scanoneX[rownames(gmap)]
          }
        }
      }
    }
  }
  

  if(any(is.na(results) | results < -1e-6 | results == Inf))
    warning("Some LOD scores NA, Inf or < 0")
  
  # output has 2 fields, lod and map
  out <- list(lod=results,map=gmap,scanoneX=scanoneX)
  class(out) <- "scantwo"

  if(run.scanone) # also did scanone
    diag(out$lod) <- out.scanone[rownames(out$map)]

  attr(out,"method") <- method
  attr(out,"type") <- type
  out
}

######################################################################
#
# scantwo.perm: Permutation test of scantwo
#
######################################################################

scantwo.perm <-
function(cross, pheno.col=1,
         method=c("em","imp","hk","mr","mr-imp","mr-argmax"),
         addcovar=NULL, intcovar=NULL, weights=NULL,
         incl.markers=FALSE, maxit=4000, tol=1e-4, trace=FALSE,
         n.perm=1000) 
{
  method <- match.arg(method)

  n.ind <- nind(cross)
  addcovarp <- intcovarp <- NULL
  if(!is.null(addcovar)) addcovar <- as.matrix(addcovar)
  if(!is.null(intcovar)) intcovar <- as.matrix(intcovar)

  if(method=="mr-imp") # save version with missing genotypes 
    tempcross <- cross
  if(method=="mr-argmax") # impute genotypes
    cross <- fill.geno(cross,method="argmax")

  # initialize the result matrix
  # the first row is for full model comparison
  # the second row is for additive model comparison
  res <- matrix(ncol=2,nrow=n.perm)
  for(i in 1:n.perm) {
    if(trace) cat("Permutation", i, "\n")

    # impute genotypes for method "mr-imp"
    if(method=="mr-imp") cross <- fill.geno(tempcross)

    o <- sample(1:n.ind)
    cross$pheno <- cross$pheno[o,,drop=FALSE]
    if(!is.null(addcovar)) addcovarp <- addcovar[o,,drop=FALSE]
    if(!is.null(intcovar)) intcovarp <- intcovar[o,,drop=FALSE]
    tem <- scantwo(cross,  pheno.col=pheno.col,
                   method=method, addcovar=addcovarp,
                   intcovar=intcovarp, incl.markers=incl.markers,
                   weights=weights, run.scanone=FALSE, maxit=maxit,
                   tol=tol, trace=FALSE, n.perm = -1)

    # take max of the two triangles
    res[i,1] <- max( tem$lod[tem$lod < Inf & row(tem$lod)>col(tem$lod)], na.rm=TRUE )
    res[i,2] <- max( tem$lod[tem$lod < Inf & row(tem$lod)<col(tem$lod)], na.rm=TRUE )
  }
  colnames(res) <- c("LOD.jnt","LOD.interxn")
  attr(res,"method") <- method
  res
}


######################################################################
#
# summerize the result from scantwo
#
######################################################################
summary.scantwo <-
function (object, thresholds = c(0, 0, 0),
          type = c("joint","interaction"), ...)
{
  type <- match.arg(type)
  
  if(length(thresholds) < 3) {
    if(length(thresholds) == 1) thresholds <- c(thresholds, 0, 0)
    else stop("You must give three thresholds: full, interaction and main\n")
  }

  thrfull <- thresholds[1]
  thrint <- thresholds[2]
  thrcond <- thresholds[3]

  lod <- object$lod
  map <- object$map

  # backward compatibility for previous version of R/qtl
  if(is.na(match("scanoneX",names(object)))) {
    warning("It would be best to re-run scantwo() with the R/qtl version 0.98 or later.")
    scanoneX <- NULL
  }
  else scanoneX <- object$scanoneX

  # deal with bad LOD score values
  if(any(is.na(lod) | lod < -1e-06 | lod == Inf)) 
    warning("Some LOD scores NA, Inf or < 0; set to 0")
  lod[is.na(lod) | lod < 0 | lod == Inf] <- 0

  # if there's no mainscan result, ignore the thresholds
  #     and don't include the 4 conditional LOD columns
  if(all(is.na(diag(lod)) | diag(lod) < 1e-10)) 
    includes.scanone <- FALSE
  else includes.scanone <- TRUE

  # If scanone results available, calculate conditional LOD scores
  if(includes.scanone) {
    d <- diag(lod)
    q1 <- matrix(rep(d,length(d)),ncol=length(d))
    q2 <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE)

    if(!is.null(scanoneX) && any(map[,4])) {
      d <- scanoneX
      q1X <- matrix(rep(d,length(d)),ncol=length(d))
      q2X <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE)
      q1[map[,4],] <- q1X[map[,4],]
      q2[,map[,4]] <- q2X[,map[,4]]
    }

    q1[lower.tri(q1)] <- t(q2)[lower.tri(q2)]
    condlod <- abs(lod - t(lod)) - q1
    diag(condlod) <- 0
  }
  else condlod <- NULL

  # Negative thresholds are interpreted relative to the maximum LOD score
  if(thrfull < 0) 
    thrfull <- max(0,max(lod[lower.tri(lod)]) + thrfull)
  if(thrint < 0) 
    thrint <- max(0,max(lod[upper.tri(lod)]) + thrint)
  if(thrcond < 0 && includes.scanone)
    thrcond <- max(0,max(condlod) + thrcond)
  
  crosstype <- attr(object, "type")
  if(is.null(crosstype)) {
    warning("No type attribute in input data; assuming backcross.")
    crosstype <- "bc"
  }

  # calculate the degree of freedom
  if(crosstype == "bc" || crosstype == "riself" || crosstype == 
      "risib") {
    df.int <- 1
    df.add <- 1
  }
  else if(crosstype == "f2") {
    df.int <- 4
    df.add <- 2
  }
  else if(crosstype == "4way") {
    df.int <- 9
    df.add <- 3
  }
  else {
    stop("Don't know what to do with cross type ", crosstype)
  }

  # chromsomes in the result
  chr <- unique(map[, 1])
  n.chr <- length(chr)

  # calculate the locations of each chromosome within the LOD matrix
  wh.index <- vector("list", n.chr)
  n <- nrow(map)
  for(i in 1:n.chr)
    wh.index[[i]] <- which(map[, 1] == chr[i])

  results <- NULL

  # go through each pair of chromosomes
  for(i in 1:n.chr) {
    for(j in i:n.chr) { 
      tmplod1 <- lod[wh.index[[j]], wh.index[[i]]]
      if(!is.null(condlod)) {
        if(i==j) tmpcondlod <- condlod[wh.index[[i]],wh.index[[i]]]
        else {
          tmpcondlod1 <- condlod[wh.index[[j]],wh.index[[i]]]
          tmpcondlod2 <- condlod[wh.index[[i]],wh.index[[j]]]
        }
      }

      if(i != j) tmplod2 <- lod[wh.index[[i]], wh.index[[j]]]
      else tmplod2 <- tmplod1
      

      if(type == "joint") {
        if(i == j) {
          tri <- lower.tri(tmplod1)
          lod.joint <- max(tmplod1[tri])
          idx <- which(tmplod1 == lod.joint & tri, arr.ind=TRUE)
        }
        else {
          lod.joint <- max(tmplod1)
          idx <- which(tmplod1 == lod.joint, arr.ind=TRUE)
        }
        if(nrow(idx)>1) idx <- idx[sample(nrow(idx),1),]
        idx.row <- idx[1]
        idx.col <- idx[2]
        
        lod.int <- tmplod2[idx.col, idx.row]
      }
      else { # interaction lod
        if(i == j) {
          tri <- upper.tri(tmplod2)
          lod.int <- max(tmplod2[tri])
          idx <- which(tmplod2 == lod.int & tri, arr.ind=TRUE)
        }
        else {
          lod.int <- max(tmplod2)
          idx <- which(tmplod2 == lod.int)
        }
        if(nrow(idx)>1) idx <- idx[sample(nrow(idx),1),]
        idx.row <- idx[2]
        idx.col <- idx[1]
        
        lod.joint <- tmplod1[idx.row, idx.col]
      }
      
      full.idx.row <- idx.row + wh.index[[j]][1] - 1
      full.idx.col <- idx.col + wh.index[[i]][1] - 1

      if(lod.joint >= thrfull) {
        if(includes.scanone) {
          if(i==j) {
            lod.q1 <- tmpcondlod[idx.row,idx.col]
            lod.q2 <- tmpcondlod[idx.col,idx.row]
          }
          else {
            lod.q1 <- tmpcondlod1[idx.row,idx.col]
            lod.q2 <- tmpcondlod2[idx.col,idx.row]
          }
          
          if(lod.int >= thrint || min(c(lod.q1, lod.q2)) >= thrcond) {
            
            i.pos <- map[full.idx.col, 2]
            j.pos <- map[full.idx.row, 2]
            results <- rbind(results,
                             data.frame(chr[i], chr[j], i.pos, j.pos,
                                        lod.joint, 1 - pchisq(2 * log(10) * lod.joint,
                                                              df.int + 2 * df.add), 
                                        lod.int, 1 - pchisq(2 * log(10) * lod.int, df.int),
                                        lod.q1, 1 - pchisq(2 * log(10) * lod.q1, df.add),
                                        lod.q2, 1 - pchisq(2 * log(10) * lod.q2, df.add))
                             )
          }
        } 
        else { # no scanone output
          i.pos <- map[full.idx.col, 2]
          j.pos <- map[full.idx.row, 2]
          results <- rbind(results,
                           data.frame(chr[i], chr[j], i.pos, j.pos,
                                      lod.joint, 1 - pchisq(2 * log(10) * lod.joint,
                                                            df.int + 2 * df.add), 
                                      lod.int, 1 - pchisq(2 * log(10) * lod.int, df.int))
                           )
        }

      } # lod joint above threshold

    } # end loop over chromosomes
  }

  if(is.null(results)) {
    results <- numeric(0)
  }
  else {
    if(includes.scanone) 
      colnames(results) <- c("chr1", "chr2", "pos1", "pos2", 
                             "lod.joint", "p.joint", "lod.int", "p.int", "lod.q1", 
                             "p.q1", "lod.q2", "p.q2")
    else colnames(results) <- c("chr1", "chr2", "pos1", "pos2", 
                                "lod.joint", "p.joint", "lod.int", "p.int")
    results <- as.data.frame(results)
  }
  class(results) <- c("summary.scantwo", "data.frame")
  results
}


print.summary.scantwo <-
function(x,...)
{
  if(length(x)==0) {
    cat("    There were no pairs of loci meeting the criteria.\n")
    invisible(return(NULL))
  }

  # column names
  cnames <- c("pos1", "pos2", "  LODjnt", "-logP",
              "  LODint", "-logP", "  LODq1", "-logP",
              "  LODq2", "-logP")

  # chr names
  chr1 <- paste("c",x[,1],sep="")
  chr2 <- paste("c",x[,2],sep="")

  # pad chr names with spaces; this isn't really necessary
  nchar.c1 <- nchar(chr1); max.nchar.c1 <- max(nchar.c1)
  nchar.c2 <- nchar(chr2); max.nchar.c2 <- max(nchar.c2)
  if(any(nchar.c1 < max.nchar.c1 | nchar.c2 < max.nchar.c2)) {
    for(i in 1:length(nchar.c2)) {
      if(nchar.c1[i] < max.nchar.c1)
        chr1[i] <- paste(paste(rep(" ", max.nchar.c1-nchar.c1[i]),collapse=""),
                         chr1[i],sep="")
      if(nchar.c2[i] < max.nchar.c2)
        chr2[i] <- paste(paste(rep(" ", max.nchar.c2-nchar.c2[i]),collapse=""),
                         chr2[i],sep="")
    }
  }
  chr <- paste(chr1,chr2,sep=":")

  # round the rest; take -log10(P-values)
  for(j in 3:ncol(x)) {
    if(j<5)
      x[,j] <- round(x[,j])
    else if(j %% 2)  # odd
      x[,j] <- round(x[,j],2)
    else
      x[,j] <- -round(log10(x[,j]),1)
  }

  res <- as.data.frame(x[,-(1:2)])
  names(res) <- cnames[1:ncol(res)]
  rownames(res) <- chr

  cat("\n")
  print.data.frame(res)
  cat("\n")
}

######################################################################
#
# max.scantwo:  Give maximum joint and intxnLODs for results of the
#               scantwo function
#
######################################################################

max.scantwo <-
function(..., na.rm=TRUE)
{
  dots <- list(...)[[1]]
  lod <- dots$lod
  map <- dots$map

  lod[is.na(lod) | lod == Inf | lod == -Inf] <- 0

  # maximum LODs
  max.jnt <- max(lod[row(lod)>col(lod)],na.rm=na.rm)
  max.int <- max(lod[row(lod)<col(lod)],na.rm=na.rm)

  # "zero" out everything but the maxima
  minmax <- c(min(max.jnt,max.int)/2)
  lod[row(lod)>col(lod) & !is.na(lod) &
      (lod<max.jnt & t(lod)<max.int)] <- minmax/10
  lod[row(lod)<col(lod) & !is.na(lod) &
      (t(lod)<max.jnt & lod<max.int)] <- minmax/10
  diag(lod) <- 0
  dots$lod <- lod

  # get locations of just the maxima
  summary(dots, c(minmax,0,0))
}


# end of scantwo.R
######################################################################
#
# sim.geno.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: sim.geno
#
######################################################################

######################################################################
#
# sim.geno: simulate from the joint distribution Pr(g | O)
#
######################################################################

sim.geno <-
function(cross, n.draws=16, step=0, off.end=0, error.prob=0,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  # map function
  map.function <- match.arg(map.function)
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h

  # don't let error.prob be exactly zero, just in case
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  n.ind <- nind(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)
  type <- class(cross)[1]

  # calculate genotype probabilities one chromosome at a time
  for(i in 1:n.chr) {
    if(n.mar[i]==1) temp.offend <- max(c(off.end,5))
    else temp.offend <- off.end

    # which type of cross is this?
    if(type == "f2") {
      n.gen <- 3
      one.map <- TRUE
      if(class(cross$geno[[i]]) == "A") # autosomal
        cfunc <- "sim_geno_f2"
      else                              # X chromsome
        cfunc <- "sim_geno_bc"
    }
    else if(type == "bc" || type=="riself" || type=="risib") {
      cfunc <- "sim_geno_bc"
      n.gen <- 2
      one.map <- TRUE
    }
    else if(type == "4way") {
      n.gen <- 4
      cfunc <- "sim_geno_4way"
      one.map <- FALSE
    }
    else {
      err <- paste("sim_geno not available for cross type",
                   type, ".")
      stop(err)
    }

    # genotype data
    gen <- cross$geno[[i]]$data
    gen[is.na(gen)] <- 0
    
    # recombination fractions
    if(one.map) {
      # recombination fractions
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map))
      if(type=="risib" || type=="riself")
        rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),class(cross$geno[[i]]))
      rf[rf < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=length(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,names(map))
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
    }
    else {
      map <- create.map(cross$geno[[i]]$map,step,temp.offend)
      rf <- mf(diff(map[1,]))
      rf[rf < 1e-14] <- 1e-14
      rf2 <- mf(diff(map[1,]))
      rf2[rf2 < 1e-14] <- 1e-14

      # new genotype matrix with pseudomarkers filled in
      newgen <- matrix(ncol=ncol(map),nrow=nrow(gen))
      dimnames(newgen) <- list(NULL,colnames(map))
      newgen[,colnames(gen)] <- gen
      newgen[is.na(newgen)] <- 0
      n.pos <- ncol(newgen)
    }

    
    # call C function
    if(one.map) {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.draws),       # number of simulation replicates
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(error.prob),     # 
              draws=as.integer(rep(0,n.draws*n.ind*n.pos)), 
              PACKAGE="qtl")

      cross$geno[[i]]$draws <- array(z$draws,dim=c(n.ind,n.pos,n.draws))
      dimnames(cross$geno[[i]]$draws) <- list(NULL, names(map), NULL)
    }
    else {
      z <- .C(cfunc,
              as.integer(n.ind),         # number of individuals
              as.integer(n.pos),         # number of markers
              as.integer(n.draws),       # number of simulation replicates
              as.integer(newgen),        # genotype data
              as.double(rf),             # recombination fractions
              as.double(rf2),            # recombination fractions
              as.double(error.prob),     # 
              draws=as.integer(rep(0,n.draws*n.ind*n.pos)),
              PACKAGE="qtl")

      cross$geno[[i]]$draws <- array(z$draws,dim=c(n.ind,n.pos,n.draws))
      dimnames(cross$geno[[i]]$draws) <- list(NULL, colnames(map), NULL)

    }

    # attribute set to the error.prob value used, for later
    #     reference
    attr(cross$geno[[i]]$draws,"error.prob") <- error.prob
    attr(cross$geno[[i]]$draws,"step") <- step
    attr(cross$geno[[i]]$draws,"off.end") <- temp.offend
    attr(cross$geno[[i]]$draws,"map.function") <- map.function
  }

  # store simulated genotypes as integers
  for(i in 1:nchr(cross))
    storage.mode(cross$geno[[i]]$draws) <- "integer"

  cross
}

# end of sim.geno.R
######################################################################
#
# simulate.R
#
# copyright (c) 2001-2, Karl W Broman, Johns Hopkins University
# last modified Apr, 2002
# first written April, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: sim.map, sim.cross, sim.cross.bc, sim.cross.f2,
#           sim.cross.4way
#
######################################################################

######################################################################
#
# sim.map: simulate a genetic map
#
######################################################################

sim.map <-
function(len=rep(100,20), n.mar=10, anchor.tel=TRUE, include.x=TRUE,
         sex.sp=FALSE, eq.spacing=FALSE)
{
  if(length(len)!=length(n.mar) && length(len)!=1 && length(n.mar)!=1)
    stop("Lengths of vectors len and n.mar do not conform.")

  # make vectors the same length
  if(length(len) == 1) len <- rep(len,length(n.mar))
  else if(length(n.mar) == 1) n.mar <- rep(n.mar,length(len))

  n.chr <- length(n.mar)

  map <- vector("list",n.chr)
  names(map) <- as.character(1:n.chr)
  if(include.x) names(map)[n.chr] <- "X"

  for(i in 1:n.chr) {
    if(anchor.tel) {
      if(n.mar[i] < 2) n.mar[i] <- 2
      map[[i]] <- c(0,len[i])
      if(n.mar[i] > 2) {
        if(!eq.spacing)
          map[[i]] <- sort(c(map[[i]],runif(n.mar[i]-2,0,len[i])))
        else # equal spacing
          map[[i]] <- seq(0,len[i],length=n.mar[i])
      }
    }
    else {
      if(!eq.spacing) {
        map[[i]] <- sort(runif(n.mar[i],0,len[i]))
        map[[i]] <- map[[i]] - min(map[[i]])
      }
      else {  # equal spacing
        map[[i]] <- seq(0,len[i],length=n.mar[i]+1)
        map[[i]] <- map[[i]][-1] - map[[i]][2]/2
      }
    }
    names(map[[i]]) <- paste("D", names(map)[i], "M", 1:n.mar[i], sep="")
    class(map[[i]]) <- "A"
  }

  if(sex.sp) {
    if(eq.spacing) tempmap <- map
    else {
      for(i in 1:n.chr) {
        if(anchor.tel) {
          if(n.mar[i] < 2) n.mar[i] <- 2
          tempmap <- c(0,len[i])
          if(n.mar[i] > 2)
            tempmap <- sort(c(tempmap,runif(n.mar[i]-2,0,len[i])))
        }
        else {
          tempmap <- sort(runif(n.mar[i],0,len[i]))
          tempmap <- tempmap - min(tempmap)
        }
      }
    }
    map[[i]] <- rbind(map[[i]],tempmap)
    dimnames(map[[i]]) <- list(NULL,paste("D", names(map)[i], "M", 1:n.mar[i], sep=""))
    class(map[[i]]) <- "A"

    if(include.x && i==n.chr)  # if X chromosome, force no recombination in male
      map[[i]][2,] <- rep(0,ncol(map[[i]]))
  }

  if(include.x) class(map[[n.chr]]) <- "X"

  class(map) <- "map"
  map
}

######################################################################
#
# sim.cross: Simulate an experimental cross
#
# Note: These functions are a bit of a mess.  I was in the "get it to
#       work without worrying about efficiency" mode while writing it.
#       Sorry!
#
######################################################################

sim.cross <-
function(map, model=NULL, n.ind=100, type=c("f2","bc","4way"),
         error.prob=0, missing.prob=0, partial.missing.prob=0,
         keep.qtlgeno=TRUE, keep.errorind=TRUE,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  type <- match.arg(type)
  map.function <- match.arg(map.function)

  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  # sort the model matrix
  if(!is.null(model) && is.matrix(model)) 
    model <- model[order(model[,1],model[,2]),]

  if(type=="bc")
    cross <- sim.cross.bc(map,model,n.ind,error.prob,missing.prob,
                          keep.errorind,map.function)
  else if(type=="f2")
    cross <- sim.cross.f2(map,model,n.ind,error.prob,missing.prob,
                          partial.missing.prob,keep.errorind,map.function)
  else
    cross <- sim.cross.4way(map,model,n.ind,error.prob,missing.prob,
                            partial.missing.prob,keep.errorind,map.function)


  # remove QTL genotypes from data and, if keep.qtlgeno=TRUE,
  #     place them in cross$qtlgeno
  qtlgeno <- NULL
  for(i in 1:nchr(cross)) {
    o <- grep("^QTL[0-9]+", colnames(cross$geno[[i]]$data))
    if(length(o) != 0) {
      qtlgeno <- cbind(qtlgeno, cross$geno[[i]]$data[,o,drop=FALSE])
      cross$geno[[i]]$data <- cross$geno[[i]]$data[,-o,drop=FALSE]
      if(is.matrix(cross$geno[[i]]$map)) 
        cross$geno[[i]]$map <- cross$geno[[i]]$map[,-o,drop=FALSE]
      else
        cross$geno[[i]]$map <- cross$geno[[i]]$map[-o]
    }
  }
  if(keep.qtlgeno) cross$qtlgeno <- qtlgeno

  # store genotype data as integers
  for(i in 1:nchr(cross))
    storage.mode(cross$geno[[i]]$data) <- "integer"

  cross
}


######################################################################
#
# sim.cross.bc
#
######################################################################

sim.cross.bc <-
function(map,model,n.ind,error.prob,missing.prob,
         keep.errorind,map.function)
{
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h

  if(any(sapply(map,is.matrix)))
    stop("Map must not be sex-specific.")

  n.chr <- length(map)

  if(is.null(model)) n.qtl <- 0
  else {
    if(!((!is.matrix(model) && length(model) == 3) ||
         (is.matrix(model) && ncol(model) == 3))) 
      stop("Model must be a matrix with 3 columns (chr, pos and effect).")
    if(!is.matrix(model)) model <- rbind(model)
    n.qtl <- nrow(model)
    if(any(model[,1] < 0 | model[,1] > n.chr))
      stop("Chromosome indicators in model matrix out of range.")
    model[,2] <- model[,2]+1e-14 # so QTL not on top of marker
  }

  # if any QTLs, place qtls on map
  if(n.qtl > 0) {
    for(i in 1:n.qtl) {
      temp <- map[[model[i,1]]]
      if(model[i,2] < min(temp)) {
        temp <- c(model[i,2],temp)
        names(temp)[1] <- paste("QTL",i,sep="")
      }
      else if(model[i,2] > max(temp)) {
        temp <- c(temp,model[i,2])
        names(temp)[length(temp)] <- paste("QTL",i,sep="")
      }
      else {
        j <- max((seq(along=temp))[temp < model[i,2]])
        temp <- c(temp[1:j],model[i,2],temp[(j+1):length(temp)])
        names(temp)[j+1] <- paste("QTL",i,sep="")
      }
      map[[model[i,1]]] <- temp
    }
  }
  
  geno <- vector("list", n.chr)
  names(geno) <- names(map)
  n.mar <- sapply(map,length)
  mar.names <- lapply(map,names)

#  chr.type <- sapply(map,function(a)
#                     if(is.null(class(a))) return("A")
#                     else return(class(a)))
  chr.type <- sapply(map, function(a) ifelse(class(a)=="X","X","A"))
  
  for(i in 1:n.chr) {
    data <- matrix(nrow=n.ind,ncol=n.mar[i])
    dimnames(data) <- list(NULL,mar.names[[i]])

    # simulate genotype data
    d <- diff(map[[i]]) # inter-marker distances (cM)
    r <- mf(d) # recombination fractions (Kosambi map function)
    rbar <- 1-r

    # first locus on chromosome
    data[,1] <- sample(1:2,n.ind,repl=TRUE)

    # rest of markers
    if(n.mar[i] > 1) {
      for(j in 1:(n.mar[i]-1)) {
        rec <- sample(0:1,n.ind,repl=TRUE,prob=c(1-r[j],r[j]))
        data[rec==0,j+1] <- data[rec==0,j]
        data[rec==1,j+1] <- 3-data[rec==1,j]
      }
    } # if n.mar[i] > 1

    geno[[i]] <- list(data = data, map = map[[i]])
    class(geno[[i]]) <- chr.type[i]
    class(geno[[i]]$map) <- NULL
    
  } # end loop over chromosomes

  # simulate phenotypes
  pheno <- rnorm(n.ind,0,1)

  if(n.qtl > 0) {
    # find QTL positions in genotype data
    QTL.chr <- QTL.loc <- NULL
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0) {
        QTL.chr <- c(QTL.chr,rep(i,length(o)))
        QTL.loc <- c(QTL.loc,o)
      }
    }

    # incorporate QTL effects
    for(i in 1:n.qtl) {
      QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]]
      pheno[QTL.geno==1] <- pheno[QTL.geno==1] - model[i,3]
      pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,3]
    }

  } # end simulate phenotype
      
  n.mar <- sapply(geno, function(a) length(a$map))

  # add errors
  if(error.prob > 0) {
    for(i in 1:n.chr) {
      a <- sample(0:1,n.mar[i]*n.ind,repl=TRUE,
                  prob=c(1-error.prob,error.prob))
      geno[[i]]$data[a == 1] <- 3 - geno[[i]]$data[a == 1]
      if(keep.errorind) {
        errors <- matrix(0,n.ind,n.mar[i])
        errors[a==1] <- 1
        colnames(errors) <- colnames(geno[[i]]$data)
        geno[[i]]$errors <- errors
      }
    } 
  } 

  # add missing
  if(missing.prob > 0) {
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0)
        x <- geno[[i]]$data[,o]
      geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,repl=TRUE,
                            prob=c(missing.prob,1-missing.prob))] <- NA
      if(length(o)>0)
        geno[[i]]$data[,o] <- x
    }
  }

  pheno <- data.frame(phenotype=pheno)

  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c("bc","cross")

  cross
}  
       
######################################################################
#
# sim.cross.f2
#
######################################################################

sim.cross.f2 <-              
function(map,model,n.ind,error.prob,missing.prob,partial.missing.prob,
         keep.errorind,map.function)
{
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h

  if(any(sapply(map,is.matrix)))
    stop("Map must not be sex-specific.")

  # chromosome types
  chr.type <- sapply(map,function(a)
                     if(is.null(class(a))) return("A")
                     else return(class(a)))
  
  n.chr <- length(map)
  if(is.null(model)) n.qtl <- 0
  else {
    if(!((!is.matrix(model) && length(model) == 4) ||
         (is.matrix(model) && ncol(model) == 4))) {
      stop("Model must be a matrix with 4 columns (chr, pos and effects).")
    }
    if(!is.matrix(model)) model <- rbind(model)
    n.qtl <- nrow(model)
    if(any(model[,1] < 0 | model[,1] > n.chr))
      stop("Chromosome indicators in model matrix out of range.")
    model[,2] <- model[,2]+1e-14 # so QTL not on top of marker
  }

  # if any QTLs, place qtls on map
  if(n.qtl > 0) {
    for(i in 1:n.qtl) {
      temp <- map[[model[i,1]]]
      if(model[i,2] < min(temp)) {
        temp <- c(model[i,2],temp)
        names(temp)[1] <- paste("QTL",i,sep="")
      }
      else if(model[i,2] > max(temp)) {
        temp <- c(temp,model[i,2])
        names(temp)[length(temp)] <- paste("QTL",i,sep="")
      }
      else {
        j <- max((seq(along=temp))[temp < model[i,2]])
        temp <- c(temp[1:j],model[i,2],temp[(j+1):length(temp)])
        names(temp)[j+1] <- paste("QTL",i,sep="")
      }
      map[[model[i,1]]] <- temp
    }
  }
  
  geno <- vector("list", n.chr)
  names(geno) <- names(map)
  n.mar <- sapply(map,length)
  mar.names <- lapply(map,names)

  for(i in 1:n.chr) {

    data <- matrix(nrow=n.ind,ncol=n.mar[i])
    dimnames(data) <- list(NULL,mar.names[[i]])

    # simulate genotype data
    d <- diff(map[[i]]) # inter-marker distances (cM)
    r <- mf(d) # recombination fractions (Kosambi map function)
    rbar <- 1-r

    # first locus on chromosome
    if(chr.type[i]=="X") data[,1] <- sample(1:2,n.ind,repl=TRUE)
    else data[,1] <- sample(1:3,n.ind,repl=TRUE,prob=c(1,2,1))
    
    # rest of markers
    if(n.mar[i] > 1) {
      for(j in 1:(n.mar[i]-1)) {
        if(chr.type[i]=="X") { # X chromosome (like a backcross)
          rec <- sample(0:1,n.ind,repl=TRUE,prob=c(1-r[j],r[j]))
          data[rec==0,j+1] <- data[rec==0,j]
          data[rec==1,j+1] <- 3-data[rec==1,j]
        }
        else { # F2 autosome
          data[data[,j]==1,j+1] <- sample(1:3,sum(data[,j]==1),repl=TRUE,
                     prob=c(rbar[j]*rbar[j],2*r[j]*rbar[j],r[j]*r[j]))
          data[data[,j]==2,j+1] <- sample(1:3,sum(data[,j]==2),repl=TRUE,
                     prob=c(r[j]*rbar[j],rbar[j]*rbar[j]+r[j]*r[j],r[j]*rbar[j]))
          data[data[,j]==3,j+1] <- sample(1:3,sum(data[,j]==3),repl=TRUE,
                     prob=c(r[j]*r[j],2*r[j]*rbar[j],rbar[j]*rbar[j]))
        }
      } # end loop over intervals
    } # if n.mar[i] > 1

    geno[[i]] <- list(data = data, map = map[[i]])
    class(geno[[i]]) <- chr.type[i]
    class(geno[[i]]$map) <- NULL
    
  } # end loop over chromosomes

  # simulate phenotypes
  pheno <- rnorm(n.ind,0,1)

  if(n.qtl > 0) {
    # find QTL positions in genotype data
    QTL.chr <- QTL.loc <- NULL
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0) {
        QTL.chr <- c(QTL.chr,rep(i,length(o)))
        QTL.loc <- c(QTL.loc,o)
      }
    }

    # incorporate QTL effects
    for(i in 1:n.qtl) {
      QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]]
      pheno[QTL.geno==1] <- pheno[QTL.geno==1] - model[i,3]
      pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,4]
      pheno[QTL.geno==3] <- pheno[QTL.geno==3] + model[i,3]
    }

  } # end simulate phenotype
      
  n.mar <- sapply(geno, function(a) length(a$map))

  # add errors
  if(error.prob > 0) {
    for(i in 1:n.chr) {
      if(chr.type[i]=="X") {
        a <- sample(0:1,n.mar[i]*n.ind,repl=TRUE,
                    prob=c(1-error.prob,error.prob))
        geno[[i]]$data[a == 1] <- 3 - geno[[i]]$data[a == 1]
      }
      else {
        a <- sample(0:2,n.mar[i]*n.ind,repl=TRUE,
                    prob=c(1-error.prob,error.prob/2,error.prob/2))
        if(any(a>0 & geno[[i]]$data==1))
          geno[[i]]$data[a>0 & geno[[i]]$data==1] <-
            (geno[[i]]$data+a)[a>0 & geno[[i]]$data==1]
        if(any(a>0 & geno[[i]]$data==2)) {
          geno[[i]]$data[a>0 & geno[[i]]$data==2] <-
            (geno[[i]]$data+a)[a>0 & geno[[i]]$data==2]
          geno[[i]]$data[geno[[i]]$data>3] <- 1
        }
        if(any(a>0 & geno[[i]]$data==3))
          geno[[i]]$data[a>0 & geno[[i]]$data==3] <-
            (geno[[i]]$data-a)[a>0 & geno[[i]]$data==3]
      }

      if(keep.errorind) {
        errors <- matrix(0,n.ind,n.mar[i])
        errors[a>0] <- 1
        colnames(errors) <- colnames(geno[[i]]$data)
        geno[[i]]$errors <- errors
      }

    } # end loop over chromosomes
  } # end simulate genotyping errors

  # add partial missing
  if(partial.missing.prob > 0) {
    for(i in 1:n.chr) {
      if(chr.type[i] != "X") {
        o <- sample(c(TRUE,FALSE),n.mar[i],repl=TRUE,
                    prob=c(partial.missing.prob,1-partial.missing.prob))
        if(any(o)) {
          o2 <- grep("^QTL[0-9]+",mar.names[[i]])
          if(length(o2)>0)
            x <- geno[[i]]$data[,o2]
          m <- (1:n.mar[i])[o]
          for(j in m) {
            if(runif(1) < 0.5) 
              geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==2,j] <- 4
            else 
              geno[[i]]$data[geno[[i]]$data[,j]==3 | geno[[i]]$data[,j]==2,j] <- 5
          }
          if(length(o2)>0)
            geno[[i]]$data[,o2] <- x
        }
      }

    } # end loop over chromosomes
  } # end simulate partially missing data
            
  # add missing
  if(missing.prob > 0) {
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0)
        x <- geno[[i]]$data[,o]
      geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,repl=TRUE,
                            prob=c(missing.prob,1-missing.prob))] <- NA
      if(length(o)>0)
        geno[[i]]$data[,o] <- x
    }
  }

  pheno <- data.frame(phenotype=pheno)

  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c("f2","cross")

  cross
}

######################################################################
#
# sim.cross.4way
#
######################################################################

sim.cross.4way <-              
function(map,model,n.ind,error.prob,missing.prob,partial.missing.prob,
         keep.errorind,map.function)
{
  if(map.function=="kosambi") mf <- mf.k
  else if(map.function=="c-f") mf <- mf.cf
  else if(map.function=="morgan") mf <- mf.m
  else mf <- mf.h

  if(!all(sapply(map,is.matrix)))
    stop("Map must be sex-specific.")

  n.chr <- length(map)
  if(is.null(model)) n.qtl <- 0
  else {
    if(!((!is.matrix(model) && length(model) == 5) ||
         (is.matrix(model) && ncol(model) == 5))) {
      stop("Model must be a matrix with 5 columns (chr, pos and effects).")
    }
    if(!is.matrix(model)) model <- rbind(model)
    n.qtl <- nrow(model)
    if(any(model[,1] < 0 | model[,1] > n.chr))
      stop("Chromosome indicators in model matrix out of range.")
    model[,2] <- model[,2]+1e-14 # so QTL not on top of marker
  }

  # if any QTLs, place qtls on map
  if(n.qtl > 0) {
    for(i in 1:n.qtl) {
      temp <- map[[model[i,1]]]
      temp1 <- temp[1,]
      temp2 <- temp[2,]
      qtlloc <- model[i,2]

      if(qtlloc < min(temp1)) {
        temp1 <- c(qtlloc,temp1)
        temp2 <- min(temp2) - (min(temp1)-qtlloc)/diff(range(temp1))*diff(range(temp2))
        temp1 <- temp1-min(temp1)
        temp2 <- temp2-min(temp2)
        n <- c(paste("QTL",i,sep=""),colnames(temp))
      }
      else if(qtlloc > max(temp1)) {
        temp1 <- c(temp1,qtlloc)
        temp2 <- (qtlloc-max(temp1))/diff(range(temp1))*diff(range(temp2))+max(temp2)
        n <- c(colnames(temp),paste("QTL",i,sep=""))
      }
      else {
        temp1 <- c(temp1,qtlloc)
        o <- order(temp1)
        wh <- (seq(along=temp1))[order(temp1)==length(temp1)]
        temp2 <- c(temp2[1:(wh-1)],NA,temp2[-(1:(wh-1))])
        temp2[wh] <- temp2[wh-1] + (temp1[wh]-temp1[wh-1])/(temp1[wh+1]-temp1[wh-1]) *
          (temp2[wh+1]-temp2[wh-1])
        temp1 <- sort(temp1)
        n <- c(colnames(temp),paste("QTL",i,sep=""))[o]
      }
      map[[model[i,1]]] <- rbind(temp1,temp2)
      dimnames(map[[model[i,1]]]) <- list(NULL, n)
    }
  }
  
  geno <- vector("list", n.chr)
  names(geno) <- names(map)
  n.mar <- sapply(map,ncol)
  mar.names <- lapply(map,function(a) colnames(a))
  chr.type <- sapply(map,function(a)
                     if(is.null(class(a))) return("A")
                     else return(class(a)))
  
  for(i in 1:n.chr) {

    data <- matrix(nrow=n.ind,ncol=n.mar[i])
    dimnames(data) <- list(NULL,mar.names[[i]])

    # simulate genotype data
    d <- diff(map[[i]][1,])
    r <- mf(d)
    rbar <- 1-r
    d2 <- diff(map[[i]][2,])
    r2 <- mf(d2)
    rbar2 <- 1-r2
    
    data2 <- data

    # first locus on chromosome
    data[,1] <- sample(1:2,n.ind,repl=TRUE)  # mother's chromosome
    data2[,1] <- sample(1:2,n.ind,repl=TRUE) # father's chromosome

    sex <- NULL
    if(chr.type[i]=="X") {
      sex <- rep(0,n.ind)
      sex[data2[,1]==2] <- 1
    }

    # rest of markers
    if(n.mar[i] > 1) {
      for(j in 1:(n.mar[i]-1)) {
        rec <- sample(0:1,n.ind,repl=TRUE,prob=c(1-r[j],r[j]))
        data[rec==0,j+1] <- data[rec==0,j]
        data[rec==1,j+1] <- 3-data[rec==1,j]
          
        rec <- sample(0:1,n.ind,repl=TRUE,prob=c(1-r2[j],r2[j]))
        data2[rec==0,j+1] <- data2[rec==0,j]
        data2[rec==1,j+1] <- 3-data2[rec==1,j]
      }
    } 
    data <- data + (data2-1)*2 

    geno[[i]] <- list(data = data, map = map[[i]])
    class(geno[[i]]) <- chr.type[i]
    class(geno[[i]]$map) <- NULL
    
  } # end loop over chromosomes

  # simulate phenotypes
  pheno <- rnorm(n.ind,0,1)

  if(n.qtl > 0) {
    # find QTL positions
    QTL.chr <- QTL.loc <- NULL
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0) {
        QTL.chr <- c(QTL.chr,rep(i,length(o)))
        QTL.loc <- c(QTL.loc,o)
      }
    }

    # incorporate QTL effects
    for(i in 1:n.qtl) {
      QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]]
      pheno[QTL.geno==1] <- pheno[QTL.geno==1] + model[i,3]
      pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,4]
      pheno[QTL.geno==3] <- pheno[QTL.geno==3] + model[i,5]
    }

  } # end simulate phenotype
      
  n.mar <- sapply(geno, function(a) ncol(a$map))

  # add errors
  if(error.prob > 0) {
    for(i in 1:n.chr) {
      if(chr.type[i] != "X") { # 4-way cross; autosomal
        a <- sample(0:3,n.mar[i]*n.ind,repl=TRUE,
                    prob=c(1-error.prob,rep(error.prob/3,3)))
        if(any(a>0 & geno[[i]]$data==1))
          geno[[i]]$data[a>0 & geno[[i]]$data==1] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==1] + a[a>0 & geno[[i]]$data==1]
        if(any(a>0 & geno[[i]]$data==2))
          geno[[i]]$data[a>0 & geno[[i]]$data==2] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==2] + c(-1,1,2)[a[a>0 & geno[[i]]$data==2]]
        if(any(a>0 & geno[[i]]$data==3))
          geno[[i]]$data[a>0 & geno[[i]]$data==3] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==3] + c(-2,-1,1)[a[a>0 & geno[[i]]$data==3]]
        if(any(a>0 & geno[[i]]$data==4))
          geno[[i]]$data[a>0 & geno[[i]]$data==4] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==4] - a[a>0 & geno[[i]]$data==4]
      }
      else {
        a <- sample(0:1,n.mar[i]*n.ind,repl=TRUE,
                    prob=c(1-error.prob,error.prob))
        if(any(a>0 & geno[[i]]$data==1))
          geno[[i]]$data[a>0 & geno[[i]]$data==1] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==1] + 1
        if(any(a>0 & geno[[i]]$data==2))
          geno[[i]]$data[a>0 & geno[[i]]$data==2] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==2] - 1
        if(any(a>0 & geno[[i]]$data==3))
          geno[[i]]$data[a>0 & geno[[i]]$data==3] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==3] + 1
        if(any(a>0 & geno[[i]]$data==4))
          geno[[i]]$data[a>0 & geno[[i]]$data==4] <-
            geno[[i]]$data[a>0 & geno[[i]]$data==4] - 1
      }

      if(keep.errorind) {
        errors <- matrix(0,n.ind,n.mar[i])
        errors[a>0] <- 1
        colnames(errors) <- colnames(geno[[i]]$data)
        geno[[i]]$errors <- errors
      }

    } # end loop over chromosomes
  } # end simulate genotyping errors

  # add partial missing
  if(partial.missing.prob > 0) {
    for(i in 1:n.chr) {
      if(chr.type[i] != "X") {
        o <- sample(c(TRUE,FALSE),n.mar[i],repl=TRUE,
                    prob=c(partial.missing.prob,1-partial.missing.prob))

        if(any(o)) {
          o2 <- grep("^QTL[0-9]+",mar.names[[i]])
          if(length(o2)>0)
            x <- geno[[i]]$data[,o2]
          m <- (1:n.mar[i])[o]
          for(j in m) {
            a <- sample(1:4,1)
            if(a==1) { # AB:AA marker
              geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==3,j] <- 5
              geno[[i]]$data[geno[[i]]$data[,j]==2 | geno[[i]]$data[,j]==4,j] <- 6
            }
            else if(a==2) { # AA:AB marker
              geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==2,j] <- 7
              geno[[i]]$data[geno[[i]]$data[,j]==3 | geno[[i]]$data[,j]==4,j] <- 8
            }
            else if(a==3)  # AB:AB marker
              geno[[i]]$data[geno[[i]]$data[,j]==2 | geno[[i]]$data[,j]==3,j] <- 10
            else  # AB:BA marker
              geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==4,j] <- 9
          }
          if(length(o2) > 0)
            geno[[i]]$data[,o2] <- x
        }
      }

    } # end loop over chromosomes
  } # end simulate partially missing data
            
  # add missing
  if(missing.prob > 0) {
    for(i in 1:n.chr) {
      o <- grep("^QTL[0-9]+",mar.names[[i]])
      if(length(o)>0)
        x <- geno[[i]]$data[,o]
      geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,repl=TRUE,
                            prob=c(missing.prob,1-missing.prob))] <- NA
      if(length(o)>0)
        geno[[i]]$data[,o] <- x
    }
  }

  if(!is.null(sex)) {
    pheno <- cbind(pheno,sex)
    dimnames(pheno) <- list(NULL, c("phenotype", "sex"))
  }
  else {
    pheno <- cbind(pheno)
    dimnames(pheno) <- list(NULL, "phenotype")
  }

  pheno <- as.data.frame(pheno)
  cross <- list(geno=geno,pheno=pheno)
  class(cross) <- c("4way","cross")

  cross
}



# end of simulate.R
######################################################################
#
# summary.cross.R
#
# copyright (c) 2001-3, Karl W Broman, Johns Hopkins University
# last modified Nov, 2003
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: summary.cross, print.summary.cross, nind, nchr, nmar,
#           totmar, nphe, nmissing, print.cross
#
######################################################################

summary.cross <-
function(object,...)
{
#  if(is.na(match("cross",class(object))))
#    stop("This is not an object of class cross.")
    
  n.ind <- nind(object)
  tot.mar <- totmar(object)
  n.phe <- nphe(object)
  n.chr <- nchr(object)
  n.mar <- nmar(object)
  type <- class(object)[1]

  if(type != "f2" && type != "f2ss" && type != "bc" && type != "4way" &&
     type != "riself" && type != "risib") {
    err <- paste("Cross type", type, "is not suppoted.")
    stop(err)
  }

  # combine genotype data into one big matrix
  Geno <- object$geno[[1]]$data
  if(n.chr > 1)
    for(i in 2:n.chr)
      Geno <- cbind(Geno,object$geno[[i]]$data)

  # proportion of missing genotype data
  missing.gen <- mean(is.na(Geno))
  
  # table of genotype values
  if(type=="f2" || type=="f2ss") {
    typings <- table(factor(Geno[!is.na(Geno)], levels=1:5))
    names(typings) <- c("AA","AB","BB","not BB","not AA")
  }
  else if(type=="bc") {
    typings <- table(factor(Geno[!is.na(Geno)], levels=1:2))
    names(typings) <- c("AA","AB")
  }
  else if(type=="riself" || type=="risib") {
    typings <- table(factor(Geno[!is.na(Geno)], levels=1:2))
    names(typings) <- c("AA","BB")
  }
  else typings <- table(factor(Geno[!is.na(Geno)]))

  # turn into fractions
  typings <- typings/sum(typings)

  # amount of missing phenotype data
  missing.phe <- as.numeric(cbind(apply(object$pheno,2,function(a) mean(is.na(a)))))

  # check that, in the case of "f2ss" and "4way" crosses, the genetic
  #     maps are matrices with 2 rows, and that for other crosses,
  #     the genetic maps are numeric vectors
  if(type=="f2ss" || type=="4way") {
    if(any(!sapply(object$geno, function(a) (is.matrix(a$map) && nrow(a$map)==2)))) 
      warning("The genetic maps should all be matrices with two rows.")
  }
  else {
    if(any(sapply(object$geno, function(a) is.matrix(a$map))))
      warning("The genetic maps should all be numeric vectors rather than matrices.")
  }

  # check that object$geno[[i]]$data has colnames and that they match
  #     the names in object$geno[[i]]$map
  for(i in 1:n.chr) {
    nam1 <- colnames(object$geno[[i]]$data)
    map <- object$geno[[i]]$map
    if(is.matrix(map)) nam2 <- colnames(map)
    else nam2 <- names(map)
    chr <- names(object$geno)[[i]]
    if(is.null(nam1)) {
      warn <- paste("The data matrix for chr", chr,
                    "lacks column names")
      warning(warn)
    }
    if(is.null(nam2)) {
      warn <- paste("The genetic map for chr", chr,
                    "lacks column names")
      warning(warn)
    }
    if(any(nam1 != nam2)) {
      warn <- paste("Marker names in the data matrix and genetic map\n",
                    "for chr ", chr, " do not match.",sep="")
      stop(warn)
    }
      
    if((is.matrix(map) && (any(diff(map[1,])<0) || any(diff(map[2,])<0))) ||
       (!is.matrix(map) && any(diff(map)<0))) {
      err <- paste("Markers out of order on chr", chr)
      stop(err)
    }
  }
    
  if(!is.data.frame(object$pheno))
    warning("Phenotypes should be a data.frame.")

  # check genotype data
  if(type=="bc" || type=="riself" || type=="risib") {
    # Invalid genotypes?
    if(any(!is.na(Geno) & Geno != 1 & Geno != 2)) { 
      warn <- paste("Invalid genotypes.",
                    "\n    Observed genotypes:",
                    paste(unique(as.numeric(Geno)),collapse=" "))
      warning(warn)
      return(Geno)
    }

    # Missing genotype category on autosomes?
    if(sum(!is.na(Geno) & Geno==2) == 0 ||
       sum(!is.na(Geno) & Geno==1) == 0) {
      warn <- paste("Strange genotype pattern on chr ", chr, ".", sep="")
      warning(warn)
    }
  }
  else if(type=="f2" || type=="f2ss") {
    # invalid genotypes
    if(any(!is.na(Geno) & Geno!=1 & Geno!=2 & Geno!=3 &
           Geno!=4 & Geno!=5)) { 
      warn <- paste("Invalid genotypes on chr", chr, ".", 
                    "\n    Observed genotypes:",
                    paste(unique(as.numeric(Geno)),collapse=" "))
      warning(warn)
    }

    # X chromosome
    for(i in 1:n.chr) {
      if(class(object$geno[[i]]) == "X") {
        dat <- object$geno[[i]]$data
        if(any(!is.na(dat) & dat!=1 & dat!=2)) { 
          warn <- paste("Invalid genotypes on X chromosome:",
                        "\n    Observed genotypes:",
                        paste(unique(as.numeric(dat)),collapse=" "))
          warning(warn)
        }
      }
    }

    # Missing genotype category on autosomes?
    dat <- NULL; flag <- 0
    for(i in 1:n.chr) {
      if(class(object$geno[[i]]) != "X") {
        dat <- cbind(dat,object$geno[[i]]$data)
        flag <- 1
      }
    }
    if(flag && (sum(!is.na(dat) & dat==2) == 0 ||
               sum(!is.na(dat) & dat==1) == 0 ||
               sum(!is.na(dat) & dat==3) == 0))
      warning("Strange genotype pattern.")
  }

  # Look for duplicate marker names
  mnames <- NULL
  for(i in 1:nchr(object)) 
    mnames <- c(mnames,colnames(object$geno[[i]]$data))
  o <- table(mnames)
  if(any(o > 1))
    warning("Duplicate markers [", paste(mnames[mnames==names(o)[o>1]],
                                         collapse=", "), "]")

  # make sure the genotype data are matrices rather than data frames
  if(any(sapply(object$geno, function(a) is.data.frame(a$data))))
    warning("The $data objects should be simple matrices, not data frames.")

  cross.summary <- list(type=type, n.ind = n.ind, n.phe=n.phe, 
			n.chr=n.chr, n.mar=n.mar,
			missing.gen=missing.gen,typing.freq=typings,
			missing.phe=missing.phe)
  class(cross.summary) <- "summary.cross"
  cross.summary
  
}


print.summary.cross <-
function(x,...)
{
#  cat("\n")
  if(x$type=="f2") cat("    F2 intercross\n\n")
  else if(x$type=="f2ss") cat("    F2 intercross w/ sex-specific maps\n\n")
  else if(x$type=="bc") cat("    Backcross\n\n")
  else if(x$type=="4way") cat("    4-way cross\n\n")
  else if(x$type=="riself") cat("    RI strains via selfing\n\n")
  else if(x$type=="risib") cat("    RI strains via sib matings\n\n")
  else cat(paste("    cross", x$type, "\n\n",sep=" "))

  cat("    No. individuals: ", x$n.ind,"\n\n")
  cat("    No. phenotypes:  ", x$n.phe,"\n")
  cat("    Percent phenotyped: ", round((1-x$missing.phe)*100,1), "\n\n")
  cat("    No. chromosomes: ", x$n.chr,"\n")
  cat("    Total markers:   ", sum(x$n.mar), "\n")
  cat("    No. markers:     ", x$n.mar, "\n")
  cat("    Percent genotyped: ", round((1-x$missing.gen)*100,1), "\n")
  cat("    Genotypes (%):     ", 
      paste(names(x$typing.freq),round(x$typing.freq*100,1),sep=":", collapse="  "),
      "\n")
#  cat("\n")
}



nind <-
function(object)
{
  if(any(is.na(match(c("pheno","geno"),names(object)))))
    stop("This is not an object of class cross.")

  n.ind1 <- nrow(object$pheno)
  n.ind2 <- sapply(object$geno,function(x) nrow(x$data))
  if(any(n.ind2 != n.ind1))
    stop("Different numbers of individuals in genotypes and phenotypes.")
  n.ind1
}

nchr <-
function(object)
{
  if(any(is.na(match(c("pheno","geno"),names(object)))))
    stop("This is not an object of class cross.")
  length(object$geno)
}

nmar <- 
function(object)
{
  if(any(is.na(match(c("pheno","geno"),names(object)))))
    stop("This is not an object of class cross.")

  if(!is.matrix(object$geno[[1]]$map))
    n.mar1 <- sapply(object$geno, function(x) length(x$map))
  else # sex-specific maps
    n.mar1 <- sapply(object$geno, function(x) ncol(x$map))

  n.mar2 <- sapply(object$geno, function(x) ncol(x$data))
  if(any(n.mar1 != n.mar2))
    stop("Different numbers of markers in genotypes and maps.")
  n.mar1
}

totmar <-
function(object)
{
  if(any(is.na(match(c("pheno","geno"),names(object)))))
    stop("This is not an object of class cross.")

  if(!is.matrix(object$geno[[1]]$map))
    totmar1 <- sum(sapply(object$geno, function(x) length(x$map)))
  else # sex-specific maps
    totmar1 <- sum(sapply(object$geno, function(x) ncol(x$map)))
  totmar2 <- sum(sapply(object$geno, function(x) ncol(x$data)))
  if(totmar1 != totmar2)
    stop("Different numbers of markers in genotypes and maps.")
  totmar1
}

nphe <-
function(object) {
  if(any(is.na(match(c("pheno","geno"),names(object)))))
    stop("This is not an object of class cross.")

  ncol(object$pheno)
}

# count number of missing genotypes for each individual or each marker
nmissing <-
function(cross,which=c("ind","mar"))
{
  which <- match.arg(which)

  if(which=="ind") {
    n.missing <- rep(0,nind(cross))
    for(i in 1:nchr(cross)) 
      n.missing <- n.missing +
        apply(cross$geno[[i]]$data,1,function(a) sum(is.na(a)))
  }
  else {
    n.missing <- NULL
    for(i in 1:nchr(cross))
      n.missing <- c(n.missing,
                     apply(cross$geno[[i]]$data,2,function(a) sum(is.na(a))))
  }

  n.missing
}


# "print" method for cross object
#
# to avoid ever printing the entire object, print just a little
#     warning message and then the summary
print.cross <-
function(x, ...)
{
  cat("  This is an object of class \"cross\".\n")
  cat("  It is too complex to print, so we provide just this summary.\n")
  print(summary(x))
  return(summary(x))
}


# end of summary.cross.R
#####################################################################
#
# util.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
#     [find.pheno and find.flanking from Brian Yandell]
# last modified Sep, 2004
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: pull.map, replace.map, create.map,
#           convert.cross, clean, drop.nullmarkers
#           drop.markers, geno.table, mf.k, mf.h, imf.k, imf.h
#           mf.cf, imf.cf, mf.m, imf.m, convert2ss, switch.order
#           subset.cross, fill.geno, check.covar, find.marker,
#           adjust.rf.ri, pull.geno, lodint, makeSSmap,
#           comparecrosses, movemarker, summary.map,
#           print.summary.map, convert.scanone, find.pheno,
#           find.flanking
#
######################################################################

######################################################################
#
# pull.map
#
# pull out the map portion of a cross object, as a list
#
######################################################################

pull.map <-
function(cross)
{
  a <- lapply(cross$geno,function(a) { b <- a$map; class(b) <- class(a); b })
  class(a) <- "map"
  a
}

######################################################################
#
# replace.map
#
# replace the map portion of a cross object with a list defining a map
#
######################################################################

replace.map <-
function(cross, map)
{
  n.chr <- nchr(cross) 
  n.mar <- nmar(cross)

  n.chr2 <- length(map)
  n.mar2 <- sapply(map,length)

  type <- class(cross)[1]
  if(type=="4way" || type=="f2ss") {
    mnames <- unlist(lapply(cross$geno, function(a) colnames(a$map)))
    mnames2 <- unlist(lapply(map, function(a) colnames(a)))
    n.mar2 <- n.mar2/2
  }
  else if(type == "bc" || type == "f2" || type == "riself" || type=="risib") {
    mnames <- unlist(lapply(cross$geno, function(a) names(a$map)))
    mnames2 <- unlist(lapply(map, function(a) names(a)))
  }
  else 
    stop("Cross type ", type, " not yet supported.")

  # check that things line up properly
  if(n.chr != n.chr2)
    stop("Numbers of chromosomes don't match.")
  if(any(names(cross$geno) != names(map)))
    stop("Chromosome names don't match.")
  if(any(n.mar != n.mar2))
    stop("Number of markers don't match.")
  if(any(mnames != mnames2)) 
    stop("Marker names don't match.")

  # proceed if no errors
  for(i in 1:length(cross$geno))
    cross$geno[[i]]$map <- map[[i]]

  cross
}

######################################################################
#
# create.map
#
# create a new map with inserted inter-marker locations
#
# Note: map is a vector or a matrix with 2 rows
# 
######################################################################

create.map <-
function(map, step, off.end)
{
  if(step<0 || off.end<0) stop("step and off.end must be > 0.")

  if(!is.matrix(map)) { # sex-ave map
    if(length(map) == 1) { # just one marker!
      if(off.end==0) {
        if(step == 0) step <- 1
        nam <- names(map)
        map <- c(map,map+step)
        names(map) <- c(nam,paste("loc",step,sep=""))
      }
      else {
        if(step==0) m <- c(-off.end,off.end)
        else m <- seq(-off.end,off.end,by=step)
        m <- m[m!=0]
        names(m) <- paste("loc",m,sep="")
        map <- sort(c(m+map,map))
      }
      return(map)
    }

    minloc <- min(map)
    map <- map-minloc

    if(step==0 && off.end==0) return(map+minloc)
    else if(step==0 && off.end > 0) {
      a <- c(floor(min(map)-off.end),ceiling(max(map)+off.end))
      names(a) <- paste("loc", a, sep="")
      return(sort(c(a,map))+minloc)
    }
    else if(step>0 && off.end == 0) {
      a <- seq(floor(min(map)),max(map),
               by = step)
      if(any(is.na(match(a,map)))) {
        a <- a[is.na(match(a,map))]
        names(a) <- paste("loc",a,sep="")
        return(sort(c(a,map))+minloc)
      }
      else return(map+minloc)
    }
    else {
      a <- seq(floor(min(map)-off.end),ceiling(max(map)+off.end+step),
               by = step)
      a <- a[is.na(match(a,map))]
      
      # no more than one point above max(map)+off.end
      z <- (seq(along=a))[a >= max(map)+off.end]
      if(length(z) > 1) a <- a[-z[-1]]
      
      names(a) <- paste("loc",a,sep="")
      return(sort(c(a,map))+minloc)
    }
  } # end sex-ave map
  else { # sex-specific map
    minloc <- c(min(map[1,]),min(map[2,]))
    map <- map-minloc
    markernames <- colnames(map)

    if(step==0 && off.end==0) return(map+minloc)
    else if(step==0 && off.end > 0) {
      if(ncol(map)==1) { # only one marker; assume equal recomb in sexes
        L1 <- L2 <- 1
      }
      else {
        L1 <- diff(range(map[1,]))
        L2 <- diff(range(map[2,]))
      }

      a <- c(floor(min(map[1,])-off.end),ceiling(max(map[1,])+off.end))
      names(a) <- paste("loc", a, sep="")
      b <- c(floor(min(map[2,])-off.end)*L2/L1,
             ceiling(max(map[2,])+off.end)*L2/L1)
      n <- c(names(a)[1],markernames,names(a)[2])
      map <- cbind(c(a[1],b[1]),map,c(a[2],b[2]))
      dimnames(map) <- list(NULL,n)
      return(map+minloc)
    }
    else if(step>0 && off.end == 0) {
      if(ncol(map)==1) return(map+minloc)

      a <- seq(floor(min(map[1,])),max(map[1,]),
               by = step)
      a <- a[is.na(match(a,map[1,]))]
      
      b <- sapply(a,function(x,y,z) {
          ZZ <- min((seq(along=y))[y > x])
          (x-y[ZZ-1])/(y[ZZ]-y[ZZ-1])*(z[ZZ]-z[ZZ-1])+z[ZZ-1] }, map[1,],map[2,])
      m1 <- c(a,map[1,])
      m2 <- c(b,map[2,])
      names(m1) <- names(m2) <- c(paste("loc",a,sep=""),markernames)
      return(rbind(sort(m1),sort(m2))+minloc)
    }
    else {
      a <- seq(floor(min(map[1,])-off.end),ceiling(max(map[1,])+off.end+step),
               by = step)
      a <- a[is.na(match(a,map[1,]))]
      # no more than one point above max(map)+off.end
      z <- (seq(along=a))[a >= max(map[1,])+off.end]
      if(length(z) > 1) a <- a[-z[-1]]

      b <- sapply(a,function(x,y,z,ml) {
        if(x < min(y)) {
          return(min(z) - (min(y)-x)/diff(range(y))*diff(range(z)) - ml)
        }
        else if(x > max(y)) {
          return(max(z) + (x - max(y))/diff(range(y))*diff(range(z)) - ml)
        }
        else {
          ZZ <- min((seq(along=y))[y > x])
          (x-y[ZZ-1])/(y[ZZ]-y[ZZ-1])*(z[ZZ]-z[ZZ-1])+z[ZZ-1]
        }
        }, map[1,],map[2,], minloc[2])
      m1 <- c(a,map[1,])
      m2 <- c(b,map[2,])
      names(m1) <- names(m2) <- c(paste("loc",a,sep=""),markernames)
      return(rbind(sort(m1),sort(m2))+minloc)
    }
  }
}

  
######################################################################
#
# convert.cross: convert a "qtl.cross" data set from the format
#                used in old versions (<= 0.65) of R/qtl to the
#                updated data structure (versions >= 0.70).
#
######################################################################

convert.cross <-
function(cross)   
{
  nchr <- length(cross$map)
  geno <- vector("list",nchr)
  nmar <- c(0,cumsum(sapply(cross$map,length)))
  for(i in 1:nchr) {
    whichpos <- (nmar[i]+1):nmar[i+1]
    geno[[i]] <- list(data=cross$geno[,whichpos],map=cross$map[[i]])
    dimnames(geno[[i]]$data) <- list(NULL, names(cross$map[[i]]))
    class(geno[[i]]) <- "A"
    chr.name <- names(cross$map)[i]
    if(chr.name == "X" || chr.name == "x")
      class(geno[[i]]) <- "X"
  }
  names(geno) <- names(cross$map)
  cross$geno <- geno
  type <- cross$type
  cross <- cross[1:2]
  class(cross) <- c(type,"cross")
  cross
}

    

######################################################################
#
# clean
# 
# remove all of the extraneous stuff from a cross object, to get back
# to just the data
#
######################################################################

clean <-
function(cross)
{
  cross2 <- list(geno=cross$geno,pheno=cross$pheno)

  for(i in 1:length(cross$geno)) {
    cross2$geno[[i]] <- list(data=cross$geno[[i]]$data,
                             map=cross$geno[[i]]$map)
    class(cross2$geno[[i]]) <- class(cross$geno[[i]])
  }
    
  class(cross2) <- class(cross)
  cross2
}


######################################################################
#
# drop.qtlgeno
#
# remove any QTLs from the genotype data and the genetic maps
# from data simulated via sim.cross. (They all have names "QTL*")
#
######################################################################

#drop.qtlgeno <-
#function(cross)  
#{
#  n.chr <- nchr(cross)
#  mar.names <- lapply(cross$geno, function(a) {
#    m <- a$map
#    if(is.matrix(m)) return(colnames(m))
#    else return(names(m)) } )
#    
#  for(i in 1:n.chr) {
#    o <- grep("^QTL[0-9]+",mar.names[[i]])
#    if(length(o) != 0) {
#      cross$geno[[i]]$data <- cross$geno[[i]]$data[,-o,drop=FALSE]
#      if(is.matrix(cross$geno[[i]]$map)) 
#        cross$geno[[i]]$map <- cross$geno[[i]]$map[,-o,drop=FALSE]
#      else
#        cross$geno[[i]]$map <- cross$geno[[i]]$map[-o]
#    }
#  }
#  cross
#}

######################################################################
#
# drop.nullmarkers
#
# remove markers that have no genotype data from the data matrix and
# genetic maps
#
######################################################################

drop.nullmarkers <-
function(cross)
{
  n.chr <- nchr(cross)

  keep.chr <- rep(TRUE,n.chr)
  for(i in 1:n.chr) {
    o <- !apply(cross$geno[[i]]$data,2,function(a) sum(!is.na(a)))
    if(any(o)) { # remove from genotype data and map
      mn.drop <- colnames(cross$geno[[i]]$data)[o]
      if(length(mn.drop) == ncol(cross$geno[[i]]$data)) 
        keep.chr[i] <- FALSE # removing all markers from this chromosome

      cross$geno[[i]]$data <- cross$geno[[i]]$data[,!o,drop=FALSE]

      if(is.matrix(cross$geno[[i]]$map)) 
        cross$geno[[i]]$map <- cross$geno[[i]]$map[,!o,drop=FALSE]
      else
        cross$geno[[i]]$map <- cross$geno[[i]]$map[!o]

      # results of calc.genoprob
      if(!is.na(match("prob",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$prob))
        cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,-o,,drop=FALSE]
      }

      # results of argmax.geno
      if(!is.na(match("argmax",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$argmax))
        cross$geno[[i]]$argmax <- cross$geno[[i]]$argmax[,-o,drop=FALSE]
      }

      # results of sim.geno
      if(!is.na(match("draws",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$draws))
        cross$geno[[i]]$draws <- cross$geno[[i]]$draws[,-o,,drop=FALSE]
      }

      # results of est.rf
      if(!is.na(match("rf",names(cross)))) {
        o <- match(mn.drop,colnames(cross$rf))
        cross$rf <- cross$rf[-o,-o]
      }
    }
  }
  cross$geno <- cross$geno[keep.chr]

  cross
}

    
######################################################################
#
# drop.markers
#
# remove a vector of markers from the data matrix and genetic maps
#
######################################################################

drop.markers <-
function(cross,markers)
{
  n.chr <- nchr(cross)

  keep.chr <- rep(TRUE,n.chr)
  found <- rep(FALSE, length(markers))
  for(i in 1:n.chr) {
    # find markers on this chromosome
    o <- match(markers,colnames(cross$geno[[i]]$data))
    found[!is.na(o)] <- TRUE
    o <- o[!is.na(o)]
    a <- rep(FALSE,ncol(cross$geno[[i]]$data))
    a[o] <- TRUE
    o <- a
    
    if(any(o)) { # remove from genotype data and map
      mn.drop <- colnames(cross$geno[[i]]$data)[o]
      if(length(mn.drop) == ncol(cross$geno[[i]]$data)) 
        keep.chr[i] <- FALSE # removing all markers from this chromosome

      cross$geno[[i]]$data <- cross$geno[[i]]$data[,!o,drop=FALSE]

      if(is.matrix(cross$geno[[i]]$map)) 
          x <- cross$geno[[i]]$map[,!o,drop=FALSE]
      else 
        cross$geno[[i]]$map <- cross$geno[[i]]$map[!o]

      # results of calc.genoprob
      if(!is.na(match("prob",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$prob))
        cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,-o,,drop=FALSE]
      }

      # results of argmax.geno
      if(!is.na(match("argmax",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$argmax))
        cross$geno[[i]]$argmax <- cross$geno[[i]]$argmax[,-o,drop=FALSE]
      }

      # results of sim.geno
      if(!is.na(match("draws",names(cross$geno[[i]])))) {
        o <- match(mn.drop,colnames(cross$geno[[i]]$draws))
        cross$geno[[i]]$draws <- cross$geno[[i]]$draws[,-o,,drop=FALSE]
      }

      # results of est.rf
      if(!is.na(match("rf",names(cross)))) {
        o <- match(mn.drop,colnames(cross$rf))
        cross$rf <- cross$rf[-o,-o]
      }
    }
  }

  if(any(!found)) 
    warning("Markers not found: ", paste(markers[!found],collapse=" "))

  cross$geno <- cross$geno[keep.chr]

  cross
}

    
######################################################################
#
# geno.table
#
# create table showing observed numbers of individuals with each
# genotype at each marker
#
######################################################################

geno.table <- 
function(cross)
{
  n.chr <- nchr(cross)

  type <- class(cross)[1]
  if(type == "f2" || type=="f2ss") {
    n.gen <- 5
    gen.names <- c("AA","AB","BB","AA/AB","AB/BB")
  }
  else if(type == "bc") {
    n.gen <- 2
    gen.names <- c("AA","AB")
  }
  else if(type == "risib" || type=="riself") {
    n.gen <- 2
    gen.names <- c("AA","BB")
  }
  else if(type == "4way") {
    n.gen <- 10
    gen.names <- c("AC","BC","AD","BD","AC/AD","BC/BD",
                   "AC/BC","AD/BD","AC/BD","AD/BC")
  }
  else stop("Unknown cross type: ",type)
    
  res <- lapply(cross$geno, function(a,ngen) {
                a <- a$data; a[is.na(a)] <- 0
                apply(a,2,function(b,ngen) table(factor(b,levels=0:ngen)),ngen)
                },n.gen)
  results <- NULL
  for(i in 1:length(res)) 
    results <- rbind(results,t(res[[i]]))
  colnames(results) <- c("missing",gen.names)
  rownames(results) <- unlist(lapply(cross$geno,function(a) colnames(a$data)))

  pval <- rep(NA,nrow(results))
  if(type=="bc" || type=="risib" || type=="riself") {
    for(i in 1:length(pval)) {
      x <- results[i,2:3]
      if(sum(x) > 0)
        pval[i] <- chisq.test(x,p=c(0.5,0.5))$p.value
    }
    results <- cbind(results, P.value=pval)
  }
  else if(type=="f2") {
    # determine whether marker is autosomal or X-linked
    mar.type <- unlist(sapply(cross$geno,function(a) rep(class(a),ncol(a$data))))

    for(i in 1:length(pval)) {
      if(mar.type[i] == "A") {
        x <- results[i,2:4]
        y <- results[i,5:6]
        if(sum(x) > 0 && sum(y)==0)
          pval[i] <- chisq.test(x,p=c(0.25,0.5,0.25))$p.value
      }
      else {
        x <- results[i,2:3]
        y <- results[i,4:6]
        if(sum(x) > 0 && sum(y)==0)
          pval[i] <- chisq.test(x,p=c(0.5,0.5))$p.value
      }
    }
    results <- cbind(results, P.value=pval)
  }    
  else if(type == "4way") {
    # determine whether marker is autosomal or X-linked
    mar.type <- unlist(sapply(cross$geno,function(a) rep(class(a),ncol(a$data))))

    for(i in 1:length(pval)) {
      if(mar.type[i] == "A") {
        x <- results[i,2:5]
        y <- results[i,-(1:5)]
        if(sum(x) > 0 && sum(y)==0)
          pval[i] <- chisq.test(x,p=c(0.25,0.25,0.25,0.25))$p.value
      }
    }
    results <- cbind(results, P.value=pval)
  }   

  data.frame(chr=rep(names(cross$geno),nmar(cross)),results)
}
    
# map functions
mf.k <- function(d) 0.5*tanh(d/50)
mf.h <- function(d) 0.5*(1-exp(-d/50))
imf.k <- function(r) 50*atanh(2*r)
imf.h <- function(r) -50*log(1-2*r)
mf.m <- function(d) sapply(d,function(a) min(a/100,0.5))
imf.m <- function(r) sapply(r,function(a) min(a*100,50))

# carter-falconer: mf.cf, imf.cf
imf.cf <- function(r) 12.5*(log(1+2*r)-log(1-2*r))+25*atan(2*r)

mf.cf <-
function(d)
{
  icf <- function(r,d)
    imf.cf(r)-d

  sapply(d,function(a) {
    if(a==0) return(0)
    uniroot(icf, c(0,0.5-1e-10),d=a)$root })
}


# convert F2 intercross to sex-specific
convert2ss <-
function(cross)  
{
  if(class(cross)[1] != "f2")
    stop("This function applies only to f2 crosses.")

  class(cross)[1] <- "f2ss"

#  for(i in 1:nchr(cross)) 
#    cross$geno[[i]]$map <- rbind(cross$geno[[i]]$map,
#                                 cross$geno[[i]]$map)
  cross <- makeSSmap(cross)

  cross
}

######################################################################
#
# switch.order: change the marker order on a given chromosome to some
#               specified order
#
######################################################################

switch.order <-
function(cross, chr, order, error.prob=0,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  map.function <- match.arg(map.function)
  
  # check chromosome argument
  if(is.character(chr)) {
    old.chr <- chr
    chr <- match(chr, names(cross$geno))
    if(length(chr) > 1) chr <- chr[1]
    if(is.na(chr))
      stop("There is no chromosome named", chr)
  }

  # check order argument
  n.mar <- nmar(cross)
  if(n.mar[chr] == length(order)-2 || n.mar[chr]==length(order)-1) 
    order <- order[1:n.mar[chr]]     # useful for output from ripple()
  if(n.mar[chr] != length(order))
    stop("Incorrect number of markers.")

  # save recombination fractions
  flag <- 0
  if(!is.na(match("rf",names(cross)))) {
    rf <- cross$rf
    # determine column within rec fracs
    oldcols <- cumsum(c(0,n.mar))[chr]+seq(along=order)
    newcols <- cumsum(c(0,n.mar))[chr]+order
    rf[oldcols,] <- rf[newcols,]
    rf[,oldcols] <- rf[,newcols]
    colnames(rf)[oldcols] <- colnames(rf)[newcols]
    rownames(rf)[oldcols] <- rownames(rf)[newcols]
    flag <- 1
  }

  # remove any intermediate calculations (except rec fracs),
  #   as they will no longer be meaningful
  cross <- clean(cross)

  # re-order markers
  cross$geno[[chr]]$data <- cross$geno[[chr]]$data[,order,drop=FALSE]
  m <- seq(0,by=5,length=ncol(cross$geno[[chr]]$data))
  names(m) <- colnames(cross$geno[[chr]]$data)
  if(is.matrix(cross$geno[[chr]]$map)) 
    cross$geno[[chr]]$map <- rbind(m,m)
  else
    cross$geno[[chr]]$map <- m

  # re-estimate rec fracs for re-ordered chromosome
  if(flag==1) {
    temp <- est.rf(subset(cross, chr=chr))$rf
    rf[oldcols,oldcols] <- temp
    cross$rf <- rf
  }

  # re-estimate map
  newmap <- est.map(subset(cross,chr=chr),
                    error.prob=error.prob, map.function=map.function)

  cross$geno[[chr]]$map <- newmap[[1]]

  cross
}

######################################################################
#
# subset.cross: General subsetting function for a cross object
#
######################################################################

subset.cross <-
function(x, chr, ind, ...)  
{
  n.chr <- nchr(x)
  n.ind <- nind(x)

  # pull out relevant chromosomes
  if(!missing(chr)) {
    if(is.logical(chr)) {
      if(length(chr) != n.chr) 
        stop("If logical, chr argument must have length ", n.chr)
      chr <- sort((1:n.chr)[chr])
    }
        
    if(is.numeric(chr)) {
      # if all negative numbers, convert to positive
      if(all(chr < 1)) chr <- sort((1:n.chr)[chr])
      else chr <- sort(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.")
      # convert to numeric
      chr <- sort(match(chr,names(x$geno)))
    }

    if(!is.na(match("rf",names(x)))) { # pull out part of rec fracs
      n.mar <- nmar(x)
      n.chr <- n.chr
      wh <- rbind(c(0,cumsum(n.mar)[-n.chr])+1,cumsum(n.mar))
      dimnames(wh) <- list(NULL, names(n.mar))
      wh <- wh[,chr,drop=FALSE]
      wh <- unlist(apply(wh,2,function(a) a[1]:a[2]))
      x$rf <- x$rf[wh,wh]
    }

    x$geno <- x$geno[chr]
  }

  if(!missing(ind)) {
    if(is.logical(ind)) {
      if(length(ind) != n.ind) 
        stop("If logical, ind argument must have length ", n.ind)
      ind <- (1:n.ind)[ind]
    }
        
    if(is.numeric(ind)) {
      # if all negative numbers, convert to positive
      if(all(ind < 1)) ind <- (1:n.ind)[ind]
        
      if(any(ind < 1 | ind > n.ind))
        stop("Individual numbers out of range.")
    }
    else stop("ind argument must be either logical or numeric.")
    # Note: ind should now be a numeric vector

    if(length(ind) == 0)
      stop("Must retain at least one individual.")
    if(length(ind) == 1)
      warning("Retained only one individual!")

    x$pheno <- x$pheno[ind,,drop=FALSE]

    for(i in 1:nchr(x)) {
      x$geno[[i]]$data <- x$geno[[i]]$data[ind,,drop=FALSE]

      if(!is.na(match("prob",names(x$geno[[i]])))) 
        x$geno[[i]]$prob <- x$geno[[i]]$prob[ind,,,drop=FALSE]
      if(!is.na(match("errorlod",names(x$geno[[i]])))) 
        x$geno[[i]]$errorlod <- x$geno[[i]]$errorlod[ind,,drop=FALSE]
      if(!is.na(match("argmax",names(x$geno[[i]])))) 
        x$geno[[i]]$argmax <- x$geno[[i]]$argmax[ind,,drop=FALSE]
      if(!is.na(match("draws",names(x$geno[[i]])))) 
        x$geno[[i]]$draws <- x$geno[[i]]$draws[ind,,,drop=FALSE]
    }
  }
  x
}

#pull.chr <-
#function(cross, chr) {
#  warning("pull.chr is deprecated; use subset.cross.")
#  subset.cross(cross, chr)
#}


######################################################################
#
# c.cross: Combine crosses
#
######################################################################

c.cross <-
function(...)
{
  args <- list(...)

  # if only one cross, just return it
  if(length(args)==1) return(args[[1]])

  if(any(sapply(args, function(a) class(a)[2]) != "cross"))
    stop("All arguments must be cross objects.")

  if(length(unique(sapply(args, nchr))) > 1) 
    stop("All arguments must have the same number of chromosomes.")

  x <- args[[1]]
  chr <- names(x$geno)
  n.mar <- nmar(x)
  marnam <- unlist(lapply(x$geno,function(b) colnames(b$data)))

  for(i in 2:length(args)) {
    y <- args[[i]]
    y.marnam <- unlist(lapply(y$geno, function(b) colnames(b$data)))
    if(chr != names(y$geno) || any(n.mar != nmar(y)) || any(marnam != y.marnam))
      stop("All arguments must have the same chromosomes and markers.")
  }
    
  # get all phenotype names
  phenam <- names(x$pheno)
  for(i in 2:length(args))
    phenam <- c(phenam, names(args[[i]]$pheno))
  phenam <- unique(phenam)

  # form big phenotype matrix
  n.ind <- sapply(args,nind)
  pheno <- matrix(nrow=sum(n.ind),ncol=length(phenam))
  colnames(pheno) <- phenam
  pheno <- as.data.frame(pheno)

  for(i in 1:length(phenam)) {
    phe <- vector("list",length(args))
    for(j in 1:length(args)) {
      o <- match(phenam[i],names(args[[j]]$pheno))
      if(is.na(o)) phe[[j]] <- rep(NA,n.ind[j])
      else phe[[j]] <- args[[j]]$pheno[,o]
    }
    pheno[,i] <- unlist(phe)
  }

  # indicator of which cross
  whichcross <- matrix(0,ncol=length(args),nrow=sum(n.ind))
  colnames(whichcross) <- paste("cross",1:length(args),sep="")
  prev <- 0
  for(i in 1:length(args)) {
    wh <- prev + 1:n.ind[i]
    prev <- prev + n.ind[i]
    whichcross[wh,i] <- 1
  }
  pheno <- cbind(pheno,whichcross)

  # crosses must be all the same, or must be combination of F2 and BC
  classes <- sapply(args,function(a) class(a)[1])
  if(length(unique(classes))==1) {
    allsame <- TRUE
    type <- classes[1]
  }
  else {
    if(any(classes != "bc" & classes != "f2")) 
      stop("Experiments must be either the same type or be bc/f2.")
    allsame <- FALSE
    type <- "f2"
    which <- rep(c(0,1)[match(classes,c("bc","f2"))],n.ind)
    pheno <- cbind(pheno,which)
  }

  x$pheno <- pheno

  # create genotype information
  geno <- x$geno
  for(j in 1:nchr(x)) { # drop extraneous stuff
    geno[[j]] <- list(data=geno[[j]]$data, map=geno[[j]]$map)
    class(geno[[j]]) <- class(x$geno[[j]])
  }
  for(i in 2:length(args)) 
    for(j in 1:nchr(x))
      geno[[j]]$data <- rbind(geno[[j]]$data,args[[i]]$geno[[j]]$data)
  
  # if probs exist in each and all have the same
  #     set up values, keep them
  wh <- sapply(args, function(a) match("prob",names(a$geno[[1]])))
  step <- sapply(args,function(a) attr(a$geno[[1]]$prob,"step"))
  error.prob <- sapply(args,function(a) attr(a$geno[[1]]$prob,"error.prob"))
  off.end <- sapply(args,function(a) attr(a$geno[[1]]$prob,"off.end"))
  map.function <- sapply(args,function(a) attr(a$geno[[1]]$prob,"map.function"))
  if(!any(is.na(wh)) && length(unique(step))==1 &&
     length(unique(error.prob))==1 && length(unique(off.end))==1 &&
     length(unique(map.function))==1) {
    if(allsame) { # all same cross type
      for(j in 1:nchr(x)) {
        geno[[j]]$prob <- array(dim=c(sum(n.ind),dim(x$geno[[j]]$prob)[-1]))
        dimnames(geno[[j]]$prob) <- dimnames(x$geno[[j]]$prob)
        prev <- 0
        for(i in 1:length(args)) {
          wh <- prev + 1:n.ind[i]
          prev <- prev + n.ind[i]
          geno[[j]]$prob[wh,,] <- args[[i]]$geno[[j]]$prob
        }
      }
    }
    else { # mixed F2 and BC
      for(j in 1:nchr(x)) {
        wh <- match("f2",classes)
        geno[[j]]$prob <- array(0,dim=c(sum(n.ind),dim(args[[wh]]$geno[[j]]$prob)[-1]))
        dimnames(geno[[j]]$prob) <- dimnames(args[[wh]]$geno[[j]]$prob)
        prev <- 0
        for(i in 1:length(args)) {
          wh <- prev + 1:n.ind[i]
          prev <- prev + n.ind[i]
          if(classes[i]=="f2") 
            geno[[j]]$prob[wh,,] <- args[[i]]$geno[[j]]$prob
          else # backcross
            geno[[j]]$prob[wh,,1:2] <- args[[i]]$geno[[j]]$prob
        }
      }
    }    

    for(j in 1:nchr(x)) {
      attr(geno[[j]]$prob,"step") <- step[1]
      attr(geno[[j]]$prob,"error.prob") <- error.prob[1]
      attr(geno[[j]]$prob,"off.end") <- off.end[1]
      attr(geno[[j]]$prob,"map.function") <- map.function[1]
    }
  }

  # if draws exist in each and all have the same
  #     set up values, keep them
  wh <- sapply(args, function(a) match("draws",names(a$geno[[1]])))
  step <- sapply(args,function(a) attr(a$geno[[1]]$draws,"step"))
  error.prob <- sapply(args,function(a) attr(a$geno[[1]]$draws,"error.prob"))
  off.end <- sapply(args,function(a) attr(a$geno[[1]]$draws,"off.end"))
  map.function <- sapply(args,function(a) attr(a$geno[[1]]$draws,"map.function"))
  ndraws <- sapply(args,function(a) dim(a$geno[[1]]$draws)[3])
  if(!any(is.na(wh)) && length(unique(step))==1 &&
     length(unique(error.prob))==1 && length(unique(off.end))==1 &&
     length(unique(map.function))==1 && length(unique(ndraws))==1) {
    for(j in 1:nchr(x)) {
      geno[[j]]$draws <- array(0,dim=c(sum(n.ind),dim(x$geno[[j]]$draws)[-1]))
      dimnames(geno[[j]]$draws) <- dimnames(x$geno[[j]]$draws)
      prev <- 0
      for(i in 1:length(args)) {
        wh <- prev + 1:n.ind[i]
        prev <- prev + n.ind[i]
        geno[[j]]$draws[wh,,] <- args[[i]]$geno[[j]]$draws
      }

      attr(geno[[j]]$draws,"step") <- step[1]
      attr(geno[[j]]$draws,"error.prob") <- error.prob[1]
      attr(geno[[j]]$draws,"off.end") <- off.end[1]
      attr(geno[[j]]$draws,"map.function") <- map.function[1]
    }
  }

  x <- list(geno=geno, pheno=pheno)
  class(x) <- c(type,"cross")
  x
} 

######################################################################
#
# fill.geno: Run argmax.geno or sim.geno and then fill in the
#            genotype data with the results.  This will allow
#            rough genome scans by marker regression without
#            holes.  WE WOULD NOT PLACE ANY TRUST IN THE RESULTS!
#
######################################################################

fill.geno <-
function(cross, method=c("imp","argmax"), error.prob=0,
         map.function=c("haldane","kosambi","c-f","morgan"))
{
  method <- match.arg(method)
  
  # don't let error.prob be exactly zero (or >1)
  if(error.prob < 1e-50) error.prob <- 1e-50
  if(error.prob > 1) {
    error.prob <- 1-1e-50
    warning("error.prob shouldn't be > 1!")
  }

  # remove any extraneous material
  cross <- clean(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)

  if(method=="imp") {
    # do one imputation
    temp <- sim.geno(cross,n.draws=1,step=0,off.end=0,
                     error.prob=error.prob,map.function=map.function)
    # replace the genotype data with the results,
    #     stripping off any attributes
    for(i in 1:n.chr) {
      nam <- colnames(cross$geno[[i]]$data)
      cross$geno[[i]]$data <-
        matrix(as.numeric(temp$geno[[i]]$draws[,,1]),ncol=n.mar[i])
      colnames(cross$geno[[i]]$data) <- nam
    }
  }
  else {
    # run the Viterbi algorithm
    temp <- argmax.geno(cross,step=0,off.end=0,error.prob=error.prob,
                        map.function=map.function)
    # replace the genotype data with the results,
    #     stripping off any attributes
    for(i in 1:n.chr) {
      nam <- colnames(cross$geno[[i]]$data)
      cross$geno[[i]]$data <-
        matrix(as.numeric(temp$geno[[i]]$argmax),ncol=n.mar[i])
      colnames(cross$geno[[i]]$data) <- nam
    }
  }
  cross
}

######################################################################
#
# checkcovar
#
# This is a utility function for scanone and scantwo.  We remove  
# individuals with missing phenotypes or covariates and check
# that the covariates are of the appropriate form.
#
######################################################################

checkcovar <-
function(cross, pheno.col, addcovar, intcovar)
{
  chrtype <- sapply(cross$geno, class)

  # drop individuals whose sex or pgm is missing if X chr is included
  if(any(chrtype=="X")) {
    sexpgm <- getsex(cross)
    keep <- rep(TRUE,nind(cross))
    flag <- 0
    if(!is.null(sexpgm$sex)) {
      if(any(is.na(sexpgm$sex))) {
        keep[is.na(sexpgm$sex)] <- FALSE
        flag <- 1
      }
    }
    if(!is.null(sexpgm$pgm)) {
      if(any(is.na(sexpgm$pgm))) {
        keep[is.na(sexpgm$pgm)] <- FALSE
        flag <- 1
      }
    }
    if(flag) {
      warning("Dropping ", sum(!keep), " individuals with missing sex or pgm.\n")
      cross <- subset(cross, ind=keep)
      if(!is.null(addcovar)) {
        if(!is.matrix(addcovar)) addcovar <- addcovar[keep]
        else addcovar <- addcovar[keep,]
      }
      if(!is.null(intcovar)) {
        if(!is.matrix(intcovar)) intcovar <- intcovar[keep]
        else intcovar <- intcovar[keep,]
      }
    }
  }

  # check phenotypes
  if(length(pheno.col) > 1) pheno.col <- pheno.col[1]
  if(pheno.col < 1 || pheno.col > nphe(cross))
    stop("Specified phenotype column is invalid.")

  orig.n.ind <- nind(cross)

  # drop individuals with missing phenotypes
  pheno <- cross$pheno[,pheno.col]
  if(any(is.na(pheno))) {
    keep.ind <- (1:length(pheno))[!is.na(pheno)]
    cross <- subset.cross(cross,ind=keep.ind)
    pheno <- pheno[keep.ind]
  }
  else keep.ind <- 1:nind(cross)
  n.ind <- nind(cross)
  n.chr <- nchr(cross)      # number of chromosomes
  type <- class(cross)[1]   # type of cross

  n.addcovar <- n.intcovar <- 0
  if(!is.null(addcovar)) { # for additive covariates
    if(!is.matrix(addcovar)) {
      if(is.vector(addcovar) || is.data.frame(addcovar))
        addcovar <- as.matrix(addcovar)
      else stop("addcovar should be a matrix")
    }
    if(!all(apply(addcovar,2,is.numeric)))
      stop("All columns of addcovar must be numeric")
    if( nrow(addcovar) != orig.n.ind ) {
      # the length of additive covariates is incorrect
      stop("Number of rows in additive covariates is incorrect")
    }
    addcovar <- addcovar[keep.ind,,drop=FALSE]
    n.addcovar <- ncol(addcovar)
  }
  if(!is.null(intcovar)) { # interacting covariates
    if(!is.matrix(intcovar)) {
      if(is.vector(intcovar) || is.data.frame(intcovar))
        intcovar <- as.matrix(intcovar)
      else stop("intcovar should be a matrix")
    }
    if(!all(apply(intcovar,2,is.numeric)))
      stop("All columns of intcovar must be numeric")
    if(nrow(intcovar)[1] != orig.n.ind) {
      # the length of interacting covariates is incorrect
      stop("The length of interacting covariates is incorrect!")
    }
    intcovar <- intcovar[keep.ind,,drop=FALSE]
    n.intcovar <- ncol(intcovar)
  }

  # drop individuals missing any covariates
  if(!is.null(addcovar)) { # note that intcovar is contained in addcovar
    wh <- apply(cbind(addcovar,intcovar),1,function(a) any(is.na(a)))
    if(any(wh)) {
      cross <- subset.cross(cross,ind=(!wh))
      pheno <- pheno[!wh]
      addcovar <- addcovar[!wh,,drop=FALSE]
      if(!is.null(intcovar)) intcovar <- intcovar[!wh,,drop=FALSE]
      n.ind <- nind(cross)
      warning("Dropping ", sum(wh), " individuals with missing covariates.\n")
    }
  }

  # make sure columns of intcovar are contained in addcovar
  if(!is.null(intcovar)) {
    if(is.null(addcovar)) {
      addcovar <- intcovar
      n.addcovar <- n.intcovar
      warning("addcovar forced to contain all columns of intcovar\n")
    }
    else {
      wh <- 1:n.intcovar
      for(i in 1:n.intcovar) {
        o <- (apply(addcovar,2,function(a,b) max(abs(a-b)),intcovar[,i])<1e-14)
        if(any(o)) wh[i] <- (1:n.addcovar)[o]
        else wh[i] <- NA
      }
      if(any(is.na(wh))) {
        addcovar <- cbind(addcovar,intcovar[,is.na(wh)])
        n.addcovar <- ncol(addcovar)
        warning("addcovar forced to contain all columns of intcovar")
      }
    }
  }

  list(cross=cross, pheno=pheno, addcovar=addcovar, intcovar=intcovar,
       n.addcovar=n.addcovar, n.intcovar=n.intcovar)
}

# Find the nearest marker to a particular position
find.marker <-
function(cross, chr, pos)  
{
  # if chr has length 1, expand if necessary
  if(length(chr) == 1) 
    chr <- rep(chr,length(pos))
  # otherwise, chr and pos should have same length
  else if(length(chr) != length(pos)) 
    stop("chr and pos must be the same length.")

  markers <- rep("",length(chr))
  for(i in 1:length(chr)) {
    # find chromosome
    o <- match(chr[i], names(cross$geno))
    if(is.na(o)) markers[i] <- NA  # chr not matched
    else {
      thismap <- cross$geno[[o]]$map # genetic map

      # sex-specific map; look at female positions
      if(is.matrix(thismap)) thismap <- thismap[1,]
      
      # find closest marker
      d <- abs(thismap-pos[i])
      o2 <- (1:length(d))[d==min(d)]
      if(length(o2)==1) markers[i] <- names(thismap)[o2]
      # if multiple markers are equidistant,
      #     choose the one with the most data
      #     or choose among them at random
      else {
        x <- names(thismap)[o2]
        n.geno <- apply(cross$geno[[o]]$data[,o2],2,function(a) sum(!is.na(a)))
        o2 <- o2[n.geno==max(n.geno)]
        markers[i] <- names(thismap)[sample(o2,1)]
      }
    }
  }

  markers
}


# expand recombination fractions for RI lines
adjust.rf.ri <-
function(r, type=c("self","sib"), chrtype=c("A","X"), expand=TRUE)
{
  # type of RI lines
  type <- match.arg(type)
  chrtype <- match.arg(chrtype)

  if(type=="self") {
    if(expand) return(r*2/(1+2*r))
    else return(r/2/(1-r))
  }
  else {
    if(chrtype=="A") { # autosome / sib mating
      if(expand) return(r*4/(1+6*r))
      else return(r/(4-6*r))
    }
    else { # X chromosome/ sib mating
      if(expand) return(8/3*r/(1+4*r))
      else return(3/8*r/(1-1.5*r))
    }
  }
}

######################################################################
# pull.geno
######################################################################
pull.geno <-
function(cross)
{
  X <- cross$geno[[1]]$data
  if(nchr(cross) > 1)
    for(i in 2:nchr(cross))
      X <- cbind(X, cross$geno[[i]]$data)
  X
}

######################################################################
# lodint: function to get lod support interval
######################################################################
lodint <-
function(results, chr, drop=1.5)
{
  results <- results[results[,1]==chr,]

  if(all(is.na(results[,3]))) return(NULL)

  maxlod <- max(results[,3],na.rm=TRUE)
  w <- which(!is.na(results[,3]) & results[,3] == maxlod)
  o <- range(which(!is.na(results[,3]) & results[,3] > maxlod-drop))

  if(length(o)==0) o <- c(1,nrow(results))

  else {
    if(o[1] > 1) o[1] <- o[1]-1
    if(o[2] < nrow(results)) o[2] <- o[2]+1
  }

  results <- results[c(o[1],w,o[2]),]
  class(results) <- c("scanone","data.frame")

  results
}


######################################################################
# makeSSmap: convert a genetic map, or the genetic maps in a cross
#            object, to be sex-specific (i.e., 2-row matrices)
######################################################################
makeSSmap <-
function(cross)
{
  if(class(cross)[1] == "map") {
    # input object is a genetic map
    for(i in 1:length(cross)) {
      if(!is.matrix(cross[[i]]))
        cross[[i]] <- rbind(cross[[i]], cross[[i]])
    }
  }
  else { # input object is assumed to be a "cross" object
    n.chr <- nchr(cross)
    for(i in 1:n.chr) {
      if(!is.matrix(cross$geno[[i]]$map))
        cross$geno[[i]]$map <-
          rbind(cross$geno[[i]]$map, cross$geno[[i]]$map)
    }
  }

  cross
}

######################################################################
# comparecrosses: verify that two cross objects have identical
#                 classes, chromosomes, markers, genotypes, maps,
#                 and phenotypes
######################################################################
comparecrosses <-
function(cross1, cross2, tol=1e-5)
{
  # both are of class "cross"
  if(is.na(match("cross", class(cross1)))) 
    stop("cross1 is not a cross object.")
  if(is.na(match("cross", class(cross2)))) 
    stop("cross2 is not a cross object.")

  # classes are the same
  if(any(class(cross1) != class(cross2))) 
    stop("crosses are not the same type.")

  if(nchr(cross1) != nchr(cross2)) 
    stop("crosses do not have the same number of chromosomes.")

  if(any(names(cross1$geno) != names(cross2$geno)))
    stop("Chromosome names do not match.")

  if(any(nmar(cross1) != nmar(cross2)))
    stop("Number of markers per chromosome do not match.")

  mnames1 <- unlist(lapply(cross1$geno, function(a) colnames(a$data)))
  mnames2 <- unlist(lapply(cross2$geno, function(a) colnames(a$data)))
  if(any(mnames1 != mnames2)) {
#    stop("Markers names do not match.")
    for(i in 1:nchr(cross1)) 
      if(any(colnames(cross1$geno[[i]]$data) != colnames(cross2$geno[[i]]$data)))
        stop("Marker names on chr ", names(cross1$geno)[i], " don't match.")
  }


  chrtype1 <- sapply(cross1$geno, class)
  chrtype2 <- sapply(cross2$geno, class)
  if(any(chrtype1 != chrtype2))
    stop("Chromosome types (autosomal vs X) do not match.")

  for(i in 1:nchr(cross1)) {
    if(any(abs(diff(cross1$geno[[i]]$map) - diff(cross2$geno[[i]]$map)) > tol))
      stop("Genetic maps for chromosome ", names(cross1$geno)[i],
           " do not match.")
      
    if(abs(cross1$geno[[i]]$map[1] - cross2$geno[[i]]$map[1]) > tol)
      warning("Initial marker positions for chromosome ", names(cross1$geno)[i],
              " do not match.")
  }

  if(nind(cross1) != nind(cross2))
    stop("Number of individuals do not match.")

  for(i in 1:nchr(cross1)) {
    g1 <- cross1$geno[[i]]$data
    g2 <- cross2$geno[[i]]$data
    if(any((is.na(g1) & !is.na(g2)) | (!is.na(g1) & is.na(g2)) |
           (!is.na(g1) & !is.na(g2) & g1!=g2))) 
      stop("Genotype data for chromosome ", names(cross1$geno)[i],
           " do not match.")
  }

  if(nphe(cross1) != nphe(cross2))
    stop("Number of phenotypes do not match.")

  if(any(names(cross1$pheno) != names(cross2$pheno)))
    stop("Phenotype names do not match.")

  for(i in 1:nphe(cross1)) {
    phe1 <- cross1$pheno[,i]
    phe2 <- cross2$pheno[,i]
    if(is.numeric(phe1) & is.numeric(phe2)) {
      if(any((is.na(phe1) & !is.na(phe2)) | (!is.na(phe1) & is.na(phe2)) |
             (!is.na(phe1) & !is.na(phe2) & abs(phe1-phe2) > tol))) {
        stop("Data for phenotype ", names(cross1$pheno)[i],
             " do not match.")
      }
    }
    else {
      if(any((is.na(phe1) & !is.na(phe2)) | (!is.na(phe1) & is.na(phe2)) |
             (!is.na(phe1) & !is.na(phe2) &
              as.character(phe1) != as.character(phe2)))) {
        stop("Data for phenotype ", names(cross1$pheno)[i], " do not match.")
      }
    }
  }

  cat("\tCrosses are identical.\n")
}


######################################################################
# move marker
# Move a marker to a new chromosome...placed at the end
######################################################################
movemarker <-
function(cross, marker, newchr, newpos)
{
  cross <- clean(cross)
  mnames <- unlist(lapply(cross$geno,function(a) colnames(a$data)))
  chr <- rep(names(cross$geno),nmar(cross))
  pos <- unlist(lapply(cross$geno,function(a) 1:ncol(a$data)))
  wh <- match(marker, mnames)

  # Marker found precisely once?
  if(is.na(wh)) stop(marker, " not found.\n")
  if(length(wh) > 1) stop(marker, " found multiple times.\n")

  if(is.na(match(newchr,names(cross$geno))))
    stop("Chromosome ", newchr, " not found.\n")

  chr <- chr[wh]
  pos <- pos[wh]

  # pull out genotype data
  g <- cross$geno[[chr]]$data[,pos]

  # delete marker
  if(nmar(cross)[chr] == 1)  # it's the only marker on that chromosome, so drop the chromosome
    cross$geno <- cross$geno[-match(chr,names(cross$geno))]
  else {
    cross$geno[[chr]]$data <- cross$geno[[chr]]$data[,-pos,drop=FALSE]
    if(is.matrix(cross$geno[[chr]]$map))
      cross$geno[[chr]]$map <- cross$geno[[chr]]$map[,-pos,drop=FALSE]
    else
      cross$geno[[chr]]$map <- cross$geno[[chr]]$map[-pos]
  }

  if(missing(newpos)) {
    # add marker to end of new chromosome
    n.mar <- nmar(cross)[newchr]
    cross$geno[[newchr]]$data <- cbind(cross$geno[[newchr]]$data,g)
    colnames(cross$geno[[newchr]]$data)[n.mar+1] <- marker
  
    if(is.matrix(cross$geno[[newchr]]$map)) {
      cross$geno[[newchr]]$map <- cbind(cross$geno[[newchr]]$map,
                                        cross$geno[[newchr]]$map[,n.mar]+10)
      colnames(cross$geno[[newchr]]$map)[n.mar+1] <- marker
    }
    else {
      cross$geno[[newchr]]$map <- c(cross$geno[[newchr]]$map,
                                    cross$geno[[newchr]]$map[n.mar]+10)
      names(cross$geno[[newchr]]$map)[n.mar+1] <- marker
    }
  }
  else {
    # add marker to the specified position
    dat <- cross$geno[[newchr]]$data
    map <- cross$geno[[newchr]]$map

    if(length(newpos) != 1)
      stop("newpos should be a single number.")

    if(is.matrix(map)) { # sex-specific maps
      wh <- which(map[1,] < newpos)
      if(length(wh) == 0) { # place in first spot
        map <- cbind(c(newpos,map[2,1]-(map[1,1]-newpos)),map)
        colnames(map)[1] <- marker
      }
      else {
        wh <- max(wh)
        if(wh == ncol(map)) { # place at end of chromosome
          map <- cbind(map,c(newpos,map[2,ncol(map)]+(newpos-map[1,ncol(map)])))
          colnames(map)[ncol(map)] <- marker
        }
        else {
          left <- map[,wh]
          right <- map[,wh+1]
          newpos2 <- (newpos-left[1])/(right[1]-left[1])*(right[2]-left[2])+left[2]
          map <- cbind(map[,1:wh], c(newpos,newpos2), map[,-(1:wh)])
          colnames(map)[wh+1] <- marker
        }
      }
    }
    else {
      wh <- which(map < newpos)
      if(length(wh) == 0) { # place in first position
        map <- c(newpos,map)
        names(map)[1] <- marker
      }
      else {
        wh <- max(wh)
        if(wh == length(map)) { # place in last position
          map <- c(map,newpos)
          names(map)[length(map)] <- marker
        }
        else {
          map <- c(map[1:wh],newpos,map[-(1:wh)])
          names(map)[wh+1] <- marker
        }
      }
    }
    cross$geno[[newchr]]$map <- map

    if(length(wh)==0) { # place marker in first position
      dat <- cbind(g, dat)
      colnames(dat)[1] <- marker
    }
    else if(wh == ncol(dat)) { # place marker in last position
      dat <- cbind(dat, g)
      colnames(dat)[ncol(dat)] <- marker
    }
    else { # place marker in the middle
      dat <- cbind(dat[,1:wh],g,dat[,-(1:wh)])
      colnames(dat)[wh+1] <- marker
    }
    cross$geno[[newchr]]$data <- dat
    
    # make sure the marker names for the data and the genetic map match
    colnames(cross$geno[[newchr]]$data) <- names(cross$geno[[newchr]]$map)
  }

  cross
}

######################################################################
#
# summary.map
#
# Give a short summary of a genetic map object.
# 
######################################################################
summary.map <- 
function(object, ...)
{
  map <- object
  if(length(class(map))>1 && class(map)[2] == "cross") # a cross object
    map <- pull.map(map)
  
  n.chr <- length(map)
  chrnames <- names(map)
  if(is.matrix(map[[1]])) { # sex-specific map
    sexsp <- TRUE
    n.mar <- sapply(map,ncol)
    tot.mar <- sum(n.mar)
    fmap <- lapply(map,function(a) a[1,])
    mmap <- lapply(map,function(a) a[2,])

    len.f <- sapply(fmap,function(a) diff(range(a)))
    len.m <- sapply(mmap,function(a) diff(range(a)))
    avesp.f <- sapply(fmap,function(a) mean(diff(a)))
    avesp.m <- sapply(mmap,function(a) mean(diff(a)))
    totlen.f <- sum(len.f)
    totlen.m <- sum(len.m)

    tot.avesp.f <- mean(unlist(lapply(fmap,diff)))
    tot.avesp.m <- mean(unlist(lapply(mmap,diff)))
                    
    output <- rbind(cbind(n.mar,len.f,len.m,avesp.f,avesp.m),
                    c(tot.mar,totlen.f,totlen.m,tot.avesp.f,tot.avesp.m))
    dimnames(output) <- list(c(chrnames,"overall"),
                             c("n.mar","length.female","length.male",
                               "ave.spacing.female","ave.spacing.male"))
  }                   
  else {
    sexsp=FALSE
    n.mar <- sapply(map,length)
    len <- sapply(map,function(a) diff(range(a)))
    tot.mar <- sum(n.mar)

    len <- sapply(map,function(a) diff(range(a)))
    avesp <- sapply(map,function(a) mean(diff(a)))
    totlen <- sum(len)
    tot.avesp <- mean(unlist(lapply(map,diff)))
                    
    output <- rbind(cbind(n.mar,len,avesp),
                    c(tot.mar,totlen,tot.avesp))
    dimnames(output) <- list(c(chrnames,"overall"),
                             c("n.mar","length","ave.spacing"))

  }

  output <- list(summarytable=output,sexsp=sexsp)
  class(output) <- "summary.map"
  output
}


######################################################################
#
# print.summary.map
#
# Print out the result of summary.map()
# 
######################################################################
print.summary.map <-
function(x, ...)  
{
  if(x[[2]]) cat("Sex-specific map\n\n")
  else cat("Sex-averaged map\n\n")

  x <- x[[1]]
  x <- apply(x,2,round,1)
  print(x)
}
  
######################################################################
#
# convert.scanone
#
# Convert scanone output from the format for R/qtl ver 0.97 to
# that for R/qtl ver 0.98
# (previously, inter-maker locations named loc*.c*; now c*.loc*)
#
######################################################################
convert.scanone <-
function(output)
{  
  rn <- rownames(output)
  o <- grep("^loc\-*[0-9]+(\.[0-9]+)*\.c[0-9A-Za-z]+$", rn)
  if(length(o) > 0) {
    temp <- rn[o]
    temp <- strsplit(temp,"\\.")
    temp <- sapply(temp, function(a)
                   paste(a[c(length(a),1:(length(a)-1))],collapse="."))
    rownames(output)[o] <- temp
  }
  output
}
            
######################################################################
# find.pheno
#
# utility to get pheno number given pheno name
######################################################################
find.pheno <-
function( cross,  pheno )
  seq( ncol( cross$pheno ))[match(pheno,names(cross$pheno))]

######################################################################
# find.flanking
#
# utility to get flanking and/or closest marker to chr and pos
######################################################################
find.flanking <-
function( cross, chr, pos)
{
  map = pull.map(cross)

  if(is.matrix(map[[1]]) && nrow(map[[1]]) > 1) 
    stop("This function works only for crosses with sex-averaged maps.")

  if(length(chr) == 1 && length(pos) > 1) {
    chr <- rep(chr,length(pos))
  }

  marker = NULL
  for (i in seq(length(chr))) {
    tmp = map[[chr[i]]]-pos[i]
    m = names(map[[chr[i]]])
    left = sum(tmp < 0)
    at = sum(tmp == 0)
    right = sum(tmp > 0)
    f <- if (at > 0)
      left+at[c(1,length(at))]
    else {
      if (right > 0)
        c(left,left+at+1)
      else
        c(left,left+at)
    }
    marker = rbind(marker,m[f[c(1:2,order(abs(tmp[f]))[1])]])
  }
  dimnames(marker) <- list(paste("chr",chr,":",pos,sep=""),
                           c("left","right","close"))
  as.data.frame(marker)
}


# end of util.R

######################################################################
#
# vbscan.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
# last modified Apr, 2004
# first written May, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: vbscan
#
######################################################################

######################################################################
#
# vbscan: scan genome for a quantitative phenotype for which some
# individuals' phenotype is undefined (for example, the size of a
# lesion, where some individuals have no lesion).
#
######################################################################

vbscan <-
function(cross, pheno.col=1, upper=FALSE, method="em", maxit=4000,
         tol=1e-4)
{
  method <- match.arg(method)
  type <- class(cross)[1]

  # check arguments are okay
  if(length(pheno.col) > 1) pheno.col <- pheno.col[1]
  if(pheno.col > nphe(cross))
    stop("Specified phenotype column exceeds the number of phenotypes")
  y <- cross$pheno[,pheno.col]

  # modify phenotypes
  if(upper) {
    if(!any(y == Inf)) y[y==max(y)] <- Inf
  }
  else {
    if(!any(y == -Inf)) y[y==min(y)] <- -Inf
  }
  survived <- rep(0,length(y))
  survived[y == -Inf | y == Inf] <- 1

  # The following line is included since .C() doesn't accept Infs
  y[y == -Inf | y == Inf] <- 99999

  n.chr <- nchr(cross)
  results <- NULL

  for(i in 1:n.chr) {
    # make sure inferred genotypes or genotype probabilities are available
    if(is.na(match("prob",names(cross$geno[[i]])))) {
      cat(" -Calculating genotype probabilities\n")
      cross <- calc.genoprob(cross)
    }

    genoprob <- cross$geno[[i]]$prob
    n.pos <- dim(genoprob)[2]
    n.ind <- length(y)

    chrtype <- class(cross$geno[[i]])
    if(chrtype=="X") sexpgm <- getsex(cross)
    else sexpgm <- NULL

    gen.names <- getgenonames(type,chrtype,"full", sexpgm)
    n.gen <- length(gen.names)

    # revise X chromosome genotypes
    if(chrtype=="X" && (type=="f2" || type=="f2ss" || type=="bc"))
      genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob)

    z <- .C("R_vbscan",
            as.integer(n.pos),
            as.integer(n.ind),
            as.integer(n.gen),
            as.double(genoprob),
            as.double(y),
            as.integer(survived),
            lod=as.double(rep(0,(4+2*n.gen)*n.pos)),
            as.integer(maxit),
            as.double(tol),
            PACKAGE="qtl")

    map <- create.map(cross$geno[[i]]$map,
                      attr(cross$geno[[i]]$prob,"step"),
                      attr(cross$geno[[i]]$prob,"off.end"))
    if(is.matrix(map)) map <- map[1,]

    res <- data.frame(chr=rep(names(cross$geno)[i],length(map)),
                      pos = map,
                      matrix(z$lod,nrow=n.pos,byrow=TRUE))

    w <- names(map)
    o <- grep("^loc\-*[0-9]+",w)

    if(length(o) > 0) # inter-marker locations cited as "c*.loc*"
      w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="")
    rownames(res) <- w
    
    colnames(res) <- c("chr","pos","lod","lod.p","lod.mu",
                       paste("pi",gen.names,sep="."),
                       paste("mu",gen.names,sep="."), "sigma")

    z <- res


    # get null log10 likelihood for the X chromosome
    if(chrtype=="X") {

      # determine which covariates belong in null hypothesis
      temp <- scanoneXnull(type, sexpgm)
      adjustX <- temp$adjustX
      dfX <- temp$dfX
      sexpgmcovar <- temp$sexpgmcovar
      sexpgmcovar.alt <- temp$sexpgmcovar.alt
      
      if(adjustX) { # get LOD-score adjustment 
        n.gen <- ncol(sexpgmcovar)+1
        genoprob <- matrix(0,nrow=n.ind,ncol=n.gen)
        for(i in 1:n.gen)
          genoprob[sexpgmcovar.alt==i,i] <- 1

        nullz <- .C("R_vbscan",
            as.integer(1),
            as.integer(n.ind),
            as.integer(n.gen),
            as.double(genoprob),
            as.double(y),
            as.integer(survived),
            lod=as.double(rep(0,(4+2*n.gen))),
            as.integer(maxit),
            as.double(tol),
            PACKAGE="qtl")

        # adjust LOD curve
        for(i in 1:3) z[,i+2] <- z[,i+2] - nullz$lod[i]
      }
    } 

    # if different number of columns from other chromosomes,
    #     expand to match
    if(!is.null(results) && ncol(z) != ncol(results)) {
      cnz <- colnames(z)
      cnr <- colnames(results)
      wh.zr <- match(cnz,cnr)
      wh.rz <- match(cnr,cnz)
      if(all(!is.na(wh.rz))) {
        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=ncol(z)))
        dimnames(newresults) <- list(rownames(results), cnz)
        newresults[,cnr] <- results
        results <- newresults
        for(i in 2:ncol(results))
          if(is.factor(results[,i])) results[,i] <- as.numeric(results[,i])
      }
      else if(all(!is.na(wh.zr))) {
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=ncol(results)))
        dimnames(newz) <- list(rownames(z), cnr)
        newz[,cnz] <- z
        z <- newz
        for(i in 2:ncol(z))
          if(is.factor(z[,i])) z[,i] <- as.numeric(z[,i])
      }
      else {
        newnames <- c(cnr, cnz[is.na(wh.zr)])

        newresults <- data.frame(matrix(NA,nrow=nrow(results),ncol=length(newnames)))
        dimnames(newresults) <- list(rownames(results), newnames)
        newresults[,cnr] <- results
        results <- newresults
        for(i in 2:ncol(results))
          if(is.factor(results[,i])) results[,i] <- as.numeric(results[,i])
        
        newz <- data.frame(matrix(NA,nrow=nrow(z),ncol=length(newnames)))
        dimnames(newz) <- list(rownames(z), newnames)
        newz[,cnz] <- z
        z <- newz
        for(i in 2:ncol(z))
          if(is.factor(z[,i])) z[,i] <- as.numeric(z[,i])
      }
    }

    results <- rbind(results, z)
  }
  
  # sort the later columns
  neworder <- c(colnames(results)[1:5],sort(colnames(results)[-(1:5)]))
  results <- results[,neworder]


  class(results) <- c("scanone","data.frame")
  attr(results,"method") <- method
  attr(results,"type") <- class(cross)[1]
  attr(results,"model") <- "twopart"
  results
}

# end of vbscan.R
######################################################################
#
# write.cross.R
#
# copyright (c) 2001-4, Karl W Broman, Johns Hopkins University
#                       and Hao Wu, The Jackson Laboratory
# last modified Sep, 2004
# first written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
# Contains: write.cross, write.cross.mm, write.cross.csv,
#           write.cross.gary, fixX4write
#           [See qtlcart_io.R for write.cross.qtlcart]
#
######################################################################


######################################################################
#
# write.cross: Wrapper for the other write.cross functions
#
######################################################################

write.cross <-
function(cross, format=c("csv","mm","qtlcart", "gary"), filestem="data", chr, digits=5)
{
  format <- match.arg(format)
  if(!missing(chr)) cross <- subset(cross,chr=chr)

  # revise X data
  chrtype <- sapply(cross$geno,class)
  crosstype <- class(cross)[1]
  if((crosstype=="bc" || crosstype=="f2" || crosstype=="f2ss") &&
     any(chrtype=="X")) {
    sexpgm <- getsex(cross)
    sex <- sexpgm$sex
    pgm <- sexpgm$pgm
    for(i in which(chrtype=="X")) 
      cross$geno[[i]]$data <- fixX4write(cross$geno[[i]]$data,sex,pgm,crosstype)
  }

  if(format=="csv") write.cross.csv(cross,filestem,digits)
  else if(format=="mm") write.cross.mm(cross,filestem,digits)
  else if(format=="qtlcart") write.cross.qtlcart(cross, filestem)
  else write.cross.gary(cross, digits)
}




######################################################################
#
# write.cross.mm: Write data for an experimental cross in Mapmaker
#                 format
#
#           creates two files: "raw" file with geno & pheno data
#                              "prep" file with map information
#
######################################################################

write.cross.mm <-
function(cross, filestem="data", digits=5)
{
  n.ind <- nind(cross)
  tot.mar <- totmar(cross)
  n.phe <- nphe(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)
  
  type <- class(cross)[1]
  if(type=="riself" || type=="risib") type <- "bc"
  if(type != "f2" && type != "bc")
    stop("write.cross.mm only works for intercross, backcross and RI data.")

  # write genotype and phenotype data
  file <- paste(filestem, ".raw", sep="")
  
  # write experiment type
  if(type == "f2") 
    write("data type f2 intercross", file, append=FALSE)
  else 
    write("data type f2 backcross", file, append=FALSE)

  # write numbers of progeny, markers and phenotypes
  write(paste(n.ind, tot.mar, n.phe), file, append=TRUE)

  # max length of marker name
  mlmn <- max(nchar(unlist(lapply(cross$geno,function(a) colnames(a$data)))))+1

  # write marker data
  for(i in 1:n.chr) {
    for(j in 1:n.mar[i]) {
      mn <- paste("*", colnames(cross$geno[[i]]$data)[j], sep="")
      if(nchar(mn) < mlmn)
        mn <- paste(mn,paste(rep(" ", mlmn-nchar(mn)),collapse=""),sep="")
      g <- cross$geno[[i]]$data[,j]
      
      x <- rep("", n.ind)
      x[is.na(g)] <- "-"
      x[!is.na(g) & g==1] <- "A"
      x[!is.na(g) & g==2] <- "H"
      if(type == "f2") {
        x[!is.na(g) & g==3] <- "B"
        x[!is.na(g) & g==4] <- "D"
        x[!is.na(g) & g==5] <- "C"
      }

      if(n.ind < 60)
        write(paste(mn, paste(x,collapse="")), file, append=TRUE)
      else {
        lo <- seq(1,n.ind-1,by=60)
        hi <- c(lo[-1]-1,n.ind)
        for(k in seq(along=lo)) {
          if(k==1) write(paste(mn,paste(x[lo[k]:hi[k]],collapse="")),file,append=TRUE)
          else write(paste(paste(rep(" ", mlmn),collapse=""),
                           paste(x[lo[k]:hi[k]],collapse="")),file,append=TRUE)
        }
      }

    }
  } # end writing marker data

  # max length of phenotype name
  mlpn <- max(nchar(colnames(cross$pheno)))+1

  # write phenotypes
  for(i in 1:n.phe) {
    pn <- paste("*",colnames(cross$pheno)[i],sep="")
    if(nchar(pn) < mlpn)
      pn <- paste(pn, paste(rep(" ", mlpn-nchar(pn)),collapse=""),sep="")

    if(!is.factor(cross$pheno[,i]))
      x <- as.character(round(cross$pheno[,i],digits))
    else
      x <- as.character(cross$pheno[,i])
    x[is.na(x)] <- "-"

    if(n.ind < 10)
      write(paste(pn, paste(x,collapse="")), file, append=TRUE)
    else {
      lo <- seq(1,n.ind-1,by=10)
      hi <- c(lo[-1]-1,n.ind)
      for(k in seq(along=lo)) {
        if(k==1) write(paste(pn,paste(x[lo[k]:hi[k]],collapse=" ")),file,append=TRUE)
        else write(paste(paste(rep(" ", mlpn),collapse=""),
                         paste(x[lo[k]:hi[k]],collapse=" ")),file,append=TRUE)
      }
    }
  }
    

  # make "prep" file with map information
  file <- paste(filestem, ".prep", sep="")

  for(i in 1:n.chr) {
    cname <- paste("chr", names(cross$geno)[i], sep="")
    line <- paste("make chromosome", cname)
    if(i==1) write(line, file, append=FALSE)
    else write(line, file, append=TRUE)

    mn <- names(cross$geno[[i]]$map)
#    dis <- round(diff(cross$geno[[i]]$map),2)
#    dis <- paste("=", dis, sep="")
#    write(paste(paste("sequence", mn[1]), paste(dis,mn[-1],collapse=" ")),
#          file, append=TRUE)
    write(paste(paste("sequence", mn[1]), paste(mn[-1],collapse=" ")),
          file, append=TRUE)

    write(paste("anchor", cname), file, append=TRUE)
    write(paste("framework", cname), file, append=TRUE)
  } 

} 

######################################################################
#
# write.cross.csv: Write data for an experimental cross in
#                  comma-delimited format (the same format as is read
#                  by read.cross.csv)
#
######################################################################

write.cross.csv <-
function(cross, filestem="data", digits=5)
{
  n.ind <- nind(cross)
  tot.mar <- totmar(cross)
  n.phe <- nphe(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)
  
  type <- class(cross)[1]
  if(type != "f2" && type != "bc" && type != "riself" && type != "risib")
    stop("write.cross.csv only works for intercross, backcross and RI data.")

  file <- paste(filestem, ".csv", sep="")
  
  geno <- matrix(ncol=tot.mar,nrow=n.ind)
  alleles <- c("A","H","B","D","C")
  firstmar <- 1
  for(i in 1:n.chr) {
    # replace allele numbers with 
    geno[,firstmar:(firstmar+n.mar[i]-1)] <-
      alleles[match(cross$geno[[i]]$data,1:5)]
    firstmar <- firstmar + n.mar[i]
  }
  if(any(is.na(geno))) geno[is.na(geno)] <- "-"
  pheno <- matrix(as.character(round(unlist(cross$pheno),digits)),nrow=n.ind)
  # factors: should be character by the levels rather than something like "1", "2", etc.
  for(i in 1:nphe(cross)) 
    if(is.factor(cross$pheno[,i])) pheno[,i] <- as.character(cross$pheno[,i])
  
  if(any(is.na(pheno))) pheno[is.na(pheno)] <- "-"
  data <- cbind(pheno,geno)
  colnames(data) <- c(colnames(cross$pheno),
                      unlist(lapply(cross$geno, function(a) colnames(a$data))))
  chr <- rep(names(cross$geno),n.mar)
  pos <- unlist(lapply(cross$geno,function(a) a$map))
  chr <- c(rep("",n.phe),chr)
  pos <- c(rep("",n.phe),as.character(round(pos,digits)))

  # write names
  write.table(matrix(colnames(data),nrow=1),file,append=FALSE,quote=FALSE,
              sep=",",row.names=FALSE,col.names=FALSE)
  # write chr IDs
  write.table(matrix(chr,nrow=1),file,append=TRUE,quote=FALSE,sep=",",
              row.names=FALSE,col.names=FALSE)
  # write marker positions
  write.table(matrix(pos,nrow=1),file,append=TRUE,quote=FALSE,sep=",",
              row.names=FALSE,col.names=FALSE)
  # write phenotype and genotype data
  write.table(data,file,append=TRUE,quote=FALSE,sep=",",row.names=FALSE,
              col.names=FALSE)

}


######################################################################
#
# write.cross.gary: Write data for an experimental cross in
# Gary's format. There will be 6 output files, they are:
#    chrid.dat - chromosome ids
#    markerpos.txt - marker position
#    mnames.txt - marker names
#    geno.data - genotypes
#    pheno.data - phenotypes
#    pnames.txt - phenotype names
#
######################################################################

write.cross.gary <-
function(cross, digits)
{
  # local variables
  n.ind <- nind(cross)
  tot.mar <- totmar(cross)
  n.phe <- nphe(cross)
  n.chr <- nchr(cross)
  n.mar <- nmar(cross)

  # chromosome ids
  chrid <- NULL
  for(i in 1:n.chr) {
    # the name for this chromosome
    chrname <- names(cross$geno[i])
    # convert to number (why?)
#    if(chrname=="X") chrname <- 20
#    else chrname <- as.numeric(chrname)
    chrid <- c(chrid, rep(chrname, n.mar[i]))
  }
  write.table(chrid, file="chrid.dat", quote=F, row.names=F,
              col.names=F)

  # marker position file
  markpos <- NULL
  for(i in 1:n.chr)
    markpos <- c(markpos, cross$geno[[i]]$map)
  write.table(markpos, file="markerpos.txt", quote=F, sep="\t",
              row.names=T, col.names=F)

  # marker names
  mnames <- names(markpos)
  write.table(mnames, file="mnames.txt", quote=F, row.name=F, col.names=F)

  # genotype
  geno <- NULL
  for(i in 1:n.chr)
    geno <- cbind(geno, cross$geno[[i]]$data)
  # note that gary's format codes genotype from 0
  # and 9 is for NA
  geno <- geno - 1 # note NA will still be NA
  write.table(geno, file="geno.dat", quote=F, row.name=F, col.name=F,
              sep="\t", na="9")

  # phenotype
  pheno <- matrix(as.character(round(unlist(cross$pheno),digits)),nrow=n.ind)
  for(i in 1:nphe(cross)) 
    if(is.factor(cross$pheno[,i])) pheno[,i] <- as.character(cross$pheno[,i])

  write.table(pheno, file="pheno.dat", quote=F, row.names=F,
              col.names=F, sep="\t", na="-999")
  # phenotype names
  write.table(names(cross$pheno), file="pnames.txt", quote=F, row.names=F,
              col.names=F, sep="\t", na="-999")

}
                          

######################################################################
# fixX4write
######################################################################

fixX4write <-
function(geno,sex,pgm,crosstype)
{
  # males
  if(!is.null(sex) & any(sex==1)) { 
    temp <- geno[sex==1,,drop=FALSE]
    temp[temp==2] <- 3
    geno[sex==1,] <- temp
  }

  if(crosstype == "f2" || crosstype=="f2ss") {

    # females
    if(!is.null(pgm)) {
      if(!is.null(sex) & any(sex==0)) {
        if(any(pgm==1)) {
          temp <- geno[sex==0 & pgm==1,,drop=FALSE]
          temp[temp==1] <- 3
          geno[sex==0 & pgm==1,] <- temp
        }
      }
      else { # assume all females
        if(any(pgm==1)) {
          temp <- geno[pgm==1,,drop=FALSE]
          temp[temp==1] <- 3
          geno[pgm==1,] <- temp
        }
      }
    }

  }
      
  geno
}

# end of write.cross.R 
#####################################################################
#
# xchr.R
#
# copyright (c) 2004, Karl W Broman, Johns Hopkins University
# last modified Jul, 2004
# first written Apr, 2004
# Licensed under the GNU General Public License version 2 (June, 1991)
# 
# Part of the R/qtl package
# Contains: Utilities for dealing with the X chromosome.
#           getsex, getgenonames, reviseXdata, scanoneXnull
#           [See also fixXgeno.bc & fixXgeno.f2 in read.cross.R]
#
######################################################################

# get sex and pgm columns from phenotype data
getsex <-
function(cross)
{
  phe.names <- names(cross$pheno)

  sex.column <- grep("^[Ss][Ee][Xx]$", phe.names)
  pgm.column <- grep("^[Pp][Gg][Mm]$", phe.names)

  if(length(sex.column)==0) { # no sex included
    sex <- NULL
  }
  else {
    if(length(sex.column)>1)
      warning("'sex' included multiple times.  Using the first one.")
    temp <- cross$pheno[,sex.column[1]]
    if(is.numeric(temp)) {
      if(any(!is.na(temp) & temp != 0 & temp != 1)) {
        warning("Sex column should be coded as 0=female 1=male; sex ignored.")
        sex <- NULL
      }
      else sex <- temp
    }
    else {
      if(!is.factor(temp)) temp <- as.factor(temp)

      if(length(levels(temp)) == 1) {
        if(levels(temp) == "F" || levels(temp)=="f") sex <- rep(0,nind(cross))
        else if(levels(temp) == "M" || levels(temp)=="m") sex <- rep(1,nind(cross))
        else 
          warning("Sex column should be coded as 0=female 1=male; sex ignored.")
      }
      else if(length(levels(temp)) > 2) {
        warning("Sex column should be coded as a two-level factor; sex ignored.")
        sex <- NULL
      }
      else { # is a factor with two levels
        lev <- levels(temp)
        if(length(grep("^[Ff]",lev))>0 &&
           length(males <- grep("^[Mm]",lev))>0) {
          temp <- as.character(temp)
          sex <- rep(0,length(temp))
          sex[is.na(temp)] <- NA
          sex[!is.na(temp) & temp==lev[males]] <- 1
        }
        else 
          warning("Don't understand levels in sex column; sex ignored.")
      }
    }
  }

  if(length(pgm.column)==0) { # no pgm included
    pgm <- NULL
  }
  else {
    if(length(pgm.column)>1)
      warning("'pgm' included multiple times.  Using the first one.")
    temp <- cross$pheno[,pgm.column[1]]
    if(!is.numeric(temp))
      temp <- as.numeric(temp)-1
    if(any(!is.na(temp) & temp != 0 & temp != 1)) {
      warning("pgm column should be coded as 0/1; pgm ignored.")
      pgm <- NULL
    }
    else pgm <- temp
  }

  list(sex=sex,pgm=pgm)
}
          


# get names of genotypes
# used in discan, effectplot, plot.pxg, scanone, scantwo, vbscan, reviseXdata
getgenonames <-
function(type=c("f2","bc","f2ss","riself","risib","4way"),
         chrtype=c("A","X"), expandX=c("simple","standard","full"),
         sexpgm)
{  
  sex <- sexpgm$sex
  pgm <- sexpgm$pgm

  # get rid of missing sex and pgm values, if there are any
  if(length(sex)>0) sex <- sex[!is.na(sex)]
  if(length(pgm)>0) pgm <- pgm[!is.na(pgm)]

  type <- match.arg(type)
  chrtype <- match.arg(chrtype)
  expandX <- match.arg(expandX)

  if(type=="riself" || type=="risib") 
    gen.names <- c("AA","BB")

  else if(type == "4way") {
    if(chrtype=="A") gen.names <- c("AC","BC","AD","BD")
    else gen.names <- c("AC","BC","AY","BY")
  }

  else if(type == "bc") {
    if(chrtype=="A") gen.names <- c("AA","AB") # autosome
    else { # X chromosome
 
#                 simple     standard       full      
#   -both sexes   A-/AB/BY   AA/AB/AY/BY    same as std
#   -all females  AA/AB      same           same
#   -all males    AY/BY      same           same

      if(length(sex)==0 || all(sex==0)) # all females
        gen.names <- c("AA","AB")
      else if(all(sex==1)) # all males
        gen.names <- c("AY","BY")
      else { # some of each
        if(expandX == "simple") gen.names <- c("A-", "AB", "BY")
        else gen.names <- c("AA","AB","AY","BY")
      }
    }
  }

  else { # intercross
    if(chrtype == "A")  # autosomal
      gen.names <- c("AA","AB","BB")
    else { # X chromsome

# both crosses     simple     standard         full
#   -both sexes   A-/AB/B-    AA/AB/BB/AY/BY   AA/AB1/AB2/BB/AY/BY
#   -all females  AA/AB/BB    same as simple   AA/AB1/AB2/BB
#   -all males    AY/BY       same             same
# forw cross
#   -both sexes   A-/AB/BY    AA/AB/AY/BY      same as std
#   -all females  AA/AB       same             same
#   -all males    AY/BY       same             same
# backw cross
#   -both sexes   B-/AB/AY    BB/AB/AY/BY      same as std
#   -all females  BB/AB       same             same
#   -all males    AY/BY       same             same

      if(length(sex)==0 || all(sex==0)) { # all females
        if(length(pgm)==0 || all(pgm==0)) # all forw dir
          gen.names <- c("AA","AB")
        else if(all(pgm==1))  # all backw dir
          gen.names <- c("BB","AB")
        else { # some of each direction
          if(expandX=="full") gen.names <- c("AA","ABf","ABr","BB")
          else gen.names <- c("AA","AB","BB")
        }
      }
      else if(all(sex==1))  # all males
        gen.names <- c("AY","BY")
      else { # some of each sex
        if(length(pgm)==0 || all(pgm==0)) { # all forw
          if(expandX=="simple") gen.names <- c("A-","AB","BY")
          else gen.names <- c("AA","AB","AY","BY")
        }
        else if (all(pgm==1)) { # all backw
          if(expandX=="simple") gen.names <- c("B-","AB","AY")
          else gen.names <- c("BB","AB","AY","BY")
        }
        else { # some of each dir
          if(expandX=="simple") gen.names <- c("A-","AB","B-")
          else if(expandX=="standard")
            gen.names <- c("AA","AB","BB","AY","BY")
          else
            gen.names <- c("AA","ABf","ABr","BB","AY","BY")
        }
      }
    }
  }

  gen.names
}

# revise genotype data, probabilities or imputations for the X chromosome
reviseXdata <-
function(type=c("f2ss","f2","bc"), expandX=c("simple","standard","full"),
         sexpgm, geno, prob, draws, pairprob)
{
  type <- match.arg(type)
  expandX <- match.arg(expandX)

  sex <- sexpgm$sex
  pgm <- sexpgm$pgm

  notmissing <- (!missing(geno)) + (!missing(prob)) + (!missing(draws)) +
      (!missing(pairprob))
  if(notmissing == 0)
    stop("Provide one of geno, prob, draws, pairprob.")
  if(notmissing > 1)
    stop("Provide just one of geno, prob, draws, pairprob.")

  # get genonames
  genonames <- getgenonames(type, "X", expandX, sexpgm)

  if(type == "bc") { # backcross

    if(length(sex)==0 || all(sex==0) || all(sex==1)) { # all one sex
      # no changes necessary
      if(!missing(geno)) return(geno)
      else if(!missing(prob)) {
        dimnames(prob)[[3]] <- genonames
        return(prob)
      }
      else if(!missing(draws)) 
        return(draws)
      else # pairprob
        return(pairprob)
    }

    else { # both sexes

      if(!missing(geno)) {
        gmale <- geno[sex==1,]
        if(expandX=="simple") 
          gmale[!is.na(gmale) & gmale==2] <- 3
        else {
          gmale[!is.na(gmale) & gmale==1] <- 3
          gmale[!is.na(gmale) & gmale==2] <- 4
        }
        geno[sex==1,] <- gmale
        return(geno)
      }

      else if(!missing(draws)) {
        gmale <- draws[sex==1,,]
        if(expandX=="simple") 
          gmale[gmale==2] <- 3
        else {
          gmale[gmale==1] <- 3
          gmale[gmale==2] <- 4
        }
        draws[sex==1,,] <- gmale
        return(draws)
      }

      else if(!missing(prob)) {
        dimprob <- dim(prob)
        dimprob[3] <- length(genonames)
        newprob <- array(0,dim=dimprob)
        dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames))
        newprob[sex==0,,1:2] <- prob[sex==0,,]

        if(expandX=="simple") {
          newprob[sex==1,,1] <- prob[sex==1,,1]
          newprob[sex==1,,3] <- prob[sex==1,,2]
        }
        else {
          newprob[sex==1,,3] <- prob[sex==1,,1]
          newprob[sex==1,,4] <- prob[sex==1,,2]
        }
        return(newprob)
      }

      else { # pairprob
        dimpairprob <- dim(pairprob)
        dimpairprob[3] <- dimpairprob[4] <- length(genonames)
        newpairprob <- array(0,dim=dimpairprob)
        newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,]
        
        if(expandX=="simple") {
          newpairprob[sex==1,,1,1] <- pairprob[sex==1,,1,1]
          newpairprob[sex==1,,1,3] <- pairprob[sex==1,,1,2]
          newpairprob[sex==1,,3,1] <- pairprob[sex==1,,2,1]
          newpairprob[sex==1,,3,3] <- pairprob[sex==1,,2,2]
        }
        else {
          newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1]
          newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2]
          newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1]
          newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2]
        }
        return(newpairprob)
      }
          
    } # end of "both sexes" / backcross

  } # end of backcross

  else { # intercross

    if(length(sex)==0 || all(sex==0)) { # all females

      if(length(pgm)==0 || all(pgm==0) || all(pgm==1)) { # one dir, females
        if(!missing(geno)) return(geno)
        else if(!missing(draws)) return(draws)
        else if(!missing(pairprob)) return(pairprob)
        else {
          dimnames(prob)[[3]] <- genonames
          return(prob)
        }
      }
        
      else { # both dir, females
        if(!missing(geno)) {
          gback <- geno[pgm==1,]
          gback[!is.na(gback) & gback==1] <- 3
          geno[pgm==1,] <- gback
          return(geno)
        }
        else if(!missing(draws)) {
          gback <- draws[pgm==1,,]
          gback[!is.na(gback) & gback==1] <- 3
          draws[pgm==1,,] <- gback
          return(draws)
        }
        else if(!missing(prob)) {
          dimprob <- dim(prob)
          dimprob[3] <- length(genonames)
          newprob <- array(0,dim=dimprob)
          dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames))
          newprob[pgm==0,,1:2] <- prob[pgm==0,,]

          if(expandX!="full") { # simple/standard
            newprob[pgm==1,,3] <- prob[pgm==1,,1]
            newprob[pgm==1,,2] <- prob[pgm==1,,2]
          }
          else {
            newprob[pgm==1,,4] <- prob[pgm==1,,1]
            newprob[pgm==1,,3] <- prob[pgm==1,,2]
          }
          return(newprob)
        }
        else { # pairprob
          dimpairprob <- dim(pairprob)
          dimpairprob[3] <- dimpairprob[4] <- length(genonames)
          newpairprob <- array(0,dim=dimpairprob)
          newpairprob[pgm==0,,1:2,1:2] <- pairprob[pgm==0,,,]
        
          if(expandX!="full") { # simple/standard
            newpairprob[pgm==1,,3,3] <- pairprob[pgm==1,,1,1]
            newpairprob[pgm==1,,3,2] <- pairprob[pgm==1,,1,2]
            newpairprob[pgm==1,,2,3] <- pairprob[pgm==1,,2,1]
            newpairprob[pgm==1,,2,2] <- pairprob[pgm==1,,2,2]
          }
          else {
            newpairprob[pgm==1,,4,4] <- pairprob[pgm==1,,1,1]
            newpairprob[pgm==1,,4,3] <- pairprob[pgm==1,,1,2]
            newpairprob[pgm==1,,3,4] <- pairprob[pgm==1,,2,1]
            newpairprob[pgm==1,,3,3] <- pairprob[pgm==1,,2,2]
          }
        return(newpairprob)
        }
      }
    }
    else if(all(sex==1))  { # all males
      if(!missing(geno)) return(geno)
      else if(!missing(draws)) return(draws)
      else if(!missing(pairprob)) return(pairprob)
      else {
        dimnames(prob)[[3]] <- genonames
        return(prob)
      }
    }

    else { # both sexes

      if(length(pgm)==0 || all(pgm==0)) { # both sexes, forw dir
        if(!missing(geno)) {
          gmale <- geno[sex==1,]
          if(expandX!="full") 
            gmale[!is.na(gmale) & gmale==2] <- 3
          else {
            gmale[!is.na(gmale) & gmale==1] <- 3
            gmale[!is.na(gmale) & gmale==2] <- 4
          }
          geno[sex==1,] <- gmale
          return(geno)
        }

        else if(!missing(draws)) {
          gmale <- draws[sex==1,,]
          if(expandX!="full") 
            gmale[gmale==2] <- 3
          else {
            gmale[gmale==1] <- 3
            gmale[gmale==2] <- 4
          }
          draws[sex==1,,] <- gmale
          return(draws)
        }

        else if(!missing(prob)) {
          dimprob <- dim(prob)
          dimprob[3] <- length(genonames)
          newprob <- array(0,dim=dimprob)
          dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames))
          newprob[sex==0,,1:2] <- prob[sex==0,,]

          if(expandX=="simple") {
            newprob[sex==1,,1] <- prob[sex==1,,1]
            newprob[sex==1,,3] <- prob[sex==1,,2]
          }
          else {
            newprob[sex==1,,3] <- prob[sex==1,,1]
            newprob[sex==1,,4] <- prob[sex==1,,2]
          }
          return(newprob)
        }

        else { # pairprob
          dimpairprob <- dim(pairprob)
          dimpairprob[3] <- dimpairprob[4] <- length(genonames)
          newpairprob <- array(0,dim=dimpairprob)
          newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,]
        
          if(expandX=="simple") {
            newpairprob[sex==1,,1,1] <- pairprob[sex==1,,1,1]
            newpairprob[sex==1,,1,3] <- pairprob[sex==1,,1,2]
            newpairprob[sex==1,,3,1] <- pairprob[sex==1,,2,1]
            newpairprob[sex==1,,3,3] <- pairprob[sex==1,,2,2]
          }
          else {
            newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1]
            newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2]
            newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1]
            newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2]
          }
          return(newpairprob)
        }
      } # both sexes, forw dir

      if(all(pgm==1)) { # both sexes, backw dir
        if(!missing(geno)) {
          gmale <- geno[sex==1,]
          if(expandX!="full") {
            gmale[!is.na(gmale) & gmale==1] <- 3
            gmale[!is.na(gmale) & gmale==2] <- 1
          }
          else {
            gmale[!is.na(gmale) & gmale==1] <- 3
            gmale[!is.na(gmale) & gmale==2] <- 4
          }
          geno[sex==1,] <- gmale
          return(geno)
        }

        else if(!missing(draws)) {
          gmale <- draws[sex==1,,]
          if(expandX!="full") {
            gmale[gmale==1] <- 3
            gmale[gmale==2] <- 1
          }
          else {
            gmale[gmale==1] <- 3
            gmale[gmale==2] <- 4
          }
          draws[sex==1,,] <- gmale
          return(draws)
        }

        else if(!missing(prob)) {
          dimprob <- dim(prob)
          dimprob[3] <- length(genonames)
          newprob <- array(0,dim=dimprob)
          dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames))
          newprob[sex==0,,1:2] <- prob[sex==0,,]

          if(expandX=="simple") {
            newprob[sex==1,,3] <- prob[sex==1,,1]
            newprob[sex==1,,1] <- prob[sex==1,,2]
          }
          else {
            newprob[sex==1,,3] <- prob[sex==1,,1]
            newprob[sex==1,,4] <- prob[sex==1,,2]
          }
          return(newprob)
        }

        else { # pairprob
          dimpairprob <- dim(pairprob)
          dimpairprob[3] <- dimpairprob[4] <- length(genonames)
          newpairprob <- array(0,dim=dimpairprob)
          newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,]
        
          if(expandX=="simple") {
            newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1]
            newpairprob[sex==1,,1,3] <- pairprob[sex==1,,2,1]
            newpairprob[sex==1,,3,1] <- pairprob[sex==1,,1,2]
            newpairprob[sex==1,,1,1] <- pairprob[sex==1,,2,2]
          }
          else {
            newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1]
            newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2]
            newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1]
            newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2]
          }
          return(newpairprob)
        }
      } # both sexes, backw dir

      else { # both dir, both sexes

        if(!missing(geno)) {
          gmale <- geno[sex==1,]
          gfemaler <- geno[sex==0 & pgm==1,]
          if(expandX=="simple") {
            gmale[!is.na(gmale) & gmale==2] <- 3
            gfemaler[!is.na(gfemaler) & gfemaler==1] <- 3
          }
          else if(expandX=="standard") {
            gmale[!is.na(gmale) & gmale==1] <- 4
            gmale[!is.na(gmale) & gmale==2] <- 5
            gfemaler[!is.na(gfemaler) & gfemaler==1] <- 3
          }
          else {
            gmale[!is.na(gmale) & gmale==1] <- 5
            gmale[!is.na(gmale) & gmale==2] <- 6
            gfemaler[!is.na(gfemaler) & gfemaler==1] <- 4
            gfemaler[!is.na(gfemaler) & gfemaler==2] <- 3
          }
          geno[sex==1,] <- gmale
          geno[sex==0 & pgm==1,] <- gfemaler
          return(geno)
        }

        else if(!missing(draws)) {
          gmale <- draws[sex==1,,]
          gfemaler <- draws[sex==0 & pgm==1,,]
          if(expandX=="simple") {
            gmale[gmale==2] <- 3
            gfemaler[gfemaler==1] <- 3
          }
          else if(expandX=="standard") {
            gmale[gmale==1] <- 4
            gmale[gmale==2] <- 5
            gfemaler[gfemaler==1] <- 3
          }
          else {
            gmale[gmale==1] <- 5
            gmale[gmale==2] <- 6
            gfemaler[gfemaler==1] <- 4
            gfemaler[gfemaler==2] <- 3
          }
          draws[sex==1,,] <- gmale
          draws[sex==0 & pgm==1,,] <- gfemaler
          return(draws)
        }

        else if(!missing(prob)) {
          dimprob <- dim(prob)
          dimprob[3] <- length(genonames)
          newprob <- array(0,dim=dimprob)
          dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames))
          newprob[sex==0 & pgm==0,,1:2] <- prob[sex==0 & pgm==0,,]

          if(expandX=="simple") {
            newprob[sex==1,,1] <- prob[sex==1,,1]
            newprob[sex==1,,3] <- prob[sex==1,,2]
            newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,1]
            newprob[sex==0 & pgm==1,,2] <- prob[sex==0 & pgm==1,,2]
          }
          else if(expandX=="standard") {
            newprob[sex==1,,4] <- prob[sex==1,,1]
            newprob[sex==1,,5] <- prob[sex==1,,2]
            newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,1]
            newprob[sex==0 & pgm==1,,2] <- prob[sex==0 & pgm==1,,2]
          }
          else {
            newprob[sex==1,,5] <- prob[sex==1,,1]
            newprob[sex==1,,6] <- prob[sex==1,,2]
            newprob[sex==0 & pgm==1,,4] <- prob[sex==0 & pgm==1,,1]
            newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,2]
          }
          return(newprob)
        }

        else { # pairprob
          dimpairprob <- dim(pairprob)
          dimpairprob[3] <- dimpairprob[4] <- length(genonames)
          newpairprob <- array(0,dim=dimpairprob)
          newpairprob[sex==0 & pgm==0,,1:2,1:2] <- pairprob[sex==0 & pgm==0,,,]
        
          male <- (sex==1)
          femaler <- (sex==0) & (pgm==1)
          if(expandX=="simple") {
            newpairprob[male,,1,1] <- pairprob[male,,1,1]
            newpairprob[male,,1,3] <- pairprob[male,,1,2]
            newpairprob[male,,3,1] <- pairprob[male,,2,1]
            newpairprob[male,,3,3] <- pairprob[male,,2,2]

            newpairprob[femaler,,3,3] <- pairprob[femaler,,1,1]
            newpairprob[femaler,,3,2] <- pairprob[femaler,,1,2]
            newpairprob[femaler,,2,3] <- pairprob[femaler,,2,1]
            newpairprob[femaler,,2,2] <- pairprob[femaler,,2,2]
          }
          else if(expandX=="standard") {
            newpairprob[male,,4,4] <- pairprob[male,,1,1]
            newpairprob[male,,4,5] <- pairprob[male,,1,2]
            newpairprob[male,,5,4] <- pairprob[male,,2,1]
            newpairprob[male,,5,5] <- pairprob[male,,2,2]

            newpairprob[femaler,,3,3] <- pairprob[femaler,,1,1]
            newpairprob[femaler,,3,2] <- pairprob[femaler,,1,2]
            newpairprob[femaler,,2,3] <- pairprob[femaler,,2,1]
            newpairprob[femaler,,2,2] <- pairprob[femaler,,2,2]
          }
          else {
            newpairprob[male,,5,5] <- pairprob[male,,1,1]
            newpairprob[male,,5,6] <- pairprob[male,,1,2]
            newpairprob[male,,6,5] <- pairprob[male,,2,1]
            newpairprob[male,,6,6] <- pairprob[male,,2,2]

            newpairprob[femaler,,4,4] <- pairprob[femaler,,1,1]
            newpairprob[femaler,,4,3] <- pairprob[femaler,,1,2]
            newpairprob[femaler,,3,4] <- pairprob[femaler,,2,1]
            newpairprob[femaler,,3,3] <- pairprob[femaler,,2,2]
          }
          return(newpairprob)
        }

      } 
    } 

  } # end of intercross

}

######################################################################
# scanoneXnull
#
# figure out null hypothesis business for scanone on X chromosome
######################################################################
scanoneXnull <-
function(type, sexpgm)
{
  sex <- sexpgm$sex
  pgm <- sexpgm$pgm

  if(type == "f2ss") type <- "f2"

  ### first figure out sex/pgm pattern

  # sex
  if(length(sex)==0 || all(sex==0)) { # all female
    onesex <- allfemale <- TRUE
  }
  else if(all(sex==1)) { # all male
    onesex <- TRUE
    allfemale <- FALSE
  }
  else { # both sexes
    onesex <- allfemale <- FALSE
  }
  # pgm
  if(length(pgm)==0 || all(pgm==0) || all(pgm==1)) # one direction
    onedir <- TRUE
  else onedir <- FALSE

  allmale <- onesex && !allfemale
  bothsex <- !onesex
  bothdir <- !onedir


  ### now figure out the null hypothesis and pull out appropriate
  ### covariates for the null

  # backcross, one sex
  # OR intercross, one dir and one sex
  # OR intercross, both dir and all male
  if((type=="bc" && onesex) ||
     (type=="f2" && ((onedir && onesex) || (bothdir && allmale)))) {
    adjustX <- FALSE
    dfX <- 1
    sexpgmcovar <- sexpgmcovar.alt <- NULL
  }

  # backcross, both sexes
  # OR intercross, one direction and both sexes
  else if((type=="bc" && bothsex) ||
          (type=="f2" && onedir && bothsex)) {
    adjustX <- TRUE
    dfX <- 2
    sexpgmcovar <- cbind(sex)
    sexpgmcovar.alt <- sex+1
  }

  # intercross, both dir and all female
  else if(type=="f2" && bothdir && allfemale) {
    adjustX <- TRUE
    dfX <- 2
    sexpgmcovar <- cbind(pgm)
    sexpgmcovar.alt <- pgm+1
  }

  # intercross, both dir and both sexes
  else {
    adjustX <- TRUE
    dfX <- 3
    sexpgmcovar <- cbind(sex,as.numeric(sex==0 & pgm==1))
    sexpgmcovar.alt <- rep(3,length(sex))
    sexpgmcovar.alt[sex==0 & pgm==0] <- 1
    sexpgmcovar.alt[sex==0 & pgm==1] <- 2
  }

  list(adjustX=adjustX, dfX=dfX, sexpgmcovar=sexpgmcovar,
       sexpgmcovar.alt=sexpgmcovar.alt)
}

# end of xchr.R
######################################################################
#
# zzz.R
#
# copyright (c) 2001, Karl W Broman, Johns Hopkins University
# written Feb, 2001
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/qtl package
#
# .First.lib is run when the package is loaded with library(qtl)
#
######################################################################

.First.lib <- function(lib, pkg) library.dynam("qtl", pkg, lib)

# end of zzz.R
