genetics/0000755000176000001440000000000012063014560012100 5ustar ripleyusersgenetics/MD50000644000176000001440000000742112063014560012414 0ustar ripleyusersd6a90894caea71aa592b31f61fc60e58 *ChangeLog 91a46fd915332b12a22f50c6b34c2d55 *DESCRIPTION 18179ce6f9301cd84deef2d68817d5dc *NAMESPACE b8b7201db74480b0deafc4967ea11829 *NEWS 329130f615d480aa08a6bd96e3755182 *R/HWE.chisq.R 4d3a1c564741fe0f8adcc7b196ab5e36 *R/HWE.exact.R 09d8934b5de48220fe0a635f0aa635e7 *R/HWE.test.R b0e2d44a96bf5e4c57734dea72d7076e *R/HWE.test.data.frame.R af9be5bc2a85f35e5616c7caa07a77a1 *R/LD.R 19b7b0c389f305ef5ef8141ff86e5b75 *R/ci.balance.R 88958b5bdf8047877f52bb2eb04005dd *R/diseq.R 7d38f678945174e5b6314e6b875d51b0 *R/expectedGenotypes.R 0d0c1837ed4d492060a8e0cdf470de95 *R/genotype.R 6c5b3a399c99aaa56c3e7e74642b06a9 *R/gregorius.R fe049f5f71052c044011189b09a6e070 *R/groupGenotype.R 528ec9d24b28bd841ad5e9962a971d9f *R/hapmcmc.R e3b01c6105b6ea69239e46dd31774354 *R/locus.R 6fbbbf1406ba97a880435f2a40ed29b7 *R/makeGenotypes.R 7f90308cf01854f51b6305704a238333 *R/order.genotype.R 2838edb74732efde60f82e8bd70aa24a *R/plot.LD.R b961295af99db991ac477637d013471e *R/plot.genotype.R fcfd77197879ac5a267a04d1f33b51a8 *R/power.casectl.R 2e06edea48ecce80122f5e1669133c35 *R/power.casectl.plot.R 2743bec7a11777cda0898615e68de40a *R/print.LD.R 55536419da6dfab22473a8b35cb1e408 *R/summary.genotype.R dd6312ac2351213a4377c1a2a1e1c748 *R/write.pedigree.file.R d86dd6b301b36ae8906846c9e24652c3 *R/write.pop.file.R c4323d94c00f35463a52f53648b48b48 *R/zzz.R f5201d8db362fcd733faf7ed38ca84a8 *TODO c056ba3e65d9ad68549fa69904d9c289 *data/gregorius.rda b97445c94b50ebd432dba458bf490e99 *examples/Allele_Freq.R 83d00def581d1954b83003ea514f8404 *examples/Allele_Freq.out 2e58ef3d59ff9720d224b4dc074db65f *examples/Examples.new 2e58ef3d59ff9720d224b4dc074db65f *examples/Examples.out 041b2e0305129d2c247cb58b846bd563 *examples/Gene.examples 26a6b85e55bae0e84f6b1070769f1314 *examples/Genomics.examples 1cf27d0172e89cadfd44dcd470d0a40a *examples/HWE_Test.R 87fa5923d30aea6ca11ca4eb6164bd69 *examples/HWE_Test.out 67d5f9a4fb11c4c5acd5d4717a9386c1 *examples/locus.example.R 0eea6c41d38de6d74e5627bae8131e3b *examples/test.ci.R 06410d63d43f1e0c7a44f8d5cf627e31 *examples/test.data.2.txt fe572c37864c85170a9d10aa74c6542a *examples/test.data.txt d6a90894caea71aa592b31f61fc60e58 *inst/ChangeLog b8b7201db74480b0deafc4967ea11829 *inst/NEWS 28520aba1e5fa9e753a57cb7655ebd9e *inst/doc/LD.pdf a7982b90f82857e34a253df2be42d7c1 *inst/doc/Rnews.sty 2988c573bde1042c043297c59a27f463 *inst/doc/example.R c4595de72231946f0fc1609f592b24c8 *inst/doc/example_data.csv fe4daea58bf47d838420734cab6ec3d1 *inst/doc/genetics_article.pdf f95a9e197a25b8040ecf20f9e01e2837 *inst/doc/genetics_article.tex cc034c5e7309ff6d457240994424f5d2 *inst/doc/make_example_data.R 453812fd57d3c3da0af8308630a8f6bb *man/HWE.chisq.Rd 0a6f55dcecb8ead8f866687044461836 *man/HWE.exact.Rd aed8c26068e9d2aeb9dadb1c950595c1 *man/HWE.test.Rd 4455a410899d85f85b59094523077f1a *man/LD.Rd b038e3239babb78b02d251a3ebb2d460 *man/ci.balance.Rd 21c2396b886ee16be7aff583de04c049 *man/depreciated.Rd 5446e2425a2d00f424ae86d2067c7c68 *man/diseq.Rd 43b447ccb904b0b55131c353f52faf47 *man/expectedGenotypes.Rd ba43c443084381376c9aed95e3caeecc *man/genotype.Rd 0b1f7082b99a41803de0212a4d54e1dd *man/gregorius.Rd ebb2fa0000136f23e3d4240b2957fdd1 *man/groupGenotype.Rd ab74aac707d32ded15c26bfbc43cf001 *man/homozygote.Rd 03e89dacac74ae120af0dd9eb6a3049a *man/locus.Rd 971f959f073780c286e2173b8f2f662f *man/makeGenotypes.Rd 8ea3167890beedf3316d8057e9447c0e *man/order.genotype.Rd ab170ce6ef40554e7f2c9d2b84784fd2 *man/plot.genotype.Rd f659d748a8954374edc7510cfe65a5fc *man/print.LD.Rd d8e6145f469b901e2344657b54615233 *man/summary.genotype.Rd 87f4411c595309ca34d96f338f75bb4e *man/undocumented.Rd 70df7b4bf130657d32d8f8ddb6161bec *man/write.pop.file.Rd ff1d54500f0a55f36e78d742a5136250 *tests/ci.balance.R 4738e69e9433a963e58d50c675e6472e *tests/makeGenotype_with_sep.R 439931dee85bc1d10563b3a7af36756b *tests/test.NA.R genetics/TODO0000644000176000001440000000272410451014204012567 0ustar ripleyusersTO DO: ====== (In no particular order) - provide HTML linkage disequilibrium table - consider enhancing LD tables with HWE on diagonal, potentially use lower trangular are to colorie on a second veriabe, e.g. p-value on top, D' on the bottom. - create LD.haplotype function. - chromosome, chromosome.map - Transmission/Disequilibrium Test - interface to genehunter - Haplotype estimation via EM and Gibbs/MCMC - Gene-map displays: given a list of genes, and their location on the chromosome, plot the markers along the chromosome. You know, something like m1 m2 m4 m6 ---|----|-|------|-|--------| m3 m5 - Quantitative and categorical gene-map plots. The above with a plot above it, something like Disequlibrium: | | | o o | | o | | o o | | | | o | m1 m2 m4 m6 ---|----|-|------|-|--------| m3 m5 * import/export scripts to the linkage .par and .pre files * easy grouping of genotypes, like DONE ==== DONE - update documentation for HWE.test DONE - re-write HWE test to be more general. (It currently supports only two alleles) DONE - Additional HWE test algorithms(permutation, exact) Accomplished by making HWE test a wrapper for chisq.test. DONE - compute/test pairwise disequlibrium DONE - Disequilibrium estimation & testing genetics/tests/0000755000176000001440000000000012062706260013246 5ustar ripleyusersgenetics/tests/test.NA.R0000644000176000001440000000022110720637442014644 0ustar ripleyusers## ## Test for bug when assigning NA values into an existing genotype vector ## library(genetics) G <- as.genotype( c("1/1","1/2") ) G[1] <- NA genetics/tests/makeGenotype_with_sep.R0000644000176000001440000000346311053067143017730 0ustar ripleyuserslibrary(genetics) set.seed(12345) # Create a test data set where there are several genotypes in columns # of the form "A/T". test1 <- data.frame(Tmt=sample(c("Control","Trt1","Trt2"),20, replace=TRUE), G1=sample(c("A/T","T/T","T/A",NA),20, replace=TRUE), N1=rnorm(20), I1=sample(1:100,20,replace=TRUE), G2=paste(sample(c("134","138","140","142","146"),20, replace=TRUE), sample(c("134","138","140","142","146"),20, replace=TRUE), sep=" / "), G3=sample(c("A /T","T /T","T /A"),20, replace=TRUE), comment=sample(c("Possible Bad Data/Lab Error",""),20, rep=TRUE) ) test1 # now automatically convert genotype columns geno1 <- makeGenotypes(test1) geno1 set.seed(12345) # Create a test data set where there are several genotypes in columns # of the form "A_T". test1.b <- data.frame(Tmt=sample(c("Control","Trt1","Trt2"),20, replace=TRUE), G1=sample(c("A_T","T_T","T_A",NA),20, replace=TRUE), N1=rnorm(20), I1=sample(1:100,20,replace=TRUE), G2=paste(sample(c("134","138","140","142","146"),20, replace=TRUE), sample(c("134","138","140","142","146"),20, replace=TRUE), sep=" _ "), G3=sample(c("A _T","T _T","T _A"),20, replace=TRUE), comment=sample(c("Possible Bad Data/Lab Error",""),20, rep=TRUE) ) # now automatically convert genotype columns geno1.b <- makeGenotypes(test1.b, sep="_") stopifnot(identical(geno1,geno1.b)) genetics/tests/ci.balance.R0000644000176000001440000000027210451014203015336 0ustar ripleyuserslibrary(genetics) set.seed(7981357) x <- abs(rnorm(100,1)) ci.balance(x,1, minval=0) ci.balance(x,1) x <- rnorm(100,1) x <- ifelse(x>1, 1, x) ci.balance(x,1, maxval=1) ci.balance(x,1) genetics/R/0000755000176000001440000000000012062706260012305 5ustar ripleyusersgenetics/R/zzz.R0000644000176000001440000000072610720641056013272 0ustar ripleyusers## $Id: zzz.R 1330 2007-11-20 20:23:12Z warnes $ # Obsoleted by Proper use the DESCRIPTION and NAMESPACE files .onLoad <- .First.lib <- function(libname, pkgname) { cat("\n") cat("NOTE: THIS PACKAGE IS NOW OBSOLETE.\n") cat("\n") cat(" The R-Genetics project has developed an set of enhanced genetics\n") cat(" packages to replace 'genetics'. Please visit the project homepage\n") cat(" at http://rgenetics.org for informtion.\n") cat("\n") } genetics/R/write.pop.file.R0000644000176000001440000000306210451014203015263 0ustar ripleyuserswrite.pop.file <- function(data, file="", digits=2, description="Data from R" ) { which <- sapply(data, is.genotype) if(!all(which)) warning("Data contianed non-genotype variables.", " These have been ignored: ", paste(colnames(data)[!which]) ) data <- data[,which] # convert allele names into two or three digit numbers for( col in names(data) ) { # first convert to numbers a1 <- as.numeric(factor(allele(data[[col]],1))) a2 <- as.numeric(factor(allele(data[[col]],2))) # convert NA to 0 a1[is.na(a1)] <- 0 a2[is.na(a2)] <- 0 # now format to have correct # of digits a1 <- formatC( a1, width=digits, flag="0") a2 <- formatC( a2, width=digits, flag="0") # now paste back together data[[col]] <- paste(a1,a2,sep="") } if(file=="") f <- stdout() else f <- file(file,"w") # header line cat(description, file=f) cat("\n", file=f) # marker names cat(colnames(data),sep=" ", file=f) cat("\n", file=f) # group token cat("POP", file=f) cat("\n", file=f) # write allele data. First token is row id, followed by a comma # markers are separated by space rownames(data) <- paste(rownames(data),",", sep="") write.table( data, file=f, sep=" ", quote=FALSE, col.names=F) if(file!="") close(f) } genetics/R/write.pedigree.file.R0000644000176000001440000000634510451014203016260 0ustar ripleyusers# $Id: write.pedigree.file.R 666 2006-03-10 18:19:34Z nj7w $ write.pedigree.file <- function(data, family, pid, father, mother, sex, file="pedigree.txt" ) { # pedigree file format # -------------------- # # ... # # is a unique identifier for each family, and within each family # is a unique identifier for an individual. # and identify the individuals father and mother # (if this line refers to a founder, these should be set to # zero). # denotes the individuals sex, using the convention # 1=male, 2=female. # # Each is encoded as two integer allele numbers. if(missing(family)) family <- 1:nrow(data) if(missing(pid)) pid <- 1:nrow(data) if(missing(father)) father <- rep(0,nrow(data)) if(missing(mother)) mother <- rep(0,nrow(data)) if(missing(sex)) sex <- rep(0,nrow(data)) pedigree <- list() pedigree$family <- format(family) pedigree$pid <- format(pid) pedigree$father <- format(father) pedigree$mother <- format(mother) pedigree$sex <- format(sex) which <- sapply(data, is.genotype) if(!all(which)) warning("Data contianed non-genotype variables.", " These have been ignored: ", paste(colnames(data)[!which]) ) data <- data[,which] allele.number <- function(g, ind) { as.numeric(factor(allele(g, ind), levels = allele.names(g))) } for( col in names(data) ) { name.1 <- paste(col,".1") name.2 <- paste(col,".2") ## allele.number <- function(g, ind) ## as.numeric(as.factor(allele(g,ind), levels=allele.names(g, ind) )) pedigree[[name.1]] <- allele.number( data[[col]], 1) pedigree[[name.2]] <- allele.number( data[[col]], 2) } pedigree <- as.data.frame(pedigree) # NA's are represented as 0 pedigree[is.na(pedigree)] <- 0 write.table(pedigree, file=file, sep=" ", row.names=FALSE, col.names=F, quote=F) } write.marker.file<-function(data, location, file="marker.txt") { # marker.map file format # -------------------- # # MARKERID NAME LOCATION # which <- sapply(data, is.genotype) if(!all(which)) warning("Data contianed non-genotype variables.", " These have been ignored: ", paste(colnames(data)[!which]) ) data <- data[,which] if(missing(location)) location <- 1:ncol(data) ## Create marker.map file data frame marker.map <- cbind( formatC(1:ncol(data), width=8), formatC(colnames(data), width=8, flag="-"), formatC(location, width=8) ) marker.map <- rbind(c("MARKERID", "NAME ","LOCATION"), marker.map) write.table(marker.map, file=file, sep=" ", row.names=FALSE, col.names=F, quote=F) } genetics/R/summary.genotype.R0000644000176000001440000000631310672542500015761 0ustar ripleyusers# $Id: summary.genotype.R 1314 2007-09-12 10:41:11Z ggorjan $ ### ### Provide the frequency and proportions of alleles and genotypes ### # used when summary.genotype is called from summary.data.frame: shortsummary.genotype <- function(object, ..., maxsum) { tmp <- summary.factor(object, maxsum=maxsum) retval <- paste(format(tmp), " (", format(round(prop.table(tmp)*100)), "%)", sep='' ) names(retval) <- names(tmp) #retval <- retval[order(tmp, decreasing=TRUE)] retval } # general function summary.genotype <- function(object,...,maxsum) { # if we are called from within summary.data.frame, fall back to # summary.factor so that we don't mess up the display if(!missing(maxsum)) return(shortsummary.genotype(object,...,maxsum=maxsum)) retval <- list() # retval$genotype <- object retval$allele.names <- allele.names(object) retval$locus <- attr(object,"locus") class(retval) <- "summary.genotype" af <- table(allele(object)) # make sure af has same order as allele.names... # missed <- !names(af) %in% retval$allele.names af.tab <- rep(0,length(retval$allele.names)) names(af.tab) <- retval$allele.names af.tab[names(af)] <- af # paf <- prop.table(af.tab) retval$allele.freq <- cbind("Count"=af.tab,"Proportion"=paf) gf <- table( object ) pgf <- prop.table(gf) retval$genotype.freq <- cbind("Count"=gf,"Proportion"=pgf) ## Sort by genotypeOrder asFun <- as.genotype if(is.haplotype(object)) asFun <- as.haplotype tmp <- asFun(rownames(retval$genotype.freq), alleles=allele.names(object)) tmp <- order(tmp, genotypeOrder=genotypeOrder(object)) retval$genotype.freq <- retval$genotype.freq[tmp, ] ### from code submitted by David Duffy # n.typed<-sum(gf) correction<-2*n.typed/max(1,2*n.typed-1) ehet<-(1-sum(paf*paf)) matings<- (paf %*% t(paf))^2 uninf.mating.freq <- sum(matings)-sum(diag(matings)) pic<- ehet - uninf.mating.freq retval$Hu <- correction * ehet retval$pic <- pic retval$n.typed <- n.typed retval$n.total <- length(object) retval$nallele <- nallele(object) # ### ## Add info on NA values if(any(is.na(object))){ retval$allele.freq <- rbind(retval$allele.freq, "NA"=c(sum(is.na(allele(object))),NA)) retval$genotype.freq <- rbind(retval$genotype.freq, "NA"=c(sum(is.na(object)),NA)) } return(retval) } print.summary.genotype <- function(x,...,round=2) { if(!is.null(x$locus)) { cat("\n") print( x$locus ) } cat("\n") cat("Number of samples typed: ", x$n.typed, " (", round(100*x$n.typed/x$n.total,1), "%)\n", sep="") cat("\n") cat("Allele Frequency: (", x$nallele, " alleles)\n", sep="") print(round(x$allele.freq,digits=round),...) cat("\n") cat("\n") cat("Genotype Frequency:\n") print(round(x$genotype.freq,digits=round),...) cat("\n") cat("Heterozygosity (Hu) = ", x$Hu, "\n", sep="") cat("Poly. Inf. Content = ", x$pic, "\n", sep="") cat("\n") invisible(x) } genetics/R/print.LD.R0000644000176000001440000000543510451014203014056 0ustar ripleyusers# $Id: print.LD.R 395 2005-10-04 23:43:31Z warnes $ print.LD <- function(x, digits=getOption("digits"), ...) { saveopt <- options("digits") options(digits=digits) cat("\n") cat("Pairwise LD\n") cat("-----------\n") est <- t(as.matrix( c(D=x$"D","D'"=x$"D'","Corr"=x$"r"))) rownames(est) <- "Estimates:" print(est) cat("\n") test <- t(as.matrix( c("X^2"=x$"X^2", "P-value"=x$"P-value", "N"=x$"n") ) ) rownames(test) <- "LD Test:" print(test) cat("\n") options(saveopt) invisible(x) } summary.LD.data.frame <- function(object, digits=getOption("digits"), which=c("D", "D'", "r", "X^2", "P-value", "n", " "), rowsep, show.all=FALSE, ...) { if(missing(rowsep)) if(length(which)==1) rowsep <- NULL else rowsep <- " " if(is.null(rowsep)) blank <- NULL else blank <- matrix(rowsep, ncol=ncol(object$"D"), nrow=nrow(object$"D")) saveopt <- options("digits") options(digits=digits) pdat <- list() for(name in which) pdat[[name]] <- object[[name]] tab <- interleave( "D" = if('D' %in% names(pdat)) pdat$D else NULL, "D'" = pdat$"D'", "Corr." = pdat$"r", "X^2"= pdat$"X^2", "P-value" = pdat$"P-value", "n" = pdat$"n", " "=blank, sep=" " ) statlist <- which[ ! (which %in% c("P-value", "n", " ") ) ] statlist[statlist=="X^2"] <- "X\\^2" formatlist <- sapply( statlist, function(object) grep(object, rownames(tab) ) ) formatlist <- unique(sort(unlist(formatlist))) pvallist <- grep( "P-value", rownames(tab) ) tab[formatlist,] <- formatC(as.numeric(tab[formatlist,]), digits=digits, format="f") tab[pvallist,] <- apply(object$"P-value", c(1,2), function(object)trim(format.pval(object, digits=digits))) tab[trim(tab)=="NA"] <- NA if(!show.all) { # drop blank row/column entrylen <- nrow(tab)/nrow(object$n) tab <- tab[1:(nrow(tab) - entrylen),-1] } options(saveopt) class(tab) <- "summary.LD.data.frame" tab } print.summary.LD.data.frame <- function(x, digits=getOption("digits"), ...) { cat("\n") cat("Pairwise LD\n") cat("-----------\n") print(as.matrix(unclass(x)), digits=digits, quote=FALSE, na.print=" ", right=TRUE) cat("\n") invisible(x) } print.LD.data.frame <- function(x, ...) print(summary(x)) genetics/R/power.casectl.R0000644000176000001440000000776611005740456015222 0ustar ripleyusers# power calculation for case-control design (default: case:control = 1:1) # Author: Michael Man # Date: May 5, 2004 # N: total number of subjects # gamma: relative risk in multiplicative model; # not used in Dominant or Recessive model (assume A as protective allele) # p: frequency of A allele # kp: prevalence of disease # alpha: significance level # fc: fraction of cases # pi: probability of 'aa' genotype has the disease # minh: mode of inheritance # reference: Long, A. D. and C. H. Langley (1997). Genetic analysis of complex traits. Science 275: 1328. # Agresti, A. (2002) Categorical Data Analysis. Second Edition, p243. # ( modified from pbsize{gap} ) # requirement: It is recommended to use R 1.9.0 or above. The function 'qchisq' in earlier version # has problem with large noncentrality parameter. # under HWE AA Aa aa # fHW = p(genotype) = c( p^2, 2pq, q^2 ) # model specification # f.mod = relative risk = c(gamma^2, gamma, 1 ) # multiplicative model # f.mod = = c( 0, 0, 1 ) # dominant model # f.mod = = c( 0, 1, 1 ) # recessive model # conditional prob. # p(D|genotype) = f.mod*pi = c(gamma^2, gamma, 1 )*pi # population joint prob. (f.mod = 1 under Ho) # Case p(D, genotype) = p(genotype)* p(D|genotype) = fHW* f.mod*pi # Control p(D_not, genotype) = p(genotype)*(1 - p(D|genotype)) = fHW*(1-f.mod*pi) # population conditional prob. (f.mod = 1 under Ho) # Case p(genotype|D) = p(D , genotype)/P(D ) = P(D , genotype)/sum(P(D , genotype)) = fHW* f.mod*pi / sum(fHW*f.mod*pi) # Control p(genotype|D_not) = p(D_not, genotype)/P(D_not) = P(D_not, genotype)/sum(P(D_not, genotype)) = fHW*(1-f.mod*pi) / (1-sum(fHW*f.mod*pi)) # sample or allocation probability # 1:1 case-control design p(D|Sample) = fc = 1/2 # 1:2 case-control design fc = 1/3 # a prospective design fc = sum(fHW*f.mod*pi) # sample joint prob. (f.mod = 1 under Ho) # for prospective design, this is the same as population joint prob. since 'fc' cancels out with 'sum(fHW*f.mod*pi)' # Case p(genotype,D |sample) = p(genotype|D )* p(D|Sample) = fc *fHW* f.mod*pi / sum(fHW*f.mod*pi) # Control p(genotype,D_not|sample) = p(genotype|D_not)*(1 - p(D|Sample)) = (1-fc)*fHW*(1-f.mod*pi) / (1-sum(fHW*f.mod*pi)) ## power.casectrl <- function (N, gamma = 4.5, p = 0.15, kp=.1, alpha=.05, fc=0.5, ## minh=c('multiplicative', 'dominant','recessive','partialrecessive')) ## { ## minh <- match.arg(minh) ## if ( !all(gamma > 0, N > 0) ) stop('N and gamma must be greater than 0') ## if ( min(p, kp, alpha, fc) <= 0 | max(p, kp, alpha, fc) >=1 ) stop('p, kp, alpha, and fc must be between 0 and 1.') ## f.mod <- switch(minh, ## multiplicative = c(gamma^2, gamma, 1), ## partialrecessive = c(gamma, 1, 1), ## dominant = c( 0, 0, 1), ## recessive = c( 0, 1, 1) ) ## q <- 1 - p ## fhw <- c(p^2, 2*p*q, q^2) ## pi <- kp/sum(f.mod*fhw) ## if (pi <= 0 | pi >=1) { ## warning('The combination of p, kp, and gamma produces an unrealistic value of pi.') ## ret <- NA ## } else { ## fe <- rbind(fhw, fhw) ## dimnames(fe) <- list(c("Case", "Control"), c("AA", "Aa", "aa")) ## f <- fe*rbind(f.mod*pi, 1-f.mod*pi) ## Pct <- apply(f, 1, sum) ## f2 <- f *c(fc, 1-fc)/Pct # normalize the frequencies for each row ## fe2 <- fe*c(fc, 1-fc) ## fe2; apply(fe2, 1, sum); f2; apply(f2, 1, sum) ## lambda <- sum((f2-fe2)^2/fe2)*N ## ret <- 1 - pchisq(qchisq(1-alpha, df=1), df=1, ncp=lambda, lower.tail=T) ## } ## ret ## } power.casectrl <- function (...) { .Deprecated("'GPC', 'GeneticPower.Quantitative.Factor', or 'GeneticPower.Quantitative.Numeric in the BioConductor GeneticsDesign package") } genetics/R/power.casectl.plot.R0000644000176000001440000001215512012453606016160 0ustar ripleyuserspower.casectrl.plot <- function (N, gamma=1.6, p=1:9/10, kp=0.1, alpha=0.05, fc=0.5, minh=c('multiplicative', 'dominant','recessive'), Nsnp=1, vary=c('prevalence','SNPs'), ylim=c(0,1), PLOT=T, ... ) { minh <- match.arg(minh) vary <- match.arg(vary) if (length(p)<2) stop('Must have more than 1 value in p.') if (length(kp) > 1 & length(Nsnp) > 1) stop("Nsnps and kp can't be all > 1.") if (vary=='prevalence') { cmd <- expression(tapply(p, p, function(x, ...) power.casectrl(p=x,...), N=N, gamma=gamma, kp=kp[j], alpha=alpha/Nsnp, fc=fc, minh=minh)) Xvary <- kp } else if (vary=='SNPs') { cmd <- expression(tapply(p, p, function(x, ...) power.casectrl(p=x,...), N=N, gamma=gamma, kp=kp, alpha=alpha/Nsnp[j], fc=fc, minh=minh)) Xvary <- Nsnp } J <- length(Xvary) ret <- matrix(NA, ncol=J, nrow=length(p)) colnames(ret) <- paste(vary, '=', Xvary) for (j in 1:J) ret[,j] <- eval(cmd) if (PLOT) { nc <- 1:ncol(ret) subt <- paste("( RR", gamma, "; total subjects", N,"; SNPs", Nsnp[1], "; prevalence", kp[1], "; mode of inheritance:", minh, "; overall sig.level", alpha, ")" ) matplot(p, ret, type="l", ylim=ylim, lty=1, col=nc, xlab="Allele Frequency", ylab="Power", sub=subt, ...) abline(h=c(.8), lty=1) legend( locator(1), colnames(ret), lty=1, col=nc ) } ret } ### simple simulation for two group design pw <- function(n1, n2=n1*(1-fc)/fc, fc=.5, pi=0, me1=50, me2=45, sd1=10, sd2=10, TEST=F){ covm <- matrix(c(1, pi, pi, 1 ), nrow=2)* matrix(c(sd1^2, sd1*sd2, sd1*sd2, sd2^2), nrow=2) x1 <- rmvnorm(n=n1, mean=c(me1,me1), sigma=covm) x2 <- rmvnorm(n=n2, mean=c(me1,me2), sigma=covm) x <- data.frame(rbind(x1,x2), Trt=c(rep(0,n1), rep(1,n2))) colnames(x) <- c('X', 'Y', 'Trt') mod <- lm(Y~X+Trt, data=x) if (TEST) { print( summary(mod) ) plot(Y~X+Trt, data=x) } ret <- anova(mod, test='F')['Trt','Pr(>F)'] ret } # power calculation for studies using baseline measure # - simulation: continuous response, baseline and genotype as covariate (ANCOVA) # - can specify various modes of inheritance ('additive', 'dominant','recessive') # - use compound symmetry for covariance matrix # Author: Michael Man # Date: June 22, 2004 # N: total number of subjects # p: frequency of A allele # alpha: significance level (used only in 'power.genotype.conti') # Rep: number of iterations to generate power (used only in 'power.genotype.conti') # pi: correlation coefficient # me1: mean of control group # delta: treatment/genotype effect # sd1/2: standard deviation of the control and treatment groups # minh: mode of inheritance # genotype.delta: the effect due to individual genotype effect or overall effect # Factor: whether treat 'Trt' as a factor in 'x' # TEST: debug # reference: # Frison and Pocock (1992) "Repeated measures in clinical trials: analysis using mean summary statistics # and its implications for design" Statistics in Medicine 11:1685-1704 # Vickers (2001) "The use of percentage change from baseline as an outcome in a controlled trial is # statistically inefficient: a simulation study" BMC Med Res Methodol. 2001; 1 (1): 6 # requirement: need library 'mvtnorm' simu.genotype.conti <- function (N, p=0.15, pi=0, me1=50, me2=me1, delta=-5, sd1=10, sd2=10, TEST=F, minh=c('additive', 'dominant','recessive'), genotype.delta=T, Factor=F) { minh <- match.arg(minh) if ( min(N, sd1, sd2)<0 ) stop('N, sd1, and sd2 must be greater than 0') if ( p<=0 | abs(pi)<0 | p>=1 | abs(pi)>1 ) stop('p and abs(pi) must be between 0 and 1.') f.mod <- switch(minh, dominant = c( 0, 1, 1), additive = c( 0 , 0.5, 1), recessive = c( 0, 0, 1) ) q <- 1 - p fhw <- c(q^2, 2*p*q, p^2) # major allele first nhw <- round(N*fhw) if (sum(nhw)!=N) nhw[3] <- N-sum(nhw[1:2]) covm <- matrix(c(1, pi, pi, 1 ), nrow=2)* matrix(c(sd1^2, sd1*sd2, sd1*sd2, sd2^2), nrow=2) if (!genotype.delta) delta <- delta/sum(fhw*f.mod) # convert to overall delta due to all genotypes ## Give explicit variable definitions for variables created by the ## next loop to avoid unassigned variable message. x1 <- x2 <- x3 <- t1 <- t2 <- t3 <- NULL for (i in 1:3) { if (nhw[i]!=0) { assign(paste('x',i,sep=''), rmvnorm(n=nhw[i], mean=c(me1,me2+f.mod[i]*delta), sigma=covm)) assign(paste('t',i,sep=''), rep(f.mod[i],nhw[i])) } else { assign(paste('x',i,sep=''), NULL) assign(paste('t',i,sep=''), NULL) } } x <- data.frame(rbind(x1,x2,x3), Trt=c(t1,t2,t3)) if (Factor) x$Trt <- as.factor(x$Trt) colnames(x) <- c('X', 'Y', 'Trt') mod <- lm(Y~X+Trt, data=x) # ANCOVA if (TEST) { print( summary(mod) ) plot(Y~X+Trt, data=x) } ret <- anova(mod, test='F')['Trt','Pr(>F)'] ret } ### power calculation power.genotype.conti <- function(N, Rep=100, alpha=.05, ...){ pval <- sapply(rep(N, Rep), FUN=simu.genotype.conti, ...) power <- length(pval[pval<=alpha])/length(pval) power } genetics/R/plot.LD.R0000644000176000001440000001107710451014203013677 0ustar ripleyusers# $Id: plot.LD.R 150 2003-06-04 21:22:57Z warnesgr $ plot.LD.data.frame <- function(x, digits=3, colorcut=c(0,0.01, 0.025, 0.5, 0.1, 1), colors=heat.colors(length(colorcut)), textcol="black", marker, which="D'", distance, ...) { oldpar <- par("mfrow") par(mfrow=c(1,2)) LDtable(x, digits=digits, colorcut=colorcut, colors=colors, textcol=textcol, ...) LDplot(x, marker=marker, which=which, distance=distance, ...) par(mfrow=oldpar) invisible() } LDtable <- function(x, colorcut=c(0,0.01, 0.025, 0.5, 0.1, 1), colors=heat.colors(length(colorcut)), textcol="black", digits=3, show.all=FALSE, which=c("D", "D'", "r", "X^2", "P-value", "n"), colorize="P-value", cex, ...) { if(! colorize %in% names(x)) stop(colorize, " not an element of ", deparse(substitute(x)) ) datatab <- summary(x) missmatch <- which[!(which %in% names(x))] if(length(missmatch)>0) stop(missmatch, " not an element of ", deparse(substitute(x)) ) matform <- function( value, template ) { dim(value) <- dim(template) dimnames(value) <- dimnames(template) value } tmp <- cut(x[[colorize]], colorcut, include.lowest=TRUE) colormat <- matform(as.numeric(tmp), x[[colorize]] ) n <- matform( paste("(",x$n,")",sep="" ), x$n) if(!show.all) { # remove blank row/column colormat <- colormat[-nrow(colormat),-1, drop=FALSE] n <- n[-nrow(n),-1, drop=FALSE] } # # color coded frame boxes # image(x=1:ncol(colormat), y=1:ncol(colormat), z=t(colormat[nrow(colormat):1,]), col=colors, xlab="Marker 2\n\n", ylab="Marker 1", xaxt="n", yaxt="n",...) abline(v=-0.5 + 1:(ncol(colormat)+1)) abline(h=-0.5 + 1:(nrow(colormat)+1)) axis(3, 1:ncol(colormat), colnames(colormat) ) axis(2, 1:nrow(colormat), rev(rownames(colormat)) ) # # text in boxes # cex.old <- par("cex") if(missing(cex)) cex <-min( c(1/10, 1/(length(which)+1 ) ) / c(strwidth("W"), strheight("W")*1.5)) par(cex=cex) lineheight <- strheight("W")*1.5 center <- lineheight * length(which)/2 for(i in 1:length(which)) { displaymat <- x[[which[i]]] if(!show.all) displaymat <- displaymat[-nrow(displaymat),-1, drop=FALSE] if( which[i]=="P-value" ) displaymat <- format.pval(displaymat, digits=digits) else if (which[i]!="n") displaymat <- format(displaymat, digits=digits) displaymat[] <- gsub("NA.*", "", as.character(displaymat)) text(x=col(colormat), y=nrow(colormat) - row(colormat)+ 1 + center - lineheight*(i-1), displaymat, col=textcol, adj=c(0.5, 1) ) } text(x=1, y=1, paste(which, collapse="\n"), adj=c(0.5,0.5) ) par(cex=cex.old) # # title # title(main="Linkage Disequilibrium\n") invisible(colormat) } LDplot <- function(x, digits=3, marker, distance, which=c("D", "D'", "r", "X^2", "P-value", "n", " "), ...) { which = match.arg(which) if(missing(marker)) marker <- colnames(x[[which]]) else if (is.numeric(marker)) marker <- colnames(x[[which]])[marker] datamat <- ifelse( is.na(x[[which]]), t(x[[which]]), x[[which]]) if(which %in% c("D'","r") ) diag(datamat) <- 1.0 else if (which=="P-value") diag(datamat) <- 0.0 dimnames(datamat) <- dimnames(x[[which]]) if(missing(distance)) distance <- 1:ncol(datamat) distance <- matrix(distance, ncol=ncol(datamat), nrow=nrow(datamat), byrow=TRUE) dimnames(distance) <- dimnames(datamat) matplot(x=t(distance[marker,,drop=FALSE]), t(datamat[marker,,drop=FALSE]), type="b", xlab="Marker", ylab=paste("Linkage Disequilibrium: ", which, sep=""), xaxt="n", ... ) axis(1, distance[1,], paste(1:ncol(datamat), colnames(datamat), sep=": " )) title("Pairwise Disequilibrium Plot") invisible() } genetics/R/plot.genotype.R0000644000176000001440000000161210652424420015235 0ustar ripleyusers## plot.genotype.R ###------------------------------------------------------------------------ ## What: Plot genotype object ## $Id: plot.genotype.R 1274 2007-07-18 12:09:37Z ggorjan $ ## Time-stamp: <2007-07-18 16:06:07 ggorjan> ###------------------------------------------------------------------------ plot.genotype <- function(x, type=c("genotype", "allele"), what=c("percentage","number"), ...) { what <- match.arg(what) type <- match.arg(type) ## get details tmp <- summary(x) ## Percentages or numbers whati <- ifelse(what == "percentage", 2, 1) ## Plot if (type == "allele") { barplot(tmp$allele.freq[, whati], ...) } else { # genotype barplot(tmp$genotype.freq[, whati], ...) } } ###------------------------------------------------------------------------ ## plot.genotype.R ends here genetics/R/order.genotype.R0000644000176000001440000000473312012456070015377 0ustar ripleyusers### order.genotype.R ###------------------------------------------------------------------------ ### What: Get order of genotype object according to order of allele names or ### genotype names ### Time-stamp: <2007-07-20 10:47:44 ggorjan> ###------------------------------------------------------------------------ ## Define order as generic function order <- function(..., na.last=TRUE, decreasing=FALSE) UseMethod("order") ## Get default method for order from base package order.default <- function(..., na.last=TRUE, decreasing=FALSE) base::order(..., na.last=na.last, decreasing=decreasing) ## Genotype/Haplotype methods order.genotype <- function(..., na.last=TRUE, decreasing=FALSE, alleleOrder=allele.names(x), genotypeOrder=NULL) { x <- list(...)[[1]] isHap <- is.haplotype(x) reorder <- ifelse(isHap, "no", "yes") if (is.null(genotypeOrder)) { ## --- Sort by alleleOrder --- alleleOrder <- unique(alleleOrder) ## Prepair working genotype data for given alleles only if(!identical(alleleOrder, allele.names(x))) x <- genotype(x, alleles=alleleOrder, reorder=reorder) ## Prepair working data for sort i.e. 01_allele1/15_allele15 tmp <- as.character(x) id <- seq(along=alleleOrder) id <- formatC(id, width=ceiling(log10(max(id))), flag="0") for(i in seq(along=alleleOrder)) { tmp <- sub(pattern=paste(alleleOrder[i], "/", sep=""), replacement=paste(i, "_", alleleOrder[i], "/", sep=""), x=tmp) tmp <- sub(pattern=paste("/", alleleOrder[i], sep=""), replacement=paste("/", i, "_", alleleOrder[i], sep=""), x=tmp) } } else { ## --- Sort by genotypeOrder --- genotypeOrder <- unique(genotypeOrder) if(!isHap) { ## Match both A/B and B/A genotypeOrder <- genetics:::.genotype2Haplotype(x=genotypeOrder) } tmp <- match(x, genotypeOrder) } ## print(tmp) return(order(tmp, na.last=TRUE, decreasing=FALSE)) } sort.genotype <- function(x, decreasing=FALSE, na.last=NA, ..., alleleOrder=allele.names(x), genotypeOrder=NULL) { x[order(x, decreasing=decreasing, na.last=na.last, alleleOrder=alleleOrder, genotypeOrder=genotypeOrder)] } ## No need for haplotype methods as they are exactly the same and haplotype ## is extended class of genotype sort.haplotype ###------------------------------------------------------------------------ ### order.genotype.R ends here genetics/R/makeGenotypes.R0000644000176000001440000000326111053065301015236 0ustar ripleyusers# $Id: makeGenotypes.R 1340 2008-08-20 19:04:32Z warnes $ # # convert all genotype-compatible variables in a dataframe to genotypes # makeGenotypes <- function( data, convert, sep="/", tol=0.5, ..., method=as.genotype ) { data <- as.data.frame(data) if(missing(convert)) { fun <- function(x) length(unlist(grep(sep, as.character(x) ))) convert <- sapply( data, fun )/nrow(data) > tol } #cat("Convert:");print(convert); if(is.list(convert)) { if( !all(sapply(convert,length)==2) ) stop("When convert is a list, each element must be a 2-vector.") namelist <- names(data) for(pair in convert) { if(!is.character(pair)) pair <- namelist[pair] # replace first column in pair with new data, index <- which(colnames(data)==pair[1]) data[[ index ]] <- method(data[[ pair[1] ]], data[[ pair[2] ]], sep=sep, ... ) colnames(data)[index] <- paste(pair,collapse=sep) data[[ pair[1] ]] <- data[[ pair[2] ]] <- NULL } } else { if(is.character(convert)) namelist <- convert else namelist <- colnames(data)[convert] for(col in namelist) data[[col]] <- method(data[[col]], sep=sep, ... ) } data } makeHaplotypes <- function( data, convert, sep="/", tol=0.9, ... ) { makeGenotypes( data=data, convert=convert, sep=sep, tol=tol, method=as.haplotype, ... ) } genetics/R/locus.R0000644000176000001440000000555111005741527013564 0ustar ripleyusers# $Id: locus.R 1337 2008-04-30 00:54:56Z warnes $ getlocus <- function(x,...) { if(is.locus(x)) return(x) else if(!is.null(x["locus"])) return(x["locus"]) else if(!is.null(attr(x,"locus"))) return(attr(x,"locus")) else NULL } getmarker <- getgene <- getlocus locus <- function(name, chromosome, arm=c("p","q","long","short",NA), index.start=NULL, index.end=NULL) { object <- list() if(!missing(name)) object$name <- name if(!missing(chromosome)) object$chromosome <- chromosome if(!missing(arm)) { arm <- match.arg( arm ) object$arm <- switch( arm, p="p", q="q", long="p", short="q") } if(!missing(index.start)) object$index.start <- index.start if(!missing(index.end)) object$index.end <- index.end class(object) <- "locus" return(object) } gene <- function(name, chromosome, arm=c("p","q","long","short"), index.start, index.end=NULL) { object <- locus(name, chromosome, arm, index.start, index.end) class(object) <- c("gene","locus") object } marker <- function(name, type, locus.name, bp.start, bp.end=NULL, relative.to=NULL, ... ) { if(is.locus(locus.name)) object <- locus.name else object <- locus(locus.name, ...) if(!missing(name)) object$marker.name <- name if(!missing(type)) object$type <- type if(!missing(bp.start)) object$bp.start <- bp.start if(!missing(bp.end)) object$bp.end <- bp.end if(!missing(relative.to)) object$relative.to <- relative.to class(object) <- c("marker","locus") object } is.locus <- function(x) inherits(x, "locus") is.gene <- function(x) inherits(x, "gene") is.marker <- function(x) inherits(x, "marker") as.character.locus <- function(x,...) { loc <- paste( x$chromosome, x$arm, x$index.start, sep="" ) if( !is.null(x$index.end ) && x$index.start != x$index.end ) loc <- paste(loc, "-", x$index.end, sep="") loc } as.character.gene <- function(x,...) as.character.locus(x,...) as.character.marker <- function(x,...) { loc <- as.character.locus(x) loc <- paste(loc, ":", x$bp.start, sep="") if(!is.null(x$bp.end)) loc <- paste(loc, "-", x$bp.end, sep="") loc } print.locus <- function(x,...) { cat("Locus: ", x$name, " (", as.character.locus(x), ")\n", sep="" ) } print.gene <- function(x,...) { cat("Gene: ", x$name, " (", as.character.locus(x), ")\n", sep="" ) } print.marker <- function(x,...) { cat("Marker: ", paste(x$name,":",x$marker.name,sep=""), " (", as.character.marker(x), ")\tType: ",x$type,"\n", sep="" ) } "locus<-" <- function(x,value) { attr(x,"locus") <- value x } "marker<-" <- "gene<-" <- get("locus<-") genetics/R/LD.R0000644000176000001440000000765410451014203012730 0ustar ripleyusers# $Id: LD.R 453 2005-11-09 17:04:02Z warnes $ # R translation of Cathy Stack's SAS macro # Assumes 2-alleles LD <- function(g1,...) UseMethod("LD",g1) LD.data.frame <- function(g1,...) { gvars <- sapply( g1, function(x) (is.genotype(x) && nallele(x)==2) ) if(any(gvars==FALSE)) { warning("Non-genotype variables or genotype variables ", "with more or less than two alleles detected. ", "These variables will be omitted: ", paste( colnames(g1)[!gvars] , collapse=", " ) ) g1 <- g1[,gvars] } P <- matrix(nrow=ncol(g1),ncol=ncol(g1)) rownames(P) <- colnames(g1) colnames(P) <- colnames(g1) P <- D <- Dprime <- nobs <- chisq <- p.value <- corr <- R.2 <- P for(i in 1:(ncol(g1)-1) ) for(j in (i+1):ncol(g1) ) { ld <- LD( g1[,i], g1[,j] ) D [i,j] <- ld$D Dprime [i,j] <- ld$"D'" corr [i,j] <- ld$"r" R.2 [i,j] <- ld$"R^2" nobs [i,j] <- ld$"n" chisq [i,j] <- ld$"X^2" p.value[i,j] <- ld$"P-value" } retval <- list( call=match.call(), "D"=D, "D'"=Dprime, "r" = corr, "R^2" = R.2, "n"=nobs, "X^2"=chisq, "P-value"=p.value ) class(retval) <- "LD.data.frame" retval } LD.genotype <- function(g1,g2,...) { if(is.haplotype(g1) || is.haplotype(g2)) stop("Haplotype options are not yet supported.") if(nallele(g1)!=2 || nallele(g2)!=2) stop("This function currently only supports 2-allele genotypes.") prop.A <- summary(g1)$allele.freq[,2] prop.B <- summary(g2)$allele.freq[,2] major.A <- names(prop.A)[which.max(prop.A)] major.B <- names(prop.B)[which.max(prop.B)] pA <- max(prop.A, na.rm=TRUE) pB <- max(prop.B, na.rm=TRUE) pa <- 1-pA pb <- 1-pB Dmin <- max(-pA*pB, -pa*pb) pmin <- pA*pB + Dmin; Dmax <- min(pA*pb, pB*pa); pmax <- pA*pB + Dmax; counts <- table( allele.count(g1, major.A), allele.count(g2, major.B) ) n3x3 <- matrix(0, nrow=3, ncol=3) colnames(n3x3) <- rownames(n3x3) <- 0:2 # ensure the matrix is 3x3, with highest frequency values in upper left for(i in rownames(counts)) for(j in colnames(counts)) n3x3[3-as.numeric(i),3-as.numeric(j)] <- counts[i,j] loglik <- function(pAB,...) { (2*n3x3[1,1]+n3x3[1,2]+n3x3[2,1])*log(pAB) + (2*n3x3[1,3]+n3x3[1,2]+n3x3[2,3])*log(pA-pAB) + (2*n3x3[3,1]+n3x3[2,1]+n3x3[3,2])*log(pB-pAB) + (2*n3x3[3,3]+n3x3[3,2]+n3x3[2,3])*log(1-pA-pB+pAB) + n3x3[2,2]*log(pAB*(1-pA-pB+pAB) + (pA-pAB)*(pB-pAB)) } # SAS code uses: # #s <- seq(pmin+0.0001,pmax-0.0001,by=0.0001) #lldmx <- loglik(s) #maxi <- which.max(lldmx) #pAB <- s[maxi] # but this should be faster: solution <- optimize( loglik, lower=pmin+.Machine$double.eps, upper=pmax-.Machine$double.eps, maximum=TRUE ) pAB <- solution$maximum estD <- pAB - pA*pB if (estD>0) estDp <- estD / Dmax else estDp <- estD / Dmin n <- sum(n3x3) corr <- estD / sqrt( pA * pB * pa * pb ) dchi <- (2*n*estD^2)/(pA * pa * pB* pb) dpval <- 1 - pchisq(dchi,1) retval <- list( call=match.call(), "D"=estD, "D'"=estDp, "r" = corr, "R^2" = corr^2, "n"=n, "X^2"=dchi, "P-value"=dpval ) class(retval) <- "LD" retval } genetics/R/HWE.test.R0000644000176000001440000000673310627077410014045 0ustar ripleyusers# $Id: HWE.test.R 1225 2007-05-29 19:29:10Z warnes $ ### Hardy-Weinberg Equilibrium Disequlibrium Estimates, Confidence ### Intervals, and P-values ### HWE.test <- function(x, ...) { UseMethod("HWE.test") } HWE.test.genotype <- function(x, exact=nallele(x)==2, simulate.p.value=!exact, B=10000, conf=0.95, ci.B=1000, ... ) # future options "bootstrap","exact" { retval <- list() # compute disequlibrium retval$diseq <- diseq(x) # compute confidence intervals retval$ci <- diseq.ci(x, R=ci.B, conf=conf) # do chisq test if(exact) retval$test <- HWE.exact(x) else { tab <- retval$diseq$observed.no tab <- 0.5 * (tab + t(tab)) # make symmetric for chisq.test retval$test <- HWE.chisq(x, simulate.p.value=simulate.p.value,B=B,...) } retval$simulate.p.value <- simulate.p.value retval$B <- B retval$conf <- conf retval$ci.B <- ci.B retval$test$data.name <- deparse(substitute(x)) retval$call <- match.call() class(retval) <- c("HWE.test") return(retval) } print.HWE.test <- function(x, show=c("D","D'","r","table"), ...) { cat("\n") cat("\t-----------------------------------\n") cat("\tTest for Hardy-Weinberg-Equilibrium\n") cat("\t-----------------------------------\n") cat("\n") if(!is.null(x$locus)) { cat("\n") print( x$locus ) } cat("Call: \n") print(x$call) cat("\n") if("D" %in% show) { cat("Raw Disequlibrium for each allele pair (D)\n") cat("\n") print(x$diseq$D) cat("\n") } if("D'" %in% show) { cat("Scaled Disequlibrium for each allele pair (D')\n") cat("\n") print(x$diseq$Dprime) cat("\n") } if("r" %in% show) { cat("Correlation coefficient for each allele pair (r)\n") cat("\n") print(x$diseq$r) cat("\n") } if("table" %in% show) { cat("Observed vs Expected Allele Frequencies \n") cat("\n") print(x$diseq$table) cat("\n") } if( ncol(x$diseq$r) <= 2 ) cat("Overall Values\n") else cat("Overall Values (mean absolute-value weighted by expected allele frequency)\n") cat("\n") show.tab <- NULL if("D" %in% show) show.tab <- rbind(show.tab, " D"=x$diseq$D.overall) if("D'" %in% show) show.tab <- rbind(show.tab, " D'"=x$diseq$Dprime.overall) if("r" %in% show) show.tab <- rbind(show.tab, " r"=x$diseq$r.overall) colnames(show.tab) <- "Value" print(show.tab) cat("\n") whichvec <- c("D","D'","r") %in% show cat("Confidence intervals computed via bootstrap using", x$ci.B, "samples\n") cat("\n") if(!is.null(x$ci$warning.text)) cat(strwrap(paste("WARNING:", x$ci$warning.text), prefix=" * "),"\n", sep="\n") show.tab <- matrix(ncol=4, nrow=4) tmp <- format(x$ci$ci[,1:3], digits=getOption("digits")) show.tab[,1] <- tmp[,1] # Observed show.tab[,2] <- paste("(", tmp[,2], ", ", tmp[,3], ")", sep="" ) show.tab[,3] <- x$ci$ci[,4] show.tab[,4] <- ifelse(x$ci$ci[,5],"YES","*NO*") colnames(show.tab) <- c("Observed", "95% CI", "NA's", "Contains Zero?") rownames(show.tab) <- paste(" ", rownames(tmp), sep="") print(show.tab[whichvec,], quote=FALSE) cat("\n") cat("Significance Test:\n") print(x$test) cat("\n") cat("\n") } genetics/R/HWE.test.data.frame.R0000644000176000001440000000211310526711154016030 0ustar ripleyusers HWE.test.data.frame <- function(x, ..., do.Allele.Freq=TRUE, do.HWE.test=TRUE) { data <- makeGenotypes(x) names <- names(data)[sapply(data, is.genotype)] for(i in names) { gene <- getlocus(i) genedata <- data[[i]] cat("\n") cat("+-------------------------------------\n"); if(!is.null(gene)) { cat("|\tMarker:\t ") print(gene) } else cat("|\tMarker: ", i, "\n") cat("+-------------------------------------\n"); if(do.Allele.Freq) { # compute and print the allele and genotype frequencies sum <- summary(genedata) print(sum) } if(do.HWE.test) { if(length(allele.names(genedata))<2) { cat( '*** No variant alleles observed, unable to perform\n', '*** test for Hardy-Wienburg Equilibrium. \n', sep='') } else { # now do and print the HWE test hwe <- HWE.test(genedata, ...) print(hwe) } } } } genetics/R/HWE.exact.R0000644000176000001440000000324510451014203014147 0ustar ripleyusers# $Id: HWE.exact.R 114 2003-05-22 17:25:23Z warnesgr $ # # Based on code submitted by David Duffy # # Exact test for HWE: 2 alleles # # See eg Emigh TH. Comparison of tests for Hardy-Weinberg Equilibrium. # Biometrics 1980; 36: 627-642 # HWE.exact <- function(x) { if(!is.genotype(x)) stop("x must be of class 'genotype' or 'haplotype'") nallele <- length(na.omit(allele.names(x))) if(nallele != 2) stop("Exact HWE test can only be computed for 2 markers with 2 alleles") allele.tab <- table( factor(allele(x,1), levels=allele.names(x)), factor(allele(x,2), levels=allele.names(x)) ) n11 <- allele.tab[1,1] n12 <- allele.tab[1,2] + allele.tab[2,1] n22 <- allele.tab[2,2] n1 <- 2*n11+n12 n2 <- 2*n22+n12 dhwe2 <- function(n11, n12, n22) { f <- function(x) lgamma(x+1) n <- n11+n12+n22 n1 <- 2*n11+n12 n2 <- 2*n22+n12 exp(log(2)*(n12) + f(n) - f(n11) - f(n12) - f(n22) - f(2*n) + f(n1) + f(n2)) } x12 <- seq(n1 %% 2,min(n1,n2),2) x11 <- (n1-x12)/2 x22 <- (n2-x12)/2 dist <- data.frame(n11=x11,n12=x12,n22=x22,density=dhwe2(x11,x12,x22)) dist <- dist[order(dist$density),] STATISTIC <- c("N11"=n11,"N12"=n12,"N22"=n22) PARAMETER <- c("N1"=n1,"N2"=n2) PVAL <- cumsum(dist$density)[dist$n11==n11 & dist$n12==n12 & dist$n22==n22] METHOD <- "Exact Test for Hardy-Weinberg Equilibrium" DNAME <- deparse(substitute(x)) retval <- list(statistic = STATISTIC, parameter = PARAMETER, p.value = PVAL, method = METHOD, data.name = DNAME, observed = x) class(retval) = "htest" return(retval) } genetics/R/HWE.chisq.R0000644000176000001440000000156712012457361014172 0ustar ripleyusers# $Id: HWE.chisq.R 1352 2012-08-14 14:21:35Z warnes $ ### ### Hardy-Weinberg Equilibrium Significance Test ### HWE.chisq <- function(x, ...) UseMethod("HWE.chisq") HWE.chisq.genotype <- function (x, simulate.p.value = TRUE, B = 10000, ...) { observed.no <- table(factor(allele(x, 1), levels = allele.names(x)), factor(allele(x, 2), levels = allele.names(x))) tab <- observed.no tab <- 0.5 * (tab + t(tab)) k <- ncol(tab) if(simulate.p.value) { test <- chisq.test(tab, simulate.p.value = simulate.p.value, B = B, ...) } else { test <- chisq.test(tab, ...) test$parameter <- k*(k-1)/2 test$p.value <- pchisq(test$statistic, test$parameter, lower.tail = FALSE) names(test$statistic) <- "X-squared" names(test$parameter) <- "df" } return(test) } genetics/R/hapmcmc.R0000644000176000001440000001047312012457361014045 0ustar ripleyusers# $Id: hapmcmc.R 1352 2012-08-14 14:21:35Z warnes $ # # Code contributed by David Duffy : # # "If you are interested, this is a toy/prototype for haplotyping via MCMC. # It is much slower than Dan Schaid's haplo.em, but does give the same # answers ;)" # # Routines for handling genotypes # # Convert "1/2" to 1,2 # geno.as.array <- function(genotypes,renumber=FALSE,miss=NULL,gtp.sep="/") { mknum<-function(genotypes, renumber=FALSE, gtp.sep="/") { alleles<- strsplit(genotypes, gtp.sep) gtp<-cbind(sapply(alleles, function(x) x[1], simplify=TRUE), sapply(alleles, function(x) x[2], simplify=TRUE)) if (renumber) { alleles<-unique(unlist(alleles)) gtp[,1]<-as.numeric(factor(gtp[,1],levels=alleles)) gtp[,2]<-as.numeric(factor(gtp[,2],levels=alleles)) } if (is.null(miss)) { gtp[is.na(genotypes),]<-NA }else{ gtp[is.na(genotypes),]<-miss } gtp } if (is.null(ncol(genotypes)) || ncol(genotypes)==1) { res<-mknum(genotypes, renumber=renumber) }else{ res<-data.frame(mknum(genotypes[,1], renumber=renumber)) for(i in 2:ncol(genotypes)) { res<-cbind(res,mknum(genotypes[,i], renumber=renumber)) } colnames(res)<-c(t(outer(names(genotypes),1:2,paste,sep="."))) } apply(res,2,as.character) } # hap <- function(genotypes) { res<-geno.as.array(genotypes) nc<-ncol(res) hap1<-res[,seq(1,nc,2)] hap2<-res[,seq(2,nc,2)] loci<-colnames(genotypes) colnames(hap2)<-colnames(hap1)<-loci list(hap1=hap1, hap2=hap2, class="haplotype") } hapshuffle <- function(haplotypes, hfreq=NULL, ambiguous=NULL, verbose=FALSE, set) { if (is.null(hfreq)) hfreq<-hapfreq(haplotypes, set=set) if (is.null(ambiguous)) ambiguous<-hapambig(haplotypes) nloci<-ncol(haplotypes$hap1) nobs<-nrow(haplotypes$hap1) for(ind in ambiguous) { prop<-curr<-list(hap1=haplotypes$hap1[ind,], hap2=haplotypes$hap2[ind,]) swap<-sample(c(TRUE,FALSE),nloci,replace=TRUE) if (any(swap)) { tmp<-prop$hap1[swap] prop$hap1[swap]<-prop$hap2[swap] prop$hap2[swap]<-tmp } o1<-paste(curr$hap1,collapse=":") o2<-paste(curr$hap2,collapse=":") n1<-paste(prop$hap1,collapse=":") n2<-paste(prop$hap2,collapse=":") pos.o1<-match(o1,names(hfreq)) pos.o2<-match(o2,names(hfreq)) pos.n1<-match(n1,names(hfreq)) pos.n2<-match(n2,names(hfreq)) pn<-(hfreq[pos.n1]+0.5)*(hfreq[pos.n2]+0.5) po<-(hfreq[pos.o1]+0.5)*(hfreq[pos.o2]+0.5) qa<-pn/po if (verbose) cat("Person ",ind," ",qa," ",o1,"/",o2," -> ",n1,"/",n2,sep="") if (qa>runif(1)) { if (verbose) cat(" Accepted\n") haplotypes$hap1[ind,]<-prop$hap1 haplotypes$hap2[ind,]<-prop$hap2 hfreq[pos.n1]<-hfreq[pos.n1]+1 hfreq[pos.n2]<-hfreq[pos.n2]+1 hfreq[pos.o1]<-hfreq[pos.o1]-1 hfreq[pos.o2]<-hfreq[pos.o2]-1 }else if (verbose) { cat(" Unchanged\n") } } list(hfreq=hfreq, haplotypes=haplotypes, class="hapshuffle") } hapambig <- function(haplotypes) { which(apply(haplotypes$hap1!=haplotypes$hap2,1,sum)>1) } hapenum <- function(haplotypes) { dat<-rbind(haplotypes$hap1, haplotypes$hap2) dat<-dat[complete.cases(dat),] set<-unique(dat[,1]) for(i in 2:ncol(dat)) set<-outer(set,unique(dat[,i]),paste,sep=":") factor(set) } hapfreq <- function(haplotypes, set=NULL) { if (is.null(set)) set<-hapenum(haplotypes) hap1<-apply(haplotypes$hap1[complete.cases(haplotypes$hap1),],1,paste,collapse=":") hap2<-apply(haplotypes$hap2[complete.cases(haplotypes$hap2),],1,paste,collapse=":") dat<-c(hap1,hap2) table(factor(dat,levels=set)) } hapmcmc <- function(gtp, B=1000) { tot<-2*nrow(gtp) hap.dat<-hap(gtp) hap.set<-hapenum(hap.dat) hap.amb<-hapambig(hap.dat) hap.new<-list(hfreq=hapfreq(hap.dat, set=hap.set), haplotypes=hap.dat) res<-matrix(nrow=B, ncol=length(hap.set)) colnames(res)<-as.character(hap.set) rownames(res)<-1:B for(i in 1:B) { hap.new<-hapshuffle(hap.new$haplotypes,hfreq=hap.new$hfreq,ambiguous=hap.amb, set=hap.new$set) res[i,]<-hap.new$hfreq } apply(res,2,mean)/tot } mourant <- function(n) { tab<-matrix(c(91,32,5,147,78,17,85,75,7), nrow=3) rownames(tab)<-c("M/M","M/N","N/N") colnames(tab)<-c("S/S","S/s","s/s") dat<-as.data.frame.table(tab) p<-dat$Freq/sum(dat$Freq) dat[sample(1:nrow(dat),n,replace=TRUE,prob=p),1:2] } genetics/R/groupGenotype.R0000644000176000001440000001137710652424420015306 0ustar ripleyusers### groupGenotype.R ###------------------------------------------------------------------------ ### What: Group genotype values code ### Time-stamp: <2007-07-21 12:04:16 ggorjan> ###------------------------------------------------------------------------ groupGenotype <- function(x, map, haplotype=FALSE, factor=TRUE, levels=NULL, verbose=FALSE) { if(!is.genotype(x)) stop("'x' must be of a genotype or haplotype class") if(any(names(map) == "")) stop("all list components in 'map' need to have a name") alleles <- allele.names(x) ## Put else at the end and change it to */* elseF <- FALSE elsePos <- sapply(map, function(x) length(x) == 1 && x == ".else") if(any(elsePos)) { elseF <- TRUE map <- c(map[!elsePos], map[elsePos]) map[elsePos] <- "*/*" } ## Extend the map for(i in seq(along=map)) { map[[i]] <- unlist(genetics:::.matchGenotype(alleles=alleles, pattern=map[[i]], haplotype=haplotype), use.names=FALSE) } ## Remove duplicates sequentially over all map nM <- length(map) if(nM > 1) { for(i in 2:nM) { test <- map[[i]] %in% unlist(map[1:(i - 1)], use.names=FALSE) map[[i]] <- map[[i]][!test] } } ## Show matches if(verbose) print(map) ## Group x <- as.factor(x) if(!is.null(levels)) { if(length(map) != length(levels)) warning("length of 'map' and 'levels' does not match") map <- map[levels] } mapLevels(x) <- as.levelsMap(map) ## Factor? if(!factor) x <- as.character(x) ## Return x } .matchGenotype <- function(x, alleles=allele.names(x), pattern, haplotype=FALSE) { ## Internal function ## ## Finds genotype matches according to given patterns out of possible ## genotype values that might appear in genotype data ## ## Arguments: ## x - genotype or haplotype ## alleles, character, allele names ## pattern - character, pattern in form of "A/A", "A/B", "A/*", "*/A" or "*/*" ## haplotype - logical, should order of alleles in the pattern matter ## ## Value: ## A list of length equal to length of pattern values. Each list ## component is named with pattern and has genotype values that match a ## pattern ## ## Details: ## Internally, \code{\link{genotype}} can store values as "A/B" or "B/A", ## so output for pattern="A/*" holds both "A/B" and "B/A", when ## haplotype=FALSE and there are two alleles (A and B). ## ## Example: ## pattern <- c("A/*", "A/B", "*/*", "B/A") ## genetics:::.matchGenotype(alleles=c("B", "A"), pattern=pattern) ## $`A/*` ## [1] "A/B" "B/A" "A/A" ## $`A/B` ## [1] "A/B" "B/A" ## $`*/*` ## [1] "B/B" "B/A" "A/B" "A/A" ## $`B/A` ## [1] "B/A" "A/B" ## ## genetics:::.matchGenotype(alleles=c("B", "A"), pattern=pattern, haplotype=TRUE) ## $`A/*` ## [1] "A/B" "A/A" ## $`A/B` ## [1] "A/B" ## $`*/*` ## [1] "B/B" "B/A" "A/B" "A/A" ## $`B/A` ## [1] "B/A" if(!missing(x)) { if(!is.genotype(x)) stop("'x' must be of a genotype or haplotype class") } else { if(missing(alleles)) stop("at least one of 'x' or 'alleles' must be given") } if(missing(pattern)) stop("'pattern' must be given") nP <- length(pattern) ret <- vector(mode="list", length=nP) names(ret) <- pattern ## Change * with allele names setup parts <- genetics:::.genotype2Allele(x=pattern) parts <- cbind(parts, 1:nP) testStar <- parts == "*" nA <- length(alleles) ## Expand A/* to A/{alleles} etc. for(i in 1:nrow(parts)) { ## Allele beside * whichStar <- which(!testStar[i, 1:2]) nWS <- length(whichStar) if(nWS < 2) { if(nWS == 1) { # A/* or */A a <- parts[i, whichStar] ## Create possible genotypes if(whichStar == 1) { parts <- rbind(parts, cbind(a, alleles, i)) } else { parts <- rbind(parts, cbind(alleles, a, i)) } } else { # */* tmp <- expectedHaplotypes(alleles=alleles) tmp <- genetics:::.genotype2Allele(x=tmp) parts <- rbind(parts, cbind(tmp, i)) } } } ## Remove * testStar <- rowSums(parts == "*") > 0 parts <- parts[!testStar, , drop=FALSE] ## Order by pattern and create genotypes parts <- parts[order(parts[, 3, drop=FALSE]), , drop=FALSE] parts <- cbind(paste(parts[, 1], parts[, 2], sep="/"), parts[, 3]) ## Fill the return patternId <- unique(parts[, 2]) for(i in 1:nP) { ret[[i]] <- parts[parts[, 2] == patternId[i], 1] } ## For genotype treat A/* the same as */A and A/B as B/A if(!haplotype) ret <- lapply(ret, genetics:::.genotype2Haplotype) ## Return ret } ###------------------------------------------------------------------------ ### groupGenotype.R ends here genetics/R/gregorius.R0000644000176000001440000000423710451014203014431 0ustar ripleyusers# $Id: gregorius.R 114 2003-05-22 17:25:23Z warnesgr $ # # Code contributed by David Duffy . # # Gregorius, H.-R. 1980. The probability of losing an allele when # diploid genotypes are sampled. Biometrics 36, 643-652. # # Formula from "Corollary 2" and "Corollary 3" of that paper # # N is the number of genotypes sampled, # freq=frequency of least common allele to be detected by the study, # missprob=the probability of missing at least one allele # # tol=smallest term in series to be accumulated # gregorius <- function(freq, N, missprob, tol=1.0e-10, maxN=1e4, maxiter=100, showiter=FALSE) { find.alpha <- function(N, freq, tol) #, showiter=FALSE) { n<- floor(1/freq) i<-1 sgn<- -1 term<-1.0 res<-0.0 while(abs(term)>tol && i 1) parts <- a1[,1:2] else if(!is.null(a2)) parts <- cbind(a1,a2) else { # if sep is empty, assume allele names are single characters # pasted together if(sep=="") sep <- 1 # Based on the value of sep, reformat into our standard # name-slash-name format if (is.character(sep) ) { part.list <- strsplit(a1,sep) part.list[ sapply(part.list, length)==0] <- NA ## Handle missing / empty values correctly. ## Without this, empty elements are silently dropped ## and/or cause errors # only first field was given half.empties <- lapply(part.list, length)==1 part.list[half.empties] <- lapply(part.list[half.empties],c,NA) # neither field was given empties <- is.na(a1) | lapply(part.list, length)==0 part.list[empties] <- list(c(NA,NA)) parts <- matrix(unlist(part.list),ncol=2,byrow=TRUE) } else if (is.numeric(sep)) parts <- cbind( substring(a1,1,sep), substring(a1,sep+1,9999)) else stop(paste("I don't know how to handle sep=",sep)) } mode(parts) <- "character" # needed for bare NA's o # convert entirely whitespace alleles to NAs temp <- grep("^[ \t]*$", parts) parts[temp] <- NA #parts[parts=="NA"] <- NA if(missing(alleles) || is.null(alleles)) alleles <- unique(c(na.omit(parts))) else { which.alleles <- !(parts %in% alleles) ## Skipping NA's which.alleles <- which.alleles & !is.na(parts) if(any(which.alleles)) { warning("Found data values not matching specified alleles. ", "Converting to NA.") parts[which.alleles] <- NA } } if(!allow.partial.missing) parts[is.na(parts[,1]) | is.na(parts[,2]),] <- c(NA,NA) if(reorder!="no") { if(reorder=="ascii") { alleles <- sort(alleles) } else if(reorder=="freq") { ## get reordering of alleles by frequency tmp <- names(rev(sort(table(parts)))) alleles <- unique(c(tmp,alleles)) } reorder <- function( x, alleles) { tmp <- match( x, alleles ) x[order(tmp)] } parts <- t(apply(parts,1, reorder, alleles)) } tmp <- ifelse( is.na(parts[,1]) & is.na(parts[,2]), NA, apply(parts,1,paste,collapse="/") ) object <- factor( tmp ) # force "NA" not to be a factor level ll <- levels(object) <- na.omit(levels(object)) class(object) <- c("genotype","factor") attr(object,"allele.names") <- alleles attr(object,"allele.map") <- do.call("rbind", strsplit(ll, "/")) genotypeOrder(object) <- genotypeOrder if(is.null(locus) || is.locus(locus) ) attr(object,"locus") <- locus else stop("parameter locus must be of class locus") return(object) } is.genotype <- function(x) inherits(x, "genotype") is.haplotype <- function(x) inherits(x, "haplotype") ### ### Haplotype -- differs only in that order of a1,a2 is considered siginificant ### haplotype <- function (a1, a2 = NULL, alleles = NULL, sep = "/", remove.spaces = TRUE, reorder = "no", allow.partial.missing = FALSE, locus = NULL, genotypeOrder=NULL) { retval <- genotype(a1 = a1, a2 = a2, alleles = alleles, sep = sep, remove.spaces = remove.spaces, reorder = reorder, allow.partial.missing = allow.partial.missing, locus = locus, genotypeOrder=genotypeOrder) class(retval) <- c("haplotype", "genotype", "factor") retval } as.haplotype <- function(x,...) { retval <- as.genotype(x,...,reorder="no") class(retval) <- c("haplotype","genotype","factor") retval } ### ### Display by giving values plus list of alleles ### print.genotype <- function(x,...) { if(!is.null(attr(x,"locus"))) print(attr(x,"locus")) print(as.character(x)) cat("Alleles:", allele.names(x), "\n" ) invisible(x) } ### ### Conversion Functions ### as.genotype <- function (x,...) UseMethod("as.genotype") # Do we want to do this? as.genotype.default <- function(x,...) genotype(x,...) # stop("No method to convert this object to a genotype") # for characters, and factors, just do the standard thing (factors get # implicitly converted to characters so both have the same effect. as.genotype.character <- function(x,...) genotype(x,...) as.genotype.factor <- function(x,...) genotype(as.character(x),...) as.genotype.genotype <- function(x,...) return(x) as.genotype.haplotype <- function(x,...) return(x) ## genotype.allele.counts give the count of each allele type as a ## matrix. Collapse back into the form we need as.genotype.allele.count <- function(x, alleles=c("A","B"), ...) { if(!is.matrix(x) & !is.data.frame(x) ) { x <- cbind(x, 2-x) colnames(x) <- alleles } if(any(x > 2, na.rm=TRUE) || any( x < 0, na.rm=TRUE ) ) stop("Allele counts must be in {0,1,2}") allele.names <- colnames(x) tmp <- apply(x, 1, function(y) rep( colnames(x), ifelse(is.na(y), 0, y) )) if(!is.matrix(tmp)) retval <- genotype(sapply(tmp,paste,collapse="/"), alleles=alleles, ...) else retval <- genotype(a1=tmp[1,], a2=tmp[2,], ... ) return(retval) } allele.count.2.genotype <- function(...) as.genotype.allele.count(...) as.genotype.table <- function(x, alleles, ...) { #if(missing(alleles)) alleles <- unique(unlist(dimnames(x))) tmp <- outer( rownames(x), colnames(x), paste, sep="/") retval <- genotype( rep(tmp,x), alleles=alleles ) retval } ### ### Equality test for genotype, assumes allele order is _not_ significant ### "==.genotype" <- function(x,y) { if(!is.genotype(y)) y <- as.genotype(y) x.a1 <- allele(x,1) x.a2 <- allele(x,2) y.a1 <- allele(y,1) y.a2 <- allele(y,2) return( (x.a1==y.a1 & x.a2==y.a2) | (x.a1==y.a2 & x.a2==y.a1) ) } ### ### Equality test for haplotype, assumes allele order _is_ significant ### "==.haplotype" <- function(x,y) { if(!is.genotype(y)) y <- as.haplotype(y) x.a1 <- allele(x,1) x.a2 <- allele(x,2) y.a1 <- allele(y,1) y.a2 <- allele(y,2) return( x.a1==y.a1 & x.a2==y.a2 ) } ### ### is.element i.e. %in% ### "%in%" <- function(x, table) UseMethod("%in%") ## Get default method for %in% from base package "%in%.default" <- get("%in%", pos="package:base") "%in%.genotype" <- function(x, table) { xA1 <- allele(x, 1) xA2 <- allele(x, 2) x1 <- paste(xA1, xA2, sep="/") x2 <- paste(xA2, xA1, sep="/") ## Return ((x1 %in% table) | (x2 %in% table)) } "%in%.haplotype" <- function(x, table) as.character(x) %in% as.character(table) ### ### Extract the first and/or second allele. ### ### By default, return a 2 column matrix containing both alleles ### #allele <- function (x,...) # UseMethod("allele") #allele.genotype <- function(x, which=c(1,2) ) allele <- function(x, which=c(1,2) ) { alleles.x <- attr(x,"allele.map") retval <- alleles.x[as.integer(x),which] attr(retval,"locus") <- attr(x,"locus") attr(retval,"which") <- which attr(retval,"allele.names") <- allele.names(x) #class(retval) <- c("allele.genotype", class(retval)) return( retval) } as.factor <- function(x, ...) UseMethod("as.factor") as.factor.default <- get("as.factor",pos="package:base") formals(as.factor.default) <- c(formals(as.factor.default),alist(...= )) as.factor.genotype <- function(x, ...) { attr(x,"class") <- "factor" attr(x,"allele.names") <- NULL attr(x,"allele.map") <- NULL attr(x,"locus") <- NULL attr(x,"genotypeOrder") <- NULL x } as.factor.allele.genotype <- function(x,...) factor(x,levels=allele.names(x)) print.allele.genotype <- function(x,...) { if(!is.null(attr(x,"locus"))) print(attr(x,"locus")) cat("Allele(s):", attr(x,"which"), "\n") attr(x, "which") <- attr(x, "class") <- attr(x,"locus") <- attr(x,"allele.names") <- NULL NextMethod("print",x) } ### ### Obtain the count of the number of copies of alleles for each individual ### ### By default, return a matrix containing the counts for all possible allele values. ### #allele.count <- function (x,...) # UseMethod("allele.count") #allele.count.default <- function (x, ... ) # { # x <- as.genotype(x) # allele.count(x, ...) # } #allele.count.genotype <- function(x, allele.name=allele.names(x), allele.count <- function(x, allele.name=allele.names(x), any=!missing(allele.name), na.rm=FALSE) { if(!missing(allele.name) && length(allele.name)==1) { a.1 <- allele(x,1) a.2 <- allele(x,2) retval <- ifelse(is.na(a.1) | is.na(a.2), ifelse(na.rm, 0, NA), (a.1==allele.name) + (a.2==allele.name) ) # class(retval) <- "allele.count" attr(retval,"allele") <- allele.name attr(retval,"locus") <- attr(x,"locus") return(retval) } else { retval <- sapply( allele.name, function(y) allele.count(x,y)) if(any==TRUE && is.matrix(retval) ) retval <- apply(retval,1,sum,na.rm=na.rm) if(na.rm) retval[is.na(retval)] <- 0 # class(retval) <- "allele.count" attr(retval,"locus") <- attr(x,"locus") return(retval) } } #print.allele.count <- function(x,...) # { # if(!is.null(attr(x,"locus"))) # print(attr(x,"locus")) # # if(is.null(attr(x,"allele"))) # cat("Allele Counts:\n") # else # cat("Allele Count (", attr(x,"allele"), " allele):\n", sep="") # val <- x # attr(val,"class") <- NULL # attr(val,"allele") <- NULL # print(val) # invisible(x) # } ### ### Check for the presence of alleles for each individual ### ### By default, return a matrix containing indicators for all possible ### allele values except the last. ### # #allele.ind <- function(x,allele) # { ## if(missing(allele)) ## stop("Alleles to test must be specified") ## if(length(allele)==1) # retval <- allele.count(x,allele) > 0 ## else ## retval <- apply(allele.count(x,allele) ,1,sum) > 0 # # if(missing(allele)) # allele <- colnames(retval) # attr(retval,"allele") <- allele # attr(retval,"locus") <- attr(x,"locus") # class(retval) <- "allele.ind" # return(retval) # } #print.allele.ind <- function(x,...) # { # if(!is.null(attr(x,"locus"))) # print(attr(x,"locus")) # # cat("Indicator(s) for allele(s):", attr(x,"allele"), "\n") # attr(x,"locus") <- attr(x,"class") <- attr(x,"allele") <- NULL # NextMethod("print",x) # } ### ### Methods for creating subsets based on a genotype ### homozygote <- function (x,allele.name,...) UseMethod("homozygote") homozygote.genotype <- function(x,allele.name,...) { a1 <- allele(x,1) a2 <- allele(x,2) if(missing(allele.name)) retval <- ifelse( is.na(a1) | is.na(a2), NA, a1==a2 ) else retval <- ifelse( is.na(a1) | is.na(a2), NA, a1==allele.name & a2==allele.name ) attr(retval,"locus") <- attr(x,"locus") # class(retval) <- "homozygote" return(retval) } #print.homozygote <- function(x,...) # { # if(!is.null(attr(x,"locus"))) # print(attr(x,"locus")) # # cat("Homozygote Indicators:\n") # attr(x,"locus") <- attr(x,"class") <- attr(x,"allele") <- NULL # NextMethod("print",x) # } heterozygote <- function (x,allele.name,...) UseMethod("heterozygote") heterozygote.genotype <- function(x,allele.name,...) { { a1 <- allele(x,1) a2 <- allele(x,2) if(missing(allele.name)) retval <- ifelse( is.na(a1) | is.na(a2), NA, !a1==a2 ) else retval <- ((a1 %in% allele.name) | (a2 %in% allele.name)) & (a1 != a2) attr(retval,"locus") <- attr(x,"locus") # class(retval) <- "homozygote" return(retval) } } #print.heterozygote <- function(x,...) # { # if(!is.null(attr(x,"locus"))) # print(attr(x,"locus")) # # cat("Heterozygote Indicators:\n") # attr(x,"locus") <- attr(x,"class") <- attr(x,"allele") <- NULL # NextMethod("print",x) # } carrier <- function (x,allele.name,...) UseMethod("carrier") carrier.genotype <- function(x, allele.name=allele.names(x), any=!missing(allele.name), na.rm=FALSE, ...) { retval <- allele.count(x,allele.name=allele.name,any=any,na.rm=na.rm) > 0 attr(retval,"allele") <- retval["allele"] attr(retval,"locus") <- attr(x,"locus") # class(retval) <- "carrier" return(retval) } #print.carrier <- function(x,...) # { # if(!is.null(attr(x,"locus"))) # print(attr(x,"locus")) # # cat("Carrier Indicator(s) for allele(s):", attr(x,"allele"), "\n") # attr(x,"locus") <- attr(x,"class") <- attr(x,"allele") <- NULL # NextMethod("print",unclass(x)) # } ### ### ### allele.names<- function(x) { retval <- attr(x,"allele.names") if(is.null(retval)) retval <- x$allele.names return(retval) } ### ### Subset method ### "[.genotype" <- function(x, i, drop=FALSE) { allelesOld <- attr(x, "allele.names") retval <- NextMethod("[") # force "NA" not to be a factor level ll <- levels(retval) <- na.omit(levels(retval)) class(retval) <- c("genotype","factor") if(drop) { alleles <- unique( unlist(strsplit(ll, "/") ) ) } else { alleles <- attr(x, "allele.names") } attr(retval,"allele.names") <- alleles attr(retval,"allele.map") <- do.call("rbind", strsplit(ll, "/")) attr(retval,"locus") <- attr(x,"locus") attr(retval,"label") <- attr(x,"label") goCur <- attr(x, "genotypeOrder") if(drop) { ## Removing genotype names having dropped alleles allelesOld <- allelesOld[!(allelesOld %in% alleles)] tmp <- allele(as.haplotype(goCur)) test <- tmp %in% allelesOld test <- rowSums(matrix(test, ncol=2)) > 0 attr(retval, "genotypeOrder") <- goCur[!test] } else { attr(retval, "genotypeOrder") <- goCur } return(retval) } "[.haplotype" <- function(x, i, drop=FALSE) { retval <- NextMethod("[") class(retval) <- c("haplotype","genotype","factor") retval } ### ### Subset Assigment method ### "[<-.genotype" <- function(x, i, value) { ## Special case for insertion of NA and "" values if(all( is.na(value) | as.character(value)<="" ) ) { x.class <- class(x) x <- unclass(x) x[i] <- NA class(x) <- x.class return(x) } if(!is.genotype(value)) { value <- genotype(value) } lx <- levels(x) lv <- levels(value) ax <- allele.names(x) av <- allele.names(value) m <- is.na(match(av,ax) ) if( any( m ) ) warning(paste("Adding new allele name:", av[m], "\n")) la <- unique(c(lx,lv)) aa <- unique(c(ax,av)) cx <- class(x) nas <- is.na(x) data <- match(levels(value)[value],la) class(x) <- NULL x[i] <- data attr(x, "levels") <- la map <- attr(x, "allele.map") <- do.call("rbind", strsplit(la, "/")) attr(x, "allele.names") <- aa goCur <- attr(x, "genotypeOrder") goAll <- expectedGenotypes(alleles=aa, haplotype=TRUE) attr(x, "genotypeOrder") <- c(goCur, goAll[!(goAll %in% goCur)]) class(x) <- cx x } "[<-.haplotype" <- function(x, i, value) { if(!is.haplotype(value)) stop("Assigned value must be of class haplotype.") NextMethod("[<-") } nallele <- function(x) length(allele.names(x)) genotypeOrder <- function(x) attr(x, "genotypeOrder") "genotypeOrder<-" <- function(x, value) { if(!is.genotype(x)) stop("'x' must be of a genotype class") alleles <- allele.names(x) goAll <- expectedGenotypes(alleles=alleles, haplotype=TRUE) goDef <- unique(sort(as.character(x))) if(is.null(value)) { attr(x, "genotypeOrder") <- goAll } else { value <- unique(value) ## Stop msg says all parts <- strsplit(x=value, split="/") parts <- sapply(parts, c) test <- !(parts %in% alleles) if(any(test)) stop("adding genotype names with alleles that are not in the data") ## Any genotypes in the data that are not in value? test <- !(goDef %in% value) if(any(test)) { ## These values are in all possible genotypes/haplotypes testDefinAll <- goDef[test] %in% goAll ## but not in value testDefinAllnotVa <- !(goDef[testDefinAll] %in% value) goPos <- goDef[testDefinAllnotVa] ## We could simply add goPos to value now. However, A/B in goPos ## should also match B/A, since genotype() allows reordering of ## original data and additionally we want this to work also for ## haplotype. ## Extend value first. We do not do this before, since one ## might not necessarily like to have B/A together with A/B in ## first place. value <- genetics:::.genotype2Haplotype(x=value) ## Remove heterozygos matches in goPos test <- !(goPos %in% value) goPos <- goPos[test] ## Add goPos to the end of value if(any(test)) value <- c(value, goPos) ## If there are still some values in all, but not in value ## now, we just add them at the end testGOnotAll <- !(goAll %in% value) if(any(testGOnotAll)) value <- c(value, goAll[testGOnotAll]) } else { value <- genetics:::.genotype2Haplotype(x=value) } attr(x, "genotypeOrder") <- value } x } .genotype2Haplotype <- function(x) { ## Internal function ## ## Returns a character vector of possible haplotypes for given genotypes ## in such a way that for say c("A/A", "A/B", "B/B") you get c("A/A", ## "A/B", "B/A", "B/B") i.e. "B/A" comes directly after "A/B"! ## ## x - character, vector of genotype values in form allele1/allele2 ## ## Details ## Unique values of x are taken i.e. first occurrence prevails ## ## Example ## genetics:::.genotype2Haplotype(c("A/A", "A/B", "B/B")) ## "A/A" "A/B" "B/A" "B/B" ## genetics:::.genotype2Haplotype(c("B/B", "A/B", "A/A")) ## "B/B" "A/B" "B/A" "A/A" x <- unique(x) N <- length(x) parts <- genetics:::.genotype2Allele(x=x) parts <- rbind(parts, parts[, 2:1]) ind <- rep(1:N, each=2) + c(0, N) parts <- parts[ind, ] parts <- unique(paste(parts[, 1], parts[, 2], sep="/")) parts } .genotype2Allele <- function(x) { ## Internal function ## ## Returns a matrix of alleles from a character vector of genotype names ## ## x - character, vector of genotype values in form allele1/allele2 ## ## Details: ## Coercing to character is done for x. ## ## Example ## genetics:::.genotype2Allele(c("A/A", "A/B", "B/B")) ## [,1] [,2] ## [1,] "A" "A" ## [2,] "A" "B" ## [3,] "B" "B" parts <- strsplit(x=as.character(x), split="/") parts <- t(sapply(parts, c)) parts } genetics/R/expectedGenotypes.R0000644000176000001440000000361110720641660016131 0ustar ripleyusers# expectedGenotypes.R #-------------------------------------------------------------------------- # What: Construct expected genotypes according to known allele variants # Time-stamp: <2007-07-19 12:06:26 ggorjan> #-------------------------------------------------------------------------- expectedGenotypes <- function(x, alleles=allele.names(x), ploidy=2, sort=TRUE, haplotype=FALSE) { ## Checks if (missing(x) && missing(alleles)) stop("at least one of 'x' or 'alleles' must be given") if (!(missing(x) && !missing(alleles))) { if (!is.genotype(x)) stop("x must be of class 'genotype'") } nA <- length(alleles) if(nA==0) stop("Zero length alleles vector.") ## Add numbers to allele names, so we get result sorted by ## given allele names if (sort) { allelesOrig <- alleles alleles <- paste(1:nA, alleles, sep="") } ## Find possible genotypes according to allele variants if(!haplotype) { comb <- combinations(n=nA, r=ploidy, v=alleles, repeats.allowed=T) } else { comb <- permutations(n=nA, r=ploidy, v=alleles, repeats.allowed=T) } if (sort) { for (i in 1:nA) comb[comb == alleles[i]] <- allelesOrig[i] } ## Create a nice character vector of expected genotypes nC <- dim(comb) ret <- vector(mode="character", length=nC[1]) ret <- paste(comb[, 1], comb[, 2], sep="/") if (ploidy > 2) { for (i in 3:nC[2]) { ret <- paste(ret, comb[, i], sep="/") } } return(ret) } expectedHaplotypes <- function(x, alleles=allele.names(x), ploidy=2, sort=TRUE, haplotype=TRUE) { expectedGenotypes(x=x, alleles=alleles, ploidy=ploidy, sort=sort, haplotype=haplotype) } #-------------------------------------------------------------------------- # expectedGenotypes.R ends here genetics/R/diseq.R0000644000176000001440000002057610652424420013545 0ustar ripleyusers diseq <- function(x, ...) { UseMethod("diseq") } diseq.genotype <- function(x, ...) { if (nallele(x) < 2) { warning("Only 1 Marker allele. Returning NA") return(NA) } observed.no <- table( factor(allele(x,1), levels=allele.names(x)), factor(allele(x,2), levels=allele.names(x)) ) observed <- prop.table(observed.no) observed <- 1/2 * (observed + t(observed) ) retval <- diseq.table(observed) retval$observed.no <- observed.no retval$call <- match.call() retval } diseq.table <- function(x, ...) { observed <- x allele.freq <- apply(observed,1,sum) # equal to: allele.freq <- apply(observed,2,sum) expected <- outer(allele.freq, allele.freq, "*") oeTab <- cbind(Obs=c(observed), Exp=c(expected), "Obs-Exp"=c(observed - expected)) rownames(oeTab) <- outer(rownames(observed), rownames(observed), paste, sep="/") diseq <- observed - expected diag(diseq) <- NA dmax.positive <- expected # equals: max( p(i)p(j), p(j)p(i) ) dmax.negative <- outer(allele.freq, allele.freq, pmin ) - expected # equals: min( p(i) * (1 - p(j)), p(j)( 1 - (1-p(i) ) ) ) dprime <- diseq / ifelse( diseq > 0, dmax.positive, dmax.negative ) # r gives the pairwise correlation coefficient for pairs containing at lease # one allele from the specified pair. # For two alleles: # corr coefficient = diseq / sqrt( p(a) * (1-p(a) ) * p(b) * (1-p(b)) ) #p.1.minus.p <- allele.freq * (1-allele.freq) #r <- -diseq / sqrt( outer( p.1.minus.p, p.1.minus.p, "*") ) r.denom <- sqrt( allele.freq %*% t( allele.freq)) * sqrt( (1-allele.freq) %*% t(1-allele.freq)) r <- -diseq / r.denom # above formula works unchanged for 2 alleles, but requires adjustment # for multiple alleles. # r <- r * (length(allele.freq) - 1) offdiag.expected <- expected diag(offdiag.expected) <- NA sum.expected <- sum(offdiag.expected, na.rm=TRUE) if(all(dim(x)==2)) # 2 allele case { diseq.overall <- diseq[1,2] dprime.overall <- dprime[1,2] r.overall <- r[1,2] R2.overall <- r.overall^2 } else { diseq.overall <- sum( abs(diseq) * expected , na.rm=TRUE ) / sum.expected dprime.overall <- sum( abs(dprime) * expected , na.rm=TRUE ) / sum.expected r.overall <- sum( abs(r) * expected , na.rm=TRUE ) / sum.expected R2.overall <- r.overall^2 } #diag(r) <- 1.0 retval <- list( call = match.call(), observed=observed, expected=expected, table=oeTab, allele.freq=allele.freq, D=diseq, Dprime=dprime, r=r, R2=r^2, D.overall=diseq.overall, Dprime.overall=dprime.overall, r.overall = r.overall, R2.overall = R2.overall ) class(retval) <- "diseq" retval } print.diseq <- function(x, show=c("D","D'","r","R^2","table"), ...) { cat("\n") if(!is.null(x$locus)) { cat("\n") print( x$locus ) } cat("\n") cat("Call: \n") print(x$call) cat("\n") if("D" %in% show) { cat("Disequlibrium for each allele pair (D)\n") cat("\n") print(x$D) cat("\n") } if("D'" %in% show) { cat("Disequlibrium for each allele pair (D')\n") cat("\n") print(x$Dprime) cat("\n") } if("r" %in% show) { cat("Correlation coefficient for each allele pair (r)\n") cat("\n") print(x$r) cat("\n") } if("R^2" %in% show) { cat("R^2 for each allele pair\n") cat("\n") print(x$R2) cat("\n") } if("table" %in% show) { cat("Observed vs Expected frequency table\n") cat("\n") print(x$table) cat("\n") } if( any(c("D","D'","r") %in% show)) { if( ncol(x$r) <= 2 ) cat("Overall Values\n") else cat("Overall Values (mean absolute-value weighted by expected allele frequency)\n") cat("\n") if("D" %in% show) cat(" D : ", x$D.overall, "\n", sep="") if("D'" %in% show) cat(" D' : ", x$Dprime.overall, "\n", sep="") if("r" %in% show) cat(" r : ", x$r.overall, "\n", sep="") if("R^2" %in% show) cat(" R^2: ", x$R2.overall, "\n", sep="") cat("\n") } cat("\n") } diseq.ci <- function(x, R=1000, conf=0.95, correct=TRUE, na.rm=TRUE, ...) { if (!("genotype") %in% class(x) ) stop("x must inherit from class 'genotype'.") if( any(is.na(x) ) ) { if( na.rm) x <- na.omit(x) else stop("Missing values and NaN's not allowed if `na.rm' is FALSE.") } # step 1 - generate summary table observed.no <- table( factor(allele(x,1), levels=allele.names(x)), factor(allele(x,2), levels=allele.names(x)) ) observed <- prop.table(observed.no) observed <- 1/2 * (observed + t(observed) ) # step 2 - make table into a probability vector for calling rmultinom n <- sum(observed.no) prob.vector <- c(observed) # step 3 - sample R multinomials with the specified frequenceis # (include observed data to avoid bias) resample.data <- cbind(c(observed.no), rmultz2( n, prob.vector, R ) ) bootfun <- function(x) { observed[,] <- x/n observed <- 1/2 * (observed + t(observed) ) d <- diseq(observed) c( "Overall D "=d$D.overall, "Overall D' "=d$Dprime.overall, "Overall r "=d$r.overall, "Overall R^2"=d$R2.overall) } results <- apply( resample.data, 2, bootfun ) alpha.2 <- (1-conf)/2 # ci <- t(apply(results, 1, # quantile, c( alpha.2 , 1-alpha.2), na.rm=TRUE )) if(length(allele.names(x))<=2) { ci <- t(apply(results, 1, function(x) quantile(x, c(0.025, 0.975), na.rm=na.rm ) ) ) warning.text <- paste("The R^2 disequlibrium statistics is bounded", "between [0,1]. The confidence ", "intervals for R^2 values near 0 and 1 are", "ill-behaved.", sep=" ") if(correct) { warning.text <- paste(warning.text, "A rough correction has", "been applied, but the intervals still", "may not be correct for R^2 values near", "0 or 1.", sep=" ") X <- results["Overall R^2",] ci["Overall R^2",] <- ci.balance(X,X[1],confidence=conf, minval=0,maxval=1)$ci } } else { warning.text <- paste("For more than two alleles, overall", "disequlibrium statistics are bounded", "between [0,1]. Because of this, confidence", "intervals for values near 0 and 1 are", "ill-behaved.", sep=" ") if(correct) { warning.text <- paste(warning.text, "A rough correction has been applied, but", "the intervals still may not be correct for values near 0 or 1.", sep=" ") ci <- t(apply(results, 1, function(x) ci.balance(x,x[1],confidence=conf, minval=0,maxval=1)$ci )) } else ci <- t(apply(results, 1, function(x) quantile(x, c(0.025, 0.975) ) ) ) warning(paste(strwrap(c(warning.text,"\n"),prefix=" "),collapse="\n") ) } na.count <- function(x) sum(is.na(x)) nas <- apply( results, 1, na.count) zero.in.range <- (ci[,1] <= 0) & (ci[,2] >= 0) ci <- cbind( "Observed"=results[,1], ci, "NAs"=nas, "Zero in Range"=zero.in.range ) outside.ci <- (ci[,1] < ci[,2]) | (ci[,1] > ci[,3]) if( any(outside.ci) ) warning("One or more observed value outide of confidence interval. Check results.") if(any(nas>0)) warning("NAs returned from diseq call") retval <- list( call=match.call(), R=R, conf=conf, ci=ci, warning.text=warning.text ) retval } genetics/R/ci.balance.R0000644000176000001440000000334710451014203014403 0ustar ripleyusers# $Id: ci.balance.R 453 2005-11-09 17:04:02Z warnes $ ci.balance <- function(x, est, confidence=0.95, alpha=1-confidence, minval, maxval, na.rm=TRUE) { if( any(is.na(x) ) ) { if( na.rm) x <- na.omit(x) else stop("Missing values and NaN's not allowed if `na.rm' is FALSE.") } if(missing(minval)) { minval <- min(x) minname <- "min(x)" } else minname <- "Lower Boundary" if(missing(maxval)) { maxval <- max(x) maxname <- "max(x)" } else maxname <- "Upper Boundary" x <- sort(x) n <- length(x) half.window <- n * (1-alpha) / 2 n.below <- sum( x < est ) + sum( x==est )/2 n.above <- sum( x > est ) + sum( x==est )/2 overflow.upper <- max(0, half.window - n.above ) overflow.lower <- max(0, half.window - n.below ) lower.n <- max(1, floor ( n.below - half.window - overflow.upper ) ) upper.n <- min(n, ceiling( n - (n.above - half.window - overflow.lower ) ) ) ci <- c( x[lower.n], x[upper.n] ) names(ci) <- paste( format( c(lower.n, upper.n)/n*100,digits=3 ), "%", sep="") if(overflow.lower>0) { lower.n <- minname names(ci)[1] <- minname ci[1] <- minval } if(overflow.upper>0) { upper.n <- maxname names(ci)[2] <- maxname ci[2] <- maxval } return( list( ci=ci, overflow.upper=overflow.upper, overflow.lower=overflow.lower, n.above=n.above, n.below=n.below, lower.n=lower.n, upper.n=upper.n ) ) } genetics/NEWS0000644000176000001440000001456312062705103012607 0ustar ripleyusersgenetics 1.3.8 - 2012-12-14 --------------------------- Bug fixes: - Regenerate broken PDF files in inst/doc. genetics 1.3.7 - 2012-09-14 --------------------------- Enhancements: - Improve descripiton of last examples in manual page for HWE.test(). Other Changes: - Correct warnings issued by recent versions of R CMD CHECK. genetics 1.3.6 - 2011-02-01 --------------------------- - Add missing 'locus<-', 'gene<-', and 'marker<-' functions to NAMESPACE file. - Update Greg's email address to greg@warnes.net genetics 1.3.5 - 2011-01-17 --------------------------- - Fix warning messages from R CMD check genetics 1.3.4 - 2008-08-20 --------------------------- - Fix bug in makeGenotypes that caused it to ignore the 'sep' argument when determining which columns contain genotypes & add a corresponing regression test genetics 1.3.3 - 2007-04-29 --------------------------- - Correct 'obsolete' use of '$'. R no longer permits '$' to be used to extract named elements from vectors (just lists). - Remove the power.casectl() function, which was based on invalid assumpations. It has been marked depreciated. Please use the functions in the Bioconductor package 'GeneticsDesign' instead. genetics 1.3.2 - 2007-11-20 --------------------------- - Fix bug in handling of assignment of NA value(s) to elements of an existing genotype object. - Fix warning messages from R CMD CHECK - Correct documentation error by swapping definitions of kp and alpha arguments of power.casectl(). genetics 1.3.1 -------------- - fixes in genotypeOrder to ensure all genotype/haplotype combinations are used. - genotypeOrder<- is now exported genetics 1.3.0 -------------- - A note is now displayed on startup: The R-Genetics project has developed an set of enhanced genetics packages that will shortly replace 'genetics'. Please visit the project homepage at http://rgenetics.org for more information. - binsearch() has been moved to the gtools package - New function groupGenotype to create groups/levels based on genotype names - Added some internal utility functions (.genotype2Haplotype, .genotype2Allele, and .matchGenotype) - Genotype class gets additional slot genotypeOrder (and genotype() function gets additional argument with the same name) in order to enable predefined order of genotypes in other functions e.g. summary - Added order, sort and %in% methods for genotype and haplotype classes. - Fixed genotype() with allow.partial.missing=FALSE when 'alleles' argument is passed - There is no more warning in genotype() if 'a1' or 'a2' have NA value(s) and 'alleles'' argument is specified, since NA is NA anyway - Fixed documentation of power.casectrl() - added gtools to Depends as needed by expectedGenotypes(); the latter now gives sorted genotypes according to order of given alleles - print.HWE.test() wasn't displaying the observed vs expected genotype frequency table. Fixed. genetics 1.2.1 -------------- - Update Greg's email address - Fixed a bug in function allele.number, as pointed out by Chris Wallace genetics 1.2.0 ------------- - Add R^2 to HWE and LD estimates - Correct bug in denominator of Heterozygosity calculation, as identified by Christopher Calrson - Fix handling of the 'type' and 'what' arguments for plot.genotype() - Misc bug fixes in package imports/dependencies/etc. - Add expectedGenotypes() and plot.genotypes() contributed by Gregor GORJANC - Fix bug in heterozygote when more than one allele.name is provided - Return NA and issue a warning if diseq() called on a marker with only one observed allele. genetics 1.1.2 -------------- - Remove debugging code that printed intermediate values (sometimes a lot of them). - Ensure that allele.freq table reported by summary.genotype has the same ordering as allele.names table. genetics 1.1.1 -------------- - Make it clear that the Yates continuty correction is applied *only* when simulate.p.value=FALSE, so that the reported test statistics for simulate.p.value=FALSE and simulate.p.value=TRUE will differ. - Attempt to fix/clarify HWE diseq. computations & synchronize documentation. - Updated to use a namespace and to work with the lastest gregmisc bundle, which was previously a package. genetics 1.1.0 -------------- - Add namespace support - R/diseq.R: Restore ability to show Observed vs. Expected table by adding "table" option for the 'show' parameter. - Updates to power.casectrl. (including renaming from power.casectl) - Update to work with gregmisc now that it has been converted from a package to a bundle. genetics 1.0.4 -------------- - Updated to remove warnings in R CMD check for R 1.9.1. genetics 1.0.2 -------------- - Fixed Heterozygosity (H) and PIC calculations in summary.genotype. (Bug report from Gerard Tromp . - Added experimental, undocumented, and untested function hapmcmc for imputing haplotypes and related functions. (Code submitted by David Duffy ). genetics 1.0.1 -------------- - Fixed mislabeling of rows/columns in LDtable - Extended LDtable to resize text to fit box area, and to allow selection of which statistics are displayed, and which statistic is used for coloration. - Extended LDtable to allow all columns & rows to be shown - Added a larger example to plot.LD.data.frame documentation - Changed the name of some function parameters to be more clear and/or consistent - Added summary.LD.data.frame and print.LD.data.frame - Fixed a bug in genotype() when reorder="no", such as when called by haplotype(). genetics 1.0.0 -------------- - New functions to estimate and test linkage disequilibrium (LD): LD, LD.genotype, LD.data.frame - New functions to display LD results print.LD, print.LD.data.frame, plot.LD.data.frame, LDtable, LDplot - Various bug-fixes and corrections genetics 0.6.8 -------------- - Added HWE.chisq which performs the Chi-Square test for Hardy-Wienberg Equilibrium. - Modified HWE.exact to return an object of class 'htest'. - Modified HWE.test to use HWE.exact by default for 2-allele genotypes, and HWE.chisq otherwise. genetics 0.6.7 -------------- - Added 'HWE.exact()', an exact test for Hardy-Wienberg Equilibrium for two alleles. Code contributed by David Duffy - Added 'gregorius()', which computes the probability of observing all alleles with a given frequency in a sample of a specified size. genetics/NAMESPACE0000644000176000001440000000570311522135356013332 0ustar ripleyusersexport( HWE.chisq, HWE.exact, HWE.test, LD, #binsearch, # moved to gtools ci.balance, diseq, diseq.ci, genotype, haplotype, is.genotype, is.haplotype, as.genotype, as.haplotype, allele.names, nallele, gregorius, homozygote, heterozygote, carrier, allele, allele.count, allele.names, #library.pos, locus, gene, marker, "locus<-", "gene<-", "marker<-", is.gene, is.locus, is.marker, getlocus, getmarker, getgene, makeGenotypes, makeHaplotypes, power.casectrl, LDtable, LDplot, as.factor, geno.as.array, # mknum, hap, hapshuffle, hapenum, hapfreq, hapmcmc, mourant, hapambig, write.pop.file, write.pedigree.file, write.marker.file, shortsummary.genotype, summary.LD.data.frame, as.genotype.allele.count, expectedGenotypes, expectedHaplotypes, order, genotypeOrder, "genotypeOrder<-", groupGenotype, "%in%" ) S3method(summary,genotype) #S3method(allele.count.2,genotype) #S3method(as.factor.allele,genotype) S3method(as.factor,default) S3method(as.factor,genotype) #S3method('<-',locus) #S3method('<-',marker) #S3method('<-',gene) S3method(print,gene) S3method(print,locus) S3method(print,marker) S3method(as.character,locus) S3method(as.character,gene) S3method(as.character,marker) S3method(carrier,genotype) S3method(as.genotype,allele.count) S3method(as.genotype,character) S3method(as.genotype,default) S3method(as.genotype,factor) S3method(as.genotype,genotype) S3method(as.genotype,haplotype) S3method(as.genotype,table) S3method(HWE.chisq,genotype) S3method(HWE.test,genotype) S3method(HWE.test,data.frame) S3method(print,HWE.test) S3method(LD,genotype) S3method(LD,data.frame) S3method(diseq,table) S3method(diseq,genotype) S3method(print,diseq) S3method(print,genotype) S3method('==',genotype) S3method('==',haplotype) S3method('%in%',default) S3method('%in%',genotype) S3method('%in%',haplotype) S3method('[',genotype) S3method('[',haplotype) S3method('[<-',genotype) S3method('[<-',haplotype) S3method(heterozygote,genotype) S3method(homozygote,genotype) #S3method(print,allele.count) S3method(print,allele.genotype) #S3method(allele.count,genotype) #S3method(allele,genotype) S3method(print,LD) S3method(print,LD.data.frame) S3method(print,summary.LD.data.frame) S3method(plot,LD.data.frame) S3method(print,summary.genotype) S3method(plot,genotype) S3method(order, default) S3method(order, genotype) S3method(sort, genotype) importFrom(stats, na.omit) importFrom(gdata, interleave, trim) importFrom(mvtnorm, rmvnorm) ##importFrom(combinat, rmultz2) # combinat doesn't have a namesspace. importFrom(gtools, binsearch, combinations, permutations) genetics/man/0000755000176000001440000000000012062706260012657 5ustar ripleyusersgenetics/man/write.pop.file.Rd0000644000176000001440000000407511522137670016024 0ustar ripleyusers% $Id: write.pop.file.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{write.pop.file} \alias{write.pop.file} \alias{write.pedigree.file} \alias{write.marker.file} %- Also NEED an '\alias' for EACH other topic documented here. \title{Create genetics data files} \description{ \code{write.pop.file} creates a 'pop' data file, as used by the GenePop (\url{http://wbiomed.curtin.edu.au/genepop/}) and LinkDos (\url{http://wbiomed.curtin.edu.au/genepop/linkdos.html}) software packages. \code{write.pedigree.file} creates a 'pedigree' data file, as used by the QTDT software package (\url{http://www.sph.umich.edu/statgen/abecasis/QTDT/}). \code{write.marker.file} creates a 'marker' data file, as used by the QTDT software package (\url{http://www.sph.umich.edu/statgen/abecasis/QTDT/}). } \usage{ write.pop.file(data, file = "", digits = 2, description = "Data from R") write.pedigree.file(data, family, pid, father, mother, sex, file="pedigree.txt") write.marker.file(data, location, file="marker.txt") } \arguments{ \item{data}{Data frame containing genotype objects to be exported} \item{file}{Output filename} \item{digits}{Number of digits to use in numbering genotypes, either 2 or 3.} \item{description}{Description to use as the first line of the 'pop' file.} \item{family, pid, father, mother}{Vector of family, individual, father, and mother id's, respectively.} \item{sex}{Vector giving the sex of the individual (1=Make, 2=Female)} \item{location}{Location of the marker relative to the gene of interest, in base pairs.} } \details{ The format of 'Pop' files is documented at \url{http://wbiomed.curtin.edu.au/genepop/help_input.html}, the format of 'pedigree' files is documented at \url{http://www.sph.umich.edu/csg/abecasis/GOLD/docs/pedigree.html} and the format of 'marker' files is documented at \url{http://www.sph.umich.edu/csg/abecasis/GOLD/docs/map.html}. } \value{ No return value. } \author{Gregory R. Warnes \email{greg@warnes.net}} \seealso{\code{\link{write.table}}} \examples{ # TBA } \keyword{IO} genetics/man/undocumented.Rd0000644000176000001440000000125212012457530015636 0ustar ripleyusers% $Id: undocumented.Rd 1353 2012-08-14 14:23:17Z warnes $ \name{undocumented} \alias{as.factor} \alias{allele.count.2.genotype} \alias{as.factor.allele.genotype} \alias{as.factor.default} \alias{as.factor.genotype} \alias{shortsummary.genotype} \alias{geno.as.array} \alias{mknum} \alias{hap} \alias{hapshuffle} \alias{hapenum} \alias{hapfreq} \alias{hapmcmc} \alias{mourant} \alias{hapambig} \title{Undocumented functions} \description{ These functions are undocumented. Some are internal and not intended for direct use. Some are not yet ready for end users. Others simply haven't been documented yet. } \author{Gregory R. Warnes} \keyword{ misc } %%\keyword{genetics} genetics/man/summary.genotype.Rd0000644000176000001440000000626611522137670016511 0ustar ripleyusers% $Id: summary.genotype.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{summary.genotype} \alias{summary.genotype} \alias{print.summary.genotype} \title{ Allele and Genotype Frequency from a Genotype or Haplotype Object} \description{ \code{summary.genotype} creates an object containing allele and genotype frequency from a \code{genotype} or \code{haplotype} object. \code{print.summary.genotype} displays a \code{summary.genotype} object. } \usage{ \method{summary}{genotype}(object, ..., maxsum) \method{print}{summary.genotype}(x,...,round=2) } \arguments{ \item{object, x}{ an object of class \code{genotype} or \code{haplotype} (for \code{summary.genotype}) or an object of class \code{summary.genotype} (for \code{print.summary.genotype}) } \item{\dots}{ optional parameters. Ignored by \code{summary.genotype}, passed to \code{print.matrix} by \code{print.summary,genotype}.} \item{maxsum}{ specifying any value for the parameter maxsum will cause \code{summary.genotype} to fall back to \code{summary.factor}.} \item{round}{ number of digits to use when displaying proportions.} } \details{ Specifying any value for the parameter \code{maxsum} will cause fallback to \code{summary.factor}. This is so that the function \code{summary.dataframe} will give reasonable output when it contains a genotype column. (Hopefully we can figure out something better to do in this case.) } \value{ The returned value of \code{summary.genotype} is an object of class \code{summary.genotype} which is a list with the following components: \item{locus }{locus information field (if present) from \code{x}}. \item{allele.names}{ vector of allele names } \item{allele.freq }{ A two column matrix with one row for each allele, plus one row for \code{NA} values (if present). The first column, \code{Count}, contains the frequency of the corresponding allele value. The second column, \code{Proportion}, contains the fraction of alleles with the corresponding allele value. Note each observation contains two alleles, thus the \code{Count} field sums to twice the number of observations. } \item{genotype.freq}{ A two column matrix with one row for each genotype, plus one row for \code{NA} values (if present). The first column, \code{Count}, contains the frequency of the corresponding genotype. The second column, \code{Proportion}, contains the fraction of genotypes with the corresponding value. } \code{print.summary.genotype} silently returns the object \code{x}. } %\references{ ~put references to the literature/web site here ~ } \author{ Gregory R. Warnes \email{greg@warnes.net} } %\note{ ~~further notes~~ } \seealso{ \code{\link{genotype}}, \code{\link{HWE.test}}, \code{\link{allele}}, \code{\link{homozygote}}, \code{\link{heterozygote}}, \code{\link{carrier}}, % \code{\link{summary.genotype}}, \code{\link{allele.count}} \code{\link{locus}} \code{\link{gene}} \code{\link{marker}} } \examples{ example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 summary(g1) } \keyword{ misc } %%\keyword{genetics} genetics/man/print.LD.Rd0000644000176000001440000001067112012457530014603 0ustar ripleyusers% $Id: print.LD.Rd 1353 2012-08-14 14:23:17Z warnes $ \name{print.LD} \alias{print.LD} \alias{print.LD.data.frame} \alias{summary.LD.data.frame} \alias{print.summary.LD.data.frame} \alias{plot.LD.data.frame} \alias{LDtable} \alias{LDplot} \title{Textual and graphical display of linkage disequilibrium (LD) objects} \description{ Textual and graphical display of linkage disequilibrium (LD) objects } \usage{ \method{print}{LD}(x, digits = getOption("digits"), \dots) \method{print}{LD.data.frame}(x, \dots) \method{summary.LD}{data.frame}(object, digits = getOption("digits"), which = c("D", "D'", "r", "X^2", "P-value", "n", " "), rowsep, show.all = FALSE, \dots) \method{print}{summary.LD.data.frame}(x, digits = getOption("digits"), \dots) \method{plot}{LD.data.frame}(x,digits=3, colorcut=c(0,0.01, 0.025, 0.5, 0.1, 1), colors=heat.colors(length(colorcut)), textcol="black", marker, which="D'", distance, \dots) LDtable(x, colorcut=c(0,0.01, 0.025, 0.5, 0.1, 1), colors=heat.colors(length(colorcut)), textcol="black", digits=3, show.all=FALSE, which=c("D", "D'", "r", "X^2", "P-value", "n"), colorize="P-value", cex, \dots) LDplot(x, digits=3, marker, distance, which=c("D", "D'", "r", "X^2", "P-value", "n", " "), \dots ) } \arguments{ \item{x,object}{LD or LD.data.frame object} \item{digits}{Number of significant digits to display} \item{which}{Name(s) of LD information items to be displayed} \item{rowsep}{Separator between rows of data, use \code{NULL} for no separator.} \item{colorcut}{P-value cutoffs points for colorizing LDtable} \item{colors}{Colors for each P-value cutoff given in \code{colorcut} for LDtable} \item{textcol}{Color for text labels for LDtable} \item{marker}{Marker used as 'comparator' on LDplot. If omitted separate lines for each marker will be displayed} \item{distance}{Marker location, used for locating of markers on LDplot.} \item{show.all}{If TRUE, show all rows/columns of matrix. Otherwise omit completely blank rows/columns.} \item{colorize}{LD parameter used for determining table cell colors} \item{cex}{Scaling factor for table text. If absent, text will be scaled to fit within the table cells.} \item{\dots}{Optional arguments (\code{plot.LD.data.frame} passes these to \code{LDtable} and \code{LDplot})} } %\details{ %} \value{ None. } %\references{ ~put references to the literature/web site here ~ } \author{ Gregory R. Warnes \email{greg@warnes.net} } \seealso{ \code{LD}, \code{genotype}, \code{HWE.test} } \examples{ g1 <- genotype( c('T/A', NA, 'T/T', NA, 'T/A', NA, 'T/T', 'T/A', 'T/T', 'T/T', 'T/A', 'A/A', 'T/T', 'T/A', 'T/A', 'T/T', NA, 'T/A', 'T/A', NA) ) g2 <- genotype( c('C/A', 'C/A', 'C/C', 'C/A', 'C/C', 'C/A', 'C/A', 'C/A', 'C/A', 'C/C', 'C/A', 'A/A', 'C/A', 'A/A', 'C/A', 'C/C', 'C/A', 'C/A', 'C/A', 'A/A') ) g3 <- genotype( c('T/A', 'T/A', 'T/T', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/A', 'T/T', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/T') ) data <- makeGenotypes(data.frame(g1,g2,g3)) # Compute & display LD for one marker pair ld <- LD(g1,g2) print(ld) # Compute LD table for all 3 genotypes ldt <- LD(data) # display the results print(ldt) # textual display LDtable(ldt) # graphical color-coded table LDplot(ldt, distance=c(124, 834, 927)) # LD plot vs distance # more markers makes prettier plots! data <- list() nobs <- 1000 ngene <- 20 s <- seq(0,1,length=ngene) a1 <- a2 <- matrix("", nrow=nobs, ncol=ngene) for(i in 1:length(s) ) { rallele <- function(p) sample( c("A","T"), 1, p=c(p, 1-p)) if(i==1) { a1[,i] <- sample( c("A","T"), 1000, p=c(0.5,0.5), replace=TRUE) a2[,i] <- sample( c("A","T"), 1000, p=c(0.5,0.5), replace=TRUE) } else { p1 <- pmax( pmin( 0.25 + s[i] * as.numeric(a1[,i-1]=="A"),1 ), 0 ) p2 <- pmax( pmin( 0.25 + s[i] * as.numeric(a2[,i-1]=="A"),1 ), 0 ) a1[,i] <- sapply(p1, rallele ) a2[,i] <- sapply(p2, rallele ) } data[[paste("G",i,sep="")]] <- genotype(a1[,i],a2[,i]) } data <- data.frame(data) data <- makeGenotypes(data) ldt <- LD(data) plot(ldt, digits=2, marker=19) # do LDtable & LDplot on in a single # graphics window } \keyword{misc} genetics/man/plot.genotype.Rd0000644000176000001440000000157511522137021015756 0ustar ripleyusers\name{plot.genotype} \alias{plot.genotype} \title{Plot genotype object} \description{ \code{plot.genotype} can plot genotype or allele frequency of a genotype object. } \usage{ \method{plot}{genotype}(x, type=c("genotype", "allele"), what=c("percentage", "number"), ...) } \arguments{ \item{x}{genotype object, as genotype.} \item{type}{plot "genotype" or "allele" frequency, as character.} \item{what}{show "percentage" or "number", as character} \item{\dots}{Optional arguments for \code{barplot}.} } \value{ The same as in \code{barplot}. } \author{ Gregor Gorjanc } \seealso{ \code{\link{genotype}}, \code{\link{barplot}} } \examples{ set <- c("A/A", "A/B", "A/B", "B/B", "B/B", "B/B", "B/B", "B/C", "C/C", "C/C") set <- genotype(set, alleles=c("A", "B", "C"), reorder="yes") plot(set) plot(set, type="allele", what="number") } \keyword{hplot} genetics/man/order.genotype.Rd0000644000176000001440000001103411522137021016102 0ustar ripleyusers% order.genotype.Rd %-------------------------------------------------------------------------- % What: Order/sort genotype man page % Time-stamp: <2007-07-20 03:11:39 ggorjan> %-------------------------------------------------------------------------- \name{order.genotype} \alias{order} \alias{order.genotype} \alias{sort.genotype} \alias{genotypeOrder} \alias{genotypeOrder<-} \concept{order.haplotype} \concept{sort.haplotype} \title{Order/sort genotype/haplotype object} \description{Order/sort genotype or haplotype object according to order of allele names or genotypes} \usage{ \method{order}{genotype}(..., na.last=TRUE, decreasing=FALSE, alleleOrder=allele.names(x), genotypeOrder=NULL) \method{sort}{genotype}(x, decreasing=FALSE, na.last=NA, ..., alleleOrder=allele.names(x), genotypeOrder=NULL) genotypeOrder(x) genotypeOrder(x) <- value } \arguments{ \item{\ldots}{genotype or haplotype in \code{order} method; not used for \code{sort} method} \item{x}{genotype or haplotype in \code{sort} method} \item{na.last}{as in default \code{\link{order}} or \code{\link{sort}}} \item{decreasing}{as in default \code{\link{order}} or \code{\link{sort}}} \item{alleleOrder}{character, vector of allele names in wanted order} \item{genotypeOrder}{character, vector of genotype/haplotype names in wanted order} \item{value}{the same as in argument \code{order.genotype}} } \value{The same as in \code{order} or \code{sort}} \details{ Argument \code{genotypeOrder} can be usefull, when you want that some genotypes appear "together", whereas they are not "together" by allele order. Both methods (\code{order} and \code{sort}) work with genotype and haplotype classes. If \code{alleleOrder} is given, \code{genotypeOrder} has no effect. Genotypes/haplotypes, with missing alleles in \code{alleleOrder} are treated as \code{NA} and ordered according to \code{\link{order}} arguments related to \code{NA} values. In such cases a warning is issued ("Found data values not matching specified alleles. Converting to NA.") and can be safely ignored. Genotypes present in \code{x}, but not specified in \code{genotypeOrder}, are also treated as \code{NA}. Value of \code{genotypeOrder} such as "B/A" matches also "A/B" in case of genotypes. Only unique values in argument \code{alleleOrder} or \code{genotypeOrder} are used i.e. first occurrence prevails. } \author{Gregor Gorjanc} \seealso{ \code{\link{genotype}}, \code{\link{allele.names}}, \code{\link{order}}, and \code{\link{sort}} } \examples{ x <- c("C/C", "A/C", "A/A", NA, "C/B", "B/A", "B/B", "B/C", "A/C") alleles <- c("A", "B", "C") g <- genotype(x, alleles=alleles, reorder="yes") ## "C/C" "A/C" "A/A" NA "B/C" "A/B" "B/B" "B/C" "A/C" h <- haplotype(x, alleles=alleles) ## "C/C" "A/C" "A/A" NA "C/B" "B/A" "B/B" "B/C" "A/C" ## --- Standard usage --- sort(g) ## "A/A" "A/B" "A/C" "A/C" "B/B" "B/C" "B/C" "C/C" NA sort(h) ## "A/A" "A/C" "A/C" "B/A" "B/B" "B/C" "C/B" "C/C" NA ## --- Reversed order of alleles --- sort(g, alleleOrder=c("B", "C", "A")) ## "B/B" "B/C" "B/C" "A/B" "C/C" "A/C" "A/C" "A/A" NA ## note that A/B comes after B/C since it is treated as B/A; ## order of alleles (not in alleleOrder!) does not matter for a genotype sort(h, alleleOrder=c("B", "C", "A")) ## "B/B" "B/C" "B/A" "C/B" "C/C" "A/C" "A/C" "A/A" NA ## --- Missing allele(s) in alleleOrder --- sort(g, alleleOrder=c("B", "C")) ## "B/B" "B/C" "B/C" "C/C" "A/C" "A/A" NA "A/B" "A/C" sort(g, alleleOrder=c("B")) ## "B/B" "C/C" "A/C" "A/A" NA "B/C" "A/B" "B/C" "A/C" ## genotypes with missing allele are treated as NA sort(h, alleleOrder=c("B", "C")) ## "B/B" "B/C" "C/B" "C/C" "A/C" "A/A" NA "B/A" "A/C" sort(h, alleleOrder=c("B")) ## "B/B" "C/C" "A/C" "A/A" NA "C/B" "B/A" "B/C" "A/C" ## --- Use of genotypeOrder --- sort(g, genotypeOrder=c("A/A", "C/C", "B/B", "A/B", "A/C", "B/C")) ## "A/A" "C/C" "B/B" "A/B" "A/C" "A/C" "B/C" "B/C" NA sort(h, genotypeOrder=c("A/A", "C/C", "B/B", "A/C", "C/B", "B/A", "B/C")) ## "A/A" "C/C" "B/B" "A/C" "A/C" "C/B" "B/A" "B/C" NA ## --- Missing genotype(s) in genotypeOrder --- sort(g, genotypeOrder=c( "C/C", "A/B", "A/C", "B/C")) ## "C/C" "A/B" "A/C" "A/C" "B/C" "B/C" "A/A" NA "B/B" sort(h, genotypeOrder=c( "C/C", "A/B", "A/C", "B/C")) ## "C/C" "A/C" "A/C" "B/C" "A/A" NA "C/B" "B/A" "B/B" } \keyword{manip} \keyword{misc} %-------------------------------------------------------------------------- % order.genotype.Rd ends heregenetics/man/makeGenotypes.Rd0000644000176000001440000001220511522137670015764 0ustar ripleyusers% $Id: makeGenotypes.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{makeGenotypes} \alias{makeGenotypes} \alias{makeHaplotypes} \title{Convert columns in a dataframe to genotypes or haplotypes} \description{ Convert columns in a dataframe to genotypes or haplotypes. } \usage{ makeGenotypes(data, convert, sep = "/", tol = 0.5, ..., method=as.genotype) makeHaplotypes(data, convert, sep = "/", tol = 0.9, ...) } \arguments{ \item{data}{Dataframe containing columns to be converted} \item{convert}{Vector or list of pairs specifying which columns contain genotype/haplotype data. See below for details.} \item{sep}{Genotype separator} \item{tol}{See below.} \item{\dots}{Optional arguments to as.genotype function} \item{method}{Function used to perform the conversion.} } \details{ The functions makeGenotypes and makeHaplotypes allow the conversion of all of the genetic variables in a dataset to genotypes or haplotypes in a single step. The parameter \code{convert} may be missing, a vector of column names, indexes or true/false indictators, or a list of column name or index pairs. When the argument \code{convert} is not provided, the function will look for columns where at least \code{tol}*100\% of the records contain the separator character \code{sep} ('/' by default). These columns will then be assumed to contain both of the genotype/haplotype alleles and will be converted in-place to genotype variables. When the argument \code{convert} is a vector of column names, indexes or true/false indictators, the corresponding columns will be assumed to contain both of the genotype/haplotype alleles and will be converted in-place to genotype variables. When the argument \code{convert} is a list containing column name or index pairs, the two elements of each pair will be assumed to contain the individual alleles of a genotype/haplotype. The first column specified in each pair will be replaced with the new genotype/haplotype variable named \code{name1 + sep + name2}. The second column will be removed. Note that the \code{method} argument may be used to supply a non-standard conversion function, such as \code{as.genotype.allele.count}, which converts from [0,1,2] to ['A/A','A/B','A/C'] (or the specified allele names). See the example below. } \value{ Dataframe containing converted genotype/haplotype variables. All other variables will be unchanged. } \author{ Gregory R. Warnes \email{greg@warnes.net } } \seealso{ \code{\link{genotype}} } \examples{ \dontrun{ # common case data <- read.csv(file="genotype_data.csv") data <- makeGenotypes(data) } # Create a test data set where there are several genotypes in columns # of the form "A/T". test1 <- data.frame(Tmt=sample(c("Control","Trt1","Trt2"),20, replace=TRUE), G1=sample(c("A/T","T/T","T/A",NA),20, replace=TRUE), N1=rnorm(20), I1=sample(1:100,20,replace=TRUE), G2=paste(sample(c("134","138","140","142","146"),20, replace=TRUE), sample(c("134","138","140","142","146"),20, replace=TRUE), sep=" / "), G3=sample(c("A /T","T /T","T /A"),20, replace=TRUE), comment=sample(c("Possible Bad Data/Lab Error",""),20, rep=TRUE) ) test1 # now automatically convert genotype columns geno1 <- makeGenotypes(test1) geno1 # Create a test data set where there are several haplotypes with alleles # in adjacent columns. test2 <- data.frame(Tmt=sample(c("Control","Trt1","Trt2"),20, replace=TRUE), G1.1=sample(c("A","T",NA),20, replace=TRUE), G1.2=sample(c("A","T",NA),20, replace=TRUE), N1=rnorm(20), I1=sample(1:100,20,replace=TRUE), G2.1=sample(c("134","138","140","142","146"),20, replace=TRUE), G2.2=sample(c("134","138","140","142","146"),20, replace=TRUE), G3.1=sample(c("A ","T ","T "),20, replace=TRUE), G3.2=sample(c("A ","T ","T "),20, replace=TRUE), comment=sample(c("Possible Bad Data/Lab Error",""),20, rep=TRUE) ) test2 # specifly the locations of the columns to be paired for haplotypes makeHaplotypes(test2, convert=list(c("G1.1","G1.2"),6:7,8:9)) # Create a test data set where the data is coded as numeric allele # counts (0-2). test3 <- data.frame(Tmt=sample(c("Control","Trt1","Trt2"),20, replace=TRUE), G1=sample(c(0:2,NA),20, replace=TRUE), N1=rnorm(20), I1=sample(1:100,20,replace=TRUE), G2=sample(0:2,20, replace=TRUE), comment=sample(c("Possible Bad Data/Lab Error",""),20, rep=TRUE) ) test3 # specifly the locations of the columns, and a non-standard conversion makeGenotypes(test3, convert=c('G1','G2'), method=as.genotype.allele.count) } \keyword{ misc } genetics/man/locus.Rd0000644000176000001440000001250711522137670014303 0ustar ripleyusers% $Id: locus.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{locus} \alias{locus} \alias{gene} \alias{marker} \alias{is.gene} \alias{is.locus} \alias{is.marker} \alias{print.gene} \alias{print.locus} \alias{print.marker} \alias{as.character.locus} \alias{as.character.gene} \alias{as.character.marker} \alias{getlocus} \alias{getmarker} \alias{getgene} \alias{locus<-} \alias{marker<-} \alias{gene<-} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Create and Manipulate Locus, Gene, and Marker Objects} \description{ \code{locus}, \code{gene}, and \code{marker} create objects to store information, respectively, about genetic loci, genes, and markers. \code{is.locus}, \code{is.gene}, and \code{ismarker} test whether an object is a member of the respective class. \code{as.character.locus}, \code{as.character.gene}, \code{as.character.marker} return a character string containing a compact encoding the object. \code{getlocus}, \code{getgene}, \code{getmarker} extract locus data (if present) from another object. \code{locus<-}, \code{marker<-}, and \code{gene<-} adds locus data to an object. } \usage{ locus(name, chromosome, arm=c("p", "q", "long", "short", NA), index.start, index.end=NULL) gene(name, chromosome, arm=c("p", "q", "long", "short"), index.start, index.end=NULL) marker(name, type, locus.name, bp.start, bp.end = NULL, relative.to = NULL, ...) is.locus(x) is.gene(x) is.marker(x) \method{as.character}{locus}(x, ...) \method{as.character}{gene}(x, ...) \method{as.character}{marker}(x, ...) getlocus(x, ...) locus(x) <- value marker(x) <- value gene(x) <- value } \arguments{ \item{name}{character string giving locus, gene, or marker name} \item{chromosome}{integer specifying chromosome number (1:23 for humans).} \item{arm}{character indicating long or short arm of the chromosome. Long is be specified by "long" or "p". Short is specified by "short" or "q".} \item{index.start}{integer specifying location of start of locus or gene on the chromosome. } \item{index.end}{optional integer specifying location of end of locus or gene on the chromosome. } \item{type}{character string indicating marker type, e.g. "SNP"} \item{locus.name}{either a character string giving the name of the locus or gene (other details may be specified using \code{...}) or a \code{locus} or \code{gene} object.} \item{bp.start}{start location of marker, in base pairs} \item{bp.end}{end location of marker, in base pairs (optional)} \item{relative.to}{location (optional) from which \code{bp.start} and \code{bp.end} are calculated. } \item{...}{parameters for \code{locus} used to fill in additional details on the locus or gene within which the marker is located. } \item{x}{an object of class \code{locus}, \code{gene}, or \code{marker}, or (for \code{getlocus}, \code{locus<-}, \code{marker<-}, and \code{gene<-}) an object that may contain a locus attribute or field, notably a \code{genotype} object.} \item{value}{\code{locus}, \code{marker}, or \code{gene} object} } %\details{ % ~~ If necessary, more details than the __description__ above ~~ %} \value{ Object of class \code{locus} and \code{gene}are lists with the elements: \item{name}{character string giving locus, gene, or marker name} \item{chromosome}{integer specifying chromosome number (1:23 for humans).} \item{arm}{character indicating long or short arm of the chromosome. Long is be specified by "long" or "p". Short is specified by "short" or "q".} \item{index.start}{integer specifying location of start of locus or gene on the chromosome. } \item{index.end}{optional integer specifying location of end of locus or gene on the chromosome. } Objects of class \code{marker} add the additional fields: \item{marker.name}{character string giving the name of the marker} \item{bp.start}{start location of marker, in base pairs} \item{bp.end}{end location of marker, in base pairs (optional)} \item{relative.to}{location (optional) from which \code{bp.start} and \code{bp.end} are calculated. } } %\references{ ~put references to the literature/web site here ~ } \author{Gregory R. Warnes \email{greg@warnes.net} } \seealso{ \code{\link{genotype}}, } \examples{ ar2 <- gene("AR2",chromosome=7,arm="q",index.start=35) ar2 par <- locus(name="AR2 Psedogene", chromosome=1, arm="q", index.start=32, index.end=42) par c109t <- marker(name="C-109T", type="SNP", locus.name="AR2", chromosome=7, arm="q", index.start=35, bp.start=-109, relative.to="start of coding region") c109t c109t <- marker(name="C-109T", type="SNP", locus=ar2, bp.start=-109, relative.to="start of coding region") c109t example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data, locus=ar2) g1 getlocus(g1) summary(g1) HWE.test(g1) g2 <- genotype(example.data, locus=c109t) summary(g2) getlocus(g2) heterozygote(g2) homozygote(g1) allele(g1,1) carrier(g1,"I") heterozygote(g2) } \keyword{ misc } %%\keyword{genetics}%-- one or more ... genetics/man/LD.Rd0000644000176000001440000001051011522137670013445 0ustar ripleyusers% $Id: LD.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{LD} \alias{LD} \alias{LD.genotype} \alias{LD.data.frame} \title{Pairwise linkage disequilibrium between genetic markers.} \description{ Compute pairwise linkage disequilibrium between genetic markers } \usage{ LD(g1, ...) \method{LD}{genotype}(g1,g2,...) \method{LD}{data.frame}(g1,...) } \arguments{ \item{g1}{ genotype object or dataframe containing genotype objects } \item{g2}{ genotype object (ignored if g1 is a dataframe) } \item{\dots}{ optional arguments (ignored) } } \details{ Linkage disequilibrium (LD) is the non-random association of marker alleles and can arise from marker proximity or from selection bias. \code{LD.genotype} estimates the extent of LD for a single pair of genotypes. \code{LD.data.frame} computes LD for all pairs of genotypes contained in a data frame. Before starting, \code{LD.data.frame} checks the class and number of alleles of each variable in the dataframe. If the data frame contains non-genotype objects or genotypes with more or less than 2 alleles, these will be omitted from the computation and a warning will be generated. Three estimators of LD are computed: \itemize{ \item{D}{ raw difference in frequency between the observed number of AB pairs and the expected number: \deqn{% D = p_{AB} - p_A p_B % }{% D = p(AB) - p(A)*p(B) % } } \item{D'}{ scaled D spanning the range [-1,1] \deqn{D' = \frac{D}{D_{max} } }{D' = D / Dmax} where, if D > 0: \deqn{% D_{max} = \min( p_A p_b, p_a p_B ) % }{% Dmax = min( p(A)p(b), p(a)p(B) ) % } or if D < 0: \deqn{% D_{max} = \max{ -p_A p_B, -p_a p_b } % }{% Dmax = max( -p(A)p(B), -p(a)p(b) ) % } } \item{r}{ correlation coefficient between the markers \deqn{% r = \frac{-D}{\sqrt( p_A * p_a * p_B * p_b )} % }{% r = -D / sqrt( p(A) * p(a) * p(B) * p(b) ) % } } } where \itemize{ \item{-}{ \eqn{p_A}{p(A)} is defined as the observed probability of allele 'A' for marker 1, } \item{-}{ \eqn{p_a=1-p_A}{p(a) = 1-p(A)} is defined as the observed probability of allele 'a' for marker 1, } \item{-}{\eqn{p_B}{p(B)} is defined as the observed probability of allele 'B' for marker 2, and } \item{-}{\eqn{p_b=1-p_B}{p(b) = 1- p(B)} is defined as the observed probability of allele 'b' for marker 2, and } \item{-}{\eqn{p_{AB}}{p(AB)} is defined as the probability of the marker allele pair 'AB'. } } For genotype data, AB/ab cannot be distinguished from aB/Ab. Consequently, we estimate \eqn{p_{AB}}{p(AB)} using maximum likelihood and use this value in the computations. } \value{ \code{LD.genotype} returns a 5 element list: \item{call}{the matched call} \item{D}{Linkage disequilibrium estimate} \item{Dprime }{Scaled linkage disequilibrium estimate} \item{corr}{Correlation coefficient} \item{nobs}{Number of observations} \item{chisq}{Chi-square statistic for linkage equilibrium (i.e., D=D'=corr=0)} \item{p.value}{Chi-square p-value for marker independence} \code{LD.data.frame} returns a list with the same elements, but each element is a matrix where the upper off-diagonal elements contain the estimate for the corresponding pair of markers. The other matrix elements are \code{NA}. } %\references{ ~put references to the literature/web site here ~ } \author{ Gregory R. Warnes \email{greg@warnes.net} } \seealso{ \code{\link{genotype}}, \code{\link{HWE.test}} } \examples{ g1 <- genotype( c('T/A', NA, 'T/T', NA, 'T/A', NA, 'T/T', 'T/A', 'T/T', 'T/T', 'T/A', 'A/A', 'T/T', 'T/A', 'T/A', 'T/T', NA, 'T/A', 'T/A', NA) ) g2 <- genotype( c('C/A', 'C/A', 'C/C', 'C/A', 'C/C', 'C/A', 'C/A', 'C/A', 'C/A', 'C/C', 'C/A', 'A/A', 'C/A', 'A/A', 'C/A', 'C/C', 'C/A', 'C/A', 'C/A', 'A/A') ) g3 <- genotype( c('T/A', 'T/A', 'T/T', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/A', 'T/T', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/T', 'T/A', 'T/A', 'T/A', 'T/T') ) # Compute LD on a single pair LD(g1,g2) # Compute LD table for all 3 genotypes data <- makeGenotypes(data.frame(g1,g2,g3)) LD(data) } \keyword{misc} genetics/man/HWE.test.Rd0000644000176000001440000001006311755556460014564 0ustar ripleyusers% : HWE.test.Rd,v 1.13 2004/05/25 19:40:02 warnesgr Exp $ \name{HWE.test} \alias{HWE.test} \alias{HWE.test.genotype} \alias{HWE.test.data.frame} \alias{print.HWE.test} \title{Estimate Disequilibrium and Test for Hardy-Weinberg Equilibrium} \description{ Estimate disequilibrium parameter and test the null hypothesis that Hardy-Weinberg equilibrium holds. } \usage{ HWE.test(x, ...) \method{HWE.test}{genotype}(x, exact = nallele(x)==2, simulate.p.value=!exact, B=10000, conf=0.95, ci.B=1000, ... ) \method{HWE.test}{data.frame}(x, ..., do.Allele.Freq=TRUE, do.HWE.test=TRUE) \method{print}{HWE.test}(x, show=c("D","D'","r","table"), ...) } \arguments{ \item{x}{genotype or haplotype object.} \item{exact}{a logical value indicated whether the p-value should be computed using the exact method, which is only available for 2 allele genotypes.} \item{simulate.p.value}{a logical value indicating whether the p-value should be computed using simulation instead of using the \eqn{\chi^2}{Chi-Square} approximation. Defaults to \code{TRUE}.} \item{B}{Number of simulation iterations to use when \code{simulate.p.value=TRUE}. Defaults to 10000.} \item{conf}{Confidence level to use when computing the confidence level for D-hat. Defaults to 0.95, should be in (0,1). } \item{ci.B}{Number of bootstrap iterations to use when computing the confidence interval. Defaults to 1000.} % \item{ci.type}{Method of calculating the confidence interval using the % bootstrap sample. Defaults to \code{"basic"}. See % \code{\link[boot]{boot.ci}} for details.} \item{show}{a character vector containing the names of HWE test statistics to display from the set of "D", "D'", "r", and "table".} \item{...}{ optional parameters passed to \code{HWE.test} (data.frame method) or \code{chisq.test} (base method).} \item{do.Allele.Freq}{logicial indication whether to summarize allele frequencies.} \item{do.HWE.test}{logicial indication whether to perform HWE tests} } \details{ HWE.test calls \code{\link{diseq}} to computes the Hardy-Weinberg (dis)equilibrium statistics D, D', and r (correlation coefficient). Next it calls \code{\link{diseq.ci}} to compute a bootstrap confidence interval for these estimates. Finally, it calls \code{\link{chisq.test}} to compute a p-value for Hardy-Weinberg Equilibrium using a simulation/permutation method. Using bootstrapping for the confidence interval and simulation for the p-value avoids reliance on the assumptions the underlying Chi-square approximation. This is particularly important when some allele pairs have small counts. For details on the definition of D, D', and r, see the help page for \code{\link{diseq}}. } \value{ An object of class \code{HWE.test} with components \item{diseq}{A \code{\link{diseq}} object providing details on the disequilibrium estimates.} \item{ci}{A \code{\link{diseq.ci}} object providing details on the bootstrap confidence intervals for the disequilibrium estimates.} \item{test}{A \code{htest} object providing details on the permutation based Chi-square test.} \item{call}{function call used to creat this object.} \item{conf, B, ci.B, simulate.p.value}{values used for these arguments.} } \author{ Gregory R. Warnes \email{greg@warnes.net } } \seealso{ \code{\link{genotype}}, \code{\link{diseq}}, \code{\link{diseq.ci}}, \code{\link{HWE.chisq}}, \code{\link{HWE.exact}}, \code{\link[stats]{chisq.test}} } \examples{ \testonly{ set.seed(4657613) } ## Marker with two alleles: example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 HWE.test(g1) ## Compare with individual calculations: diseq(g1) diseq.ci(g1) HWE.chisq(g1) HWE.exact(g1) ## Marker with three alleles: A, C, and T three.data <- c(rep("A/A",16), rep("C/A",40), rep("C/T",40), rep("C/C",20), rep("T/T",6)) g3 <- genotype(three.data) g3 HWE.test(g3, ci.B=10000) } \keyword{ misc } %%\keyword{genetics} genetics/man/HWE.exact.Rd0000644000176000001440000000224711522137670014704 0ustar ripleyusers% $Id: HWE.exact.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{HWE.exact} \alias{HWE.exact} \title{Exact Test of Hardy-Weinberg Equilibrium for 2-Allele Markers} \description{ Exact test of Hardy-Weinberg Equilibrium for 2 Allele Markers. } \usage{ HWE.exact(x) } \arguments{ \item{x}{ Genotype object } } %\details{ %} \value{ Object of class 'htest'. } \references{ Emigh TH. (1980) "Comparison of tests for Hardy-Weinberg Equilibrium", Biometrics, 36, 627-642. } \author{ David Duffy \email{davidD@qimr.edu.au} with modifications by Gregory R. Warnes \email{greg@warnes.net} } \note{ This function only works for genotypes with exactly 2 alleles.} \seealso{ \code{\link{HWE.chisq}}, \code{\link{HWE.test}}, \code{\link{diseq}}, \code{\link{diseq.ci}} } \examples{ example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 HWE.exact(g1) # compare with HWE.chisq(g1) \testonly{ set.seed(465764) } g2 <- genotype(sample( c("A","C"), 100, p=c(100,10), rep=TRUE), sample( c("A","C"), 100, p=c(100,10), rep=TRUE) ) HWE.exact(g2) } \keyword{ misc } %%\keyword{genetics} genetics/man/HWE.chisq.Rd0000644000176000001440000000443311522137021014674 0ustar ripleyusers% $Id: HWE.chisq.Rd 1344 2011-01-17 19:13:09Z warnes $ \name{HWE.chisq} \alias{HWE.chisq} \alias{HWE.chisq.genotype} \title{Perform Chi-Square Test for Hardy-Weinberg Equilibrium} \description{ Test the null hypothesis that Hardy-Weinberg equilibrium holds using the Chi-Square method. } \usage{ HWE.chisq(x, ...) \method{HWE.chisq}{genotype}(x, simulate.p.value=TRUE, B=10000, ...) } \arguments{ \item{x}{genotype or haplotype object.} \item{simulate.p.value}{a logical value indicating whether the p-value should be computed using simulation instead of using the \eqn{\chi^2}{Chi-Square} approximation. Defaults to \code{TRUE}.} \item{B}{Number of simulation iterations to use when \code{simulate.p.value=TRUE}. Defaults to 10000.} \item{...}{ optional parameters passed to \code{chisq.test}} } \details{ This function generates a 2-way table of allele counts, then calls \code{\link{chisq.test}} to compute a p-value for Hardy-Weinberg Equilibrium. By default, it uses an unadjusted Chi-Square test statistic and computes the p-value using a simulation/permutation method. When \code{simulate.p.value=FALSE}, it computes the test statistic using the Yates continuity correction and tests it against the asymptotic Chi-Square distribution with the approproate degrees of freedom. Note: The Yates continuty correction is applied *only* when \code{simulate.p.value=FALSE}, so that the reported test statistics when \code{simulate.p.value=FALSE} and \code{simulate.p.value=TRUE} will differ. } \value{ An object of class \code{htest}. } \seealso{ \code{\link{HWE.exact}}, \code{\link{HWE.test}}, \code{\link{diseq}}, \code{\link{diseq.ci}}, \code{\link{allele}}, \code{\link{chisq.test}}, \code{\link[boot]{boot}}, \code{\link[boot]{boot.ci}} } \examples{ \testonly{ set.seed(4657613) } example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 HWE.chisq(g1) # compare with HWE.exact(g1) # and HWE.test(g1) three.data <- c(rep("A/A",8), rep("C/A",20), rep("C/T",20), rep("C/C",10), rep("T/T",3)) g3 <- genotype(three.data) g3 HWE.chisq(g3, B=10000) } \keyword{ misc } %%\keyword{genetics} genetics/man/homozygote.Rd0000644000176000001440000000771411522137670015366 0ustar ripleyusers% $Id: homozygote.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{homozygote} \alias{homozygote} \alias{heterozygote} \alias{carrier} \alias{carrier.genotype} \alias{allele} \alias{allele.count} \alias{allele.names} \title{Extract Features of Genotype objects} \description{ \code{homozygote} creates an vector of logicals that are true when the alleles of the corresponding observation are the identical. \code{heterozygote } creates an vector of logicals that are true when the alleles of the corresponding observation differ. \code{carrier} create a logical vector or matrix of logicals indicating whether the specified alleles are present. \code{allele.count} returns the number of copies of the specified alleles carried by each observation. \code{allele} extract the specified allele(s) as a character vector or a 2 column matrix. \code{allele.names} extract the set of allele names. } \usage{ homozygote(x, allele.name, ...) heterozygote(x, allele.name, ...) carrier(x, allele.name, ...) \method{carrier}{genotype}(x, allele.name=allele.names(x), any=!missing(allele.name), na.rm=FALSE, ...) allele.count(x, allele.name=allele.names(x),any=!missing(allele.name), na.rm=FALSE) allele(x, which=c(1,2) ) allele.names(x) } \arguments{ \item{x}{ \code{genotype} object } \item{\dots}{ optional parameters (ignored) } \item{allele.name}{ character value or vector of allele names} \item{any}{ logical value. When \code{TRUE}, a single count or indicator is returned by combining the results for all of the elements of \code{allele}. If \code{FALSE} separate counts or indicators should be returned for each element of \code{allele}. Defaults to \code{FALSE} if \code{allele} is missing. Otherwise defaults to \code{TRUE}.} \item{na.rm}{ logical value indicating whether to remove missing values. When true, any \code{NA} values will be replaced by \code{0} or \code{FALSE} as appropriate. Defaults to \code{FALSE}.} \item{which}{ selects which allele to return. For first allele use \code{1}. For second allele use \code{2}. For both (the default) use \code{c(1,2)}.} } \details{ When the \code{allele.name} argument is given, heterozygote and homozygote return \code{TRUE} if \emph{exactly} one or both alleles, respectively, match the specified allele.name. } \value{ \code{homozygote} and \code{heterozygote } return a vector of logicals. \code{carrier} returns a logical vector if only one allele is specified, or if \code{any} is \code{TRUE}. Otherwise, it returns matrix of logicals with one row for each element of \code{allele}. \code{allele.count} returns a vector of counts if only one allele is specified, or if \code{any} is \code{TRUE}. Otherwise, it returns matrix of counts with one row for each element of \code{allele}. \code{allele} returns a character vector when one allele is specified. When 2 alleles are specified, it returns a 2 column character matrix. \code{allele.names} returns a character vector containing the set of allele names. } \author{ Gregory R. Warnes \email{greg@warnes.net} } \seealso{ \code{\link{genotype}}, \code{\link{HWE.test}}, % \code{\link{allele}}, % \code{\link{homozygote}}, % \code{\link{heterozygote}}, % \code{\link{carrier}}, \code{\link{summary.genotype}}, % \code{\link{allele.count}} \code{\link{locus}} \code{\link{gene}} \code{\link{marker}} } \examples{ example.data <- c("D/D","D/I","D/D","I/I","D/D","D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 heterozygote(g1) homozygote(g1) carrier(g1,"D") carrier(g1,"D",na.rm=TRUE) # get count of one allele allele.count(g1,"D") # get count of each allele allele.count(g1) # equivalent to allele.count(g1, c("D","I"), any=FALSE) # get combined count for both alleles allele.count(g1,c("I","D")) # get second allele allele(g1,2) # get both alleles allele(g1) } \keyword{ misc } %%\keyword{genetics}%-- one or more ... genetics/man/groupGenotype.Rd0000644000176000001440000001314511522137021016012 0ustar ripleyusers% groupGenotype.Rd %-------------------------------------------------------------------------- % What: Group genotype values man page % Time-stamp: <2007-07-21 12:02:09 ggorjan> %-------------------------------------------------------------------------- \name{groupGenotype} \alias{groupGenotype} \title{Group genotype values} \description{\code{groupGenotype} groups genotype or haplotype values according to given "grouping/mapping" information} \usage{ groupGenotype(x, map, haplotype=FALSE, factor=TRUE, levels=NULL, verbose=FALSE) } \arguments{ \item{x}{genotype or haplotype} \item{map}{list, mapping information, see details and examples} \item{haplotype}{logical, should values in a \code{map} be treated as haplotypes or genotypes, see details} \item{factor}{logical, should output be a factor or a character} \item{levels}{character, optional vector of level names if factor is produced (\code{factor=TRUE}); the default is to use the sort order of the group names in \code{map}} \item{verbose}{logical, print genotype names that match entries in the map - mainly used for debugging} } \value{A factor or character vector with genotypes grouped} \details{ Examples show how \code{map} can be constructed. This are the main points to be aware of: \itemize{ \item names of list components are used as new group names \item list components hold genotype names per each group \item genotype names can be specified directly i.e. "A/B" or abbreviated such as "A/*" or even "*/*", where "*" matches any possible allele, but read also further on \item all genotype names that are not specified can be captured with ".else" (note the dot!) \item genotype names that were not specified (and ".else" was not used) are changed to \code{NA} } \code{map} is inspected before grouping of genotypes is being done. The following steps are done during inspection: \itemize{ \item ".else" must be at the end (if not, it is moved) to match everything that has not yet been defined \item any specifications like "A/*", "*/A", or "*/*" are extended to all possible genotypes based on alleles in argument \code{alleles} - in case of \code{haplotype=FALSE}, "A/*" and "*/A" match the same genotypes \item since use of "*" and ".else" can cause duplicates along the whole map, duplicates are removed sequentially (first occurrence is kept) } Using ".else" or "*/*" at the end of the map produces the same result, due to removing duplicates sequentially. } \author{Gregor Gorjanc} \seealso{ \code{\link{genotype}}, \code{\link{haplotype}}, \code{\link{factor}}, and \code{\link{levels}} } \examples{ ## --- Setup --- x <- c("A/A", "A/B", "B/A", "A/C", "C/A", "A/D", "D/A", "B/B", "B/C", "C/B", "B/D", "D/B", "C/C", "C/D", "D/C", "D/D") g <- genotype(x, reorder="yes") ## "A/A" "A/B" "A/B" "A/C" "A/C" "A/D" "A/D" "B/B" "B/C" "B/C" "B/D" "B/D" ## "C/C" "C/D" "C/D" "D/D" h <- haplotype(x) ## "A/A" "A/B" "B/A" "A/C" "C/A" "A/D" "D/A" "B/B" "B/C" "C/B" "B/D" "D/B" ## "C/C" "C/D" "D/C" "D/D" ## --- Use of "A/A", "A/*" and ".else" --- map <- list("homoG"=c("A/A", "B/B", "C/C", "D/D"), "heteroA*"=c("A/B", "A/C", "A/D"), "heteroB*"=c("B/*"), "heteroRest"=".else") (tmpG <- groupGenotype(x=g, map=map, factor=FALSE)) (tmpH <- groupGenotype(x=h, map=map, factor=FALSE, haplotype=TRUE)) ## Show difference between genotype and haplotype treatment cbind(as.character(h), gen=tmpG, hap=tmpH, diff=!(tmpG == tmpH)) ## gen hap diff ## [1,] "A/A" "homoG" "homoG" "FALSE" ## [2,] "A/B" "heteroA*" "heteroA*" "FALSE" ## [3,] "B/A" "heteroA*" "heteroB*" "TRUE" ## [4,] "A/C" "heteroA*" "heteroA*" "FALSE" ## [5,] "C/A" "heteroA*" "heteroRest" "TRUE" ## [6,] "A/D" "heteroA*" "heteroA*" "FALSE" ## [7,] "D/A" "heteroA*" "heteroRest" "TRUE" ## [8,] "B/B" "homoG" "homoG" "FALSE" ## [9,] "B/C" "heteroB*" "heteroB*" "FALSE" ## [10,] "C/B" "heteroB*" "heteroRest" "TRUE" ## [11,] "B/D" "heteroB*" "heteroB*" "FALSE" ## [12,] "D/B" "heteroB*" "heteroRest" "TRUE" ## [13,] "C/C" "homoG" "homoG" "FALSE" ## [14,] "C/D" "heteroRest" "heteroRest" "FALSE" ## [15,] "D/C" "heteroRest" "heteroRest" "FALSE" ## [16,] "D/D" "homoG" "homoG" "FALSE" map <- list("withA"="A/*", "rest"=".else") groupGenotype(x=g, map=map, factor=FALSE) ## [1] "withA" "withA" "withA" "withA" "withA" "withA" "withA" "rest" "rest" ## [10] "rest" "rest" "rest" "rest" "rest" "rest" "rest" groupGenotype(x=h, map=map, factor=FALSE, haplotype=TRUE) ## [1] "withA" "withA" "rest" "withA" "rest" "withA" "rest" "rest" "rest" ## [10] "rest" "rest" "rest" "rest" "rest" "rest" "rest" ## --- Use of "*/*" --- map <- list("withA"="A/*", withB="*/*") groupGenotype(x=g, map=map, factor=FALSE) ## [1] "withA" "withA" "withA" "withA" "withA" "withA" "withA" "withB" "withB" ## [10] "withB" "withB" "withB" "withB" "withB" "withB" "withB" ## --- Missing genotype specifications produces NA's --- map <- list("withA"="A/*", withB="B/*") groupGenotype(x=g, map=map, factor=FALSE) ## [1] "withA" "withA" "withA" "withA" "withA" "withA" "withA" "withB" "withB" ## [10] "withB" "withB" "withB" NA NA NA NA groupGenotype(x=h, map=map, factor=FALSE, haplotype=TRUE) ## [1] "withA" "withA" "withB" "withA" NA "withA" NA "withB" "withB" ## [10] NA "withB" NA NA NA NA NA } \keyword{manip} \keyword{misc} %-------------------------------------------------------------------------- % groupGenotype.Rd ends heregenetics/man/gregorius.Rd0000644000176000001440000000626611522137670015171 0ustar ripleyusers% $Id: gregorius.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{gregorius} \alias{gregorius} \title{Probability of Observing All Alleles with a Given Frequency in a Sample of a Specified Size.} \description{ Probability of observing all alleles with a given frequency in a sample of a specified size. } \usage{ gregorius(freq, N, missprob, tol = 1e-10, maxN = 10000, maxiter=100, showiter = FALSE) } \arguments{ \item{freq}{(Minimum) Allele frequency (required)} \item{N}{Number of sampled genotypes} \item{missprob}{Desired maximum probability of failing to observe an allele.} \item{tol}{Omit computation for terms which contribute less than this value.} \item{maxN}{Largest value to consider when searching for N.} \item{maxiter}{Maximum number of iterations to use when searching for N.} \item{showiter}{Boolean flag indicating whether to show the iterations performed when searching for N.} } \details{ If \code{freq} and \code{N} are provided, but \code{missprob} is omitted, this function computes the probability of failing to observe all alleles with true underlying frequency \code{freq} when \code{N} diploid genotypes are sampled. This is accomplished using the sum provided in Corollary 2 of Gregorius (1980), omitting terms which contribute less than \code{tol} to the result. When \code{freq} and \code{missprob} are provide, but \code{N} is omitted. A binary search on the range of [1,\code{maxN}] is performed to locate the smallest sample size, \code{N}, for which the probability of failing to observe all alleles with true underlying frequency \code{freq} is at most \code{missprob}. In this case, \code{maxiter} specifies the largest number of iterations to use in the binary search, and \code{showiter} controls whether the iterations of the search are displayed. } \value{ A list containing the following values: \item{call}{ Function call used to generate this object.} \item{method}{ One of the strings, "Compute missprob given N and freq", or "Determine minimal N given missprob and freq", indicating which type of computation was performed.} \item{retval$freq}{ Specified allele frequency.} \item{retval$N}{ Specified or computed sample size. } \item{retval$missprob}{ Computed probability of failing to observe all of the alleles with frequency \code{freq}. } } \references{ Gregorius, H.R. 1980. The probability of losing an allele when diploid genotypes are sampled. Biometrics 36, 643-652. } \note{ This code produces sample sizes that are slightly larger than those given in table 1 of Gregorius (1980). This appears to be due to rounding of the computed \code{missprob}s by the authors of that paper. } \author{ Code submitted by David Duffy \email{davidD@qumr.edu.au}, substantially enhanced by Gregory R. Warnes \email{greg@warnes.net}. } %\seealso{ ~~objects to SEE ALSO as \code{\link{~~fun~~}}, ~~~ } \examples{ # Compute the probability of missing an allele with frequency 0.15 when # 20 genotypes are sampled: gregorius(freq=0.15, N=20) # Determine what sample size is required to observe all alleles with true # frequency 0.15 with probability 0.95 gregorius(freq=0.15, missprob=1-0.95) } \keyword{misc} genetics/man/genotype.Rd0000644000176000001440000002465212012457530015007 0ustar ripleyusers% $Id: genotype.Rd 1353 2012-08-14 14:23:17Z warnes $ \name{genotype} \alias{genotype} \alias{haplotype} \alias{is.genotype} \alias{is.haplotype} \alias{as.genotype} \alias{as.haplotype} %% \alias{print.genotype} \alias{==.genotype} \alias{==.haplotype} \alias{\%in\%} \alias{\%in\%.default} \alias{\%in\%.genotype} \alias{\%in\%.haplotype} \alias{[.genotype} \alias{[.haplotype} \alias{[<-.genotype} \alias{[<-.haplotype} \alias{heterozygote.genotype} \alias{homozygote.genotype} \alias{print.allele.count} \alias{print.allele.genotype} \alias{allele.count.genotype} %\alias{allele.genotype} %\alias{allele.names} \alias{as.genotype.allele.count} \alias{as.genotype.character} \alias{as.genotype.default} \alias{as.genotype.factor} \alias{as.genotype.genotype} \alias{as.genotype.haplotype} \alias{as.genotype.table} \alias{nallele} \title{Genotype or Haplotype Objects.} \description{ \code{genotype} creates a genotype object. \code{haplotype} creates a haplotype object. \code{is.genotype} returns \code{TRUE} if \code{x} is of class \code{genotype} \code{is.haplotype} returns \code{TRUE} if \code{x} is of class \code{haplotype} \code{as.genotype} attempts to coerce its argument into an object of class \code{genotype}. \code{as.genotype.allele.count} converts allele counts (0,1,2) into genotype pairs ("A/A", "A/B", "B/B"). \code{as.haplotype} attempts to coerce its argument into an object of class \code{haplotype}. \code{nallele} returns the number of alleles in an object of class \code{genotype}. } \usage{ genotype(a1, a2=NULL, alleles=NULL, sep="/", remove.spaces=TRUE, reorder = c("yes", "no", "default", "ascii", "freq"), allow.partial.missing=FALSE, locus=NULL, genotypeOrder=NULL) haplotype(a1, a2=NULL, alleles=NULL, sep="/", remove.spaces=TRUE, reorder="no", allow.partial.missing=FALSE, locus=NULL, genotypeOrder=NULL) is.genotype(x) is.haplotype(x) as.genotype(x, ...) \method{as.genotype}{allele.count}(x, alleles=c("A","B"), \dots ) as.haplotype(x, ...) \method{print}{genotype}(x, \dots) nallele(x) } \arguments{ \item{x}{ either an object of class \code{genotype} or \code{haplotype} or an object to be converted to class \code{genotype} or \code{haplotype}.} \item{a1,a2}{ vector(s) or matrix containing two alleles for each individual. See details, below.} \item{alleles}{ names (and order if \code{reorder="yes"}) of possible alleles.} \item{sep}{ character separator or column number used to divide alleles when \code{a1} is a vector of strings where each string holds both alleles. See below for details.} \item{remove.spaces}{ logical indicating whether spaces and tabs will be removed from a1 and a2 before processing.} \item{reorder}{how should alleles within an individual be reordered. If \code{reorder="no"}, use the order specified by the alleles parameter. If \code{reorder="freq"} or \code{reorder="yes"}, sort alleles within each individual by observed frequency. If \code{reorder="ascii"}, reorder alleles in ASCII order (alphabetical, with all upper case before lower case). The default value for \code{genotype} is \code{"freq"}. The default value for \code{haplotype} is \code{"no"}. } \item{allow.partial.missing}{logical indicating whether one allele is permitted to be missing. When set to \code{FALSE} both alleles are set to \code{NA} when either is missing.} \item{locus}{ object of class locus, gene, or marker, holding information about the source of this genotype.} \item{genotypeOrder}{character, vector of genotype/haplotype names so that further functions can sort genotypes/haplotypes in wanted order} \item{...}{optional arguments} } \details{ Genotype objects hold information on which gene or marker alleles were observed for different individuals. For each individual, two alleles are recorded. The genotype class considers the stored alleles to be unordered, i.e., "C/T" is equivalent to "T/C". The haplotype class considers the order of the alleles to be significant so that "C/T" is distinct from "T/C". When calling \code{genotype} or \code{haplotype}: \itemize{ \item If only \code{a1} is provided and is a character vector, it is assumed that each element encodes both alleles. In this case, if \code{sep} is a character string, \code{a1} is assumed to be coded as "Allele1Allele2". If \code{sep} is a numeric value, it is assumed that character locations \code{1:sep} contain allele 1 and that remaining locations contain allele 2. \item If \code{a1} is a matrix, it is assumed that column 1 contains allele 1 and column 2 contains allele 2. \item If \code{a1} and \code{a2} are both provided, each is assumed to contain one allele value so that the genotype for an individual is obtained by \code{paste(a1,a2,sep="/")}. } If \code{remove.spaces} is TRUE, (the default) any whitespace contained in \code{a1} and \code{a2} is removed when the genotypes are created. If whitespace is used as the separator, (eg "C C", "C T", ...), be sure to set remove.spaces to FALSE. When the alleles are explicitly specified using the \code{alleles} argument, all potential alleles not present in the list will be converted to \code{NA}. NOTE: \code{genotype} assumes that the order of the alleles is not important (E.G., "A/C" == "C/A"). Use class \code{haplotype} if order is significant. If \code{genotypeOrder=NULL} (the default setting), then \code{\link{expectedGenotypes}} is used to get standard sorting order. Only unique values in \code{genotypeOrder} are used, which in turns means that the first occurrence prevails. When \code{genotypeOrder} is given some genotype names, but not all that appear in the data, the rest (those in the data and possible combinations based on allele variants) is automatically added at the end of \code{genotypeOrder}. This puts "missing" genotype names at the end of sort order. This feature is especially useful when there are a lot of allele variants and especially in haplotypes. See examples. } \value{ The genotype class extends "factor" and haplotype extends genotype. Both classes have the following attributes: \item{levels}{ character vector of possible genotype/haplotype values stored coded by \code{paste( allele1, "/", allele2, sep="")}.} \item{allele.names}{ character vector of possible alleles. For a SNP, these might be c("A","T"). For a variable length dinucleotyde repeat this might be c("136","138","140","148"). } \item{allele.map}{ matrix encoding how the factor levels correspond to alleles. See the source code to \code{allele.genotype()} for how to extract allele values using this matrix. Better yet, just use \code{allele.genotype()}.} \item{genotypeOrder}{character, genotype/haplotype names in defined order that can used for sorting in various functions. Note that this slot stores both ordered and unordered genotypes i.e. "A/B" and "B/A".} } %\references{ ~put references to the literature/web site here ~ } \author{Gregory R. Warnes \email{greg@warnes.net} and Friedrich Leisch.} \seealso{ \code{\link{HWE.test}}, \code{\link{allele}}, \code{\link{homozygote}}, \code{\link{heterozygote}}, \code{\link{carrier}}, \code{\link{summary.genotype}}, \code{\link{allele.count}}, \code{\link{sort.genotype}}, \code{\link{genotypeOrder}}, \code{\link{locus}}, \code{\link{gene}}, \code{\link{marker}}, and \code{\link{\%in\%}} for default \%in\% method } \examples{ # several examples of genotype data in different formats example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 example.data2 <- c("C-C","C-T","C-C","T-T","C-C", "C-C","C-C","C-C","T-T","") g2 <- genotype(example.data2,sep="-") g2 example.nosep <- c("DD", "DI", "DD", "II", "DD", "DD", "DD", "DD", "II", "") g3 <- genotype(example.nosep,sep="") g3 example.a1 <- c("D", "D", "D", "I", "D", "D", "D", "D", "I", "") example.a2 <- c("D", "I", "D", "I", "D", "D", "D", "D", "I", "") g4 <- genotype(example.a1,example.a2) g4 example.mat <- cbind(a1=example.a1, a1=example.a2) g5 <- genotype(example.mat) g5 example.data5 <- c("D / D","D / I","D / D","I / I", "D / D","D / D","D / D","D / D", "I / I","") g5 <- genotype(example.data5,rem=TRUE) g5 # show how genotype and haplotype differ data1 <- c("C/C", "C/T", "T/C") data2 <- c("C/C", "T/C", "T/C") test1 <- genotype( data1 ) test2 <- genotype( data2 ) test3 <- haplotype( data1 ) test4 <- haplotype( data2 ) test1==test2 test3==test4 test1=="C/T" test1=="T/C" test3=="C/T" test3=="T/C" ## also test1 %in% test2 test1 %in% data2 test3 %in% test4 test1 %in% "C/T" test1 %in% "T/C" test3 %in% "C/T" test3 %in% "T/C" ## "Messy" example m3 <- c("D D/\t D D","D\tD/ I", "D D/ D D","I/ I", "D D/ D D","D D/ D D","D D/ D D","D D/ D D", "I/ I","/ ","/I") genotype(m3) summary(genotype(m3)) m4 <- c("D D","D I","D D","I I", "D D","D D","D D","D D", "I I"," "," I") genotype(m4,sep=1) genotype(m4,sep=" ",remove.spaces=FALSE) summary(genotype(m4,sep=" ",remove.spaces=FALSE)) m5 <- c("DD","DI","DD","II", "DD","DD","DD","DD", "II"," "," I") genotype(m5,sep=1) haplotype(m5,sep=1,remove.spaces=FALSE) g5 <- genotype(m5,sep="") h5 <- haplotype(m5,sep="") heterozygote(g5) homozygote(g5) carrier(g5,"D") g5[9:10] <- haplotype(m4,sep=" ",remove=FALSE)[1:2] g5 g5[9:10] allele(g5[9:10],1) allele(g5,1)[9:10] # drop unused alleles g5[9:10,drop=TRUE] h5[9:10,drop=TRUE] # Convert allele.counts into genotype x <- c(0,1,2,1,1,2,NA,1,2,1,2,2,2) g <- as.genotype.allele.count(x, alleles=c("C","T") ) g # Use of genotypeOrder example.data <- c("D/D","D/I","I/D","I/I","D/D", "D/D","D/I","I/D","I/I","") summary(genotype(example.data)) genotypeOrder(genotype(example.data)) summary(genotype(example.data, genotypeOrder=c("D/D", "I/I", "D/I"))) summary(genotype(example.data, genotypeOrder=c( "D/I"))) summary(haplotype(example.data, genotypeOrder=c( "I/D", "D/I"))) example.data <- genotype(example.data) genotypeOrder(example.data) <- c("D/D", "I/I", "D/I") genotypeOrder(example.data) } \keyword{ misc } %%\keyword{genetics} genetics/man/expectedGenotypes.Rd0000644000176000001440000000374711522137021016651 0ustar ripleyusers\name{expectedGenotypes} \alias{expectedGenotypes} \alias{expectedHaplotypes} \title{Construct expected genotypes/haplotypes according to known allele variants} \description{ \code{expectedGenotypes} constructs expected genotypes according to known allele variants, which can be quite tedious with large number of allele variants. It can handle different level of ploidy. } \usage{ expectedGenotypes(x, alleles=allele.names(x), ploidy=2, sort=TRUE, haplotype=FALSE) expectedHaplotypes(x, alleles=allele.names(x), ploidy=2, sort=TRUE, haplotype=TRUE) } \arguments{ \item{x}{genotype or haplotype} \item{alleles}{character, vector of allele names} \item{ploidy}{numeric, number of chromosome sets i.e. 2 for human autosomal genes} \item{sort}{logical, sort genotypes according to order of alleles in \code{alleles} argument} \item{haplotype}{logical, construct haplotypes i.e. ordered genotype} At least one of \code{x} or \code{alleles} must be given. } \details{ \code{expectedHaplotypes()} just calls \code{expectedGenotypes()} with argument \code{haplotype=TRUE}. } \value{ A character vector with genotype names as "alele1/alele2" for diploid example. Length of output is \eqn{(n*(n+1))/2} for genotype (unordered genotype) and \eqn{n*n} for haplotype (ordered genotype) for \eqn{n} allele variants. } \author{ Gregor Gorjanc } \seealso{ \code{\link{allele.names}}, \code{\link{genotype}}} \examples{ ## On genotype prp <- c("ARQ/ARQ", "ARQ/ARQ", "ARR/ARQ", "AHQ/ARQ", "ARQ/ARQ") alleles <- c("ARR", "AHQ", "ARH", "ARQ", "VRR", "VRQ") expectedGenotypes(as.genotype(prp)) expectedGenotypes(as.genotype(prp, alleles=alleles)) expectedGenotypes(as.genotype(prp, alleles=alleles, reorder="yes")) ## Only allele names expectedGenotypes(alleles=alleles) expectedGenotypes(alleles=alleles, ploidy=4) ## Haplotype expectedHaplotypes(alleles=alleles) expectedHaplotypes(alleles=alleles, ploidy=4)[1:20] } \keyword{ manip } genetics/man/diseq.Rd0000644000176000001440000001225711522137670014265 0ustar ripleyusers% $Id: diseq.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{diseq} \alias{diseq} \alias{diseq.table} \alias{diseq.genotype} \alias{diseq.ci} \alias{print.diseq} \title{Estimate or Compute Confidence Interval for the Single-Marker Disequilibrium} \description{ Estimate or compute confidence interval for single-marker disequilibrium. } \usage{ diseq(x, ...) \method{print}{diseq}(x, show=c("D","D'","r","R^2","table"), ...) diseq.ci(x, R=1000, conf=0.95, correct=TRUE, na.rm=TRUE, ...) } \arguments{ \item{x}{genotype or haplotype object.} \item{show}{a character value or vector indicating which disequilibrium measures should be displayed. The default is to show all of the available measures. \code{show="table"} will display a table of observed, expected, and observed-expected frequencies.} \item{conf}{Confidence level to use when computing the confidence level for D-hat. Defaults to 0.95, should be in (0,1). } \item{R}{Number of bootstrap iterations to use when computing the confidence interval. Defaults to 1000.} \item{correct}{See details.} \item{na.rm}{ logical. Should missing values be removed?} \item{...}{ optional parameters passed to \code{boot.ci} (\code{diseq.ci}) or ignored.} } \details{ For a single-gene marker, \code{diseq} computes the Hardy-Weinberg (dis)equilibrium statistic D, D', r (the correlation coefficient), and \eqn{r^2} for each pair of allele values, as well as an overall summary value for each measure across all alleles. \code{print.diseq} displays the contents of a \code{diseq} object. \code{diseq.ci} computes a bootstrap confidence interval for this estimate. For consistency, I have applied the standard definitions for D, D', and r from the Linkage Disequilibrium case, replacing all marker probabilities with the appropriate allele probabilities. Thus, for each allele pair, \itemize{ \item{D}{ is defined as the half of the raw difference in frequency between the observed number of heterozygotes and the expected number: \deqn{% D = \frac{1}{2} ( p_{ij} + p_{ji} ) - p_i p_j % }{% D = 1/2 * ( p(ij) + p(ji) ) - p(i)*p(j) % } } \item{D'}{ rescales D to span the range [-1,1] \deqn{D' = \frac{D}{D_{max} } }{D' = D / Dmax} where, if D > 0: \deqn{% D_{max} = \min{ p_i p_j, p_j p_i } = p_i p_j % }{% Dmax = min(p(i)p(j), p(j)p(i)) = p(i)p(j) % } or if D < 0: \deqn{% D_{max} = \min{ p_i (1 - p_j), p_j (1 - p_i) } % }{% Dmax = min( p(i) * (1 - p(j)), p(j)( 1 - (1-p(i) ) ) ) } } \item{r}{ is the correlation coefficient between two alleles, %ignoring all other alleles, and can be computed by \deqn{% r = \frac{-D}{\sqrt( p_i * (1-p_i) p(j) (1-p_j ) )} % }{% r = -D / sqrt( p(i)*(1-p(i)) * p(j)*(1-p(j)) ) % } } } where \itemize{ \item{-}{ \eqn{p_i}{p(i)} defined as the observed probability of allele 'i', } \item{-}{\eqn{p_j}{p(j)} defined as the observed probability of allele 'j', and } \item{-}{\eqn{p_{ij}}{p(ij)} defined as the observed probability of the allele pair 'ij'. } } When there are more than two alleles, the summary values for these statistics are obtained by computing a weighted average of the absolute value of each allele pair, where the weight is determined by the expected frequency. For example: \deqn{% D_{overall} = \sum_{i \ne j} |D_{ij}| * p_{ij} % }{% D.overall = sum |D(ij)| * p(ij) % } Bootstrapping is used to generate confidence interval in order to avoid reliance on parametric assumptions, which will not hold for alleles with low frequencies (e.g. \eqn{D'} following a a Chi-square distribution). See the function \code{\link[genetics]{HWE.test}} for testing Hardy-Weinberg Equilibrium, \eqn{D=0}. } \value{ \code{diseq} returns an object of class \code{diseq} with components \itemize{ \item{call}{function call used to create this object} \item{data}{2-way table of allele pair counts} \item{D.hat}{matrix giving the observed count, expected count, observed - expected difference, and estimate of disequilibrium for each pair of alleles as well as an overall disequilibrium value.} \item{TODO}{more slots to be documented} } \code{diseq.ci} returns an object of class \code{\link[boot]{boot.ci}} } \author{ Gregory R. Warnes \email{greg@warnes.net } } \seealso{ \code{\link{genotype}}, \code{\link{HWE.test}}, \code{\link[boot]{boot}}, \code{\link[boot]{boot.ci}} } \examples{ \testonly{ set.seed(7981357) } example.data <- c("D/D","D/I","D/D","I/I","D/D", "D/D","D/D","D/D","I/I","") g1 <- genotype(example.data) g1 diseq(g1) diseq.ci(g1) HWE.test(g1) # does the same, plus tests D-hat=0 three.data <- c(rep("A/A",8), rep("C/A",20), rep("C/T",20), rep("C/C",10), rep("T/T",3)) g3 <- genotype(three.data) g3 diseq(g3) diseq.ci(g3, ci.B=10000, ci.type="bca") # only show observed vs expected table print(diseq(g3),show='table') } \keyword{misc} %%\keyword{genetics} genetics/man/depreciated.Rd0000644000176000001440000000220711522137021015411 0ustar ripleyusers% $Id: power.casectl.Rd 1272 2007-07-18 11:57:28Z ggorjan $ \name{Depreciated} \alias{power.casectrl} \title{Depreciated functions} \description{ These functions are depreciated. } \usage{ power.casectrl(...) } \arguments{ \item{\dots}{All arguments are ignored} } \details{ The \code{power.casectl} function contained serious errors and has been replaced by \code{\link[GeneticsDesign]{GPC}}, \code{\link[GeneticsDesign]{GeneticPower.Quantitative.Factor}}, or \code{\link[GeneticsDesign]{GeneticPower.Quantitative.Numeric}} in the BioConductor GeneticsDesign package. In specific, the \code{power.casectl} function used an expected contingency table to create the test statistic that was erroneously based on the underlying null, rather than on the marginal totals of the observed table. In addition, the modeling of dominant and recessive modes of inheritance had assumed a "perfect" genotype with no disease, whereas in reality a dominant or recessive mode of inheritance simply means that two of the genotypes will have an identical odds ratio compared to the 3rd genotype (the other homozygote). } \keyword{misc} genetics/man/ci.balance.Rd0000644000176000001440000000616311522137670015136 0ustar ripleyusers% $Id: ci.balance.Rd 1346 2011-02-02 02:21:44Z warnes $ \name{ci.balance} \alias{ci.balance} \title{Experimental Function to Correct Confidence Intervals At or Near Boundaries of the Parameter Space by 'Sliding' the Interval on the Quantile Scale.} \description{Experimental function to correct confidence intervals at or near boundaries of the parameter space by 'sliding' the interval on the quantile scale.} \usage{ ci.balance(x, est, confidence=0.95, alpha=1-confidence, minval, maxval, na.rm=TRUE) } \arguments{ \item{x}{Bootstrap parameter estimates.} \item{est}{Observed value of the parameter.} \item{confidence}{Confidence level for the interval. Defaults to 0.95.} \item{alpha}{Type I error rate (size) for the interval. Defaults to 1-\code{confidence}.} \item{minval}{A numeric value specifying the lower bound of the parameter space. Leave unspecified (the default) if there is no lower bound.} \item{maxval}{A numeric value specifying the upper bound of the parameter space. Leave unspecified (the default) if there is no upper bound.} \item{na.rm}{ logical. Should missing values be removed?} } \details{ EXPERIMENTAL FUNCTION: This function attempts to compute a proper \code{conf}*100\% confidence interval for parameters at or near the boundary of the parameter space using bootstrapped parameter estimates by 'sliding' the confidence interval on the quantile scale. This is accomplished by attempting to place a \code{conf} *100\% interval symmetrically *on the quantile scale* about the observed value. If a symmetric interval would exceed the observed data at the upper (lower) end, a one-sided interval is computed with the upper (lower) boundary fixed at the the upper (lower) boundary of the parameter space. } \value{ A list containing: \item{ci}{A 2-element vector containing the lower and upper confidence limits. The names of the elements of the vector give the actual quantile values used for the interval or one of the character strings "Upper Boundary" or "Lower Boundary".} \item{overflow.upper, overflow.lower}{The number of elements beyond those observed that would be needed to compute a symmetric (on the quantile scale) confidence interval.} \item{n.above, n.below}{The number of bootstrap values which are above (below) the observed value.} \item{lower.n, upper.n}{The index of the value used for the endpoint of the confidence interval or the character string "Upper Boundary" ("Lower Boundary").} } \author{ Gregory R. Warnes \email{greg@warnes.net } } \seealso{ \code{\link[boot]{boot}}, \code{\link[bootstrap]{bootstrap}}, Used by \code{\link{diseq.ci}}. } \examples{ # These are nonsensical examples which simply exercise the # computation. See the code to diseq.ci for a real example. # # FIXME: Add real example using boot or bootstrap. set.seed(7981357) x <- abs(rnorm(100,1)) ci.balance(x,1, minval=0) ci.balance(x,1) x <- rnorm(100,1) x <- ifelse(x>1, 1, x) ci.balance(x,1, maxval=1) ci.balance(x,1) } \keyword{misc} %%\keyword{genetics} genetics/inst/0000755000176000001440000000000012062706260013061 5ustar ripleyusersgenetics/inst/NEWS0000644000176000001440000001456312062705103013564 0ustar ripleyusersgenetics 1.3.8 - 2012-12-14 --------------------------- Bug fixes: - Regenerate broken PDF files in inst/doc. genetics 1.3.7 - 2012-09-14 --------------------------- Enhancements: - Improve descripiton of last examples in manual page for HWE.test(). Other Changes: - Correct warnings issued by recent versions of R CMD CHECK. genetics 1.3.6 - 2011-02-01 --------------------------- - Add missing 'locus<-', 'gene<-', and 'marker<-' functions to NAMESPACE file. - Update Greg's email address to greg@warnes.net genetics 1.3.5 - 2011-01-17 --------------------------- - Fix warning messages from R CMD check genetics 1.3.4 - 2008-08-20 --------------------------- - Fix bug in makeGenotypes that caused it to ignore the 'sep' argument when determining which columns contain genotypes & add a corresponing regression test genetics 1.3.3 - 2007-04-29 --------------------------- - Correct 'obsolete' use of '$'. R no longer permits '$' to be used to extract named elements from vectors (just lists). - Remove the power.casectl() function, which was based on invalid assumpations. It has been marked depreciated. Please use the functions in the Bioconductor package 'GeneticsDesign' instead. genetics 1.3.2 - 2007-11-20 --------------------------- - Fix bug in handling of assignment of NA value(s) to elements of an existing genotype object. - Fix warning messages from R CMD CHECK - Correct documentation error by swapping definitions of kp and alpha arguments of power.casectl(). genetics 1.3.1 -------------- - fixes in genotypeOrder to ensure all genotype/haplotype combinations are used. - genotypeOrder<- is now exported genetics 1.3.0 -------------- - A note is now displayed on startup: The R-Genetics project has developed an set of enhanced genetics packages that will shortly replace 'genetics'. Please visit the project homepage at http://rgenetics.org for more information. - binsearch() has been moved to the gtools package - New function groupGenotype to create groups/levels based on genotype names - Added some internal utility functions (.genotype2Haplotype, .genotype2Allele, and .matchGenotype) - Genotype class gets additional slot genotypeOrder (and genotype() function gets additional argument with the same name) in order to enable predefined order of genotypes in other functions e.g. summary - Added order, sort and %in% methods for genotype and haplotype classes. - Fixed genotype() with allow.partial.missing=FALSE when 'alleles' argument is passed - There is no more warning in genotype() if 'a1' or 'a2' have NA value(s) and 'alleles'' argument is specified, since NA is NA anyway - Fixed documentation of power.casectrl() - added gtools to Depends as needed by expectedGenotypes(); the latter now gives sorted genotypes according to order of given alleles - print.HWE.test() wasn't displaying the observed vs expected genotype frequency table. Fixed. genetics 1.2.1 -------------- - Update Greg's email address - Fixed a bug in function allele.number, as pointed out by Chris Wallace genetics 1.2.0 ------------- - Add R^2 to HWE and LD estimates - Correct bug in denominator of Heterozygosity calculation, as identified by Christopher Calrson - Fix handling of the 'type' and 'what' arguments for plot.genotype() - Misc bug fixes in package imports/dependencies/etc. - Add expectedGenotypes() and plot.genotypes() contributed by Gregor GORJANC - Fix bug in heterozygote when more than one allele.name is provided - Return NA and issue a warning if diseq() called on a marker with only one observed allele. genetics 1.1.2 -------------- - Remove debugging code that printed intermediate values (sometimes a lot of them). - Ensure that allele.freq table reported by summary.genotype has the same ordering as allele.names table. genetics 1.1.1 -------------- - Make it clear that the Yates continuty correction is applied *only* when simulate.p.value=FALSE, so that the reported test statistics for simulate.p.value=FALSE and simulate.p.value=TRUE will differ. - Attempt to fix/clarify HWE diseq. computations & synchronize documentation. - Updated to use a namespace and to work with the lastest gregmisc bundle, which was previously a package. genetics 1.1.0 -------------- - Add namespace support - R/diseq.R: Restore ability to show Observed vs. Expected table by adding "table" option for the 'show' parameter. - Updates to power.casectrl. (including renaming from power.casectl) - Update to work with gregmisc now that it has been converted from a package to a bundle. genetics 1.0.4 -------------- - Updated to remove warnings in R CMD check for R 1.9.1. genetics 1.0.2 -------------- - Fixed Heterozygosity (H) and PIC calculations in summary.genotype. (Bug report from Gerard Tromp . - Added experimental, undocumented, and untested function hapmcmc for imputing haplotypes and related functions. (Code submitted by David Duffy ). genetics 1.0.1 -------------- - Fixed mislabeling of rows/columns in LDtable - Extended LDtable to resize text to fit box area, and to allow selection of which statistics are displayed, and which statistic is used for coloration. - Extended LDtable to allow all columns & rows to be shown - Added a larger example to plot.LD.data.frame documentation - Changed the name of some function parameters to be more clear and/or consistent - Added summary.LD.data.frame and print.LD.data.frame - Fixed a bug in genotype() when reorder="no", such as when called by haplotype(). genetics 1.0.0 -------------- - New functions to estimate and test linkage disequilibrium (LD): LD, LD.genotype, LD.data.frame - New functions to display LD results print.LD, print.LD.data.frame, plot.LD.data.frame, LDtable, LDplot - Various bug-fixes and corrections genetics 0.6.8 -------------- - Added HWE.chisq which performs the Chi-Square test for Hardy-Wienberg Equilibrium. - Modified HWE.exact to return an object of class 'htest'. - Modified HWE.test to use HWE.exact by default for 2-allele genotypes, and HWE.chisq otherwise. genetics 0.6.7 -------------- - Added 'HWE.exact()', an exact test for Hardy-Wienberg Equilibrium for two alleles. Code contributed by David Duffy - Added 'gregorius()', which computes the probability of observing all alleles with a given frequency in a sample of a specified size. genetics/inst/doc/0000755000176000001440000000000012062706260013626 5ustar ripleyusersgenetics/inst/doc/Rnews.sty0000644000176000001440000001556410451014204015466 0ustar ripleyusers%% %% This is file `Rnews.sty', %% generated with the docstrip utility. %% %% The original source files were: %% %% Rnews.dtx (with options: `package') %% %% IMPORTANT NOTICE: %% %% For the copyright see the source file. %% %% Any modified versions of this file must be renamed %% with new filenames distinct from Rnews.sty. %% %% For distribution of the original source see the terms %% for copying and modification in the file Rnews.dtx. %% %% This generated file may be distributed as long as the %% original source files, as listed above, are part of the %% same distribution. (The sources need not necessarily be %% in the same archive or directory.) \def\fileversion{v0.3.6} \def\filename{Rnews} \def\filedate{2002/06/02} \def\docdate {2001/10/31} %% %% Package `Rnews' to use with LaTeX2e %% Copyright (C) 2001--2002 by the R Core Development Team %% Please report errors to KH or FL %% %% -*- LaTeX -*- \NeedsTeXFormat{LaTeX2e}[1995/12/01] \ProvidesPackage{\filename}[\filedate\space\fileversion\space Rnews package] \typeout{Package: `\filename\space\fileversion \@spaces <\filedate>'} \typeout{English documentation as of <\docdate>} \RequirePackage{ifthen} \newboolean{Rnews@driver} \DeclareOption{driver}{\setboolean{Rnews@driver}{true}} \DeclareOption*{\PackageWarning{\filename}{Unknown option `\CurrentOption'}} \ProcessOptions\relax \ifthenelse{\boolean{Rnews@driver}}{}{ \RequirePackage{multicol,graphicx,color,fancyhdr,hyperref} \newcommand{\volume}[1]{\def\Rnews@volume{#1}} \newcommand{\volnumber}[1]{\def\Rnews@number{#1}} \renewcommand{\date}[1]{\def\Rnews@date{#1}} \setcounter{secnumdepth}{-1} \renewcommand{\author}[1]{\def\Rnews@author{#1}} \renewcommand{\title}[1]{\def\Rnews@title{#1}} \newcommand{\subtitle}[1]{\def\Rnews@subtitle{#1}} \newenvironment{article}{% \author{}\title{}\subtitle{}}{\end{multicols}} \renewcommand{\maketitle}{ \begin{multicols}{2}[\chapter{\Rnews@title}\refstepcounter{chapter}][3cm] \ifx\empty\Rnews@subtitle\else\noindent\textbf{\Rnews@subtitle} \par\nobreak\addvspace{\baselineskip}\fi \ifx\empty\Rnews@author\else\noindent\textit{\Rnews@author} \par\nobreak\addvspace{\baselineskip}\fi \@afterindentfalse\@nobreaktrue\@afterheading} \renewcommand\chapter{\secdef\Rnews@chapter\@schapter} \providecommand{\nohyphens}{% \hyphenpenalty=10000\exhyphenpenalty=10000\relax} \newcommand{\Rnews@chapter}{% \renewcommand{\@seccntformat}[1]{}% \@startsection{chapter}{0}{0mm}{% -2\baselineskip \@plus -\baselineskip \@minus -.2ex}{\p@}{% \normalfont\Huge\bfseries\raggedright}} \renewcommand*\l@chapter{\@dottedtocline{0}{0pt}{1em}} \def\@schapter#1{\section*#1} \renewenvironment{figure}[1][]{% \def\@captype{figure} \noindent \begin{minipage}{\columnwidth}}{% \end{minipage}\par\addvspace{\baselineskip}} \renewcommand{\theequation}{\@arabic\c@equation} \def\equation{% \let\refstepcounter\H@refstepcounter \H@equation \def\newname{\arabic{chapter}.\theequation}% \let\theHequation\newname% \hyper@makecurrent{equation}% \Hy@raisedlink{\hyper@anchorstart{\@currentHref}}% \let\refstepcounter\new@refstepcounter}% \def\endequation{\Hy@raisedlink{\hyper@anchorend}\H@endequation} \renewcommand{\thefigure}{\@arabic\c@figure} \renewcommand{\thetable}{\@arabic\c@table} \renewcommand{\contentsname}{Contents of this issue:} \renewcommand\tableofcontents{% \section*{\contentsname \@mkboth{% \MakeUppercase\contentsname}{\MakeUppercase\contentsname}}% \@starttoc{toc}} \renewcommand{\titlepage}{% \noindent \rule{\textwidth}{1pt}\\[-.8\baselineskip] \rule{\textwidth}{.5pt} \begin{center} \includegraphics[height=2cm]{Rlogo}\hspace{7mm} \fontsize{2cm}{2cm}\selectfont News \end{center} The Newsletter of the R Project\hfill Volume \Rnews@volume/\Rnews@number, \Rnews@date\\[-.5\baselineskip] \rule{\textwidth}{.5pt}\\[-.8\baselineskip] \rule{\textwidth}{1pt} \vspace{1cm} \fancyhf{} \fancyhead[L]{Vol.~\Rnews@volume/\Rnews@number, \Rnews@date} \fancyhead[R]{\thepage} \fancyfoot[L]{R News} \fancyfoot[R]{ISSN 1609-3631} \thispagestyle{empty} \begin{bottombox} \begin{multicols}{2} \setcounter{tocdepth}{0} \tableofcontents \setcounter{tocdepth}{2} \end{multicols} \end{bottombox}} \setlength{\textheight}{250mm} \setlength{\topmargin}{-10mm} \setlength{\textwidth}{17cm} \setlength{\oddsidemargin}{-6mm} \setlength{\columnseprule}{.1pt} \setlength{\columnsep}{20pt} \RequirePackage{ae,mathpple} \RequirePackage[T1]{fontenc} \renewcommand{\rmdefault}{ppl} \renewcommand{\sfdefault}{aess} \renewcommand{\ttdefault}{aett} \definecolor{Red}{rgb}{0.7,0,0} \definecolor{Blue}{rgb}{0,0,0.8} \definecolor{hellgrau}{rgb}{0.55,0.55,0.55} \newcommand{\R}{R} \newcommand{\address}[1]{\addvspace{\baselineskip}\noindent\emph{#1}} \newcommand{\email}[1]{\href{mailto:#1}{\normalfont\texttt{#1}}} \newsavebox{\Rnews@box} \newlength{\Rnews@len} \newenvironment{bottombox}{% \begin{figure*}[b] \begin{center} \noindent \begin{lrbox}{\Rnews@box} \begin{minipage}{0.99\textwidth}}{% \end{minipage} \end{lrbox} \addtolength{\Rnews@len}{\fboxsep} \addtolength{\Rnews@len}{\fboxrule} \hspace*{-\Rnews@len}\fbox{\usebox{\Rnews@box}} \end{center} \end{figure*}} \RequirePackage{verbatim} \def\boxedverbatim{% \def\verbatim@processline{% {\setbox0=\hbox{\the\verbatim@line}% \hsize=\wd0 \the\verbatim@line\par}}% \@minipagetrue \@tempswatrue \setbox0=\vbox \bgroup\small\verbatim } \def\endboxedverbatim{% \endverbatim \unskip\setbox0=\lastbox \egroup \fbox{\box0} } \pagestyle{fancy} } % \ifthenelse{\boolean{Rnews@driver}} \newcommand\code{\bgroup\@codex} \def\@codex#1{{\normalfont\ttfamily\hyphenchar\font=-1 #1}\egroup} \newcommand{\kbd}[1]{{\normalfont\texttt{#1}}} \newcommand{\key}[1]{{\normalfont\texttt{\uppercase{#1}}}} \newcommand\samp{`\bgroup\@noligs\@sampx} \def\@sampx#1{{\normalfont\texttt{#1}}\egroup'} \newcommand{\var}[1]{{\normalfont\textsl{#1}}} \let\env=\code \newcommand{\file}[1]{{`\normalfont\textsf{#1}'}} \let\command=\code \let\option=\samp \newcommand{\dfn}[1]{{\normalfont\textsl{#1}}} \newcommand{\acronym}[1]{{\normalfont\textsc{\lowercase{#1}}}} \newcommand{\strong}[1]{{\normalfont\fontseries{b}\selectfont #1}} \let\pkg=\strong \RequirePackage{alltt} \newenvironment{example}{\begin{alltt}}{\end{alltt}} \newenvironment{smallexample}{\begin{alltt}\small}{\end{alltt}} \newenvironment{display}{\list{}{}\item\relax}{\endlist} \newenvironment{smallverbatim}{\small\verbatim}{\endverbatim} \providecommand{\operatorname}[1]{% \mathop{\operator@font#1}\nolimits} \renewcommand{\P}{% \mathop{\operator@font I\hspace{-1.5pt}P\hspace{.13pt}}} \newcommand{\E}{% \mathop{\operator@font I\hspace{-1.5pt}E\hspace{.13pt}}} \newcommand{\VAR}{\operatorname{var}} \newcommand{\COV}{\operatorname{cov}} \newcommand{\COR}{\operatorname{cor}} \RequirePackage{amsfonts} \endinput %% %% End of file `Rnews.sty'. genetics/inst/doc/make_example_data.R0000644000176000001440000000122610451014204017361 0ustar ripleyusers## Create a sample dataset with 3 SNP markers set.seed(125141) g1 <- sample( x=c('C/C', 'C/T', 'T/T'), prob=c(.6,.2,.2), 100, replace=T) g2 <- sample( x=c('A/A', 'A/G', 'G/G'), prob=c(.6,.1,.5), 100, replace=T) g3 <- sample( x=c('C/C', 'C/T', 'T/T'), prob=c(.2,.4, 4), 100, replace=T) y <- rnorm(100) + (g1=='C/C') + 0.25 * (g2=='A/A' | g2=='A/G') pid <- formatC( abs(rnorm(100))*1e6, format="d", flag=0, width=8) ## Form into a data frame data <- data.frame( PID=pid, DELTA.BMI=y, c104t=g1, a1691g=g2, c2249t=g3) ## Save as a file write.table(data, file="example_data.csv", sep=",", quote=F, row.names=F) genetics/inst/doc/LD.pdf0000644000176000001440000001143312062701212014612 0ustar ripleyusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20121214144826) /ModDate (D:20121214144826) /Title (R Graphics Output) /Producer (R 2.15.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 819 /Filter /FlateDecode >> stream xWn1}߯g|MV)HMIDMz"2x.+~l~?$J&MO' lףf 40zI-6@]g7ZRK#2hN:+CcM\1VQØf`bTֳ'~0d)A YU UN">e%dN|E8u9J2u9>= :^`<ǘJX kVoS_\,|9Wy^?,vNҰ1@>XwكQ݇dA(2T~Zcn9{8_n/˧eՏU8kq\Nendstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 504 504] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus 96/quoteleft 144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 9 0 R >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F3 /BaseFont /Helvetica-Bold /Encoding 9 0 R >> endobj xref 0 12 0000000000 65535 f 0000000021 00000 n 0000000164 00000 n 0000001183 00000 n 0000001266 00000 n 0000001389 00000 n 0000001422 00000 n 0000000213 00000 n 0000000293 00000 n 0000004117 00000 n 0000004374 00000 n 0000004471 00000 n trailer << /Size 12 /Info 1 0 R /Root 2 0 R >> startxref 4573 %%EOF genetics/inst/doc/genetics_article.tex0000644000176000001440000004372611522140034017657 0ustar ripleyusers% $Id: genetics_article.tex 1347 2011-02-02 02:23:23Z warnes $ % \documentclass{report} \usepackage{Rnews} \usepackage{graphicx} \setlength{\textheight}{225mm} % To fit on US-Letter paper \begin{document} \author{by Gregory R. Warnes} \title{The genetics package} \subtitle{Utilities for handling genetic data} \maketitle \section{Introduction} In my work as a statistician in the Non-Clinical Statistics and Biostatistical Applications group within Pfizer Global Research and Development I have the opportunity to perform statistical analysis in a wide variety of domains. One of these domains is pharmacogenomics, in which we attempt to determine the relationship between the genetic variability of individual patients and disease status, disease progression, treatment efficacy, or treatment side effect profile. Our normal approach to pharmacogenomics is to start with a small set of candidate genes. We then look for markers of genetic variability within these genes. The most common marker types we encounter are Single Nucleotide Polymorphisms (SNPs). SNPs are locations where some individuals differ from the norm by the substitution one of the 4 DNA bases, adenine (A), thymine (T), guanine (G), and cytosine (C), by a one of the other bases. For example, a single cytosine (C) might be replaced by a single tyrosine (T) in the sequence `CCT\textbf{C}AGC', yielding `CCT\textbf{T}AGC'. We also encounter simple sequence length polymorphisms (SSLP), which are also known as microsatellite DNA. SSLP are simple reteating patters of bases where the number of repeats can vary. E.g., at a particular position, some individuals might have 3 repeats of the pattern `CT', `AC\textbf{CTCTCT}AA', while others might have 5 repeats, `AC\textbf{CTCTCTCTCT}AA'. Regardless of the type or location of genetic variation, each individual has two copies of each chromosome, hence two alleles (variants), and consequently two data values for each marker. This information is often presented together by providing a pair of allele names. Sometimes a separator is used (e.g. `A/T'), sometimes they are simply concatinated (e.g., `AT'). A further layer of complexity arises from the inability of most laboratory methods to determine which observed variants comes from which copy of the chromosome. (Statistical methods are often necessary to impute this information when it is needed.) For this type of data `A/T', and `T/A' are equivalent. \section{The genetics package} The genetics package, available from CRAN, includes classes and methods for creating, representing, and manipulating genotypes (unordered allele pairs) and haplotypes (ordered allele pairs). Genotypes and haplotypes can be annotated with chromosome, locus (location on a chromosome), gene, and marker information. Utility functions compute genotype and allele frequencies, flag homozygotes or heterozygotes, flag carriers of certain alleles, count the number of a specific allele carried by an individual, extract one or both alleles. . These functions make it easy to create and use single-locus genetic information in \R's statistical modeling functions. The genetics library also provide a set of functions to estimate and test for departure from Hardy-Weinberg equilibrium (HWE). HWE specifies the expected allele frequencies for a single population when none of the variant alleles impart a survival benefit. Departure from HWE is often indicative of a problem with the laboratory assay, and is often the first statistical method applied to genetic data. In addition, the genetics package provides functions to test for linkage disequilibrium (LD), the non-random association of marker alleles which can arise from marker proximity or from selection bias. Further, to assist in sample size calculations when considering sample sizes needed when investigating potential markers, we provide a function which computes the probability of observing all alleles with a given true frequency. My primary motivation in creating the genetics library was to overcome the difficulty in representing and manipulating genotype in general-purpose statistical packages. Without an explicit genotype variable type, handling genetic variables requires considerable string manipulation, which can be quite messy and tedious. The \code{genotype} function has been designed to remove the need to perform string manupulation by allowing allele pairs to be specified in any of four commonly occuring notations: \begin{itemize} \item A single vector with a character separator: {\small \begin{verbatim} g1 <- genotype( c('A/A','A/C','C/C','C/A', NA,'A/A','A/C','A/C') ) g3 <- genotype( c('A A','A C','C C','C A', '','A A','A C','A C'), sep=' ', remove.spaces=F) \end{verbatim} } \item A single vector with a positional separator {\small \begin{verbatim} g2 <- genotype( c('AA','AC','CC','CA','', 'AA','AC','AC'), sep=1 ) \end{verbatim} } \item Two separate vectors {\small \begin{verbatim} g4 <- genotype( c('A','A','C','C','','A','A','A'), c('A','C','C','A','','A','C','C') ) \end{verbatim} } \item A dataframe or matrix with two columns {\small \begin{verbatim} gm <- cbind( c('A','A','C','C','','A','A','A'), c('A','C','C','A','','A','C','C') ) g5 <- genotype( gm ) \end{verbatim} } \end{itemize} For simplicity, the functions makeGenotype and makeHaplotype can be used to convert all of the genetic variables contained in a dataframe in a single pass. (See the help page for details.) A second difficulty in using genotypes is the need to represent the information in different forms at different times. To simplify the use of genotype variables, each of the three basic ways of modeling the effect of the allele combinations is directly supported by the \code{genetics} package: \begin{description} \item[categorical] Each allele combination acts differently. This situation is handled by entering the \code{genotype} variable without modification into a model. In this case, it will be treated as a factor: {\small \begin{verbatim} lm( outcome ~ genotype.var + confounder ) \end{verbatim} } \item[additive] The effect depends on the number of copies of a specific allele (0, 1, or 2). The function \code{allele.count( gene, allele )} returns the number of copies of the specified allele: {\small \begin{verbatim} lm( outcome ~ allele.count(genotype.var,'A') + confounder ) \end{verbatim} } \item[dominant/recessive] The effect depends only on the presence or absence of a specific allele. The function \code{carrier( gene, allele )} returns a boolean flag if the specified allele is present: {\small \begin{verbatim} lm( outcome ~ carrier(genotype.var,'A') + confounder ) \end{verbatim} } \end{description} \section{Implementation} The basic functionality of the \code{genetics} package is provided by the \code{genotype} class and the \code{haplotype} class, which is a simple extension of the former. Friedrich Leisch and I collaborated on the design of the \code{genotype} class. We had four goals: First, we wanted to be able to manipulate both alleles as a single variable. Second, we needed a clean way of accessing the individual alleles when this was required. Third, a genotype variable should be able to be stored in dataframes as they are currently implemented in R. Fourth, the implementation of genotype variables should be space-efficient. After considering several potential implementations, we chose to implement the genotype class as an extension to the in-built factor variable type with additional information stored in attributes. Genotype objects are stored as factors and have the class list \code{c("genotype","factor")}. The names of the factor levels are constructed as \code{paste(allele1,"/",allele2,sep="")}. Since most genotyping methods do not indicate which allele comes from which member of a chromosome pair, the alleles for each individual are placed in a consistent order controlled by the \code{reorder} argument. In cases when the allele order is informative, the \code{haplotype} class, which preserves the allele order, should be used instead. The set of allele names is stored in the attribute \code{allele.names}. A translation table from the factor levels to the names of each of the two alleles is stored in the attribute \code{allele.map}. This map is a two column character matrix with one row per factor level. The columns provide the individual alleles for each factor level. Accesing the individual alleles, as performed by the \code{allele} function, is accomplished by simply indexing into this table, \begin{verbatim} allele.x <- attrib(x,"allele.map") alleles.x[genotype.var,which] \end{verbatim} where \code{which} is \code{1}, \code{2}, or \code{c(1,2)} as appropriate. Finally, there is often additional meta-information associated with a genotype. The functions \code{locus}, \code{gene}, and \code{marker} create objects to store information, respectively, about genetic loci, genes, and markers. Any of these objects can be included as part of a genotype object using the \code{locus} argument. The print and summary functions for genotype objects properly display this information when it is present. This implementation of the genotype class met our four design goals and offered an additional benefit: in most contexts factors behave the same as the desired default behavior for genotype objects. Consequently, relatively few additional methods needed to written. Further, in the absence of the genetics package, the information stored in genotype objects is still accessible in a reasonable way. The \code{genotype} class is accompanied by a full complement of helper methods for standard R operators ( \code{[]}, \code{[<-}, \code{==}, etc. ) and object methods ( \code{summary}, \code{print}, \code{is.genotype}, \code{as.genotype}, etc. ). Additional functions for manipulating genotypes include: \begin{description} \item[allele] Extracts individual alleles. matrix. \item[allele.names] Extracts the set of allele names. \item[homozygote] Creates a logical vector indicating whether both alleles of each observation are the same. \item[heterozygote] Creates a logical vector indicating whether the alleles of each observation differ. \item[carrier] Creates a logical vector indicating whether the specified alleles are present. \item[allele.count] Returns the number of copies of the specified alleles carried by each observation. \item[getlocus] Extracts locus, gene, or marker information. \item[makeGenotypes] Convert appropriate columns in a dataframe to genotypes or haplotypes \item[write.pop.file] Creates a 'pop' data file, as used by the GenePop (\url{http://wbiomed.curtin.edu.au/genepop/}) and LinkDos (\url{http://wbiomed.curtin.edu.au/genepop/linkdos.html}) softare packages. \item[write.pedigree.file] Creates a 'pedigree' data file, as used by the QTDT software package (\url{http://www.sph.umich.edu/statgen/abecasis/QTDT/}). \item[write.marker.file] Creates a 'marker' data file, as used by the QTDT software package (\url{http://www.sph.umich.edu/statgen/abecasis/QTDT/}). \end{description} The genetics package provides four functions related to Hardy-Weinberg Equilibrium: \begin{description} \item[diseq] Estimate or compute confidence interval for the single marker Hardy-Weinberg disequilibrium \item[HWE.chisq] Performs a Chi-square test for Hardy-Weinberg equilibrium \item[HWE.exact] Performs a Fisher's exact test of Hardy-Weinberg equilibrium for two-allele markers. \item[HWE.test] Computes estimates and bootstrap confidence intervals, as well as testing for Hardy-Weinberg equilibrium. \end{description} as well as three related to linkage disequilibrium (LD): \begin{description} \item[LD] Compute pairwise linkage disequilibrium between genetic markers. \item[LDtable] Generate a graphical table showing the LD estimate, number of observations and p-value for each marker combination, color coded by significance. \item[LDplot] Plot linkage disequilibrium as a function of marker location. \end{description} and one function for sample size calculation: \begin{description} \item[gregorius] Probability of Observing All Alleles with a Given Frequency in a Sample of a Specified Size. \end{description} The algorithms used in the HWE and LD functions are beyond the scope of this article, but details are provided in the help pages or the corresponding package documentation. \section{Example} Here is a partial session using tools from the genotype package to examine the features of 3 simulated markers and thier relationships with a continuous outcome: {\small \begin{verbatim} > library(genetics) [...] > # Load the data from a CSV file > data <- read.csv("example_data.csv") > > # Convert genotype columns to genotype variables > data <- makeGenotypes(data) > > ## Annotate the genes > marker(data$a1691g) <- + marker(name="A1691G", + type="SNP", + locus.name="MBP2", + chromosome=9, + arm="q", + index.start=35, + bp.start=1691, + relative.to="intron 1") [...] > > # Look at some of the data > data[1:5,] PID DELTA.BMI c104t a1691g c2249t 1 1127409 0.62 C/C G/G T/T 2 246311 1.31 C/C A/A T/T 3 295185 0.15 C/C G/G T/T 4 34301 0.72 C/T A/A T/T 5 96890 0.37 C/C A/A T/T > > # Get allele information for c104t > summary(data$c104t) Marker: MBP2:C-104T (9q35:-104) Type: SNP Allele Frequency: Count Proportion C 137 0.68 T 63 0.32 Genotype Frequency: Count Proportion C/C 59 0.59 C/T 19 0.19 T/T 22 0.22 > > > # Check Hardy-Weinberg Equilibrium > HWE.test(data$c104t) ----------------------------------- Test for Hardy-Weinberg-Equilibrium ----------------------------------- Call: HWE.test.genotype(x = data$c104t) Raw Disequlibrium for each allele pair (D) C T C 0.12 T 0.12 Scaled Disequlibrium for each allele pair (D') C T C 0.56 T 0.56 Correlation coefficient for each allele pair (r) C T C 1.00 -0.56 T -0.56 1.00 Overall Values Value D 0.12 D' 0.56 r -0.56 Confidence intervals computed via bootstrap using 1000 samples Observed 95% CI NA's Overall D 0.121 ( 0.073, 0.159) 0 Overall D' 0.560 ( 0.373, 0.714) 0 Overall r -0.560 (-0.714, -0.373) 0 Contains Zero? Overall D *NO* Overall D' *NO* Overall r *NO* Significance Test: Exact Test for Hardy-Weinberg Equilibrium data: data$c104t N11 = 59, N12 = 19, N22 = 22, N1 = 137, N2 = 63, p-value = 3.463e-08 > > # Check Linkage Disequilibrium > ld <- LD(data) Warning message: Non-genotype variables or genotype variables with more or less than two alleles detected. These variables will be omitted: PID, DELTA.BMI in: LD.data.frame(data) > ld # text display Pairwise LD ----------- a1691g c2249t c104t D -0.01 -0.03 c104t D' 0.05 1.00 c104t Corr. -0.03 -0.21 c104t X^2 0.16 8.51 c104t P-value 0.69 0.0035 c104t n 100 100 a1691g D -0.01 a1691g D' 0.31 a1691g Corr. -0.08 a1691g X^2 1.30 a1691g P-value 0.25 a1691g n 100 > > LDtable(ld) # graphical display \end{verbatim} \begin{center} \includegraphics[width=0.5\textwidth]{LD.pdf} \end{center} \begin{verbatim} > # fit a model > summary(lm( DELTA.BMI ~ + homozygote(c104t,'C') + + allele.count(a1691g, 'G') + + c2249t, data=data)) Call: lm(formula = DELTA.BMI ~ homozygote(c104t, "C") + allele.count(a1691g, "G") + c2249t, data = data) Residuals: Min 1Q Median 3Q Max -2.9818 -0.5917 -0.0303 0.6666 2.7101 Coefficients: Estimate Std. Error (Intercept) -0.1807 0.5996 homozygote(c104t, "C")TRUE 1.0203 0.2290 allele.count(a1691g, "G") -0.0905 0.1175 c2249tT/C 0.4291 0.6873 c2249tT/T 0.3476 0.5848 t value Pr(>|t|) (Intercept) -0.30 0.76 homozygote(c104t, "C")TRUE 4.46 2.3e-05 *** allele.count(a1691g, "G") -0.77 0.44 c2249tT/C 0.62 0.53 c2249tT/T 0.59 0.55 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 1.1 on 95 degrees of freedom Multiple R-Squared: 0.176, Adjusted R-squared: 0.141 F-statistic: 5.06 on 4 and 95 DF, p-value: 0.000969 \end{verbatim} } \section{Conclusion} The current release of the \code{genetics} package, 1.0.0, provides a complete set of classes and methods for handling single-locus genetic data as well as functions for computing and testing for departure from Hardy-Weinberg and linkage disequilibrium using a variety of estimators. As noted earlier, Friedrich Leisch and I collaborated on the design of the data structures. While I was primarily motivated by the desire to provide a natural way to include single-locus genetic variables in statistical models, Fritz also wanted to support multiple genetic changes spread across one or more genes. As of the current version, my goal has largely been realized, but more work is necessary to fully support Fritz's goal. In the future I intend to add functions to perform haplotype imputation and generate standard genetics plots. I would like to thank Freidrich Leisch for his assistance in designing the genotype data structure, David Duffy for contributing the code for the \code{gregarious} and {HWE.exact} functions, and Michael Man for error reports and helpful discussion. I welcome comments and contributions. \address{Gregory R. Warnes \\ \emph{greg@warnes.net} } \end{multicols} \end{document} genetics/inst/doc/genetics_article.pdf0000644000176000001440000035727212062701443017643 0ustar ripleyusers%PDF-1.5 % 29 0 obj << /Length 3982 /Filter /FlateDecode >> stream xڵZY~_7h#H֫vY6m@Chz]ѿ>UfeH j:Yk/^vy~*'gWk/t7޾]usϛ7oW.MUi Ό7*sibڕ^Ea0n =_<%5)m$LP t4ȺEBgmWP%@~omaNDdSY7Cޖ ·Z0)GUDq0tlAyw Л"(yt:~GO [@ۻg*vLt v8)uXIIQ-U+Lx&*I2Lm'Mꎟ5^lZ:W{qՓe^s65F=Fȁ CW е|gp Bbb+ c-m}$#k K}:֋eC:MAQ!7SHX)cVs}Pv`Ag$vR2}4D'Ew%8Bԥ\Ǩ8 zTNvuűcMY}ld7u| .wy|ZC#plK96oz ͋g_bhH]haBa~ R[eŽ{.Տ-!ap7'0"f>dv3n'1b3 !5{RKh#lM0xKoj ]+8Z!"@xG!iM 'їә#\4Ɠrt'{LIq@$jtt*VfȤe"ޣxt<$%{rBTjo>b^-Jw,OmFQPa}dYD6'^9W 8@AA䵟9>$?O>mna[aBٱ'95FTɀH{f:=h`LSғV&Oj^=HH9?@)-|΍|$3-bKEo>wM `f+Ί9b`}rKf- f]T }I1#tFJ޲)s$wgjxr L9.,l7Y "4G$a2Jl4/$=PS3[X!Wv@PEWlN:v&G)G洨ȫ(>1X:K!|+P hgFwaFԑm`0h*;Z/$+H z-תX P;d ۡ2 zBHRێMo9qCw̗zy~h.RƴD`FSsh%?ԯɐ%Ha* al|"gxa2Kh1x #p;WsQHc>RT$%u[l+ȏ@QgeuQ%k65K] Ū_D[\3!:N?j![7\SmՉ \0ʓ`zc"# J-8gU`iTZZz&34^kGe#%ӛf Ad4/Ǫw'7-̠"&ٓmYԲN^E_L1Αb#ޗWoYE4ƙQ W|:d~F^k",[~A'Oϴ} .`O>P(|xhɊo ~~BF C[W?pBT׾sȱ#Z[Փ` 2p]H aU, R+DŽJXu/ȍ,F3>tv`hFҊݢ_*M 0랟q=ܟ= _%_ã ]aB<?FOJ +b6Er,? \U8FLe͹d`λKQUcqmQ? \VC3]DjM=XJ2xHv7#l~og`~Hh(n|1θ4 R}{9gar{цb-cb|UBEXg? KBߩe!=C͵~gB?^o>̓MóC?>{\%yҺ`dS5dL lFyM?[^O~Af> !c9Z=<eJ.6ڣT=hݦVGfUz3Sb)_utx|ڏmXvŸ~~ endstream endobj 43 0 obj << /Length 3848 /Filter /FlateDecode >> stream xrP%t>)lv7rE3){|ɷ$A=S@"Z;2]$2Y\,b#P-׋wW_:Ŀ|)DEWPW|Fo~oή~9j*I(,g?-" nv3f?"qEI4$34"DKI=<_R꒪v )#Y- ~{s{sv<ꀬE8],E?gA˝3 ?A`7[=HXJFJі~Dz4KIot& b}Yj٢kS'}`wUQ* 3t>F1-j?5T{ 1=ީo sg)NB_G3oYSͻ}eZ]TmٜFN>4 ~%spD1-Lf#A_= RĨ0mJ-,>/Uqt*9EW6on6hٺv y ZC)p ÿwJph ]C;UEGmx]5cZ]Y)Dp|Uٖ./k\eMeN'3mYVvn]޶! LV;[¾ &(CQ_D X8\db$CsP4.UoZ-v9ʎ$* QMDSzKS8y7?U%YЕ[ ppb*^XI vd_h!.8haNH_c>ZҤ$6k[9e"5=j@؊E]uuI* akS贫iI(OHf:뭗,&4tu(cG|PD4VhʜN_ٗE^=ehc&+G9<ـ6gBqgѵ,Z^ IFd%!cz(O%L z4d:g‡ޱB~DM,35W{Q܊Qزtz7FW_3H` q yk/j#}9Ԝs69Ωѭ%K&xsDq#q2ytyPqƌ9pLLD5z]v} 1+㣉NƀzR']?>lWO+mv" HMYCAhg ‡...DĄ W$;2#.1Tߑ<W{t*_q9'.Qa<*ؒ=b@h`F$ϫt):_sw"@$1(d i0T6 Jݽ¶3RjT(≔HNU hL*z0eR1zjQt|K֗Gm$˞4(£=A0ℍ%/ɑbԉb\9!U%O._ơJ]TGӢRxb"6̌;V /Yٝޘl*np2oJ bpџ2…N;֭dQN9`]9#v_ޭnl2ESUٓN Y۶e df~902bBG 2߿1``cۘu byuۇȭڭÝ;B8IXHH*ܾdLLGj!T_11)H@hGܥ0wgZ- y.lxAlZ91d+[`nQ}FMmQ^k+q4eX_ cNㄠȘr7 qb0قdZ{g'5oY>lh: VlU"P! n +y԰y_4z+"JY/Wh4q /Sxd1JPAhgtϞnO/WΥ&4I0?%bPvb_G~3XGM甁k\N Q̆Y>ѱS)e\ !X2 Cq 1n+Z3~9oGU ҁIOWJ.9 Kv2gRzB] gD]x)h]tvV=&C1_9r!4NYPr&P9=-c q]ŲLS}s\Vrpt>ʩV<ѧT}:VO3cP:L y}b 7>.Qd qA:);6a0WdkV%/N/Ne-T2 A*W^&\SK}A{m>ID%y3 <8xhyF9X{5s^gA]|,M6 ~q?E({-OJ効6߱A,%& MLbjx%t]z?DN\HQ:xię`m|`5!'4` b=ҥ ]e Pg{ǫDɗ{)a^#zKvط[O>>fxR `p8NtTSIf vA /v5wIpG֡d=H RߦAJ_ 51} ?ڽ{ge@`ro\  ؠv2k_mGX`evP{d\'Rb,4:ziP٨cv%tg;ܬf> stream xZmo_H ʢנ |3ɡjҞ^s~}g8CI+˲}m/ Rpf(g]87'\vElǁ,6 ߳]HaZ/~.qK)[WBWxOwk_釫N.N>Y~N'|pkhn2~EŽb('?8CN;#luS͗)X,}Y7TJˢQj$mʊ++Kndϥ`qR;}w:07`V豳Bk @ުlj76}Ⱥ(DتNK`*͜'Mvh0B^gMVIu@C5r]ScX)[U4"Ƿ^" `=?8{#dU"Jw VMG4!I"6Y\jظn4+f Z^VMTLTuյ ^4_R]ۄSHσy\ =DWDWDvF<:h:}=|ϳ!iԸ7EVRI!0FXQ'G { )`ɡY=KXA X9/rH@L.\=V@XgdodD:I8g/= Ã㺓,an3ĶxnU-f#k`M/$P9P<e[4s8]$I5mF7/h+SI|!S5jpX#ٞ]8hg! y~lUi;k'A[&BF@h˨k.Da@XyS9Tiy4 V7~qHg̈@(_~l<[UY4)?Y>>#l}-OW9s!e2\γ6Ԏi rB@DD!!u9Qϡ}r4ynDhG n !6Atw ĝF2Rtw |i!;{NU茣}ZxE.[@ZuI=p,vnO }>A1H" uVAnOpjA8~jhmfH,P\l=ZtLAL*>;@_eSCw :qZ5HCk99uWDq5:At3fہ}2Y=v8|7;vѰ**}jb{Ix:#So_ynؖA8NIVSTx]o̫S÷}9V ^7FI;D1p7 ;7`\R[Hr N5qjD_{aAÏ/hTKv2Gɂ,8;UVAYA2/5„ף::I&psv_D_:8a.M!"@#Ԡiz@ fʂg?Ց:]DZxRJΒUj[bdKN*YPAAeϵmI!6kv "Cv*}a&Å]c<3xvEZ)!nf.9a% /. ֹ'2tݕPxhz!ZxzFJR9FmZ5Iw}h19g(9@m)LQ8}K 8_-ve~. '] \RuztI61C@Zޒ)K P7Оj)G: F0 (XBtYa;.l Tn?h Kپ|bJ>@K҇b .;讒>mNJj6`Gw/"ؑ 858_ߙ A\S71sq=x>Lub6@KtI twB L)JM }njj9W ]dF(nzԾns9ɟ'x/fq4/S]N.Sf]RnIB3Mn %q#eZgb >na ?Y3դ@hO-׃ }`-䷀''֬st~(ҿO^>0-3 j{ 9o0wq=> sX{408l?7xgg4&3h60J6z X12y xH`Ī$)BA endstream endobj 62 0 obj << /Length 1831 /Filter /FlateDecode >> stream xio6n]T,)ꢱn[XnF4Ѯ~&.?U җ 3=ը1ٙ!{Ю $UP0L+#P.5G Tn@ 3k3(˄ht4Z)"LQT v̳yT=1ev]6ɽ5m,;Qߍȡ>xq P-rUȪC9.aoI;qO^"$\; ؄eӔ9s+U}[r }=ٔ﫯vDz1*_{_l<plW\f\N-`}YmF22j> FylM/oUv?/;T~眫{K,zgP#wHav9V졨io"YXO~!zBIg4#,e4HcJxLH $I!I)b"֕1T;ܸN/_EZiݣJ:jqr=``@ &-ĬQ)~cuK. 0%A^{෪qX(m&.Yu[4`fp #i pAt'Qp=Ir-U9O;jG-2/5m_9G0q ^ϧXRkxPG(C??\j*K M8NB+9iVmS>ͩkBYQR `UXP8T΋Hu(9<•Ԇ kgcm.qY<!w91'LyDY%whמmn~rwf6K"'2qNh9# b( endstream endobj 66 0 obj << /Length 2286 /Filter /FlateDecode >> stream xkoF2|? 8ױⴉ]C@ir%B IuPoH-iha+1Ώ>z~FjK# 4TׅyW?\]|zaySCor @3]vxlV?xZ.\2i FCvr; w022 qB- Xx1 70.a\ba%"d/Gau'‹9 l?Ɖpe_Ltl ZL6"A&D0RW$D?MdjXNĥ:8$f>̑?G^wi:=s8m7p~>|)ܓKNTo_M `:d8= tLoUTå%S70{u9U UܝK{퐐D,˩By>{zV1zGQwbM8^U*kP91;Ť}9HfZMlHF* Y>[)( Ny&vamC9Mwe }0Z~խ^o+)Fc9+MصnB-f0- T)]˘ڨyQd]PہMnq$Cj:fKٶ-yʛ!!^sqC)FCo )К2C  ķUU^1 13_)Q}Cn>K|ҘR4L#vTMAc)*{'#;uT%L&hvKY>𒟴Mה7y6U~e"އ~-!-^-o|wj_}Ϥ?sy c Q ]fRG m%a$4xVU[@^  : Ple'G38gaWu#U(MSB_t}!DvrKo endstream endobj 59 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./LD.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 68 0 R /BBox [0 0 504 504] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 69 0 R/F3 70 0 R>> /ExtGState << >>/ColorSpace << /sRGB 71 0 R >>>> /Length 819 /Filter /FlateDecode >> stream xWn1}߯g|MV)HMIDMz"2x.+~l~?$J&MO' lףf 40zI-6@]g7ZRK#2hN:+CcM\1VQØf`bTֳ'~0d)A YU UN">e%dN|E8u9J2u9>= :^`<ǘJX kVoS_\,|9Wy^?,vNҰ1@>XwكQ݇dA(2T~Zcn9{8_n/˧eՏU8kq\N endstream endobj 73 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 82 0 obj << /Length1 1403 /Length2 6029 /Length3 0 /Length 6987 /Filter /FlateDecode >> stream xڍx4ֶ Zhчu{NDc0D{ !: G'JM=5k={_{p (!mHZ$(i PD&0пD&Pw ;ؔh P<@"H\ Re'-xD@QDJHWw#S[7Pp `@v`*Bp!}#*%$%vA "dy^0#{B(t.?8F0_C= ` p@aB<vPw:PC E Ht%!~!+C8ap(@WUKv`8 {ap-{`>a sEQ0/B`ڬSB@hѯ)ܡL}3{eCa*dy@5`0&h(PRLLG_|\~HW=4f|P@  B`gǘ1X1>(TL PSQ H H .. guoz`؟GF =  L&GƆ :HP\@!,{Gpo?_v} 0z@cfCCM 6^ 43# @P0o qKK!Q_L_>A1~g]ikE`wwF(U;oH4&G:X(@#1vxc0^u( !ABÜ^(0x l୬vF'E9g9jgM)ؽ37W11|Qwnrz>Ko]P`qI0&NqDfckb:s.#rPr(9%gMg@)ub?1ge_E?"naakhimn_Qfo؋J:*ytIPXJilt.86? ےD<to>~QY>b1.Dr99ڑ&]t(ZߋK \֞Bka/4?snLK ||(gv7]auZ/yҌ%qmPO! dpYG& &*bZYd5OB^TA~^[Cyɹq#Y#mLBsp)rRJ/L/= iI>^?@^~KMD[C!a+·6:\a'gZS=~o#IAB]CxtjdwL3_vpm{7\RI +D[-Z'=O,ΤmZ}j9pQᦨ M5.)B;S8$PmxC BѾh.@Sk9BqQ/ 8DU⇧ȇBfbo}]_n[1(hE[)=h(4O~Whru%n-rEK9R=͏D=IG5A߆$9?0aa2VI=*jI> gQyEmzɬgX_$DPRMi? Rpc.G}yahPeYAVY;8Ϫq+ԫwPFOJgu9!}r\?o"epc o*ItBYϋ5:$JCT&ȺEּdTZa륕*7eN4PJ+Wv$#%pMgkV8׳®Ϧ,Tu憜zHd 32Ө-Aч1n/N(h1ܬš[ rWËIlƥr'ur)3a➤2z TY|NաHZf}kG$2E' (>5ANF\tl_㇓~YYki;3P\J>k5/^[B%Rjn\t[74.91$}/!U,n9c%'pñX`;h4b5y|dI!OKhBpu %Ydm cV}[ 0d+NvaeM z%(CXX2Z'xP;>qVNi)7"5?(?1FzuE .O} ):p@}|j]) ج2Yg[|'?ES2Œu<{K >L4X껞v'2wK=Lտ9,LCOӠ*M<8HqKYV-)ɱqCX?զ }bjjx3rwSWUf@K#[a,!>.ع./jJ> 7!汫brԋ߷j~89n71Ii+ϹADi.F@x$wvmX6XDf'TkFKjYǴOu韝{W Ǭ8ȁ W{.amXd.ȩ{7[_k@ Oڏ:wA@B礱*w3"!,*d:G>GbMty/#xxH"OKa)5dEI"8tgX$s*8xĒjO&~1~i_<>>*[G,4qr%-B}S;f~seBЗB%*[tS.T3oԝZ̊ {D>7qFY-b U>$յZ[r灻(Bqb^2aL[@{Ȳ=Hud2'8Iɏ I3[ɻlكh;!حiTެEGaeW%RO?4 ~Z6J]$l~8fM/8r_:6GT_*[k)s|f /B S(`xηiꆌ9F@Be -tAjk ؑT/tc˃Hd|MZzdH>.Ef쇒*4N2DO,yݬ&9+V0Uwb֧=۫nXV^/Oka,Jzg=a1a_zMgEIKݞ6jўtz_3 zTFaSu$+RS"sE=+  A\.{YƟ%]Y;Kmp̔%+ydYq,b&Wn^y?HF;;sIQ._XtҎg"u;"rt a#n9hBix:ì{̚Q}zʷ(csR\S6~M}̀o׏<#rSI9HH ^͔m{*BUEK8'f-zB m)t\"(IXŢclsqayY5W/L%4d=K_,Jh!Q"䑲Yw迦O%Tku6b%,b]Z EJ6O]lGI;<'ҕskr;co$׎^t;(<"h["WH] iEt:Z=K&Ij}7śuР<ɚ{81%]Wv*wO{*j,rk,ו/NYL.i ~D"d>{mJ=s6O(oi<AG6V^8UDo|I!Ҋqǎ7M]3w^r#_= _w_Ub}#rȾc魖bw±\' LN }plHlプ:0B*\WtEo#̫zf9$^[ڕM=dV0Y ?4C!RL2 1Zt+%!.T ߳b, F<˃(v Z1SJ%^O!{ZN?㡏5+#;|ݺsj\b^GbfȻ5u#s,KL{,vƂTf"S"XflIL{iԼ|1 _{s"g,y ZtͰ3Pس Kc*u!{T#wbzAB/𾏢x9;|y4GX=#[lg\_YeE~h{۟[ML3%פR;s!LnPSO.K~xZU[^l:DxBFIC%2`Hjx^xYv56KߴYշ{?Z!NJs˕ssc {;2Sd՟=WE iƤ ]Z%u)r:Uzj턜7:83-nN|UNѓg\hԗ`;Hr0q/h,ӇZ=w^G9XpG+fvPh5b-hk ~jɗa˂ifAgќyK"'krTUGO(νʨPꥪ޷GKI:$g̬WxҒe` Y%WDS8pHG1R&v#SYSSĘG&5 _+,/w1r^+/_=}b+Ք6_:Q8U9dS'8vd`'=b7eTo F?liG:Vt?V^.}|>V6L+Vi> stream xڍP ]: 4;ww@p>fܙWWT5ڧ)>*2 ;gFf^ 3B_;ىLyh-&s`r@nv^Efvf0ugRtpʈnftp033s <:Y0si},̀ཛྷ\gG׿YX&c?@wt0ˏf '+f$*YJ/;EEA/v+ */?F_d@Pxi 꿖Aj.33*{"I? ZxfP g.+l!"v6Ihllbb{ m, '? 3񽯜~Y%L@+']_/5)m=`rJ9LD,F<\&{?=9cg!08ދlg_ ;[1&!]?ߏb/vhw;}#ӌl6\?w-eWw O_ߏn=Ѳes Ϩީ:˻_?g'dcdy#_  3tg SM\9ϟ h2 &Bư;%0GF LSx+<ڇ#A}#Buږ ^ev~i{hX~!gkVnY<nd{)ՉO{5rգtK)pIahQonsHd}Nپzio<,xW:iAޠORz*-L91H=7 :2O{=f?⇬]UC{:ctfnnRJ-{#L\ca=~.Ch1,.Cx]dYF^o5}b?9T!q [QE1Sn/(ފ*+ 4n'O77Fbcf+X\Erd²³' wOhdtuP١F_ZS5#o0#9Vv놊C $&OQE ,"EIA6kSԩʢ}2WI+ WShyC*pS3A؟7mB{W{c}&.v_R\'~,qm=X+~fъe*:oe\qn/Z~-vtNyݶe{O:sBd q2̋YǛSb?0O{zDEjc=A-.$q2?#Tey\:ٙM]tNܴ:S2rvY;tgF5d Y\Gg|]& 7jAPF G% Ȼ()V=*;2Áyo,rG7M+☼BGTtjKql)1F>666#yX{ʒ,1y@iNR_E(!;9;V?S->kO>;Sq^n [pŶ7.U#ϣYCfƭ+H -#0I/vV]۝ 0&qn,l~ƹ2zY-u1֎"w.JO(-/HbƑ*^UTToS={>wU~ PŹ0oTqU!J^iF?35F8ֳmEG>\+L4& 5dWCUvm2^NE%\~ ٵtBâk4G u%T{`Rx j! Z~P(Aِ_*$H3].ڗ f `lP琨sѲ$y"T٤XU9us5VnHb3:XCi^>M,+VOVU]og(25nq;qiL{Xxq(G/Cn퉆oEePQT}[0}jj2v@_Mh 1wy뷋;i~?TaPZ,{yݳL'Jj'^AԸrb'r<҃ aym9%6T)ҷo܃??(*iH]B:L7.*$At]?Λ2AB0‚~tlBbߏ7³PNSμDgv h9>xY`WJVX]s5D>~ 8?$^v )qTzHBnDJn*}x/`.r6K-%UW!zb}~ReD[=iK,Ch52ԯ֯Fp?HkX Hʀsw9#3U7fF`gGo:S$AHRoLYT]A`K SEE[1Cڨa1Ep\^5hwi(0X|Gy;kH.KUtgY29tM2=DvNU 2!Q)ԣy2"n&e,UTZ л;.ˆm$JWBOѢ@fm?-aB{.Pܾ V2(VOi"NZh r4l)^ ERoTOBE:BgF|P#D"3/\$_cńfR R(/(Ni 58oYѳZ`T /ԐUp50*EȆHHw% *]z~G!`PB4ܔXLFf)qژϝQ#!5=;Y69ɱ}57Yv-8_ȻkeSj.@>D ;č51,4OؑdWc20|~z8蝣*ݯm2I#Bى;ƢS#?Vs6tڤ~˜mָhN`|֚LFܿ-D:{l N6-hRO!N8]o<]ℍ?D~to0Z7t\Et'DB99Aŋ]i5DGbQ=R5"? 6)꫺ }ڝp7#)Sf~ien#h H ߻}VE5JQd]~-RPӝ~K?aD1sTz?Q,&27@,wD0i$HRIr*(uO12BGkeM+Ⱅ7,9Ow. DQ5r2%OʺKɪ;zseV0T95>-w \Bx&wIK )< BÈ`qħ^d³V3晹\dž~sxi cSx"?Xi5# τ.{濾$G.P$$ ?t(lreN3yCyz0:N#wNWU#z fd}»2Ur=O}N!Df?e`rWGuS:ݠ_?M}v屗C!ȍjg4@@b4ΦBԋؒ󛁫gU883܀rMstoY.N1?W`h< w݉(O*[[i&!m9O)%(eLުy2!LS)! A3'~?oHlEZxO2R4Gw` `UڛZÁYqԖ7Sk6PxsXՌ&z͘X哨?˒RMV .9'j(>Rn|SG+ RD~;vdR3GMYVW3J ˭0ʜ7-n=,6sNbgYD,?1 -/SxY]SZ}8KVen.%̛l_ m 6|w1.Uо-4`U~N?s1WGӔ/>HzߒD)dE֚9 tEM uJXK$cO%YY(:%X9Ms7nń&љ%<DNzT5ć-)SVvIPz,MgI!&EVN7P V[fDGiƮB i4D&iāõk'7|#gXͭ,K6(t6LxcobC֧.RGY8cB4& kW)o\?>ru؀2!Bn\\嚃T&ˉ:.s@?ϒ5LrH[~t>"wmJF{34֭NU4!:ʨ5G-̻^/I>[ڐ{WYޝ0;؟wruH?~ Ow <-_Oˌڄ*>Sc#0+&v]^t1)sJUzBӼ>GboI hh2 I2`,dY<2dA&vQ4p*5I ;i-tce*׌}!skmhain}wH_R}KǓayi;֣zBiKFaL0%(SۇtwĊ79w4o4Z!:"#o?kl[;\bp#~e&W>4N*VK52eͪZ̉.zU+PUA2u`W,G"u 6 NB _8jJP(`$x]#H [ʾL4*vB1EF_;mY:kۍfEg&֚-:'*ok5T۲&Vlf lbbq|Jc_GExCpG0#n)}\~e_3EX`l|TJ|[r38\pC 8-2bձ^,#!"iڃ`⩥9wH0;b x,w86_HwH4\=\3[)BaCQg:t̂`Q&)4PʠfZ Px2ȏfel\=Mt!AʎG^֪erj="wtx ٴט4#ϕHSUo~*~21 *B Ga6 63 c#U1T7&[;#Wixޱ]ܺ~S(o~W?D`3,!3q>T=_iEYň͒)^ s[&D; ;_ՠ_Y> W!I\CzQ?knE)~Ca^h#& [՗.p ЮonϝH4Мc{䨄Jv2\8NBmQ|ocmfaY:&'6٘H֤}^E<:&]. ܉K{?zܳT[U0 v3_e,_ul)͑ tj@ I|gƒ{S6Y&@8L\Ai K?)YTxZj9wgpaw:oPں+RMR)D}HJ?0XM Aux&\1~L-\ FɁ1?uy''xVwu;ݪY|} y8Z˟o*|$uYX-c8&%^~oӣzg@3wfx3ҤQxCK9]Bh.fɰr5Wel)ID7W>n}k'侺QEM{ GP5ljj^&6Q,%/t[W/E\.,S璺m=(5< ]3c^C!0ڽBd)|[05,4:uvX/푮r/l.lBz<bT~M߃I\ dCݨo?8ܳZV|M$*W_T<֎YPgJrg1<`=F(Gjs̋-1" +]G ܲz(i*(O=F;/!Z;jz.DgV]R'ۘ@>K">h$9)/Q_WkNlF:׸؂s)o~fw"'IZAYhȁ‚UptX[~&GFFs%/+BïMt.&kQ t(GifC_A. b<0}n?O! gت_Mٰ;;=1 Mdn\fݚUi-N7o:ymZY79í=3|KՄަsuz.Iɜo}RvD *3׏?TeΛ43Q~t%ܯZipR&sjg& ES30ѹb/qW? y_5W#_ʏm]GR)R6V3ml`1Bo;!o 以Ӫ#jjUǰMIbofcaXZ˕ԯPE <04V&a!~atY%KQ{8#tpuɔ9JE3xdK3S'|kfV>U6] {#5F7ZLb|c"lheJ%d\iQLClӨsiPax-mʩbӅI֩ eMlȚ 3.Z3v}Kqi'`!V_ѹ#ltf2̬yFS)c9:Us@u_1=H!-n9UHGʌRa_y+E!. ^iS*FVtW8 _"4MK-zn> &*M!ceuD.5o`l2P'%>p rՋ ոە\Sc> ۃ~Tkw)ieRTNS2Tis]t~[4~2 kض8נxjD2jmXͲm@c@JLuOv_s @{e9'8Ruդ+}6PW=N1|юvw8Ƌ_~iV2f wrG~QB3MkT)tVc8yKީƽˑf`*,3|dIPAQq3kO#ONi{j dyс,"WQS&6=sYEяcpkqGq̃`rIgc:3[e,ݵ=E;T n2&6Dw(֥e°,j@<ݧ+ G+`Sңm 3ϰHZA(8["8HJ/Ii‚^{Gz;@mW$ #2F`LR:r}PҪ;[/=CGHq n_5hiBbDa"sCdk j|ߘg{!ڄ#{y1ɫIK ,785mnzd TJ&J6'g?<%fbEH?y1y+v&U'3m;ܿ Aþ^baL=l3Pb33d##0V ̩CˇY.!FL%VQ?֮ jCU}߉αűa!Dw/[ lD-x*Ȉrx aobC d{ ~wzi%e =| _3&|F. |3%5eR2}c"V0 3#,,ƉP G\6d U{b ]FOI_Nd,AƶՖ/{_~}1N-~ _̨n臚挙_c`k/y(;iRЛǰN E\7 }R)ߞlVl;'ԉЧ2 *A+-Au6|4 Vp8wfȵ89ST6إSAӑToy ,{Ի(IibuTbEaX8_! V)7%RVI\s 0j~< /&p%+~Q">>QqpNby)1ddX Gq# -֚Z:42ĸrBcu"mo'߼@rʓutᕔSsƣ+AIOs_ L`WLi2/UŚ2hmr.SEѲm}sS]~h*$aH(b~] 7Q6dlܼ0ɻV0o(NO3Lnl>ӫi\B~ ;$pv~Ss6N}hfk*BԛOoW)#,a? p5!?WND4E]P5UT/Bc϶jv\6$U-}o*[A9'jVbm!K7QdXX^j N)I*<{ɡrվщ7o^wvUp^gœuuA*䠑qU]ᬃtK"p n\ >r#0/J|o9*0mS:֯bkin1nƇį}#i@O%)UѷO%;a򟝚Ul͹W4=[r1`i'I(xxG 5ւs$iJ֨ݾ keO ʶ-,*ҷ{geՒvuճ#,UɧmƗ:&*v:V`OHqv˺Eq,L_BmK\k9akåa$KØ Q+ghNߔ`峐h0J_/  iv16})6^OgsN^Pد|WK(OS3Zk=spvu!؁;}!jBvw f& {}!TO7sΆM&F2_> O {@R0zk3"@HaXHܙ 3(e-M Q!csa80~ V @ewT<:.\TCvd+!00NvETceܳRkALy<;?\pDB@J_-wh;vFٔ .(I qΙ>Q6K^2pE* \ FlK+ٙw2|ˮY?qMU3ZكO51t endstream endobj 86 0 obj << /Length1 2763 /Length2 17736 /Length3 0 /Length 19316 /Filter /FlateDecode >> stream xڌP .! %]lp'[pwwwww ޜs=꽢 fuղ@A"H/`6>LL LL,(J { ?b l![=D&o[$,̬fO̜,LL\5~; Blb 21G!5K-P oo D4Է( A@{qAcjooɉAҎlk7(퀶@#_20c@(#W;he9`e@ť@KǀOm _@V74[Z[L @VTٞoer^Qdo1;s}<@Bzv k{;;_rheoW~ [!.鬹` 225(. D[f311}dem@gCSƿ+XV-0p[!$ c #`opS`2M@V(C@`HmAM&16dV./ ;9,v6G:-oV`@J_ ? C 2`$T_}moB-A.@`jX_SUYhrZq{}rXX[F(h$74{\w Pl331d !Ue߈"V`ok.vv3d=5 l9mQj(;Q/Q70 F¿Q_`b o ` ~#H<O7ē}ē #H<O7b0*Fʿ$oE_A,#H};Cdk`=1d@v濝@q@VyČYgU@g/bx7[@&$XZ(2 Y!-,HrA1>FKoYG dk r_jß1 &&=B&=?M fi) dj)9 Uk~!ߡ! knV]&yqBn[O٘oY!)Xm!@ eb66v_LfK.?Ɏf qG!_G!vߴ!,Lp;}a71T;8;}H̿mld>Nl$ĩi!\nC[H~\!_@g!ʏ9!Y_]4Ŏj"56 8T5W["TnM1-OQ ;-( osj wݟmUa;$(2m>bec99/VpH>Oч+iyPd;#E'Dy}9s}3:cX"(5Mc%~uTŮO!IJ7x y5t&j3A#<zyگP5;J _FPv0׉`3V 8*CeX*7R7{UiexLlMלsiԚ(3=IQN})$GEv $=K O'BOjee^zTT6-<XW0VIV %wD#iNN}_?sӦ5CGk:@09m;8iw6\8"mz4#E*t3å=L:!hX$׏Jexc-h6jcUڃq]W'Kq- 3Qٵ?ƃ|#ƹL _U%YH+5沭݄L[ QٹRu w|o0XRs꠽ wzM)Ԭ1q3\þlg&D.~Mؽ)m.OjJB︢кKң,2TvLM≰8y[~MDUjJ.%[Ul;$L=1 ׬<ǽ1*}I/\]>giA[s]VĬ&d{⯓:E?]%|oX˙WtudJ ȯH߾gOGC#/a/~r{)¼hRۚD}1R87R͊.(qx-]. 0Fw,>pԘ@=h]~}uj%KПeOLLyl~ggwB/_^Ip 'dLtU N@zwy8wݚ`AҿM>sa2 j]Gx_v~)(xHT{RFeβbf !J5gH2٬O(dѴ"tpR@bF0a䳉kC :]W)9`wlmMyqz7vp EbG/yҒo=0UBLE1P}rsO>*HGdbaM^1/zTR*EL8C*3Brhk* [5\Y*O0WQDKtٳX\ʒtqVuYPԞOn/E|'/׏G_[(jGtj VN"ˉR3զֺ\1lxeZߌZj Pz[UI \k00FAd8dol04Ie~Lƌ|m^]7ӽPScЫ *zՍ䩓: +8\9s}r_bA~1g[%U죯l_JH`3LF7&Ơuf;E!Esآ#D4Qs({^@XWDz\Y1Cv4hj&$DPNm u_!QO?|wƍn2i%PĬ2bXxQ#+1cRBzPunn_Vb.:w- Z/Y)Sq6:L(m #Ͼg=sI7Ae@S/럜&.liTH%.+9Sȭ'O$KA0meVxm^҇2u!jX1#jKMl#rqTĔj-e4%L1#"'BN&ښ5 ỹ#&o9+Sk4>S ) /Տpd7fK}PY;>ՍfMO`@]gQ{7[K$_:⏘LeQuN;-;o@/7OP&'&gjKQv]1E[[ q'i0KuYewq7V6r- %T& bOe`y=W\pN$fS#LoNZak\aצ-FgR/wj +FB?4|`0Q<9?qUdTcFSڶmeJpY'vR$;+t[?~)Fg`qf>cٝj]OPᏩȸϘ~PWQ`657yR5MU^qV3_ F/،fe5,C<9(WrZPjAph_ʈ͛7NFI뺰`uyշhC~ ͟%2UZ28Ř,rIˇW7C٭D88Ę5%:[ rNXQ&?,8Uaܫrd w(Ђ1Gpɉ锲XBƅdWTqw09q~nΩqG4.@-RQ]{uӳ*ƃ ;(&XES/#!~t7yq"~,=~=:{FIKQzFgZbUh8m_o\u:9fEAtiqR73ۗ N5L*Hfv-Pdr8IՆ}nmZw#[q'&GZZ}DzJnC[.я>͎;13Q^XJ JOiϱo` [mp\Z_[!!ctXxS@% ^؆4*Ab~؇8W,ԨsIQ\v*-Oa]1 zߕ=D=K[:B1ǍRN( RlI%13>[WJzGW^`7o"g6W#qIq~%2՚!RADn9n<#fU uoq?1|.(ΈvɐeM{|t3AN4SlF[׳'E{//D)i`}F!< h6HdNTd}]|ꚁ)w4U &CjP*tѤߊI咲9.7u(ri&Gٙ9y\S翓 qq\kF Q3LkҾC:aԑ" !ƷtYc~{(;=mjC@ K{1 ۠Ve!AxR.|^>+4]XaDM 0]gHZJs Y0BR0@N6ƪ :H[LX&` },ǟ OقKn:H9iy!P";2XphEQc 3ΊÿQh(Η6uΐҶzڡ/x4 {E6 Rf k$*Ô#vJ,sYS/f)j lJyуV͞g6_-_T&I'?U/c&3蘣S~BV\}]y雳Tˬ%]rj_fϷ5Ϥi{JDzTU0S݄Tٳ$Wl;O[__WFsQ=)A)rxӟ~ 4Ň.[|)sߗ]W6V\5)w %Krۊ&'Th>[]iN!U b4йu`*ZN zfVdڛOIۥ4熩`ǃl4 Qj{\lq{V8OF310Z4[9M@wЕn6R\Kq\i(^oh2X>%[@(x߅A `. iTiw^"'Kij |%8 3j z@Q5j'w(^ j`2O5jp֪"t+(;RO4S\[aAB{K7,M~m\GtFQ;5zS\'){Q"muXCV|Z#J49 UJԉACO6ʅzL6J\)QxC{աDxI6FM#=Klh~(-W)HO`۶\OI*{vh4鮵q*/Q3vIt!v4ЃoړqbDW nDܘܹfB}:^eA7[3TlЉC[- '^Ɇi3o45z6 D/ؤ? ,Zًq[Q̃z<bPFJ>ۇ$pq *y&= "eOpqK;Rywh$~#ʻTGx\eI[;IMg(X>gJ2GsL0$V 0KcmbSgzq&fy+VޥjdSJ2xbOEp.Ye"}Ҏe,:M~.`)kkr4ePPibcg[Y ?wm@w 3I+Q 'Z'L ]IKg< K.}Ӯv9iaA D $b㹾~9MT$\?s6f@}GvQՆ f3x?zxw^u_:7}]mu)Axq8DV ju.qJBpCʿHU*3_P6ѢUB2AT.M"H&cZTt'9 'i f nS&ZNj-e .8}DR՟-X&s1q)dY"pj7o.8e[;a,U?2[W&6g[?VFąR*3W֫._X j,t{d36◲*:S*qbWHv Xzψ8W0 ހ!MEյRYO}B#ū~zXԲu+W_iĂ;#K,_2IBz_Ѫ8?[kaܴk],BIf(^sU2\s de aI)])%QOZ$wtɛEYۭs{v2|{bxI]G/aXSɊtc!/vz LK1wNMg@m쏆 =~$'EL5үLcxn@oG_5\v".tVZ:ʰ>LݵF>wQ{{f$E8-=ŕFͧ[/fw :l CV~\EceA!kx{  3H7"ƔuǼ`Oozvռ,o"͝^/# hTmT|e[R.FpS3-"r?txE5_fk/o V ߨ~v0{`\IqE=S'bn*?~SˍxZH*zuz`pβQRg. wD,FbW#wJp9JM}HTIWeڟbmi OsYMVjm߹7@S҇h4+0طa|U)?O|-?k&ƍ5IV=ovYD5>NSڭJt+*C:i; uhTc.i 뤤t*@prFzVpA >p񶒸5܃!M Na,lW(hWx[L,, Z kqz-D>"o_01+&jU<қXIsoc ׼Yψ#ӈVu}*ru>}B)?̬wR{U!CDd8yU6$Raz+KpX:;,|qC6;Ɠࢰ 荸ۈPJd(8:`Pz=@+Z cß|!G1 +)_5u^5+W G"`6(e` ڣ2m!ּnOj(*'FPK2XBVwP^2{l!B^ݞ"p~| q ^.ü|V.kOP/Cu6_Qa4  I]F*AO8d(4ѩ:נhfJ 't1|{CE h"JbҷJT;>432zCor;U L_F*k{xv15_H9 };!cmX7.llbHzYGb~BWe|+OJ(0%\(tՖEv-ES IFrIhVskb>gxǼY|d'm&9KQ>WM*WD`R*Qy8 ɓ@5Y%іT~fVB*eF㧞 ]]afs_73IS-LY{whqSqfbלgڊ0;_S 9~$5%_BGTr׌53 RG]oѠ StHEtTYD!;AڷoUĄVzRr~ǰq.Xz\V~]2[$ϬAg Hjd ܖ3hqƪB%ކ-j4/> O`X"oLi5NJ:O$>$eJ[* ٤Iƪ5Ztž^N4)Ӻf"])CUdtfUB%g}}b]:L%0k$43#OfywU})`R00‡Y"N<մi®#PbizR'!ƞ l- ;]*@ ydiTTuFY6Uo(Bo8%kE@3%P0nV|z8SŦÖDeLYBAh/ ;9=f``X`W\_ 5-i߅rT``KӲV5PhzE+;6 !#iq#A@5% R<2jw*֎|O ˡ6ʀu o!Gan S1VEmhCymZ5_ؾu]s6P4{8kݴ wc.?L =PjtVD+YI#TNF+q8r\\)IwSr,\8{2] qY8ц<$kS4@Rc6Jb}_K;ȷzo 1|MdOM.ѯ5:SiF>)ŋT9RZ}KpָoУabC#!P0ahހKgꛋ@l#aCCg ?|i=r]>ɈaD~lRFbvp?<x{"*{< :OH2 !q5 B*0w=&KXlu*.)kg߽W%=!qZ* VlfJ) &0Y|OF=uڦ~!#;Y"%r}S%& q+3 vp'![\UIMWvW"mVU5>CD; +ox:oڅl+".T H$F-@͛Pg3efR䞉i᷎>ChW)0h6hs%t-KK& v-Iq#VAøzEFنe{za>gQo8l[cICRj shg?~3K3˰C rFnz9X6!=h U>Tu;Z z}f*4 `eV ;[|ҹ׍'uE6^J8P߽:c&PwuaLsX ;Wv#z)ٖ/ߝŰ%mZSL Фro& Gw*n\\N"M޾e63Z⭥­+! ];<5Lc(@>Œ+,HJ~ɴVxST8\IIa[H:pV%rvq9Ep6nT\#LFwNuկu?՚,UJgh('$3z<Wqz2Kb&}2=Μl~`ۗpKXOsh^ 05k]7΅iYucoY&62WSZ)DH8q54fެN ޱ^)I,-{omx'_-RWIesP.*hr7"xb `(TOךylPbYyXX;6vmT{Q1N⩭[Nb/1eu`|gDD#f{AU|[58\,LA7qD?\LwܩyC`p5޾m&zK 9Ï\&A+Fw ܘ\2ݎ{ޣ`f?p U ,* )H0Lʕ̭S\НKn`@GKD(W}Jd PX[v#<ztVfy)벤l O!~vD#Lļ/BQ r-΂--Gx_S2Z!N03u#zk[~Ľ' Q_8O߳pt̸KWNZ#YnJ}^;aHmU^r ^b3]tggh[0e'xCS[>.xtMo?0ԭ> Dy i^X>"Voo*οu.vj5+W>V瘽lh,I9V,(mWe#n]Q=/b73L:7}l2vFRY^O(  6iR!pM]`Tpv4\zY݌"EzPs(FG%% &bKn Ns:b 'n.wr>Qt}/n.iS#[2)cG~Qlr#CQlAel6uK_T]| %!Xۭ}eEykHAxN ط:N;h<=KhCNU`x8:@Rxvj!EA}l(W)$9qD+[Lj}OS vow}jr{>-G gҏP=8x& ElWТPƉJ) U_km~/av^b?>g 8G};fP+n2$} KEz5 DW2~uWJ챈LW~¡Ӧ`KUnܞj~,/Òd.6WPNʹ>J<5 eZ=v8cgĝs3xt`c=Q¿~^7c?%l?r?y0}p 4#"PU[mH>r8hKjס1 x.Z#еU_팜{.c(0 S_X*C藾ı$eTAt˷QU2!?(d틧p*Ta-3n@qd Tx7^Y͊eTU 1:05ϑg6`ڹ|Y -'me8N.6UF@n.:diu0SGRzį4+$:JL…ΞIXSSVq#ؿ7<,iQhf3Y8ϨW|qG$'K*>Q=<.wءS5)=*QIıA^3z͢[)2m~0MtҌun7!tVL%"!xy^^UMa m׍@Sz7G8PRLo|ѦǯimymByn ltJo"~_XǝU&WlP3?p%{a,G.vbW7~0ݔ#O"enQmxdF9ԩ5>ϭaצ\8)Tș]\|6}20q q?;)U`vfbۋ(x6&Pd??ģՇ>TNK݅CؼʹEх@[q>8yεwhY-PxStD$,UR{7(qqƂΡ+i2ԭ?TTgV|YM^Ӧ ^*z73[Nq='ۧYoli>emoX&?Qx `=LtdILV&PWK&ާ)!!% Jn*a1g|Gb<oSU;_OK|L7ȿ5?R+_Q'Ɔ޺:VhH)/·[>TbaN[?D ^עՌ#]\/[y ij΀N19|&$zh$ު@"ReSұyM&jSɏLD$mFi^Ʒ*-iZjL+Ga\6 BgqڍOZ>ܘa00i&l^- ɽpݮ Eq^ zט3/ ^x<%LY)^Uҽ$5p6~Ѽb]{2u[#gOfNӫ4J] =韥>? } E2L㟸FO|M+yGtš^`!01\ γ ˒Ȟpi_HDE˟;'y%/ 9"(1d1TsPFP&cߪR~ 6 4Pe,[&IzykV m˽Z,U4csn2{,&:Ӈ V)(إa֎^3=֞=|Xs3C%tJpTS0ʢlF񸚾z3{ em;Q}ȵ*W۠ X#k9 `6~J7ˢGPͪ4pd|ĠTGeÓ>}u4'~K6)cVK&4Jwx,n5BYZ Ⱈ_0K='uu)"-IR̸r$c;ְHpb$ qu z*\-e>C*v<>IyU#֢|ɰTRʽA&ot:S A(:~˓]#w 3ۤ4dR:k_i{Ŧ5ܞhX ;,{UȁRoE#šAtjNU8c Jhcnd.ޤ.hj\р!9O-f/ sxBb=gqH.!3~8s[;i~]A͙-۳ &XцX[tC,/YڷO`1:: P&7VqΥ+эZ2LE+Ns SWfjd2 L;$pAR%G&Rq':?^WZŢԱ8ͫ?8pZϠTH h)8[*W_F ݳP1qǏFYmvT@?j΄C쇛-_"}`uSWv$UΘ C R_X" B[wM~p|pΆ$/ ?{eeY32a6kX./;q?n}ϓa, 9jAgKe<%;"Dէ(0xӍKS|o꺟 SejM2 7y{k''EHO*ԜV#IJ}ZYc#3g0]+Da[r1 oʳeKZn!y5gV>ݛ-DGHѷ\ F!-ms9wG1jyBS\ pD_ ,~\PuBjf&-f|5 , zu?hi8Z׊ep+r8P:%Zt.~, zk½X^$I-sZ-Ni&w*|tiJ@sp1ml) ? \$fi[\՟=E|T7sq׵G*gi]:4l__0O=Ebl2>dl>DcDc>M*$\p [* P1hC(Z~},~cQI |T@;*>岬M0sZU  >g#ȴⷽ`DA|hxTB8'WiЋCb2l`kˬƣ/擥.H4qh[}ϣ9\<PlR tЊs.q_(*%tU`ZIҚDaTD {pFHl^huErF ߻JO# endstream endobj 88 0 obj << /Length1 1614 /Length2 15303 /Length3 0 /Length 16131 /Filter /FlateDecode >> stream xڭctf]%vFŶm'OTUm۶mT\qz۷oq8{a{q* P΅dlcclfe/ bock怣uXۉy@3 `憣;x:YYXbzf:[Y(mlv.!U@%`ne**iK+H%@; @ ge s6ۙYӚ3_,ag1hj7 a tEp:Z9;}X9,\`egjjvs 98 dld[UIL?xXS`o7u1s=\eY9;{_Vvŀ0v2:;tOҽFOV.@sF8ֿ5M]ֶcgHۙXn>7ӿg%alfog 01)ػ- S$"y5_ߡ%\mlm&d`c[+SAY?VV@3%+SK)kW3:X  ,ͧfies hgߩ_Lr*to_]<Rۛ?(""oV37ǏCXk-od?{EܦNNUm?nt h lolR7<)>P֨V\_c]i^4tq(C{4ڋeCՓ . AFWE(ɠ 1B3'ޤA;t?4dnOHi q(M huEIFzn!r`)x}SI]<M?!_8~*xrMm(Eʝjj /k#>=s"Pqɰp$$%T+7P ]|0 &oǧ&%3D9Mjm -IJ<f_x ZmWp"}4_?C+]B7+iNK=!w ~馩7͵!m^7d ?W.0cÌ5]77 oM)8F)?}!FU #N"URE#GqCPdMPLb`F "m 6=0cv]㽓BK27h#tPq3G`N(=I/m +SzT=ǰN /fe1+d !O q,>3BDzYY_.fjT֫џe?'D9b?H-`i?4*xO=T%}_=ytuc\QX.oW{\K!z {ߩm%&)T9Ke""w LXN! ȪEҤ - lX(|T6%Miޞk|%W;:ྋɻ%@`Djf٦_*P=N?bH&Z"Ǭ%F64)D6mˢ$HXipesmN'/@Ev׽u02 j&]#a=4^O<8)pt:؞#A9o"}ȐT0!)CZDbiҊlS 6 CSeLTIL;M=?ӤF߄&#!ɤĮg O j<Hk\،lMû?u":N 3鐗T^;ܙX,k )jeNZ;aӓh|LijTf@BZ#p<5yö]KQ׿5 Ü]#YtMy$q?-e|+E YgW3qv~ۏC>Xڤ%9X䝈l^NJrߓsZ d^ҫ@4j* 5*k{[]:q1'sP+ØOo2%YNj'_{ba.6gnC@`1t@~NХWT>5 1K^ "=QPzob\x?8.WKз))*hͩڨǜ$7!D.50$|q4JT|%'OW4߰\~$sƒ;a O);La #ZUcc? ]ߜ@D ]#מkk̬)꾘{p%>gْO]vF)ol(!h>,-JH!`w 6$œ8CZgj 6(g8YfA@j>oIN6Y\Gm;ו{+HqB| (WDE6}ocAf~eT8[J*A\Q]y##﹖r+5Ө˛-{6Wo|޻(!fᴚЉQ B& ةץu@^Gu3 r70c-6|ҩx|yR+IC_ idBbrQ %1[1nKV_2PێV#Fht,.bS2?{`5q?oUe_DS|<#UCis9p~d(\?d g&l?w %xyA`Oųӱn;!}/=^, .CSdY# oh7<dVFW x(R.͆,4?=mZLwFʝ3O%1|s2iՄ#E"W6 ~J+a|YGu063U5RH⯂JxB+O0H~v%|>9a>N0VXiFblMeVmUN, _\#6i|vƟUl٨܇Mk{C~TT=)I X /r1+ST+뼕zEEY.PR1/LiߴTU}X*諜 *DŽ{çnxW܀H&F"GW(1XL~%8u;%džLzZY$RzjYy=v]6bS!֧- އ5U^*H\LMpގ8\4㏋vl`eQ*g vD,h3±f8MaB)`>y(,M:r@<+U+bF~yn?C3S7=[g늓 cc-_mXlr|P``̝A%*p#H#HAQAJtZl=ဢܬ| ]U^8zTy ᗖ$uY_z02)-EtR)j9\u(MddeԭbĴ#O!'i3EhPT! K8 V{T55s dg`iUrϚ>S 3܊u:RLGHxk>ǞqUfSxwͷ%`1tϘ ֵ>-nl^StsaV Z )LmF?ۈգQi@ymE02WI])+S],=/,~OeK8V/*]PƞRCW#Z0QS-|9M9eŒvs LC8]:=.A7`KQ*B|=푊챉{0lg䨩ò:ŏIU7j,z[b;~S/3Xb< S2 ]ٱRL(Y3X-ZǎXi+wZtD$/y=NiLO =64ĤYE!#vrػG;$)aSMcH'"gBs'>LwLS &~lВˉdH@Hq$e&DBS$QlỲ7BomvS~l QB.m`e,2ET$= .2ҐX`dߘ&^ Sur9Hehfgi$q%Is*ώ'ݒ`S:_ ZCDG9`#W}`yc(_ Fy},)Jx:ir21{_P#BU$7;D@ց΀I08@;ԹFu#Mt_+ۣђb%0.'Qj?}%I!KzUdXPI:OoWYMz -oPOE2J|w‡^ Nq+nۧ25$pȍ0` $oYo.!dq|U:G?OLmʴ(?b#[:NC1{Q̥kJZk2ӨB}´=F&9,_K>*uc6رiiL UPwv&7R6ldYSAu3Lul'ۤjǣ;rml-W ˱W\!9YuWۄhVwG+tUz1 ;εfDA5}%NLIKGD9K@ph f,(49FB* .rYSB}v$_0{ʻ7o7;^&%18=q+!k܎"ytÙtQl3_aF[qU̢i1;WF9ʯjyxiqj?V (̅,@>OWmϢN]g끹:1j*,#U-шa7Ǥ.p*.60ϏH}0LYS#!QxA-w#@Pԍ'1qeIÜBZ<}Y-3<+qʅ{at/>ÀEE*;}.@fY{&8$7w;<0Źyڳ}TXj>;f_Xk(ly'ҕy Gy$er[-USa4P;6\ZU *2ʯg􆨛Y[<6[ ':Bϫyc"x!ىv| ~`T0u6~Λdp֊X=(07IVkbLag ssq-DN\!jmm0DLj05uVǙp-*W/Djaiv3EKZ,s_/[3$URsC޺t=n?NۮQ)>DSY)EȔ$!9*q$@M,|0@k[I ajKyqߩܿwAgXۢ2E qZrx5)Z8SRHصJ _e}"5ZJ|JAP"'N5׺rlVZܩ[RqO{DIXg;qUօ 7D" (I<CwDѢ!WGlǪn]hLdQ ,( ΟsGuv9PWL9 ؾEfU8 :#z ~zP)ZF A;G 0Huti2cݰix zpb9~6X6!~PE`M8n mW%JARb+^ǯ4*tN0Ʌ.U!ickW3ڀ.5x%e9Kk&͇]u!Go0-+L \5N{;֊Nhd-S EF>\ʯFzWjcZZĪ1CQ|H_L3#cԐ1}GՑ % 75?4t:}򓎇si'ԅAA^˳[NG^ْu۷Uّ^h46["ւjtv&`^Ynk*DqauKF'?9,B!'v+J4o PF4Z2W8=(0HdtnWPOQH_p)9Mb>7\(MR>`, !hqMTGаH a;.Rl 'YꖢfZqÚ#yBنm%&9;hO>KPqbGO;AV}T߷&OFnb49 ,gsgz~Hb"l%}w&?jEwp|/喆Ka?cN|+f#BaDž#nŎ M=6^ .ABd#1/z~(e|'Je&tϊ@YNrUP`.'ipyr5S]䏥ɗ ګt/:rCpp7`~= v+-旋^@6!B݉O)c^>1esb2ZMT\(p{uomO$ ce;4Qȁ9+Qd 4j:VznPW7_?Vio&C/1KH70]JefMO!NٮK@PUZ \U:7dO%k#k<-|N&] տz$Kkfk!M녜".k0VL%{>ٵ 𸽻H4 T}ۈ\#7,K_Nx54ؗO.dQfgvEFAήt>`ʌ{b5ob^ヒ$ TdMMUIGTXC+M@l13߆YH(W?ż+?բG}^&XbC(_k 1_b"eSlqMS6.?:"Ii q 5b*5b# 8ejGb"75;զV\i#0FA%".ک 3Y:nGUDL&ƅ.z{L5pƮWNS鋲op jGـ\Fzg*g b¤Rd)#Ƌ5İөPIQ[;MLa7bq2MP&PL'b'.6sz~>}xǣ,m 'Y8'@GS>YoZ`%12lu3jQmPhi0") o^4ۃꍱh!ؔh*!R % Pq71CedWTI1k8]|飺H-R.%$nHH6i! ڕOӉ1Qm^Gi8SA L;]:`WA>+[ b ~I-β J[$\ {Jo|aߣ[{"ڵLmvwIR I{i=%ӹS6ߵm'6+ZD9MdJys1+%@sJ[M$L 'XM:h"@B , >Z2slhliE†RpH'¸z%"j"W:b(&JKMj[]6Msw7{y2&)oX8Zػiz)R J=5;rM!k;#?ޞjۭd1FJ&q'RLo|1&?$p`_ Z%z)ul0yd`aE&)4C꒨B6.8|Ա4 c}\[1rEڞjA  ~>bMqS /vN&-.YOS\DXvG%~Go]4u~:CW \Fo&8oRU;dHN >\;柭\8[AY*|mtmfX ܘ dĽT%hbMMt:2 n`Sy,3mFWi窥zJع,CFw6+%)270z"Z1~  =4.W8y;v5|NɤF{P;qC1!]\lZ͗Ab,˽P{o MKyL:"3:}W_1 G㢽QfokaUUP@_*AB;zQ{hCABF1XUk#j}Ѳv[5qZ{\SZ?'DíŒEEgِxYy.w, | t8~NzkO^JLQI'|WwY6tJ%Ѩ'm1ҍzcmFa  7Cé/7AN'Cb;Nec6DI2'[)As;ӧ{jUjRc1@a~hsuTCAJWIRZ^vJ:]E~*m v#2N4+UU~M~u*7,5Ѭ!{ow'A#氊RdV6&_m 4=D ăsi`/CGѷb ‘<#%~̘ϿIp;xE;16g: +Il} Eէ Yo_XT(j(Ǯi΂Yb~{ЗJqU&+@v(hȜ)!;HL1r?O'/e1R\E7q@iy麲LaAi,/񇇸#I;-K#*hdܺ$L ,ЛM:/%#2yEFًgCT>Zz}LiFt) b*~" #UC3PZM/i?BH2L_3nn} x&I2ZKmz!fV@RRǞ-YJʒz9ۂCio q;Ev\% ߚ_֟l@t# /?t"EE$ .w04ʘR\ 'ص]ncZ .H&_8F/-zЗ)$oL1I7F|YljsD["KHEl¯eP{7rY '!L,Ň \& %W 1V8%$;l1LfϮ-(YC'9uBOJ3r8|m ݂ 5y꾊[N62gBY! KP놈,QGW'3 3QIQ822a CazhZ6m) '7aR~;[~&$:w :ˀnwɣ~D^G >u`'>'MWf (GUA᫐\է}XuÛNg-B䋗8R+s[ 261{ )CIR.}E!mV,a(g}P`'kdF 7 غn`9PJL}G1VO/)j_ZwRlAh`jLQr8%fVvm_,ql?QG.TItG iK0 _8K~4@vqH: eᔇ#̡߳ˌɹ(Y&P6)|bL12sU(,]D/ 9*f ǸU W}`|VhLClXMsS?)G'Vwd)}B8`njҢn]bS3.Ik {rcJeTjA.Eߜ]i~$f##`# Ml4bGMD¥X;η6\<=I**N6:Lb뗑rJ#{m\M9Yg`'u2UNY~`Hb#oyAÍ)dA#f ݉Ey@EzGQ>l}A =bpWp#O9+͢qw7Wo&6,=Ɉ; 4p JG *BKiیɒ>b6Phca*(+Aa#xJ༵-NP;X]xXg/E n&$_| 5O~튦`ݡHYo?h˨]ZZAZhA4hxV4}MG KPJ3J{K$k8cME406n5~҆$qSҪhO.>QMDaײ+U endstream endobj 90 0 obj << /Length1 1616 /Length2 21397 /Length3 0 /Length 22232 /Filter /FlateDecode >> stream xڬct]%vvl'}b۶m۶9mNoWcZfլ&#RP434ucg*+X[[)`ȄM -lE M&#33 lghaf AECC_B@/Fe  ,))'Sؚ8X\ -2F&N&TS;G,FvDK `p71-3 `h`v [#kKo__0;'g'#G {g߬ "bN;ӿvF./_\&c '{k;ZKM M;U'vFON&֦0Ls9mfa ϨHښnb>WDP%a`lgk061as@2;HD'kCX[ؘ w @%cEXX{{?H:m_9h$fnb`ld05ۧ&&:&FS10l25J/s)9iMeiN7N*Rd!!;w;;cfp2 _kYgG w߲-|k`Dmeg[? \[uw#e;#` z̼)~&Б&BZ>]*i?RGc}&Wx>$T[]4G e^׋2;`?ՎtK? XI\ H|лP'>?Q8ĥɍ&1MCdbЭ^ёyHbm 3\/͢ğ%g;@A0O9gS M)B؅sN5v8%X^DUpDQ9F _WUZZ C߲."̓"b ӡ#w*)1]UAӱ2MsK)aH l^wwhߺ¿cZe8/7MmqR1]HEXܘ +0|!xPAPϭQAIN,BcSMҧD$X 5iPl )X'ļHA%dc(;e[g a[ zx_s^6UVWhQ^.,ŽU :$nW#zʶ<A,ʹ LSxH! Ur|VtIokO+AfC\.͎#1>b9AҼn򭤋:i/Y"4aGpcvGXYn_0JҘ nr8_c/YtBDy.Ӧ5{ːOV.K,w JbeF Zղ.ꣁ}leR8% _'T~SreH;){08ɳ>6Vrj_ٌ?Ut#]QGRY *5,x Br9 OK)Qd54.-Ɲ=ԟF6>N&2ePlKnZb>ߪ뺫u*2X"yl(^$)kKf^^@`ovG!KO/l22٩F\..Ed>OYS;׎˅b sp+x|:30"g0 ɔUJԁ *YGv69јyHC VD8m0s#Z},仠3^Ϲ$wmjrӈtnhDPOz@6ତʟQbnXT> $ƶuo72%),k"TG!.AÏ'KYa,hߏFD?mh#2h3Jk>9aȢ|\ul'P͔sBJb3VW*?9Pc 4Nq*-rLh{#-c6~YWV ّ*{J.SڔO:Q?yiui&["`>`L㣏Qu?=ˣ[zs E~Q,P q,q3pzZ@oZTnW՗ I%½r3*Ҟ8ÔPH\dE$TAT BzI9.UO2iRDv  ^Fk(x֕ٓ#IuY`uyee_wC]~O(.jU' fΘ's f{)} Bk햮:Z e 8tgưTD^M46 4eܸ'{6~Zp*e*48;KJ$]".wE]8i9|t+D-s{\_{:l`Ejd7s/s*[Uꬬ^;,o!sc"Y>q.[1>xɪeJBCo KGj>hPLz J(.=q?FiϻF)Z2"jI>_6HPG;9i6P^1MOPʋk9B-uR>ܐiWx+Yvqon QѨ"C*0( V MSuVdv;ldO+'I`5h=GiA$]K@;M'$uKFy ; S Ul 2j҆u  6* ;6h{r14[J] l}g[ ߓȜ v3I=~yйXvMb%,?jؘ >lX "7=jHƵjAS0/F/{Db.Úl3"Rq$9K;:tTӸFa*_"(BlT{##wv+P?D^/^0^8 >.u20e%g"߈Q[Yk6gV`m05tW)ܿQ9C u&H"l!*U<͚٨I0y\e?dH(3W°G(,cעx@@ɠyAv"6W/NrqeC l- q60vidK"x)N_j~`T܀Qף (ӝy N񗛒DN{OC-IÝ2{!E;?e_JG[kgBuTWl\Ilڨ/W&{xfh'ld:p:xjfPrA |Kw2؄_OZ$qQ B38?<x"=>;$_Ţq#kR Yʵ ,=k{-4Lj#+urt0\>| RC%D.9.I-O7h\I=ꡀ[Ԩ3;*W(@'< s =T@LViNQc~!"0.!|F_e1gzMfnb2[vz[h q;y0CG}XM|0#$VNɮ (]2HeM7^K#xaqJÎG ۘuwP=p$]FAn֚V@6ldYqKqd-mk zYp:r)p1]5$4Θ{zF),ٿjNpGGhP㎇bd)O` " L9)Gy{)ILS5],6 NOYZ>nq1}XO;p maa)C:?nSBy5 נ&M8bz F9x!m29uggk,䴳B\Oʲ-jg0[0:)q PmN]R+%nDYL1SwP$UeCU= D./ڵ5W  OKVf4ı>`Y}BIhBPaN)zFDPdc!`|kF}fcY S\dDi^d{ h7wWEI:M[$#0S;@`?El[פ!&eō>?h]qd)m|tCbE\M`NO7#L {P*)kU5L⽥˯5#F{1܊=h{;}X_m]GڧI1k$)byw,2dq>RVÃ1rFwqh5FǭBk+>j@e JL\I a@59<d|', GDraOi"n-%VCrZ4d䭭a vʜgm2c=86H=HjOiU&h }(N^MGYl5Ms$7s v[F_ba5pV,| )0HA>Þ9Ywb% Kq!F܊Fxx}xHkH4i+*)RhZ'6"D֍Vk0<>UGaC[:]!| +J򄦿m2x_6Hy5S4 *ߏa##drǽk9҇aԸa*ΐ"@zfg듉ͣdN;ȭֳ #H)J7эS@-. N+wN_ ȯGtLdfη4S xyګ5RƩ~}q2>2D*?T+C`eJJ_qUO[N ) gjoFFD[txTa&R^^Co*S܄D^{^4串d~rN \?)i4LCf=脾PsrOb Olk4O܁ zX=OpnJ9O7E|U pq,eqp q~E'M N'i0`qSQhQ\!jYDW=d2^D`hW4>F*y|Ji907d"g+W}joWjz85w V3=+R- ?kyCJJm_nz^88{G$$ޝWTOD>;2 yCy,S#%K# >5 }ªc:i2Ymb՘~NG"ATV-MW_eͻ ".moJR#Y>P(T(<[$+f$!kjniؖ(ZD>F́ZLv!@ڵ8É||ݡk)>~[8!N_Қ ,o/nh$Bi0^S9zC![~ M2QgeI+6@,u'Ȩ&JTZh<}Ҟb}v7zôK] |lB7GC9gu1fC[?G(IQ 3 Yc;#m_Z| "iNdEH! Oa;[0/?wa/ekZ{%jqjodb*/JVEBd -!jۆ1Iq(5$byΓ:OkcHt:CE,a-nqQg|)S)my$ً]:"4^F(uGHಊh+vfݗY ZGu[b,t|tCGP">λl TjjDn N=/A)Ϯ#gO(bD!ɩ|$Ǡ"߁]B=nw =pT@vmYϪ?=H%ćM>$pfkӆ\^~gdSehO|DZ\u`UM5s &ލX@Z*^*)TpL2R_P 9VYP7f?k->f_ٷ-`m?8l)JsY*N^y2] lcm*P+ъzU? t~ߝ#߯U%i7I?Wz C!Hvױat Y4rgtTڌ 2d&yG똟sN ȴ8w9^4jܬa}) CPˇHUL eMa7m.ˑ - K~`g IfR?:HEMjƺ0RC'TtlM%?;{f땂E /bwrj$ٟ%ܨO  I)lxfB%%tqKf󫥖ScIiAaQikv4H{{,r\ W"DV #vUl?,t-/y8JrAc.fӣC6:'"LՃ)ւUCx?}*4N'4 V)+S.潢9re bm۠wP@ekLF|6Xx MӴsিRq$08`ڑUea)P0ޯ/BYllMlI-p\i1|Z'H49ΙS"b@둫 [F [et uGRBzNR-_nnlN YoQ˜'ybzƤ"3oR U Ac2 4Յf`$%=.R"z?>2 mſ% %њSL#)%pO5)Jqop>㋬Qe I^[{/ϹW3U&^-jIaŏ( jLUqp"%Ԕ/7ǵX Ap-EAȟ] ePg\uL/ Hĉ5=I?ڠ(6 1_Kc 7H#%nsz0\<ٽQ  EP91z Z[He^St4$j] $ݹ$)}d6M[ 9miWyiLA;ԡ[f\U*\L0`2`J_D&,)DmbS1fN y4lkĨ[` e(c`=- 'd{!rKNϢKhީooOZp8ܪ]P}Ixf=P-qҬDP1&grl+6)RSf~8jB*ZH|X/ HT3d ' DLзEk^^XJd9-b8b@Oaj|WzBiֲ\;%T#1yvk67GjS/O>oJrGIWOw ,u g{V2<֋'bJ=U[V&buj&>Get W!Kх /wc!(&It`g;-aYyT羗jlq7y1͜%#w}rhe4_^:dHRK%x,VCy*Gg.s )F|Y iJ` TxVA\UdӦA! -翺n:1Pe7^X HZ"`Ȅ Y8"z]#/ gjg\*:1rL['wI([poL j)mnޞ_/6$(`+BP5LMoTSNNL&_< !i|PkԖhzI@N$6%p`XQ?uʟ7OIJ쳑?8YN>JJo^j;WҚN&*]>_A5K*޿Cl! p\IcX6bB^v˷Q8IxJP7岛+]*Ie}õސ ]) ~U[&XQw'}82)b([,M zIΐ؄vTIߨGm3[ /6hC t.}v vNOhf("b$/C=1t1!7ԧC^D=s?Qf9lU2QW8;Z+̺!Xl-H||oDclaqJ0NV.#_/e#WBƚ"XFC8 Dꋙ>Px_I#w.["_ٹQbM~=yU }M(?T\Cv+sj2D #^ Sj5U4㇐}C)KVYc52ǓKt`ԬTӾ@dٸv?y0iPAcmoo(XS5:_ ]wEܤ=|@y ()1m N e z  zYO$.n xg5Z(*9{p,G2v6_兄p(֟P' _A/?ܳO~_Z}ЊS@VsOegi }䳨Tw uqk~nHrި `C#*iOҟQJ-}G4-N\{mu5>YxK;`PoJ)JҪj*lY?ߟݓҞw`&]N 1ҧh*xVǫDlxQ;s":.vJ$Jل]+.i oB0Gx 9j쇵7ur~AP^۹U!زnI) _vy|98Q;7g:\~2D6'nK1m?]gsAݖ UmfL@Re Pw,m)YV ոyVS b/L8 ֻ0x~m ~*ݚ߉Cébzcqz͐\I|s^աa^ÃC]:VusJ4>ge%nbq+P~!C dܲSI 9 o1>+kv@;g:'G>Bthˌ؎Hi¹]MLhSj\%\t@ÒX_ ,i㧚$FH$^.P֌J$"VQ) W(Ud:INkuacVR[G5ٽ,.Go%h"Q~ 1P> `RA7EŶ] hBz:Tϣr4-5yx*w`?{1H\z΄6,W μh8xr%eBMfrg9htri EگMa[&sfnsZQ.KesVNc8]YEHia֦sEzdۦ"*ͨ`hgZȝ;Q."6leb8uŗ#`ȹαߔ7&kʄY{xiAaK7O Yfh(Mk U}N/otHOEHiHKcRI[8>3#L3zzpq]_,dݭЁJ^S#_ U*A=RF/ /||HjgVJxGpZǑ>|Q֩xT |΀ %쵔Oagl+3`XJ}aGMt?F-m4EDx [1¾"GSr᜸N˦ klL;T&22  UHC*ɩ7BmL<i+S6ɭcs7cs֑'!^{[}DϏX5E vnJ.AaKB@5mŤ2H!oOM3滜1ڦ܏\s B cڋG7"x_SFd>A19j7_Ʉ({K `)P\4?end, фdϼ{0`qd6N;qh'TNe#B8\E D, <Â,MJ:b +?C^jnG$\UlqxK~8zK!L1)rq&_@ve-:̌b s3:b=BEo0oYZC y5%dL HiTX+?E&;ԹŐ!o!@Wޗ`԰^mE@\BGƒsƀsd59){'4 '#8d <^=*:G  e=$(v:]S,rk \WJhp-pܼvئfGϫ_Q./<.qա\? ֤m@VP2g/w`fj*g_5f :d8Z`d͹(zәz] Z'ݶ0k+ Ο̨U?c{i/m>y͙?QFU8'P){PaՋ#9c!xPs-dA'*=Fx15ug o^81RNb5K"R򶦫zQnD<@1%%/k˝KfdY q3AT]–20~RoQvJ?s; ^s>qYD5Y'މ B+Gzx֫E.3/DF@ry%JFM$!Sp^?禎7| /"0\FTB:4@0=Pѹ:$C_xuղ}y*f-O`K[̄=*d2<\Տy:92,ꓟIW*܈;lk Ȅȹك=ۻM'|,.@4@4'aXH.S<]1|ZHo[1vGH+'*2R?&&_ 7([S0pۮPsV.f|ŦrRq`ӷXqa9,=Gbj; "j XvR~kQpCxr/,맢J֧uAkFBI.CYS|ՎCN|h? aT]c` Cꮳ ~l=̠X#P)+^%xhU/:o݃'=jtEA#žxHNaBp{|WNjN<4*}h!(54J MqS>m(/  \ߐ |uٸ;dyIG.ܻTƷͪ/UW9JsWU҅ᑹ8Nѧ'˷#Y}dbD\؂Smx׾?jōeNa'#Hë,(2;Fe~-?X8d|sA>Ɯ Ϋ: Ĩ,`R/[HL_W9M̂5'ER"/4ڳL[OОK9+ KML#~Nf[χf 1l>59,p%^uoa'h ~VhǬ6 r׶}l`vm]~`FjLKon[uq[/ ,ƕ"G(# 'QXrUI˨MܺzNy}{#21WLJt6*Y xTǰȃB@]7SNJ#ي?t˒ϵf8=G LNи t c-%YUq54./ ~2cChfE6z$as$66b*a5+JAbB]\>KGZ zn7˻4ŌF3?!a}X~zmX#wGyVNbB?qǡ@! "umc>hX.ڙr.6QUǂJ 2ii kjIӥ`t/Vewu'F̌dA!B5VBn a&hB  J3 >nٕza\N*髲#Ϫ:X*4ivB#QuPދ5դȓ Xi/*%bs WG_8j&_wptz^ CUx&<3U$Z/< ]E$?[O8ȉؿ#eTLa<`{ % .Ͽ<+R4HpL^ɮА$UA DjWvmY0'XD;99?ۗP,ru2-l(96b;MgUn1lF5h5_7{̪?{`<4p5 =b}#= 8ՉCnG~ϧ\< f1]+U&~XBg /Fe&/ģ1ceDO{~:2eлn(006AurL Ϳb9wz>[ ,VSsVZc[y,OmDr캭D?a{1j( jh]3 jmb>[xo`p3u4M ۞Ek?ܕn U*?rW*U$J)APFz]VbV&#uû*P@ Ս4[ Řݥ9˧?ЇH  X}l0K]5 )uT.F /Ee퓎JpkCCup<\ef=͍D`pR& &|P;+$W ih[1q(xކm0Bs$Á" S$ڜ`d~ЂssOc|{@!*uc}Iq 6x kW\8=n0 Ѵ*OmVoI"@N%I+dΪ4bO@1G;bpK3.G:껦 YDaa3BO.(_l9H߅@;[UtvICR/c-gҩ0Vt E<$ a:^_Ė[FI8_(5[s*OV‘-%&CId zӳG.teI,n^>U6"/wE$eo /-*IsuۧBխ9%Ї'F / 9^:+̶߁_' endstream endobj 92 0 obj << /Length1 1630 /Length2 9974 /Length3 0 /Length 10801 /Filter /FlateDecode >> stream xڭvuX6!HtЍHt  1tt) )!%) ~{s:5gk+<0ШkqHZA0(KnYa0;35# A !. xx܂ )#`~`acc S `|pA`v ( %HWP0˩@Pl` bX jӚ d@n@`r;9=}N+G3(ip B-dU# {"S9`{8)u­r;`t_ 7CpO.sd1sDf g'0_AVfOW4/; kd{q uؐV8:Ry#Fՠ^s;xR W4 6kکwf*V^*Jo;tذp`{p7e(ANOh>sYjP; mW84P-q_R=CIuߏX//b~̧ͳֶ&O$TC̎*9d?_h>>_l0iqVo&,7iN~NP Phypej5QI먋Hiy9?l$Rxv5idI 'HC1MT< 5ύѭee2}>OR7V<)Oae~[{)(MDXY [[.ۘ)) $Lh62 #J`ʯ'6[_@{t ΊuR7iumBa"K/8X w@6C+fIkw14VaXrv=N\(&2P8Fz v{"+Eۍrl>lxF[BPיL~)?+v>^tFyfWl+Lr\_ضJ68`#ZƼaxdz{w[<4:I}uFQY &BوzGF.R΅_"?v٘IVTkQd.Uaƨv3L;1-D&>tB |ڗw2Hh|9! u5+bS$v8GۗzJFDv‹Bqڜ2U阎wxn-W8?wϢ:4oJS.TEFb9;a.wD9N"&VomYN2/)QuN"_O+sSHl֓ۜFr~큭5Rɪ#׌7-# 2BYF2/K3o:n)CImē^BCIB o2U?r,0(nfhB]gB6%&G"jG>02zK9 2@cnP6'Η6T/AcPu;%#s𬔮fm2G2O*MgpqU8'U%},%ЗH dsߩ*!9&&Jmc.,M1y[~bGklrvǠ^jt{ȩO ʮAnHo4G$Ґ3)Lq~ҭ{*91 0i%呍5b u$Ġ>^,ovכ9ڂZ^~pq O< IV_3dS3gY js6ȭPY%BsM&J_)EJbB~f'bF~->Rɏܬ_+u>4-爿Z?$SLSӜ zYx;QyeְجRx+e@o(4aGH Y֫$yoCr^S&,~47@IJu|RBDʴXcD-GDX%uq?DO9燻S2ލsV؜a6gb+y HΩ2pv%'l?/Yk_A?11~HlW SkEݽƎgڸpD7+x/~G~qV{%*ӡA(>P(s}dnhoT鷦 p:\r7ر)^ 6H8D𧳴դF)JI}qne@j%2H]3Yv+rdNسFn+eqAjp!u.B 8#׌y=!"_OUݜs3 m Fw=cwq#B35TN$/?9Zvۚq06*uGF5L$MxBx% %J@BpN:eJ޽9-;-]@]"&tnEHplq&f#O᠍.Fb`x{]-#M}^BeksK|*[{2 _߬m'v%&8M :}M(vl cPZdrWt]uOSL_Rjs_v͡KKFli>aƼؕfWƅ vz_C8y‘{BMJc=nJqr\P}<-u}F|ěxW`4)7?i|B0"yW?H9t?g_F* 4jr0P88X^_U!6 +u-Ԑ&w@)a9% )O՟)Ez /'qqWu;r}~dR@@.r73@UQ:Ʊ {\Gڴp\~^s|&I'>"8,9 ͟U2)&P!;L@*Ͳz.-E#"4UCRVSSƹԷ2Snް &l#2[c wէ.+FP4 x}4{W~T1B@Ewt/rE}P4rc@uiƄGX{QM4q5֯`뜻Ҟwp rU #'}DBmWy->.[-pפ|1pP1 Z8{&l^Pèm(R7.`b{tr]lݾm֜[ҟa/i63CT'W7Mm7~+,fyꄬےkK#qƝ~rZfj1#haK*͜Qh_(^YXOXdSV?=l X?>{~ƨEev%x7w?4t[k~mY =>5&}[<_4C=fF+:>a.N;B'4\/l|J'ʿvv(9Vo<:-@Z8I%fN;I NtQ+ʵh*/ ɏKGdE~O|x<}X\>軗Q|Ys3%ϑ4rzQWDFyT>cLz=)<њ[ UzjgtZQy~gOxM\v):_뒱8dQ(Q[ǚ^Ԓ<\cGP:PE/i|5{8}%;4;̙mx{uk#Db>q:7cP+) ͶdK`ȅ;ՆspLՖһ|=b}2VԳlK)Wa;iH&]N"1dugWDg!&MZY6jPUAGLj1N,d8{NpB I)fVBqƆp;cm(>Tf#RV$mIơbnѶm@KP\ͯ6ԍzIF$ >Ky6kB})zgM*ɤ0R" g"da>d_#ԧ3-wCLuB4\?X8loeloꛭZڃ48'i* д.H=?k£G{2pϸ$m[Jsi;3l_@ʫ?}~W o[-áu4=|xOM"WBOBc KdZ\}z>Ǹ7 Bй ry|ZSm] ulIYXԳW^Zz#9ܑs9}SsAB^Kd%C|6+ iV"MF J_BskRkJiC%4>v)~2?=OFH =FKs3J%ޖ+.֌ ZtNdo_$;p .yS(_2~ECQ%sxE"|t( \| >G?ˤZ| vh%2EI8?*RO{b?蘷^ a)BQoA;yyMAݥ%S|pf~&"i&ϯa8r7FǧsdFY:[hѹ|ݮZ}P'fD u+E2" W2NZ'iY[T@ml~i@\-YHZKL>Z=ͦ%࢏ ,àB`-;zF$6mw% Tbo\f>eJFmq5C5 E&J <δ1>%vS.o}D*]5Mpۓl nW J*?f3{0wzm^bkͱ)Ǽg? LQ6^A$d}\E.~t":gFۋJؕ @Hȝq pla~[p,q?[ۍ£鿓|(-R+.hYqq+uqMnytފ_g)%lYo KNeG'ӣ%vݙ^z19܈H>Nk@,¯7I))V}( ATQ$G.x_~}.]ŕ"j7xFDt9{.l>V"{7BDmNثX^@I1#4l"0|%+?W/E`f'E': &Եh8:ilӽuh3whwhbxYm 'ØBsز;A *9wt1t%Q܁T1c%=10<`5yp,7>[!8fMeVQ92mɊmEU/c64ܚ{#uuHHz՛֍w8QN*n,b_܏뒊 79:WtvD\xn7x"J=qܳ*7'SIOߩK{^{u|\HXj⎔صVHS/P!YRZ1XE"ܬW^4{KN˄?EÝ:B,[">a*^ 7 h:S7)s.9k *ҳxRFhG+W|ǮAY 3J yOj~CF N67A[Q,!5>ƹVѶ~NY䀕 Z9j)-"/Bo3oC y~lQ,2&`Ibf; ]3t1H7-˛vȍ1=^Ck}AF{%2 j6c&I:9kqpǽg. J1՟ȯ){kqٮ0r{+Fʚ#+qR%d?K*IxѾ~'Fv8e_90bݷnV#ڶ͔sn+y Xb;7 5-ba~ժrs﹢.mgc%ʅ7CՄد^vuQ< CoFK?|\@饃u,1!D8..$d !:+\tSIsM%\2%)*AP`KEjM, YOW6! *eSTViPJz7WՉV- :mjmJY8^n˞RH.hna,R$eG tDU\Z/iTzuUuZO.g[W/+3pbʼn0T4U0fBL_mRH NC [XQ=Bۼ|&1V哄dZ8२YɎA)|$qk=NE LѬ̟ڨ.f)wY`jr:%/v ):_mJD0+&\mZLN!} 1cQ:rOުxOXJ %ͰkXgXEQldY]y +6- ",{Qpر <\;4O*~/IŠ\O*ڭQ`OR^FyBS*Jmin [7iu*48wNJ$t偢T$FH-ߖY3=JW,O^CE(| U:f^ߨ=Cv:wJjB.x#6{M~gK6}c?i|T{\{ t?Hb_;tGPQy mVcue[+Uڇ6MIr蟗UHHT7jyi%mq/foo ^1)D5wkvďn|yYNg%;Z+C`U"ځC7)BkHǧϨDim?0{_Jq2{& \B\32U~@(Gm`(.C}[Q'NZ 4j! T;R'D~#T.CU}Z4S[q tMQxˣ5Rw 2{h Vܵ4%af]3} ^@V3Pnr{p^&BQ!,k+*GdL}{mbVmR4tKĒ) 1A A6 @ 8Z ̀Me߷< Z鲰j۲jlry;y=p=ؓ{ V~D&2rB 5m,{Z3'X@FSهi3O(xoǂ"٤^z5u $FPP M)2liz[eg1("5YAh m*7*}@#FSܴI2/RS9$Mhf?[TzZ=]s 瘗wa`HqON# =VtB HH_InR1LhqfaY-^ᛃb[5A5o b4)v%y/ CHU5:)*+ ]D?j:]PZiwJŹ÷+>*O_E"J''bIo{jAs A*"~> stream xڭteXmt0 ! HHK 0 04Ðݝ!Ht|ֹֹEK"jlcp >j(--ydA0h`ϏF uBL`O LLvT֍ <6ܒe$HgbYkca/H>t2-6/Gc\PkW9^4WĚH6gUt{W}_:~ vm1eDҾyP\ G;G>1$IfAer:>?T 5I2]H+J$4h+<5H0 eٛÐɰ2>_iV..^6i /3Dsba:D[| j;lv$X  -腣0WgX^haqS^NYr{~jCICmmiŏ=NO ZNz)obgo[n!g{\_uqVI-E'.UYm++ Xɒ@89hpE*2arɈ4GiK:bʡ^5`S|.#cJQ},/:m؎3d#z^ցȠŀx[ѐٴ3;MHgM5͝<#zC}ijG>.J["TS[rP^7-# V갑C:9WbQGhp5̉$j6J|IN4G964qUs*l T QI=ֶxc.` `G%'0-ՠLt:F'PqM!:Nג-p:C)W =>" ˛s"K(Դ3ub")ᖒ,1 bҧ7SFeeŅ;~DH8 0)<O!dO͋!ӻG]18*9&S/&IHYJf֘V *#CIEqgr[6iU6vCNTw̭0SEAŘc&J}5 MCȁ >2xAE2ji؊s5S½}hIc}6Kb^eǽNtG#SwҜwfV!= a?ivF$5UWA:"o<(W@%aȣAGωp S4zQZE`Bbj {YETK#MY/ fߍS@^Djρ dllPoLE&ak㫤촤Tb5Mhz;g{֖d1ɣ Կ(fxDPv$3_,F֢~[znwN71P雇 ^KzMQv(CaMqSd[+;VC⼷'3Vŧ_hU1Z*7fߐPQ̱ pon21pil aNNnfzHJ+m#“4ǾOkR$ֱ)q#022^3K0-;)yUōx|pzb#d389T) nPAN %YU} =8!g1秏{ˑxn꤉*O7F1:Y ((7n;2+L&W8x> '%0.qyNvT+1Pbr 6nDVN6͆p'()P*^Hʮrx8`7yr Aؕ "PCtXzJg3ba6 .gQҒ9lz Y&1'c4En %CYFl>m`ɜ7.9o]ě‘7<̚v/γ͇=sн d JWZI9_͇a;S.v;֋ԄKGj K]? =y@5~5>%Bp3sa~&6N&DzH܌{D[$xĤ~ghB*kTdX'GN#]8bOtGUƧDlx]]֊Y`Jˉ_]B^/ eMޤ;Q"Dp{Atq܄ظtZNbfL3I%kaΡhaǿhHmفУ|"cci \z^S""7dg/TpknXG5a^qof^'$9Hi TrRd=OhU;+.H|%n,0M,K藴-Co,>Fx=ѣ':\/mV^Ǘ"!'Ng[OsguFHIbK@r=v|e[6D7xmR*x%OӚy嘀|TBJnC5ʗ4]-_׳5566O>~eh~^LϷ0N`xt$3j`gy1;i. U͒dp P]6uK] H`Cwb!v7R1Vj& 1w:j6t#v-ӑ+wg{'U|1σqSXN(=UgbQ o7AwCxdəK5rՆmYT5kK-s(qmMvM(4|Dx~7^+c8٧$8=jF; yȿЮ7끪X=|VYQ ^sL'a-LɯwD^$>gU!wtWzGv5cHۑԡ&(TlQ FQ`)en,U`xl3f?45I]$diJqROOuIe>CżvD%TGw̵lA5v1OvU񜟚l@tA1li n@vi3Zdgh$`'qǛ[UXOZe+YJXjǝ!XhLǫw D~$j@XhF$J EU#"SEeՒbl58Vg=ڕ☻wbcW82?N fJts]Өk "CZ.Ң髓꟭gM,Rk$ d6 mLOե6isH-|0@;qȏM~Y^ l}^QRN U9@HYW9`'j)m145vNΣ줭 %;M*Հm{Gl%_UYg=1s䡼G9AZV ef0҇Yyzc u?*G.ιJaB1g.>5$Tfn\ńb?S;cPܞX sz5:xu(IS n੄>s]c<i6pޭforIK;j0`YhebRt0Tq"f-#X8T{bJŴ8)'YF%c͔932-^$i[wޏ[ ({ Q\NFqQk0@X/F)uJjсXXxѭ!viқ9P]~*W|}Mq#fbl>Wa2Gf{'/+?JBnfY:Ww] A,RTjwsw"[p>VѲes# IKy^d!ὒO= RC_̔W`>Cpث֒˔ɭCqP^O1I9Ӣx=`cClk s%=;*)~mYɿq+4TiNd~ܧWE^>;w>) wk469H{E~PW&`C Ʈ^Z&(㞿hxpósaca[0×wG t/:c&$οG@%EͽSv7C ']"w?Kj2y<=x>QFj}dvCR|(ab!߄P~ԹfS U';/qGѠ/z'L'B͎H;Fb+R.W䥩g9.?jkpi!uy)M.˹f eV\g[R#nQ/@CbRoH yun^\)O*@u"pM@FQ0 e6pH5 "|(*!pwF#(1ÞSAOc?ťl~^QZ#*SZ~ų[`ag%K\D} mQץ%${WVcjeAvmPXePBE_>p}UJ.yTO:y1 !߭/fhӯn2F~*fdoJkEE||E@s!\?l\ AZNNN&DŽ>iⅯ\/!c-h'ܲaGpʇ:`>>kzLbC#z. yj> %!A׉ɹP4~] C;1A31N'Z${ŜR} b:}M%8۞ :*ɒL4\u90:2CXSRўΫӵU|Vqx40e{L%ٺ "~͗;h{/[z1}mJ8) [G> H ~+7:rE)&T\-i2+>7;ڣo<'bZ4;|[Mg}uپK5_bk-X#nɮ&[ ` Q5ĸʲ"M8yTLq/<}p4_ŀ; 1Ʉ0rL+r^~:P/~Er!S,0=~7~'R,v *[5E>f5oԡxE1!F:h$h.ҐE*G!kaΤXw8(?(NgMu# $/ ) KT֙5XO:R &$O"jo~ RкD24w^oq=+'7ռ^D!,P=d 7n!e&+TK.TF|5CoP5c ^5bh킺oc$nA *VV*u* )dCȔ9Xwй4d_Wx>~V% =}͐R#89 skoc{hD8[枰v*4Y[j{WolWܬXPoNF+_^EP)\確BqQK˙F`Y*1ap] ts%M_G2hBRy<w_nGdPZ*Qt*Cn"v{'k?]0 !Gh?SO|CB?W+uq1뜟;K,$=#{CyM-ߎxumˍ7+NPOnnIѼ+U kGVd$S̃; tMǒ {! ywa[( h3 J-yI7 hth[bE-L5t;vrV$ѓװm֋c ^B:VF 2󎻵B PQ0K|0rl\RrMgD86Lk[=+Uq߀ALٟYqU4ʫXGg'-ف}U зg4oK~^ /]r\tsգ$ ,3i|pZ4\,>Tij'P9au Bk/KXz߈ ͢E :ZŏĴXb޾쇟 oOi;ߊr6drnNakSLn~%/Ũf ﷆRTiĝq l6h^-Í=-vy1N82DDWn~TȴǕZ1(o6ċ?nD38Wh|Й~Y !lJWLm;+&hY endstream endobj 103 0 obj << /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.12)/Keywords() /CreationDate (D:20121214145058-05'00') /ModDate (D:20121214145058-05'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.1415926-2.3-1.40.12 (TeX Live 2011/Fink) kpathsea version 6.0.1) >> endobj 2 0 obj << /Type /ObjStm /N 87 /First 674 /Length 3209 /Filter /FlateDecode >> stream xZks۶_cx:8vyΫ-6T߳ )QNɇN1Hg ,bJ0"!_0@>d(L*5hidd4LMsLL d5,fp@ZfL̴d(,jtȱ5hN2/ # 5- K$3 -k Fn`; R*bDi7(5XUYCEdVPv.@ \>$ 9 q faJ a<u|dd0A$8&/*L(18fX n H)8L8m ~osB` 4KD!u DCJ U@^E1Q[C#6Qm!y28B-?eQqV0~v,b@;g]eӬӊ͒crn%YuY -սtVd6&ٴN%j% 4bMB? /Bvq^?s1sk@~UżL3ܱ͝g0O_؇7Ԕ(1{*߽  V.P|<>4T7C4BzRȘmk*@ݮC 3[3|2r±_ZA%ic%2][Q&6m6ݏ(3 eYY>Gnje_j~gZ,VXK&6|!-ZڼޓH\݅#~0J#j-Va!Mnھj >r8X# y !LE9lzfVw:!?ͧO'?_$鼬i A2͊mpQ@meփR&0es â Fd*DF XDCB&562dA5I2f\diRuvtWȵ%^WbFIt Z ݏHp"X ?.„-ÀЩ0BELZ# F­+ЦP V׫Pe^A~U[VY_*s*}oz:c;G?P`K.4BJ ipcY^slD[z6wEشe%@Dε jloLO"k*_'%4-=no?><CbV-惺gj(NΗ]\,mC;45 N(2Rmj|t|!:Ut3/c{I-72Gr~Q͌E JjoO8y\'<=^qZg717,Pʙ~*Zg77G Mi' 84,C s愝1m4房g<hcVS9ܵKSci1$|31O_9aS|̩~>Gmg|F{/ҷ̋aS}/ƼI55?|? sc}߿==xsnشkLq7R|C3?S?/KO Jw4fT5x>r{w @J|wcr-,xEì{UNss:\de_}ݿ~Oy6W;QWj&` [2,Fe1"-ʬ++p1w Oۗ vWzST.NכЮDO,c̆R'^ &tPy5Hy$`{E| U.T'TdU^{GVOݔhh5шk&1]n\ˉ[.=~u읎i?eV:\[1Nח>zb|B8L/,2YѴvj%&c3Y1nڄ p%}̎GM6[M4RplgvOM0)w%7.٘k+m+Wtx5zu)lqf\ LeU{Ӥw6֣>@s{[V[rswkuϚ+R[k8:C.`l8;[XWl[5\bFM1!k駔K-;^́jQM}7Ԝ-/kbյb1ϿY-Lﰺw8U}O(Ɖ}ĥ.E )zٗrRRlO0ׅNID3M^OLs%n ⎽Gux~HN뤬wYrN:JfxWhgaZGkKߵ..3%4n:&?ڥXwj@!Ap:aL/bs n|mL$ײ0jW\ t_|8e"\{6gvįo>M.qϟ'Շ;b[-[ -[-[Z,6{ endstream endobj 104 0 obj << /Type /XRef /Index [0 105] /Size 105 /W [1 3 1] /Root 102 0 R /Info 103 0 R /ID [ ] /Length 257 /Filter /FlateDecode >> stream x7NQ{d` Dܰ$eH5m>t433 >ތj3P 'P P0Z#zh6!`98.h?~K@ C,(B?`aD.nċNDdgs0 eJ>Y$,AaR*+xMV{˞6dw^i)ڔS^[69\%\5H_z?! endstream endobj startxref 122041 %%EOF genetics/inst/doc/example_data.csv0000644000176000001440000000640610526711154016776 0ustar ripleyusersPID,DELTA.BMI,c104t,a1691g,c2249t 01127409, 0.62390966,C/C,G/G,T/T 00246311, 1.31467723,C/C,A/A,T/T 00295185, 0.14557216,C/C,G/G,T/T 00034301, 0.71724779,C/T,A/A,T/T 00096890, 0.36547546,C/C,A/A,T/T 00873040,-1.55914252,C/T,A/A,C/T 00732686, 2.54430278,C/T,A/A,C/T 01070337,-0.47641762,C/C,G/G,C/T 00611474, 1.73689506,T/T,A/A,T/T 00864795,-0.90662058,T/T,G/G,T/T 00918732,-0.31370184,C/C,A/A,C/C 00618784, 0.14475739,C/T,A/A,T/T 01403693,-0.40294393,C/T,G/G,T/T 02032187,-0.30590688,T/T,A/A,T/T 00366659, 1.33851658,C/C,A/A,T/T 00845125, 0.86584499,C/C,A/A,T/T 00298023, 2.18598811,C/C,G/G,C/T 02157282, 0.70348866,C/C,A/A,C/T 00803951, 1.88416610,C/C,A/A,T/T 00882445, 1.88549144,C/C,A/A,T/T 01150083, 1.48282724,C/C,A/G,T/T 02088263, 2.56937805,T/T,A/A,T/T 01287201, 1.91065257,C/C,G/G,T/T 00115092,-0.01537719,T/T,G/G,T/T 02135848, 2.44097283,C/T,G/G,T/T 01533373,-1.79450947,C/C,A/A,T/T 01276862, 2.14057568,C/C,A/A,T/T 00221971, 1.54749874,C/C,G/G,T/T 00861315, 0.24441620,C/T,A/A,T/T 00087413,-0.99468615,T/T,A/A,T/T 01360126, 2.04552409,C/C,G/G,T/T 00556103, 0.28281046,C/C,G/G,T/T 01346315, 1.06237532,C/C,A/A,T/T 01804633,-0.00385481,T/T,A/G,T/T 01011442, 0.48108310,C/C,G/G,T/T 00803557,-2.99053022,T/T,G/G,T/T 00515912, 1.49279556,C/C,A/A,T/T 00169684,-1.23580721,C/C,G/G,T/T 00059120, 0.06400596,C/T,A/A,T/T 00752435, 2.52648644,C/C,G/G,T/T 00788752,-1.36428259,T/T,A/A,T/T 00751486, 0.72759632,C/C,A/A,T/T 00458803, 1.74315854,C/C,A/A,T/T 01419954, 0.63648436,C/C,G/G,T/T 02345907, 0.26442754,C/C,A/A,C/C 00324042, 0.37067176,C/C,A/A,T/T 01371961, 2.61511284,C/C,A/A,T/T 00309839,-0.26442266,C/C,A/A,T/T 01549358, 2.88531831,C/C,G/G,T/T 01897731,-0.23598921,C/C,A/A,T/T 00965366,-0.67902921,T/T,A/A,T/T 01269754, 0.85410931,C/C,G/G,T/T 01269285,-0.96192347,C/C,A/A,T/T 00657099,-0.07227161,C/C,G/G,T/T 00777624,-0.85502357,T/T,A/A,T/T 00091238, 1.25489689,T/T,A/A,T/T 00211292, 0.53930311,C/T,A/A,C/T 00020813, 0.09478948,C/T,A/A,T/T 02285393, 0.88452839,C/T,G/G,T/T 00815154,-0.66684196,C/T,G/G,T/T 00319565,-0.17516960,T/T,A/A,T/T 00790798, 0.24168860,T/T,A/A,T/T 01015630, 0.03949522,T/T,G/G,T/T 00176972, 0.71005989,C/T,G/G,C/T 01010568, 1.96810483,C/C,A/A,T/T 02108774, 0.92269642,C/C,A/A,T/T 00837358, 0.96785641,C/C,G/G,T/T 00839539, 1.84379209,C/C,A/A,T/T 01687654, 0.63713012,T/T,A/A,T/T 00019101, 1.14485949,C/C,A/A,C/C 02216628,-0.63449201,C/C,A/A,T/T 00146502, 0.55917031,C/T,A/G,T/T 02847809,-0.65522345,T/T,G/G,T/T 01090873,-1.23888034,C/T,G/G,T/T 00400579, 0.28825009,C/C,A/A,T/T 00226001, 1.30684212,C/C,G/G,T/T 01374583, 0.77596253,C/T,A/A,T/T 00512566, 0.91477827,C/C,G/G,C/T 00747178, 1.51580675,C/C,A/G,T/T 01076826, 2.26302728,C/C,A/A,C/C 01691633, 1.17669289,C/C,G/G,T/T 00931565, 1.95872322,C/C,A/A,T/T 01633803,-0.16339637,C/T,A/A,T/T 01800352,-1.14332353,T/T,A/A,T/T 00371509, 1.11888267,C/C,A/A,T/T 01005745, 0.06812222,C/T,G/G,T/T 00965355, 2.13453582,C/C,G/G,T/T 00305132, 0.36929628,C/T,G/G,T/T 00436031, 1.40005165,T/T,A/A,T/T 01106474, 0.81117111,C/C,A/A,T/T 00289593, 0.86960664,C/C,G/G,C/T 00493533, 0.93620639,C/C,G/G,T/T 00635052,-0.28131220,T/T,G/G,T/T 00735942, 2.14977507,C/C,A/G,T/T 00531722, 1.72857447,C/C,G/G,T/T 00052969, 3.89732106,C/C,A/A,T/T 00357223,-0.31698610,T/T,G/G,T/T 00266110, 0.77503725,T/T,G/G,T/T 00085266, 1.01225542,C/C,G/G,T/T 00077481, 3.12579289,C/C,A/A,T/T genetics/inst/doc/example.R0000644000176000001440000000254410451014204015377 0ustar ripleyusers# narrow window, few few digits, quiet options(width=50) options(digits=2) options(verbose=FALSE) library(genetics) # Load the data from a CSV file data <- read.csv("example_data.csv") # Convert genotype columns to genotype variables data <- makeGenotypes(data) ## Annotate the genes marker(data$a1691g) <- marker(name="A1691G", type="SNP", locus.name="MBP2", chromosome=9, arm="q", index.start=35, bp.start=1691, relative.to="intron 1") marker(data$c104t) <- marker(name="C-104T", type="SNP", locus.name="MBP2", chromosome=9, arm="q", index.start=35, bp.start=-104, relative.to="intron 1") marker(data$c2249t) <- marker(name="C2249T", type="SNP", locus.name="MBP2", chromosome=9, arm="q", index.start=35, bp.start=2249, relative.to="intron 1") # Look at some of the data data[1:5,] # Get allele information for c104t summary(data$c104t) # Check Hardy-Weinberg Equilibrium HWE.test(data$c104t) # Check Linkage Disequilibrium ld <- LD(data) ld # text display pdf(file="LD.pdf") LDtable(ld) # graphics display dev.off() summary(lm( DELTA.BMI ~ homozygote(c104t,'C') + allele.count(a1691g, 'G') + c2249t, data=data)) genetics/inst/ChangeLog0000644000176000001440000000612012062704574014640 0ustar ripleyusers2012-12-14 20:17 warnes * [r1360] doc/LD.pdf, doc/example.Rout.save, doc/genetics_article.pdf: Update PDF files and create example.Rout.save 2012-08-14 14:36 warnes * [r1356] NEWS: Update for release 1.3.7. 2011-02-02 02:28 warnes * [r1349] NEWS: Update for release 1.3.6 2011-02-02 02:24 warnes * [r1348] doc/genetics_article.pdf: update Greg's email 2011-02-02 02:23 warnes * [r1347] doc/genetics_article.pdf, doc/genetics_article.tex: update Greg's email 2011-01-17 19:13 warnes * [r1344] NEWS: Correct R CMD check warnings. 2008-08-20 19:23 warnes * [r1343] NEWS: Update news file to note new regression test 2008-08-20 19:06 warnes * [r1341] NEWS: Bump version numer up and update NEWS file 2008-04-30 01:05 warnes * [r1338] NEWS: Update for version 1.3.3 2007-11-20 20:27 warnes * [r1334] NEWS: Update NEWS and DESCRIPTION for genetics 1.3.2 2007-09-12 10:41 ggorjan * [r1314] NEWS: - fixes in genotypeOrder to ensure all genotype/haplotype combinations are used. - genotypeOrder<- is now exported 2007-08-21 14:36 warnes * [r1304] NEWS: Move Changelog (not in SVN) and NEWS to inst/ 2007-08-21 14:35 warnes * [r1303] ChangeLog, NEWS: Remove softlinks in inst, doesn't work on windows 2007-08-20 18:30 warnes * [r1301] ChangeLog, NEWS: Add softlinks in inst to NEWS and ChangeLog so these will get installed. 2006-11-14 22:20 ggorjan * [r1101] doc/example_data.csv: Removing executable property 2006-11-11 04:09 warnes * [r1087] doc/genetics_article.tex: Update my email address 2004-12-23 01:34 warnes * [r191] doc/LD.pdf, doc/example_data.csv, doc/genetics_article.pdf: Check in some files that seem to have been overlooked in the past. 2003-05-29 02:27 warnesgr * [r139] doc/genetics_article.tex: - added ld to conclusion text 2003-05-29 02:23 warnesgr * [r138] doc/genetics_article.tex: Updated for version 1.0.0 2003-05-29 02:20 warnesgr * [r136] doc/genetics_article.tex: - Final version to send to Fritz. 2003-05-29 01:55 warnesgr * [r135] doc/example.R, doc/genetics_article.tex, doc/make_example_data.R: - Add R code to generate and demo genetics package 2003-05-16 18:39 warnesgr * [r106] doc/Rnews.sty, doc/genetics_article.tex: - Updated to version 0.7.0 - Made changes to pass R CMD check 2003-02-03 16:13 warnesgr * [r97] doc/genetics_article.tex: - Fixed typos and R CMD check warnings. - Updated version number - Removed 'data' directory to fix new R CMD check warning. 2002-11-27 15:32 warnesgr * [r87] doc/genetics_article.tex: Correct spelling errors and typos. 2002-06-27 18:46 warnesgr * [r62] doc/genetics_article.tex: - More revisions. Hopefully last set before submission to publication review. 2002-06-25 21:38 warnesgr * [r60] doc/genetics_article.tex: - Fixed syntax errors - Some reorganization 2002-06-19 10:34 warnesgr * [r58] doc/genetics_article.tex: Much enhancement, including addition of example section. 2002-04-09 00:49 warneg * [r49] ., doc, doc/Rnews.sty, doc/genetics_article.tex: - Initial checkin of article sources genetics/examples/0000755000176000001440000000000012062706260013722 5ustar ripleyusersgenetics/examples/test.data.txt0000644000176000001440000000434510451014204016346 0ustar ripleyusersPatient ID,Locus,Marker,Genotype 1028022,P53,C1556G,G/G 1028022,P53,T127A,A/T 1028022,P53,T5094A,A/T 1035130,P53,C1556G,G/G 1035130,P53,T127A,A/T 1035130,P53,T5094A,A/T 1090730,P53,C1556G,G/G 1090730,P53,T127A,A/A 1090730,P53,T5094A,A/A 1266053,P53,C1556G,G/C 1266053,P53,T127A,A/T 1266053,P53,T5094A,A/A 1313129,P53,C1556G,G/C 1313129,P53,T127A,A/A 1313129,P53,T5094A,A/A 1317274,P53,C1556G,G/G 1317274,P53,T127A,A/T 1317274,P53,T5094A,A/A 1490037,P53,C1556G,G/G 1490037,P53,T127A,A/T 1490037,P53,T5094A,A/A 1490938,P53,C1556G,G/G 1490938,P53,T127A,A/T 1490938,P53,T5094A,A/A 1554594,P53,C1556G,G/G 1554594,P53,T127A,A/A 1554594,P53,T5094A,A/A 1588019,P53,C1556G,G/G 1588019,P53,T127A,A/A 1588019,P53,T5094A,A/T 1659908,P53,C1556G,G/G 1659908,P53,T127A,T/T 1659908,P53,T5094A,A/T 1726741,P53,C1556G,G/G 1726741,P53,T127A,A/A 1726741,P53,T5094A,A/A 1963357,P53,C1556G,G/G 1963357,P53,T127A,A/T 1963357,P53,T5094A,A/T 1973699,P53,C1556G,G/G 1973699,P53,T127A,T/T 1973699,P53,T5094A,A/A 2089460,P53,C1556G,G/C 2089460,P53,T127A,A/A 2089460,P53,T5094A,A/A 2100343,P53,C1556G,G/C 2100343,P53,T127A,A/A 2100343,P53,T5094A,A/A 2262462,P53,C1556G,G/G 2262462,P53,T127A,A/T 2262462,P53,T5094A,A/A 2525870,P53,C1556G,G/G 2525870,P53,T127A,A/A 2525870,P53,T5094A,A/T 2655839,P53,C1556G,G/G 2655839,P53,T127A,T/T 2655839,P53,T5094A,A/A 2878777,P53,C1556G,G/G 2878777,P53,T127A,A/A 2878777,P53,T5094A,A/A 2881107,P53,C1556G,G/G 2881107,P53,T127A,A/A 2881107,P53,T5094A,A/T 288933,P53,C1556G,G/G 288933,P53,T127A,A/T 288933,P53,T5094A,A/A 3022102,P53,C1556G,G/G 3022102,P53,T127A,A/T 3022102,P53,T5094A,A/T 3058775,P53,C1556G,G/G 3058775,P53,T127A,A/A 3058775,P53,T5094A,A/A 313580,P53,C1556G,G/C 313580,P53,T127A,T/T 313580,P53,T5094A,A/A 3282544,P53,C1556G,G/G 3282544,P53,T127A,A/A 3282544,P53,T5094A,A/A 3335501,P53,C1556G,G/G 3335501,P53,T127A,A/A 3335501,P53,T5094A,A/A 3345731,P53,C1556G,G/G 3345731,P53,T127A,A/A 3345731,P53,T5094A,A/T 3506399,P53,C1556G,G/G 3506399,P53,T127A,A/T 3506399,P53,T5094A,A/A 3509677,P53,C1556G,G/C 3509677,P53,T127A,A/A 3509677,P53,T5094A,A/A 3521979,P53,C1556G,G/G 3521979,P53,T127A,A/T 3521979,P53,T5094A,A/A 3525409,P53,C1556G,G/G 3525409,P53,T127A,A/A 3525409,P53,T5094A,A/A 3528815,P53,C1556G,G/G 3528815,P53,T127A,A/A 3528815,P53,T5094A,A/T genetics/examples/test.data.2.txt0000644000176000001440000003172310451014204016506 0ustar ripleyusersPatient Id,Locus,Marker,Genotype 1214,IL-1 beta,C3953T,C/T 1214,IL-1 beta,T-31C,T/C 1175,IL-1 beta,C-511T,C/C 1175,IL-1 beta,T-31C,T/T 1175,IL-1 beta,C3953T,C/C 1175,IL1RN,IL1RN-VNTR,1/1 1176,IL-1 beta,C-511T,T/T 1176,IL-1 beta,T-31C,C/C 1176,IL-1 beta,C3953T,C/C 1176,IL1RN,IL1RN-VNTR,1/1 1177,IL-1 beta,C-511T,C/T 1177,IL-1 beta,T-31C,T/C 1177,IL-1 beta,C3953T,C/C 1177,IL1RN,IL1RN-VNTR,1/2 1178,IL-1 beta,C-511T,T/T 1178,IL-1 beta,T-31C,C/C 1178,IL-1 beta,C3953T,C/C 1178,IL1RN,IL1RN-VNTR,1/2 1179,IL-1 beta,C-511T,C/C 1179,IL-1 beta,T-31C,T/T 1179,IL-1 beta,C3953T,C/C 1179,IL1RN,IL1RN-VNTR,1/1 1180,IL-1 beta,C-511T,C/C 1180,IL-1 beta,T-31C,T/T 1180,IL-1 beta,C3953T,C/C 1180,IL1RN,IL1RN-VNTR,1/1 1165,IL-1 beta,C-511T,T/T 1165,IL-1 beta,T-31C,C/C 1165,IL-1 beta,C3953T,C/C 1165,IL1RN,IL1RN-VNTR,1/1 1092,IL-1 beta,C-511T,C/T 1092,IL-1 beta,T-31C,T/C 1092,IL-1 beta,C3953T,C/C 1092,IL1RN,IL1RN-VNTR,1/1 1198,IL-1 beta,C-511T,C/T 1198,IL-1 beta,T-31C,T/C 1198,IL-1 beta,C3953T,C/C 1198,IL1RN,IL1RN-VNTR,1/1 1199,IL-1 beta,C-511T,C/T 1199,IL-1 beta,T-31C,T/C 1199,IL-1 beta,C3953T,C/C 1199,IL1RN,IL1RN-VNTR,2/2 1200,IL-1 beta,C-511T,C/T 1200,IL-1 beta,T-31C,T/C 1200,IL-1 beta,C3953T,C/C 1200,IL1RN,IL1RN-VNTR,1/2 1201,IL-1 beta,C-511T,C/T 1201,IL-1 beta,T-31C,T/C 1201,IL-1 beta,C3953T,T/T 1201,IL1RN,IL1RN-VNTR,1/1 1202,IL-1 beta,C-511T,T/T 1202,IL-1 beta,T-31C,C/C 1202,IL-1 beta,C3953T,C/C 1202,IL1RN,IL1RN-VNTR,1/1 1203,IL-1 beta,C-511T,C/C 1203,IL-1 beta,T-31C,T/T 1203,IL-1 beta,C3953T,C/T 1203,IL1RN,IL1RN-VNTR,1/2 1106,IL-1 beta,C-511T,C/T 1106,IL-1 beta,T-31C,T/C 1106,IL-1 beta,C3953T,C/C 1106,IL1RN,IL1RN-VNTR,1/1 1098,IL-1 beta,C-511T,T/T 1098,IL-1 beta,T-31C,C/C 1098,IL-1 beta,C3953T,C/C 1098,IL1RN,IL1RN-VNTR,1/1 1090,IL-1 beta,C-511T,C/C 1090,IL-1 beta,T-31C,T/T 1090,IL-1 beta,C3953T,C/C 1090,IL1RN,IL1RN-VNTR,1/1 1112,IL-1 beta,C-511T,C/T 1112,IL-1 beta,T-31C,T/C 1112,IL-1 beta,C3953T,C/C 1112,IL1RN,IL1RN-VNTR,1/2 1212,IL-1 beta,C-511T,C/T 1212,IL-1 beta,T-31C,T/C 1212,IL-1 beta,C3953T,C/T 1213,IL-1 beta,C-511T,C/T 1213,IL-1 beta,T-31C,T/C 1213,IL-1 beta,C3953T,C/C 1137,IL-1 beta,C-511T,C/C 1137,IL-1 beta,T-31C,T/T 1137,IL-1 beta,C3953T,C/T 1137,IL1RN,IL1RN-VNTR,1/1 1136,IL-1 beta,C-511T,C/C 1136,IL-1 beta,T-31C,T/T 1136,IL-1 beta,C3953T,C/T 1136,IL1RN,IL1RN-VNTR,2/2 1128,IL-1 beta,C-511T,T/T 1128,IL-1 beta,T-31C,C/C 1128,IL-1 beta,C3953T,C/C 1128,IL1RN,IL1RN-VNTR,1/1 1120,IL-1 beta,C-511T,C/C 1120,IL-1 beta,T-31C,T/T 1120,IL-1 beta,C3953T,C/T 1120,IL1RN,IL1RN-VNTR,1/1 1104,IL-1 beta,C-511T,C/C 1104,IL-1 beta,T-31C,T/T 1104,IL-1 beta,C3953T,C/C 1104,IL1RN,IL1RN-VNTR,2/2 1144,IL-1 beta,C-511T,C/T 1144,IL-1 beta,T-31C,T/C 1144,IL-1 beta,C3953T,C/C 1144,IL1RN,IL1RN-VNTR,1/2 1089,IL-1 beta,C-511T,C/T 1089,IL-1 beta,T-31C,T/C 1089,IL-1 beta,C3953T,C/C 1089,IL1RN,IL1RN-VNTR,1/1 1097,IL-1 beta,C-511T,C/T 1097,IL-1 beta,T-31C,T/C 1097,IL-1 beta,C3953T,C/C 1097,IL1RN,IL1RN-VNTR,1/2 1105,IL-1 beta,C-511T,C/T 1105,IL-1 beta,T-31C,T/C 1105,IL-1 beta,C3953T,C/C 1105,IL1RN,IL1RN-VNTR,1/2 1113,IL-1 beta,C-511T,T/T 1113,IL-1 beta,T-31C,C/C 1113,IL-1 beta,C3953T,C/T 1113,IL1RN,IL1RN-VNTR,1/1 1121,IL-1 beta,C-511T,C/C 1121,IL-1 beta,T-31C,T/T 1121,IL-1 beta,C3953T,C/C 1121,IL1RN,IL1RN-VNTR,1/1 1129,IL-1 beta,C-511T,C/C 1129,IL-1 beta,T-31C,T/T 1129,IL-1 beta,C3953T,C/T 1129,IL1RN,IL1RN-VNTR,1/1 1214,IL-1 beta,C-511T,C/T 1174,IL1RN,IL1RN-VNTR,1/1 1210,IL-1 beta,T-31C,T/T 1210,IL-1 beta,C3953T,C/C 1162,IL-1 beta,C-511T,C/T 1162,IL-1 beta,T-31C,T/C 1162,IL-1 beta,C3953T,C/C 1162,IL1RN,IL1RN-VNTR,1/2 1163,IL-1 beta,C-511T,C/T 1163,IL-1 beta,T-31C,T/C 1163,IL-1 beta,C3953T,C/C 1163,IL1RN,IL1RN-VNTR,1/1 1164,IL-1 beta,C-511T,C/T 1164,IL-1 beta,T-31C,T/C 1164,IL-1 beta,C3953T,C/C 1164,IL1RN,IL1RN-VNTR,2/2 1149,IL-1 beta,C-511T,C/C 1149,IL-1 beta,T-31C,T/T 1149,IL-1 beta,C3953T,C/C 1149,IL1RN,IL1RN-VNTR,2/4 1150,IL-1 beta,C-511T,C/T 1150,IL-1 beta,T-31C,T/C 1150,IL-1 beta,C3953T,C/C 1151,IL-1 beta,C-511T,T/T 1151,IL-1 beta,T-31C,C/C 1151,IL-1 beta,C3953T,C/C 1151,IL1RN,IL1RN-VNTR,1/2 1211,IL-1 beta,C-511T,T/T 1211,IL-1 beta,T-31C,C/C 1211,IL-1 beta,C3953T,C/C 1107,IL-1 beta,C-511T,C/C 1107,IL-1 beta,T-31C,T/T 1107,IL-1 beta,C3953T,C/C 1107,IL1RN,IL1RN-VNTR,1/2 1115,IL-1 beta,C-511T,C/T 1115,IL-1 beta,T-31C,T/C 1115,IL-1 beta,C3953T,C/T 1115,IL1RN,IL1RN-VNTR,1/2 1123,IL-1 beta,C-511T,T/T 1123,IL-1 beta,T-31C,C/C 1123,IL-1 beta,C3953T,C/C 1123,IL1RN,IL1RN-VNTR,1/1 1131,IL-1 beta,C-511T,C/T 1131,IL-1 beta,T-31C,T/C 1131,IL-1 beta,C3953T,C/C 1131,IL1RN,IL1RN-VNTR,1/1 1139,IL-1 beta,C-511T,C/C 1139,IL-1 beta,T-31C,T/T 1139,IL-1 beta,C3953T,C/C 1139,IL1RN,IL1RN-VNTR,1/2 1147,IL-1 beta,C-511T,C/T 1147,IL-1 beta,T-31C,T/C 1147,IL-1 beta,C3953T,C/T 1147,IL1RN,IL1RN-VNTR,1/2 1204,IL-1 beta,C-511T,C/T 1204,IL-1 beta,T-31C,T/C 1204,IL-1 beta,C3953T,C/T 1204,IL1RN,IL1RN-VNTR,1/2 1189,IL-1 beta,C-511T,C/T 1189,IL-1 beta,T-31C,T/C 1189,IL-1 beta,C3953T,C/C 1189,IL1RN,IL1RN-VNTR,1/1 1190,IL-1 beta,C-511T,C/T 1190,IL-1 beta,T-31C,T/C 1190,IL-1 beta,C3953T,C/T 1190,IL1RN,IL1RN-VNTR,1/1 1191,IL-1 beta,C-511T,T/T 1191,IL-1 beta,T-31C,C/C 1191,IL-1 beta,C3953T,C/C 1191,IL1RN,IL1RN-VNTR,1/2 1192,IL-1 beta,C-511T,C/T 1192,IL-1 beta,T-31C,T/C 1192,IL-1 beta,C3953T,C/T 1192,IL1RN,IL1RN-VNTR,1/1 1193,IL-1 beta,C-511T,C/T 1193,IL-1 beta,T-31C,T/C 1193,IL-1 beta,C3953T,C/C 1193,IL1RN,IL1RN-VNTR,1/1 1194,IL-1 beta,C-511T,C/C 1194,IL-1 beta,T-31C,T/T 1194,IL-1 beta,C3953T,T/T 1194,IL1RN,IL1RN-VNTR,1/2 1195,IL-1 beta,C-511T,C/T 1195,IL-1 beta,T-31C,T/C 1195,IL-1 beta,C3953T,C/T 1195,IL1RN,IL1RN-VNTR,1/1 1196,IL-1 beta,C-511T,T/T 1196,IL-1 beta,T-31C,C/C 1196,IL-1 beta,C3953T,C/C 1196,IL1RN,IL1RN-VNTR,1/2 1181,IL-1 beta,C-511T,C/C 1181,IL-1 beta,T-31C,T/T 1181,IL-1 beta,C3953T,C/C 1181,IL1RN,IL1RN-VNTR,2/2 1182,IL-1 beta,C-511T,C/T 1182,IL-1 beta,T-31C,T/C 1182,IL-1 beta,C3953T,C/T 1182,IL1RN,IL1RN-VNTR,1/2 1183,IL-1 beta,C-511T,C/T 1183,IL-1 beta,T-31C,T/C 1183,IL-1 beta,C3953T,C/T 1183,IL1RN,IL1RN-VNTR,1/1 1184,IL-1 beta,C-511T,T/T 1184,IL-1 beta,T-31C,C/C 1184,IL-1 beta,C3953T,C/C 1184,IL1RN,IL1RN-VNTR,1/1 1185,IL-1 beta,C-511T,C/C 1185,IL-1 beta,T-31C,T/T 1185,IL-1 beta,C3953T,C/C 1185,IL1RN,IL1RN-VNTR,2/3 1186,IL-1 beta,C-511T,C/C 1186,IL-1 beta,T-31C,T/T 1186,IL-1 beta,C3953T,T/T 1186,IL1RN,IL1RN-VNTR,1/2 1187,IL-1 beta,C-511T,C/C 1187,IL-1 beta,T-31C,T/T 1187,IL-1 beta,C3953T,T/T 1187,IL1RN,IL1RN-VNTR,1/1 1188,IL-1 beta,C-511T,C/C 1188,IL-1 beta,T-31C,T/T 1188,IL-1 beta,C3953T,C/T 1188,IL1RN,IL1RN-VNTR,1/2 1173,IL-1 beta,C-511T,C/T 1173,IL-1 beta,T-31C,T/C 1173,IL-1 beta,C3953T,T/T 1173,IL1RN,IL1RN-VNTR,1/1 1174,IL-1 beta,C-511T,C/T 1174,IL-1 beta,T-31C,T/C 1174,IL-1 beta,C3953T,C/T 1210,IL-1 beta,C-511T,C/C 1114,IL-1 beta,T-31C,T/C 1114,IL-1 beta,C3953T,C/T 1114,IL1RN,IL1RN-VNTR,1/2 1122,IL-1 beta,C-511T,C/C 1122,IL-1 beta,T-31C,T/T 1122,IL-1 beta,C3953T,C/T 1122,IL1RN,IL1RN-VNTR,1/1 1205,IL-1 beta,C-511T,C/T 1205,IL-1 beta,T-31C,T/C 1205,IL-1 beta,C3953T,C/C 1205,IL1RN,IL1RN-VNTR,2/2 1206,IL-1 beta,C-511T,C/C 1206,IL-1 beta,T-31C,T/T 1206,IL-1 beta,C3953T,C/C 1206,IL1RN,IL1RN-VNTR,2/2 1207,IL-1 beta,C-511T,C/T 1207,IL-1 beta,T-31C,T/C 1207,IL-1 beta,C3953T,C/C 1207,IL1RN,IL1RN-VNTR,1/2 1208,IL-1 beta,C-511T,C/C 1208,IL-1 beta,T-31C,T/T 1208,IL-1 beta,C3953T,C/T 1208,IL1RN,IL1RN-VNTR,1/1 1209,IL-1 beta,C-511T,T/T 1209,IL-1 beta,T-31C,C/C 1209,IL-1 beta,C3953T,C/C 1209,IL1RN,IL1RN-VNTR,2/2 1197,IL-1 beta,C-511T,C/T 1197,IL-1 beta,T-31C,T/C 1197,IL-1 beta,C3953T,C/T 1197,IL1RN,IL1RN-VNTR,1/2 1130,IL-1 beta,C-511T,T/T 1130,IL-1 beta,T-31C,C/C 1130,IL-1 beta,C3953T,C/C 1130,IL1RN,IL1RN-VNTR,2/2 1138,IL-1 beta,C-511T,C/C 1114,IL-1 beta,C-511T,C/T 1138,IL-1 beta,T-31C,T/T 1138,IL-1 beta,C3953T,C/C 1138,IL1RN,IL1RN-VNTR,1/1 1146,IL-1 beta,C-511T,C/T 1146,IL-1 beta,T-31C,T/C 1146,IL-1 beta,C3953T,C/C 1146,IL1RN,IL1RN-VNTR,1/2 1145,IL-1 beta,C-511T,C/T 1145,IL-1 beta,T-31C,T/C 1145,IL-1 beta,C3953T,C/C 1145,IL1RN,IL1RN-VNTR,1/2 1091,IL-1 beta,C-511T,C/T 1091,IL-1 beta,T-31C,T/C 1091,IL-1 beta,C3953T,C/C 1091,IL1RN,IL1RN-VNTR,1/2 1099,IL-1 beta,C-511T,C/T 1099,IL-1 beta,T-31C,T/C 1099,IL-1 beta,C3953T,C/T 1099,IL1RN,IL1RN-VNTR,1/1 1085,IL-1 beta,C-511T,C/T 1085,IL-1 beta,T-31C,T/C 1085,IL-1 beta,C3953T,C/C 1085,IL1RN,IL1RN-VNTR,1/2 1093,IL-1 beta,C-511T,C/T 1093,IL-1 beta,T-31C,T/C 1093,IL-1 beta,C3953T,C/T 1093,IL1RN,IL1RN-VNTR,1/1 1101,IL-1 beta,C-511T,T/T 1101,IL-1 beta,T-31C,C/C 1101,IL-1 beta,C3953T,C/C 1101,IL1RN,IL1RN-VNTR,1/2 1109,IL-1 beta,C-511T,C/T 1109,IL-1 beta,T-31C,T/C 1109,IL-1 beta,C3953T,C/C 1109,IL1RN,IL1RN-VNTR,1/3 1117,IL-1 beta,C-511T,C/C 1117,IL-1 beta,T-31C,T/T 1117,IL-1 beta,C3953T,C/C 1117,IL1RN,IL1RN-VNTR,1/2 1125,IL-1 beta,C-511T,C/T 1125,IL-1 beta,T-31C,T/C 1125,IL-1 beta,C3953T,C/T 1125,IL1RN,IL1RN-VNTR,1/2 1133,IL-1 beta,C-511T,C/T 1133,IL-1 beta,T-31C,T/C 1133,IL-1 beta,C3953T,C/C 1133,IL1RN,IL1RN-VNTR,1/2 1141,IL-1 beta,C-511T,C/C 1141,IL-1 beta,T-31C,T/T 1141,IL-1 beta,C3953T,C/C 1141,IL1RN,IL1RN-VNTR,1/1 1086,IL-1 beta,C-511T,T/T 1086,IL-1 beta,T-31C,C/C 1086,IL-1 beta,C3953T,C/C 1086,IL1RN,IL1RN-VNTR,1/2 1094,IL-1 beta,C-511T,C/C 1094,IL-1 beta,T-31C,T/T 1094,IL-1 beta,C3953T,C/T 1094,IL1RN,IL1RN-VNTR,1/2 1102,IL-1 beta,C-511T,C/T 1102,IL-1 beta,T-31C,T/C 1102,IL-1 beta,C3953T,C/C 1102,IL1RN,IL1RN-VNTR,1/1 1110,IL-1 beta,C-511T,C/C 1110,IL-1 beta,T-31C,T/T 1110,IL-1 beta,C3953T,C/T 1110,IL1RN,IL1RN-VNTR,1/1 1118,IL-1 beta,C-511T,C/T 1118,IL-1 beta,T-31C,T/C 1118,IL-1 beta,C3953T,C/C 1118,IL1RN,IL1RN-VNTR,1/1 1126,IL-1 beta,C-511T,C/T 1126,IL-1 beta,T-31C,T/C 1126,IL-1 beta,C3953T,T/T 1126,IL1RN,IL1RN-VNTR,1/1 1134,IL-1 beta,C-511T,C/C 1134,IL-1 beta,T-31C,T/T 1134,IL-1 beta,C3953T,C/T 1134,IL1RN,IL1RN-VNTR,1/1 1142,IL-1 beta,C-511T,C/T 1142,IL-1 beta,T-31C,T/C 1142,IL-1 beta,C3953T,C/C 1142,IL1RN,IL1RN-VNTR,1/2 1087,IL-1 beta,C-511T,C/T 1087,IL-1 beta,T-31C,T/C 1087,IL-1 beta,C3953T,C/C 1087,IL1RN,IL1RN-VNTR,1/1 1095,IL-1 beta,C-511T,C/T 1095,IL-1 beta,T-31C,T/C 1095,IL-1 beta,C3953T,C/C 1095,IL1RN,IL1RN-VNTR,1/3 1103,IL-1 beta,C-511T,C/T 1103,IL-1 beta,T-31C,T/C 1103,IL-1 beta,C3953T,C/C 1103,IL1RN,IL1RN-VNTR,1/1 1111,IL-1 beta,C-511T,C/C 1111,IL-1 beta,T-31C,T/T 1111,IL-1 beta,C3953T,C/C 1111,IL1RN,IL1RN-VNTR,1/1 1119,IL-1 beta,C-511T,T/T 1119,IL-1 beta,T-31C,C/C 1119,IL-1 beta,C3953T,C/C 1119,IL1RN,IL1RN-VNTR,1/1 1127,IL-1 beta,C-511T,C/C 1127,IL-1 beta,T-31C,T/T 1127,IL-1 beta,C3953T,C/T 1127,IL1RN,IL1RN-VNTR,1/1 1135,IL-1 beta,C-511T,C/C 1135,IL-1 beta,T-31C,T/T 1135,IL-1 beta,C3953T,C/T 1135,IL1RN,IL1RN-VNTR,1/1 1143,IL-1 beta,C-511T,C/C 1143,IL-1 beta,T-31C,T/T 1143,IL-1 beta,C3953T,C/C 1143,IL1RN,IL1RN-VNTR,1/1 1088,IL-1 beta,C-511T,C/C 1088,IL-1 beta,T-31C,T/T 1088,IL-1 beta,C3953T,C/T 1088,IL1RN,IL1RN-VNTR,1/1 1096,IL-1 beta,C-511T,C/C 1096,IL-1 beta,T-31C,T/T 1096,IL-1 beta,C3953T,C/C 1096,IL1RN,IL1RN-VNTR,1/1 1100,IL-1 beta,C-511T,T/T 1100,IL-1 beta,T-31C,C/C 1100,IL-1 beta,C3953T,C/C 1100,IL1RN,IL1RN-VNTR,1/2 1132,IL-1 beta,C-511T,C/T 1132,IL-1 beta,T-31C,T/C 1132,IL-1 beta,C3953T,C/T 1132,IL1RN,IL1RN-VNTR,1/1 1140,IL-1 beta,C-511T,C/C 1140,IL-1 beta,T-31C,T/T 1140,IL-1 beta,C3953T,C/C 1140,IL1RN,IL1RN-VNTR,1/1 1148,IL-1 beta,C-511T,C/C 1148,IL-1 beta,T-31C,T/T 1148,IL-1 beta,C3953T,C/T 1148,IL1RN,IL1RN-VNTR,1/2 1108,IL-1 beta,C-511T,C/C 1108,IL-1 beta,T-31C,T/T 1108,IL-1 beta,C3953T,C/C 1108,IL1RN,IL1RN-VNTR,1/1 1116,IL-1 beta,C-511T,C/T 1116,IL-1 beta,T-31C,T/C 1116,IL-1 beta,C3953T,C/C 1116,IL1RN,IL1RN-VNTR,1/2 1124,IL-1 beta,C-511T,C/T 1124,IL-1 beta,T-31C,T/C 1124,IL-1 beta,C3953T,C/T 1124,IL1RN,IL1RN-VNTR,1/1 1166,IL-1 beta,C-511T,C/T 1166,IL-1 beta,T-31C,T/C 1166,IL-1 beta,C3953T,C/C 1166,IL1RN,IL1RN-VNTR,1/2 1167,IL-1 beta,C-511T,C/C 1167,IL-1 beta,T-31C,T/T 1167,IL-1 beta,C3953T,C/C 1167,IL1RN,IL1RN-VNTR,1/2 1168,IL-1 beta,C-511T,C/C 1168,IL-1 beta,T-31C,T/T 1168,IL-1 beta,C3953T,T/T 1168,IL1RN,IL1RN-VNTR,1/1 1169,IL-1 beta,C-511T,C/C 1169,IL-1 beta,T-31C,T/T 1169,IL-1 beta,C3953T,C/C 1169,IL1RN,IL1RN-VNTR,2/2 1170,IL-1 beta,C-511T,C/T 1170,IL-1 beta,T-31C,C/C 1170,IL-1 beta,C3953T,C/C 1170,IL1RN,IL1RN-VNTR,1/1 1171,IL-1 beta,C-511T,C/T 1171,IL-1 beta,T-31C,T/T 1171,IL-1 beta,C3953T,C/T 1171,IL1RN,IL1RN-VNTR,1/2 1172,IL-1 beta,C-511T,T/T 1172,IL-1 beta,T-31C,C/C 1172,IL-1 beta,C3953T,C/C 1172,IL1RN,IL1RN-VNTR,1/1 1152,IL-1 beta,C-511T,C/C 1152,IL-1 beta,T-31C,T/T 1152,IL-1 beta,C3953T,C/C 1152,IL1RN,IL1RN-VNTR,1/1 1153,IL-1 beta,C-511T,C/C 1153,IL-1 beta,T-31C,T/T 1153,IL-1 beta,C3953T,C/T 1153,IL1RN,IL1RN-VNTR,1/2 1154,IL-1 beta,C-511T,C/T 1154,IL-1 beta,T-31C,T/C 1154,IL-1 beta,C3953T,C/T 1154,IL1RN,IL1RN-VNTR,1/1 1155,IL-1 beta,C-511T,C/T 1155,IL-1 beta,T-31C,T/C 1155,IL-1 beta,C3953T,T/T 1155,IL1RN,IL1RN-VNTR,1/2 1156,IL-1 beta,C-511T,C/T 1156,IL-1 beta,T-31C,T/C 1156,IL-1 beta,C3953T,C/C 1156,IL1RN,IL1RN-VNTR,1/3 1157,IL-1 beta,C-511T,C/T 1157,IL-1 beta,T-31C,T/C 1157,IL-1 beta,C3953T,C/C 1157,IL1RN,IL1RN-VNTR,1/2 1158,IL-1 beta,C-511T,C/T 1158,IL-1 beta,T-31C,T/C 1158,IL-1 beta,C3953T,C/C 1158,IL1RN,IL1RN-VNTR,1/2 1159,IL-1 beta,C-511T,C/C 1159,IL-1 beta,T-31C,T/T 1159,IL-1 beta,C3953T,C/C 1159,IL1RN,IL1RN-VNTR,1/2 1160,IL-1 beta,C-511T,C/T 1160,IL-1 beta,T-31C,T/C 1160,IL-1 beta,C3953T,C/C 1160,IL1RN,IL1RN-VNTR,1/2 1161,IL-1 beta,C-511T,C/T 1161,IL-1 beta,T-31C,T/C 1161,IL-1 beta,C3953T,C/C 1161,IL1RN,IL1RN-VNTR,1/2 genetics/examples/test.ci.R0000644000176000001440000000066510451014204015413 0ustar ripleyusers# test 3 allele model library(genetics) library(combinat) gen3 <- function(d=0, nobs=20) { pvec <- c(aa=1+d, ab=2*(1-d), ac=2*(1-d), bb=1+d, bc=2*(1-d), cc=1+d) pvec <- pvec/sum(pvec) gen <- rmultinomial(n=nobs, p=rbind(pvec), rows=1) genotype( rep( c("A/A","A/B","A/C","B/B","B/C","C/C"), gen), alleles=c("A","B","C") ) } worker <- function(...) diseq.ci(gen3())$ci sim <- t(sapply(1:10, function(x) worker)) genetics/examples/locus.example.R0000644000176000001440000000172610451014204016620 0ustar ripleyusers ar2 <- gene("AR2",chromosome=7,arm="q",index.start=35) ar2 par <- locus(name="AR2 Psedogene", chromosome=1, arm="q", index.start=32, index.end=42) par c109t <- marker(name="C-109T", type="SNP", locus.name="AR2", chromosome=7, arm="q", index.start=35, bp.start=-109, relative.to="start of coding region") c109t c109t <- marker(name="C-109T", type="SNP", locus=ar2, bp.start=-109, relative.to="start of coding region") c109t example.data <- c("D/D","D/I","D/D","I/I","D/D","D/D","D/D","D/D","I/I","") g1 <- genotype(example.data, locus=ar2) g1 summary(g1) HWE.test(g1) g2 <- genotype(example.data, locus=c109t) summary(g2) getlocus(g2) heterozygote(g2) homozygote(g1) allele(g1,1) carrier(g1,"I") heterozygote(g2) genetics/examples/HWE_Test.R0000644000176000001440000001207210451014204015457 0ustar ripleyusers# $Id: HWE_Test.R 61 2002-06-27 18:46:05Z warnesgr $ # # $Log$ # Revision 1.2 2002/06/27 18:46:05 warnesgr # - Allow user to specify parameters for the chisquare test. # # Revision 1.1 2001/05/07 13:22:39 warnes # # Added example files, code, and output. # # Revision 1.4 2001/05/01 14:33:19 warneg # # Updated files to use changed PG database output format. The new format is # # Patient ID,Gene,Marker,Allele1/Allele2 # # Before it was # # Patient ID,Gene,Marker,Count of Allele1,Count of Allele2,Count of Allele 3, ... # # This involved changes in Allele_Freq.R, HWE_Test.R, and test.data.txt # # --- # # Modified Examples.R to remove random values. This will allow # diffing current and previous versions of the code to check for # regressions. # # --- # # Fixed as.genotype.allele.count() to handle conversions both when when NA values # are and are not obtained. # # Simplified the class type of HWE.test results to "HWE.test" from # "HWE.test.allele.freq". # # Revision 1.3 2001/04/25 17:45:37 warneg # Fixed typo that caused an error. # # Revision 1.2 2001/04/23 19:39:01 warneg # Updated to use revised Genomics.R that provides "genotype" and "haplotype" classes. # # Revision 1.1 2001/02/06 23:09:44 warneg # # # HWE_Test.R performs the Hardy-Weinberg equilibrium test for the markers # supplied in the input file. Initial revision. # # Revision 1.2 2001/02/06 17:00:26 warneg # # # Added CVS tags to track version. # # # run as # /usr/local/bin/R --vanilla --slave < Allele<-Freq.R # first, get the library functions library(genetics) # get the name of the file containing the allele data file.name <- Sys.getenv("ALLELE_INPUT_FILENAME") if(file.name=="") { warning(paste("Unable to read input file name from the environment\n", "variable '\$ALLELE_INPUT_FILENAME'. ", "Using 'input.data.txt' instead.\n",sep="")); file.name <- "test.data.txt" } # get the data cat("\nReading data file '", file.name, "' ...", "\n", sep="" ) input.data <- read.table(file.name,sep=", ", header=T) # report on what we have cat( dim(input.data)[1], " rows and ", dim(input.data)[2], " columns were read. \n\n") cat("Column names are: ", names(input.data), "\n" ) cat("Note: Spaces and '<-' characters are converted to periods ('.') \n") # make all names uppercase names(input.data) <- toupper(names(input.data)) # check that we have "PATIENT.ID", "LOCUS", and "MARKER" fields. # If not give warning and assume these are columns 1, 2, and 3. if( is.na(match("PATIENT.ID", names(input.data) ) ) ) { warning(paste( "No column labeled 'PATIENT ID'.\n", "Assuming that the first column ('", names(input.data)[1], "' contains patient id. \n", sep='') ) names(input.data)[1] <- "PATIENT.ID" } if( is.na(match("LOCUS", names(input.data) ) ) ) { warning(paste( "No column labeled 'LOCUS'.\n", "Assuming that the second column ('", names(input.data)[2], "' contains locus/gene name. \n", sep='')) names(input.data)[2] <- "LOCUS" } if( is.na(match("MARKER", names(input.data) ) ) ) { warning(paste( "No column labeled 'MARKER'.", "Assuming that the third column ('", names(input.data)[3], "' contains marker name. \n", sep='')) names(input.data)[3] <- "MARKER" } if( is.na(match("GENOTYPE", names(input.data) ) ) ) { warning(paste( "No column labeled 'GENOTYPE'.", "Assuming that the fourth column ('", names(input.data)[4], "' contains genotype. \n", sep='')) names(input.data)[4] <- "GENOTYPE" } # # convert data to 1 record per patient # input.data$LOCUS.MARKER <- paste(input.data$LOCUS,input.data$MARKER,sep=":") data <- data.frame(PATIENT.ID=unique(as.character(input.data$PATIENT.ID))) data[,unique(input.data$LOCUS.MARKER)] <- NA data <- as.matrix(data) rownames(data) <- data[,1] tmp <- split(input.data[,c("PATIENT.ID","LOCUS.MARKER","GENOTYPE")], input.data$LOCUS.MARKER) for(i in 1:nrow(input.data)) data[ as.character(input.data[i,"PATIENT.ID"]), as.character(input.data[i,"LOCUS.MARKER"]) ] <- as.character(input.data[i,"GENOTYPE"]) data <- data.frame(apply( data[,-1], 2, as.character )) data <- data.frame(sapply( data, as.genotype, simplify=F)) ## Now iterate through doing the HWE test and displaying output ind <- !duplicated(input.data$LOCUS.MARKER) namemat <- input.data[ind,c("LOCUS","MARKER","LOCUS.MARKER")] nmarker <- sum(ind) for(i in 1:nmarker) { gene <- as.character(namemat[i,"LOCUS"]) marker <- as.character(namemat[i,"MARKER"]) cat("\n") cat("+-------------------------------------\n"); if(!is.null(gene)) cat("|\tGene:\t ", gene, "\n"); if(!is.null(marker)) cat("|\tMarker:\t ", marker, "\n"); cat("+-------------------------------------\n"); # compute and print the allele and genotype frequencies sum <- summary(data[,i]) print(sum) # now do and print the HWE test hwe <- HWE.test(data[,i]) print(hwe) } genetics/examples/HWE_Test.out0000644000176000001440000000457710451014204016100 0ustar ripleyusersWarning message: Unable to read input file name from the environment variable '$ALLELE_INPUT_FILENAME'. Using 'input.data.txt' instead. Reading data file 'test.data.txt' ... 99 rows and 4 columns were read. Column names are: Patient.ID Locus Marker Genotype Note: Spaces and '<-' characters are converted to periods ('.') +------------------------------------- | Gene: P53 | Marker: C1556G +------------------------------------- Allele Frequency: Count Proportion C 6 0.0909091 G 60 0.9090909 NA 0 NA Genotype Frequency: Count Proportion G/C 6 0.1818182 G/G 27 0.8181818 NA 0 NA Test for Hardy-Wienburg-Equilibrium Call: HWE.test.summary.genotype(x = sum) Disequlibrium Estimate: D-hat=0.1735537 Significance Tests: test.stat p-value lower 95% CI upper 95% CI z 12.15062 5.693194e-34 0.1453560 0.2017514 chisq 145.53000 0.000000e+00 NA NA chisq-adj 123.19167 0.000000e+00 NA NA +------------------------------------- | Gene: P53 | Marker: T127A +------------------------------------- Allele Frequency: Count Proportion A 46 0.6969697 T 20 0.3030303 NA 0 NA Genotype Frequency: Count Proportion A/A 17 0.5151515 A/T 12 0.3636364 T/T 4 0.1212121 NA 0 NA Test for Hardy-Wienburg-Equilibrium Call: HWE.test.summary.genotype(x = sum) Disequlibrium Estimate: D-hat=0.02938476 Significance Tests: test.stat p-value lower 95% CI upper 95% CI z 0.8862823 0.3754654 -0.04267604 0.1014456 chisq 0.6387902 0.4241492 NA NA chisq-adj 0.2351985 0.6276957 NA NA +------------------------------------- | Gene: P53 | Marker: T5094A +------------------------------------- Allele Frequency: Count Proportion A 56 0.8484848 T 10 0.1515152 NA 0 NA Genotype Frequency: Count Proportion A/A 23 0.6969697 A/T 10 0.3030303 NA 0 NA Test for Hardy-Wienburg-Equilibrium Call: HWE.test.summary.genotype(x = sum) Disequlibrium Estimate: D-hat=-0.02295684 Significance Tests: test.stat p-value lower 95% CI upper 95% CI z -0.938776 0.3478458 -0.06681993 0.02090625 chisq 1.052296 0.3049789 NA NA chisq-adj 0.211824 0.6453415 NA NA genetics/examples/Genomics.examples0000644000176000001440000000652610451014204017225 0ustar ripleyuserslibrary(genetics) ### demos example.data <- c("D/D","D/I","D/D","I/I","D/D","D/D","D/D","D/D","I/I","") example.data2 <- c("C-C","C-T","C-C","T-T","C-C","C-C","C-C","C-C","T-T","") example.data3 <- c("D / D","D / I","D / D","I / I", "D / D","D / D","D / D","D / D", "I / I","") example.nosep <- c("DD", "DI", "DD", "II", "DD", "DD", "DD", "DD", "II", "") example.split1 <- c("D", "D", "D", "I", "D", "D", "D", "D", "I", "") example.split2 <- c("D", "I", "D", "I", "D", "D", "D", "D", "I", "") g1 <- genotype(example.data) g1 g2 <- genotype(example.data2,sep="-") g2 g3 <- genotype(example.nosep,sep="") g3 g4 <- genotype(example.split1,example.split2) g4 g5 <- genotype(example.data3,rem=T) g5 tmp <- data.frame(g1,g2,g3,g4) # show what summary does in a normal context summary(g1) summary(tmp$g1) # show what summary does in a data frame context summary(tmp) allele.count(g1,"I") ac <- allele.count(g1) ac as.genotype(ac) test1 <- genotype(c("C/C", "C/T", "T/C")) test2 <- genotype(c("C/C", "T/C", "T/C")) test3 <- genotype(c("C/C", "C/C", "T/T")) test1==test2 test1==test3 test4 <- haplotype(as.character(test1)) test5 <- haplotype(as.character(test2)) test6 <- haplotype(as.character(test3)) test4==test5 HWE.test(test4) # test use in linear model sg <- genotype(rep(c("C/C","T/C","T/T","T/T","T/T","C/C","T/C","T/C","C/T"),5),reorder="freq") "y" <- c(-2.02, 1.15, -0.26, 1.34, 2.54, -1.74, -0.23, 0.34, -0.23, 1.29, 2.03, 0.13, -1.67, 1.23, -1.46, -0.28, -0.75, -0.71, 0.17, -1.52, 0.57, -0.12, 0.81, 0.49, -0.12, 0.43, 0.31, 0.25, 0.69, 1, -0.43, 2.24, -0.87, 0.74, 0.63, -0.32, -0.06, -1.24, -1.45, 0.77, -1.16, 1.07, -0.56, 2.11, 0.32) w <- y + (carrier(sg,"C") + 0.5 *carrier(sg,"T")) summary(lm(w ~ allele.count(sg,"C"))) summary(lm(w ~ carrier(sg,"C") + carrier(sg,"T"))) boxplot(w ~ allele.count(sg,"C")) boxplot(w ~ carrier(sg,"C")) m1 <- c("D / D","D / I","D / D","I / I","D / D", "D / D","D / D","D / D","I / I"," / ", "Other / Other","Other / I", "Other / Other", "I / I", "Other / Other","Other / Other", "Other / Other","Other / Other", "I / I"," / ") mg <- genotype(m1) my <- c(0.58, 0.67, 0.04, -0.85, 0.01, -0.46, 0.93, -0.11, -1.06, -1.2, -0.29, 1.07, 0.49, -0.03, 1.62, 0.37, -0.95, -0.63, -0.25, 0.71) mw <- carrier(mg) + my summary(lm(mw ~ mg)) colnames(allele.count(mg)) summary(lm(mw ~ allele.count(mg))) colnames(carrier(mg)) summary(lm(mw ~ carrier(mg))) ## "Messy" example m3 <- c("D D/\t D D","D\tD/ I", "D D/ D D","I/ I", "D D/ D D","D D/ D D","D D/ D D","D D/ D D", "I/ I","/ ","/I") genotype(m3) summary(genotype(m3)) m4 <- c("D D","D I","D D","I I", "D D","D D","D D","D D", "I I"," "," I") genotype(m4,sep=1) genotype(m4,sep=" ",remove.spaces=F) summary(genotype(m3)) m5 <- c("DD","DI","DD","II", "DD","DD","DD","DD", "II"," "," I") genotype(m5,sep=1) haplotype(m5,sep=1,remove.spaces=F) g5 <- genotype(m5,sep="") heterozygote(g5) homozygote(g5) carrier(g5,"D") g5[9:10] <- haplotype(m4,sep=" ",remove=F)[1:2] g5 g5[9:10] allele(g5[9:10],1) allele(g5,1)[9:10] genetics/examples/Gene.examples0000644000176000001440000000014610451014204016327 0ustar ripleyusers## Examples g <- gene("P53","17q 1009232cM") m <- marker("C-107QT",g,begin=-107,end=-107,type="SNP") genetics/examples/Examples.out0000644000176000001440000002543010451014204016223 0ustar ripleyusers [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "C/C" "C/T" "C/C" "T/T" "C/C" "C/C" "C/C" "C/C" "T/T" "NA" Alleles: C T [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I Allele Frequency: Count Proportion D 13 0.72 I 5 0.28 NA 2 NA Genotype Frequency: Count Proportion D/D 6 0.67 D/I 1 0.11 I/I 2 0.22 NA 1 NA Allele Frequency: Count Proportion D 13 0.72 I 5 0.28 NA 2 NA Genotype Frequency: Count Proportion D/D 6 0.67 D/I 1 0.11 I/I 2 0.22 NA 1 NA g1 g2 g3 g4 D/D :6 C/C :6 D/D :6 D/D :6 D/I :1 C/T :1 D/I :1 D/I :1 I/I :2 T/T :2 I/I :2 I/I :2 NA's:1 NA's:1 NA's:1 NA's:1 Allele Count (I allele): [1] 0 1 0 2 0 0 0 0 2 NA Allele Counts: D I [1,] 2 0 [2,] 1 1 [3,] 2 0 [4,] 0 2 [5,] 2 0 [6,] 2 0 [7,] 2 0 [8,] 2 0 [9,] 0 2 [10,] NA NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] TRUE TRUE TRUE [1] TRUE FALSE FALSE [1] TRUE TRUE TRUE Test for Hardy-Wienburg-Equilibrium Call: HWE.test.genotype(x = test4) Disequlibrium Estimate: D-hat=-0.1111111 Significance Tests: test.stat p-value lower 95% CI upper 95% CI z -0.5773503 0.5637029 -0.3625792 0.140357 chisq 0.7500000 0.3864762 NA NA chisq-adj 0.1250000 0.7236736 NA NA Call: lm(formula = w ~ allele.count(sg, "C")) Residuals: Min 1Q Median 3Q Max -2.3480 -0.7980 0.0920 0.6635 2.4335 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.1780 0.2735 4.308 9.4e-05 *** allele.count(sg, "C") -0.0015 0.2368 -0.006 0.995 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 1.171 on 43 degrees of freedom Multiple R-Squared: 9.329e-07, Adjusted R-squared: -0.02325 F-statistic: 4.012e-05 on 1 and 43 degrees of freedom, p-value: 0.995 Call: lm(formula = w ~ allele.ind(sg, "C") + allele.ind(sg, "T")) Residuals: Min 1Q Median 3Q Max -2.0393 -0.6995 0.1805 0.6005 2.1707 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -0.05817 0.51339 -0.113 0.9103 allele.ind(sg, "C") 0.77017 0.37673 2.044 0.0472 * allele.ind(sg, "T") 0.92750 0.42717 2.171 0.0356 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 1.103 on 42 degrees of freedom Multiple R-Squared: 0.1333, Adjusted R-squared: 0.09206 F-statistic: 3.231 on 2 and 42 degrees of freedom, p-value: 0.04954 Response Other : Call: lm(formula = Other ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.1650 0.2841 0.581 0.5714 mgD/I 0.5050 0.7517 0.672 0.5135 mgI/I -0.7125 0.4492 -1.586 0.1368 mgOther/I 1.9050 0.7517 2.534 0.0249 * mgOther/Other 0.9367 0.4018 2.331 0.0365 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.6061, Adjusted R-squared: 0.4849 F-statistic: 5 on 4 and 13 degrees of freedom, p-value: 0.01158 Response D : Call: lm(formula = D ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.1650 0.2841 4.100 0.00125 ** mgD/I 0.5050 0.7517 0.672 0.51348 mgI/I -1.7125 0.4492 -3.812 0.00216 ** mgOther/I -0.0950 0.7517 -0.126 0.90137 mgOther/Other -1.0633 0.4018 -2.646 0.02015 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.6051, Adjusted R-squared: 0.4836 F-statistic: 4.98 on 4 and 13 degrees of freedom, p-value: 0.01176 Response I : Call: lm(formula = I ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.16500 0.28413 0.581 0.5714 mgD/I 1.50500 0.75172 2.002 0.0666 . mgI/I 0.28750 0.44924 0.640 0.5333 mgOther/I 1.90500 0.75172 2.534 0.0249 * mgOther/Other -0.06333 0.40181 -0.158 0.8772 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.456, Adjusted R-squared: 0.2886 F-statistic: 2.724 on 4 and 13 degrees of freedom, p-value: 0.07578 [1] "Other" "D" "I" Response Other : Call: lm(formula = Other ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1837 -0.5711 -0.0847 0.3322 1.5847 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) -0.2631 0.3806 -0.691 0.4999 allele.count(mg)Other 0.7484 0.2552 2.933 0.0103 * allele.count(mg)D 0.2428 0.2552 0.952 0.3564 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.8055 on 15 degrees of freedom Multiple R-Squared: 0.3911, Adjusted R-squared: 0.31 F-statistic: 4.818 on 2 and 15 degrees of freedom, p-value: 0.0242 Response D : Call: lm(formula = D ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1437 -0.5611 -0.1047 0.3122 1.4263 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) -0.2631 0.3724 -0.707 0.49064 allele.count(mg)Other 0.2284 0.2497 0.915 0.37474 allele.count(mg)D 0.7628 0.2497 3.055 0.00802 ** --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.7882 on 15 degrees of freedom Multiple R-Squared: 0.4156, Adjusted R-squared: 0.3377 F-statistic: 5.334 on 2 and 15 degrees of freedom, p-value: 0.0178 Response I : Call: lm(formula = I ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1816 -0.6107 -0.1304 0.3043 1.5590 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) 0.7904 0.3981 1.986 0.0657 . allele.count(mg)Other -0.2794 0.2669 -1.047 0.3118 allele.count(mg)D -0.2650 0.2669 -0.993 0.3365 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.8426 on 15 degrees of freedom Multiple R-Squared: 0.0799, Adjusted R-squared: -0.04278 F-statistic: 0.6513 on 2 and 15 degrees of freedom, p-value: 0.5355 [1] "Other" "D" "I" Response Other : Call: lm(formula = Other ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 2.4189 0.6122 3.951 0.00145 ** allele.ind(mg)D 1.4161 0.6122 2.313 0.03645 * allele.ind(mg)I 0.7367 0.5159 1.428 0.17527 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.6003, Adjusted R-squared: 0.5147 F-statistic: 7.009 on 3 and 14 degrees of freedom, p-value: 0.004126 Response D : Call: lm(formula = D ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 1.4189 0.6122 2.318 0.03613 * allele.ind(mg)D 2.4161 0.6122 3.946 0.00146 ** allele.ind(mg)I 0.7367 0.5159 1.428 0.17527 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.5993, Adjusted R-squared: 0.5135 F-statistic: 6.98 on 3 and 14 degrees of freedom, p-value: 0.004196 Response I : Call: lm(formula = I ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 1.4189 0.6122 2.318 0.03613 * allele.ind(mg)D 1.4161 0.6122 2.313 0.03645 * allele.ind(mg)I 1.7367 0.5159 3.366 0.00461 ** --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.448, Adjusted R-squared: 0.3298 F-statistic: 3.788 on 3 and 14 degrees of freedom, p-value: 0.0352 [1] "DD/DD" "DD/I" "DD/DD" "I/I" "DD/DD" "DD/DD" "DD/DD" "DD/DD" "I/I" [10] "NA" "I/NA" Alleles: DD I Allele Frequency: Count Proportion DD 13 0.68 I 6 0.32 NA 3 NA Genotype Frequency: Count Proportion DD/DD 6 0.6 DD/I 1 0.1 I/I 2 0.2 I/NA 1 0.1 NA 1 NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "NA" "I/NA" Alleles: D I Allele Frequency: Count Proportion DD 13 0.68 I 6 0.32 NA 3 NA Genotype Frequency: Count Proportion DD/DD 6 0.6 DD/I 1 0.1 I/I 2 0.2 I/NA 1 0.1 NA 1 NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "NA/I" Alleles: D I [1] FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE NA NA [1] TRUE FALSE TRUE TRUE TRUE TRUE TRUE TRUE TRUE NA NA [1] TRUE TRUE TRUE FALSE TRUE TRUE TRUE TRUE FALSE NA NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "D/D" "D/I" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" Alleles: D I [1] "D" "D" [1] "D" "D" genetics/examples/Examples.new0000644000176000001440000002543010451014204016205 0ustar ripleyusers [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "C/C" "C/T" "C/C" "T/T" "C/C" "C/C" "C/C" "C/C" "T/T" "NA" Alleles: C T [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I Allele Frequency: Count Proportion D 13 0.72 I 5 0.28 NA 2 NA Genotype Frequency: Count Proportion D/D 6 0.67 D/I 1 0.11 I/I 2 0.22 NA 1 NA Allele Frequency: Count Proportion D 13 0.72 I 5 0.28 NA 2 NA Genotype Frequency: Count Proportion D/D 6 0.67 D/I 1 0.11 I/I 2 0.22 NA 1 NA g1 g2 g3 g4 D/D :6 C/C :6 D/D :6 D/D :6 D/I :1 C/T :1 D/I :1 D/I :1 I/I :2 T/T :2 I/I :2 I/I :2 NA's:1 NA's:1 NA's:1 NA's:1 Allele Count (I allele): [1] 0 1 0 2 0 0 0 0 2 NA Allele Counts: D I [1,] 2 0 [2,] 1 1 [3,] 2 0 [4,] 0 2 [5,] 2 0 [6,] 2 0 [7,] 2 0 [8,] 2 0 [9,] 0 2 [10,] NA NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" Alleles: D I [1] TRUE TRUE TRUE [1] TRUE FALSE FALSE [1] TRUE TRUE TRUE Test for Hardy-Wienburg-Equilibrium Call: HWE.test.genotype(x = test4) Disequlibrium Estimate: D-hat=-0.1111111 Significance Tests: test.stat p-value lower 95% CI upper 95% CI z -0.5773503 0.5637029 -0.3625792 0.140357 chisq 0.7500000 0.3864762 NA NA chisq-adj 0.1250000 0.7236736 NA NA Call: lm(formula = w ~ allele.count(sg, "C")) Residuals: Min 1Q Median 3Q Max -2.3480 -0.7980 0.0920 0.6635 2.4335 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.1780 0.2735 4.308 9.4e-05 *** allele.count(sg, "C") -0.0015 0.2368 -0.006 0.995 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 1.171 on 43 degrees of freedom Multiple R-Squared: 9.329e-07, Adjusted R-squared: -0.02325 F-statistic: 4.012e-05 on 1 and 43 degrees of freedom, p-value: 0.995 Call: lm(formula = w ~ allele.ind(sg, "C") + allele.ind(sg, "T")) Residuals: Min 1Q Median 3Q Max -2.0393 -0.6995 0.1805 0.6005 2.1707 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -0.05817 0.51339 -0.113 0.9103 allele.ind(sg, "C") 0.77017 0.37673 2.044 0.0472 * allele.ind(sg, "T") 0.92750 0.42717 2.171 0.0356 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 1.103 on 42 degrees of freedom Multiple R-Squared: 0.1333, Adjusted R-squared: 0.09206 F-statistic: 3.231 on 2 and 42 degrees of freedom, p-value: 0.04954 Response Other : Call: lm(formula = Other ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.1650 0.2841 0.581 0.5714 mgD/I 0.5050 0.7517 0.672 0.5135 mgI/I -0.7125 0.4492 -1.586 0.1368 mgOther/I 1.9050 0.7517 2.534 0.0249 * mgOther/Other 0.9367 0.4018 2.331 0.0365 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.6061, Adjusted R-squared: 0.4849 F-statistic: 5 on 4 and 13 degrees of freedom, p-value: 0.01158 Response D : Call: lm(formula = D ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.1650 0.2841 4.100 0.00125 ** mgD/I 0.5050 0.7517 0.672 0.51348 mgI/I -1.7125 0.4492 -3.812 0.00216 ** mgOther/I -0.0950 0.7517 -0.126 0.90137 mgOther/Other -1.0633 0.4018 -2.646 0.02015 * --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.6051, Adjusted R-squared: 0.4836 F-statistic: 4.98 on 4 and 13 degrees of freedom, p-value: 0.01176 Response I : Call: lm(formula = I ~ mg) Residuals: Min 1Q Median 3Q Max -1.0517 -0.3694 -0.0625 0.3656 1.5183 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 0.16500 0.28413 0.581 0.5714 mgD/I 1.50500 0.75172 2.002 0.0666 . mgI/I 0.28750 0.44924 0.640 0.5333 mgOther/I 1.90500 0.75172 2.534 0.0249 * mgOther/Other -0.06333 0.40181 -0.158 0.8772 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.696 on 13 degrees of freedom Multiple R-Squared: 0.456, Adjusted R-squared: 0.2886 F-statistic: 2.724 on 4 and 13 degrees of freedom, p-value: 0.07578 [1] "Other" "D" "I" Response Other : Call: lm(formula = Other ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1837 -0.5711 -0.0847 0.3322 1.5847 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) -0.2631 0.3806 -0.691 0.4999 allele.count(mg)Other 0.7484 0.2552 2.933 0.0103 * allele.count(mg)D 0.2428 0.2552 0.952 0.3564 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.8055 on 15 degrees of freedom Multiple R-Squared: 0.3911, Adjusted R-squared: 0.31 F-statistic: 4.818 on 2 and 15 degrees of freedom, p-value: 0.0242 Response D : Call: lm(formula = D ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1437 -0.5611 -0.1047 0.3122 1.4263 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) -0.2631 0.3724 -0.707 0.49064 allele.count(mg)Other 0.2284 0.2497 0.915 0.37474 allele.count(mg)D 0.7628 0.2497 3.055 0.00802 ** --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.7882 on 15 degrees of freedom Multiple R-Squared: 0.4156, Adjusted R-squared: 0.3377 F-statistic: 5.334 on 2 and 15 degrees of freedom, p-value: 0.0178 Response I : Call: lm(formula = I ~ allele.count(mg)) Residuals: Min 1Q Median 3Q Max -1.1816 -0.6107 -0.1304 0.3043 1.5590 Coefficients: (1 not defined because of singularities) Estimate Std. Error t value Pr(>|t|) (Intercept) 0.7904 0.3981 1.986 0.0657 . allele.count(mg)Other -0.2794 0.2669 -1.047 0.3118 allele.count(mg)D -0.2650 0.2669 -0.993 0.3365 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.8426 on 15 degrees of freedom Multiple R-Squared: 0.0799, Adjusted R-squared: -0.04278 F-statistic: 0.6513 on 2 and 15 degrees of freedom, p-value: 0.5355 [1] "Other" "D" "I" Response Other : Call: lm(formula = Other ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 2.4189 0.6122 3.951 0.00145 ** allele.ind(mg)D 1.4161 0.6122 2.313 0.03645 * allele.ind(mg)I 0.7367 0.5159 1.428 0.17527 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.6003, Adjusted R-squared: 0.5147 F-statistic: 7.009 on 3 and 14 degrees of freedom, p-value: 0.004126 Response D : Call: lm(formula = D ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 1.4189 0.6122 2.318 0.03613 * allele.ind(mg)D 2.4161 0.6122 3.946 0.00146 ** allele.ind(mg)I 0.7367 0.5159 1.428 0.17527 --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.5993, Adjusted R-squared: 0.5135 F-statistic: 6.98 on 3 and 14 degrees of freedom, p-value: 0.004196 Response I : Call: lm(formula = I ~ allele.ind(mg)) Residuals: Min 1Q Median 3Q Max -1.0848 -0.3942 -0.1069 0.3408 1.4852 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.2842 0.6167 -2.082 0.05613 . allele.ind(mg)Other 1.4189 0.6122 2.318 0.03613 * allele.ind(mg)D 1.4161 0.6122 2.313 0.03645 * allele.ind(mg)I 1.7367 0.5159 3.366 0.00461 ** --- Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1 Residual standard error: 0.6755 on 14 degrees of freedom Multiple R-Squared: 0.448, Adjusted R-squared: 0.3298 F-statistic: 3.788 on 3 and 14 degrees of freedom, p-value: 0.0352 [1] "DD/DD" "DD/I" "DD/DD" "I/I" "DD/DD" "DD/DD" "DD/DD" "DD/DD" "I/I" [10] "NA" "I/NA" Alleles: DD I Allele Frequency: Count Proportion DD 13 0.68 I 6 0.32 NA 3 NA Genotype Frequency: Count Proportion DD/DD 6 0.6 DD/I 1 0.1 I/I 2 0.2 I/NA 1 0.1 NA 1 NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "NA" "I/NA" Alleles: D I Allele Frequency: Count Proportion DD 13 0.68 I 6 0.32 NA 3 NA Genotype Frequency: Count Proportion DD/DD 6 0.6 DD/I 1 0.1 I/I 2 0.2 I/NA 1 0.1 NA 1 NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "I/I" "NA" [11] "NA/I" Alleles: D I [1] FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE NA NA [1] TRUE FALSE TRUE TRUE TRUE TRUE TRUE TRUE TRUE NA NA [1] TRUE TRUE TRUE FALSE TRUE TRUE TRUE TRUE FALSE NA NA [1] "D/D" "D/I" "D/D" "I/I" "D/D" "D/D" "D/D" "D/D" "D/D" "D/I" [11] "I/NA" Alleles: D I [1] "D/D" "D/I" Alleles: D I [1] "D" "D" [1] "D" "D" genetics/examples/Allele_Freq.R0000644000176000001440000001121510451014204016206 0ustar ripleyusers# $Id: Allele_Freq.R 7 2001-05-07 13:22:40Z warnes $ # # $Log$ # Revision 1.1 2001/05/07 13:22:39 warnes # Added example files, code, and output. # # Revision 1.6 2001/05/01 14:33:17 warneg # # Updated files to use changed PG database output format. The new format is # # Patient ID,Gene,Marker,Allele1/Allele2 # # Before it was # # Patient ID,Gene,Marker,Count of Allele1,Count of Allele2,Count of Allele 3, ... # # This involved changes in Allele_Freq.R, HWE_Test.R, and test.data.txt # # --- # # Modified Examples.R to remove random values. This will allow # diffing current and previous versions of the code to check for # regressions. # # --- # # Fixed as.genotype.allele.count() to handle conversions both when when NA values # are and are not obtained. # # Simplified the class type of HWE.test results to "HWE.test" from # "HWE.test.allele.freq". # # Revision 1.5 2001/04/25 17:48:35 warneg # Changed to store computed allele and genotype frequencies in a variable before printing them out. # # Revision 1.4 2001/04/23 19:38:20 warneg # Updated to use revised Genomics.R code that provides "genotype" and "haplotype" classes. # # Revision 1.1 2001/02/06 23:09:44 warneg # # # HWE_Test.R performs the Hardy-Weinberg equilibrium test for the markers # supplied in the input file. Initial revision. # # Revision 1.2 2001/02/06 17:00:26 warneg # # # Added CVS tags to track version. # # # run as # /usr/local/bin/R --vanilla --slave < Allele<-Freq.R # first, get the library functions source("Genomics.R") # later this will become : # library(genomics) # get the name of the file containing the allele data file.name <- Sys.getenv("ALLELE_INPUT_FILENAME") if(file.name=="") { warning(paste("Unable to read input file name from the environment\n", "variable '\$ALLELE_INPUT_FILENAME'. ", "Using 'input.data.txt' instead.\n",sep="")); file.name <- "test.data.txt" } # get the data cat("\nReading data file '", file.name, "' ...", "\n", sep="" ) input.data <- read.table(file.name,sep=", ", header=T) # report on what we have cat( dim(input.data)[1], " rows and ", dim(input.data)[2], " columns were read. \n\n") cat("Column names are: ", names(input.data), "\n" ) cat("Note: Spaces and '<-' characters are converted to periods ('.') \n") # make all names uppercase names(input.data) <- toupper(names(input.data)) # check that we have "PATIENT.ID", "LOCUS", and "MARKER" fields. # If not give warning and assume these are columns 1, 2, and 3. if( is.na(match("PATIENT.ID", names(input.data) ) ) ) { warning(paste( "No column labeled 'PATIENT ID'.\n", "Assuming that the first column ('", names(input.data)[1], "' contains patient id. \n", sep='') ) names(input.data)[1] <- "PATIENT.ID" } if( is.na(match("LOCUS", names(input.data) ) ) ) { warning(paste( "No column labeled 'LOCUS'.\n", "Assuming that the second column ('", names(input.data)[2], "' contains locus/gene name. \n", sep='')) names(input.data)[2] <- "LOCUS" } if( is.na(match("MARKER", names(input.data) ) ) ) { warning(paste( "No column labeled 'MARKER'.", "Assuming that the third column ('", names(input.data)[3], "' contains marker name. \n", sep='')) names(input.data)[3] <- "MARKER" } if( is.na(match("GENOTYPE", names(input.data) ) ) ) { warning(paste( "No column labeled 'GENOTYPE'.", "Assuming that the fourth column ('", names(input.data)[4], "' contains genotype. \n", sep='')) names(input.data)[4] <- "GENOTYPE" } # # convert data to 1 record per patient # input.data$LOCUS.MARKER <- interaction(input.data$LOCUS,input.data$MARKER) data <- unstack( input.data, GENOTYPE ~ LOCUS.MARKER) data <- sapply(data, as.genotype, simplify=F) data <- as.data.frame(data) ## Now iterate through doing the HWE test and displaying output ind <- !duplicated(input.data$LOCUS.MARKER) namemat <- input.data[ind,c("LOCUS","MARKER","LOCUS.MARKER")] nmarker <- sum(ind) for(i in 1:nmarker) { gene <- as.character(namemat[i,"LOCUS"]) marker <- as.character(namemat[i,"MARKER"]) cat("\n") cat("+-------------------------------------\n"); if(!is.null(gene)) cat("|\tGene:\t ", gene, "\n"); if(!is.null(marker)) cat("|\tMarker:\t ", marker, "\n"); cat("+-------------------------------------\n"); # compute and print the allele and genotype frequencies sum <- summary(data[,i]) print(sum) # now do and print the HWE test #hwe <- HWE.test(sum) #print(hwe) } genetics/examples/Allele_Freq.out0000644000176000001440000000244010451014204016614 0ustar ripleyusersWarning message: Unable to read input file name from the environment variable '$ALLELE_INPUT_FILENAME'. Using 'input.data.txt' instead. Reading data file 'test.data.txt' ... 99 rows and 4 columns were read. Column names are: Patient.ID Locus Marker Genotype Note: Spaces and '<-' characters are converted to periods ('.') +------------------------------------- | Gene: P53 | Marker: C1556G +------------------------------------- Allele Frequency: Count Proportion C 6 0.0909091 G 60 0.9090909 NA 0 NA Genotype Frequency: Count Proportion G/C 6 0.1818182 G/G 27 0.8181818 NA 0 NA +------------------------------------- | Gene: P53 | Marker: T127A +------------------------------------- Allele Frequency: Count Proportion A 46 0.6969697 T 20 0.3030303 NA 0 NA Genotype Frequency: Count Proportion A/A 17 0.5151515 A/T 12 0.3636364 T/T 4 0.1212121 NA 0 NA +------------------------------------- | Gene: P53 | Marker: T5094A +------------------------------------- Allele Frequency: Count Proportion A 56 0.8484848 T 10 0.1515152 NA 0 NA Genotype Frequency: Count Proportion A/A 23 0.6969697 A/T 10 0.3030303 NA 0 NA genetics/DESCRIPTION0000644000176000001440000000152712063014560013613 0ustar ripleyusersPackage: genetics Title: Population Genetics Version: 1.3.8 Date: 2012-11-26 Author: Gregory Warnes, with contributions from Gregor Gorjanc, Friedrich Leisch, and Michael Man. Maintainer: Gregory Warnes Depends: combinat, gdata, gtools, MASS, mvtnorm Description: Classes and methods for handling genetic data. Includes classes to represent genotypes and haplotypes at single markers up to multiple markers on multiple chromosomes. Function include allele frequencies, flagging homo/heterozygotes, flagging carriers of certain alleles, estimating and testing for Hardy-Weinberg disequilibrium, estimating and testing for linkage disequilibrium, ... biocViews: Genetics License: GPL Packaged: 2012-12-14 20:31:44 UTC; warnegr1 Repository: CRAN Date/Publication: 2012-12-15 07:32:16 genetics/data/0000755000176000001440000000000012062706260013015 5ustar ripleyusersgenetics/data/gregorius.rda0000644000176000001440000000060712050461343015513 0ustar ripleyusers r0b```b`bf H020pibfa,09f_6PN(˶`u.-U׉To|*# J%PyP)P~ nʛھ!Ǖ`pAJAiS(}tPuP~2U_'@.(ݗw(@@i=(mAPxP:i΀@äTw͠304{cPu:1x84@M|@i7@I@y d칙yiE0nqfzn)*p|Y_3@t'$$ÜJI,IK+0genetics/ChangeLog0000644000176000001440000000612012062704574013663 0ustar ripleyusers2012-12-14 20:17 warnes * [r1360] doc/LD.pdf, doc/example.Rout.save, doc/genetics_article.pdf: Update PDF files and create example.Rout.save 2012-08-14 14:36 warnes * [r1356] NEWS: Update for release 1.3.7. 2011-02-02 02:28 warnes * [r1349] NEWS: Update for release 1.3.6 2011-02-02 02:24 warnes * [r1348] doc/genetics_article.pdf: update Greg's email 2011-02-02 02:23 warnes * [r1347] doc/genetics_article.pdf, doc/genetics_article.tex: update Greg's email 2011-01-17 19:13 warnes * [r1344] NEWS: Correct R CMD check warnings. 2008-08-20 19:23 warnes * [r1343] NEWS: Update news file to note new regression test 2008-08-20 19:06 warnes * [r1341] NEWS: Bump version numer up and update NEWS file 2008-04-30 01:05 warnes * [r1338] NEWS: Update for version 1.3.3 2007-11-20 20:27 warnes * [r1334] NEWS: Update NEWS and DESCRIPTION for genetics 1.3.2 2007-09-12 10:41 ggorjan * [r1314] NEWS: - fixes in genotypeOrder to ensure all genotype/haplotype combinations are used. - genotypeOrder<- is now exported 2007-08-21 14:36 warnes * [r1304] NEWS: Move Changelog (not in SVN) and NEWS to inst/ 2007-08-21 14:35 warnes * [r1303] ChangeLog, NEWS: Remove softlinks in inst, doesn't work on windows 2007-08-20 18:30 warnes * [r1301] ChangeLog, NEWS: Add softlinks in inst to NEWS and ChangeLog so these will get installed. 2006-11-14 22:20 ggorjan * [r1101] doc/example_data.csv: Removing executable property 2006-11-11 04:09 warnes * [r1087] doc/genetics_article.tex: Update my email address 2004-12-23 01:34 warnes * [r191] doc/LD.pdf, doc/example_data.csv, doc/genetics_article.pdf: Check in some files that seem to have been overlooked in the past. 2003-05-29 02:27 warnesgr * [r139] doc/genetics_article.tex: - added ld to conclusion text 2003-05-29 02:23 warnesgr * [r138] doc/genetics_article.tex: Updated for version 1.0.0 2003-05-29 02:20 warnesgr * [r136] doc/genetics_article.tex: - Final version to send to Fritz. 2003-05-29 01:55 warnesgr * [r135] doc/example.R, doc/genetics_article.tex, doc/make_example_data.R: - Add R code to generate and demo genetics package 2003-05-16 18:39 warnesgr * [r106] doc/Rnews.sty, doc/genetics_article.tex: - Updated to version 0.7.0 - Made changes to pass R CMD check 2003-02-03 16:13 warnesgr * [r97] doc/genetics_article.tex: - Fixed typos and R CMD check warnings. - Updated version number - Removed 'data' directory to fix new R CMD check warning. 2002-11-27 15:32 warnesgr * [r87] doc/genetics_article.tex: Correct spelling errors and typos. 2002-06-27 18:46 warnesgr * [r62] doc/genetics_article.tex: - More revisions. Hopefully last set before submission to publication review. 2002-06-25 21:38 warnesgr * [r60] doc/genetics_article.tex: - Fixed syntax errors - Some reorganization 2002-06-19 10:34 warnesgr * [r58] doc/genetics_article.tex: Much enhancement, including addition of example section. 2002-04-09 00:49 warneg * [r49] ., doc, doc/Rnews.sty, doc/genetics_article.tex: - Initial checkin of article sources genetics/.Rinstignore0000644000176000001440000000006311763752016014416 0ustar ripleyusersdoc/.*\.tex$ doc/.*\.sty$ doc/.*\.dtx$ doc/.*\.Rnw$