

\section{Intro to Pedigree Shrink}

The pedigree.shrink functions were initially written to deal with a pedigree
represented as a data.frame with pedTrim, written by Steve Iturria, to trim 
the subjects from a pedigree who were less useful for linkage and family 
association studies.  It was later turned into a package called pedShrink 
by Daniel Schaid's group, still working on a pedigree, but assuming it was 
just a data.frame.  Later, the functions were managed by Jason Sinnwell who 
worked with the 2010 version of the pedigree object by Terry Therneau in 
planning to group many of the pedigree functions together into an enhanced 
kinship package.

This file also contains the pedigree.unrelated function, developed by Dan 
Schaid and Shannon McDonnell, which uses the kinship matrix to 
determine relatedness of subjects in a pedigree, and returns the person id
of one of the maximal sets of individuals that are not related. 
Details described below.


\section{Pedigree Shrink}
The pedigree.shrink function trims an object of class pedigree, and 
returns a list with information about how the pedigree was shrunk, 
and the final shrunken pedigree object.

\emph{pedigree.shrink}.  
Accepts the following input
\begin{description}
  \item[ped] a pedigree object
  \item[avail] indicator vector of availability of each person in the pedigree
  \item[seed] seed to control randomness
  \item[maxBits] bit size to shrink the pedigree size under
\end{description}

<<pedigree.shrink>>=

#'@examples
#'pedigree.shrink <- function(ped, avail, affected=NULL, seed=NULL, maxBits = 16){
#'  if(class(ped) != "pedigree")
#'    stop("Must be a pegigree object.\n")
#'  
  ##set the seed for random selections
#'
#'  if(is.null(seed))
#'  {
#'    seed <- sample(2^20, size=1)
#'  }
#'  set.seed(seed)
#'  
#'  if(any(is.na(avail)))
#'    stop("NA values not allowed in avail vector.")
#'  
#'  if(is.null(affected))
#'    affected = if(is.matrix(ped$affected)) ped$affected[,1] else ped$affected
#'  
#'  ped$affected = affected
#'  
#'  idTrimmed <- numeric()
#'  idList <- list()
#'  nOriginal <- length(ped$id)
#'  
#'  bitSizeOriginal <- bitSize(ped)$bitSize
#'  
  ## first find unavailable subjects to remove anyone who is not 
  ## available and does not have an available descendant
#'  
#'  idTrimUnavail <- findUnavailable(ped, avail)
#'  
#'  if(length(idTrimUnavail)) {    
#'    
#'    pedTrimmed <- pedigree.trim(idTrimUnavail, ped)
#'    avail <- avail[match(pedTrimmed$id, ped$id)]
#'    idTrimmed <- c(idTrimmed, idTrimUnavail)
#'    idList$unavail <- paste(idTrimUnavail, collapse=' ')
#'    
#'  } else {
    ## no trimming, reset to original ped
#'    pedTrimmed <- ped
#'  }
#'  
  ## Next trim any available terminal subjects with unknown phenotype
  ## but only if both parents are available
#'  
  ## added nNew>0 check because no need to trim anymore if empty ped
#'  
#'  nChange <- 1
#'  idList$noninform = NULL
#'  nNew <- length(pedTrimmed$id)
#'  
#'  while(nChange > 0 & nNew > 0){
#'    nOld <- length(pedTrimmed$id)
#'    
    ## findAvailNonInform finds non-informative, but after suggesting 
    ## their removal, checks for more unavailable subjects before returning
#'    idTrimNonInform <- findAvailNonInform(pedTrimmed, avail)
#'    
#'    if(length(idTrimNonInform)) {
#'      pedNew <- pedigree.trim(idTrimNonInform, pedTrimmed)
#'      avail <- avail[match(pedNew$id, pedTrimmed$id)]
#'      idTrimmed <- c(idTrimmed, idTrimNonInform)
#'      idList$noninform = paste(c(idList$noninform, 
#'                                 idTrimNonInform), collapse=' ')
#'      pedTrimmed <- pedNew
#'      
#'    }
#'    nNew <- length(pedTrimmed$id)
#'    nChange <- nOld - nNew
#'    
#'  }
#'  
  ##  Determine number of subjects & bitSize after initial trimming
