\subsection{alignped1}
This is the first of the three co-routines.
It is called with a single subject, and returns the subtree founded
on said subject, as though it were the only tree.  
We only go down the pedigree, not up.
Input arguments are
\begin{description}
  \item[nid] the numeric id of the subject in question
  \item[dad] points to the row of the father, 0=no father in pedigree
  \item[mom] points to the row of the mother
  \item[level] the plotting depth of each subject
  \item[horder] orders the kids within a sibship
  \item[packed] if true, everything is slid to the left
  \item[spouselist] a matrix of spouses
    \begin{itemize}
      \item col 1= pedigree index of the husband
      \item col 2= pedigree index of the wife
      \item col 3= 1:plot husband to the left, 2= wife to the left
      \item col 4= 1:left member is rooted here, 2=right member, 0=either
    \end{itemize}
\end{description}

The return argument is a set of matrices as described in 
section \ref{sect:alignped}, along with the spouselist matrix.
The latter has marriages removed as they are processed.

In this routine the [[nid]] array consists of the final nid array + 1/2 of the
final spouse array.
The basic algorithm is simple.  
\begin{enumerate}
  \item Find all of the spouses for which [[x]] is the anchor subject.  If
    there are none then return the trivial tree consisting of [[x]] alone.
  \item For each marriage in the set, call [[alignped2]] on the children
    and add this to the result.
\end{enumerate}
Note that the [[spouselist]] matrix will only contain spouse pairs that
are not yet processed.
The logic for anchoring is slightly tricky.  First, if row 4 of
the spouselist matrix is 0, we anchor at the first opportunity, i.e. now..
Also note that if spouselist[,3]==spouselist[,4] it is
the husband who is the anchor (just write out the possibilities).

