Note that to get this to really be a vignette, I must insert this at the top:
<!-- %\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{Running on chinook data and comparing to Colony} -->
library(pedvis)
We are going to have to see how well we can make a few full sibling families here and whether we will have to make an upper and a lower band to get enough in.
Let's start with 3 singletons, 2 doubletons, 2 triples, 1 quad and 1 quint. Here we make a data frame for that
sibsizes <- list( one = c(1, 1, 1, 2, 2, 3), two = c(3, 4, 5)) # + 1 # add the one there to make a prong on each one lapply(names(sibsizes), function(z) { x <- sibsizes[[z]] pa <- rep(letters[1:length(x)], x) ma <- rep(LETTERS[1:length(x)], x) ped <- data.frame(Kid = as.character(1:sum(x)), Pa = pa, Ma = ma, stringsAsFactors = F) dump <- ped2dot(ped, outf = paste("full-sib-ped", z, sep="-"), pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = paste(1:nrow(ped))) # make the pedigrees with no observed data dump <- ped2dot(ped, outf = paste("full-sib-ped-no-obs", z, sep="-"), pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis") })
Down here we are going to make the same pedigrees with the observed data but add some prongs to them.
sibsizes <- list( one = c(1, 1, 1, 2, 2, 3) + 1, two = c(3, 4, 5) + 1) # + 1 # add the one there to make a prong on each one lapply(names(sibsizes), function(z) { x <- sibsizes[[z]] pa <- rep(letters[1:length(x)], x) ma <- rep(LETTERS[1:length(x)], x) ped <- data.frame(Kid = as.character(1:sum(x)), Pa = pa, Ma = ma, stringsAsFactors = F) dump <- ped2dot(ped, outf = paste("full-sib-ped-with-prongs", z, sep="-"), pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = paste(1:nrow(ped)), ProngNodes = as.character(cumsum(x))) })
Down here I want to make two layers of 11 pronged singletons:
sibsizes <- list( one = rep(2, 11), two = rep(2, 11)) lapply(names(sibsizes), function(z) { x <- sibsizes[[z]] pa <- rep(letters[1:length(x)], x) ma <- rep(LETTERS[1:length(x)], x) ped <- data.frame(Kid = as.character(1:sum(x)), Pa = pa, Ma = ma, stringsAsFactors = F) dump <- ped2dot(ped, outf = paste("11-with-prongs", z, sep="-"), pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = paste(1:nrow(ped)), ProngNodes = as.character(cumsum(x))) })
Now, let's make a gnarly pedigree using spip. First I simulated some data (I don't know what the seeds were):
2014-06-02 07:50 /pedvis/--% (master) pwd /Users/eriq/Documents/git-repos/pedvis 2014-06-02 23:27 /pedvis/--% (master) spip -A 1 -s 1 -f 1 -m 1 --fem-prob-repro 1 --male-prob-repro 1 -T 5 --initial-males 5 --initial-females 5 --cohort-size const 16 --fem-rep-disp-par .4 --mate-fidelity 0 | awk 'BEGIN {print "Kid Pa Ma"} /^PEDIGREE/ && $3 >= 3 {print $5, $6, $7}' > spip_out.txt # then I moved that to a file: # /Users/eriq/Documents/git-repos/pedvis/hairy_pedigree_raw.txt
So, now we can read it and look at it, making anyone born in year 4 or 5 observed:
ped <- read.table("hairy_pedigree_raw.txt", header=T, stringsAsFactors = F) ped2dot(ped, outf = "hairy_ped1", pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = ped$Kid[grep("[MF][45].*", ped$Kid)])
I will want to get rid of a few individuals, so let us plot that with the labels:
ped2dot(ped, outf = "hairy_ped1", pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = ped$Kid[grep("[MF][45].*", ped$Kid)], ShowLabelNodes = unique(c(ped$Kid, ped$Ma, ped$Pa)))
Which tells us that lines with M3_0
and M3_2
can be eliminated. Good
ped <- ped[!(ped$Kid == "M3_0" | ped$Kid == "M3_2"), ]
And now we want to add prongs too. This is easy. Add a kid for every pair of mated parents:
mpairs <- t(simplify2array(strsplit(unique(paste(ped$Pa, ped$Ma, sep="-")), "-"))) colnames(mpairs) <- c("Pa", "Ma") mpairs <- as.data.frame(mpairs, stringsAsFactors = F) Prongs <- paste("Pr", 1:nrow(mpairs), sep="") mpairs$Kid <- Prongs pedp <- rbind(ped, mpairs) ped2dot(pedp, outf = "hairy_ped_with_prongs", pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = pedp$Kid[grep("[MF][45].*", pedp$Kid)], ProngNodes = Prongs)
And we can also make that with invisible prongs
ped2dot(pedp, outf = "hairy_ped_with_invis_prongs", pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis", ObsNodes = pedp$Kid[grep("[MF][45].*", pedp$Kid)], ProngNodes = Prongs, ProngStyle = list(style="invis"), ProngEdgeStyle = list(style="invis"))
And we can also add the o-factors and p-factors on there
ped2dot(pedp, outf = "hairy_ped_as_factor_graph", ObsNodes = pedp$Kid[grep("[MF][45].*", pedp$Kid)], ProngNodes = Prongs, Draw_O_factors = T)
Finally let us make a single individual with parents and granparents as prongs
kpp <- data.frame(Kid = c("a", "d", "g"), Pa = c("b", "e", "a"), Ma = c("c", "f", "d"), stringsAsFactors = F) ped2dot(kpp, outf = "single-kid-with-parent-prongs", ObsNodes = "g", ProngNodes = letters[1:6], pfactorNodeStyle = "invis", pfactorEdgeStyle = "invis")
That has dashed lines above the founders, which is a hassle to change at this point, so I am going to just hack the dot file.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.