#'  nIntermed <- length(pedTrimmed$id)
#'  
#'  bitSize <- bitSize(pedTrimmed)$bitSize
#'  
  ## Now sequentially shrink to fit bitSize <= maxBits
#'  
#'  bitVec <- c(bitSizeOriginal,bitSize)
#'  
#'  isTrimmed <- TRUE
#'  idList$affect=NULL 
#'  
#'  while(isTrimmed & (bitSize > maxBits))
#'  {  
#'    
    ## First, try trimming by unknown status
#'    save <- findAvailAffected(pedTrimmed, avail, affstatus=NA)
#'    isTrimmed <- save$isTrimmed
#'    
    ## Second, try trimming by unaffected status if no unknowns to trim
#'    if(!isTrimmed)
#'    {
#'      save <- findAvailAffected(pedTrimmed, avail, affstatus=0)
#'      isTrimmed <- save$isTrimmed
#'      
#'    }
#'    
#'    
    ## Third, try trimming by affected status if no unknowns & no unaffecteds
    ## to trim
#'    if(!isTrimmed) {
#'      save <- findAvailAffected(pedTrimmed, avail, affstatus=1)
#'      isTrimmed <- save$isTrimmed
#'    }
#'    
#'    if(isTrimmed)  {
#'      pedTrimmed <- save$ped
#'      avail <- save$newAvail
#'      bitSize <- save$bitSize
#'      bitVec <- c(bitVec, bitSize)          
#'      idTrimmed <- c(idTrimmed, save$idTrimmed)
#'      idList$affect = paste(c(idList$affect, save$idTrimmed), 
#'                            collapse=' ')
#'    }
#'   
#'    
#'  } 
    ## end while (isTrimmed) & (bitSize > maxBits)
#'
#'  nFinal <- length(pedTrimmed$id)
#'  
#'  obj <- list(pedObj = pedTrimmed,
#'              idTrimmed = idTrimmed,
#'              idList = idList,
#'              bitSize = bitVec,
#'              avail=avail,
#'              pedSizeOriginal = nOriginal,
#'              pedSizeIntermed = nIntermed,
#'              pedSizeFinal  = nFinal,
#'              seed = seed)
#'  
#'  oldClass(obj) <- "pedigree.shrink"
#'  
#'  return(obj)
#'} 
#'
#'@
  
  
\subsection{Sub-Functions}


These next functions were written to support pedigree.shrink.
In making the new kinship2 package to include pedigree.shrink, Jason Sinnwell
decided to add functionality to removed  subjects from a pedigree object 
given their id.  Then within pedigree.shrink, any removal of subjects consists
of two steps, identifying who to remove by their ids. Then removing them with
a new pedigree.trim function.  

The problem with pedigree.trim is that if the removal of any subject causes
a marriage to be split and have parentless children, it will cause a problem.

Therefore, when using functions like findAvalNonInform and findAvalAffected
for persons to remove, follow them up with a call findUnavailable, after 
setting the removal candidates availability to FALSE, so clear up any 
removals.

This last step was re-written by Jason Sinnwell on 6/1/2011, and his test cases
seemed to test against the results before the re-write. He expects there to 
be bugs to be discovered down the road.


What was previously pedTrim is now split into two functions, pedigree.trim and findUnavail.  

pedigree.trim : remove subjects from pedigree object given their id. 
Update for version 1.2.8 (9/27/11) Allow creation of an empty pedigree 
if all IDs are removed. This allows bitSize and 
pedigree.shrink to still complete with an empty pedigree. 