<<alignped1>>=
alignped1 <- function(x, dad, mom, level, horder, packed, spouselist){
    # Set a few constants
    maxlev <- max(level)
    lev <- level[x]
    n <- integer(maxlev)

    if (length(spouselist)==0)  spouse <- NULL
    else {
	if (any(spouselist[,1]==x)){
	    sex <- 1		                  # I'm male
	    sprows <- (spouselist[,1]==x & (spouselist[,4] ==spouselist[,3] |
                                            spouselist[,4] ==0))
	    spouse <- spouselist[sprows, 2] #ids of the spouses
	    }
	else {
	    sex <- 2
	    sprows <- (spouselist[,2]==x & (spouselist[,4]!=spouselist[,3] |
                                            spouselist[,4] ==0))
            spouse <- spouselist[sprows, 1]
            }
	}
    # Marriages that cross levels are plotted at the higher level (lower
    #  on the paper).
    if (length(spouse)) {
        keep <- level[spouse] <= lev
        spouse <- spouse[keep]
        sprows <- (which(sprows))[keep]
        }
    nspouse <- length(spouse)  # Almost always 0, 1 or 2
@ 
Create the set of 3 return structures, which will be matrices with
(1+nspouse) columns.
If there are children then other routines will widen the result.
<<alignped1>>= 
    nid <- fam <- matrix(0L, maxlev, nspouse+1)
    pos <- matrix(0.0, maxlev, nspouse +1)
    n[lev] <- nspouse +1       
    pos[lev,] <- 0:nspouse
    if (nspouse ==0) {   
        # Easy case: the "tree rooted at x" is only x itself
	nid[lev,1] <- x
	return(list(nid=nid, pos=pos, fam=fam, n=n, spouselist=spouselist))
	}
@ 
Now we have a list of spouses that should be dealt with and 
the the correponding columns of the spouselist matrix.  
Create the two complimentary lists lspouse and rspouse to denote
those plotted on the left and on the right.  
For someone with lots of spouses we try to split them evenly.
If the number of spouses is odd, then men should have more on the
right than on the left, women more on the right.
Any hints in the spouselist matrix override.
We put the undecided marriages closest to [[x]], 
then add predetermined ones to the left and
right.
The majority of marriages will be undetermined singletons, for which
nleft will be 1 for female (put my husband to the left) and 0 for male.
In one bug found by plotting canine data, lspouse could initially be empty but 
length(rspouse)> 1. This caused nleft>length(indx). A fix was to not let
indx to be indexed beyond its length, fix by JPS 5/2013.

<<alignped1>>=
    lspouse <- spouse[spouselist[sprows,3] == 3-sex] # 1-2 or 2-1
    rspouse <- spouse[spouselist[sprows,3] == sex]   # 1-1 or 2-2
    if (any(spouselist[sprows,3] ==0)) {
        #Not yet decided spouses
        indx <- which(spouselist[sprows,3] ==0)
        nleft <- floor((length(sprows) + (sex==2))/2) #total number to left
        nleft <- nleft - length(lspouse)  #number of undecideds to the left
        if (nleft >0) {
            # JPS fixed 5/2013, don't index when nleft > length(indx)
            lspouse <- c(lspouse, spouse[indx[seq_len(min(nleft,length(indx)))]])
            indx <- indx[-(seq_len(min(nleft,length(indx))))]       
          }
        if (length(indx)) rspouse <- c(spouse[indx], rspouse)
      }

    nid[lev,] <- c(lspouse, x, rspouse)
    nid[lev, 1:nspouse] <- nid[lev, 1:nspouse] + .5  #marriages    

    spouselist <- spouselist[-sprows,, drop=FALSE]
@ 

The spouses are in the pedigree, now look below.
For each spouse get the list of children.
If there are any we call alignped2 to generate their tree and
then mark the connection to their parent.
If multiple marriages have children we need to join the
trees.
<<alignped1>>=
    nokids <- TRUE   #haven't found any kids yet
    spouse <- c(lspouse, rspouse)  #reorder
    for (i in 1:nspouse) {
        ispouse <- spouse[i]
	children <- which((dad==x & mom==ispouse) | (dad==ispouse & mom==x))
	if (length(children) > 0) {
	    rval1 <- alignped2(children, dad, mom, level, horder, 
			      packed, spouselist)
            spouselist <- rval1$spouselist
	    # set the parentage for any kids
	    #  a nuisance: it's possible to have a child appear twice, when
	    #  via inbreeding two children marry --- makes the "indx" line
	    #  below more complicated
	    temp <- floor(rval1$nid[lev+1,])  # cut off the .5's for matching
	    indx <- (1:length(temp))[match(temp,children, nomatch=0) >0]
	    rval1$fam[lev+1,indx] <- i   #set the kids parentage
	    if (!packed) {
		# line the kids up below the parents
		# The advantage at this point: we know that there is 
		#   nothing to the right that has to be cared for
		kidmean <- mean(rval1$pos[lev+1, indx])
		parmean <- mean(pos[lev, i + 0:1])
		if (kidmean > parmean) {
		    # kids to the right of parents: move the parents
		    indx <- i:(nspouse+1)
		    pos[lev, indx] <- pos[lev, indx] + (kidmean - parmean)
		    }
		else {
		    # move the kids and their spouses and all below
		    shift <- parmean - kidmean
		    for (j in (lev+1):maxlev) {
			jn <- rval1$n[j]
			if (jn>0) 
			    rval1$pos[j, 1:jn] <- rval1$pos[j, 1:jn] +shift
			}
		    }
		}
	    if (nokids) {
		rval <- rval1
		nokids <- FALSE
		}
	    else {
		rval <- alignped3(rval, rval1, packed)
		}
	    }
	}
@ 

To finish up we need to splice together the tree made up
from all the kids, which only has data from lev+1 down,
with the data here.  
There are 3 cases.  The first and easiest is when no
children were found.
The second, and most common, is when the tree below is
wider than the tree here, in which case we add the
data from this level onto theirs.
The third is when below is narrower, for instance an
only child.
<<alignped1>>=
    if (nokids) {
	return(list(nid=nid, pos=pos, fam=fam, n=n, spouselist=spouselist))
	}

    if (ncol(rval$nid) >= 1+nspouse) {
	# The rval list has room for me!
	rval$n[lev] <- n[lev]
	indx <- 1:(nspouse+1)
	rval$nid[lev, indx] <- nid[lev,]
	rval$pos[lev, indx] <- pos[lev,]
	}
    else {
	#my structure has room for them
	indx <- 1:ncol(rval$nid)   
	rows <- (lev+1):maxlev
	n[rows] <- rval$n[rows]
	nid[rows,indx] <- rval$nid[rows,]
	pos[rows,indx] <- rval$pos[rows,]
	fam[rows,indx] <- rval$fam[rows,]
	rval <- list(nid=nid, pos=pos, fam=fam, n=n)
	}
    rval$spouselist <- spouselist
    rval
    }