findUnavail: identify subjects are not available and who do not have 
an available descendant.  Do this iteratively by successively removing 
unavailable terminal nodes.  Written by  Steve Iturria, PhD, modified 
by Dan Schaid.

<<pedigree.trim>>=
#'@examples
#'pedigree.trim <- function(removeID, ped){
## trim subjects from a pedigree who match the removeID 
## trim relation matrix as well
#'
#'if(class(ped) != "pedigree")
#'stop("Must be a pegigree object.\n")
#'
#'rmidx <- match(removeID, ped$id)
#'if(length(rmidx)>0) {
#'pedtrimmed <- ped[-rmidx]
#'return(pedtrimmed)
#'} else {
#'return(ped)
#'}
#'}
#'
#'@ 
#'
Place the two exclude functions within the same file as findUnavailable
because that is the only place they are used. Pretty self-documenting.

<<findUnavailable>>=

#'@examples
#'findUnavailable <-function(ped, avail) {
#'
  ## find id within pedigree anyone who is not available and
  ## does not have an available descendant
#'
  ## avail = TRUE/1 if available, FALSE/0 if not
#'
  ## will do this iteratively by successively removing unavailable
  ## terminal nodes
  ## Steve Iturria, PhD, modified by Dan Schaid
#'
#'cont <- TRUE                  # flag for whether to keep iterating
#'
#'is.terminal <- (is.parent(ped$id, ped$findex, ped$mindex) == FALSE)
  ## JPS 3/10/14 add strings check in case of char ids
#'pedData <- data.frame(id=ped$id, father=ped$findex, mother=ped$mindex,
#'sex=ped$sex, avail, is.terminal, stringsAsFactors=FALSE)  
#'iter <- 1
#'
#'while(cont)  {
  ##print(paste("Working on iter", iter))
#'
#'num.found <- 0
#'idx.to.remove <- NULL
#'
#'for(i in 1:nrow(pedData))
#'{
#'  
#'  if(pedData$is.terminal[i])
#'  {
#'  if( pedData$avail[i] == FALSE )   # if not genotyped         
#'  {
#'  idx.to.remove <- c(idx.to.remove, i)
#'  num.found <- num.found + 1
#'  
  ## print(paste("  removing", num.found, "of", nrow(pedData)))
#'  }
#'  }
#'  
#'}
#'
#'if(num.found > 0) {
#'
#'pedData <- pedData[-idx.to.remove, ]
  ## re-index parents, which varies depending on if the removed indx is
  ## prior to parent index
#'for(k in 1:nrow(pedData)){
#'if(pedData$father[k] > 0) {
#'pedData$father[k] <- pedData$father[k] -
#'sum(idx.to.remove < pedData$father[k])
#'}
#'if(pedData$mother[k]+0) {
#'pedData$mother[k] <- pedData$mother[k] -
#'sum(idx.to.remove < pedData$mother[k])
#'}
#'}
#'pedData$is.terminal <-
#'(is.parent(pedData$id, pedData$father, pedData$mother) == FALSE)
#'
#'}
#'else {
#'cont <- FALSE
#'}
#'iter <- iter + 1   
#'
#'}
#'
  ## A few more clean up steps
#'
  ## remove unavailable founders
#'tmpPed <- excludeUnavailFounders(pedData$id, 
#'pedData$father, pedData$mother, pedData$avail)
#'
#'tmpPed <- excludeStrayMarryin(tmpPed$id, tmpPed$father, tmpPed$mother)
#'
#'id.remove <- ped$id[is.na(match(ped$id, tmpPed$id))]
#'
#'return(id.remove)
#'
#'}
#'
#'excludeStrayMarryin <- function(id, father, mother){
  # get rid of founders who are not parents (stray available marryins
  # who are isolated after trimming their unavailable offspring)
  ## JPS 3/10/14 add strings check in case of char ids
#'trio <- data.frame(id=id, father=father, mother=mother, stringsAsFactors=FALSE)
#'parent <- is.parent(id, father, mother)
#'founder <- is.founder(father, mother)
#'
#'exclude <- !parent & founder
#'trio <- trio[!exclude,,drop=FALSE]
#'return(trio)
#'
#'}
#'
#'excludeUnavailFounders <- function(id, father, mother, avail)
#'{
#'  nOriginal <- length(id)
#'  idOriginal <- id   
#'  zed <- father!=0 & mother !=0
  ## concat ids to represent marriages. 
  ## Bug if there is ":" in char subj ids
#'  marriage <- paste(id[father[zed]], id[mother[zed]], sep=":" )
#'  
#'  sibship <- tapply(marriage, marriage, length)
#'  nm <- names(sibship)
#'  
#'  splitPos <- regexpr(":",nm)
#'  dad <- substring(nm, 1, splitPos-1)
#'  mom <- substring(nm, splitPos+1,  nchar(nm))
#'  
  ##  Want to look at parents with only one child.
  ##  Look for parents with > 1 marriage.  If any
  ##  marriage has > 1 child then skip this mom/dad pair.
#'  
#'  nmarr.dad <- table(dad)
#'  nmarr.mom <- table(mom)
#'  skip <- NULL
#'  
#'  if(any(nmarr.dad > 1)) {
  ## Dads in >1 marriage
#'  ckdad <- which(as.logical(match(dad,
#'  names(nmarr.dad)[which(nmarr.dad > 1)],nomatch=FALSE)))
#'  skip <- unique(c(skip, ckdad))
#'  }
#'  
#'  if(any(nmarr.mom > 1)) {
  ## Moms in >1 marriage
#'  ckmom <- which(as.logical(match(mom,
#'  names(nmarr.mom)[which(nmarr.mom > 1)],nomatch=FALSE)))
#'  skip <- unique(c(skip, ckmom))
#'  }
#'  
#'  if(length(skip) > 0) {
#'  dad <- dad[-skip]
#'  mom <- mom[-skip]
#'  zed <- (sibship[-skip]==1) 
#'  } else {
#'  zed <- (sibship==1)
#'  }
#'  
#'  n <- sum(zed)
#'  idTrimmed <- NULL
#'  if(n>0)
#'  {
#'  
  # dad and mom are the parents of sibships of size 1
#'  dad <- dad[zed]
#'  mom <- mom[zed]
#'  for(i in 1:n){
  ## check if mom and dad are founders (where their parents = 0)
#'  dad.founder <- (father[id==dad[i]] == 0) & (mother[id==dad[i]] == 0)
#'  mom.founder <- (father[id==mom[i]] == 0) & (mother[id==mom[i]] == 0)
#'  both.founder <- dad.founder & mom.founder
#'  
  ## check if mom and dad have avail
#'  dad.avail <- avail[id==dad[i]]
#'  mom.avail <- avail[id==mom[i]]
#'  
  ## define not.avail = T if both mom & dad not avail
#'  not.avail <- (dad.avail==FALSE & mom.avail==FALSE)
#'  
#'  if(both.founder & not.avail)   {
  ## remove mom and dad from ped, and zero-out parent 
  ## ids of their child
#'  
#'  child <- which(father==which(id==dad[i]))          
#'  father[child] <- 0
#'  mother[child] <- 0
#'  
#'  idTrimmed <- c(idTrimmed, dad[i], mom[i])
#'  
#'  excludeParents <- (id!=dad[i]) & (id!=mom[i])
#'  id <- id[excludeParents]
#'  father <- father[excludeParents]
#'  mother <- mother[excludeParents]
#'  
  ## re-index father and mother, assume len(excludeParents)==2