@

\subsection{alignped2}
This routine takes a collection of siblings, grows the tree for
each, and appends them side by side into a single tree.
The input arguments are the same as those to
[[alignped1]] with the exception that [[x]] will be a vector.
This routine does nothing to the spouselist matrix, but needs
to pass it down the tree and back since one of the routines
called by [[alignped2]] might change the matrix.

The code below has one non-obvious special case.  Suppose
that two sibs marry.  
When the first sib is processed by [[alignped1]] then both
partners (and any children) will be added to the rval
structure below.  
When the second sib is processed they
will come back as a 1 element tree (the marriage will no longer
be on the spouselist), which should \emph{not} be added
onto rval.  
The rule thus is to not add any 1 element tree whose
value (which must be x[i]) is already in the rval structure for this level.
(Where did Curtis O. \emph{find} these families?)

<<alignped2>>=
alignped2 <- function(x, dad, mom, level, horder, packed,
                      spouselist) {
    x <- x[order(horder[x])]  # Use the hints to order the sibs
    rval <- alignped1(x[1],  dad, mom, level, horder, packed, 
                      spouselist)
    spouselist <- rval$spouselist

    if (length(x) >1) {
	mylev <- level[x[1]]
	for (i in 2:length(x)) {
	    rval2 <-  alignped1(x[i], dad, mom, level,
				horder, packed, spouselist)
            spouselist <- rval2$spouselist
	    
	    # Deal with the unusual special case:
	    if ((rval2$n[mylev] > 1) || 
		          (is.na(match(x[i], floor(rval$nid[mylev,])))))
		rval <- alignped3(rval, rval2, packed)
	    }
        rval$spouselist <- spouselist
	}
    rval
    }
@


\subsection{alignped3}
The third co-routine merges two pedigree trees which are side by
side into a single object.
The primary special case is when the rightmost person in the left
tree is the same as the leftmost person in the right tree; we 
needn't plot two copies of the same person side by side.
(When initializing the output structures don't worry about this - there
is no harm if they are a column bigger than finally needed.)
Beyond that the work is simple bookkeeping.

<<alignped3>>= 
alignped3 <- function(x1, x2, packed, space=1) {
    maxcol <- max(x1$n + x2$n)
    maxlev <- length(x1$n)
    n1 <- max(x1$n)   # These are always >1
    n  <- x1$n + x2$n

    nid <- matrix(0, maxlev, maxcol)
    nid[,1:n1] <- x1$nid
    
    pos <- matrix(0.0, maxlev, maxcol)
    pos[,1:n1] <- x1$pos

    fam <- matrix(0, maxlev, maxcol)
    fam[,1:n1] <- x1$fam
    fam2 <- x2$fam
    if (!packed) {
        <<align3-slide>>
        }
    <<align3-merge>>

    if (max(n) < maxcol) {
	maxcol <- max(n)
	nid <- nid[,1:maxcol]
	pos <- pos[,1:maxcol]
	fam <- fam[,1:maxcol]
	}

    list(n=n, nid=nid, pos=pos, fam=fam)
    }
@ 

For the unpacked case, which is the traditional way to draw a pedigree
when we can assume the paper is infinitely wide, all parents are centered
over their children.  
In this case we think if the two trees to be merged as solid blocks.
On input they both have a left margin of 0.
Compute how far over we have to slide the right tree.
<<align3-slide>>=
slide <- 0
for (i in 1:maxlev) {
    n1 <- x1$n[i]
    n2 <- x2$n[i]
    if (n1 >0 & n2 >0) {
	if (nid[i,n1] == x2$nid[i,1])
		temp <- pos[i, n1] - x2$pos[i,1]
	else    temp <- space + pos[i, n1] - x2$pos[i,1]
	if (temp > slide) slide <- temp
	}
    }