#'  father <- father - 1*(father > which(!excludeParents)[1]) -
#'  1*(father > which(!excludeParents)[2])
#'  
#'  mother <- mother - 1*(mother > which(!excludeParents)[1]) -
#'  1*(mother > which(!excludeParents)[2])
#'  
#'  avail <- avail[excludeParents]
#'  } 
#'  }
#'  }
#'  
#'  nFinal <- length(id)
#'  nTrimmed = nOriginal - nFinal 
#'  
#'  return(list(nTrimmed = nTrimmed, idTrimmed=idTrimmed,
#'  id=id, father=father, mother=mother))
#'}
#'
#'@ 
#'
Function to calculate pedigree bit size, which is 
2 * n.NonFounder  - n.Founder.  It is an indicator for how much resources
the pedigree will require to be processed by linkage algorithms to calculate
the likelihood of the observed genotypes given the pedigree structure.

The Lander-Green handles smaller pedigrees and many markers
The Elston-Stewart handles larger pedigrees and fewer markers.

<<bitSize>>=
#'@examples
  ## renamed from pedBits, part of pedigree.shrink functions
#'
#'bitSize <- function(ped) {
  ## calculate bit size of a pedigree
#'
#'if(class(ped) != "pedigree")
#'stop("Must be a pegigree object.\n")
#'
#'father = ped$findex
#'mother = ped$mindex
#'id = ped$id
#'
#'founder <- father==0 & mother==0
#'pedSize <- length(father)
#'nFounder <- sum(founder)
#'nNonFounder <- pedSize - nFounder
#'bitSize <- 2*nNonFounder - nFounder
#'return(list(bitSize=bitSize,
#'nFounder = nFounder,
#'nNonFounder = nNonFounder))
#'}
#'
#'@
#'
Two functions to identify subjects to remove by other indicators0
than availability. 

findAvailNonInform: id subjects to remove who are available, but not 
informative. This function was formerly trimAvailNonInform().


findAvailAffected: id subjects to remove who were not removed by 
findUnavailable(), but who would be best to remove given their 
affected status.  Try trimming one subject by with affected matching 
affstatus.  If there are ties of multiple subjects that reduce bit 
size equally, randomly choose one of them. This function was formerly named pedTrimOneSubj().
On 3/10/14, Nick Larson found a bug with char ids when stringsAsFactors was TRUE; this
is now fixed with the option set specifically in the data.frames sset to FALSE.


<<findAvailNonInform>>=
#'@examples
#'findAvailNonInform <- function(ped, avail){
#'
  ## trim persons who are available but not informative b/c not parent
  ## by setting their availability to FALSE, then call findUnavailable()
  ## JPS 3/10/14 add strings check in case of char ids
#'pedData <- data.frame(id=ped$id, father=ped$findex, 
#'mother=ped$mindex, avail=avail, stringsAsFactors=FALSE )
#'
#'checkParent <- is.parent(pedData$id, pedData$father, pedData$mother)
#'
#'for(i in 1:nrow(pedData)){
#'
#'if(checkParent[i]==FALSE & avail[i]==TRUE & 
#'all(ped$affected[i]==0, na.rm=TRUE)) {
#'
  ## could use ped$affected[i,] if keep matrix
#'
#'fa <- pedData$id[pedData$father[i]]
#'mo <- pedData$id[pedData$mother[i]]
#'if(avail[pedData$id==fa] & avail[pedData$id==mo])
#'{
#'  pedData$avail[i] <- FALSE
#'}
#'}
#'}
#'
#'idTrim <- findUnavailable(ped, pedData$avail)
#'return(idTrim)
#'} 
#'
#'@ 
#'
<<findAvailAffected>>=
#'@examples
#'findAvailAffected <- function(ped, avail, affstatus)
  ## Try trimming one subject by affection status indicator
  ## If ties for bits removed, randomly select one of the subjects