@ 

Now merge the two trees. 
Start at the top level and work down.
\begin{enumerate}
  \item If n2=0, there is nothing to do
  \item Decide if there is a subject overlap, and if so 
    \begin{itemize}
      \item Set the proper parent id. 
        Only one of the two copies will be attached and the other
        will have fam=0, so max(fam, fam2) preserves the correct one.
      \item If not packed, set the position.  Choose the one connected
        to a parent, or midway for a double marriage.
    \end{itemize}
  \item If packed=TRUE determine the amount of slide for this row. It
    will be [[space]] over from the last element in the left pedigree,
    less overlap.
  \item Move everything over
  \item Fix all the children of this level, right hand pedigree, to
    point to the correct parental position.
\end{enumerate}

<<align3-merge>>= 
for (i in 1:maxlev) {
    n1 <- x1$n[i]
    n2 <- x2$n[i]
    if (n2 >0) {   # If anything needs to be done for this row...
        if (n1>0 && (nid[i,n1] == floor(x2$nid[i,1]))) {
            #two subjects overlap
            overlap <- 1
            fam[i,n1] <- max(fam[i,n1], fam2[i,1])
            nid[i,n1] <- max(nid[i,n1], x2$nid[i,1]) #preserve a ".5"
            if (!packed) {
                if(fam2[i,1]>0) 
                    if (fam[i,n1]>0) 
                        pos[i,n1] <- (x2$pos[i,1] + pos[i,n1] + slide)/2
                    else pos[i,n1] <- x2$pos[i,1]+ slide
                    }
            n[i] <- n[i] -1
            }
        else overlap <- 0
        
        if (packed) slide <- if (n1==0) 0 else pos[i,n1] + space - overlap

        zz <- seq(from=overlap+1, length=n2-overlap)
        nid[i, n1 + zz- overlap] <- x2$nid[i, zz]
        fam[i, n1 + zz -overlap] <- fam2[i,zz] 
        pos[i, n1 + zz -overlap] <- x2$pos[i,zz] + slide
        
        if (i<maxlev) {
    	    # adjust the pointers of any children (look ahead)
            temp <- fam2[i+1,]
            fam2[i+1,] <- ifelse(temp==0, 0, temp + n1 -overlap)
    	    }
        }
    }
@

\section{alignped4}
The alignped4 routine is the final step of alignment.  It attempts to line
up children under parents and put spouses and siblings `close' to each other,%'` 
to the extent possible within the constraints of page width.  This routine
used to be the most intricate and complex of the set, until I realized that
the task could be cast as constrained quadradic optimization.
The current code does necessary setup and then calls the [[quadprog]]
function.  
At one point I investigated using one of the simpler least-squares routines
where $\beta$ is constrained to be non-negative. 
However a problem can only be translated into that form if the number
of constraints is less than the number of parameters, which is not
true in this problem.