#'
#'{
#'  
#'  notParent <- !is.parent(ped$id, ped$findex, ped$mindex)
#'  
#'  if(is.na(affstatus)) {
#'  possiblyTrim <- ped$id[notParent & avail & is.na(ped$affected)]
#'  } else {
#'  possiblyTrim <- ped$id[notParent & avail & ped$affected==affstatus]
#'  }
#'  nTrim <- length(possiblyTrim)
#'  
#'  if(nTrim == 0)
#'  {
#'  return(list(ped=ped,
#'  idTrimmed = NA,
#'  isTrimmed = FALSE,
#'  bitSize = bitSize(ped)$bitSize))
#' }
#'  
#'  trimDat <- NULL
#'  
#'  for(idTrim in possiblyTrim) {
#' 
#'  avail.try <- avail
#'  avail.try[ped$id==idTrim] <- FALSE
#'  id.rm <- findUnavailable(ped, avail.try)
#'  newPed <- pedigree.trim(id.rm, ped)
#'  trimDat <- rbind(trimDat,
#'  c(id=idTrim, bitSize=bitSize(newPed)$bitSize))
#'  }
#'  
#'  bits <- trimDat[,2]
#'  
  # trim by subject with min bits. This trims fewer subject than
  # using max(bits).
#'  
#'  idTrim <- trimDat[bits==min(bits), 1]
#'  
  ## break ties by random choice
#'  if(length(idTrim) > 1)
#'  {
#'  rord <- order(runif(length(idTrim)))
#'  idTrim <- idTrim[rord][1]
#'  }
#'  
#'  avail[ped$id==idTrim] <- FALSE
#'  id.rm <- findUnavailable(ped, avail)
#'  newPed <- pedigree.trim(id.rm, ped)
#'  pedSize <- bitSize(newPed)$bitSize
#'  avail <- avail[!(ped$id %in% id.rm)]
#'  
#'  return(list(ped=newPed,
#'  newAvail = avail,
#'  idTrimmed = idTrim,
#'  isTrimmed = TRUE,
#'  bitSize = pedSize))
#'}
#'
#'@ 
#'
Group other functions used in the above main functions
together as pedigree.shrink.minor.R


These functions get indicator vectors of who is a parent, 
founder, or disconnected

<<pedigree.shrink.minor>>=
#'@examples
#'is.parent <- function(id, findex, mindex){
  # determine subjects who are parents
  # assume input of father/mother indices, not ids
#'
#'father <- mother <- rep(0, length(id))
#'father[findex>0] <- id[findex]
#'mother[mindex>0] <- id[mindex]
#'
#'isFather <- !is.na(match(id, unique(father[father!=0])))
#'isMother <- !is.na(match(id, unique(mother[mother!=0])))
#'isParent <- isFather |isMother
#'return(isParent)
#'}
#'
#'is.founder <- function(mother, father){
#'check <- (father==0) & (mother==0)
#'return(check)
#'}
#'
#'is.disconnected <- function(id, findex, mindex)
#'{
#'  
  # check to see if any subjects are disconnected in pedigree by checking for
  # kinship = 0 for all subjects excluding self
#'  father <- id[findex]
#'  mother <- id[mindex]  
#'  kinMat <- kinship(id, father, mother)
#'  diag(kinMat) <- 0
#'  disconnected <- apply(kinMat==0.0, 1, all)
#'  
#'  return(disconnected)
#'}
#'
#'@ 
#'
Print a pedigree.shrink object.  Tell the original bit size and the trimmed bit size.

<<print.pedigree.shrink>>=
#'@examples
#'print.pedigree.shrink <- function(x, ...){
#'
#'printBanner(paste("Shrink of Pedigree ", unique(x$pedObj$ped), sep=""))
#'
#'cat("Pedigree Size:\n")
#'
#'if(length(x$idTrimmed) > 2)
#'{
#'  n <- c(x$pedSizeOriginal, x$pedSizeIntermed, x$pedSizeFinal)
#'  b <- c(x$bitSize[1], x$bitSize[2], x$bitSize[length(x$bitSize)])
#'  row.nms <- c("Original","Only Informative","Trimmed")
#'} else {
#'  n <- c(x$pedSizeOriginal, x$pedSizeIntermed)
#'  b <- c(x$bitSize[1], x$bitSize[2])
#'  row.nms <- c("Original","Trimmed")
#'}
#'
#'df <- data.frame(N.subj = n, Bits = b)
#'rownames(df) <- row.nms
#'print(df, quote=FALSE)
#'
#'if(!is.null(x$idList$unavail)) 
#'cat("\n Unavailable subjects trimmed:\n", x$idList$unavail, "\n")
#'
#'if(!is.null(x$idList$noninform)) 
#'cat("\n Non-informative subjects trimmed:\n", x$idList$noninform, "\n")
#'
#'if(!is.null(x$idList$affect)) 
#'cat("\n Informative subjects trimmed:\n", x$idList$affect, "\n")
#'
  ##cat("\n Pedigree after trimming:", x$bitSize, "\n")
#'
#'invisible()
#'}
#'
#'@ 
#'
<<printBanner>>=
#'@examples
#'printBanner <- function(str, banner.width=options()$width, char.perline=.75*banner.width, border = "="){
#'
  # char.perline was calculated taking the floor of banner.width/3
#'
#'vec <- str
#'new<-NULL
#'onespace<-FALSE
#'for(i in 1:nchar(vec)){
#'if (substring(vec,i,i)==' ' && onespace==FALSE){
#'onespace<-TRUE
#'new<-paste(new,substring(vec,i,i),sep="")}
#'else if (substring(vec,i,i)==' ' && onespace==TRUE)
#'{onespace<-TRUE}
#'else{
#'onespace<-FALSE
#'new<-paste(new,substring(vec,i,i),sep="")}
#'}
#'
#'where.blank<-NULL
#'indx <- 1
#'
#'for(i in 1:nchar(new)){
#'if((substring(new,i,i)==' ')){
#'where.blank[indx]<-i
#'indx <- indx+1
#'}
#'}
#'
  # Determine the position in the where.blank vector to insert the Nth character position of "new"
#'j<-length(where.blank)+1
#'
  # Add the Nth character position of the "new" string to the where.blank vector.
#'where.blank[j]<-nchar(new)
#'
#'begin<-1
#'end<-max(where.blank[where.blank<=char.perline])
#'
  # If end.ok equals NA then the char.perline is less than the position of the 1st blank.
#'end.ok <- is.na(end) 
#'
  # Calculate a new char.perline. 
#'if (end.ok==TRUE){ 
#'char.perline <- floor(banner.width/2)
#'end<-max(where.blank[where.blank<=char.perline])
#'}
#'
#'cat(paste(rep(border, banner.width), collapse = ""),"\n")
#'
#'repeat {
#'titleline<-substring(new,begin,end)
#'n <- nchar(titleline)
#'if(n < banner.width)
#'{
#'  n.remain <- banner.width - n
#'  n.left <- floor(n.remain/2)
#'  n.right <- n.remain - n.left
#'  for(i in 1:n.left) titleline <- paste(" ",titleline,sep="")
#'  for(i in 1:n.right) titleline <- paste(titleline," ",sep="")
#'  n <- nchar(titleline)
#'}
#'cat(titleline,"\n")
#'begin<-end+1
#'end.old <- end
  # Next line has a problem when used in R.  Use print.banner.R until fixed.
  # Does max with an NA argument
#'tmp <- where.blank[(end.old<where.blank) & (where.blank<=end.old+char.perline+1)]
#'if(length(tmp)) end <- max(tmp)
#'else break
#'
  #   end<-max(where.blank[(end.old<where.blank)&(where.blank<=end.old+char.perline+1)])
  #   end.ok <- is.na(end)
  #   if (end.ok==TRUE)
  #      break
#'}
#'
#'cat(paste(rep(border, banner.width), collapse = ""), "\n")
#'invisible()
#'
#'}
#'
#'@ 
#'
Plot a pedigree.shrink object, which calls the plot.pedigree function on the trimmed 
pedigree object.