There are two important parameters for the function.  One is the user specified
maximum width.  The smallest possible width is the maximum number of subjects
on a line, if the user's suggestion  %'
is too low it is increased to that 1+ that
amount (to give just a little wiggle room).
The other is a vector of 2 alignment parameters $a$ and $b$.
For each set of siblings ${x}$ with parents at $p_1$ and $p_2$ the
alignment penalty is
$$
   (1/k^a)\sum{i=1}{k} (x_i - (p_1 + p_2)^2
$$
where $k$ is the number of siblings in the set.
Using the fact that $\sum(x_i-c)^2 = \sum(x_i-\mu)^2 + k(c-\mu)^2$,
when $a=1$ then moving a sibship with $k$ sibs one unit to the left or
right of optimal will incur the same cost as moving one with only 1 or
two sibs out of place.  If $a=0$ then large sibships are harder to move
than small ones, with the default value $a=1.5$ they are slightly easier 
to move than small ones.  The rationale for the default is as long as the
parents are somewhere between the first and last siblings the result looks
fairly good, so we are more flexible with the spacing of a large family.
By tethering all the sibs to a single spot they tend are kept close to 
each other.
The alignment penalty for spouses is $b(x_1 - x_2)^2$, which tends to keep 
them together.  The size of $b$ controls the relative importance of sib-parent
and spouse-spouse closeness.

We start by adding in these penalties.  The total number of parameters
in the alignment problem (what we hand to quadprog) is the set 
of [[sum(n)]] positions.  A work array myid keeps track of the parameter
number for each position so that it is easy to find.
There is one extra penalty added at the end.  Because the penalty amount
would be the same if all the final positions were shifted by a constant,
the penalty matrix will not be positive definite; solve.QP doesn't like  %'
this.  We add a tiny amount of leftward pull to the widest line.
<<alignped4>>=
alignped4 <- function(rval, spouse, level, width, align) {
    if (is.logical(align)) align <- c(1.5, 2)  #defaults
    maxlev <- nrow(rval$nid)
    width <- max(width, rval$n+.01)   # width must be > the longest row

    n <- sum(rval$n)  # total number of subjects
    myid <- matrix(0, maxlev, ncol(rval$nid))  #number the plotting points
    for (i in 1:maxlev) {
        myid[i, rval$nid[i,]>0] <-  cumsum(c(0, rval$n))[i] + 1:rval$n[i]
        }

    # There will be one penalty for each spouse and one for each child
    npenal <- sum(spouse[rval$nid>0]) + sum(rval$fam >0) 
    pmat <- matrix(0., nrow=npenal+1, ncol=n)

    indx <- 0
    # Penalties to keep spouses close
    for (lev in 1:maxlev) {
        if (any(spouse[lev,])) {
            who <- which(spouse[lev,])
            indx <- max(indx) + 1:length(who)
            pmat[cbind(indx, myid[lev,who])] <-  sqrt(align[2])
            pmat[cbind(indx, myid[lev,who+1])] <- -sqrt(align[2])
            }
        }

    # Penalties to keep kids close to parents
    for (lev in (1:maxlev)[-1])  { # no parents at the top level
        families <- unique(rval$fam[lev,])
        families <- families[families !=0]  #0 is the 'no parent' marker
        for (i in families) {  #might be none
            who <- which(rval$fam[lev,] == i)
            k <- length(who)
            indx <- max(indx) +1:k   #one penalty per child
            penalty <- sqrt(k^(-align[1]))
            pmat[cbind(indx, myid[lev,who])] <- -penalty
            pmat[cbind(indx, myid[lev-1, rval$fam[lev,who]])] <- penalty/2
            pmat[cbind(indx, myid[lev-1, rval$fam[lev,who]+1])] <- penalty/2
            }
	}
    maxrow <- min(which(rval$n==max(rval$n)))
    pmat[nrow(pmat), myid[maxrow,1]] <- 1e-5
@ 

Next come the constraints.  If there are $k$ subjects on a line there will
be $k+1$ constraints for that line.  The first point must be $\ge 0$, each
subesquent one must be at least 1 unit to the right, and the final point
must be $\le$ the max width.
<<alignped4>>=
    ncon <- n + maxlev    # number of constraints
    cmat <- matrix(0., nrow=ncon, ncol=n)
    coff <- 0  # cumulative constraint lines so var
    dvec <- rep(1., ncon)
    for (lev in 1:maxlev) {
	nn <- rval$n[lev]
	if (nn>1) {
            for (i in 1:(nn-1)) 
                cmat[coff +i, myid[lev,i + 0:1]] <- c(-1,1)
            }

	cmat[coff+nn,   myid[lev,1]]  <- 1     #first element >=0
        dvec[coff+nn] <- 0
	cmat[coff+nn+1, myid[lev,nn]] <- -1    #last element <= width-1
        dvec[coff+nn+1] <- 1-width
        coff <- coff + nn+ 1
	}

    if (exists('solve.QP')) {
         pp <- t(pmat) %*% pmat + 1e-8 * diag(ncol(pmat))
         fit <- solve.QP(pp, rep(0., n), t(cmat), dvec)
         }
    else stop("Need the quadprog package")

    newpos <- rval$pos
    #fit <- lsei(pmat, rep(0, nrow(pmat)), G=cmat, H=dvec)
    #newpos[myid>0] <- fit$X[myid]           
    newpos[myid>0] <- fit$solution[myid]
    newpos
    }
@ 