<<plot.pedigree.shrink>>=
#'@examples
#'plot.pedigree.shrink <- function(x, bigped=FALSE, title="", 
#'xlegend="topright", ...){
#'
  ##  Plot pedigrees, coloring subjects according
  ##   to availability, shaded by affected status used in shrink
#'
#'if (bigped == FALSE) {
#'tmp <- plot(x$pedObj, col = x$avail + 1,keep.par=T)
#'}
#'else {
#'tmp <- plot.pedigree(x$pedObj, align = FALSE, packed = FALSE, 
#'col = x$avail + 1, cex = 0.5, symbolsize = 0.5,keep.par=T)
#'}
#'
#'legend(x = xlegend, legend = c("DNA Available", "UnAvailable"), 
#'pch = c(1, 1), col = c(2, 1), bty = "n", cex=.5)
#'title(paste(title, "\nbits = ", x$bitSize[length(x$bitSize)]),cex.main=.9)
#'invisible(tmp)
#'} 
#'
#'@ 
#'
/section{Pedigree Unrelated}

Purpose: Determine set of maximum number of unrelated
available subjects from a pedigree
PI:      Dan Schaid
Author(s): Dan Schaid, Shannon McDonnell
Dates:   Created: 10/19/2007, Moved to kinship2: 6/2011

In many pedigrees there are multiple sets of subjects that could be of the 
size of the maximal set of unrelated subjects in a pedigree.  The set could
contain a married-in uncle and any of a set of siblings from his 
sister-in-law's family.  Therefore, the maximal sets include the uncle and 
any of the sibship of his wife's sister.

<<pedigree.unrelated>>=

  ## Authors: Dan Schaid, Shannon McDonnell
  ## Updated by Jason Sinnwell

#'pedigree.unrelated <- function(ped, avail) {

  # Requires: kinship function

  # Given vectors id, father, and mother for a pedigree structure,
  # and avail = vector of T/F or 1/0 for whether each subject
  # (corresponding to id vector) is available (e.g.,
  # has DNA available), determine set of maximum number
  # of unrelated available subjects from a pedigree.

  # This is a greedy algorithm that uses the kinship
  # matrix, sequentially removing rows/cols that
  # are non-zero for subjects that have the most
  # number of zero kinship coefficients (greedy
  # by choosing a row of kinship matrix that has
  # the most number of zeros, and then remove any
  # cols and their corresponding rows that are non-zero.
  # To account for ties of the count of zeros for rows,
  # a random choice is made. Hence, running this function
  # multiple times can return different sets of unrelated
  # subjects.
#'
#'@examples
#'id <- ped$id
avail <- as.integer(avail)
#'
#'kin <- kinship(ped)
#'
#'ord <- order(id)
#'id <- id[ord]
#'avail <- as.logical(avail[ord])
#'kin <- kin[ord,][,ord]
#'
#'rord <- order(runif(nrow(kin)))
#'
#'id <- id[rord]
#'avail <- avail[rord]
#'kin <- kin[rord,][,rord]
#'
#'id.avail <- id[avail]
#'kin.avail <- kin[avail,,drop=FALSE][,avail,drop=FALSE]
#'
#'diag(kin.avail) <- 0
#'
#'while(any(kin.avail > 0))
#'{
#'  nr <- nrow(kin.avail)
#'  indx <- 1:nrow(kin.avail)
#'  zero.count <- apply(kin.avail==0, 1, sum)
#'  
#'  mx <- max(zero.count[zero.count < nr])
#'  mx.zero <- indx[zero.count == mx][1]
#'  
#'  exclude <- indx[kin.avail[, mx.zero] > 0]
#'  
#'  kin.avail <- kin.avail[- exclude, , drop=FALSE][, -exclude, drop=FALSE]
#'  
#'}
#'
#'choice <- sort(dimnames(kin.avail)[[1]])
#'
#'return(choice)
#'}
#'
#'@ 
