qtl/0000755000176200001440000000000014661520123011052 5ustar liggesusersqtl/tests/0000755000176200001440000000000014661346505012226 5ustar liggesusersqtl/tests/test_mapqtl_io.Rout.save0000644000176200001440000000233412770016226017055 0ustar liggesusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.1.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # test input/output in mapqtl format > > library(qtl) > data(fake.4way) > > write.cross(fake.4way, "mapqtl", "fake_4way_mapqtl") > > x <- read.cross("mapqtl", "", genfile="fake_4way_mapqtl.loc", + phefile="fake_4way_mapqtl.qua", + mapfile="fake_4way_mapqtl_female.map") --Read the following data: Number of individuals: 250 Number of markers: 157 Number of phenotypes: 2 --Cross type: 4way > > x <- replace.map(x, pull.map(fake.4way)) > > comparecrosses(x, fake.4way) Crosses are identical. > > proc.time() user system elapsed 4.311 0.247 4.547 qtl/tests/test_io.Rout.save0000644000176200001440000000722612770016226015504 0ustar liggesusers R version 2.11.0 (2010-04-22) Copyright (C) 2010 The R Foundation for Statistical Computing ISBN 3-900051-07-0 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ###################################################################### > # > # TestIO/input.R > # > # copyright (c) 2002, Karl W Broman > # last modified Feb, 2002 > # first written Feb, 2002 > # > # This program is free software; you can redistribute it and/or > # modify it under the terms of the GNU General Public License, > # version 3, as published by the Free Software Foundation. > # > # This program is distributed in the hope that it will be useful, > # but without any warranty; without even the implied warranty of > # merchantability or fitness for a particular purpose. See the GNU > # General Public License, version 3, for more details. > # > # A copy of the GNU General Public License, version 3, is available > # at http://www.r-project.org/Licenses/GPL-3 > # > # This file contains code for testing the cross IO in R/qtl. > # > # Needed input files: > # > # gen.txt, map.txt, phe.txt [Karl's format] > # listeria.raw, listeria.map [mapmaker format] > # listeria.raw, listeria2.map [mapmaker format; no marker pos] > # listeria.csv [csv format] > # listeria2.csv [csv format; no marker pos] > # > ###################################################################### > > library(qtl) > > ############################## > # Reading > ############################## > # Read CSV format > csv <- read.cross("csv", "", "listeria.csv") --Read the following data: 120 individuals 133 markers 1 phenotypes --Cross type: f2 Warning message: In fixXgeno.f2(cross, alleles) : --Assuming that all individuals are female. > csv2 <- read.cross("csv", "", "listeria2.csv", estimate=FALSE) --Read the following data: 120 individuals 133 markers 1 phenotypes --Cross type: f2 Warning message: In fixXgeno.f2(cross, alleles) : --Assuming that all individuals are female. > > # Read mapmaker format > mm <- read.cross("mm", "", "listeria.raw", "listeria.map") --Read the following data: Type of cross: f2 Number of individuals: 120 Number of markers: 133 Number of phenotypes: 1 --Cross type: f2 Warning message: In fixXgeno.f2(cross, alleles) : --Assuming that all individuals are female. > mm2 <- read.cross("mm", "", "listeria.raw", "listeria2.map", estimate=FALSE) --Read the following data: Type of cross: f2 Number of individuals: 120 Number of markers: 133 Number of phenotypes: 1 --Cross type: f2 Warning message: In fixXgeno.f2(cross, alleles) : --Assuming that all individuals are female. > > ############################## > # Writing > ############################## > # Write in CSV format > write.cross(csv, "csv", filestem="junk1") > csv3 <- read.cross("csv", "", "junk1.csv", genotypes=c("AA","AB","BB","not BB","not AA")) --Read the following data: 120 individuals 133 markers 3 phenotypes --Cross type: f2 > comparecrosses(csv, csv3) Crosses are identical. > > # Write in mapmaker format > write.cross(csv, "mm", filestem="junk2") > > # Cleanup > unlink("junk1.csv") > unlink("junk2.raw") > unlink("junk2.prep") > qtl/tests/gen.txt0000644000176200001440000007626012770016226013544 0ustar liggesusers3 3 3 2 2 2 3 3 2 2 2 2 2 2 1 1 0 1 1 3 3 3 3 3 3 1 2 1 2 1 1 2 2 2 2 2 0 2 2 2 3 3 1 1 2 2 2 2 2 2 2 3 3 3 3 3 3 2 2 2 2 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 3 3 3 2 2 2 1 1 2 3 3 3 3 3 3 5 0 2 2 2 1 1 1 1 1 1 1 3 3 2 2 1 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 3 3 3 3 2 2 2 5 2 2 0 3 3 3 2 2 2 2 2 2 2 2 2 3 3 2 0 2 1 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 2 2 3 3 3 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 2 2 2 3 3 3 2 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 3 2 1 1 2 2 2 2 0 2 2 2 2 2 1 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 3 3 2 2 1 2 2 5 2 2 0 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 0 0 2 2 2 2 2 3 3 1 1 2 2 1 1 1 1 2 2 2 0 2 2 2 2 1 2 2 2 2 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 2 2 2 3 2 2 3 3 3 3 3 3 3 2 1 1 1 1 2 2 2 2 2 2 3 3 2 2 2 3 1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 2 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 2 2 3 3 2 2 1 1 2 2 3 3 2 2 2 2 3 3 3 3 3 3 3 1 0 1 0 2 2 3 2 2 2 2 2 2 2 2 2 0 2 1 1 1 1 1 0 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 2 3 3 3 3 3 2 2 2 2 2 2 2 2 1 2 3 2 2 3 3 3 3 3 2 1 1 2 1 1 1 5 2 2 2 2 2 2 2 2 2 2 2 2 1 1 2 2 3 2 2 2 2 1 1 1 2 2 3 1 2 2 3 1 1 1 1 3 2 2 5 2 1 2 2 2 2 3 2 2 2 2 2 2 2 2 3 2 2 0 0 2 3 1 1 1 1 1 1 1 1 2 0 1 1 1 1 1 0 0 2 2 2 2 2 1 1 1 1 1 1 0 2 2 2 2 2 2 3 2 1 1 2 2 1 1 1 1 1 2 3 3 3 2 2 2 2 1 2 2 2 2 3 3 3 3 3 2 1 1 1 1 1 1 5 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 3 3 3 1 1 1 2 1 1 1 1 2 1 1 5 1 1 2 2 3 3 3 3 3 3 3 3 3 3 3 2 1 1 1 0 1 3 3 3 3 3 3 2 2 2 2 1 1 1 1 1 1 2 0 2 2 2 0 2 1 1 1 2 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 2 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 2 2 2 2 5 2 0 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 3 3 3 3 3 3 2 2 2 2 2 2 2 3 2 2 2 2 1 1 1 5 1 2 2 2 2 2 1 1 1 1 2 2 2 2 2 3 3 3 3 0 2 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 0 1 1 1 0 2 2 2 2 2 2 2 2 3 3 3 3 3 3 1 1 1 2 2 2 3 3 3 3 3 3 3 3 3 1 1 1 1 2 2 2 2 2 1 1 1 2 2 3 3 2 1 1 1 1 5 2 3 3 3 3 3 3 3 3 3 3 1 2 2 2 1 1 1 1 1 1 1 0 3 2 2 2 2 1 1 2 2 2 3 3 3 3 1 1 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 1 0 1 1 2 3 2 2 2 2 2 0 2 3 3 3 3 3 3 3 3 0 3 3 2 2 2 1 1 1 1 2 2 0 3 3 3 3 3 3 2 2 2 2 2 3 1 1 2 2 2 2 3 3 3 3 3 3 2 1 1 0 1 1 2 3 2 3 3 2 1 2 2 2 2 2 5 2 2 1 1 1 0 1 1 0 1 2 2 3 2 2 3 3 3 3 2 2 2 2 3 3 3 3 2 2 2 2 1 1 0 2 2 2 2 5 1 0 1 1 2 3 3 3 2 2 2 2 2 0 2 1 2 2 2 2 3 1 2 2 1 1 1 2 2 2 3 2 2 2 2 1 1 1 0 1 1 1 0 2 2 2 2 2 3 3 3 2 2 2 2 2 2 3 3 3 3 3 2 3 3 0 3 3 1 2 2 2 1 1 1 1 2 3 3 3 3 3 3 2 2 2 2 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 2 1 1 1 1 1 1 1 2 3 3 3 1 1 2 2 3 3 0 3 2 2 2 1 1 2 3 3 2 2 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 1 2 2 2 2 1 3 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 2 1 1 1 2 2 3 3 3 2 2 2 3 3 3 3 3 2 1 1 2 2 2 2 1 2 2 2 2 3 1 0 1 1 1 1 5 2 2 2 2 2 2 2 2 2 2 2 1 2 3 2 2 2 2 2 2 2 2 2 3 3 3 2 1 1 1 1 1 1 1 1 2 3 3 5 2 1 1 2 2 2 2 2 2 2 2 2 2 0 2 1 1 3 3 3 3 2 1 1 2 2 2 2 2 2 3 2 2 2 2 2 2 2 0 2 2 2 3 3 2 2 2 2 2 2 1 1 1 1 1 1 1 2 1 2 2 2 0 1 1 1 1 1 1 2 2 3 3 3 3 3 1 2 2 2 1 1 2 2 2 2 2 1 1 1 2 2 3 5 2 2 2 2 2 2 2 2 2 2 2 3 2 2 2 1 1 1 1 1 1 1 2 3 3 3 2 2 3 3 3 1 1 1 1 3 2 2 5 1 2 1 1 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 2 2 1 2 3 2 2 2 2 2 3 3 3 3 3 3 3 3 3 0 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 3 3 2 1 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 2 2 1 1 1 1 2 1 0 1 1 1 1 1 2 2 0 2 2 3 3 3 3 2 2 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 1 1 2 5 2 2 1 1 2 2 2 2 3 3 3 3 3 0 3 2 2 2 2 2 2 1 1 1 1 1 1 2 2 2 1 2 2 2 2 2 2 2 0 2 2 2 0 2 3 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 1 2 2 2 1 1 1 1 1 2 1 1 1 0 1 2 5 2 1 1 1 1 1 1 1 2 2 2 3 3 3 3 1 1 1 1 1 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 2 3 3 2 0 2 3 2 2 2 3 2 2 2 2 2 3 3 3 3 3 3 3 0 3 3 3 0 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 0 2 2 1 1 1 1 1 2 3 3 3 3 3 3 2 3 2 2 2 2 3 2 2 2 2 1 2 2 2 2 2 3 5 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 3 3 3 3 3 3 3 2 1 1 1 3 3 3 3 1 1 0 2 2 3 0 5 1 2 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 2 2 3 3 3 3 3 3 2 2 3 3 1 1 2 2 2 2 2 0 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 2 2 2 3 2 2 2 2 1 1 1 2 2 1 1 1 1 1 2 1 1 1 3 2 1 1 2 1 1 2 2 2 2 2 2 5 2 1 1 1 1 1 1 1 2 2 2 1 1 2 2 0 0 1 1 1 1 1 0 2 2 2 2 2 2 2 2 3 3 3 3 2 2 2 1 1 1 2 2 3 3 3 3 2 2 2 2 2 1 1 3 3 2 2 1 1 2 0 2 2 2 2 3 3 3 3 2 3 3 3 3 3 3 0 3 3 3 3 2 2 2 2 2 2 3 0 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 3 2 2 3 2 2 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 2 3 1 1 2 0 1 1 1 1 1 1 1 3 3 3 2 3 3 2 2 3 0 0 3 3 3 3 5 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 2 0 2 2 3 0 1 1 1 1 3 2 2 2 2 2 2 2 3 3 3 0 3 3 3 3 3 2 2 3 3 3 3 3 3 3 2 2 2 2 1 2 2 2 3 2 3 3 3 3 3 2 3 3 2 2 2 1 1 1 1 1 1 2 1 1 1 1 1 3 1 1 1 1 1 1 5 3 3 3 3 3 3 3 3 3 3 3 1 1 1 2 2 1 1 1 1 1 1 0 3 2 2 1 1 1 1 1 1 0 0 1 2 0 1 1 1 2 3 3 2 2 0 2 2 2 2 2 2 3 3 3 3 2 2 2 3 1 1 1 2 2 2 1 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 1 1 1 0 1 1 1 1 2 2 3 3 3 3 1 1 1 2 2 0 2 2 2 1 1 1 2 2 2 5 3 3 3 3 3 3 3 3 0 3 3 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 2 2 2 2 2 0 3 2 0 2 1 1 1 2 2 1 2 2 2 3 3 3 3 3 0 3 2 2 1 1 1 2 1 1 2 1 2 1 1 0 2 1 1 1 1 1 1 1 1 0 1 1 1 0 1 2 2 1 2 2 2 2 2 2 2 3 3 3 2 2 2 2 1 1 3 3 3 2 2 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 1 5 3 3 3 3 3 3 2 2 2 2 2 1 2 2 3 2 1 1 1 1 1 1 0 2 3 3 3 3 3 0 2 2 2 0 2 3 3 3 0 1 2 2 2 2 2 1 1 1 1 1 1 0 2 2 2 2 2 1 1 1 1 1 1 1 0 1 1 2 2 2 3 2 2 2 2 2 2 0 2 1 1 1 1 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 3 3 3 2 2 0 2 2 2 2 2 1 1 2 3 3 3 2 2 3 3 3 3 3 3 3 3 3 2 0 5 2 2 2 2 1 1 1 1 1 1 1 3 2 1 1 3 3 3 3 3 3 2 2 2 2 1 1 2 2 2 3 1 1 0 1 3 3 3 5 1 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 2 1 1 1 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 0 1 1 1 0 1 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 2 1 1 1 2 2 3 2 2 2 1 1 1 1 2 2 2 2 2 1 1 2 2 2 2 1 1 1 1 3 3 5 2 2 2 2 2 2 2 2 2 2 2 3 2 1 1 3 3 3 3 2 2 2 2 2 2 1 1 3 3 3 2 2 2 0 2 2 2 2 5 2 1 3 3 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 1 1 2 3 3 3 2 2 3 3 3 3 1 1 2 2 2 2 2 0 2 2 2 0 3 2 2 2 2 3 3 3 3 3 3 3 3 3 2 2 2 1 1 1 2 2 3 3 3 3 1 1 1 2 3 3 3 1 1 1 1 1 2 2 3 3 3 3 3 3 2 2 2 2 5 2 0 2 2 2 2 2 2 2 2 1 2 1 1 2 2 2 2 2 2 2 2 2 1 1 2 2 2 2 2 0 2 0 0 2 1 1 1 1 2 1 1 1 1 1 1 1 2 2 3 3 3 3 3 0 1 1 1 1 2 1 2 2 1 1 1 3 3 3 2 1 1 1 1 1 1 1 0 1 2 2 2 1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 3 3 3 2 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 1 2 2 2 2 2 2 1 1 1 1 2 2 5 0 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 1 1 0 1 1 1 2 5 1 1 2 2 2 0 2 2 2 2 2 2 2 2 1 2 2 3 3 3 1 2 2 2 2 3 3 2 2 1 3 0 3 3 3 3 3 3 0 3 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 3 2 2 0 2 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 3 3 3 3 3 3 3 2 2 2 2 2 2 5 0 2 2 2 1 1 1 1 1 1 1 2 2 2 2 3 3 3 3 3 3 3 3 1 1 1 1 2 2 2 3 1 1 0 1 2 2 2 5 2 2 0 2 2 2 2 2 3 3 3 3 3 3 3 2 1 1 0 2 2 1 1 1 1 1 1 2 2 2 2 3 0 3 3 2 2 2 2 2 1 1 1 1 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 0 1 1 1 1 2 3 2 2 2 2 2 2 2 1 1 1 2 2 2 2 2 3 3 2 2 2 2 2 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 3 3 2 2 2 3 2 2 0 3 2 3 2 5 1 1 0 2 3 2 2 2 2 2 2 2 2 2 2 1 3 3 0 2 1 2 2 2 2 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1 3 3 2 2 2 2 0 2 2 2 0 2 2 2 1 3 3 2 0 2 2 2 1 1 2 2 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 1 1 1 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 3 2 2 2 1 2 2 2 2 2 2 2 3 3 3 3 2 2 3 2 2 2 0 2 3 3 2 5 0 2 0 2 2 2 2 2 2 2 2 2 2 1 1 2 2 2 0 2 2 1 2 2 2 2 2 1 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 0 2 2 2 2 2 2 2 2 2 2 2 3 2 3 3 3 3 2 1 1 1 1 1 1 1 2 2 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 2 2 2 3 3 3 3 3 3 3 2 1 1 1 1 1 1 1 1 1 2 0 2 2 2 3 5 1 1 0 2 2 1 1 1 1 1 1 1 1 1 1 2 2 3 0 1 1 2 1 1 1 1 2 2 3 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 2 2 0 2 2 2 2 2 2 3 2 2 2 1 0 3 3 3 3 3 3 2 3 3 3 3 3 2 1 1 2 2 2 2 3 3 3 3 3 1 1 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 2 2 2 2 3 3 3 3 3 3 3 2 3 3 3 3 3 3 2 1 1 0 1 3 2 2 5 2 1 2 2 2 1 0 2 2 2 2 2 2 2 2 0 1 2 2 2 3 3 3 3 2 2 2 1 2 2 1 1 1 1 1 1 1 1 1 1 1 2 0 2 2 2 2 3 3 3 0 3 3 3 3 3 3 3 3 3 3 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 1 2 2 2 3 2 3 3 3 2 2 2 1 1 1 2 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 3 2 2 2 2 2 2 3 2 2 2 2 2 2 2 1 1 1 0 1 2 2 2 5 1 2 1 1 1 2 2 3 2 2 2 2 2 2 2 0 2 2 2 0 2 2 3 3 2 2 2 3 2 3 2 0 2 2 2 2 2 2 2 2 2 1 0 2 1 2 2 2 2 2 0 2 2 2 2 2 2 2 1 1 1 2 2 1 1 2 2 3 3 3 2 2 0 2 2 3 1 2 2 2 1 2 2 2 2 2 2 3 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 1 1 1 2 2 2 2 3 2 2 0 2 2 2 2 5 2 2 1 1 2 2 2 2 1 1 1 1 1 2 2 3 3 3 2 2 1 2 1 1 2 2 2 2 2 3 2 2 2 1 1 1 1 1 1 1 1 1 0 1 3 2 2 2 2 2 0 2 2 2 2 0 2 3 3 3 3 3 3 2 2 2 2 2 2 1 1 1 1 2 2 3 2 2 1 1 1 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 3 2 2 2 2 2 2 2 2 2 2 2 2 1 2 3 3 2 2 2 3 1 1 0 1 2 2 2 5 2 2 1 1 2 2 3 3 2 2 2 2 1 1 1 0 2 3 3 3 2 2 2 2 2 2 2 2 1 1 2 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 0 3 3 3 3 3 3 1 1 1 1 2 0 3 3 3 2 2 0 2 2 2 1 1 1 1 3 2 2 2 3 1 0 2 2 1 1 3 3 3 3 1 1 3 3 0 2 2 2 0 2 2 1 2 1 2 3 3 2 1 1 2 2 2 2 3 2 2 2 2 2 1 1 2 2 1 1 0 1 2 2 2 5 2 2 3 3 2 1 1 1 1 1 2 2 2 2 2 3 3 3 3 2 2 3 2 2 1 1 1 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 2 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 1 2 0 2 2 2 2 3 3 3 3 2 2 3 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 3 3 0 2 2 2 2 5 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 1 1 2 1 2 2 2 2 2 3 0 2 3 2 2 2 2 2 2 3 2 3 3 3 3 3 2 2 2 2 2 2 0 2 2 1 1 2 2 2 2 1 1 1 0 2 2 2 2 2 0 2 3 3 3 3 3 3 1 1 1 2 2 2 2 2 2 2 3 2 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 3 3 1 1 1 1 1 1 1 1 1 1 1 1 2 1 2 2 2 2 0 2 3 2 2 5 2 2 3 3 3 3 3 3 3 3 3 3 3 2 0 2 2 2 2 1 2 2 1 2 2 3 3 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 3 3 0 3 3 3 2 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 1 1 3 3 2 1 2 2 1 1 1 1 1 1 1 1 1 0 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 3 3 3 3 3 3 0 3 2 1 1 5 1 2 2 2 3 3 3 3 3 3 3 3 3 2 0 1 2 2 3 3 3 2 2 2 2 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 1 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 3 3 3 3 0 3 3 2 2 2 2 3 2 2 2 2 2 2 1 2 2 2 2 1 1 1 1 2 2 0 2 2 2 1 1 1 1 2 2 2 2 2 2 2 1 1 1 1 1 0 3 2 2 1 1 1 2 2 2 1 0 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 3 0 3 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 1 1 2 2 3 3 3 3 3 2 2 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 1 1 0 1 1 1 1 1 1 0 1 1 1 1 1 1 2 2 1 1 1 1 1 1 1 2 3 3 2 2 2 2 2 2 0 1 2 2 2 1 1 2 3 3 3 3 3 3 2 2 2 2 2 2 0 1 3 3 0 3 3 1 1 1 1 0 2 2 2 2 3 1 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 3 3 1 1 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 2 2 2 2 3 3 0 3 2 2 2 5 1 1 3 3 2 2 1 1 1 1 1 1 1 1 0 2 2 3 3 3 2 2 2 2 2 0 1 2 2 2 2 1 1 3 3 3 3 3 3 3 3 3 3 3 1 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 3 3 3 1 2 2 2 3 1 1 1 2 2 2 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 0 1 1 1 1 1 2 0 3 3 3 3 3 3 2 2 2 2 2 3 3 3 3 2 0 0 2 1 1 3 5 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 2 2 1 0 2 2 2 2 2 2 3 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 1 1 1 1 1 1 1 1 2 3 3 1 1 1 1 1 1 2 2 2 3 3 3 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 1 1 2 2 2 3 1 1 1 1 1 1 1 1 1 0 1 1 2 1 1 1 0 3 3 3 3 3 3 3 1 1 1 1 2 2 2 2 1 1 0 1 2 1 1 1 1 2 3 3 3 3 3 3 2 2 2 2 2 0 2 2 1 1 1 0 1 1 2 2 2 2 2 2 3 3 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 2 2 2 2 1 1 2 1 1 1 1 2 2 3 2 1 1 1 1 2 3 3 3 3 3 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 3 2 2 0 2 2 2 2 2 2 0 2 2 0 1 1 1 2 1 1 1 1 1 1 0 2 3 0 2 5 1 2 1 1 1 1 1 1 1 1 1 1 2 2 2 1 1 2 2 2 2 1 1 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 3 3 3 3 3 3 3 2 2 2 2 2 2 2 1 1 1 1 2 1 1 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 1 1 1 1 1 3 3 0 0 2 2 2 2 2 0 2 2 1 1 1 3 2 0 1 1 1 1 1 1 2 2 2 2 3 3 3 3 3 3 0 3 3 0 3 5 1 1 3 3 3 1 1 1 2 2 1 1 1 1 1 0 2 2 0 3 3 3 2 1 1 1 1 2 0 1 2 1 1 2 2 2 2 2 2 2 2 2 0 3 2 2 2 2 2 2 0 0 2 2 2 2 2 1 1 1 1 1 0 2 2 2 2 2 0 2 2 3 0 3 1 1 2 2 1 1 1 3 3 3 3 3 3 3 3 2 2 2 0 2 2 3 3 3 3 3 3 3 3 3 3 2 0 3 3 2 0 2 2 2 2 2 3 3 3 3 2 2 2 2 2 3 3 0 3 3 3 3 5 1 2 2 2 2 3 3 3 3 3 3 3 3 2 2 2 2 2 1 1 1 2 1 1 1 1 2 2 1 2 3 2 2 2 2 2 1 1 1 1 1 1 1 1 3 3 3 3 2 2 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3 1 1 2 2 2 2 2 3 3 3 3 2 0 3 3 2 2 2 2 0 2 2 2 2 2 2 2 2 3 2 1 2 2 1 0 1 1 2 2 2 3 3 3 3 3 2 2 2 0 1 1 0 2 1 1 1 1 2 2 1 1 1 2 2 3 3 3 3 3 3 0 3 1 1 0 0 1 1 1 1 1 2 2 3 2 2 2 2 3 3 2 2 2 2 2 2 2 2 1 0 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 0 3 3 3 3 2 0 2 2 2 1 1 1 1 2 1 1 1 2 2 2 2 2 2 1 1 1 2 1 1 1 2 2 0 2 2 2 2 2 2 2 2 2 2 0 3 3 1 0 1 1 1 1 2 2 1 1 1 1 1 2 0 2 1 0 0 1 1 1 2 5 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 1 2 1 0 3 3 2 2 2 2 2 2 2 0 1 1 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 3 0 2 2 2 2 2 0 3 3 3 0 3 2 2 1 1 2 2 3 2 1 1 1 1 2 3 3 2 2 2 2 2 2 0 1 1 1 1 2 2 0 2 2 0 0 2 2 1 0 1 1 1 1 1 0 1 1 1 2 2 1 1 1 3 3 0 3 2 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 0 3 2 1 3 0 1 2 1 2 2 3 3 3 2 2 2 2 0 1 1 1 1 1 1 1 1 1 1 0 1 2 2 2 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 3 3 3 1 1 1 3 3 3 0 3 3 3 2 2 2 2 2 2 1 1 1 1 2 2 2 2 3 2 0 2 2 2 2 2 2 2 2 3 2 2 2 3 0 1 2 3 0 2 2 0 2 2 2 3 3 3 3 2 2 0 2 3 3 0 3 2 2 2 5 1 0 2 2 1 1 1 1 1 1 1 1 2 2 2 2 2 2 0 3 3 2 2 1 1 1 1 1 2 2 2 0 1 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 2 2 2 1 1 1 3 3 3 3 3 2 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 2 0 1 1 2 0 2 2 3 3 0 3 2 2 2 2 1 1 1 2 3 3 0 2 2 2 0 5 2 0 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 0 2 2 2 1 1 1 1 1 2 2 2 1 3 3 3 3 3 3 0 0 3 3 3 3 3 2 2 2 2 3 2 0 2 2 2 2 2 2 1 0 1 0 1 1 3 3 3 3 2 0 1 1 2 2 0 2 2 1 1 0 1 1 1 1 1 2 2 2 1 1 1 1 1 1 5 1 2 2 2 3 3 3 3 3 3 3 1 2 2 2 2 2 2 2 2 2 1 1 2 3 3 3 1 1 1 1 2 2 1 1 2 1 1 1 1 2 0 2 2 1 1 1 1 1 1 1 1 2 2 1 2 2 0 1 1 2 2 2 2 2 2 3 0 2 2 2 2 2 2 2 2 0 0 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 3 3 3 0 3 3 3 3 3 3 2 2 1 1 0 1 1 3 3 2 1 1 1 1 1 3 3 3 1 1 1 1 1 1 5 3 3 3 3 3 3 3 3 3 3 3 2 2 1 1 2 2 2 2 2 2 1 1 1 1 1 1 3 3 3 2 2 2 2 2 3 3 2 5 1 1 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 0 1 2 2 2 2 2 2 3 2 0 3 3 3 3 3 3 3 3 3 3 3 3 3 0 2 2 2 2 2 2 2 0 3 3 3 3 3 3 3 3 3 3 1 1 2 2 2 1 1 1 1 1 1 1 0 2 2 3 3 2 2 1 1 0 1 1 1 2 3 0 2 2 2 3 5 3 3 0 3 3 3 2 2 2 2 2 3 3 3 3 1 1 2 2 2 2 2 3 1 1 2 2 2 2 2 2 2 2 2 2 1 1 2 5 1 1 0 3 3 3 3 3 2 2 2 2 2 2 2 1 1 2 0 3 3 1 2 2 2 2 3 3 2 1 1 2 2 2 2 0 2 2 2 2 2 1 1 1 2 2 2 2 2 2 0 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 3 0 3 2 2 2 2 1 2 2 2 2 1 1 2 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 3 3 2 2 2 3 3 3 3 3 3 0 2 2 2 1 2 2 3 3 2 2 3 3 2 2 1 1 2 2 1 0 2 1 1 1 1 1 1 1 1 1 1 3 1 1 0 2 2 2 3 3 3 3 3 2 0 3 3 3 3 3 3 2 2 2 2 2 2 2 1 1 1 1 1 1 2 2 0 2 2 2 3 3 3 1 2 2 2 1 1 1 1 2 2 2 0 2 2 2 2 0 3 3 3 3 3 3 2 2 3 3 3 3 3 2 1 1 1 2 2 5 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 1 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 1 1 2 3 1 1 1 1 2 1 3 3 3 3 3 3 3 3 3 3 3 3 3 1 2 2 2 2 1 3 2 1 2 2 2 2 2 3 3 0 3 3 3 3 3 3 3 3 3 3 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 1 1 1 1 1 1 2 2 2 2 0 2 2 2 2 2 2 2 1 2 2 3 3 3 1 1 1 1 1 1 5 2 1 1 1 1 0 1 1 1 1 1 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 5 1 2 1 0 2 2 3 3 3 3 3 3 3 3 3 0 3 3 3 3 2 2 2 2 2 2 2 2 2 1 2 2 2 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 0 3 3 3 3 3 3 2 2 2 1 1 1 2 2 1 1 1 0 2 1 1 1 0 2 2 2 2 3 3 3 2 0 1 1 1 1 1 1 1 1 1 1 5 2 2 2 2 2 0 2 2 2 2 1 3 3 3 2 2 2 2 2 2 2 2 3 3 3 2 2 1 1 1 1 2 2 3 2 2 2 1 1 1 1 2 2 3 2 2 2 3 3 3 3 3 3 3 1 2 1 0 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 0 3 3 2 2 2 0 1 1 1 1 1 2 2 1 2 0 2 3 2 2 2 2 1 1 2 2 0 2 3 3 5 2 0 2 2 2 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 2 2 2 1 3 2 2 2 3 3 3 3 2 2 2 5 2 2 2 0 2 2 1 1 2 2 3 3 3 3 3 2 1 1 2 3 3 2 2 2 2 1 1 2 2 2 2 1 2 2 2 2 2 2 2 2 2 3 3 3 2 2 2 3 3 3 3 3 3 3 3 3 3 2 2 2 2 3 3 2 2 1 1 1 1 2 1 2 2 0 2 2 2 2 3 3 2 2 2 2 2 2 1 1 1 1 2 2 2 5 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 1 1 1 1 1 1 1 2 0 2 2 1 1 1 1 1 1 1 1 3 2 2 5 2 2 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 1 1 2 2 2 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 3 3 3 2 2 1 1 0 1 1 2 2 2 2 2 1 2 3 2 2 1 1 1 1 1 1 1 1 1 0 1 1 1 0 1 2 0 2 2 3 2 2 2 2 2 2 2 2 2 2 2 3 2 2 3 3 3 3 2 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 3 3 3 2 2 1 1 1 1 2 1 1 1 1 1 1 1 2 2 3 3 3 3 3 3 3 2 2 2 2 2 3 3 3 3 2 2 2 2 3 3 2 0 2 2 2 2 2 3 3 3 3 3 3 2 0 1 1 1 2 2 2 2 1 2 2 2 2 2 3 2 2 2 2 0 1 1 1 1 1 1 0 1 1 0 1 2 3 3 2 2 2 2 3 3 3 3 3 3 3 2 2 2 2 3 3 3 3 3 1 1 2 2 2 5 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 2 2 2 2 0 2 1 2 3 3 3 3 2 2 3 3 1 1 1 1 1 2 2 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 0 2 2 2 2 2 2 2 2 1 1 2 0 0 2 2 1 1 1 1 1 3 3 2 2 2 1 1 1 1 1 1 2 1 1 0 1 1 1 1 1 1 0 1 2 1 3 3 3 3 3 3 3 3 3 3 0 2 2 2 2 2 3 3 3 3 3 2 2 1 2 2 5 1 1 3 3 3 3 3 3 3 3 2 2 2 2 2 2 3 2 2 2 2 2 2 3 3 3 3 2 2 2 3 2 2 2 2 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 2 3 3 3 3 3 2 2 2 2 0 3 3 2 2 3 3 3 3 3 3 3 3 1 2 2 1 1 1 1 5 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 1 1 3 2 2 5 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 2 2 2 2 2 2 2 2 2 0 3 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 3 0 1 1 2 0 0 1 1 1 1 1 2 2 3 3 3 3 3 1 3 3 2 2 2 2 1 1 0 2 2 2 0 2 2 2 2 2 1 1 1 1 3 3 3 3 3 3 3 2 2 2 2 1 3 3 2 2 2 2 2 2 1 1 1 1 1 0 2 2 2 2 3 3 3 3 3 3 2 2 2 3 3 3 3 3 3 2 2 3 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 0 1 1 1 1 1 1 3 3 3 3 2 1 2 2 2 2 2 1 1 1 1 1 0 1 1 3 3 3 2 2 2 2 2 2 2 2 2 1 1 1 1 2 5 3 3 3 3 3 3 3 2 0 2 2 2 2 2 1 0 2 2 2 2 2 2 3 3 3 3 3 2 2 2 1 2 2 2 2 3 1 1 1 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 1 1 1 1 1 1 2 2 1 1 1 1 3 3 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 1 1 2 2 2 2 2 2 2 2 2 2 3 2 2 2 2 2 1 1 2 2 2 3 1 1 1 1 1 1 1 2 2 2 2 2 2 3 3 3 3 3 3 3 2 1 1 1 5 1 0 3 3 3 3 3 3 3 3 3 1 1 1 2 0 3 3 3 3 3 2 0 1 2 2 3 2 2 2 2 2 2 2 2 3 3 3 5 2 2 1 1 2 2 2 2 2 2 1 1 1 1 1 0 1 2 2 2 2 1 2 2 2 2 2 3 0 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 2 2 2 0 3 3 3 0 0 2 2 1 1 2 2 3 1 1 1 2 2 2 2 1 2 2 2 3 5 3 3 3 3 3 3 3 3 3 3 3 2 2 1 2 2 0 1 1 1 1 1 1 1 1 1 2 2 2 2 3 3 3 0 3 2 2 1 1 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 3 3 3 3 0 3 1 1 1 3 3 3 2 2 2 3 2 2 2 2 0 2 2 2 2 2 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 2 1 1 1 1 1 1 3 3 3 2 0 2 2 1 2 2 2 2 1 1 0 1 1 1 3 3 3 3 3 3 1 1 0 1 1 1 1 1 1 0 2 2 2 2 2 2 2 0 2 2 3 3 3 3 1 1 2 2 2 2 1 1 2 2 0 2 3 2 2 5 1 1 2 2 2 2 2 2 2 2 2 2 0 2 2 3 2 2 0 2 2 3 2 2 2 2 2 3 0 3 3 2 3 3 3 3 3 3 3 3 2 2 0 2 3 2 2 2 2 2 2 2 2 2 1 1 1 2 2 2 0 3 0 2 2 2 2 2 0 3 3 3 3 0 3 3 1 1 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 5 2 1 1 1 1 1 1 1 1 1 1 2 2 3 3 2 0 3 3 3 2 2 3 3 2 2 2 1 2 2 2 3 3 3 3 2 1 2 5 1 1 2 2 1 1 1 1 2 2 2 3 3 3 3 2 2 2 2 3 3 2 3 3 3 3 3 2 3 3 3 3 3 3 3 3 3 3 3 2 2 2 0 2 2 1 1 1 1 1 1 1 1 1 2 2 2 2 1 1 1 1 0 2 2 2 3 3 3 3 3 2 2 0 1 1 1 1 2 2 3 3 3 3 2 2 2 2 2 2 2 2 3 1 1 1 1 1 1 1 1 1 1 1 1 2 0 3 3 2 0 2 2 1 1 1 1 2 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 2 2 1 1 1 1 1 1 2 2 3 3 3 3 3 2 3 3 0 2 2 3 2 2 3 3 3 1 1 2 3 1 2 1 1 1 1 1 1 1 1 1 0 1 1 1 1 2 3 3 3 3 3 3 3 3 3 2 2 2 0 2 0 3 3 3 2 1 1 2 2 3 3 0 2 2 2 2 2 2 2 3 3 3 3 3 3 2 2 2 3 3 3 5 2 2 2 2 2 2 2 2 0 2 3 2 0 2 2 2 0 2 2 2 2 1 1 3 3 3 3 3 2 2 1 2 2 2 2 1 1 1 5 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 2 2 2 2 2 2 1 1 1 3 0 2 1 1 1 1 2 2 2 3 3 0 2 3 3 2 2 2 2 2 2 2 2 2 2 2 1 1 2 0 2 0 2 2 2 2 2 0 2 2 2 2 0 2 2 2 3 3 3 3 1 2 2 2 2 2 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 0 1 1 1 0 2 2 3 0 3 3 3 3 0 0 2 2 2 2 2 2 2 2 1 1 1 1 2 2 3 5 2 1 2 2 2 2 2 2 2 2 2 2 2 0 2 2 2 3 0 2 2 2 3 3 3 2 2 3 2 2 2 1 2 1 1 1 1 1 1 1 1 2 0 2 3 3 3 3 3 3 3 3 3 3 3 3 3 1 0 3 0 3 2 3 3 3 3 3 3 2 2 2 2 0 3 3 2 2 2 1 2 3 2 1 1 1 1 3 3 0 3 3 3 5 2 1 1 1 1 1 1 1 1 1 1 3 3 2 2 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 5 2 1 3 3 3 3 3 3 2 2 1 1 1 1 1 2 1 1 1 1 1 2 2 2 2 2 2 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 3 3 3 3 3 2 2 2 2 3 2 2 0 1 1 1 1 1 0 1 2 2 3 3 3 3 2 2 2 1 1 1 5 3 3 3 3 3 2 2 2 2 2 2 3 3 3 2 1 2 0 2 2 2 0 0 1 2 2 2 2 3 3 3 1 1 2 2 2 2 2 5 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 2 0 2 2 2 1 1 1 1 2 1 3 3 2 2 3 3 3 3 3 3 0 3 3 3 3 3 2 2 2 2 2 2 0 2 2 3 3 3 3 2 2 2 2 3 3 2 2 2 2 2 0 1 1 2 0 2 2 2 2 2 3 2 2 2 2 2 3 3 3 3 3 3 3 3 3 5 3 3 3 3 3 3 3 3 3 3 3 0 2 2 1 1 2 2 1 1 1 1 1 2 3 0 2 2 2 2 3 2 2 2 2 3 3 2 5 1 2 0 2 0 2 2 2 2 2 2 2 2 2 2 3 2 2 0 2 2 1 1 2 2 2 3 1 1 2 3 2 2 2 2 2 2 2 2 2 2 2 2 1 3 3 3 3 3 3 0 3 3 3 3 3 3 3 3 2 0 1 1 1 1 1 1 1 1 2 2 2 2 2 1 1 1 1 1 1 1 2 2 2 2 2 3 2 2 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 1 1 2 2 2 2 1 2 2 0 1 2 3 3 5 2 2 3 3 2 2 2 2 1 1 1 1 1 1 1 2 1 1 0 2 2 1 1 2 2 2 2 3 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 0 1 1 1 1 1 1 3 2 2 2 3 2 2 2 0 2 2 2 1 1 2 2 2 2 2 2 2 1 1 1 2 2 2 2 2 3 3 3 3 3 2 2 1 1 1 1 1 1 1 1 1 1 1 1 2 3 3 3 2 2 2 2 2 2 2 2 3 3 2 2 2 2 2 2 1 1 1 1 1 1 1 5 2 2 0 2 1 1 2 2 2 2 2 2 2 2 2 3 3 3 0 1 1 1 1 1 1 1 1 2 2 3 2 0 2 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 3 3 0 1 1 1 1 1 1 1 2 3 3 2 2 2 2 2 3 3 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 2 2 3 3 3 3 3 3 3 3 3 2 1 1 2 2 2 1 2 2 2 2 1 2 3 5 1 2 2 2 2 2 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 2 2 2 2 3 3 3 2 1 1 1 1 1 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 2 2 1 3 3 3 3 3 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 2 2 2 2 2 2 1 1 1 2 3 2 2 2 2 2 2 3 2 2 1 1 1 1 0 2 2 3 3 3 3 3 3 3 3 3 3 2 2 0 1 2 2 2 1 1 1 2 2 1 1 2 3 0 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 3 3 2 1 1 1 2 2 2 3 3 3 2 3 3 3 3 3 3 3 3 3 2 1 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 2 2 2 2 2 2 2 2 1 2 2 2 3 3 3 2 2 2 1 1 2 2 2 5 2 1 1 1 2 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 3 2 2 2 3 2 2 2 2 3 2 1 2 2 2 3 3 5 2 3 3 3 2 2 2 2 2 2 2 1 2 2 3 1 1 1 1 1 1 1 0 2 1 1 2 2 3 3 3 3 3 1 1 1 1 1 1 2 2 1 1 1 2 2 2 2 2 1 1 1 1 1 3 2 2 2 2 2 3 3 3 2 2 2 2 0 3 2 3 2 1 1 1 1 1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 3 3 1 2 2 0 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 5 2 1 1 1 1 0 1 1 1 1 1 2 2 2 1 2 3 3 3 3 3 3 3 2 2 2 1 1 1 1 2 3 3 3 3 3 3 3 5 2 2 2 2 3 0 2 3 3 3 3 3 3 3 3 1 2 2 2 2 2 2 3 3 3 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 2 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 3 2 2 2 3 2 2 2 0 2 2 2 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 0 2 2 2 2 2 2 1 1 1 2 2 2 2 2 2 2 3 3 2 2 3 3 3 3 2 1 1 1 1 2 2 2 5 2 1 3 3 1 1 1 1 1 1 1 1 1 1 1 2 1 1 2 2 2 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 1 2 2 0 3 2 2 2 2 2 2 2 1 1 1 1 1 1 2 2 2 2 2 2 3 3 3 0 3 3 2 2 1 1 1 1 5 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 2 2 1 1 3 2 2 1 1 1 1 2 2 2 2 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 3 3 3 2 1 1 2 2 2 3 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 2 2 2 1 1 1 1 1 1 1 1 3 3 2 2 1 1 2 2 2 2 2 1 1 1 1 2 2 2 1 1 2 2 2 2 2 1 1 1 1 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 3 2 2 2 2 2 2 1 3 3 3 2 3 3 2 2 1 1 1 1 1 2 3 5 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 2 2 2 3 3 2 1 2 2 2 2 2 2 2 2 2 2 2 0 2 2 3 3 3 3 3 3 3 3 3 2 2 2 2 1 1 0 2 2 2 2 2 2 3 3 2 2 2 2 3 3 3 1 2 2 2 2 1 2 2 3 3 2 3 3 2 2 2 1 1 1 1 1 1 1 0 1 1 0 1 1 2 2 2 1 3 0 3 3 3 3 0 2 1 2 2 2 1 3 3 3 2 2 2 2 3 3 3 5 1 1 2 2 2 2 2 2 3 3 2 2 2 2 2 3 3 3 1 1 1 2 1 1 1 1 2 2 0 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 2 3 3 2 1 1 1 2 2 0 2 1 0 1 1 1 1 1 1 1 1 1 1 1 1 2 2 3 3 3 3 2 2 2 2 2 2 5 2 2 2 2 2 2 2 2 2 2 2 1 2 2 2 3 3 3 3 3 3 2 2 2 3 2 2 2 2 2 3 2 2 2 2 1 1 1 1 1 1 2 2 3 3 3 3 3 3 3 3 3 2 2 3 1 1 1 1 1 2 1 2 2 2 2 2 2 2 2 3 2 1 1 1 1 1 1 1 1 1 0 1 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 0 2 2 2 2 1 1 1 1 2 2 2 3 3 3 3 2 2 2 2 2 3 1 1 1 1 1 3 3 2 2 2 3 5 3 0 1 3 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 3 3 3 3 2 2 2 2 1 3 3 5 1 1 1 1 1 2 1 2 3 3 3 3 3 3 3 2 3 2 2 1 1 2 2 2 3 2 2 1 1 1 3 2 2 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 2 0 2 3 1 1 1 1 1 2 2 2 2 2 2 2 3 2 1 1 1 1 2 2 2 1 1 2 3 3 3 3 3 3 5 0 2 2 2 2 2 2 2 0 2 2 2 2 2 2 0 0 2 2 2 2 2 2 3 3 1 1 1 1 1 1 1 1 1 1 2 2 3 5 1 2 3 3 3 3 3 3 2 2 2 2 2 2 3 2 2 2 2 1 1 2 1 1 1 1 2 3 0 3 2 2 2 2 2 2 2 2 2 2 2 2 0 3 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 0 2 2 1 1 1 1 1 2 3 3 3 2 2 2 2 1 1 2 3 3 1 1 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 1 1 0 0 3 3 3 3 0 3 3 3 3 2 1 3 3 3 2 3 3 3 2 2 2 5 2 1 1 1 2 1 2 2 3 3 3 3 3 3 3 2 2 2 1 1 1 2 2 1 1 1 1 3 3 3 1 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 1 2 2 0 2 2 2 2 2 1 1 2 2 2 2 2 2 2 2 1 1 1 1 1 2 2 1 1 1 1 1 1 1 1 2 3 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 0 2 2 2 2 2 1 1 1 1 1 3 2 2 2 1 1 2 2 1 1 1 5 1 1 2 2 2 2 2 2 2 1 1 1 1 2 2 2 2 2 2 2 2 2 2 1 1 1 1 3 3 3 2 1 2 2 2 2 2 3 3 3 3 3 0 3 3 2 2 2 1 1 1 1 1 1 1 1 2 3 0 2 0 2 2 2 2 2 3 3 0 3 3 2 2 2 1 1 1 1 1 1 1 2 2 1 1 1 2 2 2 3 3 2 2 5 2 2 2 0 2 2 1 1 1 1 1 3 3 3 3 3 3 3 3 3 3 2 2 1 1 1 1 3 3 3 2 2 2 2 3 2 1 2 5 1 2 1 1 0 2 2 2 1 1 1 1 1 1 2 2 2 2 2 2 2 1 0 0 1 1 0 0 0 0 3 2 2 2 2 2 2 2 0 2 2 2 0 2 2 0 2 2 2 0 0 2 2 0 2 2 2 0 3 3 3 3 0 2 2 2 0 2 2 1 1 2 0 2 0 0 2 0 1 1 1 0 2 0 0 1 2 0 0 1 1 0 1 5 2 2 0 0 2 2 1 1 0 1 0 0 1 1 0 1 1 2 0 2 2 2 0 0 1 0 0 0 0 0 3 0 2 1 1 0 0 0 0 1 1 2 2 0 2 2 2 2 2 2 2 2 1 1 2 2 3 3 2 2 3 0 0 1 1 0 0 0 0 1 2 2 2 2 2 2 2 0 2 2 2 0 2 2 0 2 2 2 0 0 2 2 0 2 2 2 0 1 1 1 1 0 1 1 1 0 2 3 1 1 1 0 1 0 0 2 0 3 3 3 0 3 0 0 2 2 0 0 2 2 0 2 5 2 2 0 0 2 2 2 2 2 2 1 0 2 2 0 3 3 3 0 3 3 3 0 0 2 0 0 0 0 0 3 0 3 2 2 0 0 0 0 1 2 0 2 0 2 2 2 2 2 2 2 2 3 3 2 1 1 1 1 2 2 0 0 2 2 0 0 0 0 2 2 2 2 2 2 2 2 0 2 2 2 0 3 2 0 2 2 2 0 0 2 2 0 1 1 1 0 3 2 0 2 0 3 3 2 0 2 2 2 0 2 0 2 0 0 2 0 2 2 2 0 2 2 0 2 1 0 0 3 3 0 2 1 1 1 0 0 1 1 1 1 1 1 1 0 3 3 0 1 1 1 0 1 1 2 0 0 3 0 0 0 0 0 2 0 1 1 1 0 0 0 0 1 1 0 2 0 2 1 1 1 1 1 1 1 0 1 2 1 2 2 2 2 2 0 0 2 2 0 0 0 0 2 1 1 1 1 1 1 3 0 3 3 3 0 3 1 0 1 1 2 0 0 2 2 0 2 2 2 0 2 2 2 2 0 2 2 2 0 0 2 2 2 2 0 1 0 0 2 0 2 2 2 0 3 3 0 3 3 0 0 2 2 0 2 5 2 2 0 0 2 2 2 2 2 2 3 0 2 2 0 1 1 1 0 1 1 1 0 0 1 0 0 0 0 3 3 0 2 3 3 0 0 0 0 1 1 0 2 0 3 3 3 3 3 3 2 2 2 2 2 2 1 2 2 3 2 0 0 2 2 0 0 0 0 1 3 3 3 3 3 3 3 0 2 2 2 0 1 1 0 2 2 1 0 0 1 1 0 1 1 1 0 3 2 2 2 0 1 1 2 0 2 1 3 0 3 0 3 0 0 1 0 2 2 2 0 3 3 0 3 3 0 0 2 2 0 2 1 1 1 0 0 1 1 1 1 1 1 1 0 3 3 0 2 2 2 0 1 1 1 0 0 1 0 0 0 0 0 1 0 2 2 2 0 0 0 0 1 2 2 2 0 2 2 0 2 2 2 2 0 2 2 3 3 2 3 3 2 2 0 0 1 1 0 0 0 0 2 1 2 2 2 2 2 2 0 2 2 2 0 2 2 0 3 3 3 0 0 2 2 0 2 2 2 0 1 0 1 1 0 3 3 3 0 3 3 2 0 1 0 2 0 0 3 0 2 2 2 0 2 2 0 1 1 0 0 2 0 0 2 1 1 1 0 0 1 1 1 1 1 1 2 0 2 2 0 2 2 2 0 2 2 2 0 0 2 0 0 0 0 0 1 0 0 3 3 0 0 0 0 1 2 0 1 0 2 2 0 2 2 2 2 2 3 3 2 3 3 3 3 3 2 0 0 2 2 0 0 0 0 3 2 2 2 2 2 2 2 0 2 1 1 0 1 2 0 2 2 2 0 0 2 2 0 2 2 2 0 2 2 2 1 0 3 3 3 0 3 3 1 2 2 0 3 0 0 3 0 1 2 2 0 2 0 0 2 2 0 0 3 3 0 3 1 1 2 0 0 2 2 2 2 2 0 2 0 1 1 0 2 2 2 0 2 2 2 0 0 2 0 0 0 0 0 3 0 1 2 2 0 0 0 0 2 2 0 2 0 2 2 2 2 2 2 2 2 2 2 1 1 2 2 2 2 2 0 0 2 2 0 0 0 0 2 3 3 3 3 3 3 3 0 3 3 3 0 1 2 0 2 2 2 0 0 2 2 0 2 2 2 0 2 2 0 2 0 3 3 3 0 2 2 2 2 2 0 3 0 0 2 0 2 3 2 0 1 1 0 1 0 0 0 2 2 0 1 5 2 2 0 0 1 1 1 1 0 1 2 0 2 2 0 2 2 2 0 2 2 2 0 0 3 0 0 0 0 1 2 0 1 1 1 0 0 0 0 2 0 0 3 0 2 1 1 2 2 2 2 2 2 2 2 1 1 2 2 2 1 0 0 2 2 0 0 0 0 3 3 0 3 3 3 3 2 0 2 2 2 0 3 3 0 3 3 3 0 0 3 3 0 2 2 2 0 2 3 3 2 0 2 2 3 0 0 3 1 0 2 0 2 0 0 2 0 3 1 1 0 1 1 0 1 2 0 0 2 3 0 2 1 1 1 0 0 1 1 1 1 0 1 1 0 3 0 0 2 2 2 0 2 2 2 0 0 1 0 0 0 0 0 3 0 1 1 1 0 0 0 0 2 1 3 3 0 1 1 1 1 1 1 1 0 1 1 2 2 2 2 2 2 1 0 0 1 1 0 0 0 0 2 2 0 2 2 2 2 2 0 2 2 2 0 2 1 0 1 1 1 0 0 1 1 0 2 2 2 0 1 1 1 2 0 1 0 1 0 1 1 3 3 3 0 3 0 0 3 0 2 2 3 0 2 2 0 2 2 0 0 2 2 0 1 5 2 2 0 0 2 2 2 2 2 2 1 0 1 0 0 3 3 3 0 3 3 3 0 0 1 0 0 0 0 1 1 0 2 2 2 0 0 0 0 1 1 1 1 0 2 2 2 1 1 1 1 1 1 1 2 3 3 2 2 2 2 0 0 2 2 0 0 0 0 2 2 2 2 2 2 2 2 0 2 2 2 0 1 3 0 3 2 2 0 0 2 2 0 2 2 2 0 2 2 3 3 0 3 3 3 0 3 3 2 0 2 0 2 0 0 2 0 2 2 2 0 3 0 0 2 1 0 0 2 2 0 2 5 2 2 0 0 1 1 1 1 1 1 1 0 2 2 0 2 2 1 0 1 1 1 0 0 1 0 0 0 0 2 2 0 2 2 3 0 0 0 0 1 1 1 1 0 2 2 2 2 2 3 3 3 0 2 2 2 1 1 1 1 1 0 0 2 2 0 0 0 0 2 2 0 1 1 1 1 1 0 1 2 2 0 2 3 0 2 1 1 0 0 0 1 0 1 1 1 0 3 1 0 1 0 3 3 3 0 3 1 1 0 1 0 2 0 0 2 0 1 0 1 0 2 3 0 3 0 0 0 3 0 0 1 5 2 2 0 0 3 3 3 3 3 3 3 0 2 2 0 2 1 1 0 1 1 1 0 0 2 0 0 0 0 0 2 0 2 0 2 0 0 0 0 1 1 0 3 3 3 3 2 2 2 2 2 1 1 1 1 2 2 3 3 3 2 0 0 3 3 0 0 0 0 1 2 2 2 2 1 1 1 0 1 1 1 0 2 1 0 1 1 1 0 0 2 2 0 2 2 2 0 2 1 1 1 0 2 2 2 0 2 2 1 1 1 0 1 0 0 3 0 3 3 3 0 2 2 0 1 2 0 0 1 1 0 1 5 2 2 0 0 2 2 2 2 2 2 2 0 2 0 0 2 2 2 0 2 2 1 0 0 1 0 0 0 0 2 1 0 3 2 2 0 0 0 0 1 1 3 3 3 2 2 2 3 3 2 2 2 2 2 2 2 2 1 1 1 2 0 0 1 2 0 0 0 0 1 3 3 3 3 2 2 2 0 2 2 2 0 2 1 0 2 2 2 0 0 2 2 0 2 2 2 0 3 2 2 2 0 2 2 3 0 3 3 3 1 2 0 2 0 0 2 0 1 0 1 0 2 2 0 2 3 0 0 1 1 0 2 5 2 2 0 0 2 3 3 3 0 3 3 0 2 2 0 2 3 3 0 3 3 3 0 0 2 0 0 0 0 0 3 0 3 3 3 0 0 0 0 1 2 0 2 0 2 2 2 1 1 1 1 1 1 1 3 3 3 3 3 1 1 0 0 3 3 0 0 0 0 1 1 1 1 2 2 2 2 0 2 2 2 0 2 1 0 2 2 2 0 0 2 2 0 2 2 2 0 1 1 1 1 0 1 1 2 0 3 3 3 3 3 0 3 0 0 2 0 1 1 1 0 2 2 0 2 1 0 0 1 1 0 2 5 2 1 0 0 1 1 1 1 0 1 1 0 3 3 0 1 1 1 0 2 2 2 0 0 3 0 0 0 0 2 2 0 2 2 2 0 0 0 0 2 2 1 2 0 3 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 1 0 0 1 1 0 0 0 0 3 3 3 3 3 3 3 3 0 3 3 3 0 3 2 0 2 2 2 0 0 1 1 0 1 1 1 0 3 2 1 1 0 2 0 2 0 1 1 2 2 2 0 2 0 0 1 0 2 3 2 0 2 0 0 2 1 0 0 2 2 0 2 5 2 1 0 0 1 1 1 1 0 1 1 0 2 2 0 3 3 3 0 3 3 3 0 0 2 0 0 0 0 2 2 0 2 3 3 0 0 0 0 2 2 3 3 3 3 2 2 1 1 2 2 2 2 2 3 2 2 2 2 2 2 0 0 2 2 0 0 0 0 2 1 1 1 1 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 0 2 2 0 2 0 3 3 3 0 3 2 2 3 3 0 3 0 0 3 0 2 2 2 0 2 2 0 2 2 0 0 2 2 0 3 5 2 2 0 0 1 1 1 1 1 1 1 0 3 2 0 2 2 2 0 0 2 2 0 0 3 0 0 0 0 1 1 0 3 3 3 0 0 0 0 1 2 3 3 3 2 2 3 3 3 3 3 3 3 3 2 2 2 1 1 1 1 0 0 0 2 0 0 0 0 2 2 0 3 3 3 3 3 0 3 3 3 0 3 2 0 2 2 2 0 0 3 3 0 3 3 3 0 2 1 1 1 0 1 1 1 0 2 2 2 2 3 0 3 0 0 3 0 1 1 2 0 2 2 0 1 1 0 0 1 1 0 2 1 1 1 0 0 1 2 2 2 2 2 2 0 1 1 0 1 2 2 0 2 2 2 0 0 2 0 0 0 0 3 1 0 2 2 2 0 0 0 0 1 1 2 2 3 3 3 3 2 2 2 2 2 2 2 2 3 3 3 2 2 3 0 0 2 2 0 0 0 0 1 3 3 1 1 1 1 1 0 1 1 1 0 2 3 0 3 3 2 0 0 2 2 0 1 1 1 0 2 2 3 3 0 1 1 1 0 1 2 2 2 3 0 3 0 0 1 0 3 3 3 0 3 3 0 3 3 0 0 3 3 0 3 5 2 2 0 0 2 2 2 2 2 2 2 0 1 1 0 3 3 3 0 3 3 3 0 0 2 0 0 0 0 2 0 0 3 2 2 0 0 0 0 1 1 1 1 0 2 3 3 3 3 3 3 0 3 3 3 3 3 3 3 3 1 0 0 2 2 0 0 0 0 2 1 1 1 1 1 1 1 0 1 2 2 0 2 3 0 2 2 2 0 0 2 2 0 2 2 2 0 2 2 2 2 0 3 3 2 0 2 2 2 0 2 0 1 0 0 2 0 2 0 2 0 2 2 0 2 2 0 0 2 0 0 3 5 2 2 0 0 3 3 3 3 3 3 3 0 2 0 0 2 2 2 0 2 2 2 0 0 2 0 0 0 0 0 2 0 2 2 2 0 0 0 0 1 1 3 3 0 0 1 1 1 1 1 1 2 2 2 2 1 1 2 2 2 2 0 0 2 2 0 0 0 0 3 2 2 2 2 2 2 2 0 2 2 2 0 2 3 0 3 3 3 0 0 3 3 0 3 3 3 0 2 0 1 2 0 2 2 2 0 1 2 2 2 2 0 1 0 0 2 0 2 2 2 0 2 2 0 2 2 0 0 3 0 0 3 5 2 2 0 0 1 1 1 1 1 1 1 0 1 1 0 1 1 2 0 2 2 2 0 0 3 0 0 0 0 2 1 0 3 3 3 0 0 0 0 2 2 2 2 0 2 2 2 2 2 2 2 2 3 3 3 3 2 1 1 1 2 0 0 2 2 0 0 0 0 1 2 2 2 2 2 2 2 0 2 2 2 0 3 1 0 1 1 2 0 0 2 2 0 2 2 2 0 1 1 1 1 0 3 3 3 0 3 3 0 3 3 0 3 0 0 2 0 2 2 2 0 3 3 0 3 0 0 0 2 2 0 2 5 2 2 0 0 2 2 2 2 2 2 2 0 2 2 0 3 3 3 0 3 2 2 0 0 3 0 0 0 0 1 2 0 0 2 2 0 0 0 0 2 2 1 1 0 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 3 2 0 0 2 2 0 0 0 0 2 3 3 3 3 3 3 0 0 2 2 1 0 1 3 0 2 2 2 0 0 2 2 0 2 2 3 0 2 2 2 2 0 2 2 2 0 2 2 1 1 2 0 2 0 0 1 0 3 0 3 0 2 0 0 2 1 0 0 3 3 0 2 5 2 2 0 0 2 2 2 2 2 2 2 0 2 2 0 3 3 3 0 2 2 2 0 0 2 0 0 0 0 2 2 0 1 2 1 0 0 0 0 1 1 2 2 0 1 1 1 1 1 1 1 1 0 1 1 2 2 3 3 2 2 0 0 0 1 0 0 0 0 1 2 0 2 2 0 3 3 0 3 3 3 0 3 1 0 1 1 2 0 0 0 2 0 2 2 2 0 2 0 3 3 0 1 1 0 0 3 3 2 2 2 0 2 0 0 2 0 2 0 2 0 2 2 0 2 2 0 0 1 1 0 2 5 2 2 0 0 2 2 2 1 0 1 2 0 2 2 0 3 2 2 0 2 2 2 0 0 1 0 0 0 0 1 2 0 2 1 1 0 0 0 0 1 2 3 3 3 3 3 2 2 2 2 2 2 2 2 3 3 2 2 2 1 2 0 0 1 1 0 0 0 0 1 3 0 2 2 2 2 2 0 2 2 2 0 2 1 0 2 2 2 0 0 0 3 0 3 3 3 0 3 3 0 2 0 1 1 1 0 1 1 3 0 3 0 3 0 0 3 0 1 0 2 0 1 2 0 3 3 0 0 2 2 0 3 1 1 1 0 0 1 1 1 1 2 2 3 0 2 2 0 3 3 3 0 3 3 3 0 0 1 0 0 0 0 1 1 0 2 2 2 0 0 0 0 1 1 2 2 0 3 3 3 3 3 3 3 2 2 2 2 2 3 3 3 2 2 0 0 2 0 0 0 0 0 3 2 2 1 1 1 1 1 0 1 1 1 0 2 1 0 1 1 1 0 0 2 2 0 2 2 2 0 2 2 2 3 0 1 1 1 0 1 2 3 0 3 0 3 0 0 3 0 2 2 2 0 2 2 0 3 3 0 0 2 2 0 1 1 1 1 0 0 1 1 2 2 2 2 2 0 1 2 0 1 1 1 0 1 1 1 0 0 2 0 0 0 0 0 2 0 3 3 3 0 0 0 0 1 1 1 1 0 3 3 3 3 3 3 3 3 2 2 2 2 3 2 2 2 2 0 0 2 2 0 0 0 0 1 3 3 3 3 3 3 3 0 3 2 2 0 2 3 0 3 2 2 0 0 2 2 0 2 2 2 0 1 1 0 2 0 3 3 2 0 2 2 1 0 1 0 1 0 0 1 0 2 0 2 0 2 2 0 3 3 0 0 2 2 0 2 5 2 2 0 0 2 0 2 2 0 2 2 0 1 1 0 2 1 1 0 1 1 1 0 0 2 0 0 0 0 0 2 0 2 1 1 0 0 0 0 1 2 2 2 3 3 3 3 3 3 2 2 2 2 2 1 1 1 2 2 2 2 0 0 2 2 0 0 0 0 2 2 2 2 2 0 2 2 0 2 2 3 0 3 2 0 2 1 2 0 0 2 2 0 2 2 2 0 2 2 2 2 0 2 2 2 0 2 2 2 2 2 0 1 0 0 2 0 2 2 2 0 2 2 0 3 2 0 0 2 0 0 1 5 2 1 0 0 1 1 2 2 2 2 2 0 2 2 0 1 1 1 0 1 1 1 0 0 2 0 0 0 0 3 2 0 2 2 3 0 0 0 0 2 2 1 1 0 1 1 1 1 1 1 1 1 1 1 3 3 2 2 2 2 3 0 0 2 2 0 0 0 0 2 3 3 2 2 2 2 2 0 2 2 2 0 2 3 0 3 3 3 0 0 3 3 0 2 2 2 0 1 3 3 3 0 2 2 1 0 2 2 3 3 3 0 3 0 0 2 0 3 0 3 0 2 2 0 2 2 0 0 3 3 0 2 5 2 2 0 0 2 2 2 2 2 2 2 0 2 2 0 2 2 2 0 2 2 2 0 0 2 0 0 0 0 3 3 0 2 2 2 0 0 0 0 2 1 1 1 0 2 2 2 2 2 2 2 2 1 1 1 2 2 2 1 1 2 0 0 2 3 0 0 0 0 2 2 2 2 2 2 2 2 0 3 3 0 0 3 2 0 2 2 1 0 0 1 1 0 1 1 1 0 1 2 2 2 0 2 2 1 0 2 2 1 1 1 0 1 0 0 2 0 2 0 2 0 2 3 0 3 3 0 0 2 2 0 3 5 2 2 0 0 2 2 2 2 2 2 2 0 3 3 0 2 2 2 0 3 3 3 0 0 2 0 0 0 0 2 3 0 2 2 2 0 0 0 0 1 1 qtl/tests/test_tidyIO.Rout.save0000644000176200001440000000233012770016226016265 0ustar liggesusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.1.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(qtl) > data(hyper) > > # write to tidy format > write.cross(hyper, "tidy", "hyper_tidy") > > # read back in > x <- read.cross("tidy", "", genfile="hyper_tidy_gen.csv", + mapfile="hyper_tidy_map.csv", phefile="hyper_tidy_phe.csv", + genotypes=c("BB", "BA", "AA")) --Read the following data: 250 individuals 174 markers 2 phenotypes --Cross type: bc > > # compare results > comparecrosses(x, hyper) Crosses are identical. > > proc.time() user system elapsed 0.687 0.052 0.726 qtl/tests/test_scanonevar.R0000644000176200001440000000256112770016226015544 0ustar liggesuserslibrary(qtl) data(map10) map10 <- map10[1:2] set.seed(8789993) simcross <- sim.cross(map10, n.ind=125, type="bc", model=rbind(c(1, 50, 1.5), c(2, 50, 0))) simcross$pheno[,1] <- simcross$pheno[,1] + rnorm(nind(simcross), 0, 2*simcross$qtlgeno[,2]) simcross <- calc.genoprob(simcross) out <- scanonevar(simcross, tol=0.01) summary(out, format="allpeaks") #### data(fake.bc) fake.bc <- fake.bc[1:2,1:150] # only chr 1 and 2, and first 100 individuals fake.bc <- calc.genoprob(fake.bc, step=5) out <- scanonevar(fake.bc, tol=0.01) summary(out, format="allpeaks") covar <- fake.bc$pheno[,c("sex", "age")] out <- scanonevar(fake.bc, mean_covar=covar, var_covar=covar, tol=0.01) summary(out, format="allpeaks") #########Simulate a vQTL on Chromosome 1######## chromo=1 qtl.position=14 # 50 cM N=nind(fake.bc) a1<-fake.bc$geno[[chromo]]$prob[,,1] y <- fake.bc$pheno$pheno1 y <- y + rnorm(N,0,exp(a1[,qtl.position])) out <- scanonevar(fake.bc, y, mean_covar=covar, var_covar=covar) summary(out, format="allpeaks") out <- scanonevar(fake.bc, y, mean_covar=covar, tol=0.01) summary(out, format="allpeaks") out <- scanonevar(fake.bc, y, var_covar=covar, tol=0.01) summary(out, format="allpeaks") out <- scanonevar(fake.bc, y, tol=0.01) summary(out, format="allpeaks") qtl/tests/testaugmentation.R0000644000176200001440000000132012770016226015731 0ustar liggesusers# Test augmentation with MQM # # Note: the full version of this test has moved to ./contrib/bin/rtest, # as it takes a long time to run. The full version can be run with: # # cd contrib/bin # rm CMakeCache.txt ; cmake -DTEST_R=TRUE # make testR library(qtl) set.seed(1000) version = mqm_version() cat("R/qtl=",version$RQTL) cat("R-MQM=",version$RMQM) cat("MQM=",version$MQM) testaugmentation <- function(cross, ...){ crossML <- mqmaugment(cross, ...) res1 <- mqmscan(crossML,logtransform=TRUE) list(res1) } data(listeria) r <- testaugmentation(listeria) if(!round(r[[1]][3,3],3)==0.307) stop("Listeria ML dataaugmentation error") cat("testaugmentation.R, tests succesfully run!") qtl/tests/test_scanonevar.Rout.save0000644000176200001440000000576512770016226017242 0ustar liggesusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.1.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(qtl) > data(map10) > map10 <- map10[1:2] > set.seed(8789993) > simcross <- sim.cross(map10, n.ind=125, type="bc", + model=rbind(c(1, 50, 1.5), c(2, 50, 0))) > simcross$pheno[,1] <- simcross$pheno[,1] + rnorm(nind(simcross), 0, 2*simcross$qtlgeno[,2]) > simcross <- calc.genoprob(simcross) > out <- scanonevar(simcross, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 58.6 1.65 107.5 0.841 2 2 62.2 1.17 51.8 5.817 > > #### > > data(fake.bc) > fake.bc <- fake.bc[1:2,1:150] # only chr 1 and 2, and first 100 individuals > fake.bc <- calc.genoprob(fake.bc, step=5) > out <- scanonevar(fake.bc, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 9.8 0.995 20 0.514 2 2 30.0 2.200 50 1.702 > covar <- fake.bc$pheno[,c("sex", "age")] > out <- scanonevar(fake.bc, mean_covar=covar, var_covar=covar, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 5 0.725 37.1 2.31 2 2 30 5.202 30.0 2.28 > > #########Simulate a vQTL on Chromosome 1######## > > chromo=1 > qtl.position=14 # 50 cM > N=nind(fake.bc) > a1<-fake.bc$geno[[chromo]]$prob[,,1] > y <- fake.bc$pheno$pheno1 > y <- y + rnorm(N,0,exp(a1[,qtl.position])) > out <- scanonevar(fake.bc, y, mean_covar=covar, var_covar=covar) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 45 0.784 70.0 5.781 2 2 0 0.368 21.8 0.672 > > out <- scanonevar(fake.bc, y, mean_covar=covar, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 45 0.746 70.0 6.012 2 2 0 0.380 72.1 0.617 > > out <- scanonevar(fake.bc, y, var_covar=covar, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 45.0 0.896 70.0 3.41 2 2 72.1 0.645 21.8 0.53 > > out <- scanonevar(fake.bc, y, + tol=0.01) > summary(out, format="allpeaks") chr pos neglogP_mean pos neglogP_disp 1 1 45.0 0.838 70.0 3.486 2 2 72.1 0.654 21.8 0.486 > > proc.time() user system elapsed 8.548 0.071 8.682 qtl/tests/listeria.raw0000644000176200001440000004600712770016226014555 0ustar liggesusersdata type f2 intercross 120 133 1 symbols a=A h=H b=B c=C *D10M44 b--bhhhhabaaahahabhhhbah----haaabbbhhbbhbabhahhhh-b-abahhbhh bhhhahhhahhbh-b-h-aahbhhhhabahah---h---baa-b-abbhabhahbhahaa *D1M3 bbhbhhhhabhaahahabhhhbahhhhhhaaabbbhhbbbbabhahhhhhbb-b-h-bhh bhhhahhhahhbhhbhhhaahbhhhhabahahhhhhahbbaabbhhbbhabhahbhahaa *D1M75 bbhhhbhhhhhhhahbahahhhahhbhhhahhhbbbhbhbbabhaahahhbbhbhbhbhh bhhhhhhaahhbh-hahhhabahhhbabhh------------bb--bbb-----b--b-- *D1M215 hbhhhbhhbhhhhahbahhhaha-hhhaahhhabbbhbhbbaabhabahabbabhhhbhh bhhhhbhaahhbhhhahbbh-ahhhbhbahhhhhbhhhhahhbhhbbhbh-haabbbbah *D1M309 hhhhbbaabahhhahba-haahahhhha-hhbabbbhbabbaabhabahabbabbhabha bhbhhbhaahhbhhhhbbbhhahhhbabhhhhhabhhhaahhbhhahhbbahaabbbbah *D1M218 hhhhhbaabahhhahbahhaahahhhhahbhbabbbhbabbaabbabahabbabbhabha bhbhhbhaahhbhhhhbbbhbahhhbhbhhhhhab--haahhhhhahbbbahaahbbbah *D1M451 bhhbhbaahahhbahhhhbaahhhbhhahhahabbbhhabhahbbhbahabhabbbhhha bhbahbhhhhhhhhahbbhhbahhbbbhbhahhabhhhhaahhbaaabhbahaahbbbah *D1M504 bhhbhbaahahhbahhhhbaahhhbhhahhahabbbahabhahbbhbahabhabbbhhha bhbahbhhhhhhhhahbbhhbahhbbbhbaahhabhhhhaahhbaaabhbahaahbbbah *D1M113 hhbbhbhhhahhbahhhhbahhbhbhhahhahhbbbahabhaabbhbahabhabbbbhha hhbaahhhbhhahhahhbhababhhbbhbaahhabhhhhaabhhaahbhbahaahbbhah *D1M355 hhbbhbhhhahhbahhhhbahhbhbhhahhahhbbbahabhaabbhbahabhabbbbhha hhbaahhbbhhahhahhbhababhhbbhbaahhahhhhhaabhhaahbhbahaahbbhah *D1M291 hhbbhbhhhahhbahhhhb-hhbhbhhahhaahbbbahabhhabbhbhhabhabbbbhha hhhhah-bbhhahhahhbhababhhbbhbaahhah-hhh-abahaahbh-hhaahhbhah *D1M209 hhbbhbhh-a-h-ahahb-hh-bhbhaahhhahbhhahab-hah-h-hhhbhabbbbhha hhhhahhbbh-ahhahhbhababhhhbhbhaab-hhbhhaa-ahaahbhbhba-hhhhaa *D1M155 hhbbhbhhhahhbahahbbhhhbabhaahhhahb-----bhhahbhbhhhbhabbbbhha hhhhahhbbhhahhahhbhababhhhbbbhhabahhbhhaahahaahbhbhbaahhhhaa *D2M365 hbhabhbhaaabhhhbhbhhhh-hhahh--b-bbhabahaha-haahhaahaba-ahhhh hhba-bbhhhhhbbhbhhhbahhhbbhhhhhhhhhbhahhhhahbbbhhbhbaabhhaba *D2M37 abh-habhhaabhbhbbbhhhhahabhhahbhbhhhhbhaaahhahahhhhaahbhahhh babaabhhbahabhabhhhhhahhbabhhhhhaahbbaahbhhhbbhhbbabhhbhhabh *D2M396 ahhahabahhbhhbahhhahahababhbhhbbbhhhhbbaahhh-abhhhhhahbaah-h hhbahbhhbabahhabh-hhhahhbahhhhhbahahbhahbahhbbhhbbahhhhbbahh *D2M493 -----ab-hhbhhhah-haaahab----hhhbbahba-baah-a---------hb-habh hhbahb-h-a-a----hahhhhbhaahhahhbahhbbhhhhababbhabbhahbhbhhhh *D2M226 ah-h---ahhbhh-hahhaaaaabhhhah-hbhaababbh-hbaababhaabhhbabhb- hhbah-hbhahahhhahhhhhhbhaaaaahhhahhbbhhhhababbhahbhahbhbhhha *D2M148 aahhhahabhbhhhhahbhabahahahabhahhhhbabhhahbaabhbhahbhahabhbh hhbahbhbhahahhhahhbhhhbhaaaaahhhhhbhbhhhhabaabhahbhabhahhhha *D3M265 bbhbbbbhaahaabbhbaaabhahahahbhhhbahhhahaaabhahahhhhahbhhhhha hhhhaabhbhhhhaaahhhbhahbhhhhhhabhhhhhhaahahhaahabahhhhhhhhbh *D3M51 bbhhabhbhhahahb--aaahbhhahhabbahhhahhah-hahaahhhahhhbhhhhhhh hhhhhahbhhbhaaaabahbbaabaahahh------------------------------ *D3M106 bbhhabhhhhabahbhaahahbhhahhabbahhhhhhahhhhaaahhaahhhbahhhhab bhbahahbhhbhahhahahbbaabahhaaa------------------------------ *D3M257 bhhhabhhahhhahbhahaahbahahhahhhhahhhaahhhhaahhbaahhhbhhhhhab bhhahbhbbhbhahhahahhbahhahbaaaaahhhahhhahhbabah-hhhhh-ahhhhh *D3M147 bhbhabhhahhhabbhahh-hhabahhahhhhahbh---hhhaahhbaahhhbhhhahab bhhahbhbbhhhahhahhhhhahhahhaaaaahhhahhhahhbhbahhhhhhhaa-hhhb *D3M19 bhbhabhhaahhahbhahaahhabahhhhhhhahbhahahhhahbhbaahbbbhhhaaab bhhahbhbbhhhhbhahhhhhahhhhhhaa------------------------------ *D4M2 ahahahhhhbhhhhhbbaaahbbhhhahabhhhbhhahhhhbhhhhhahbhbhhhhhahh hhbbbhbhaabbaabhbahhhabbhhabbb------------------------------ *D4M178 hhahahh-hhhhhhhbhh-hhbbhhh-bhhhab-bbahhhbb-ah-hhh--h-hhhhhah hhbb-h-baahbbahhbah-hahb-ha-bb------------------------------ *D4M187 ahhhahhhhhhbhhbbhhhhhbbahbhhhbbabhbbahhbbbahhahhhhbabbahhhab hhbhhhbbhahbbhhbbhhbhahhhhabbb------------------------------ *D4M251 hhhhhhhbbhbbahbbhhahhbhbhbhhahhhbbbhabhhhbhbhahhahbabbhhhhab bahhhbbbbbhbhbhhhbhhbahahhbhahbahhahbhbhhhaaabhhahbahaabahhh *D5M148 aha--ahbhhhbhbahhhabhaa-bbhba-hahhbhbaabbhahbb--bhbhb-hhaaaa hahb-hhba-abhhh-a-hbbbahbbhhbahhhabahbbhhhhbabahbahhbhbhbhbh *D5M232 ahahaaabhhhbhbabhhahhaab-bhbahhahhbhbhabbhahbbaabhbhbbhhhaaa hahbhhbbhhhbbhhhaahhbbahbhhhbhhhhabhhb--h-hbaba-bahhb--hbhbh *D5M257 hhaaaaabhhhbhbhbhhahahabbhhbahaahhhhbhbbbhhhhbahbhbhbbahhaaa hhhbhhbbaaahbhhaaahabbahbabhbhhhhabhhbbhhahbababaahhbhhabhhh *D5M83 hhaaaaabhhhbhbhbhhahahabbhhbahaahhhhbhbbbhhhhbahbhbhbbahhaaa hhhbhhbbaaahbhhaaahabbahbabhbhhhhabhhbbhhahbhbabaahhbhhabhhh *D5M307 hhhaaaabahhbhbhbbhahahabhhhbahaahhhhbhbbbhhhhbahbhb-hbahhaha ahhbh-bbaaahbhhaaahabbahbabhbhhhhabhhbbhhaahhbabaahhb-hab-hh *D5M357 hhhaaaabahhbhbhbbhahahabhhhbahaahhhhbhbbbhhahbahbhbhhbahhahh ahhbhhbbaaahbhhahahabhahbabhbhhhhabhhbbhhaahhbabaahhbbhabhhh *D5M205 hhha-habahhbhbhbbhahahabhhhbahaahbhhbhbbbhhahbah--bhhbahhbbh ahhbhhbbahahbhaahahabhahbabhbbhhhbbhhbhhhaahhbabaahh-bhabhhh *D5M398 ------------------------hhhbahaahhhhbhbbbhhahbah--bhhbahhbbh ahhbhhbbahah-haahahabhahbabhbb------------------------------ *D5M91 hhhahhabahhbhbhbbhahahabhhhbahaahbhhbhbbbhhahbahbhbhhbahhbbb ahhbhhbhahahbhaahahabhahbabhbbhhhbhhhbhhhaahhbabaahhhbhabhhb *D5M338 hhhahhabahhbhbhbbhaaahhhahhbahaahbhhbhbbbhhahbahbbbhhbahhbbb ahhbhhhhabahbhaahahahhahbabhbbhhhbhhabhhhhahhbabahhhhbhahhhb *D5M188 hbhahhahahhbhbhbbhaaahhhahhbhaahhbhabhbbbhhaabahbbbahbahbbbb ahhbhhhhabhhbhhabahahhahbabhbbhhhbhhabhhhhahhbabahhhabhahbh- *D5M29 bbhah--h-hbb--hbbh-a--hhahhb---hhbha-hbbba-a-b-abb-aa-ahbbbb h-hbhh------bhhhbahahha-b-b-b------------------------------- *D5M168 bbaahhhhhhbbhhhhbhaaabahaahbhhahbbhabhbbbabaabaabhhaahahbbbh hbhbhhhhahhhbahhbaaahhbhbabbbbhhbbahaabhahhhhbabhhhbabhhhbhb *D6M223 aahhaahahhhhbhhhhahbbhhabbaahabhbhhbahahhbhbahhahhhhahbhhbhh haahabbhabbhhbhhhhhh-hbhahahhbhhhaahhhbabbaaahahbbbabaaabhbh *D6M188 aahhaahahhhhhbhhhahbhhhabbaahhhhbhhhabhhhbhbahhahhhhahbhhbhh haaaahhaabbhhbhhhhhhhhbbahahhh------------------------------ *D6M284 hahhaahahhhhhbhhbaabhhhahhaahhhhhhhhabhhhbhbahhahhhhahbhhhhh hhaaahhaahbhhbhhhhhhhhhbahahhhhhhahbhhbabhahhhahbhbahahabhbh *D6M39 hahhahhahhhhhbahbahbhhhahhaabhhhhhhhhbhhhbhbhhbahhhhahbbbhhh hhahahhahhbhhbhhhbhbhhhbahahhhhhhahbhhbahaahhhahbhbahahahabh *D6M254 habhabhhbhhhhbahbhhhhbhahhhhbhhhahhhhbhhhbhhhhbabhhhhhbbbhhh hhahhhhabhbhhbhbhbhbhhhbahahhahhhhabhhbahaahhhahhhbhhhhahhba *D6M194 habhabhhbhhhhbabbhhhhbhahhhhbhhhahhhhbhahbhhhhbahhhhhhbbbhbh hhahhhhabhbhhbhbhbhbhbabahahha------------------------------ *D6M290 habh-bh-bhahhba-bhhhhbhah-------a-hhhbhahb-ah-ba-h---h-bbhbh hh-hhhhabhbh---bhb-bhbabahahha------------------------------ *D6M25 habhhbbbhhahhbabbhhhhbhahhhhbhhbahhhhbhahh-ahhbahhbhhhbbbhbh hhahhhhabhbhhbabhbhbhbabahahhahhhhahhhbah-hhhaabhhbhh--hhhba *D6M339 habhhbbbhaahhbabbhhhhbhahhhhbhhbahhhhbhahhhahhbahhbhhhbbbhbh hhahhhhabhbhhbabhbhbhbabahahhahhhhahhhbahahhhaabhhbhhhbhhhba *D6M59_ bhbhhbbbhaahhbabhhhhhbhahhhhbhhbaahhhbhahhhahhbahhbhhhbbbhhh hhahhhhabhbhbbabhbhbhbabahahha------------------------------ *D6M201 bhbbhbbbhaahhbabhhbhhbhah-hhbhhbaahhhbhahhhahhbahhbhbhbbbhhh hhahhhahbhbhbbabhbhbhbahahahhahhahahhhhhhahhhaabahbhhhbhhhha *D6M15 bhbbhbbbhaahhbabhhbhhbhahhhhbh-bahhhhbhahhhahhbahhbhbhbbbhhh hhahhhahbhbhbbabhbhbhbahahahhahhahahhhhhhahhhaabahbhhhbhhhha *D6M294 bhbbhbbbhaahhbabhhbhhbhahhhhbhhbahhhhbhahhhahhbahhbhbhbbbhhh hhahhhahbhbhbbabhbhbhbahhhhhhhhhahahhhhhhahhhaabahbhbhbhhhha *D7M246 bhabbaahbhhhababahhhhhabhhhbbhbabhhhhbbhhhahbhbaahbaahhhhabb hhbbahhhhaahhbbhhhhahabhbaabab------------------------------ *D7M145 bbabhaahbaahhbhbhhhhhhhhhahhbababhhhhbbbbaaabhha--bahahhhabb hhbhhbhaha-hhbhhhhhhhhbabaabh-babhbahhhahbhbabhhhhhahhbhahaa *D7M62 hbabaaahbahhhhhbhhhbahbhhbhhbababahhbbbbbaaabhhaabbahhhhhahb hhbhhbhahhbhhhhhbhhhahhahahbhhbahhh-hhbahaahahhahh-ah-bhahbh *D7M126 hbabaahhbah-h-hbhbhbaab-hbhhbababahhbbbabaaabhh--bbahhahha-- habhhb-a----h-hhbhh-a-h-a-----ba-hhah-bab-ahaa-abhaahb-h-hbh *D7M105 hbabhahhbhhhhhbbbbahaabhbhhahhbhbahbbbbabaaabbhaabahahahbhhh bhhhhhbahhbbbabhbhhhabahahhhhhbahhhaahhhbaahaahabhhahbhbhhbh *D7M259 hbahhahbhh-hhhhbhbahhaha--b-hhb-b--bbbhahh-a--haa-ahaha-bhhh bhahhh----hbbahhbhhhahahahbhhh------------------------------ *D8M94 hhhbahbabbahhahbbhbbahahahhbbahbbhbhbahahahabhbhbbhhaahbhhhh hhhahahhbhbbhahhbbhhhhhhhhaahhhabhabbbhabbhhahbaabhbhaaabhhh *D8M339 hhhbahbabbahhahbbabbahahahbbbahbbhbhhahahahabhbhbbhhaahbhhhh bhhahahhbhbbhahhbbhhhhhhhhaahhhabhabbbh-bbhha-baabhbhaaabhhh *D8M178 hhhbabbh-bahhahbbabbabhhahbbbhhbbh-hhahahhhabhbhbbhhhaahahhh bhhhhahhbhbbha-hbhhhhhhh-aaahhhahhhbbbbabbhbhhbaahhbh-aahhaa *D8M242 hbbbabbhbhabhaabbahhhbhhaabbbhhhbhbhhahhahhabhaabbahhaahabbh bhhhhahbhhbhhahbhahhhhhhhaaaab------------------------------ *D8M213 bbhbabbhbhabhaabb-hhhbhhhabbbbhhbhbhaahhahhahhaahbahhaahabbh bbhhhahbahbhhahbhahhhhhbaaaaabhhh-hbbh-abbhbbabhahabhbaahhhh *D8M156 bbhhhhbhahahhhahhaa-bbhhbhhbhbh-b-bhahhhhh-a--aa-bah-a--abbh b-ab-a-ba-bh-ah-aahhbhab-ahhh-hbhhabbhbabahbbahhhhhbhbahhhhh *D9M247 bhbhbhbbhbhahbhhbaahhahhhhahhbahhhhhhhhbabhbhbbbahahhhhahhba haaabbbbhhhhahaabhhahaahahhbhbaahhbhahabhaabbhhhhhh-ahbbahba *D9M328 babhbhbbhbhahbhhbaahhahhhhabhhahhbbhhhhbabhbhbbbahahhhaaahba haaabbbbhhhbahaabhhahaahahhbhbaa-h--hh-b--aabhbhh-hbah---hba *D9M106 habhbhbbhbbahbahhaahhahhhhabhhahhbbhbhhbabbbhbbbhaahhhaahabh hhaabbbhbhhhhhhabhhahaahahhbhhhahhbahhhbhaahbhbbbhhbhhbbahba *D9M269 hhbhhhababbaabahhhhhahhhhhabh-aahbbhbhhhab-ba--bhaabhhaahah- h-aa-hbhbhhh-hhabbhabahhabhhhh------------------------------ *D9M346 hhbhhhababbaabahhhhhabhhhhabhhhahbbhbhbhhhbbabbb-------a---- ---a--------hhhabbhahahbabhhhhhahabhbbhbhhahbhbbbaabhhbbaaba *D9M55 hhbhhhabahbaabahabhaabhhhhabhhhahbbhbhbhhhabahbhhahbbhhhhaah baaahhbahhbahahahbaahahbabhhha------------------------------ *D9M18 hhbhhhahaabaahahabhaabhhhhahhbbahbbbbhbhbhabahbhhahhbhhhhaah baaahhbahhbahahahhaahhababbhha------------------------------ *D10M298 hahaahhahaabhbhhabhhhahhabhaaahbaabhhhahhhhahahhabbhbhhahhaa habhaaaahhhahahhhbba-haaahhaaahhhhabbhhbhhbhhabbahhhahbbahhh *D10M294 haahhhhabhhbahahabbbhahaabhahhhhhahbhhhaahhaaahhabbhbhhhhhha habhahaahbhahahbabhahhhhahaaaa------------------------------ *D10M42_ baabhhh-bhhbhhahaabbhahhabhhhhah-ahbhhhaahahahhh-hhhbhb-bhha babhhhhhhbhabaababhhhhhhahahaaabhhhhahbhhabaahhabhhhbhahhhbh *D10M10 baahhhhabhhbhhabaabbha-hhhhhhhahhhhbhbhaahahahhhaahabhbhbhha bhhhhhhhhba-haahabhhhhhhahabaaabhhhhhbahh-b-abhab-hh---h-h-- *D10M233 baahhhhabhabhhbbhabhhaabhhhhbaabhhhbhbbaahahhbhhaaahhhbbhhha bhhhbhhbhbhahaahabbhbhhhahabaaabhhhhhhabhabaahhhbhhhbhhhhhbh *D11M78 hahbbhahbaababhhahbhahhbhhhhhhaahhhhbaahhhbhhhhbaaahhahhhaab bbhhaahbbabhhhhhhbhbabhahbhahh------------------------------ *D11M20 hahbbbabbhhbahahahbbahhbhhabbha-hhhhbaahbhbhhaabaa-hbh-hhhhb bbhbaahbbhhhhhhhhbhbabahhahahhhbhbbhhaahbhhhhhhhbhhbhhahhhhh *D11M242 hahbbbahhhhbahaba-hbhbhbhhabbhhhbhhhhhahb-bbhaabaaahbhahhbhh bbhba-hbbhabhhhhhbhhabahbahhaa--hbbh-aah-bhhh-hhbhhb-hhhhhhb *D11M356 aahbbbhbhhhbahhhahhbhbhbbhabbhhhbhhhhhhhbhbbhaahhbaabbahhhhh bbhbhahhbhabbhhbhbhha-abbaahaa------------------------------ *D11M327 aahbbbhbhhhbahahahhbhbhbbhabhhhabhahhhhhbhbbhaahhbaabbaahhhh bbhbhahhbhabbhhbhhbhababbaahaaahhbbahaahhbahhhhabhhbhhbbbbhb *D11M333 hahhhbbhhbhhhaabbhhbhbhbhhabhhhabbahhhhhbhbbahhhhbhhbbaaaaha aahbhahhbhabbbbhhahhabhhbahhahhhabbah-hha-hbaahabhh-ahbbbhhb *D12M105 babaabbaaaahahhhaahbabahhahahbabhhbhhahaahbhabhhaabahaahaaba hbhbhbbhhabhbhbbhhahahhbhbbhah------------------------------ *D12M46 babaabhha-aaahhhaahbabahhahaahabhhbhhahaaab-abhhaa-aaaahaaha hbababbhhabhbhbbhhhhahhbhbbhah------------------------------ *D12M34 bhhhahahhaaaahhhaahbahahhahhahabbhhhhahhaahbhhhhaahaaaa-aaha ahahhbbhhh-hbabbhhhhaahhhhbhabahbhhhbhhhhbaaahhabhbhbahhhhbh *D12M5 bbhaahahhaha-hhhahhbahahhhhbahabbhahhahhaahbahbhaahaaaahhaha ahaahbbhbhbababbbbhhaaahhhbhabahbhh-bhbhh-aaahhab--hbahhh-bh *D12M99 bbhaahahhahaahhhahhhbhhhbhhbhhaabhhhhabhaahhahhhaahahaabhaha ahaahbbhbhbabahbbbbhaaahhhbahh------------------------------ *D12M150 bhbaahahhabhhbhhaha-bhhhbhhbhhaabhh-hhbbaa-hah-haabahaabha-h ahhabbbbbhbabahhbbbhaaaahbbabhahhhhhbahahaahhhbhbbbhhhbahahb *D13M59 caacccccaccacccaccccccccbbhhhaabahahahbabbhhhhhhcccacccccaaa cacccacacacccaahbhccacaacccaacccacaaacaccccccccaccccccaacccc *D13M88 -aahhhhhahh-hbhabbbhhh--bbhhhaabahahahbabbhhhhhhabbabhhhbaaa hababahahahbbhahbhhhahaahb-a-hhhahaaahahhhhhhhhahhhhhhaahhhh *D13M21 hhahh-bhahhaabaabbbhh-hhbbhhhaa-a-ah-hhab-b---hahbb-bah-b-a- b-b-b-aahaabbhahbhbaabaah-haahhhahaahhahhhhhaahahhhhhhaahahh *D13M39 hhahhhbaahhaabaabbbhhhhhbbbhhaahahahahhab-bhhahahb-abahhbaaa hhbbbaaahaabbhahbhbaahaahahaah------------------------------ *D13M167 hhahhhbaahhaabaabbbhhhhhbbbhhaahahahahhabhbhhahahbbabahhbaaa hhbbbaaahaabbhahbhbaahaahbhaa------------------------------- *D13M99 ahahhhbaahhaabahbbbahhhabhbhhaahahabahhabhbhhahabbbabahhbaaa hhbbbaaahaabbhahbhhahhaahahaahhhahaahaahabhhaaaahbahhhaahahh *D13M233 a-ahhhb-ahhaabahbbbahhhahhbh-aa-ahabahhabhbhhahabbbab--ab--a h-bbbaaahaahbhahbhh--ha-h-haahhhahaahaahabhbaaahhbahhhaa-ahh *D13M106 ahhhhhbaahhhabahbbhahhhahhbhhaahahabahhabhbhhhhabbhabahabaaa hhbbbaaahaahbhahbhhahhaahahaaaahahaahaahabhbaaahhbahhhahhhhh *D13M147 ahhhhhbaahhhabahbbhahhhahhbhhaahahabahhabhbhhhbabbhabahabhaa hhhbbaaahaahbhahbhhahhaahahaaaahahaahaahabhbaaahhbahhaahhhhh *D13M226 ahhhhhb-ahh-hbhhb-hahhhahhbhhaaaah---h--b-bhh-habbhabahab--- hh-bb-aa--ahbhahbhhahha-h--aaa-hahaah--habh---ahhbahh-hh-hhh *D13M290 ahhhhhbaahhhhbhhbbhahhhahhbhhaahahabahaabhbhhhhabbhabahabhaa hhhbbhaahaahbhahbhhahhaahahaaaahahaa-aahabhbaaahhbahhahhhhhh *D13M151 ahhhhhbhahhhhbhhbbhahahahhbhhabaahhbahaahhbbhhhabbhabaaabhhh hhhbbhaabaahbhahbhhahhaahahaaa-aabahhhaaabhbaaahhbahhhbhhhhh *D14M14 babhhaahbabbbhabahabbhahhbbbhhhhhhhhahahhahhh-bhahbbhhbhhbba hahahhhhhabb-hhbbbahhhhhaahhab------------------------------ *D14M115 bbbahahbbhhbbhaaahhhhaahhhhhhhhbhhhhahaa-a-a----hhbbhhbahhbb hahahhh---bbhbbbbbhhahahhahhabahbhbhahbahhhhbhbaahahhhhaahhb *D14M265 hbbahahhbbhbbhhaahhaaaahhhhhhhhbhbhhahaahabhbhaahabhhhbahhhb hahaahbbhhhbhbbhbbhhahahhahaabahbhbhah--hh-hbhhaa-ahhhhhahhb *D14M266 hbhhhahhbhhbbhhhhhbaahahhhhhhhhhhbhhahhahbbhbhhahabhhhhahhhb haahhhbbhhhhabbhbhbaahaahahaab------------------------------ *D15M226 abbhahabhhahah--hhhbbhhbhabhbhhahahbhh--hhhaaabhhhahahhahhhb hb--hhhhhbbaahhbahahhhbbba--hbabaahhhhhbhhhhabhabhabbbbahahh *D15M100 hhbbahabahahab-aahabbhabhhbbhhhahahhhhbbh-------hhabhhhaahhb abhb------bhhhhbahabhhh-ba---babaahhhhhbhahbabhhbhabbhbaaahh *D15M209 hhbhababahahabaaahabbhabhhbbhhhhhahhahbbhahaaahhhhhbhahaahbb abhbahbhhbb-hhhbhhabhhhbbahbhbhbaahhhhhbaahbabhhbhhbbhbaaahh *D15M144 hhbhababahahabaaahabbhabhhbbhhhhhahhahbbhahaaahhhhhbhahaahbb abhbahbhhbbhahhbhhabhhhbbahbhb------------------------------ *D15M68 hhbhabahahahabaaahabhhabhhbbhhhhhahhahbb-ahhaa-bhhhbhahaahbb abhbabbahbbhahhbhhabhahbbahbhbhbaaahhhhbaahbhb-hbhhbhhbaaahb *D15M239 hhbhabahahahhbaaahabhhabhhbbhhhhhahhahbbhahhaahbhhhbhahaahbb abhbabhahbbhahhbhhabhahbbahbhbhbaaahhhhbaahbhbhhbhhhhhbaaahb *D15M241 hhbaabahahahhbaaahahhhabbhbbhbhbhahhahbbhahhhah-aahbhahaahbb abhhabhaa-b-ahhbhhabhah-hah-hhhbhaahhhhbaaabhbhhbhhhhhbaaahb *D15M34 hhbaab-hahhhhb-a-h-hhhabbhhbbbhhhahaahhb-abbh-hbaab-babaahb- ahb-abbaa-b-ahhbhh-bbaahhahbah------------------------------ *D16M154 ahbaahbbhbbbbhhbbahhhaaahbahhaahhahhabhaahbbaabhhaahbabhhbbh hhbaaabhbhhahhbbaahhbhbahhbbaa------------------------------ *D16M4 ahbhbhhbbbbbhahbhabhhaaahbabhahhhaahhbhaahbbaabhbaahbabh-hhh hhbhaahbbhhhbabhahahhhbhbhbbaaahbaahhbaaahahbhbhhhbbhaahhhhh *D16M139 ahbhbhhbbbbbhahbhabaahaabbabhabhhaahbbhaahbbaabhbahhhahhhhhh hhbhahhbbhhh-ahaahahhabhhhabaa------------------------------ *D16M86 aabbbhhbbhhhhahhaabaahhabbabhhbhhaahbbhahhhbahbhbahahahahbhh habbhhhbbhhhhhhahhhabahhhhahaa------------------------------ *D17M260 hhaaahhhaahhhbhbaabhbhhhhhabhhhahhbahhbhabhhahhaabhhhaababhh hbhhhhabbhhhhhhhbbhabbbahbaabb------------------------------ *D17M66 hhahahahaabhhbhbahbhbhhhhhabhhhahabahhbhabhhhahaabhhhaahabbb hbhhhhhbhhhbhhhhhbbabhbbhbabhb------------------------------ *D17M88 hhahahahhabhhbhhah-hbhhhhbabhhhhhhbahhbhabhh-a-aabhbhhahabbb hhhhhahbhhhbhhhhhbbabhhbhbabhb---b---a-ah-h-hhabh-hahaa--bbh *D17M129 hhabhbhhhabhhbhhahhbh-hbbhahabbhahbahhbhabh-hahhahhbhhahahbb hhahbahbahhbbahahhbhhahbbbabhhbbhbaabhbahhabhhaa-hahhhahhhbb *D18M94 bbhaahhabaahhabbahhahhaahhaaahaabhbhhbhaabbaabbbhhhhahhbahbb hhhhbhbahahahhahhhbbaaahhhahah------------------------------ *D18M58 bbhaahhabaahhab--hhah-aahhhaahaabhbhhb-aabba-bbbhhhhahhbahbb hhhhbhbahahahhahhhbbaaahhhabahhbahh-aaahhhbbhhbhbhb-ahhbhhhh *D18M106 bhbaahb--aahh-b---------------------------------ahhbhhbbahah ahhh--bahahhh-ahhaabaaahhhabhhahabhbhaahh-hbhbbhhhbhhahbahhh *D18M186 bhbaahbhbaahhhbbabhahhaabhhaahaahhbhabhahbbhabbhahhbbhhbahah ahhhbhbahahhhaahbaabahahhhabhbahabhbhaahbhhbhbbhhhbhaahbabhh *D19M68 hahbhabhhhbaahhbhhbbhaahhbhbhhhhhbhhhhahbbbaahhhhbahahhhbaha babbhbhaahbhbhaahhabhhabaahhah------------------------------ *D19M117 hhhhaabhhbhaabhb--bbhaahbbhhhhhhhhahhhaa--baaahhabahahhhhahh haabhhaaahbhbbahhhabhhhbabhhaa------------------------------ *D19M65 hhahaaahhbhha-hbahbbhahhhhbhhhhhhhaahhbahbbahah-ahhaahahhahh haabahhaabbhhbabahabhhbbabbhah------------------------------ *D19M10 ccacccacacccacacaa-ccacccccccccccccaaccacccacaccaccaacaccacc caacaccaccccccccacaccaccaccccc------------------------------ *DXM186 hhhhaahaahahhaaaaaaahhaha-ahahhhhhaaaahaaaahhaahaaahhaahhaaa aahhhaahhhhhahhaahhhhhaaaaahaaaaaaaahhhaaaaahhaaaahhaaaaahha *DXM64 hhhaahh-hahhhhaahahhaaahahaahhhhhhhahahhhahhha--haahahahhhaa a-hhhaahhaahhhhhaahhahaaaahaahahaahhh-aaaaahhhhaaahhahaahhaa *T264 118.317 264 194.917 264 145.417 177.233 264 76.667 90.75 76.167 104.083 194.5 75.917 75.833 90.25 103.667 128.4 122.25 264 72.6 264 264 264 81.717 264 264 116.483 87.467 264 - 74.417 264 264 174.567 88.583 264 95 264 86.05 71.517 112.767 264 264 117.817 185.3 85.367 264 70.883 98.45 85.1 216.367 94.65 111.817 90.9 264 170.517 111.717 264 75.383 84.35 97.667 97.783 264 90.433 264 90.05 90.083 90.117 264 71.967 264 - 264 264 74.267 - - 264 264 264 109.867 264 264 96.017 136.417 168.25 120.7 114.55 94.033 67.683 93.833 93.867 139.867 117.933 77.8 117.833 264 77.733 93.183 77.633 77.55 264 117.433 93.067 99.867 82.333 163.75 82.017 264 264 91.283 140.767 81.733 75.667 76.483 116.467 116.517 139.55 264 116.2 qtl/tests/listeria.map0000644000176200001440000000402012770016226014526 0ustar liggesusers1 D10M44 0.00 1 D1M3 1.00 1 D1M75 24.85 1 D1M215 40.41 1 D1M309 49.99 1 D1M218 52.80 1 D1M451 70.11 1 D1M504 70.81 1 D1M113 80.62 1 D1M355 81.40 1 D1M291 84.93 1 D1M209 92.68 1 D1M155 93.64 2 D2M365 0.00 2 D2M37 27.94 2 D2M396 47.11 2 D2M493 67.26 2 D2M226 77.40 2 D2M148 90.86 3 D3M265 0.00 3 D3M51 32.48 3 D3M106 43.94 3 D3M257 57.59 3 D3M147 63.19 3 D3M19 70.84 4 D4M2 0.00 4 D4M178 19.16 4 D4M187 35.32 4 D4M251 68.10 5 D5M148 0.00 5 D5M232 6.10 5 D5M257 19.22 5 D5M83 19.55 5 D5M307 23.72 5 D5M357 25.50 5 D5M205 30.90 5 D5M398 30.91 5 D5M91 32.91 5 D5M338 38.07 5 D5M188 44.02 5 D5M29 50.98 5 D5M168 61.88 6 D6M223 10.00 6 D6M188 18.19 6 D6M284 23.87 6 D6M39 31.09 6 D6M254 41.80 6 D6M194 45.15 6 D6M290 47.53 6 D6M25 51.25 6 D6M339 51.65 6 D6M59_ 55.30 6 D6M201 59.01 6 D6M15 59.37 6 D6M294 60.76 7 D7M246 0.00 7 D7M145 18.79 7 D7M62 34.91 7 D7M126 41.03 7 D7M105 60.11 7 D7M259 72.08 8 D8M94 0.00 8 D8M339 1.34 8 D8M178 11.42 8 D8M242 27.14 8 D8M213 32.99 8 D8M156 50.86 9 D9M247 0.00 9 D9M328 4.22 9 D9M106 14.72 9 D9M269 27.32 9 D9M346 32.96 9 D9M55 45.34 9 D9M18 52.50 10 D10M298 0.00 10 D10M294 24.75 10 D10M42_ 40.71 10 D10M10 48.73 10 D10M233 61.06 11 D11M78 0.00 11 D11M20 15.15 11 D11M242 26.42 11 D11M356 38.52 11 D11M327 42.16 11 D11M333 64.34 12 D12M105 0.00 12 D12M46 6.18 12 D12M34 21.58 12 D12M5 29.08 12 D12M99 41.80 12 D12M150 54.46 13 D13M59 0.00 13 D13M88 0.29 13 D13M21 10.37 13 D13M39 13.05 13 D13M167 13.06 13 D13M99 18.91 13 D13M233 21.01 13 D13M106 24.88 13 D13M147 26.16 13 D13M226 28.39 13 D13M290 28.40 13 D13M151 35.99 14 D14M14 0.00 14 D14M115 23.91 14 D14M265 32.79 14 D14M266 45.55 15 D15M226 0.00 15 D15M100 13.46 15 D15M209 18.79 15 D15M144 19.36 15 D15M68 23.91 15 D15M239 25.13 15 D15M241 31.28 15 D15M34 42.97 16 D16M154 0.00 16 D16M4 16.77 16 D16M139 26.23 16 D16M86 41.80 17 D17M260 0.00 17 D17M66 11.73 17 D17M88 17.34 17 D17M129 38.85 18 D18M94 0.00 18 D18M58 0.69 18 D18M106 16.98 18 D18M186 20.90 19 D19M68 0.00 19 D19M117 16.36 19 D19M65 32.83 19 D19M10 44.49 X DXM186 0.00 X DXM64 42.35 qtl/tests/map.txt0000644000176200001440000000345412770016226013543 0ustar liggesusers20 13 0.0100 0.2219 0.1508 0.0947 0.0280 0.1665 0.0069 0.0969 0.0077 0.0353 0.0769 0.0096 D10M44 D1M3 D1M75 D1M215 D1M309 D1M218 D1M451 D1M504 D1M113 D1M355 D1M291 D1M209 D1M155 6 0.2536 0.1828 0.1913 0.1000 0.1314 D2M365 D2M37 D2M396 D2M493 D2M226 D2M148 6 0.2857 0.1126 0.1333 0.0557 0.0759 D3M265 D3M51 D3M106 D3M257 D3M147 D3M19 4 0.1827 0.1562 0.2877 D4M2 D4M178 D4M187 D4M251f 13 0.0574 0.1154 0.0033 0.0400 0.0175 0.0513 0.0000 0.0197 0.0490 0.0562 0.0650 0.0979 D5M148 D5M232 D5M257 D5M83 D5M307 D5M357 D5M205 D5M398 D5M91 D5M338 D5M188 D5M29 D5M168 13 0.0755 0.0537 0.0672 0.0963 0.0324 0.0233 0.0358 0.0040 0.0352 0.0357 0.0036 0.0137 D6M233 D6M188 D6M284 D6M39 D6M254 D6M194 D6M290 D6M25 D6M339 D6M59_ D6M201 D6M15 D6M294 6 0.1795 0.1559 0.0609 0.1821 0.1175 D7M246 D7M145 D7M62 D7M126 D7M105 D7M259 6 0.0134 0.0995 0.1522 0.0582 0.1715 D8M94 D8M339 D8M178 D8M242 D8M213 D8M156 7 0.0421 0.1035 0.1235 0.0561 0.1213 0.0712 D9M247 D9M328 D9M106 D9M269 D9M346 D9M55 D9M18 5 0.1952 0.1366 0.0741 0.1093 D10M298 D10M294 D10M42_ D10M10 D10M233 6 0.1471 0.1108 0.1187 0.0363 0.2083 D11M78 D11M20 D11M242 D11M356 D11M327 D11M333 6 0.0615 0.1493 0.0745 0.1244 0.1240 D12M105 D12M46 D12M34 D12M5 D12M99 D12M150 12 0.0029 0.0912 0.0262 0.0000 0.0552 0.0206 0.0372 0.0126 0.0218 0.0000 0.0705 D13M59 D13M88 D13M21 D13M39 D13M167 D13M99 D13M233 D13M106 D13M147 D13M226 D13M290 D13M151 4 0.2224 0.0879 0.1249 D14M14 D14M115 D14M265 D14M266 8 0.1315 0.0531 0.0057 0.0454 0.0121 0.0612 0.1149 D15M226 D15M100 D15M209 D15M144 D15M68 D15M239 D15M241 D15M34 4 0.1617 0.0935 0.1508 D16M154 D16M4 D16M139 D16M86 4 0.1152 0.0558 0.2028 D17M260 D17M66 D17M88 D17M129 4 0.0068 0.1391 0.0377 D18M94 D18M58 D18M106 D18M186 4 0.1580 0.1589 0.1146 D19M68 D19M117 D19M65 D19M10 2 0.3447 DXM186 DXM64 qtl/tests/phe.txt0000644000176200001440000000131612770016226013535 0ustar liggesusersT264 118.317 264 194.917 264 145.417 177.233 264 76.667 90.75 76.167 104.083 194.5 75.917 75.833 90.25 103.667 128.4 122.25 264 72.6 264 264 264 81.717 264 264 116.483 87.467 264 - 74.417 264 264 174.567 88.583 264 95 264 86.05 71.517 112.767 264 264 117.817 185.3 85.367 264 70.883 98.45 85.1 216.367 94.65 111.817 90.9 264 170.517 111.717 264 75.383 84.35 97.667 97.783 264 90.433 264 90.05 90.083 90.117 264 71.967 264 - 264 264 74.267 - - 264 264 264 109.867 264 264 96.017 136.417 168.25 120.7 114.55 94.033 67.683 93.833 93.867 139.867 117.933 77.8 117.833 264 77.733 93.183 77.633 77.55 264 117.433 93.067 99.867 82.333 163.75 82.017 264 264 91.283 140.767 81.733 75.667 76.483 116.467 116.517 139.55 264 116.2 qtl/tests/test_tidyIO.R0000644000176200001440000000051312770016226014601 0ustar liggesuserslibrary(qtl) data(hyper) # write to tidy format write.cross(hyper, "tidy", "hyper_tidy") # read back in x <- read.cross("tidy", "", genfile="hyper_tidy_gen.csv", mapfile="hyper_tidy_map.csv", phefile="hyper_tidy_phe.csv", genotypes=c("BB", "BA", "AA")) # compare results comparecrosses(x, hyper) qtl/tests/test_qtl.R0000644000176200001440000000531212770016226014202 0ustar liggesusers###################################################################### # # test_qtl.R # # copyright (c) 2009, Karl W Broman, Pjotr Prins # first written July 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Some basic regression/integration testing for some of the QTL mapping routines # # You can run it with: # # R --no-save --no-restore --no-readline --slave < ./tests/test_qtl.R ###################################################################### library(qtl) version = mqm_version() cat("R/qtl=",version$RQTL) cat("R-MQM=",version$RMQM) cat("MQM=",version$MQM) data(listeria) if (nind(listeria)!=120) stop("Number of individuals incorrect") # ---- a quick test of standard R/qtl scanone mr = scanone(listeria, method='mr') test = round(mr[15,]$lod*1000) cat(mr[15,]$lod,test) if (test != 966) stop("scanone_mr gives an incorrect result") # ---- a quick test of MQM for R/qtl augmentedcross <- mqmaugment(listeria, minprob=1.0, verbose=TRUE) nind = nind(augmentedcross) if (nind!=120) stop("Number of individuals incorrect: ",nind) result <- mqmscan(augmentedcross, logtransform=TRUE, outputmarkers = FALSE,off.end=0) test1 = round(result[5,5]*1000) test2 = round(max(result[,5]*1000)) cat("test1 = ",test1,"\n") cat("test2 = ",test2,"\n") if (test1 != 76) stop("MQM gives an unexpected result (1)") if (test2 != 5384) stop("MQM gives an unexpected result (2)") # ---- Test for negative markerlocations data(hyper) hyper <- fill.geno(hyper) #Mess up the markers by shifting temp <- shiftmap(hyper, offset=10^7) out.temp <- mqmscan(temp,verb=TRUE,off.end=10) if(!(rownames(out.temp)[3]=="D1Mit296")) stop("MQM something wrong with positive shifts in location") #Mess up the dataset by moving 1 marker infront of the chromosome hyper$geno[[1]]$map[1] <- -10 res <- mqmscan(hyper,verbose=T,off.end=100) if(any(is.na(res[,3]))) stop("MQM failed to handle negative locations correctly") if(!(rownames(res)[2]=="c1.loc-95")) stop("MQM something wrong with negative locations") #to -15 because off.end defaults to 10 cat("Version information:\n") cat("R/qtl = ",version$RQTL,"\n") cat("R-MQM = ",version$RMQM,"\n") cat("MQM = ",version$MQM,"\n\n") cat("test_qtl.R tests succesfully run!") qtl/tests/testthat/0000755000176200001440000000000014661520123014054 5ustar liggesusersqtl/tests/testthat/test-stepwiseqtl.R0000644000176200001440000000235012770016226017543 0ustar liggesuserscontext("stepwiseqtl") test_that("stepwiseqtl works with X-chr-specific perms", { data(fake.f2) fake.f2 <- calc.genoprob(fake.f2) set.seed(17370120) operm1 <- scantwopermhk(fake.f2, n.perm=10, verbose=FALSE) set.seed(17370120) operm2 <- scantwopermhk(fake.f2, n.perm=10, perm.Xsp=TRUE, verbose=FALSE) pen1 <- calc.penalties(operm1) pen2 <- calc.penalties(operm2) out.sq1 <- stepwiseqtl(fake.f2, max.qtl=4, penalties=pen1, method="hk", verbose=FALSE) expect_equal(out.sq1$chr, c("1", "8", "13", "X")) expect_equal(out.sq1$pos, c(37.11, 61.20, 24.03, 14.20)) out.sq2 <- stepwiseqtl(fake.f2, max.qtl=4, penalties=pen2, method="hk", verbose=FALSE) expect_equal(out.sq2$chr, c("1", "13", "X")) expect_equal(out.sq2$pos, c(37.11, 24.03, 14.20)) out.sq3 <- stepwiseqtl(fake.f2, chr=1:19, max.qtl=4, penalties=pen2, method="hk", verbose=FALSE) expect_equal(out.sq3$chr, c("1", "13")) expect_equal(out.sq3$pos, c(37.11, 24.03)) pen2b <- calc.penalties(operm2, alpha=0.2) out.sq2b <- stepwiseqtl(fake.f2, max.qtl=6, penalties=pen2b, method="hk", verbose=FALSE) expect_equal(out.sq2b$chr, c("1", "8", "13", "X")) expect_equal(out.sq2b$pos, c(37.11, 61.20, 24.03, 14.20)) }) qtl/tests/testthat/test-scantwoperm.R0000644000176200001440000000436312770016226017527 0ustar liggesuserscontext("scantwo perms") test_that("scantwo and scantwopermhk give same results", { data(hyper) hyper <- calc.genoprob(hyper[c(18,19,"X"),]) set.seed(92999298) out1 <- scantwo(hyper, method="hk", n.perm=3, verbose=FALSE) set.seed(92999298) out2 <- scantwopermhk(hyper, n.perm=3, verbose=FALSE) expect_equivalent(out1, out2) # X-chr-specific permutations set.seed(92999298) out1 <- scantwo(hyper, method="hk", n.perm=3, perm.Xsp=TRUE, verbose=FALSE) set.seed(92999298) out2 <- scantwopermhk(hyper, n.perm=3, perm.Xsp=TRUE, verbose=FALSE) expect_equivalent(out1, out2) }) test_that("summary.scantwo works with X-chr-specific perms", { data(hyper) set.seed(23615071) hyper <- calc.genoprob(fill.geno(hyper[c(18,19,"X"),])) # selected chr; imputed genotypes out2 <- scantwo(hyper, method="hk", verbose=FALSE) set.seed(17370120) operm1 <- scantwopermhk(hyper, n.perm=100, verbose=FALSE) set.seed(17370120) operm2 <- scantwopermhk(hyper, n.perm=100, perm.Xsp=TRUE, verbose=FALSE) # no significant pairs sum1 <- summary(out2, perms=operm1, alpha=0.05) sum2 <- summary(out2, perms=operm2, alpha=0.05) expect_equal(nrow(sum1), 0) expect_equal(nrow(sum2), 0) # p-values match expectation; not X-chr-specific sum1 <- summary(out2, perms=operm1, pvalues=TRUE) lodcol <- grep("^lod", names(sum1)) expect_equal(lodcol, c(5, 7, 9, 13, 15)) for(i in 1:5) expect_equal(sum1[,lodcol[i]+1], sapply(sum1[,lodcol[i]], function(a) mean(operm1[[i]] >= a))) # p-values match expectation; X-chr-specific sum2 <- summary(out2, perms=operm2, pvalues=TRUE) pairtype <- paste0(ifelse(sum2$chr1=="X", "X", "A"), ifelse(sum2$chr2=="X", "X", "A")) pairtype <- match(pairtype, c("AA", "AX", "XX")) L <- attr(operm2, "L") pow <- sum(L)/L lodcol <- grep("^lod", names(sum1)) expect_equal(lodcol, c(5, 7, 9, 13, 15)) for(j in 1:nrow(sum2)) { for(i in 1:5) { lod <- sum2[j,lodcol[i]] p <- sum2[j,lodcol[i]+1] nominal_p <- mean(operm2[[pairtype[j]]][[i]] >= lod) adj_p <- 1 - (1-nominal_p)^pow[pairtype[j]] expect_equivalent(p, adj_p) } } }) qtl/tests/testthat/test-fliporder.R0000644000176200001440000000244712770016226017154 0ustar liggesuserscontext("flip.order") test_that("flip.order, when applied twice, should get us back to the same thing", { data(hyper) # reduce size set.seed(53307443) hyper <- hyper[,sample(nind(hyper), 8)] hyper <- calc.genoprob(hyper, step=1) hyper <- sim.geno(hyper, step=10, n.draws=2) hyper <- argmax.geno(hyper, step=1) hyper <- calc.errorlod(hyper) hyperfl <- flip.order(hyper, chr=c(1, 4, 6, 15)) summary(hyperfl) hyperfl2 <- flip.order(hyperfl, chr=c(1, 4, 6, 15)) summary(hyperfl2) # having flipped twice, should be back to where we were # (except starting locations for each chromosome map) expect_null(comparecrosses(shiftmap(hyper), shiftmap(hyperfl2))) }) test_that("flip.order for 4-way cross", { data(fake.4way) # reduce size set.seed(36461124) fake.4way <- fake.4way[,sample(nind(fake.4way), 8)] fake.4way <- calc.genoprob(fake.4way, step=1) fake.4way.fl <- flip.order(fake.4way, chr=c(1, 4, 6, 15)) summary(fake.4way.fl) fake.4way.fl2 <- flip.order(fake.4way.fl, chr=c(1, 4, 6, 15)) summary(fake.4way.fl2) # having flipped twice, should be back to where we were # (except starting locations for each chromosome map) expect_null(comparecrosses(shiftmap(fake.4way), shiftmap(fake.4way.fl2))) }) qtl/tests/listeria2.csv0000644000176200001440000010216512770016226014637 0ustar liggesusersT264,D10M44,D1M3,D1M75,D1M215,D1M309,D1M218,D1M451,D1M504,D1M113,D1M355,D1M291,D1M209,D1M155,D2M365,D2M37,D2M396,D2M493,D2M226,D2M148,D3M265,D3M51,D3M106,D3M257,D3M147,D3M19,D4M2,D4M178,D4M187,D4M251,D5M148,D5M232,D5M257,D5M83,D5M307,D5M357,D5M205,D5M398,D5M91,D5M338,D5M188,D5M29,D5M168,D6M223,D6M188,D6M284,D6M39,D6M254,D6M194,D6M290,D6M25,D6M339,D6M59_,D6M201,D6M15,D6M294,D7M246,D7M145,D7M62,D7M126,D7M105,D7M259,D8M94,D8M339,D8M178,D8M242,D8M213,D8M156,D9M247,D9M328,D9M106,D9M269,D9M346,D9M55,D9M18,D10M298,D10M294,D10M42_,D10M10,D10M233,D11M78,D11M20,D11M242,D11M356,D11M327,D11M333,D12M105,D12M46,D12M34,D12M5,D12M99,D12M150,D13M59,D13M88,D13M21,D13M39,D13M167,D13M99,D13M233,D13M106,D13M147,D13M226,D13M290,D13M151,D14M14,D14M115,D14M265,D14M266,D15M226,D15M100,D15M209,D15M144,D15M68,D15M239,D15M241,D15M34,D16M154,D16M4,D16M139,D16M86,D17M260,D17M66,D17M88,D17M129,D18M94,D18M58,D18M106,D18M186,D19M68,D19M117,D19M65,D19M10,DXM186,DXM64 ,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,6,6,6,6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,8,8,8,8,8,8,9,9,9,9,9,9,9,10,10,10,10,10,11,11,11,11,11,11,12,12,12,12,12,12,13,13,13,13,13,13,13,13,13,13,13,13,14,14,14,14,15,15,15,15,15,15,15,15,16,16,16,16,17,17,17,17,18,18,18,18,19,19,19,19,X,X 118.317,B,B,B,H,H,H,B,B,H,H,H,H,H,H,A,A,-,A,A,B,B,B,B,B,B,A,H,A,H,A,A,H,H,H,H,H,-,H,H,H,B,B,A,A,H,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,B,B,B,H,H,H,A,A,H,B,B,B,B,B,B,C,-,H,H,H,A,A,A,A,A,A,A,B,B,H,H,A,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,B,B,B,B,H,H,H,C,H,H 264,-,B,B,B,H,H,H,H,H,H,H,H,H,B,B,H,-,H,A,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,H,H,B,B,B,A,A,A,A,A,A,A,A,A,H,H,H,H,H,B,B,B,B,B,H,H,H,B,B,B,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,A,A,H,H,H,H,-,H,H,H,H,H,A,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,B,B,H,H,A,H,H,C,H,H 194.917,-,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,-,-,H,H,H,H,H,B,B,A,A,H,H,A,A,A,A,H,H,H,-,H,H,H,H,A,H,H,H,H,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,H,H,H,B,H,H,B,B,B,B,B,B,B,H,A,A,A,A,H,H,H,H,H,H,B,B,H,H,H,B,A,A,A,A,A,A,A,H,H,H,H,H,B,B,B,H,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,B,B,H,H,A,A,H,H 264,B,B,H,H,H,H,B,B,B,B,B,B,B,A,-,A,-,H,H,B,H,H,H,H,H,H,H,H,H,-,H,A,A,A,A,A,-,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,A,H,B,H,H,B,B,B,B,B,H,A,A,H,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,H,A,A,H,H,B,H,H,H,H,A,A,A,H,H,B,A,H,H,B,A,A,A,A,B,H,H,C,H,A 145.417,H,H,H,H,B,H,H,H,H,H,H,H,H,B,H,H,-,-,H,B,A,A,A,A,A,A,A,A,H,-,A,A,A,A,A,-,-,H,H,H,H,H,A,A,A,A,A,A,-,H,H,H,H,H,H,B,H,A,A,H,H,A,A,A,A,A,H,B,B,B,H,H,H,H,A,H,H,H,H,B,B,B,B,B,H,A,A,A,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,B,B,B,A,A,A,H,A,A,A,A,H,A,A,C,A,A 177.233,H,H,B,B,B,B,B,B,B,B,B,B,B,H,A,A,A,-,A,B,B,B,B,B,B,H,H,H,H,A,A,A,A,A,A,H,-,H,H,H,-,H,A,A,A,H,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,H,H,H,H,C,H,-,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,B,H,H,H,H,A,A,A,C,A,H 264,H,H,H,H,A,A,A,A,H,H,H,H,H,B,B,B,B,-,H,B,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,-,A,A,A,-,H,H,H,H,H,H,H,H,B,B,B,B,B,B,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,H,H,H,A,A,A,H,H,B,B,H,A,A,A,A,C,H,B,B,B,B,B,B,B,B,B,B,A,H,H,H,A,A,A,A,A,A,A,-,B,H,H,H,H,A,A,H,H,H,B,B,B,B,A,A,H,H 76.667,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,A,-,A,A,H,B,H,H,H,H,H,-,H,B,B,B,B,B,B,B,B,-,B,B,H,H,H,A,A,A,A,H,H,-,B,B,B,B,B,B,H,H,H,H,H,B,A,A,H,H,H,H,B,B,B,B,B,B,H,A,A,-,A,A,H,B,H,B,B,H,A,H,H,H,H,H,C,H,H,A,A,A,-,A,A,-,A,H,H,B,H,H,B,B,B,B,H,H,H,H,B,B,B,B,H,H,H,H,A,A,-,H,H,H,H,C,A,- 90.75,A,A,H,B,B,B,H,H,H,H,H,-,H,A,H,H,H,H,B,A,H,H,A,A,A,H,H,H,B,H,H,H,H,A,A,A,-,A,A,A,-,H,H,H,H,H,B,B,B,H,H,H,H,H,H,B,B,B,B,B,H,B,B,-,B,B,A,H,H,H,A,A,A,A,H,B,B,B,B,B,B,H,H,H,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,H,A,A,A,A,A,A,A,H,B,B,B,A,A,H,H,B,B,-,B,H,H,H,A,A,H 76.167,B,B,H,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,A,H,H,H,H,A,B,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,A,A,A,H,H,B,B,B,H,H,H,B,B,B,B,B,H,A,A,H,H,H,H,A,H,H,H,H,B,A,-,A,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,A,H,B,H,H,H,H,H,H,H,H,H,B,B,B,H,A,A,A,A,A,A,A,A,H,B,B,C,H,A 104.083,A,H,H,H,H,H,H,H,H,H,H,-,H,A,A,B,B,B,B,H,A,A,H,H,H,H,H,H,B,H,H,H,H,H,H,H,-,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,A,A,A,H,A,H,H,H,-,A,A,A,A,A,A,H,H,B,B,B,B,B,A,H,H,H,A,A,H,H,H,H,H,A,A,A,H,H,B,C,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,A,A,A,A,A,A,A,H,B,B,B,H,H,B,B,B,A,A,A,A,B,H,H,C,A,H 194.5,A,A,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,H,H,A,H,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,-,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,B,B,H,A,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,H,H,A,A,A,A,H,A,-,A,A,A,A,A,H,H,-,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,A,H,C,H,H 75.917,A,A,H,H,H,H,B,B,B,B,B,-,B,H,H,H,H,H,H,A,A,A,A,A,A,H,H,H,A,H,H,H,H,H,H,H,-,H,H,H,-,H,B,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,A,H,H,H,A,A,A,A,A,H,A,A,A,-,A,H,C,H,A,A,A,A,A,A,A,H,H,H,B,B,B,B,A,A,A,A,A,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H 75.833,H,H,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,-,H,B,H,H,H,B,H,H,H,H,H,B,B,B,B,B,B,B,-,B,B,B,-,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,-,H,H,A,A,A,A,A,H,B,B,B,B,B,B,H,B,H,H,H,H,B,H,H,H,H,A,H,H,H,H,H,B,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,A,B,B,B,B,A,A,-,H,H,B,-,C,A,H 90.25,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,H,H,B,B,B,B,B,B,H,H,B,B,A,A,H,H,H,H,H,-,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,H,H,H,H,A,A,A,H,H,A,A,A,A,A,H,A,A,A,B,H,A,A,H,A,A,H,H,H,H,H,H,C,H,A,A,A,A,A,A,A,H,H,H,A,A,H,H,-,-,A,A,A,A,A,-,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,A,A,A 103.667,H,H,B,B,B,B,H,H,H,H,H,A,A,B,B,H,H,A,A,H,-,H,H,H,H,B,B,B,B,H,B,B,B,B,B,B,-,B,B,B,B,H,H,H,H,H,H,B,-,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,H,H,B,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,B,A,A,H,-,A,A,A,A,A,A,A,B,B,B,H,B,B,H,H,B,-,-,B,B,B,B,C,A,A 128.4,A,A,A,A,A,A,H,H,H,H,H,H,H,H,B,H,-,H,H,B,-,A,A,A,A,B,H,H,H,H,H,H,H,B,B,B,-,B,B,B,B,B,H,H,B,B,B,B,B,B,B,H,H,H,H,A,H,H,H,B,H,B,B,B,B,B,H,B,B,H,H,H,A,A,A,A,A,A,H,A,A,A,A,A,B,A,A,A,A,A,A,C,B,B,B,B,B,B,B,B,B,B,B,A,A,A,H,H,A,A,A,A,A,A,-,B,H,H,A,A,A,A,A,A,-,-,A,H,-,A,A,A,H 122.25,B,B,H,H,-,H,H,H,H,H,H,B,B,B,B,H,H,H,B,A,A,A,H,H,H,A,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,A,A,A,-,A,A,A,A,H,H,B,B,B,B,A,A,A,H,H,-,H,H,H,A,A,A,H,H,H,C,B,B,B,B,B,B,B,B,-,B,B,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,-,B,H,-,H,A,A,A 264,H,H,A,H,H,H,B,B,B,B,B,-,B,H,H,A,A,A,H,A,A,H,A,H,A,A,-,H,A,A,A,A,A,A,A,A,-,A,A,A,-,A,H,H,A,H,H,H,H,H,H,H,B,B,B,H,H,H,H,A,A,B,B,B,H,H,A,A,A,A,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,A,C,B,B,B,B,B,B,H,H,H,H,H,A,H,H,B,H,A,A,A,A,A,A,-,H,B,B,B,B,B,-,H,H,H,-,H,B,B,B,-,A,H 72.6,H,H,H,H,A,A,A,A,A,A,-,H,H,H,H,H,A,A,A,A,A,A,A,-,A,A,H,H,H,B,H,H,H,H,H,H,-,H,A,A,A,A,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,B,H,H,-,H,H,H,H,H,A,A,H,B,B,B,H,H,B,B,B,B,B,B,B,B,B,H,-,C,H,H,H,H,A,A,A,A,A,A,A,B,H,A,A,B,B,B,B,B,B,H,H,H,H,A,A,H,H,H,B,A,A,-,A,B,B,B,C,A,H 264,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,A,A,A,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,-,A,A,A,-,A,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,H,A,A,A,H,H,B,H,H,H,A,A,A,A,H,H,H,H,H,A,A,H,H,H,H,A,A,A,A,B,B,C,H,H,H,H,H,H,H,H,H,H,H,B,H,A,A,B,B,B,B,H,H,H,H,H,H,A,A,B,B,B,H,H,H,-,H,H,H,H,C,H,A 264,B,B,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,A,A,H,B,B,B,H,H,B,B,B,B,A,A,H,H,H,H,H,-,H,H,H,-,B,H,H,H,H,B,B,B,B,B,B,B,B,B,H,H,H,A,A,A,H,H,B,B,B,B,A,A,A,H,B,B,B,A,A,A,A,A,H,H,B,B,B,B,B,B,H,H,H,H,C,H,-,H,H,H,H,H,H,H,H,A,H,A,A,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,H,-,H,-,-,H,A,A,A,A,H,A 264,A,A,A,A,A,A,H,H,B,B,B,B,B,-,A,A,A,A,H,A,H,H,A,A,A,B,B,B,H,A,A,A,A,A,A,A,-,A,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,B,B,B,H,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,A,H,H,H,H,H,H,A,A,A,A,H,H,C,-,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,A,A,-,A,A,A,H,C,A,A 81.717,H,H,H,-,H,H,H,H,H,H,H,H,A,H,H,B,B,B,A,H,H,H,H,B,B,H,H,A,B,-,B,B,B,B,B,B,-,B,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,B,H,H,-,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,B,B,B,B,B,B,B,H,H,H,H,H,H,C,-,H,H,H,A,A,A,A,A,A,A,H,H,H,H,B,B,B,B,B,B,B,B,A,A,A,A,H,H,H,B,A,A,-,A,H,H,H,C,H,H 264,-,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,-,H,H,A,A,A,A,A,A,H,H,H,H,B,-,B,B,H,H,H,H,H,A,A,A,A,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,-,A,A,A,A,H,B,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,B,B,H,H,H,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,H,H,H,B,H,H,-,B,H,B,H,C,A,A 264,-,H,B,H,H,H,H,H,H,H,H,H,H,A,B,B,-,H,A,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,B,B,H,H,H,H,-,H,H,H,-,H,H,H,A,B,B,H,-,H,H,H,A,A,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,A,A,A,H,H,H,B,B,B,B,B,H,H,H,H,H,H,H,B,H,H,H,A,H,H,H,H,H,H,H,B,B,B,B,H,H,B,H,H,H,-,H,B,B,H,C,-,H 116.483,-,H,H,H,H,H,H,H,H,H,H,A,A,H,H,H,-,H,H,A,H,H,H,H,H,A,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,-,H,H,H,H,H,H,H,H,H,H,H,B,H,B,B,B,B,H,A,A,A,A,A,A,A,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,B,B,B,B,B,B,B,H,A,A,A,A,A,A,A,A,A,H,-,H,H,H,B,C,A,A 87.467,-,H,H,A,A,A,A,A,A,A,A,A,A,H,H,B,-,A,A,H,A,A,A,A,H,H,B,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,-,H,H,H,H,H,H,B,H,H,H,A,-,B,B,B,B,B,B,H,B,B,B,B,B,H,A,A,H,H,H,H,B,B,B,B,B,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,B,B,B,B,B,B,B,H,B,B,B,B,B,B,H,A,A,-,A,B,H,H,C,H,A 264,H,H,H,A,-,H,H,H,H,H,H,H,H,-,A,H,H,H,B,B,B,B,H,H,H,A,H,H,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,B,B,B,-,B,B,B,B,B,B,B,B,B,B,H,H,B,B,B,B,B,H,H,H,H,H,H,H,H,A,H,H,H,B,H,B,B,B,H,H,H,A,A,A,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,B,H,H,H,H,H,H,H,A,A,A,-,A,H,H,H,C,A,H NA,A,A,A,H,H,B,H,H,H,H,H,H,H,-,H,H,H,-,H,H,B,B,H,H,H,B,H,B,H,-,H,H,H,H,H,H,H,H,H,A,-,H,A,H,H,H,H,H,-,H,H,H,H,H,H,H,A,A,A,H,H,A,A,H,H,B,B,B,H,H,-,H,H,B,A,H,H,H,A,H,H,H,H,H,H,B,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,A,A,A,H,H,H,H,B,H,H,-,H,H,H,H,C,H,H 74.417,A,A,H,H,H,H,A,A,A,A,A,H,H,B,B,B,H,H,A,H,A,A,H,H,H,H,H,B,H,H,H,A,A,A,A,A,A,A,A,A,-,A,B,H,H,H,H,H,-,H,H,H,H,-,H,B,B,B,B,B,B,H,H,H,H,H,H,A,A,A,A,H,H,B,H,H,A,A,A,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,B,H,H,H,H,H,H,H,H,H,H,H,H,A,H,B,B,H,H,H,B,A,A,-,A,H,H,H,C,H,H 264,A,A,H,H,B,B,H,H,H,H,A,A,A,-,H,B,B,B,H,H,H,H,H,H,H,H,A,A,H,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,-,B,B,B,B,B,B,A,A,A,A,H,-,B,B,B,H,H,-,H,H,H,A,A,A,A,B,H,H,H,B,A,-,H,H,A,A,B,B,B,B,A,A,B,B,-,H,H,H,-,H,H,A,H,A,H,B,B,H,A,A,H,H,H,H,B,H,H,H,H,H,A,A,H,H,A,A,-,A,H,H,H,C,H,H 264,B,B,H,A,A,A,A,A,H,H,H,H,H,B,B,B,B,H,H,B,H,H,A,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,A,H,-,H,H,H,H,B,B,B,B,H,H,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,B,B,-,H,H,H,H,C,H,H 174.567,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,A,A,H,A,H,H,H,H,H,B,-,H,B,H,H,H,H,H,H,B,H,B,B,B,B,B,H,H,H,H,H,H,-,H,H,A,A,H,H,H,H,A,A,A,-,H,H,H,H,H,-,H,B,B,B,B,B,B,A,A,A,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,A,H,H,H,H,-,H,B,H,H,C,H,H 88.583,B,B,B,B,B,B,B,B,B,B,B,H,-,H,H,H,H,A,H,H,A,H,H,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,-,B,B,B,H,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,A,A,B,B,H,A,H,H,A,A,A,A,A,A,A,A,A,-,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,B,B,B,B,B,B,-,B,H,A,A,C,A,H 264,H,H,B,B,B,B,B,B,B,B,B,H,-,A,H,H,B,B,B,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,B,B,B,B,-,B,B,H,H,H,H,B,H,H,H,H,H,H,A,H,H,H,H,A,A,A,A,H,H,-,H,H,H,A,A,A,A 95,H,H,H,H,H,H,H,A,A,A,A,A,-,B,H,H,A,A,A,H,H,H,A,-,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,-,B,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,A,A,H,H,B,B,B,B,B,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,A,A,-,A,A,A,A,A,A,-,A,A,A,A,A,A,H,H,A,A,A,A,A,A,A,H,B,B,H,H,H,H,H,H,-,A,H,H,H,A,A,H 264,B,B,B,B,B,B,H,H,H,H,H,H,-,A,B,B,-,B,B,A,A,A,A,-,H,H,H,H,B,A,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,B,B,A,A,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,B,B,-,B,H,H,H,C,A,A 86.05,B,B,H,H,A,A,A,A,A,A,A,A,-,H,H,B,B,B,H,H,H,H,H,-,A,H,H,H,H,A,A,B,B,B,B,B,B,B,B,B,B,B,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,B,A,H,H,H,B,A,A,A,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,-,A,A,A,A,A,H,-,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,H,-,-,H,A,A,B,C,H,H 71.517,H,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,A,-,H,H,H,H,H,H,B,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,A,A,A,A,A,H,B,B,A,A,A,A,A,A,H,H,H,B,B,B,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,A,A,H,H,H,B,A,A,A,A,A,A,A,A,A,-,A,A,H,A,A,A,-,B,B,B,B,B,B,B,A,A,A,A,H,H,H,H,A,A,-,A,H,A,A,A,A,H 112.767,B,B,B,B,B,B,H,H,H,H,H,-,H,H,A,A,A,-,A,A,H,H,H,H,H,H,B,B,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,A,A,H,A,A,A,A,H,H,B,H,A,A,A,A,H,B,B,B,B,B,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,H,H,-,H,H,H,H,H,H,-,H,H,-,A,A,A,H,A,A,A,A,A,A,-,H,B,-,H,C,A,H 264,A,A,A,A,A,A,A,A,A,A,H,H,H,A,A,H,H,H,H,A,A,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,B,B,B,B,B,B,B,H,H,H,H,H,H,H,A,A,A,A,H,A,A,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,A,A,A,A,A,B,B,-,-,H,H,H,H,H,-,H,H,A,A,A,B,H,-,A,A,A,A,A,A,H,H,H,H,B,B,B,B,B,B,-,B,B,-,B,C,A,A 264,B,B,B,A,A,A,H,H,A,A,A,A,A,-,H,H,-,B,B,B,H,A,A,A,A,H,-,A,H,A,A,H,H,H,H,H,H,H,H,H,-,B,H,H,H,H,H,H,-,-,H,H,H,H,H,A,A,A,A,A,-,H,H,H,H,H,-,H,H,B,-,B,A,A,H,H,A,A,A,B,B,B,B,B,B,B,B,H,H,H,-,H,H,B,B,B,B,B,B,B,B,B,B,H,-,B,B,H,-,H,H,H,H,H,B,B,B,B,H,H,H,H,H,B,B,-,B,B,B,B,C,A,H 117.817,H,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,H,A,A,A,A,H,H,A,H,B,H,H,H,H,H,A,A,A,A,A,A,A,A,B,B,B,B,H,H,A,A,A,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,B,A,A,H,H,H,H,H,B,B,B,B,H,-,B,B,H,H,H,H,-,H,H,H,H,H,H,H,H,B,H,A,H,H,A,-,A,A,H,H,H,B,B,B,B,B,H,H,H,-,A,A,-,H,A,A,A,A,H,H 185.3,A,A,A,H,H,B,B,B,B,B,B,-,B,A,A,-,-,A,A,A,A,A,H,H,B,H,H,H,H,B,B,H,H,H,H,H,H,H,H,A,-,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,-,B,B,B,B,H,-,H,H,H,A,A,A,A,H,A,A,A,H,H,H,H,H,H,A,A,A,H,A,A,A,H,H,-,H,H,H,H,H,H,H,H,H,H,-,B,B,A,-,A,A,A,A,H,H,A,A,A,A,A,H,-,H,A,-,-,A,A,A,H,C,H,H 85.367,H,H,A,A,A,A,H,H,H,H,H,H,H,A,H,A,-,B,B,H,H,H,H,H,H,H,-,A,A,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,B,-,H,H,H,H,H,-,B,B,B,-,B,H,H,A,A,H,H,B,H,A,A,A,A,H,B,B,H,H,H,H,H,H,-,A,A,A,A,H,H,-,H,H,-,-,H,H,A,-,A,A,A,A,A,-,A,A,A,H,H,A,A,A,B,B,-,B,H,A,A,A,A,A 264,H,H,H,B,B,B,B,B,B,B,B,-,B,H,A,B,-,A,H,A,H,H,B,B,B,H,H,H,H,-,A,A,A,A,A,A,A,A,A,A,-,A,H,H,H,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,A,A,A,B,B,B,-,B,B,B,H,H,H,H,H,H,A,A,A,A,H,H,H,H,B,H,-,H,H,H,H,H,H,H,H,B,H,H,H,B,-,A,H,B,-,H,H,-,H,H,H,B,B,B,B,H,H,-,H,B,B,-,B,H,H,H,C,A,- 70.883,H,H,A,A,A,A,A,A,A,A,H,H,H,H,H,H,-,B,B,H,H,A,A,A,A,A,H,H,H,-,A,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,-,A,A,H,H,H,A,A,A,B,B,B,B,B,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,H,-,A,A,H,-,H,H,B,B,-,B,H,H,H,H,A,A,A,H,B,B,-,H,H,H,-,C,H,- 98.45,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,-,H,H,H,A,A,A,A,A,H,H,H,A,B,B,B,B,B,B,-,-,B,B,B,B,B,H,H,H,H,B,H,-,H,H,H,H,H,H,A,-,A,-,A,A,B,B,B,B,H,-,A,A,H,H,-,H,H,A,A,-,A,A,A,A,A,H,H,H,A,A,A,A,A,A,C,A,H,H,H,B,B,B,B,B,B,B,A,H,H,H,H,H,H,H,H,H,A,A,H,B,B,B,A,A,A,A,H,H,A,A,H,A,A,A,A,H 85.1,-,H,H,A,A,A,A,A,A,A,A,H,H,A,H,H,-,A,A,H,H,H,H,H,H,B,-,H,H,H,H,H,H,H,H,-,-,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,-,B,B,B,B,B,B,H,H,A,A,-,A,A,B,B,H,A,A,A,A,A,B,B,B,A,A,A,A,A,A,C,B,B,B,B,B,B,B,B,B,B,B,H,H,A,A,H,H,H,H,H,H,A,A,A,A,A,A,B,B,B,H,H,H,H,H,B,B,H,C,A,A 216.367,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,-,A,H,H,H,H,H,H,B,H,-,B,B,B,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,H,H,-,B,B,B,B,B,B,B,B,B,B,A,A,H,H,H,A,A,A,A,A,A,A,-,H,H,B,B,H,H,A,A,-,A,A,A,H,B,-,H,H,H,B,C,B,B,-,B,B,B,H,H,H,H,H,B,B,B,B,A,A,H,H,H,H,H,B,A,A,H,H,H,H,H,H,H,H,H,H,A,A,H,C,A,A 94.65,-,B,B,B,B,B,H,H,H,H,H,H,H,A,A,H,-,B,B,A,H,H,H,H,B,B,H,A,A,H,H,H,H,-,H,H,H,H,H,A,A,A,H,H,H,H,H,H,-,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,B,-,B,H,H,H,H,A,H,H,H,H,A,A,H,A,A,A,A,A,A,A,A,-,A,A,A,A,A,A,A,A,A,B,B,H,H,H,B,B,B,B,B,B,-,H,H,H,A,H,H,B,B,H,H,B,B,H,H,A,A,H,H 111.817,A,-,H,A,A,A,A,A,A,A,A,A,A,B,A,A,-,H,H,H,B,B,B,B,B,H,-,B,B,B,B,B,B,H,H,H,H,H,H,H,A,A,A,A,A,A,H,H,-,H,H,H,B,B,B,A,H,H,H,A,A,A,A,H,H,H,-,H,H,H,H,-,B,B,B,B,B,B,H,H,B,B,B,B,B,H,A,A,A,H,H,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,A,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,A,A,H,B,A,A,A,A,H,A 90.9,B,B,B,B,B,B,B,B,B,B,B,B,B,A,H,H,H,H,A,B,H,A,H,H,H,H,H,B,B,-,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,A,A,A,A,A,A,H,H,H,H,-,H,H,H,H,H,H,H,A,H,H,B,B,B,A,A,A,A,A,A,C,H,A,A,A,A,-,A,A,A,A,A,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,C,A,H 264,A,-,H,H,B,B,B,B,B,B,B,B,B,-,B,B,B,B,H,H,H,H,H,H,H,H,H,A,H,H,H,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,-,B,B,B,B,B,B,H,H,H,A,A,A,H,H,A,A,A,-,H,A,A,A,-,H,H,H,H,B,B,B,H,-,A,A,A,A,A,A,A,A,A,A,C,H,H,H,H,H,-,H,H,H,H,A,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,H,H,B,H,H,H,A,A,A,A 170.517,H,H,B,H,H,H,B,B,B,B,B,B,B,A,H,A,-,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,-,B,B,H,H,H,-,A,A,A,A,A,H,H,A,H,-,H,B,H,H,H,H,A,A,H,H,-,H,B,B,C,H,-,H,H,H,A,A,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,A,B,H,H,H,B,B,B,B,H,H,H,C,H,H 111.717,H,-,H,H,A,A,H,H,B,B,B,B,B,H,A,A,H,B,B,H,H,H,H,A,A,H,H,H,H,A,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,B,B,H,H,A,A,A,A,H,A,H,H,-,H,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,H,H,H,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,A,A,A,A,H,-,H,H,A,A,A,A,A,A,A,A,B,H,H,C,H,H 264,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,A,A,H,H,H,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,B,B,B,H,H,A,A,-,A,A,H,H,H,H,H,A,H,B,H,H,A,A,A,A,A,A,A,A,A,-,A,A,A,-,A,H,-,H,H,B,H,H,H,H,H,H,H,H,H,H,H,B,H,H,B,B,B,B,H,H,H,H,H,A,A,A,A,A,H 75.383,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,H,H,A,A,A,A,H,A,A,A,A,A,A,A,H,H,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,H,H,H,H,B,B,H,-,H,H,H,H,H,B,B,B,B,B,B,H,-,A,A,A,H,H,H,H,A,H,H,H,H,H,B,H,H,H,H,-,A,A,A,A,A,A,-,A,A,-,A,H,B,B,H,H,H,H,B,B,B,B,B,B,B,H,H,H,H,B,B,B,B,B,A,A,H,H,H,C,A,A 84.35,H,H,H,H,A,A,A,A,A,A,A,A,A,H,H,H,H,-,H,A,H,B,B,B,B,H,H,B,B,A,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,-,H,H,H,H,H,H,H,H,A,A,H,-,-,H,H,A,A,A,A,A,B,B,H,H,H,A,A,A,A,A,A,H,A,A,-,A,A,A,A,A,A,-,A,H,A,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,B,B,B,B,B,H,H,A,H,H,C,A,A 97.667,B,B,B,B,B,B,B,B,H,H,H,H,H,H,B,H,H,H,H,H,H,B,B,B,B,H,H,H,B,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,B,B,B,B,B,H,H,H,H,-,B,B,H,H,B,B,B,B,B,B,B,B,A,H,H,A,A,A,A,C,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,A,A,B,H,H,C,A,A 97.783,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,H,H,H,H,-,B,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,B,-,A,A,H,-,-,A,A,A,A,A,H,H,B,B,B,B,B,A,B,B,H,H,H,H,A,A,-,H,H,H,-,H,H,H,H,H,A,A,A,A,B,B,B,B,B,B,B,H,H,H,H,A,B,B,H,H,H,H,H,H,A,A,A,A,A,- 264,H,H,H,H,B,B,B,B,B,B,H,H,H,B,B,B,B,B,B,H,H,B,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,-,A,A,A,A,A,A,B,B,B,B,H,A,H,H,H,H,H,A,A,A,A,A,-,A,A,B,B,B,H,H,H,H,H,H,H,H,H,A,A,A,A,H,C,B,B,B,B,B,B,B,H,-,H,H,H,H,H,A,-,H,H,H,H,H,H,B,B,B,B,B,H,H,H,A,H,H,H,H,B,A,A,A,H,H 90.433,H,H,H,H,H,H,A,A,A,A,H,H,H,A,A,A,A,A,A,H,H,A,A,A,A,B,B,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,A,A,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,A,A,H,H,H,B,A,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,A,C,A,-,B,B,B,B,B,B,B,B,B,A,A,A,H,-,B,B,B,B,B,H,-,A,H,H,B,H,H,H,H,H,H,H,H,B,B,B,C,H,H 264,A,A,H,H,H,H,H,H,A,A,A,A,A,-,A,H,H,H,H,A,H,H,H,H,H,B,-,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,-,B,B,B,-,-,H,H,A,A,H,H,B,A,A,A,H,H,H,H,A,H,H,H,B,C,B,B,B,B,B,B,B,B,B,B,B,H,H,A,H,H,-,A,A,A,A,A,A,A,A,A,H,H,H,H,B,B,B,-,B,H,H,A,A,H,H 90.05,H,H,H,B,B,B,B,B,H,H,H,H,H,B,B,B,B,-,B,A,A,A,B,B,B,H,H,H,B,H,H,H,H,-,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,A,A,B,B,B,H,-,H,H,A,H,H,H,H,A,A,-,A,A,A,B,B,B,B,B,B,A,A,-,A,A,A,A,A,A,-,H,H,H,H,H,H,H,-,H,H,B,B,B,B,A,A,H,H,H,H,A,A,H,H,-,H,B,H,H,C,A,A 90.083,H,H,H,H,H,H,H,H,H,H,-,H,H,B,H,H,-,H,H,B,H,H,H,H,H,B,-,B,B,H,B,B,B,B,B,B,B,B,H,H,-,H,B,H,H,H,H,H,H,H,H,H,A,A,A,H,H,H,-,B,-,H,H,H,H,H,-,B,B,B,B,-,B,B,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,C,H,A,A,A,A,A,A,A,A,A,A,H,H,B,B,H,-,B,B,B,H,H,B,B,H,H,H,A,H,H,H,B,B,B,B,H,A,H,C,A,A 90.117,H,H,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,B,B,H,B,B,B,B,B,H,B,B,B,B,B,B,B,B,B,B,B,H,H,H,-,H,H,A,A,A,A,A,A,A,A,A,H,H,H,H,A,A,A,A,-,H,H,H,B,B,B,B,B,H,H,-,A,A,A,A,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,A,A,A,A,A,A,A,A,A,A,A,A,H,-,B,B,H,-,H,H,A,A,A,A,H,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,H,H 264,A,A,A,A,A,A,H,H,B,B,B,B,B,H,B,B,-,H,H,B,H,H,B,B,B,A,A,H,B,A,H,A,A,A,A,A,A,A,A,A,-,A,A,A,A,H,B,B,B,B,B,B,B,B,B,H,H,H,-,H,-,B,B,B,H,A,A,H,H,B,B,-,H,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,B,B,B,C,H,H,H,H,H,H,H,H,-,H,B,H,-,H,H,H,-,H,H,H,H,A,A,B,B,B,B,B,H,H,A,H,H,H,H,A,A,A,C,H,H 71.967,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,A,A,A,B,-,H,A,A,A,A,H,H,H,B,B,-,H,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,H,-,H,-,H,H,H,H,H,-,H,H,H,H,-,H,H,H,B,B,B,B,A,H,H,H,H,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,-,A,A,A,-,H,H,B,-,B,B,B,B,-,-,H,H,H,H,H,H,H,H,A,A,A,A,H,H,B,C,H,A 264,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,B,-,H,H,H,B,B,B,H,H,B,H,H,H,A,H,A,A,A,A,A,A,A,A,H,-,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,-,B,-,B,H,B,B,B,B,B,B,H,H,H,H,-,B,B,H,H,H,A,H,B,H,A,A,A,A,B,B,-,B,B,B,C,H,A,A,A,A,A,A,A,A,A,A,B,B,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,C,H,A NA,B,B,B,B,B,B,H,H,A,A,A,A,A,H,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,B,B,H,H,H,H,B,H,H,-,A,A,A,A,A,-,A,H,H,B,B,B,B,H,H,H,A,A,A,C,B,B,B,B,B,H,H,H,H,H,H,B,B,B,H,A,H,-,H,H,H,-,-,A,H,H,H,H,B,B,B,A,A,H,H,H,H,H,C,H,H 264,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,-,H,H,H,A,A,A,A,H,A,B,B,H,H,B,B,B,B,B,B,-,B,B,B,B,B,H,H,H,H,H,H,-,H,H,B,B,B,B,H,H,H,H,B,B,H,H,H,H,H,-,A,A,H,-,H,H,H,H,H,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,C,B,B,B,B,B,B,B,B,B,B,B,-,H,H,A,A,H,H,A,A,A,A,A,H,B,-,H,H,H,H,B,H,H,H,H,B,B,H,C,A,H 264,-,H,-,H,H,H,H,H,H,H,H,H,H,B,H,H,-,H,H,A,A,H,H,H,B,A,A,H,B,H,H,H,H,H,H,H,H,H,H,H,H,A,B,B,B,B,B,B,-,B,B,B,B,B,B,B,B,H,-,A,A,A,A,A,A,A,A,H,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,B,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,A,H,H,-,A,H,B,B,C,H,H 74.267,B,B,H,H,H,H,A,A,A,A,A,A,A,H,A,A,-,H,H,A,A,H,H,H,H,B,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,-,A,A,A,A,A,A,B,H,H,H,B,H,H,H,-,H,H,H,A,A,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,B,B,B,B,B,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,B,H,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,A,A,A,C,H,H NA,-,H,A,A,H,H,H,H,H,H,H,H,H,B,B,B,-,A,A,A,A,A,A,A,A,H,H,B,H,-,H,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,B,B,-,A,A,A,A,A,A,A,H,B,B,H,H,H,H,H,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,B,B,B,B,B,B,B,H,A,A,H,H,H,A,H,H,H,H,A,H,B,C,A,H NA,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,B,B,B,H,A,A,A,A,A,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,H,H,A,B,B,B,B,B,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,H,H,H,H,H,H,A,A,A,H,B,H,H,H,H,H,H,B,H,H,A,A,A,A 264,-,H,H,B,B,B,B,B,B,B,B,B,B,H,H,-,A,H,H,H,A,A,A,H,H,A,A,H,B,-,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,B,B,H,A,A,A,H,H,H,B,B,B,H,B,B,B,B,B,B,B,B,B,H,A,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,H,H,H,B,B,B,H,H,H,A,A,H,H,H,C,H,A 264,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,B,H,H,H,B,H,H,H,H,B,H,A,H,H,H,B,B,C,H,B,B,B,H,H,H,H,H,H,H,A,H,H,B,A,A,A,A,A,A,A,-,H,A,A,H,H,B,B,B,B,B,A,A,A,A,A,A,H,H 264,A,A,A,H,H,H,H,H,A,A,A,A,A,B,H,H,H,H,H,B,B,B,H,H,H,H,-,B,H,B,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,B,A,H,H,-,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,C,H,A,A,A,A,-,A,A,A,A,A,H,H,H,A,H,B,B,B,B,B,B,B,H,H,H,A,A,A,A,H,B,B,B,B,B,B,B,C,H,H 109.867,H,H,B,-,H,B,B,B,B,B,B,B,B,A,H,H,H,H,H,H,B,B,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,B,H,H,H,B,H,H,H,-,H,H,H,B,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,H,H,A,A,A,H,H,H,H,H,H,H,B,B,H,H,B,B,B,B,H,A,A,A,A,H,H,H,C,H,A 264,B,B,A,A,A,A,A,A,A,A,A,A,A,H,A,A,H,H,H,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,A,H,H,-,B,H,H,H,H,H,H,H,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,-,B,B,H,H,A,A,A,A,C,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,A,A,B,H,H,A,A,A,A,H,H,H,H,A,H,H 264,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,B,B,B,H,A,A,H,H,H,B,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,B,B,B,H,H,H,A,A,A,A,A,A,A,A,B,B,H,H,A,A,H,H,H,H,H,A,A,A,A,H,H,H,A,A,H,H,H,H,H,A,A,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,A,A,A,B,H,H,H,H,H,H,A,B,B,B,H,B,B,H,H,A,A,A,A,A,H,B,C,A,A 96.017,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,B,B,H,A,H,H,H,H,H,H,H,H,H,H,H,-,H,H,B,B,B,B,B,B,B,B,B,H,H,H,H,A,A,-,H,H,H,H,H,H,B,B,H,H,H,H,B,B,B,A,H,H,H,H,A,H,H,B,B,H,B,B,H,H,H,A,A,A,A,A,A,A,-,A,A,-,A,A,H,H,H,A,B,-,B,B,B,B,-,H,A,H,H,H,A,B,B,B,H,H,H,H,B,B,B,C,A,A 136.417,H,H,H,H,H,H,B,B,H,H,H,H,H,B,B,B,A,A,A,H,A,A,A,A,H,H,-,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,A,A,A,H,H,-,H,A,-,A,A,A,A,A,A,A,A,A,A,A,A,H,H,B,B,B,B,H,H,H,H,H,H,C,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,B,B,B,B,B,B,H,H,H,B,H,H,H,H,H,B,H,H,H,H,A,A,A,A,A,A 168.25,H,H,B,B,B,B,B,B,B,B,B,H,H,B,A,A,A,A,A,H,A,H,H,H,H,H,H,H,H,B,H,A,A,A,A,A,A,A,A,A,-,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,-,H,H,H,H,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,H,B,A,A,A,A,A,B,B,H,H,H,B,C,B,-,A,B,A,-,A,A,-,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,B,B,B,B,H,H,H,H,A,B,B,C,A,A 120.7,A,A,A,H,A,H,B,B,B,B,B,B,B,H,B,H,H,A,A,H,H,H,B,H,H,A,A,A,B,H,H,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,A,A,H,-,H,B,A,A,A,A,A,H,H,H,H,H,H,H,B,H,A,A,A,A,H,H,H,A,A,H,B,B,B,B,B,B,C,-,H,H,H,H,H,H,H,-,H,H,H,H,H,H,-,-,H,H,H,H,H,H,B,B,A,A,A,A,A,A,A,A,A,A,H,H,B,C,A,H 114.55,B,B,B,B,B,B,H,H,H,H,H,H,B,H,H,H,H,A,A,H,A,A,A,A,H,B,-,B,H,H,H,H,H,H,H,H,H,H,H,H,-,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,-,H,H,A,A,A,A,A,H,B,B,B,H,H,H,H,A,A,H,B,B,A,A,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,H,A,A,-,-,B,B,B,B,-,B,B,B,B,H,A,B,B,B,H,B,B,B,H,H,H,C,H,A 94.033,A,A,H,A,H,H,B,B,B,B,B,B,B,H,H,H,A,A,A,H,H,A,A,A,A,B,B,B,A,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,-,H,H,H,H,H,A,A,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,A,A,A,A,A,A,A,A,H,B,A,-,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,H,A,A,A,A,A,B,H,H,H,A,A,H,H,A,A,A,C,A,A 67.683,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,A,A,A,A,B,B,B,H,A,H,H,H,H,H,B,B,B,B,B,-,B,B,H,H,H,A,A,A,A,A,A,A,A,H,B,-,H,-,H,H,H,H,H,B,B,-,B,B,H,H,H,A,A,A,A,A,A,A,H,H,A,A,A,H,H,H,B,B,H,H,C,H,H,H,-,H,H,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,H,H,A,A,A,A,B,B,B,H,H,H,H,B,H,A,H,C,A,H 93.833,A,A,-,H,H,H,A,A,A,A,A,A,H,H,H,H,H,H,H,A,-,-,A,A,-,-,-,-,B,H,H,H,H,H,H,H,-,H,H,H,-,H,H,-,H,H,H,-,-,H,H,-,H,H,H,-,B,B,B,B,-,H,H,H,-,H,H,A,A,H,-,H,-,-,H,-,A,A,A,-,H,-,-,A,H,-,-,A,A,-,A,C,H,H,-,-,H,H,A,A,-,A,-,-,A,A,-,A,A,H,-,H,H,H,-,-,A,-,-,-,-,-,B,-,H,A,A,-,-,-,-,A,A 93.867,H,H,-,H,H,H,H,H,H,H,H,A,A,H,H,B,B,H,H,B,-,-,A,A,-,-,-,-,A,H,H,H,H,H,H,H,-,H,H,H,-,H,H,-,H,H,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,A,A,A,-,H,B,A,A,A,-,A,-,-,H,-,B,B,B,-,B,-,-,H,H,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,A,-,H,H,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,-,B,-,B,H,H,-,-,-,-,A,H 139.867,-,H,-,H,H,H,H,H,H,H,H,B,B,H,A,A,A,A,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,H,H,H,-,H,H,H,-,B,H,-,H,H,H,-,-,H,H,-,A,A,A,-,B,H,-,H,-,B,B,H,-,H,H,H,-,H,-,H,-,-,H,-,H,H,H,-,H,H,-,H,A,-,-,B,B,-,H,A,A,A,-,-,A,A,A,A,A,A,A,-,B,B,-,A,A,A,-,A,A,H,-,-,B,-,-,-,-,-,H,-,A,A,A,-,-,-,-,A,A 117.933,-,H,-,H,A,A,A,A,A,A,A,-,A,H,A,H,H,H,H,H,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,B,-,B,B,B,-,B,A,-,A,A,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,H,H,H,-,-,H,H,H,H,-,A,-,-,H,-,H,H,H,-,B,B,-,B,B,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,B,-,H,H,-,A,A,A,-,A,A,A,-,-,A,-,-,-,-,B,B,-,H,B,B,-,-,-,-,A,A 77.8,-,H,-,B,B,B,B,B,B,H,H,H,H,H,H,A,H,H,B,H,-,-,H,H,-,-,-,-,A,B,B,B,B,B,B,B,-,H,H,H,-,A,A,-,H,H,A,-,-,A,A,-,A,A,A,-,B,H,H,H,-,A,A,H,-,H,A,B,-,B,-,B,-,-,A,-,H,H,H,-,B,B,-,B,B,-,-,H,H,-,H,A,A,A,-,-,A,A,A,A,A,A,A,-,B,B,-,H,H,H,-,A,A,A,-,-,A,-,-,-,-,-,A,-,H,H,H,-,-,-,-,A,H 117.833,H,H,-,H,H,-,H,H,H,H,-,H,H,B,B,H,B,B,H,H,-,-,A,A,-,-,-,-,H,A,H,H,H,H,H,H,-,H,H,H,-,H,H,-,B,B,B,-,-,H,H,-,H,H,H,-,A,-,A,A,-,B,B,B,-,B,B,H,-,A,-,H,-,-,B,-,H,H,H,-,H,H,-,A,A,-,-,H,-,-,H,A,A,A,-,-,A,A,A,A,A,A,H,-,H,H,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,A,-,-,B,B,-,-,-,-,A,H 264,-,A,-,H,H,-,H,H,H,H,H,B,B,H,B,B,B,B,B,H,-,-,H,H,-,-,-,-,B,H,H,H,H,H,H,H,-,H,A,A,-,A,H,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,H,A,-,B,B,B,-,B,B,A,H,H,-,B,-,-,B,-,A,H,H,-,H,-,-,H,H,-,-,B,B,-,B,A,A,H,-,-,H,H,H,H,H,-,H,-,A,A,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,B,-,A,H,H,-,-,-,-,H,H 77.733,-,H,-,H,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,H,-,-,H,H,-,-,-,-,H,B,B,B,B,B,B,B,-,B,B,B,-,A,H,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,-,H,-,B,B,B,-,H,H,H,H,H,-,B,-,-,H,-,H,B,H,-,A,A,-,A,-,-,-,H,H,-,A,C,H,H,-,-,A,A,A,A,-,A,H,-,H,H,-,H,H,H,-,H,H,H,-,-,B,-,-,-,-,A,H,-,A,A,A,-,-,-,-,H,- 93.183,-,B,-,H,A,A,H,H,H,H,H,H,H,H,A,A,H,H,H,A,-,-,H,H,-,-,-,-,B,B,-,B,B,B,B,H,-,H,H,H,-,B,B,-,B,B,B,-,-,B,B,-,H,H,H,-,H,B,B,H,-,H,H,B,-,-,B,A,-,H,-,H,-,-,H,-,B,A,A,-,A,A,-,A,H,-,-,H,B,-,H,A,A,A,-,-,A,A,A,A,-,A,A,-,B,-,-,H,H,H,-,H,H,H,-,-,A,-,-,-,-,-,B,-,A,A,A,-,-,-,-,H,A 77.633,B,B,-,A,A,A,A,A,A,A,-,A,A,H,H,H,H,H,H,A,-,-,A,A,-,-,-,-,H,H,-,H,H,H,H,H,-,H,H,H,-,H,A,-,A,A,A,-,-,A,A,-,H,H,H,-,A,A,A,H,-,A,-,A,-,A,A,B,B,B,-,B,-,-,B,-,H,H,B,-,H,H,-,H,H,-,-,H,H,-,A,C,H,H,-,-,H,H,H,H,H,H,A,-,A,-,-,B,B,B,-,B,B,B,-,-,A,-,-,-,-,A,A,-,H,H,H,-,-,-,-,A,A 77.55,A,A,-,H,H,H,A,A,A,A,A,A,A,H,B,B,H,H,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,H,H,H,-,H,H,H,-,A,B,-,B,H,H,-,-,H,H,-,H,H,H,-,H,H,B,B,-,B,B,B,-,B,B,H,-,H,-,H,-,-,H,-,H,H,H,-,B,-,-,H,A,-,-,H,H,-,H,C,H,H,-,-,A,A,A,A,A,A,A,-,H,H,-,H,H,A,-,A,A,A,-,-,A,-,-,-,-,H,H,-,H,H,B,-,-,-,-,A,A 264,A,A,-,H,H,H,H,H,B,B,B,-,H,H,H,A,A,A,A,A,-,-,H,H,-,-,-,-,H,H,-,A,A,A,A,A,-,A,H,H,-,H,B,-,H,A,A,-,-,-,A,-,A,A,A,-,B,A,-,A,-,B,B,B,-,B,A,A,-,A,-,H,-,-,H,-,A,-,A,-,H,B,-,B,-,-,-,B,-,-,A,C,H,H,-,-,B,B,B,B,B,B,B,-,H,H,-,H,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,H,-,H,-,-,-,-,A,A 117.433,-,B,B,B,B,H,H,H,H,H,A,A,A,A,H,H,B,B,B,H,-,-,B,B,-,-,-,-,A,H,H,H,H,A,A,A,-,A,A,A,-,H,A,-,A,A,A,-,-,H,H,-,H,H,H,-,H,A,A,A,-,H,H,H,-,H,H,A,A,A,-,A,-,-,B,-,B,B,B,-,H,H,-,A,H,-,-,A,A,-,A,C,H,H,-,-,H,H,H,H,H,H,H,-,H,-,-,H,H,H,-,H,H,A,-,-,A,-,-,-,-,H,A,-,B,H,H,-,-,-,-,A,A 93.067,B,B,B,H,H,H,B,B,H,H,H,H,H,H,H,H,A,A,A,H,-,-,A,H,-,-,-,-,A,B,B,B,B,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,H,H,-,H,H,H,-,B,H,H,H,-,H,H,B,-,B,B,B,A,H,-,H,-,-,H,-,A,-,A,-,H,H,-,H,B,-,-,A,A,-,H,C,H,H,-,-,H,B,B,B,-,B,B,-,H,H,-,H,B,B,-,B,B,B,-,-,H,-,-,-,-,-,B,-,B,B,B,-,-,-,-,A,H 99.867,-,H,-,H,H,H,A,A,A,A,A,A,A,B,B,B,B,B,A,A,-,-,B,B,-,-,-,-,A,A,A,A,H,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,A,A,H,-,B,B,B,B,B,-,B,-,-,H,-,A,A,A,-,H,H,-,H,A,-,-,A,A,-,H,C,H,A,-,-,A,A,A,A,-,A,A,-,B,B,-,A,A,A,-,H,H,H,-,-,B,-,-,-,-,H,H,-,H,H,H,-,-,-,-,H,H 82.333,A,H,-,B,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,A,-,-,A,A,-,-,-,-,B,B,B,B,B,B,B,B,-,B,B,B,-,B,H,-,H,H,H,-,-,A,A,-,A,A,A,-,B,H,A,A,-,H,-,H,-,A,A,H,H,H,-,H,-,-,A,-,H,B,H,-,H,-,-,H,A,-,-,H,H,-,H,C,H,A,-,-,A,A,A,A,-,A,A,-,H,H,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,H,H,-,H,B,B,-,-,-,-,H,H 163.75,B,B,B,B,H,H,A,A,H,H,H,H,H,B,H,H,H,H,H,H,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,A,-,A,A,A,-,A,A,-,A,A,A,-,-,A,A,-,A,A,A,-,H,H,-,H,-,B,B,B,-,B,H,H,B,B,-,B,-,-,B,-,H,H,H,-,H,H,-,H,H,-,-,H,H,-,B,C,H,H,-,-,A,A,A,A,A,A,A,-,B,H,-,H,H,H,-,-,H,H,-,-,B,-,-,-,-,A,A,-,B,B,B,-,-,-,-,A,H 82.017,B,B,B,H,H,B,B,B,B,B,B,B,B,H,H,H,A,A,A,A,-,-,-,H,-,-,-,-,H,H,-,B,B,B,B,B,-,B,B,B,-,B,H,-,H,H,H,-,-,B,B,-,B,B,B,-,H,A,A,A,-,A,A,A,-,H,H,H,H,B,-,B,-,-,B,-,A,A,H,-,H,H,-,A,A,-,-,A,A,-,H,A,A,A,-,-,A,H,H,H,H,H,H,-,A,A,-,A,H,H,-,H,H,H,-,-,H,-,-,-,-,B,A,-,H,H,H,-,-,-,-,A,A 264,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,B,-,-,H,H,-,-,-,-,A,B,B,A,A,A,A,A,-,A,A,A,-,H,B,-,B,B,H,-,-,H,H,-,A,A,A,-,H,H,B,B,-,A,A,A,-,A,H,H,H,B,-,B,-,-,A,-,B,B,B,-,B,B,-,B,B,-,-,B,B,-,B,C,H,H,-,-,H,H,H,H,H,H,H,-,A,A,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,H,-,-,B,H,H,-,-,-,-,A,A 264,A,A,-,H,B,B,B,B,B,B,-,B,B,B,B,B,B,B,B,A,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,A,-,A,H,H,-,H,B,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,B,B,H,-,H,H,H,-,H,-,A,-,-,H,-,H,-,H,-,H,H,-,H,H,-,-,H,-,-,B,C,H,H,-,-,B,B,B,B,B,B,B,-,H,-,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,H,-,H,H,H,-,-,-,-,A,A 91.283,B,B,-,-,A,A,A,A,A,A,H,H,H,H,A,A,H,H,H,H,-,-,H,H,-,-,-,-,B,H,H,H,H,H,H,H,-,H,H,H,-,H,B,-,B,B,B,-,-,B,B,-,B,B,B,-,H,-,A,H,-,H,H,H,-,A,H,H,H,H,-,A,-,-,H,-,H,H,H,-,H,H,-,H,H,-,-,B,-,-,B,C,H,H,-,-,A,A,A,A,A,A,A,-,A,A,-,A,A,H,-,H,H,H,-,-,B,-,-,-,-,H,A,-,B,B,B,-,-,-,-,H,H 140.767,H,H,-,H,H,H,H,H,H,H,H,B,B,B,B,H,A,A,A,H,-,-,H,H,-,-,-,-,A,H,H,H,H,H,H,H,-,H,H,H,-,B,A,-,A,A,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,B,B,B,-,B,B,-,B,B,-,B,-,-,H,-,H,H,H,-,B,B,-,B,-,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,B,B,B,-,B,H,H,-,-,B,-,-,-,-,A,H,-,-,H,H,-,-,-,-,H,H 81.733,A,A,-,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,B,H,-,-,H,H,-,-,-,-,H,B,B,B,B,B,B,-,-,H,H,A,-,A,B,-,H,H,H,-,-,H,H,-,H,H,B,-,H,H,H,H,-,H,H,H,-,H,H,A,A,H,-,H,-,-,A,-,B,-,B,-,H,-,-,H,A,-,-,B,B,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,B,B,B,-,H,H,H,-,-,H,-,-,-,-,H,H,-,A,H,A,-,-,-,-,A,A 75.667,H,H,-,A,A,A,A,A,A,A,A,-,A,A,H,H,B,B,H,H,-,-,-,A,-,-,-,-,A,H,-,H,H,-,B,B,-,B,B,B,-,B,A,-,A,A,H,-,-,-,H,-,H,H,H,-,H,-,B,B,-,A,A,-,-,B,B,H,H,H,-,H,-,-,H,-,H,-,H,-,H,H,-,H,H,-,-,A,A,-,H,C,H,H,-,-,H,H,H,A,-,A,H,-,H,H,-,B,H,H,-,H,H,H,-,-,A,-,-,-,-,A,H,-,H,A,A,-,-,-,-,A,H 76.483,B,B,B,B,B,H,H,H,H,H,H,H,H,B,B,H,H,H,A,H,-,-,A,A,-,-,-,-,A,B,-,H,H,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,-,B,-,B,B,B,-,B,B,-,H,-,A,A,A,-,A,A,B,-,B,-,B,-,-,B,-,A,-,H,-,A,H,-,B,B,-,-,H,H,-,B,A,A,A,-,-,A,A,A,A,H,H,B,-,H,H,-,B,B,B,-,B,B,B,-,-,A,-,-,-,-,A,A,-,H,H,H,-,-,-,-,A,A 116.467,H,H,-,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,H,H,-,-,H,-,-,-,-,-,B,H,H,A,A,A,A,A,-,A,A,A,-,H,A,-,A,A,A,-,-,H,H,-,H,H,H,-,H,H,H,B,-,A,A,A,-,A,H,B,-,B,-,B,-,-,B,-,H,H,H,-,H,H,-,B,B,-,-,H,H,-,A,A,A,A,-,-,A,A,H,H,H,H,H,-,A,H,-,A,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,B,B,B,-,-,-,-,A,A 116.517,A,A,-,B,B,B,B,B,B,B,B,H,H,H,H,B,H,H,H,H,-,-,H,H,-,-,-,-,A,B,B,B,B,B,B,B,-,B,H,H,-,H,B,-,B,H,H,-,-,H,H,-,H,H,H,-,A,A,-,H,-,B,B,H,-,H,H,A,-,A,-,A,-,-,A,-,H,-,H,-,H,H,-,B,B,-,-,H,H,-,H,C,H,H,-,-,H,-,H,H,-,H,H,-,A,A,-,H,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,H,A,A,-,-,-,-,A,H 139.55,H,H,B,B,B,B,B,B,H,H,H,H,H,A,A,A,H,H,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,-,H,H,-,H,H,B,-,B,H,-,H,A,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,H,H,H,-,H,H,H,H,H,-,A,-,-,H,-,H,H,H,-,H,H,-,B,H,-,-,H,-,-,A,C,H,A,-,-,A,A,H,H,H,H,H,-,H,H,-,A,A,A,-,A,A,A,-,-,H,-,-,-,-,B,H,-,H,H,B,-,-,-,-,H,H 264,A,A,-,A,A,A,A,A,A,A,A,A,A,B,B,H,H,H,H,B,-,-,H,H,-,-,-,-,H,B,B,H,H,H,H,H,-,H,H,H,-,H,B,-,B,B,B,-,-,B,B,-,H,H,H,-,A,B,B,B,-,H,H,A,-,H,H,B,B,B,-,B,-,-,H,-,B,-,B,-,H,H,-,H,H,-,-,B,B,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,B,B,-,H,H,H,-,-,-,-,H,A 116.2,A,A,-,H,H,H,H,H,H,H,H,A,A,A,H,H,H,A,A,H,-,-,H,B,-,-,-,-,H,H,H,H,H,H,H,H,-,B,B,-,-,B,H,-,H,H,A,-,-,A,A,-,A,A,A,-,A,H,H,H,-,H,H,A,-,H,H,A,A,A,-,A,-,-,H,-,H,-,H,-,H,B,-,B,B,-,-,H,H,-,B,C,H,H,-,-,H,H,H,H,H,H,H,-,B,B,-,H,H,H,-,B,B,B,-,-,H,-,-,-,-,H,B,-,H,H,H,-,-,-,-,A,A qtl/tests/testthat.R0000644000176200001440000000004412770016226014200 0ustar liggesuserslibrary(testthat) test_check("qtl") qtl/tests/test_mapqtl_io.R0000644000176200001440000000054712770016226015374 0ustar liggesusers# test input/output in mapqtl format library(qtl) data(fake.4way) write.cross(fake.4way, "mapqtl", "fake_4way_mapqtl") x <- read.cross("mapqtl", "", genfile="fake_4way_mapqtl.loc", phefile="fake_4way_mapqtl.qua", mapfile="fake_4way_mapqtl_female.map") x <- replace.map(x, pull.map(fake.4way)) comparecrosses(x, fake.4way) qtl/tests/listeria2.map0000644000176200001440000000241212770016226014613 0ustar liggesusers1 D10M44 1 D1M3 1 D1M75 1 D1M215 1 D1M309 1 D1M218 1 D1M451 1 D1M504 1 D1M113 1 D1M355 1 D1M291 1 D1M209 1 D1M155 2 D2M365 2 D2M37 2 D2M396 2 D2M493 2 D2M226 2 D2M148 3 D3M265 3 D3M51 3 D3M106 3 D3M257 3 D3M147 3 D3M19 4 D4M2 4 D4M178 4 D4M187 4 D4M251 5 D5M148 5 D5M232 5 D5M257 5 D5M83 5 D5M307 5 D5M357 5 D5M205 5 D5M398 5 D5M91 5 D5M338 5 D5M188 5 D5M29 5 D5M168 6 D6M223 6 D6M188 6 D6M284 6 D6M39 6 D6M254 6 D6M194 6 D6M290 6 D6M25 6 D6M339 6 D6M59_ 6 D6M201 6 D6M15 6 D6M294 7 D7M246 7 D7M145 7 D7M62 7 D7M126 7 D7M105 7 D7M259 8 D8M94 8 D8M339 8 D8M178 8 D8M242 8 D8M213 8 D8M156 9 D9M247 9 D9M328 9 D9M106 9 D9M269 9 D9M346 9 D9M55 9 D9M18 10 D10M298 10 D10M294 10 D10M42_ 10 D10M10 10 D10M233 11 D11M78 11 D11M20 11 D11M242 11 D11M356 11 D11M327 11 D11M333 12 D12M105 12 D12M46 12 D12M34 12 D12M5 12 D12M99 12 D12M150 13 D13M59 13 D13M88 13 D13M21 13 D13M39 13 D13M167 13 D13M99 13 D13M233 13 D13M106 13 D13M147 13 D13M226 13 D13M290 13 D13M151 14 D14M14 14 D14M115 14 D14M265 14 D14M266 15 D15M226 15 D15M100 15 D15M209 15 D15M144 15 D15M68 15 D15M239 15 D15M241 15 D15M34 16 D16M154 16 D16M4 16 D16M139 16 D16M86 17 D17M260 17 D17M66 17 D17M88 17 D17M129 18 D18M94 18 D18M58 18 D18M106 18 D18M186 19 D19M68 19 D19M117 19 D19M65 19 D19M10 X DXM186 X DXM64 qtl/tests/test_io.R0000644000176200001440000000370212770016226014012 0ustar liggesusers###################################################################### # # TestIO/input.R # # copyright (c) 2002, Karl W Broman # last modified Feb, 2002 # first written Feb, 2002 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # This file contains code for testing the cross IO in R/qtl. # # Needed input files: # # gen.txt, map.txt, phe.txt [Karl's format] # listeria.raw, listeria.map [mapmaker format] # listeria.raw, listeria2.map [mapmaker format; no marker pos] # listeria.csv [csv format] # listeria2.csv [csv format; no marker pos] # ###################################################################### library(qtl) ############################## # Reading ############################## # Read CSV format csv <- read.cross("csv", "", "listeria.csv") csv2 <- read.cross("csv", "", "listeria2.csv", estimate=FALSE) # Read mapmaker format mm <- read.cross("mm", "", "listeria.raw", "listeria.map") mm2 <- read.cross("mm", "", "listeria.raw", "listeria2.map", estimate=FALSE) ############################## # Writing ############################## # Write in CSV format write.cross(csv, "csv", filestem="junk1") csv3 <- read.cross("csv", "", "junk1.csv", genotypes=c("AA","AB","BB","not BB","not AA")) comparecrosses(csv, csv3) # Write in mapmaker format write.cross(csv, "mm", filestem="junk2") # Cleanup unlink("junk1.csv") unlink("junk2.raw") unlink("junk2.prep") qtl/tests/listeria.csv0000644000176200001440000010420512770016226014552 0ustar liggesusersT264,D10M44,D1M3,D1M75,D1M215,D1M309,D1M218,D1M451,D1M504,D1M113,D1M355,D1M291,D1M209,D1M155,D2M365,D2M37,D2M396,D2M493,D2M226,D2M148,D3M265,D3M51,D3M106,D3M257,D3M147,D3M19,D4M2,D4M178,D4M187,D4M251,D5M148,D5M232,D5M257,D5M83,D5M307,D5M357,D5M205,D5M398,D5M91,D5M338,D5M188,D5M29,D5M168,D6M223,D6M188,D6M284,D6M39,D6M254,D6M194,D6M290,D6M25,D6M339,D6M59_,D6M201,D6M15,D6M294,D7M246,D7M145,D7M62,D7M126,D7M105,D7M259,D8M94,D8M339,D8M178,D8M242,D8M213,D8M156,D9M247,D9M328,D9M106,D9M269,D9M346,D9M55,D9M18,D10M298,D10M294,D10M42_,D10M10,D10M233,D11M78,D11M20,D11M242,D11M356,D11M327,D11M333,D12M105,D12M46,D12M34,D12M5,D12M99,D12M150,D13M59,D13M88,D13M21,D13M39,D13M167,D13M99,D13M233,D13M106,D13M147,D13M226,D13M290,D13M151,D14M14,D14M115,D14M265,D14M266,D15M226,D15M100,D15M209,D15M144,D15M68,D15M239,D15M241,D15M34,D16M154,D16M4,D16M139,D16M86,D17M260,D17M66,D17M88,D17M129,D18M94,D18M58,D18M106,D18M186,D19M68,D19M117,D19M65,D19M10,DXM186,DXM64 ,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,6,6,6,6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,8,8,8,8,8,8,9,9,9,9,9,9,9,10,10,10,10,10,11,11,11,11,11,11,12,12,12,12,12,12,13,13,13,13,13,13,13,13,13,13,13,13,14,14,14,14,15,15,15,15,15,15,15,15,16,16,16,16,17,17,17,17,18,18,18,18,19,19,19,19,X,X ,0,0.99675,24.84773,40.41361,49.99468,52.8002,70.11204,70.80642,80.62324,81.39623,84.93474,92.68394,93.64344,0,27.94171,47.10541,67.26185,77.39805,90.8563,0,32.47839,43.93803,57.59338,63.1854,70.839,0,19.16072,35.32086,68.10316,0,6.10396,19.22335,19.54883,23.71714,25.50009,30.89665,30.89765,32.90522,38.06807,44.02376,50.98471,61.87613,10,18.18754,23.87218,31.0941,41.79506,45.14579,47.5299,51.24736,51.65073,55.30478,59.00988,59.37089,60.76244,0,18.78851,34.91062,41.03048,60.11409,72.08424,0,1.33987,11.42091,27.14066,32.98625,50.86364,0,4.21823,14.71565,27.32417,32.95644,45.33567,52.50404,0,24.74745,40.70983,48.73004,61.05621,0,15.15394,26.42149,38.52145,42.16139,64.34481,0,6.17921,21.58051,29.08404,41.79569,54.45582,0,0.28675,10.36588,13.04983,13.05083,18.90884,21.01258,24.87531,26.15954,28.3927,28.3937,35.98707,0,23.90747,32.78679,45.55022,0,13.46195,18.79081,19.36473,23.91373,25.1265,31.27607,42.97207,0,16.76684,26.23135,41.79901,0,11.72823,17.33527,38.84807,0,0.6856,16.98386,20.8999,0,16.36398,32.82935,44.49432,0,42.34593 118.317,B,B,B,H,H,H,B,B,H,H,H,H,H,H,A,A,-,A,A,B,B,B,B,B,B,A,H,A,H,A,A,H,H,H,H,H,-,H,H,H,B,B,A,A,H,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,B,B,B,H,H,H,A,A,H,B,B,B,B,B,B,C,-,H,H,H,A,A,A,A,A,A,A,B,B,H,H,A,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,B,B,B,B,H,H,H,C,H,H 264,-,B,B,B,H,H,H,H,H,H,H,H,H,B,B,H,-,H,A,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,H,H,B,B,B,A,A,A,A,A,A,A,A,A,H,H,H,H,H,B,B,B,B,B,H,H,H,B,B,B,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,A,A,H,H,H,H,-,H,H,H,H,H,A,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,B,B,H,H,A,H,H,C,H,H 194.917,-,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,-,-,H,H,H,H,H,B,B,A,A,H,H,A,A,A,A,H,H,H,-,H,H,H,H,A,H,H,H,H,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,H,H,H,B,H,H,B,B,B,B,B,B,B,H,A,A,A,A,H,H,H,H,H,H,B,B,H,H,H,B,A,A,A,A,A,A,A,H,H,H,H,H,B,B,B,H,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,B,B,H,H,A,A,H,H 264,B,B,H,H,H,H,B,B,B,B,B,B,B,A,-,A,-,H,H,B,H,H,H,H,H,H,H,H,H,-,H,A,A,A,A,A,-,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,A,H,B,H,H,B,B,B,B,B,H,A,A,H,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,H,A,A,H,H,B,H,H,H,H,A,A,A,H,H,B,A,H,H,B,A,A,A,A,B,H,H,C,H,A 145.417,H,H,H,H,B,H,H,H,H,H,H,H,H,B,H,H,-,-,H,B,A,A,A,A,A,A,A,A,H,-,A,A,A,A,A,-,-,H,H,H,H,H,A,A,A,A,A,A,-,H,H,H,H,H,H,B,H,A,A,H,H,A,A,A,A,A,H,B,B,B,H,H,H,H,A,H,H,H,H,B,B,B,B,B,H,A,A,A,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,B,B,B,A,A,A,H,A,A,A,A,H,A,A,C,A,A 177.233,H,H,B,B,B,B,B,B,B,B,B,B,B,H,A,A,A,-,A,B,B,B,B,B,B,H,H,H,H,A,A,A,A,A,A,H,-,H,H,H,-,H,A,A,A,H,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,H,H,H,H,C,H,-,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,B,H,H,H,H,A,A,A,C,A,H 264,H,H,H,H,A,A,A,A,H,H,H,H,H,B,B,B,B,-,H,B,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,-,A,A,A,-,H,H,H,H,H,H,H,H,B,B,B,B,B,B,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,H,H,H,A,A,A,H,H,B,B,H,A,A,A,A,C,H,B,B,B,B,B,B,B,B,B,B,A,H,H,H,A,A,A,A,A,A,A,-,B,H,H,H,H,A,A,H,H,H,B,B,B,B,A,A,H,H 76.667,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,A,-,A,A,H,B,H,H,H,H,H,-,H,B,B,B,B,B,B,B,B,-,B,B,H,H,H,A,A,A,A,H,H,-,B,B,B,B,B,B,H,H,H,H,H,B,A,A,H,H,H,H,B,B,B,B,B,B,H,A,A,-,A,A,H,B,H,B,B,H,A,H,H,H,H,H,C,H,H,A,A,A,-,A,A,-,A,H,H,B,H,H,B,B,B,B,H,H,H,H,B,B,B,B,H,H,H,H,A,A,-,H,H,H,H,C,A,- 90.75,A,A,H,B,B,B,H,H,H,H,H,-,H,A,H,H,H,H,B,A,H,H,A,A,A,H,H,H,B,H,H,H,H,A,A,A,-,A,A,A,-,H,H,H,H,H,B,B,B,H,H,H,H,H,H,B,B,B,B,B,H,B,B,-,B,B,A,H,H,H,A,A,A,A,H,B,B,B,B,B,B,H,H,H,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,H,A,A,A,A,A,A,A,H,B,B,B,A,A,H,H,B,B,-,B,H,H,H,A,A,H 76.167,B,B,H,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,A,H,H,H,H,A,B,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,A,A,A,H,H,B,B,B,H,H,H,B,B,B,B,B,H,A,A,H,H,H,H,A,H,H,H,H,B,A,-,A,A,A,A,C,H,H,H,H,H,H,H,H,H,H,H,A,H,B,H,H,H,H,H,H,H,H,H,B,B,B,H,A,A,A,A,A,A,A,A,H,B,B,C,H,A 104.083,A,H,H,H,H,H,H,H,H,H,H,-,H,A,A,B,B,B,B,H,A,A,H,H,H,H,H,H,B,H,H,H,H,H,H,H,-,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,A,A,A,H,A,H,H,H,-,A,A,A,A,A,A,H,H,B,B,B,B,B,A,H,H,H,A,A,H,H,H,H,H,A,A,A,H,H,B,C,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,A,A,A,A,A,A,A,H,B,B,B,H,H,B,B,B,A,A,A,A,B,H,H,C,A,H 194.5,A,A,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,H,H,A,H,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,-,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,B,B,H,A,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,H,H,A,A,A,A,H,A,-,A,A,A,A,A,H,H,-,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,A,H,C,H,H 75.917,A,A,H,H,H,H,B,B,B,B,B,-,B,H,H,H,H,H,H,A,A,A,A,A,A,H,H,H,A,H,H,H,H,H,H,H,-,H,H,H,-,H,B,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,A,H,H,H,A,A,A,A,A,H,A,A,A,-,A,H,C,H,A,A,A,A,A,A,A,H,H,H,B,B,B,B,A,A,A,A,A,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H 75.833,H,H,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,-,H,B,H,H,H,B,H,H,H,H,H,B,B,B,B,B,B,B,-,B,B,B,-,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,-,H,H,A,A,A,A,A,H,B,B,B,B,B,B,H,B,H,H,H,H,B,H,H,H,H,A,H,H,H,H,H,B,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,A,B,B,B,B,A,A,-,H,H,B,-,C,A,H 90.25,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,H,H,B,B,B,B,B,B,H,H,B,B,A,A,H,H,H,H,H,-,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,H,H,H,H,A,A,A,H,H,A,A,A,A,A,H,A,A,A,B,H,A,A,H,A,A,H,H,H,H,H,H,C,H,A,A,A,A,A,A,A,H,H,H,A,A,H,H,-,-,A,A,A,A,A,-,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,A,A,A 103.667,H,H,B,B,B,B,H,H,H,H,H,A,A,B,B,H,H,A,A,H,-,H,H,H,H,B,B,B,B,H,B,B,B,B,B,B,-,B,B,B,B,H,H,H,H,H,H,B,-,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,H,H,B,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,B,A,A,H,-,A,A,A,A,A,A,A,B,B,B,H,B,B,H,H,B,-,-,B,B,B,B,C,A,A 128.4,A,A,A,A,A,A,H,H,H,H,H,H,H,H,B,H,-,H,H,B,-,A,A,A,A,B,H,H,H,H,H,H,H,B,B,B,-,B,B,B,B,B,H,H,B,B,B,B,B,B,B,H,H,H,H,A,H,H,H,B,H,B,B,B,B,B,H,B,B,H,H,H,A,A,A,A,A,A,H,A,A,A,A,A,B,A,A,A,A,A,A,C,B,B,B,B,B,B,B,B,B,B,B,A,A,A,H,H,A,A,A,A,A,A,-,B,H,H,A,A,A,A,A,A,-,-,A,H,-,A,A,A,H 122.25,B,B,H,H,-,H,H,H,H,H,H,B,B,B,B,H,H,H,B,A,A,A,H,H,H,A,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,A,A,A,-,A,A,A,A,H,H,B,B,B,B,A,A,A,H,H,-,H,H,H,A,A,A,H,H,H,C,B,B,B,B,B,B,B,B,-,B,B,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,-,B,H,-,H,A,A,A 264,H,H,A,H,H,H,B,B,B,B,B,-,B,H,H,A,A,A,H,A,A,H,A,H,A,A,-,H,A,A,A,A,A,A,A,A,-,A,A,A,-,A,H,H,A,H,H,H,H,H,H,H,B,B,B,H,H,H,H,A,A,B,B,B,H,H,A,A,A,A,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,A,C,B,B,B,B,B,B,H,H,H,H,H,A,H,H,B,H,A,A,A,A,A,A,-,H,B,B,B,B,B,-,H,H,H,-,H,B,B,B,-,A,H 72.6,H,H,H,H,A,A,A,A,A,A,-,H,H,H,H,H,A,A,A,A,A,A,A,-,A,A,H,H,H,B,H,H,H,H,H,H,-,H,A,A,A,A,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,B,H,H,-,H,H,H,H,H,A,A,H,B,B,B,H,H,B,B,B,B,B,B,B,B,B,H,-,C,H,H,H,H,A,A,A,A,A,A,A,B,H,A,A,B,B,B,B,B,B,H,H,H,H,A,A,H,H,H,B,A,A,-,A,B,B,B,C,A,H 264,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,A,A,A,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,-,A,A,A,-,A,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,H,A,A,A,H,H,B,H,H,H,A,A,A,A,H,H,H,H,H,A,A,H,H,H,H,A,A,A,A,B,B,C,H,H,H,H,H,H,H,H,H,H,H,B,H,A,A,B,B,B,B,H,H,H,H,H,H,A,A,B,B,B,H,H,H,-,H,H,H,H,C,H,A 264,B,B,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,A,A,H,B,B,B,H,H,B,B,B,B,A,A,H,H,H,H,H,-,H,H,H,-,B,H,H,H,H,B,B,B,B,B,B,B,B,B,H,H,H,A,A,A,H,H,B,B,B,B,A,A,A,H,B,B,B,A,A,A,A,A,H,H,B,B,B,B,B,B,H,H,H,H,C,H,-,H,H,H,H,H,H,H,H,A,H,A,A,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,H,-,H,-,-,H,A,A,A,A,H,A 264,A,A,A,A,A,A,H,H,B,B,B,B,B,-,A,A,A,A,H,A,H,H,A,A,A,B,B,B,H,A,A,A,A,A,A,A,-,A,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,B,B,B,H,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,A,H,H,H,H,H,H,A,A,A,A,H,H,C,-,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,A,A,-,A,A,A,H,C,A,A 81.717,H,H,H,-,H,H,H,H,H,H,H,H,A,H,H,B,B,B,A,H,H,H,H,B,B,H,H,A,B,-,B,B,B,B,B,B,-,B,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,B,H,H,-,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,B,B,B,B,B,B,B,H,H,H,H,H,H,C,-,H,H,H,A,A,A,A,A,A,A,H,H,H,H,B,B,B,B,B,B,B,B,A,A,A,A,H,H,H,B,A,A,-,A,H,H,H,C,H,H 264,-,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,-,H,H,A,A,A,A,A,A,H,H,H,H,B,-,B,B,H,H,H,H,H,A,A,A,A,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,-,A,A,A,A,H,B,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,B,B,H,H,H,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,H,H,H,B,H,H,-,B,H,B,H,C,A,A 264,-,H,B,H,H,H,H,H,H,H,H,H,H,A,B,B,-,H,A,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,B,B,H,H,H,H,-,H,H,H,-,H,H,H,A,B,B,H,-,H,H,H,A,A,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,A,A,A,H,H,H,B,B,B,B,B,H,H,H,H,H,H,H,B,H,H,H,A,H,H,H,H,H,H,H,B,B,B,B,H,H,B,H,H,H,-,H,B,B,H,C,-,H 116.483,-,H,H,H,H,H,H,H,H,H,H,A,A,H,H,H,-,H,H,A,H,H,H,H,H,A,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,-,H,H,H,H,H,H,H,H,H,H,H,B,H,B,B,B,B,H,A,A,A,A,A,A,A,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,B,B,B,B,B,B,B,H,A,A,A,A,A,A,A,A,A,H,-,H,H,H,B,C,A,A 87.467,-,H,H,A,A,A,A,A,A,A,A,A,A,H,H,B,-,A,A,H,A,A,A,A,H,H,B,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,-,H,H,H,H,H,H,B,H,H,H,A,-,B,B,B,B,B,B,H,B,B,B,B,B,H,A,A,H,H,H,H,B,B,B,B,B,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,B,B,B,B,B,B,B,H,B,B,B,B,B,B,H,A,A,-,A,B,H,H,C,H,A 264,H,H,H,A,-,H,H,H,H,H,H,H,H,-,A,H,H,H,B,B,B,B,H,H,H,A,H,H,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,B,B,B,-,B,B,B,B,B,B,B,B,B,B,H,H,B,B,B,B,B,H,H,H,H,H,H,H,H,A,H,H,H,B,H,B,B,B,H,H,H,A,A,A,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,B,H,H,H,H,H,H,H,A,A,A,-,A,H,H,H,C,A,H NA,A,A,A,H,H,B,H,H,H,H,H,H,H,-,H,H,H,-,H,H,B,B,H,H,H,B,H,B,H,-,H,H,H,H,H,H,H,H,H,A,-,H,A,H,H,H,H,H,-,H,H,H,H,H,H,H,A,A,A,H,H,A,A,H,H,B,B,B,H,H,-,H,H,B,A,H,H,H,A,H,H,H,H,H,H,B,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,A,A,A,H,H,H,H,B,H,H,-,H,H,H,H,C,H,H 74.417,A,A,H,H,H,H,A,A,A,A,A,H,H,B,B,B,H,H,A,H,A,A,H,H,H,H,H,B,H,H,H,A,A,A,A,A,A,A,A,A,-,A,B,H,H,H,H,H,-,H,H,H,H,-,H,B,B,B,B,B,B,H,H,H,H,H,H,A,A,A,A,H,H,B,H,H,A,A,A,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,B,H,H,H,H,H,H,H,H,H,H,H,H,A,H,B,B,H,H,H,B,A,A,-,A,H,H,H,C,H,H 264,A,A,H,H,B,B,H,H,H,H,A,A,A,-,H,B,B,B,H,H,H,H,H,H,H,H,A,A,H,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,-,B,B,B,B,B,B,A,A,A,A,H,-,B,B,B,H,H,-,H,H,H,A,A,A,A,B,H,H,H,B,A,-,H,H,A,A,B,B,B,B,A,A,B,B,-,H,H,H,-,H,H,A,H,A,H,B,B,H,A,A,H,H,H,H,B,H,H,H,H,H,A,A,H,H,A,A,-,A,H,H,H,C,H,H 264,B,B,H,A,A,A,A,A,H,H,H,H,H,B,B,B,B,H,H,B,H,H,A,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,A,H,-,H,H,H,H,B,B,B,B,H,H,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,B,B,-,H,H,H,H,C,H,H 174.567,B,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,A,A,H,A,H,H,H,H,H,B,-,H,B,H,H,H,H,H,H,B,H,B,B,B,B,B,H,H,H,H,H,H,-,H,H,A,A,H,H,H,H,A,A,A,-,H,H,H,H,H,-,H,B,B,B,B,B,B,A,A,A,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,A,H,H,H,H,-,H,B,H,H,C,H,H 88.583,B,B,B,B,B,B,B,B,B,B,B,H,-,H,H,H,H,A,H,H,A,H,H,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,-,B,B,B,H,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,A,A,B,B,H,A,H,H,A,A,A,A,A,A,A,A,A,-,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,B,B,B,B,B,B,-,B,H,A,A,C,A,H 264,H,H,B,B,B,B,B,B,B,B,B,H,-,A,H,H,B,B,B,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,B,B,B,B,-,B,B,H,H,H,H,B,H,H,H,H,H,H,A,H,H,H,H,A,A,A,A,H,H,-,H,H,H,A,A,A,A 95,H,H,H,H,H,H,H,A,A,A,A,A,-,B,H,H,A,A,A,H,H,H,A,-,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,-,B,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,A,A,H,H,B,B,B,B,B,H,H,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,A,A,-,A,A,A,A,A,A,-,A,A,A,A,A,A,H,H,A,A,A,A,A,A,A,H,B,B,H,H,H,H,H,H,-,A,H,H,H,A,A,H 264,B,B,B,B,B,B,H,H,H,H,H,H,-,A,B,B,-,B,B,A,A,A,A,-,H,H,H,H,B,A,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,B,B,A,A,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,B,B,-,B,H,H,H,C,A,A 86.05,B,B,H,H,A,A,A,A,A,A,A,A,-,H,H,B,B,B,H,H,H,H,H,-,A,H,H,H,H,A,A,B,B,B,B,B,B,B,B,B,B,B,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,B,B,B,A,H,H,H,B,A,A,A,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,-,A,A,A,A,A,H,-,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,H,-,-,H,A,A,B,C,H,H 71.517,H,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,H,H,A,-,H,H,H,H,H,H,B,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,A,A,A,A,A,H,B,B,A,A,A,A,A,A,H,H,H,B,B,B,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,A,A,H,H,H,B,A,A,A,A,A,A,A,A,A,-,A,A,H,A,A,A,-,B,B,B,B,B,B,B,A,A,A,A,H,H,H,H,A,A,-,A,H,A,A,A,A,H 112.767,B,B,B,B,B,B,H,H,H,H,H,-,H,H,A,A,A,-,A,A,H,H,H,H,H,H,B,B,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,H,H,H,H,A,A,H,A,A,A,A,H,H,B,H,A,A,A,A,H,B,B,B,B,B,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,B,H,H,-,H,H,H,H,H,H,-,H,H,-,A,A,A,H,A,A,A,A,A,A,-,H,B,-,H,C,A,H 264,A,A,A,A,A,A,A,A,A,A,H,H,H,A,A,H,H,H,H,A,A,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,B,B,B,B,B,B,B,H,H,H,H,H,H,H,A,A,A,A,H,A,A,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,-,H,H,H,H,A,A,A,A,A,B,B,-,-,H,H,H,H,H,-,H,H,A,A,A,B,H,-,A,A,A,A,A,A,H,H,H,H,B,B,B,B,B,B,-,B,B,-,B,C,A,A 264,B,B,B,A,A,A,H,H,A,A,A,A,A,-,H,H,-,B,B,B,H,A,A,A,A,H,-,A,H,A,A,H,H,H,H,H,H,H,H,H,-,B,H,H,H,H,H,H,-,-,H,H,H,H,H,A,A,A,A,A,-,H,H,H,H,H,-,H,H,B,-,B,A,A,H,H,A,A,A,B,B,B,B,B,B,B,B,H,H,H,-,H,H,B,B,B,B,B,B,B,B,B,B,H,-,B,B,H,-,H,H,H,H,H,B,B,B,B,H,H,H,H,H,B,B,-,B,B,B,B,C,A,H 117.817,H,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,H,A,A,A,A,H,H,A,H,B,H,H,H,H,H,A,A,A,A,A,A,A,A,B,B,B,B,H,H,A,A,A,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,B,A,A,H,H,H,H,H,B,B,B,B,H,-,B,B,H,H,H,H,-,H,H,H,H,H,H,H,H,B,H,A,H,H,A,-,A,A,H,H,H,B,B,B,B,B,H,H,H,-,A,A,-,H,A,A,A,A,H,H 185.3,A,A,A,H,H,B,B,B,B,B,B,-,B,A,A,-,-,A,A,A,A,A,H,H,B,H,H,H,H,B,B,H,H,H,H,H,H,H,H,A,-,A,A,A,A,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,-,B,B,B,B,H,-,H,H,H,A,A,A,A,H,A,A,A,H,H,H,H,H,H,A,A,A,H,A,A,A,H,H,-,H,H,H,H,H,H,H,H,H,H,-,B,B,A,-,A,A,A,A,H,H,A,A,A,A,A,H,-,H,A,-,-,A,A,A,H,C,H,H 85.367,H,H,A,A,A,A,H,H,H,H,H,H,H,A,H,A,-,B,B,H,H,H,H,H,H,H,-,A,A,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,B,-,H,H,H,H,H,-,B,B,B,-,B,H,H,A,A,H,H,B,H,A,A,A,A,H,B,B,H,H,H,H,H,H,-,A,A,A,A,H,H,-,H,H,-,-,H,H,A,-,A,A,A,A,A,-,A,A,A,H,H,A,A,A,B,B,-,B,H,A,A,A,A,A 264,H,H,H,B,B,B,B,B,B,B,B,-,B,H,A,B,-,A,H,A,H,H,B,B,B,H,H,H,H,-,A,A,A,A,A,A,A,A,A,A,-,A,H,H,H,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,A,A,A,B,B,B,-,B,B,B,H,H,H,H,H,H,A,A,A,A,H,H,H,H,B,H,-,H,H,H,H,H,H,H,H,B,H,H,H,B,-,A,H,B,-,H,H,-,H,H,H,B,B,B,B,H,H,-,H,B,B,-,B,H,H,H,C,A,- 70.883,H,H,A,A,A,A,A,A,A,A,H,H,H,H,H,H,-,B,B,H,H,A,A,A,A,A,H,H,H,-,A,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,-,A,A,H,H,H,A,A,A,B,B,B,B,B,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,H,-,A,A,H,-,H,H,B,B,-,B,H,H,H,H,A,A,A,H,B,B,-,H,H,H,-,C,H,- 98.45,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,-,H,H,H,A,A,A,A,A,H,H,H,A,B,B,B,B,B,B,-,-,B,B,B,B,B,H,H,H,H,B,H,-,H,H,H,H,H,H,A,-,A,-,A,A,B,B,B,B,H,-,A,A,H,H,-,H,H,A,A,-,A,A,A,A,A,H,H,H,A,A,A,A,A,A,C,A,H,H,H,B,B,B,B,B,B,B,A,H,H,H,H,H,H,H,H,H,A,A,H,B,B,B,A,A,A,A,H,H,A,A,H,A,A,A,A,H 85.1,-,H,H,A,A,A,A,A,A,A,A,H,H,A,H,H,-,A,A,H,H,H,H,H,H,B,-,H,H,H,H,H,H,H,H,-,-,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,-,B,B,B,B,B,B,H,H,A,A,-,A,A,B,B,H,A,A,A,A,A,B,B,B,A,A,A,A,A,A,C,B,B,B,B,B,B,B,B,B,B,B,H,H,A,A,H,H,H,H,H,H,A,A,A,A,A,A,B,B,B,H,H,H,H,H,B,B,H,C,A,A 216.367,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,-,A,H,H,H,H,H,H,B,H,-,B,B,B,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,H,H,-,B,B,B,B,B,B,B,B,B,B,A,A,H,H,H,A,A,A,A,A,A,A,-,H,H,B,B,H,H,A,A,-,A,A,A,H,B,-,H,H,H,B,C,B,B,-,B,B,B,H,H,H,H,H,B,B,B,B,A,A,H,H,H,H,H,B,A,A,H,H,H,H,H,H,H,H,H,H,A,A,H,C,A,A 94.65,-,B,B,B,B,B,H,H,H,H,H,H,H,A,A,H,-,B,B,A,H,H,H,H,B,B,H,A,A,H,H,H,H,-,H,H,H,H,H,A,A,A,H,H,H,H,H,H,-,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,B,-,B,H,H,H,H,A,H,H,H,H,A,A,H,A,A,A,A,A,A,A,A,-,A,A,A,A,A,A,A,A,A,B,B,H,H,H,B,B,B,B,B,B,-,H,H,H,A,H,H,B,B,H,H,B,B,H,H,A,A,H,H 111.817,A,-,H,A,A,A,A,A,A,A,A,A,A,B,A,A,-,H,H,H,B,B,B,B,B,H,-,B,B,B,B,B,B,H,H,H,H,H,H,H,A,A,A,A,A,A,H,H,-,H,H,H,B,B,B,A,H,H,H,A,A,A,A,H,H,H,-,H,H,H,H,-,B,B,B,B,B,B,H,H,B,B,B,B,B,H,A,A,A,H,H,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,A,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,A,A,H,B,A,A,A,A,H,A 90.9,B,B,B,B,B,B,B,B,B,B,B,B,B,A,H,H,H,H,A,B,H,A,H,H,H,H,H,B,B,-,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,A,A,A,A,A,A,H,H,H,H,-,H,H,H,H,H,H,H,A,H,H,B,B,B,A,A,A,A,A,A,C,H,A,A,A,A,-,A,A,A,A,A,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,C,A,H 264,A,-,H,H,B,B,B,B,B,B,B,B,B,-,B,B,B,B,H,H,H,H,H,H,H,H,H,A,H,H,H,A,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,-,B,B,B,B,B,B,H,H,H,A,A,A,H,H,A,A,A,-,H,A,A,A,-,H,H,H,H,B,B,B,H,-,A,A,A,A,A,A,A,A,A,A,C,H,H,H,H,H,-,H,H,H,H,A,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,H,H,B,H,H,H,A,A,A,A 170.517,H,H,B,H,H,H,B,B,B,B,B,B,B,A,H,A,-,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,-,B,B,H,H,H,-,A,A,A,A,A,H,H,A,H,-,H,B,H,H,H,H,A,A,H,H,-,H,B,B,C,H,-,H,H,H,A,A,A,A,A,A,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,A,B,H,H,H,B,B,B,B,H,H,H,C,H,H 111.717,H,-,H,H,A,A,H,H,B,B,B,B,B,H,A,A,H,B,B,H,H,H,H,A,A,H,H,H,H,A,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,B,B,H,H,A,A,A,A,H,A,H,H,-,H,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,H,H,H,C,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,A,A,A,A,A,A,A,H,-,H,H,A,A,A,A,A,A,A,A,B,H,H,C,H,H 264,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,A,A,H,H,H,A,A,A,A,A,A,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,B,B,B,H,H,A,A,-,A,A,H,H,H,H,H,A,H,B,H,H,A,A,A,A,A,A,A,A,A,-,A,A,A,-,A,H,-,H,H,B,H,H,H,H,H,H,H,H,H,H,H,B,H,H,B,B,B,B,H,H,H,H,H,A,A,A,A,A,H 75.383,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,H,H,A,A,A,A,H,A,A,A,A,A,A,A,H,H,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,B,H,H,H,H,B,B,H,-,H,H,H,H,H,B,B,B,B,B,B,H,-,A,A,A,H,H,H,H,A,H,H,H,H,H,B,H,H,H,H,-,A,A,A,A,A,A,-,A,A,-,A,H,B,B,H,H,H,H,B,B,B,B,B,B,B,H,H,H,H,B,B,B,B,B,A,A,H,H,H,C,A,A 84.35,H,H,H,H,A,A,A,A,A,A,A,A,A,H,H,H,H,-,H,A,H,B,B,B,B,H,H,B,B,A,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,-,H,H,H,H,H,H,H,H,A,A,H,-,-,H,H,A,A,A,A,A,B,B,H,H,H,A,A,A,A,A,A,H,A,A,-,A,A,A,A,A,A,-,A,H,A,B,B,B,B,B,B,B,B,B,B,-,H,H,H,H,H,B,B,B,B,B,H,H,A,H,H,C,A,A 97.667,B,B,B,B,B,B,B,B,H,H,H,H,H,H,B,H,H,H,H,H,H,B,B,B,B,H,H,H,B,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,B,B,B,B,B,H,H,H,H,-,B,B,H,H,B,B,B,B,B,B,B,B,A,H,H,A,A,A,A,C,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,A,A,B,H,H,C,A,A 97.783,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,H,H,H,H,-,B,A,A,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,B,-,A,A,H,-,-,A,A,A,A,A,H,H,B,B,B,B,B,A,B,B,H,H,H,H,A,A,-,H,H,H,-,H,H,H,H,H,A,A,A,A,B,B,B,B,B,B,B,H,H,H,H,A,B,B,H,H,H,H,H,H,A,A,A,A,A,- 264,H,H,H,H,B,B,B,B,B,B,H,H,H,B,B,B,B,B,B,H,H,B,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,A,-,A,A,A,A,A,A,B,B,B,B,H,A,H,H,H,H,H,A,A,A,A,A,-,A,A,B,B,B,H,H,H,H,H,H,H,H,H,A,A,A,A,H,C,B,B,B,B,B,B,B,H,-,H,H,H,H,H,A,-,H,H,H,H,H,H,B,B,B,B,B,H,H,H,A,H,H,H,H,B,A,A,A,H,H 90.433,H,H,H,H,H,H,A,A,A,A,H,H,H,A,A,A,A,A,A,H,H,A,A,A,A,B,B,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,H,A,A,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,A,A,H,H,H,B,A,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,B,H,A,A,A,C,A,-,B,B,B,B,B,B,B,B,B,A,A,A,H,-,B,B,B,B,B,H,-,A,H,H,B,H,H,H,H,H,H,H,H,B,B,B,C,H,H 264,A,A,H,H,H,H,H,H,A,A,A,A,A,-,A,H,H,H,H,A,H,H,H,H,H,B,-,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,H,H,H,H,-,B,B,B,-,-,H,H,A,A,H,H,B,A,A,A,H,H,H,H,A,H,H,H,B,C,B,B,B,B,B,B,B,B,B,B,B,H,H,A,H,H,-,A,A,A,A,A,A,A,A,A,H,H,H,H,B,B,B,-,B,H,H,A,A,H,H 90.05,H,H,H,B,B,B,B,B,H,H,H,H,H,B,B,B,B,-,B,A,A,A,B,B,B,H,H,H,B,H,H,H,H,-,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,A,A,A,A,A,A,B,B,B,H,-,H,H,A,H,H,H,H,A,A,-,A,A,A,B,B,B,B,B,B,A,A,-,A,A,A,A,A,A,-,H,H,H,H,H,H,H,-,H,H,B,B,B,B,A,A,H,H,H,H,A,A,H,H,-,H,B,H,H,C,A,A 90.083,H,H,H,H,H,H,H,H,H,H,-,H,H,B,H,H,-,H,H,B,H,H,H,H,H,B,-,B,B,H,B,B,B,B,B,B,B,B,H,H,-,H,B,H,H,H,H,H,H,H,H,H,A,A,A,H,H,H,-,B,-,H,H,H,H,H,-,B,B,B,B,-,B,B,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,C,H,A,A,A,A,A,A,A,A,A,A,H,H,B,B,H,-,B,B,B,H,H,B,B,H,H,H,A,H,H,H,B,B,B,B,H,A,H,C,A,A 90.117,H,H,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,B,B,H,B,B,B,B,B,H,B,B,B,B,B,B,B,B,B,B,B,H,H,H,-,H,H,A,A,A,A,A,A,A,A,A,H,H,H,H,A,A,A,A,-,H,H,H,B,B,B,B,B,H,H,-,A,A,A,A,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,A,A,A,A,A,A,A,A,A,A,A,A,H,-,B,B,H,-,H,H,A,A,A,A,H,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,H,H 264,A,A,A,A,A,A,H,H,B,B,B,B,B,H,B,B,-,H,H,B,H,H,B,B,B,A,A,H,B,A,H,A,A,A,A,A,A,A,A,A,-,A,A,A,A,H,B,B,B,B,B,B,B,B,B,H,H,H,-,H,-,B,B,B,H,A,A,H,H,B,B,-,H,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,B,B,B,C,H,H,H,H,H,H,H,H,-,H,B,H,-,H,H,H,-,H,H,H,H,A,A,B,B,B,B,B,H,H,A,H,H,H,H,A,A,A,C,H,H 71.967,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,H,H,H,H,A,A,A,B,-,H,A,A,A,A,H,H,H,B,B,-,H,B,B,H,H,H,H,H,H,H,H,H,H,H,A,A,H,-,H,-,H,H,H,H,H,-,H,H,H,H,-,H,H,H,B,B,B,B,A,H,H,H,H,H,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,-,A,A,A,-,H,H,B,-,B,B,B,B,-,-,H,H,H,H,H,H,H,H,A,A,A,A,H,H,B,C,H,A 264,H,H,H,H,H,H,H,H,H,H,H,-,H,H,H,B,-,H,H,H,B,B,B,H,H,B,H,H,H,A,H,A,A,A,A,A,A,A,A,H,-,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,-,B,-,B,H,B,B,B,B,B,B,H,H,H,H,-,B,B,H,H,H,A,H,B,H,A,A,A,A,B,B,-,B,B,B,C,H,A,A,A,A,A,A,A,A,A,A,B,B,H,H,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,C,H,A NA,B,B,B,B,B,B,H,H,A,A,A,A,A,H,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,-,B,B,B,B,B,H,H,H,H,B,H,H,-,A,A,A,A,A,-,A,H,H,B,B,B,B,H,H,H,A,A,A,C,B,B,B,B,B,H,H,H,H,H,H,B,B,B,H,A,H,-,H,H,H,-,-,A,H,H,H,H,B,B,B,A,A,H,H,H,H,H,C,H,H 264,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,-,H,H,H,A,A,A,A,H,A,B,B,H,H,B,B,B,B,B,B,-,B,B,B,B,B,H,H,H,H,H,H,-,H,H,B,B,B,B,H,H,H,H,B,B,H,H,H,H,H,-,A,A,H,-,H,H,H,H,H,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,C,B,B,B,B,B,B,B,B,B,B,B,-,H,H,A,A,H,H,A,A,A,A,A,H,B,-,H,H,H,H,B,H,H,H,H,B,B,H,C,A,H 264,-,H,-,H,H,H,H,H,H,H,H,H,H,B,H,H,-,H,H,A,A,H,H,H,B,A,A,H,B,H,H,H,H,H,H,H,H,H,H,H,H,A,B,B,B,B,B,B,-,B,B,B,B,B,B,B,B,H,-,A,A,A,A,A,A,A,A,H,H,H,H,H,A,A,A,A,A,A,A,H,H,H,H,H,B,H,H,A,A,A,A,A,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,A,H,H,-,A,H,B,B,C,H,H 74.267,B,B,H,H,H,H,A,A,A,A,A,A,A,H,A,A,-,H,H,A,A,H,H,H,H,B,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,-,A,A,A,A,A,A,B,H,H,H,B,H,H,H,-,H,H,H,A,A,H,H,H,H,H,H,H,A,A,A,H,H,H,H,H,B,B,B,B,B,H,H,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,B,H,H,H,H,H,H,H,H,B,B,H,H,H,H,H,H,A,A,A,A,A,A,A,C,H,H NA,-,H,A,A,H,H,H,H,H,H,H,H,H,B,B,B,-,A,A,A,A,A,A,A,A,H,H,B,H,-,H,A,A,A,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,B,B,-,A,A,A,A,A,A,A,H,B,B,H,H,H,H,H,B,B,H,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,H,H,B,B,B,B,B,B,B,B,B,H,A,A,H,H,H,A,H,H,H,H,A,H,B,C,A,H NA,H,H,H,H,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,B,B,B,H,A,A,A,A,A,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,H,H,A,B,B,B,B,B,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,H,H,H,H,H,H,A,A,A,H,B,H,H,H,H,H,H,B,H,H,A,A,A,A 264,-,H,H,B,B,B,B,B,B,B,B,B,B,H,H,-,A,H,H,H,A,A,A,H,H,A,A,H,B,-,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,B,B,H,A,A,A,H,H,H,B,B,B,H,B,B,B,B,B,B,B,B,B,H,A,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,H,H,H,H,H,H,A,H,H,H,B,B,B,H,H,H,A,A,H,H,H,C,H,A 264,A,A,H,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,B,H,H,H,B,H,H,H,H,B,H,A,H,H,H,B,B,C,H,B,B,B,H,H,H,H,H,H,H,A,H,H,B,A,A,A,A,A,A,A,-,H,A,A,H,H,B,B,B,B,B,A,A,A,A,A,A,H,H 264,A,A,A,H,H,H,H,H,A,A,A,A,A,B,H,H,H,H,H,B,B,B,H,H,H,H,-,B,H,B,H,A,A,A,A,A,A,A,A,A,A,A,H,H,H,B,B,B,B,B,B,B,B,B,B,A,H,H,-,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,H,H,H,B,B,H,H,H,H,H,H,H,H,H,H,C,H,A,A,A,A,-,A,A,A,A,A,H,H,H,A,H,B,B,B,B,B,B,B,H,H,H,A,A,A,A,H,B,B,B,B,B,B,B,C,H,H 109.867,H,H,B,-,H,B,B,B,B,B,B,B,B,A,H,H,H,H,H,H,B,B,B,H,H,H,H,H,B,B,B,B,B,B,B,B,B,B,H,H,H,H,-,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,B,H,H,H,B,H,H,H,-,H,H,H,B,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,H,H,A,A,A,H,H,H,H,H,H,H,B,B,H,H,B,B,B,B,H,A,A,A,A,H,H,H,C,H,A 264,B,B,A,A,A,A,A,A,A,A,A,A,A,H,A,A,H,H,H,A,A,A,A,A,A,A,A,A,A,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,B,B,B,B,B,A,H,H,-,B,H,H,H,H,H,H,H,A,A,A,A,A,A,H,H,H,H,H,H,B,B,B,-,B,B,H,H,A,A,A,A,C,H,B,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,A,H,H,A,A,B,H,H,A,A,A,A,H,H,H,H,A,H,H 264,H,H,H,H,H,H,H,H,B,B,B,B,B,H,H,H,B,B,B,H,A,A,H,H,H,B,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,B,B,B,H,H,H,A,A,A,A,A,A,A,A,B,B,H,H,A,A,H,H,H,H,H,A,A,A,A,H,H,H,A,A,H,H,H,H,H,A,A,A,A,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,A,A,A,B,H,H,H,H,H,H,A,B,B,B,H,B,B,H,H,A,A,A,A,A,H,B,C,A,A 96.017,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,H,H,H,B,B,H,A,H,H,H,H,H,H,H,H,H,H,H,-,H,H,B,B,B,B,B,B,B,B,B,H,H,H,H,A,A,-,H,H,H,H,H,H,B,B,H,H,H,H,B,B,B,A,H,H,H,H,A,H,H,B,B,H,B,B,H,H,H,A,A,A,A,A,A,A,-,A,A,-,A,A,H,H,H,A,B,-,B,B,B,B,-,H,A,H,H,H,A,B,B,B,H,H,H,H,B,B,B,C,A,A 136.417,H,H,H,H,H,H,B,B,H,H,H,H,H,B,B,B,A,A,A,H,A,A,A,A,H,H,-,H,H,B,B,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,B,B,H,A,A,A,H,H,-,H,A,-,A,A,A,A,A,A,A,A,A,A,A,A,H,H,B,B,B,B,H,H,H,H,H,H,C,H,H,H,H,H,H,H,H,H,H,H,A,H,H,H,B,B,B,B,B,B,H,H,H,B,H,H,H,H,H,B,H,H,H,H,A,A,A,A,A,A 168.25,H,H,B,B,B,B,B,B,B,B,B,H,H,B,A,A,A,A,A,H,A,H,H,H,H,H,H,H,H,B,H,A,A,A,A,A,A,A,A,A,-,A,H,H,H,H,H,H,H,H,H,H,H,H,H,A,A,A,-,H,H,H,H,A,A,A,A,H,H,H,B,B,B,B,H,H,H,H,H,B,A,A,A,A,A,B,B,H,H,H,B,C,B,-,A,B,A,-,A,A,-,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,B,B,B,B,H,H,H,H,A,B,B,C,A,A 120.7,A,A,A,H,A,H,B,B,B,B,B,B,B,H,B,H,H,A,A,H,H,H,B,H,H,A,A,A,B,H,H,B,B,B,B,B,B,B,B,B,B,B,A,A,A,A,A,A,A,A,A,A,A,A,H,A,A,H,-,H,B,A,A,A,A,A,H,H,H,H,H,H,H,B,H,A,A,A,A,H,H,H,A,A,H,B,B,B,B,B,B,C,-,H,H,H,H,H,H,H,-,H,H,H,H,H,H,-,-,H,H,H,H,H,H,B,B,A,A,A,A,A,A,A,A,A,A,H,H,B,C,A,H 114.55,B,B,B,B,B,B,H,H,H,H,H,H,B,H,H,H,H,A,A,H,A,A,A,A,H,B,-,B,H,H,H,H,H,H,H,H,H,H,H,H,-,B,H,H,H,H,H,H,H,H,H,H,H,H,H,B,B,B,-,H,H,A,A,A,A,A,H,B,B,B,H,H,H,H,A,A,H,B,B,A,A,H,H,H,H,H,H,H,H,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,H,A,A,-,-,B,B,B,B,-,B,B,B,B,H,A,B,B,B,H,B,B,B,H,H,H,C,H,A 94.033,A,A,H,A,H,H,B,B,B,B,B,B,B,H,H,H,A,A,A,H,H,A,A,A,A,B,B,B,A,B,B,B,B,B,B,B,B,B,B,B,B,B,H,H,H,H,H,H,H,H,H,H,H,H,H,A,H,H,-,H,H,H,H,H,A,A,H,H,H,H,H,H,H,H,A,A,A,A,A,H,H,A,A,A,A,A,A,A,A,H,B,A,-,A,A,A,A,A,A,A,A,A,A,A,A,A,A,H,-,H,H,H,H,H,A,A,A,A,A,B,H,H,H,A,A,H,H,A,A,A,C,A,A 67.683,H,H,H,H,H,H,H,A,A,A,A,H,H,H,H,H,H,H,H,H,H,A,A,A,A,B,B,B,H,A,H,H,H,H,H,B,B,B,B,B,-,B,B,H,H,H,A,A,A,A,A,A,A,A,H,B,-,H,-,H,H,H,H,H,B,B,-,B,B,H,H,H,A,A,A,A,A,A,A,H,H,A,A,A,H,H,H,B,B,H,H,C,H,H,H,-,H,H,A,A,A,A,A,B,B,B,B,B,B,B,B,B,B,H,H,A,A,A,A,B,B,B,H,H,H,H,B,H,A,H,C,A,H 93.833,A,A,-,H,H,H,A,A,A,A,A,A,H,H,H,H,H,H,H,A,-,-,A,A,-,-,-,-,B,H,H,H,H,H,H,H,-,H,H,H,-,H,H,-,H,H,H,-,-,H,H,-,H,H,H,-,B,B,B,B,-,H,H,H,-,H,H,A,A,H,-,H,-,-,H,-,A,A,A,-,H,-,-,A,H,-,-,A,A,-,A,C,H,H,-,-,H,H,A,A,-,A,-,-,A,A,-,A,A,H,-,H,H,H,-,-,A,-,-,-,-,-,B,-,H,A,A,-,-,-,-,A,A 93.867,H,H,-,H,H,H,H,H,H,H,H,A,A,H,H,B,B,H,H,B,-,-,A,A,-,-,-,-,A,H,H,H,H,H,H,H,-,H,H,H,-,H,H,-,H,H,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,A,A,A,-,H,B,A,A,A,-,A,-,-,H,-,B,B,B,-,B,-,-,H,H,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,A,-,H,H,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,-,B,-,B,H,H,-,-,-,-,A,H 139.867,-,H,-,H,H,H,H,H,H,H,H,B,B,H,A,A,A,A,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,H,H,H,-,H,H,H,-,B,H,-,H,H,H,-,-,H,H,-,A,A,A,-,B,H,-,H,-,B,B,H,-,H,H,H,-,H,-,H,-,-,H,-,H,H,H,-,H,H,-,H,A,-,-,B,B,-,H,A,A,A,-,-,A,A,A,A,A,A,A,-,B,B,-,A,A,A,-,A,A,H,-,-,B,-,-,-,-,-,H,-,A,A,A,-,-,-,-,A,A 117.933,-,H,-,H,A,A,A,A,A,A,A,-,A,H,A,H,H,H,H,H,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,B,-,B,B,B,-,B,A,-,A,A,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,H,H,H,-,-,H,H,H,H,-,A,-,-,H,-,H,H,H,-,B,B,-,B,B,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,B,-,H,H,-,A,A,A,-,A,A,A,-,-,A,-,-,-,-,B,B,-,H,B,B,-,-,-,-,A,A 77.8,-,H,-,B,B,B,B,B,B,H,H,H,H,H,H,A,H,H,B,H,-,-,H,H,-,-,-,-,A,B,B,B,B,B,B,B,-,H,H,H,-,A,A,-,H,H,A,-,-,A,A,-,A,A,A,-,B,H,H,H,-,A,A,H,-,H,A,B,-,B,-,B,-,-,A,-,H,H,H,-,B,B,-,B,B,-,-,H,H,-,H,A,A,A,-,-,A,A,A,A,A,A,A,-,B,B,-,H,H,H,-,A,A,A,-,-,A,-,-,-,-,-,A,-,H,H,H,-,-,-,-,A,H 117.833,H,H,-,H,H,-,H,H,H,H,-,H,H,B,B,H,B,B,H,H,-,-,A,A,-,-,-,-,H,A,H,H,H,H,H,H,-,H,H,H,-,H,H,-,B,B,B,-,-,H,H,-,H,H,H,-,A,-,A,A,-,B,B,B,-,B,B,H,-,A,-,H,-,-,B,-,H,H,H,-,H,H,-,A,A,-,-,H,-,-,H,A,A,A,-,-,A,A,A,A,A,A,H,-,H,H,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,A,-,-,B,B,-,-,-,-,A,H 264,-,A,-,H,H,-,H,H,H,H,H,B,B,H,B,B,B,B,B,H,-,-,H,H,-,-,-,-,B,H,H,H,H,H,H,H,-,H,A,A,-,A,H,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,H,A,-,B,B,B,-,B,B,A,H,H,-,B,-,-,B,-,A,H,H,-,H,-,-,H,H,-,-,B,B,-,B,A,A,H,-,-,H,H,H,H,H,-,H,-,A,A,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,B,-,A,H,H,-,-,-,-,H,H 77.733,-,H,-,H,H,H,H,H,H,H,H,H,H,A,A,H,H,H,H,H,-,-,H,H,-,-,-,-,H,B,B,B,B,B,B,B,-,B,B,B,-,A,H,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,-,H,-,B,B,B,-,H,H,H,H,H,-,B,-,-,H,-,H,B,H,-,A,A,-,A,-,-,-,H,H,-,A,C,H,H,-,-,A,A,A,A,-,A,H,-,H,H,-,H,H,H,-,H,H,H,-,-,B,-,-,-,-,A,H,-,A,A,A,-,-,-,-,H,- 93.183,-,B,-,H,A,A,H,H,H,H,H,H,H,H,A,A,H,H,H,A,-,-,H,H,-,-,-,-,B,B,-,B,B,B,B,H,-,H,H,H,-,B,B,-,B,B,B,-,-,B,B,-,H,H,H,-,H,B,B,H,-,H,H,B,-,-,B,A,-,H,-,H,-,-,H,-,B,A,A,-,A,A,-,A,H,-,-,H,B,-,H,A,A,A,-,-,A,A,A,A,-,A,A,-,B,-,-,H,H,H,-,H,H,H,-,-,A,-,-,-,-,-,B,-,A,A,A,-,-,-,-,H,A 77.633,B,B,-,A,A,A,A,A,A,A,-,A,A,H,H,H,H,H,H,A,-,-,A,A,-,-,-,-,H,H,-,H,H,H,H,H,-,H,H,H,-,H,A,-,A,A,A,-,-,A,A,-,H,H,H,-,A,A,A,H,-,A,-,A,-,A,A,B,B,B,-,B,-,-,B,-,H,H,B,-,H,H,-,H,H,-,-,H,H,-,A,C,H,H,-,-,H,H,H,H,H,H,A,-,A,-,-,B,B,B,-,B,B,B,-,-,A,-,-,-,-,A,A,-,H,H,H,-,-,-,-,A,A 77.55,A,A,-,H,H,H,A,A,A,A,A,A,A,H,B,B,H,H,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,H,H,H,-,H,H,H,-,A,B,-,B,H,H,-,-,H,H,-,H,H,H,-,H,H,B,B,-,B,B,B,-,B,B,H,-,H,-,H,-,-,H,-,H,H,H,-,B,-,-,H,A,-,-,H,H,-,H,C,H,H,-,-,A,A,A,A,A,A,A,-,H,H,-,H,H,A,-,A,A,A,-,-,A,-,-,-,-,H,H,-,H,H,B,-,-,-,-,A,A 264,A,A,-,H,H,H,H,H,B,B,B,-,H,H,H,A,A,A,A,A,-,-,H,H,-,-,-,-,H,H,-,A,A,A,A,A,-,A,H,H,-,H,B,-,H,A,A,-,-,-,A,-,A,A,A,-,B,A,-,A,-,B,B,B,-,B,A,A,-,A,-,H,-,-,H,-,A,-,A,-,H,B,-,B,-,-,-,B,-,-,A,C,H,H,-,-,B,B,B,B,B,B,B,-,H,H,-,H,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,H,-,H,-,-,-,-,A,A 117.433,-,B,B,B,B,H,H,H,H,H,A,A,A,A,H,H,B,B,B,H,-,-,B,B,-,-,-,-,A,H,H,H,H,A,A,A,-,A,A,A,-,H,A,-,A,A,A,-,-,H,H,-,H,H,H,-,H,A,A,A,-,H,H,H,-,H,H,A,A,A,-,A,-,-,B,-,B,B,B,-,H,H,-,A,H,-,-,A,A,-,A,C,H,H,-,-,H,H,H,H,H,H,H,-,H,-,-,H,H,H,-,H,H,A,-,-,A,-,-,-,-,H,A,-,B,H,H,-,-,-,-,A,A 93.067,B,B,B,H,H,H,B,B,H,H,H,H,H,H,H,H,A,A,A,H,-,-,A,H,-,-,-,-,A,B,B,B,B,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,H,H,-,H,H,H,-,B,H,H,H,-,H,H,B,-,B,B,B,A,H,-,H,-,-,H,-,A,-,A,-,H,H,-,H,B,-,-,A,A,-,H,C,H,H,-,-,H,B,B,B,-,B,B,-,H,H,-,H,B,B,-,B,B,B,-,-,H,-,-,-,-,-,B,-,B,B,B,-,-,-,-,A,H 99.867,-,H,-,H,H,H,A,A,A,A,A,A,A,B,B,B,B,B,A,A,-,-,B,B,-,-,-,-,A,A,A,A,H,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,A,A,H,-,B,B,B,B,B,-,B,-,-,H,-,A,A,A,-,H,H,-,H,A,-,-,A,A,-,H,C,H,A,-,-,A,A,A,A,-,A,A,-,B,B,-,A,A,A,-,H,H,H,-,-,B,-,-,-,-,H,H,-,H,H,H,-,-,-,-,H,H 82.333,A,H,-,B,A,A,A,A,A,A,A,A,A,B,B,B,B,B,B,A,-,-,A,A,-,-,-,-,B,B,B,B,B,B,B,B,-,B,B,B,-,B,H,-,H,H,H,-,-,A,A,-,A,A,A,-,B,H,A,A,-,H,-,H,-,A,A,H,H,H,-,H,-,-,A,-,H,B,H,-,H,-,-,H,A,-,-,H,H,-,H,C,H,A,-,-,A,A,A,A,-,A,A,-,H,H,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,H,H,-,H,B,B,-,-,-,-,H,H 163.75,B,B,B,B,H,H,A,A,H,H,H,H,H,B,H,H,H,H,H,H,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,A,-,A,A,A,-,A,A,-,A,A,A,-,-,A,A,-,A,A,A,-,H,H,-,H,-,B,B,B,-,B,H,H,B,B,-,B,-,-,B,-,H,H,H,-,H,H,-,H,H,-,-,H,H,-,B,C,H,H,-,-,A,A,A,A,A,A,A,-,B,H,-,H,H,H,-,-,H,H,-,-,B,-,-,-,-,A,A,-,B,B,B,-,-,-,-,A,H 82.017,B,B,B,H,H,B,B,B,B,B,B,B,B,H,H,H,A,A,A,A,-,-,-,H,-,-,-,-,H,H,-,B,B,B,B,B,-,B,B,B,-,B,H,-,H,H,H,-,-,B,B,-,B,B,B,-,H,A,A,A,-,A,A,A,-,H,H,H,H,B,-,B,-,-,B,-,A,A,H,-,H,H,-,A,A,-,-,A,A,-,H,A,A,A,-,-,A,H,H,H,H,H,H,-,A,A,-,A,H,H,-,H,H,H,-,-,H,-,-,-,-,B,A,-,H,H,H,-,-,-,-,A,A 264,H,H,B,B,B,B,H,H,H,H,H,H,H,H,B,B,B,H,H,B,-,-,H,H,-,-,-,-,A,B,B,A,A,A,A,A,-,A,A,A,-,H,B,-,B,B,H,-,-,H,H,-,A,A,A,-,H,H,B,B,-,A,A,A,-,A,H,H,H,B,-,B,-,-,A,-,B,B,B,-,B,B,-,B,B,-,-,B,B,-,B,C,H,H,-,-,H,H,H,H,H,H,H,-,A,A,-,B,B,B,-,B,B,B,-,-,H,-,-,-,-,H,-,-,B,H,H,-,-,-,-,A,A 264,A,A,-,H,B,B,B,B,B,B,-,B,B,B,B,B,B,B,B,A,-,-,H,H,-,-,-,-,H,A,A,A,A,A,A,A,-,A,H,H,-,H,B,-,H,H,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,B,B,H,-,H,H,H,-,H,-,A,-,-,H,-,H,-,H,-,H,H,-,H,H,-,-,H,-,-,B,C,H,H,-,-,B,B,B,B,B,B,B,-,H,-,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,-,H,-,H,H,H,-,-,-,-,A,A 91.283,B,B,-,-,A,A,A,A,A,A,H,H,H,H,A,A,H,H,H,H,-,-,H,H,-,-,-,-,B,H,H,H,H,H,H,H,-,H,H,H,-,H,B,-,B,B,B,-,-,B,B,-,B,B,B,-,H,-,A,H,-,H,H,H,-,A,H,H,H,H,-,A,-,-,H,-,H,H,H,-,H,H,-,H,H,-,-,B,-,-,B,C,H,H,-,-,A,A,A,A,A,A,A,-,A,A,-,A,A,H,-,H,H,H,-,-,B,-,-,-,-,H,A,-,B,B,B,-,-,-,-,H,H 140.767,H,H,-,H,H,H,H,H,H,H,H,B,B,B,B,H,A,A,A,H,-,-,H,H,-,-,-,-,A,H,H,H,H,H,H,H,-,H,H,H,-,B,A,-,A,A,H,-,-,H,H,-,H,H,H,-,A,A,A,A,-,B,B,B,-,B,B,-,B,B,-,B,-,-,H,-,H,H,H,-,B,B,-,B,-,-,-,H,H,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,B,B,B,-,B,H,H,-,-,B,-,-,-,-,A,H,-,-,H,H,-,-,-,-,H,H 81.733,A,A,-,A,A,A,A,A,A,A,A,A,A,A,H,H,H,H,B,H,-,-,H,H,-,-,-,-,H,B,B,B,B,B,B,-,-,H,H,A,-,A,B,-,H,H,H,-,-,H,H,-,H,H,B,-,H,H,H,H,-,H,H,H,-,H,H,A,A,H,-,H,-,-,A,-,B,-,B,-,H,-,-,H,A,-,-,B,B,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,B,B,B,-,H,H,H,-,-,H,-,-,-,-,H,H,-,A,H,A,-,-,-,-,A,A 75.667,H,H,-,A,A,A,A,A,A,A,A,-,A,A,H,H,B,B,H,H,-,-,-,A,-,-,-,-,A,H,-,H,H,-,B,B,-,B,B,B,-,B,A,-,A,A,H,-,-,-,H,-,H,H,H,-,H,-,B,B,-,A,A,-,-,B,B,H,H,H,-,H,-,-,H,-,H,-,H,-,H,H,-,H,H,-,-,A,A,-,H,C,H,H,-,-,H,H,H,A,-,A,H,-,H,H,-,B,H,H,-,H,H,H,-,-,A,-,-,-,-,A,H,-,H,A,A,-,-,-,-,A,H 76.483,B,B,B,B,B,H,H,H,H,H,H,H,H,B,B,H,H,H,A,H,-,-,A,A,-,-,-,-,A,B,-,H,H,H,H,H,-,H,H,H,-,H,A,-,H,H,H,-,-,-,B,-,B,B,B,-,B,B,-,H,-,A,A,A,-,A,A,B,-,B,-,B,-,-,B,-,A,-,H,-,A,H,-,B,B,-,-,H,H,-,B,A,A,A,-,-,A,A,A,A,H,H,B,-,H,H,-,B,B,B,-,B,B,B,-,-,A,-,-,-,-,A,A,-,H,H,H,-,-,-,-,A,A 116.467,H,H,-,B,B,B,B,B,B,B,H,H,H,H,H,B,B,B,H,H,-,-,H,-,-,-,-,-,B,H,H,A,A,A,A,A,-,A,A,A,-,H,A,-,A,A,A,-,-,H,H,-,H,H,H,-,H,H,H,B,-,A,A,A,-,A,H,B,-,B,-,B,-,-,B,-,H,H,H,-,H,H,-,B,B,-,-,H,H,-,A,A,A,A,-,-,A,A,H,H,H,H,H,-,A,H,-,A,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,B,B,B,-,-,-,-,A,A 116.517,A,A,-,B,B,B,B,B,B,B,B,H,H,H,H,B,H,H,H,H,-,-,H,H,-,-,-,-,A,B,B,B,B,B,B,B,-,B,H,H,-,H,B,-,B,H,H,-,-,H,H,-,H,H,H,-,A,A,-,H,-,B,B,H,-,H,H,A,-,A,-,A,-,-,A,-,H,-,H,-,H,H,-,B,B,-,-,H,H,-,H,C,H,H,-,-,H,-,H,H,-,H,H,-,A,A,-,H,A,A,-,A,A,A,-,-,H,-,-,-,-,-,H,-,H,A,A,-,-,-,-,A,H 139.55,H,H,B,B,B,B,B,B,H,H,H,H,H,A,A,A,H,H,H,H,-,-,H,H,-,-,-,-,H,H,H,H,H,-,H,H,-,H,H,B,-,B,H,-,H,A,H,-,-,H,H,-,H,H,H,-,H,H,H,H,-,H,H,H,-,H,H,H,H,H,-,A,-,-,H,-,H,H,H,-,H,H,-,B,H,-,-,H,-,-,A,C,H,A,-,-,A,A,H,H,H,H,H,-,H,H,-,A,A,A,-,A,A,A,-,-,H,-,-,-,-,B,H,-,H,H,B,-,-,-,-,H,H 264,A,A,-,A,A,A,A,A,A,A,A,A,A,B,B,H,H,H,H,B,-,-,H,H,-,-,-,-,H,B,B,H,H,H,H,H,-,H,H,H,-,H,B,-,B,B,B,-,-,B,B,-,H,H,H,-,A,B,B,B,-,H,H,A,-,H,H,B,B,B,-,B,-,-,H,-,B,-,B,-,H,H,-,H,H,-,-,B,B,-,H,C,H,H,-,-,H,H,H,H,H,H,H,-,H,H,-,H,H,H,-,H,H,H,-,-,H,-,-,-,-,B,B,-,H,H,H,-,-,-,-,H,A 116.2,A,A,-,H,H,H,H,H,H,H,H,A,A,A,H,H,H,A,A,H,-,-,H,B,-,-,-,-,H,H,H,H,H,H,H,H,-,B,B,-,-,B,H,-,H,H,A,-,-,A,A,-,A,A,A,-,A,H,H,H,-,H,H,A,-,H,H,A,A,A,-,A,-,-,H,-,H,-,H,-,H,B,-,B,B,-,-,H,H,-,B,C,H,H,-,-,H,H,H,H,H,H,H,-,B,B,-,H,H,H,-,B,B,B,-,-,H,-,-,-,-,H,B,-,H,H,H,-,-,-,-,A,A qtl/MD50000644000176200001440000010371014661520123011364 0ustar liggesusersec7c2155ac4ffeb0d4a92d1bf61062ce *DESCRIPTION 62828318221a847e7f41b6d51f00b703 *NAMESPACE e17940ba90a31acaf55227394cc9057c *NEWS.md be09adead3e7ef2c4a141178391fde75 *R/add.cim.covar.R b28895ea5226f6e156ef723ad8e4e731 *R/add_threshold.R e96452b91bdba02c6ab9af6ee9f7c4f6 *R/addmarker.R ae265237376977b9db463c71da99f60b *R/addqtl.R ced11f727f3d1eb662ad0517f029671f *R/argmax.geno.R 2340f2602a8b6258e48e8b167368ed3e *R/arithscan.R 002ddfebeedb22fee1e40842ce6c6d35 *R/bcsft.R 9a14a20468f7ab3183aee675bfd97eb4 *R/calc.genoprob.R a40a1704d82bfd8130bd8b88017d4c6e *R/calc.pairprob.R 9aab668013c4fe2cfd10f0c180846861 *R/cim.R d6c7261007d45b195229986396803847 *R/comparegeno.R ed3f6b1e8c227f2d9d9642baf4fb7f44 *R/compareorder.R 65f5bc3288a0edfad6fee76dea2532f8 *R/countXO.R 1a4e09d94b07cb64552c37054a50cc2a *R/discan.R a52ecd97ebd99ce802473e033098efa8 *R/droponemarker.R 885689db4663ad488a732ae22f712b24 *R/effectplot.R 0a2465a4c503a372f34f196185259bf0 *R/effectscan.R 473d0d17130b61deb87ee07206b8b6e2 *R/errorlod.R ccc50dae423be47359b8bfaa3a021c44 *R/est.map.R 23a2d7055bd7ad23b49717e51481859b *R/est.rf.R 6ef89ab33ddf730196accaff242318f9 *R/find_large_intervals.R 6fbab3a9c9e017a60fcf1f9b19bded3a *R/fitqtl.R aa399e34a9fa02dac1951f09c2caaa55 *R/fitstahl.R b44aa39fb0dc4cbcc086446454efcb65 *R/inferFounderHap.R 80f7c7c13c5047af9d33d3d24a485af3 *R/interpPositions.R 4b90e8e614bd3c4f8b65fb8e2e473005 *R/makeqtl.R 3a3f477add5d088a115b14ed5b48881e *R/map_construction.R 8f650676e1017bce37bf6675d4fe94f3 *R/markerlrt.R 1ad9e857df2c7ddceef72fa938cc1e69 *R/mqmaugment.R e1d3a067e5f92936bff859684e77b6c9 *R/mqmcircleplot.R 09f530a3d237d51e8bc8cf05b651ff04 *R/mqmcofactors.R 1602041dd3ac0fa1b9ba9b0dabac974c *R/mqmpermutation.R 1cdf579386990693ad14304d6574f1bf *R/mqmplots.R fc2bb78eeac87f305b27eac966b00b7f *R/mqmprepare.R 2a6201dd3d17414f02de5e8410b9fd7e *R/mqmscan.R 09b153f8183f466fcf009cca509271e2 *R/mqmscanall.R d25399c3429a884d260c04b3b7e7205d *R/mqmsnow.R 5659dadd9ec5b97b9b9b79abe017e944 *R/mqmutil.R fc27653b667d12070cdfc3271d060b1f *R/phyloqtl_scan.R 5c8e17565630ec6c23ae9564a392138d *R/phyloqtl_sim.R 23028fc0a1b8c35acb1e76cac2771a4f *R/phyloqtl_util.R 0655588ac137705ab9cf98f3d4e55590 *R/pickMarkerSubset.R ec81c87d60c8761798cb3263745d4614 *R/plot.R 77edfb6a7537fb0ca178cd725fb9b918 *R/plot.scanone.R d375402e8a058b6bbeeb4ff5299c9e6d *R/plot.scantwo.R 75df93c9e5d8b0180a5dd69ac75ac27e *R/plotModel.R 39e3d5edecc6762bb3dc9d537c4f62db *R/plotperm.R 315c570abfdeaa81cb35c6308463324b *R/pull_stuff.R 80dd7a1472e76906ddb59135e677dcc9 *R/qtlcart_io.R fe1a1baaf5dee2677e21e5a32f1759b6 *R/read.cross.R 6228b7f5b70502771c16f715cf1a7793 *R/read.cross.csv.R ffd11fa4ca3eacb4164e8ccb71cde066 *R/read.cross.csvs.R 1df2c27d80791a021df9cbfb03ddf31b *R/read.cross.gary.R c7533ed3d1776c9cda6cd06f01a3df75 *R/read.cross.karl.R 283f153d2fa002187eea066243ef0dfb *R/read.cross.mm.R a2fdb3cd04bce83448422274a26f3041 *R/read.cross.mq.R 6974001375f68b4aab8eb1abaeb26b87 *R/read.cross.qtx.R dbb0fa2ec0cc698b50702c5abd469728 *R/read.cross.tidy.R 5e9ec5e3e679253bd201ad09738e514f *R/readMWril.R 6b019fcbcc84cc709d048c1767b6917f *R/refineqtl.R 206941298c1ea1a314568bd5219a2e72 *R/replacemap.R 5b374eef35fa29bd0ea949c4be894d34 *R/ril48_reorg.R 58389f4fb02bce5683561e6fe1756c95 *R/ripple.R 29ca7f31679abd1adfbdc2920240b51a *R/scanone.R feca194c570efcfa3be35854df861e4b *R/scanoneboot.R 3a86f33fc459cfdbace4bf4ff09c1bcd *R/scanonevar.R c9a90a6d4eac5826ef4df18389ce24f6 *R/scanonevar.meanperm.R 1f78a55ede531a58a0df6a1d2f386ef5 *R/scanonevar.varperm.R d202475fdb5414415bd82db15ccdcd3b *R/scanqtl.R 49fdc398b1de40aa57a5b5afc57fd124 *R/scantwo.R b23379d4338f38ea8052ad3437e683e2 *R/scantwopermhk.R c564f5e24b346138464cf16491c52a7e *R/sim.geno.R 477a910c5b9f1a3e468207443aefe798 *R/sim_ril.R 5294ad76b17a60a7386033d1c1c561df *R/simulate.R 13556e3d4959cc0e4013bb7629a7511c *R/stepwiseqtl.R 24a640234a26f07e9cca87cd3a8ebb23 *R/stepwiseqtlX.R d82a96e0cb6fef41b4ceb0190a74dab6 *R/summary.cross.R 52224ef3269f9a4fd547d98c17b48db7 *R/summary.scanone.R e5dc28ba49a85c734a503c1b0e2ce47c *R/summary.scantwo.R 46359713b056180eae672649e7b3813a *R/summary.scantwo.old.R c6cd187dda5782475986d51d763ded86 *R/transformPheno.R 091d00be07f8abf6c5745010691b908e *R/tryallpositions.R 2727e18074d5e0509efe0994fd604fa2 *R/util.R 1ce029f5927df7e1f08001129b67e9e4 *R/vbscan.R 7a088a393e967649514591691eb020b4 *R/viridis.R a77efd38e7c69e08c2f71a80ca2056c2 *R/write.cross.R c183ffdf2a1d79b4252fcbaeb9d89807 *R/write.cross.mq.R 715d9d5eb3a8e9b2ddfeee7cd06c58bd *R/write.cross.qtab.R f404008174661ddf0883f62ef3ea5f2b *R/xchr.R aa05ad378ebea88970b04247d082510d *README.md bde22cd0e7bd3e54861eb87549f31981 *build/vignette.rds 481daed56094dea1a93d7fcb02ef9458 *data/badorder.RData e041965545520e82df47349b78d9d864 *data/bristle3.RData 97f11c2d1bde0eb9592b609c2241c7ad *data/bristleX.RData f7fa8ca10290203bae5ef5eee4afde0b *data/fake.4way.RData 720d08785fea31fc056711f12a1a75f1 *data/fake.bc.RData 680e11a0cdbbb221724d142fcca7b314 *data/fake.f2.RData 1400a637a9140ec755a0b667e6332392 *data/hyper.RData a1dc50cbd6674d50bb528dc582d31eee *data/listeria.RData 30d48d1933f1899c6bf065519ea011bc *data/locations.RData 2d1e2defc85afdd9999c128ff6ee08a7 *data/map10.RData 375227e590dac4d5eeabb4288c17b12f *data/mapthis.RData 95e71dec6263cbcb8a1bedaa8293bcde *data/multitrait.RData 61214bbecf3f6af973be7a2a60295c45 *inst/BUGS.txt 77a528c2cbae934c2f285a11ee195b35 *inst/CITATION 3e82fa429953d085e89fb6bf66f0291e *inst/INSTALL_ME.txt c8b990e307ecee343beb5a217265ffcf *inst/MQM-TODO.txt 1723dec70d7b0ed3c1c99e7b7581e948 *inst/contrib/bin/CMakeLists.txt 1e10167bc08e8c501be1ac201247af7d *inst/contrib/bin/FindRLibs.cmake a2151c53575c7e54ceef324add76f356 *inst/contrib/bin/README f300bcbb15db0aa41bfa87e4598ca999 *inst/contrib/bin/mqmdebugout.cpp b7f842cec0ea8e7025a4495586ba4548 *inst/contrib/bin/mqmmain.cpp 872352d722e347e7202db6d5e7208f26 *inst/contrib/bin/regressiontests.bat 72e795393b05712e52d2dfcd013853d2 *inst/contrib/bin/rtest/regression/mqm_listeria1.rtest 1fc00c7595303eb7b28b7c22552e6a32 *inst/contrib/bin/rtest/regression/scanone_mr.rtest 725982f79fa57446b0c29485db932256 *inst/contrib/bin/rtest/test_augmentation.R 200622b9e837aa6daab95d45df5f5c80 *inst/contrib/bin/rtest/test_mqm_hyper_prob.R ff8da1695c81b1bf1fa5ae33b55f89da *inst/contrib/bin/rtest/test_mqm_listeria1.R 277edd7b8d3d18846bcd4c83d2470fda *inst/contrib/bin/rtest/test_scanone_mr.R 106fc8e130e914c8e1921dca34e3a46f *inst/contrib/bin/scripts/cleanup.sh cf3c3279879ff2febff55923a96ba6b8 *inst/contrib/bin/scripts/create-diff.sh 973cc58b4269e7e8301bd45983a93b78 *inst/contrib/bin/scripts/profiler.sh 32d1bc0785a5d50f78ae5756d16e9f43 *inst/contrib/bin/scripts/r.sh f6b6a330299fdb56a874a47f577ebd08 *inst/contrib/bin/scripts/regression_tests.sh 9760ebdd5b902882af0c93ea062e5e96 *inst/contrib/bin/scripts/regression_tests_windows.bat 96a589c2fd23cc2fd5d1ad8eaf425f6e *inst/contrib/bin/test/chrid.dat cd80cecee345e6e4a8f0f4fa565131d9 *inst/contrib/bin/test/chridhyper.txt e476e10cab390697d56bb54e9ad6b435 *inst/contrib/bin/test/cofactors.txt 0e5803c6aa09400ba7cca13fa1d2c9dd *inst/contrib/bin/test/filledgenohyper.txt 446a8d08d0deda48af4367932016e95d *inst/contrib/bin/test/geno.dat 3ba90f4528761f630956a01e28da2d02 *inst/contrib/bin/test/genohyper.txt 48aa9dfa5117e23001cdde5d75e9c681 *inst/contrib/bin/test/markerpos.txt 58e0f70e4a38f89e0ea05200b1485f4c *inst/contrib/bin/test/markerposhyper.txt c8fcff8988bdcad867ab1d623afa53c9 *inst/contrib/bin/test/pheno.dat c8bad11adb4ec06926194513c745d1c8 *inst/contrib/bin/test/phenohyper.txt c73498b52f1d78efb2a60720e8b1c48c *inst/contrib/bin/test/regression/debugout_dnorm.txt 27131c5ce714adebfdd4f986662b53a6 *inst/contrib/bin/test/regression/debugout_pbeta.txt 79cdeca0abdbc0e981163e6203a294dd *inst/contrib/bin/test/regression/t11out-test0.txt db72cd13d6a1e2f81ff68dc4886a1910 *inst/contrib/bin/test/regression/t11out.txt 12edd0259b6630dd1281baf97b2ad7cf *inst/contrib/bin/test/regression/t12out.txt db11ebfe1d7065970b3187888bb20311 *inst/contrib/bin/test/regression/t13out.txt 4d585be836c907068dab6809184492d0 *inst/contrib/bin/test/regression/t21out.txt 93908e9b72560c748f51fc8edda09cb9 *inst/contrib/bin/test/regression/t22out.txt ed93df5f2be805fd389820394cf61221 *inst/contrib/bin/test/regression/t23out.txt 076f23f188360ca130a7c4cf428ef4f6 *inst/contrib/bin/test/regression/t24out.txt 421333f8f1a1a217f66601fa1d2ac8a1 *inst/contrib/bin/test/regression/t25out.txt d3c2546698c6f1a749821630abb0a4d8 *inst/contrib/bin/test/regression/t31out.txt fa97e5f006391c4a0dbdee6f9c8025fc *inst/contrib/bin/test/regression/t32out.txt d8acf152a44ae6e0198b2896f4174dcc *inst/contrib/bin/test/regression/t33out.txt be52b633c566c82bffd9eca8ea0c20c5 *inst/contrib/bin/test/regression/t34out.txt f43319ef224ad76487b64c22b01a6625 *inst/contrib/bin/test/settings.dat e03f233c8e59be66d7f013a8db976f58 *inst/contrib/bin/test/settingshyper.txt 446a8d08d0deda48af4367932016e95d *inst/contrib/bin/test/std/genotypes1.txt fdfed5a596dfe2cfc1c51ef4dbd06b7a *inst/contrib/bin/test/std/genotypes2.txt 3ba90f4528761f630956a01e28da2d02 *inst/contrib/bin/test/std/genotypes2m.txt 2bbf9cf9386f4a96908017107406fcd1 *inst/contrib/bin/test/std/genotypes3.txt d9c37b331ff43e122bf6443188b3826a *inst/contrib/bin/test/std/genotypes3m.txt 48aa9dfa5117e23001cdde5d75e9c681 *inst/contrib/bin/test/std/markers1.txt aaadb868ebb6041f45461a184900e31a *inst/contrib/bin/test/std/markers2.txt 73f35c4f2740b77be7c56adf7c33616d *inst/contrib/bin/test/std/markers3.txt c8fcff8988bdcad867ab1d623afa53c9 *inst/contrib/bin/test/std/phenotypes1.txt c8bad11adb4ec06926194513c745d1c8 *inst/contrib/bin/test/std/phenotypes2.txt 2411a1ba80fdd818d57ab6baad428651 *inst/contrib/bin/test/std/phenotypes3.txt 9a49e2d18c04c38baa91c18c08095c12 *inst/contrib/bin/test/std/settings1.txt d552fec023d3136c84922f940a26d75e *inst/contrib/bin/test/std/settings2.txt 88fc63b4af80b742e159b3d2cbec8b60 *inst/contrib/bin/test/std/settings3.txt c13ea1fd1dbd3322aa0773bb2712d6ab *inst/contrib/bin/test/t11/cofactors.txt 63810466f0b74772939995cff28dbc73 *inst/contrib/bin/test/t12/cofactors.txt 87726298c97c135ec4caaa1d77c4c3d0 *inst/contrib/bin/test/t22/cofactors.txt 9ba0cb2dbebbf849508443e305ad22f8 *inst/contrib/bin/test/t23/cofactors.txt aa492705f6ef171b31d4b95208da2279 *inst/contrib/bin/test/t33/cofactors.txt 4b9c827a80e2681861dc2d41baa7212c *inst/contrib/bin/wincompile.bat 4b07a887cd026fadbcd9f986054f3236 *inst/contrib/biolib/CMakeLists.txt d89ef8ce1e7a097fb859b6f0463a28ee *inst/contrib/biolib/README 73c7b09cfe6ae19cc28961e64ee7d8fd *inst/contrib/scripts/check_rqtl.sh f605130493a82e5e91911de5b6b8b6c1 *inst/contrib/scripts/cleanup.sh 2b3f7306cdc6fb6add972d40a09d7028 *inst/contrib/scripts/install_rqtl.sh 4baff6b3f8629e5d4a5b551a05b2b9f4 *inst/contrib/scripts/repl_inputs.rb 6e30a9820a443a31db0538cf07c06531 *inst/contrib/scripts/run_all_tests.sh 241ab5cd315e17513c395de2703aeec3 *inst/contrib/scripts/update_header.rb c5a2ee3e930b1755c96a48b0ec3d4e98 *inst/doc/Sources/MQM/MQM-tour.R 1211a56d552361b5b08d7da328f4823e *inst/doc/Sources/MQM/MQM-tour.Rnw 3e07376c49316ee529a84518fa9d810e *inst/doc/Sources/MQM/MQM-tour.aux 7a1d78e6cedeeb20b6d1efc0fbfcd480 *inst/doc/Sources/MQM/MQM-tour.dvi 862ff68667b81ad24828ed97feeced5c *inst/doc/Sources/MQM/MQM-tour.log aae9b12b0e7483f95697039886b74ed3 *inst/doc/Sources/MQM/MQM-tour.tex 33c6a39f98c9f6ea383bb7e6120c80d6 *inst/doc/Sources/MQM/SweaveIt.R c1c634bc94ea56778fe387637235901e *inst/doc/Sources/MQM/SweaveIt.Rout 8b9c03961a1f83a3593dd2c4f424f0ee *inst/doc/Sources/MQM/mqm/advantages_Rd.txt 9ae2c3be23d6b18713df99dea771bc74 *inst/doc/Sources/MQM/mqm/advantages_latex.txt e5963995b8306a5709edb4a82d312737 *inst/doc/Sources/MQM/mqm/description.txt f5b5b37278192ed8e6221277182b499b *inst/doc/Sources/MQM/mqm/limitations.txt fe67beb7507899b848f71b812c71fd44 *inst/doc/Sources/MQM/mqm/parallelisation_references.txt 33c48149918dc1bb67bc4dc32941d1d3 *inst/doc/Sources/MQM/mqm/significance_references.txt cbec485f87463463f5920867f8f7852b *inst/doc/Sources/MQM/mqm/standard_example.txt 00c8d3ee12a9126fd90c00fb8236d0d4 *inst/doc/Sources/MQM/mqm/standard_references.txt 93128a9804b2fd0b1be62bdc61506f4a *inst/doc/Sources/MQM/mqm/standard_seealso.txt dce125c0ba08d0504b05baf36296dc94 *inst/doc/Sources/MQM/sweaveit.bat b069721f290cbd45cc9a1d4a13c93603 *inst/doc/Sources/MQM/sweaveit.sh ce27d0a1a38d1c43e3da6accf92df372 *inst/doc/Sources/geneticmaps.Rnw 380f79ca75c5ac3187513d674862dac8 *inst/doc/Sources/new_multiqtl.Rnw 7743409fb09a35b80fb22da863cbea8b *inst/doc/Sources/new_summary_scanone.Rnw 2d06706e91525e0e8f56ca2b2f025636 *inst/doc/Sources/new_summary_scantwo.Rnw 6e5dd7b4462c4d1b74d3dd2da38f5796 *inst/doc/Sources/rqtltour.tex b8f91bbddb0c0dcee45085b0fe945c6f *inst/doc/Sources/rqtltour2.tex f61f48adc17761dab61e5035a6037632 *inst/doc/bcsft.R 504a78535def937ee020d9e8f1de9b55 *inst/doc/bcsft.Rnw 4aaf029f175b862bc695103cfd21e2d0 *inst/doc/bcsft.pdf ccbd21a4f84d3800e3330b0171883b26 *inst/doc/geneticmaps.R f326aab03d4745094152713cca6cbe25 *inst/doc/geneticmaps.pdf 40eb8179441ce7496f6c5e252c8b2b56 *inst/doc/new_multiqtl.R 2bfd394e7e6556f6f7043e9034c64234 *inst/doc/new_multiqtl.pdf b7ee88c6b1ce5df40209c9bd58acf9b8 *inst/doc/new_summary_scanone.R 1e49e4956c20a4fb3554633734be1bbb *inst/doc/new_summary_scanone.pdf a808a0dcf90e74a422bf3ea84f4bd55b *inst/doc/new_summary_scantwo.R 83dbe80c9f5b641b0b269be341c80df2 *inst/doc/new_summary_scantwo.pdf 20f1ad8aeb8fd6c722ed5a3de0885cc8 *inst/doc/rqtltour.R ea3bb90fcd6761ef1a56a26537fc4d4b *inst/doc/rqtltour.pdf ea48cfd7fee328162b3fb49a827f3606 *inst/doc/rqtltour2.R f026652abb778fd9cc577f09f953e084 *inst/doc/rqtltour2.pdf 1b42a662f601adaa9660800eefa4e42f *inst/sampledata/README.txt f6a9eebc3f37d26e0a5b8ed672354712 *inst/sampledata/gen.txt 9198bd35e7a221556c5e2008d00cf84c *inst/sampledata/listeria.csv 846a80e9b730dc4a5144437d1563f0a0 *inst/sampledata/listeria.qtx e064a29e8b8199c38b094b9c8170b434 *inst/sampledata/listeria_gen.csv 2dcca54c31a1e372c6da15881636d2c4 *inst/sampledata/listeria_gen_rot.csv 01b987cb739560eafac3cf41ec0c6154 *inst/sampledata/listeria_map.txt 3bc93e86db600b2f263a1a197269e8de *inst/sampledata/listeria_maps.txt 9bc5c1daf65145ed51a7acf1c30e6146 *inst/sampledata/listeria_phe.csv 216700811ae74ee1d581d7cff9504f05 *inst/sampledata/listeria_phe_rot.csv 3efd61cac8e5cdbba21f04c0d5a56adc *inst/sampledata/listeria_qc_cro.txt a857de8b79fd03837008a0d750dfad9c *inst/sampledata/listeria_qc_map.txt 8520b0234e8d59152126248b0cfa7566 *inst/sampledata/listeria_raw.txt af7100ff129f117e5d3b67cd10a76f63 *inst/sampledata/listeria_rot.csv dde45251d41488fedc3693dc67fc9429 *inst/sampledata/map.txt ffecb0696dd5873a13e48157180271fa *inst/sampledata/phe.txt 5497e8b6b116150c36b4e29f18a54a19 *man/MQM.Rd 189bec661dbf0478b994b82cf16a587e *man/a.starting.point.Rd 46949fdaa1c0c51a9e20860c5a9dc449 *man/add.cim.covar.Rd 8015695b644f9a91488cd8641f7704f5 *man/add.threshold.Rd 252ad8e04f8e6a7ce8dc7f6a680caed2 *man/addcovarint.Rd a5afee5a6681443227a44d37fcb7735e *man/addint.Rd 3c372acd9aa98e43ece06942fcec0b5a *man/addloctocross.Rd f02131d5347ee7c353c7d02d2432770e *man/addmarker.Rd 15829c769d63fd6b6fa0841073bb9514 *man/addpair.Rd 17e910d5933fa719c4c0e922984614aa *man/addqtl.Rd 92c986783681ef09e282f5631cdccd7e *man/addtoqtl.Rd 85fa445627d30bd65f3761f02c5b359e *man/allchrsplits.Rd df729a9fbeadc75df0415d210a6222f0 *man/argmax.geno.Rd a38d7b63bb14c00cd5a67e37d1159d4e *man/arithscan.Rd 32a3eb441513d1cb8fdcbd17d49146e3 *man/arithscanperm.Rd a0a7b6645d5e5f9966aafee19f388719 *man/badorder.Rd 019841b63104738f4c359129391544bf *man/bayesint.Rd 73775ab8daa6094717c97f1f77640768 *man/bristle3.Rd 847712ef573dbe225aee075a48701e3c *man/bristleX.Rd fdb6eff734bbbfd258da0638013d79e3 *man/c.cross.Rd 71a71ff721fe122cc73558a2cef8af47 *man/c.scanone.Rd d9c10fadb7909d4d4e34276b95695189 *man/c.scanoneperm.Rd b4c86dfeca89e79e3362a88cd0e223ec *man/c.scantwo.Rd ae898b84fc1a5daf22d1bbfdc2c1c94e *man/c.scantwoperm.Rd 7bf95c3aaa2f7a0beec1d744e8430dda *man/calc.errorlod.Rd 0558046f084b0e8452d4caa78a264a43 *man/calc.genoprob.Rd 8165f8a092741aedafb7bfffa93b1682 *man/calc.penalties.Rd 8aadba6708e22079251eccb40f24a0ae *man/cbind.scanoneperm.Rd f30f5630beaf6d671dff15195f69bc6d *man/cbind.scantwoperm.Rd 46d5d8d2dfc2f065759e40033cea4182 *man/checkAlleles.Rd b9af71345d58afd2c17534e0a5d6eeef *man/chrlen.Rd 428cccc523bb4c1d0652a5b9bc4a0324 *man/chrnames.Rd 8e4800de61407c628121e608e1da1816 *man/cim.Rd 0ae5cc5df4a84c8e6baae5743f9b0204 *man/clean.cross.Rd 70163f97553c9222e8d7543759e63e1e *man/clean.scantwo.Rd ee627a0a2ba4ce60e121b7f30aaa94f1 *man/cleanGeno.Rd 0a47df637a6af3898843c85e889127b7 *man/comparecrosses.Rd 709e0012a6a36040fd5e46c57a85726b *man/comparegeno.Rd 4f10bc1fde8b243e0ac67733942022e9 *man/compareorder.Rd 89838006533d1d0fdf075774ab51f0f3 *man/condense.scantwo.Rd 90e86820f5ed617279e793d62ccce95b *man/convert.map.Rd 01bc60b39e90f90340bb2fefd938371e *man/convert.scanone.Rd 02de456fa291a35c6c33e84b9bda2a55 *man/convert.scantwo.Rd 7ad72f6f494efe061bf6399c5342eeaa *man/convert2riself.Rd 7b82cadeebfc5adb179b0bf19fe064ca *man/convert2risib.Rd 5d4ac2477f604e97c88a59953929a792 *man/convert2sa.Rd 7ad11e08b13f7f2444deb35379f90870 *man/countXO.Rd 089e113bbc704afee2bc341cd945b698 *man/drop.dupmarkers.Rd 7db2343d4635dd778cc42dbe3d9da7d5 *man/drop.markers.Rd 2f08c1a8493fe68687ab7ab5ebf84e03 *man/drop.nullmarkers.Rd 03ee72ec78dd8f17196c064955aa7bb8 *man/dropfromqtl.Rd 50c0383bc2a1d703f337308beea715f7 *man/droponemarker.Rd 20a1ba2a468712aa6e2cce39906dfc39 *man/effectplot.Rd efe76948b0045fbb3b2a1ec127e0f0cd *man/effectscan.Rd ba754810996dd8a30f86ac801971b80e *man/est.map.Rd 79efffb2eb8b8eb3f6c55758334cad76 *man/est.rf.Rd 4577babbe8a9c70d29866599d8586883 *man/fake.4way.Rd 91581dd93ab36c8336f8ef969601e15f *man/fake.bc.Rd 39aff4c91fee4eff0c6c4ad7c40e9190 *man/fake.f2.Rd 1d78d1ee3a752e6f275cb81b0afaee5a *man/fill.geno.Rd a63955ea854d8dcec0fa40c881663df3 *man/find.flanking.Rd 5242e80a1308e0b5d831bdc58abe27f7 *man/find.marker.Rd 3bf76b62114807c5d8fe98131e9c07e5 *man/find.markerpos.Rd 49955f3579cb744042744f6f20935dfc *man/find.pheno.Rd a984a338f01fb68103a746367e4d7bbd *man/find.pseudomarker.Rd 7ca22668f996fa68f1615eb7dfa00448 *man/findDupMarkers.Rd 45188023457f6f2b44ec032869db564d *man/find_large_intervals.Rd 234a460b06096d1c506ce52bf6f584bc *man/findmarkerindex.Rd a2d8499ad7ac873af6d2ae39bf5c032e *man/fitqtl.Rd 66abbf4225d729c71cec31ad29334818 *man/fitstahl.Rd b7f3bf6e23ddfdd0520e8a5990fa0224 *man/flip.order.Rd 3ca507a6c72895822582d34ef42f40d7 *man/formLinkageGroups.Rd 3883464fd69a13a144e212f120d69e23 *man/formMarkerCovar.Rd ef7cddcaa8a37eec786fce820cc96a81 *man/geno.crosstab.Rd da34f24b7374f4fa0ff518c91f4ea9e0 *man/geno.image.Rd b660d7eb7fa1958cbd9aace60fd677db *man/geno.table.Rd c47cdc5d1da5cf5cb779ce3d49e9047c *man/getid.Rd 52b27da80f2a495ec6bdf48a6591bb86 *man/groupclusteredheatmap.Rd b901337574f9d51818f6d5241ee1a8b9 *man/hyper.Rd 16541e8fd50ba9718b9488b7d5329a07 *man/inferFounderHap.Rd 21313ca281fcaf75ef3966f34c3aa27b *man/inferredpartitions.Rd 63ed607f7863ba2faf432ce6a5c74f24 *man/interpPositions.Rd 44cecef94962ef60e6324ddb71cdf3d9 *man/jittermap.Rd 591e40dfba5b2b4695aef2454b229c30 *man/listeria.Rd bbf8b6728abf335dec63bbe059c22f46 *man/locateXO.Rd 9d9de372d92ba6f26901809e5f109776 *man/locations.Rd b1b8d9cc4fd7f853f8b46fba49df1ec7 *man/lodint.Rd 3a946f642cfac6987d17d5efc3edefaa *man/makeqtl.Rd dfef053eb57a00d2b81d8dbcd1abf274 *man/map10.Rd fbace68f304e4af12f08d02287064f61 *man/map2table.Rd 8693ff72417731ac243b5190f756937f *man/mapthis.Rd ee2e68dc6267b31f3b31486802213cb3 *man/markerlrt.Rd e2a254b4811707a419628e0f5f7486a1 *man/markernames.Rd 618ce46c81b6d97b1577bf3c3357be6c *man/max.scanPhyloQTL.Rd 3e2e35827b3b7dbeb02bcdd26f7d0606 *man/max.scanone.Rd bf36216729012f75dd019bb32672e5a8 *man/max.scantwo.Rd 3578dd1cb8f40e0d6161600742db0d22 *man/movemarker.Rd f240487116337d4e33536ff6be2403ef *man/mqmaugment.Rd a3847c4b8c499dd3cc9bb7884c50eede *man/mqmautocofactors.Rd b67c399846e909ba6e6fc69f0cf55f4f *man/mqmextractmarkers.Rd 912aa4dc49cdd9f0ad8ff60b0a84baf8 *man/mqmfind.marker.Rd ce3c9f07a8f1b04c21a708c7d2648473 *man/mqmgetmodel.Rd ad6c3a986a8535a5330f20e1fa5a831d *man/mqmpermutation.Rd 61a2fca82f616d95102e0bfaa857dcec *man/mqmplotcircle.Rd cd6666dc075a51db231dec7666210252 *man/mqmplotcistrans.Rd 48de4e6d9413aa694a7b71437e13fd22 *man/mqmplotclusteredheatmap.Rd 473ba8d3015e59d28311c978c7f8ceee *man/mqmplotcofactors.Rd f46fdd26452138dcb77b17871de28356 *man/mqmplotdirectedqtl.Rd 5f2afbf606154abe44b0e3224c0334f0 *man/mqmplotheatmap.Rd b78d0d41723e19052938716cd5cb2091 *man/mqmplotmultitrait.Rd 419cd927868afa5273de640ddd8e10de *man/mqmplotpermutations.Rd 361780d3a75584838be03ec97504b20a *man/mqmplotsingletrait.Rd c4ef7276e92570328925b96df8d53bcd *man/mqmprocesspermutation.Rd e20f11619933812802f5c2f40dcb7f87 *man/mqmscan.Rd 2e499203c225bb7c6c0e0c56e63d3e36 *man/mqmscanall.Rd d5ec27129cfe7ef77c739bee12c05f5b *man/mqmscanfdr.Rd a3244c390bc38634fa059806568f404d *man/mqmsetcofactors.Rd 85b0e704432f3360780de3ae57dbb74c *man/mqmtestnormal.Rd 4e70dc5e8948cdace77b215e4db807b2 *man/multitrait.Rd 7e3c22ac1e9cccd41a3c1b87d54e2413 *man/nchr.Rd 4735b081736c17deddb7dbe15a4ba40d *man/nind.Rd 1571e0589103927a3f7c6781253fb874 *man/nmar.Rd 922e73df3a13cb29b0b299dc9954afb8 *man/nmissing.Rd 17f7292521e7359c2986d0ff9c7b11b2 *man/nphe.Rd 8a9ca9fd8879ac5be559189aab411ff0 *man/nqrank.Rd 3285ea10367d173c248da5b7873a4fba *man/nqtl.Rd a56f786422c8a105fa099c1fe559f7a6 *man/ntyped.Rd ef662ebf23561f732f097b77100838e8 *man/nullmarkers.Rd d9d89092243093d84687b72f806e4e51 *man/orderMarkers.Rd c80115c5c4874924981d60b8e008f3a7 *man/phenames.Rd f282510a6a51dfdfde307165fc5c580d *man/pickMarkerSubset.Rd cb403d7e0fafb83658aae6212b894ddc *man/plot.comparegeno.Rd ee506edf95fc1fff05a3d28db07fcdda *man/plot.cross.Rd cf52d169fbe659014b98205455a66cb3 *man/plot.errorlod.Rd 56e38e40ee921ed4f17a3331f70f6c0e *man/plot.geno.Rd b1b532da805f90da6302084ee7080281 *man/plot.info.Rd 14e264d9f7a854e539df059980bce1e8 *man/plot.map.Rd afcbe156c50fc7ff07768e39b7699fcb *man/plot.missing.Rd 3b91f822260d90298216e71c9db7e78c *man/plot.pheno.Rd 4e0d4e4593cb0c5b985f21d81729b3ca *man/plot.pxg.Rd fa1341c1ee50a187e2cfedf9f0e469d3 *man/plot.qtl.Rd 60eb653f330f2de81f36faa0dff3e8a8 *man/plot.rf.Rd 4f6d4d35ac0443e4e96f30627a903cd5 *man/plot.rfmatrix.Rd 1f944b4c13638a9624593e5bb4418abc *man/plot.scanPhyloQTL.Rd 0c08ce497212258d5efc8cb4827df61b *man/plot.scanone.Rd da9bc9c310625a01053c67bba28b85fd *man/plot.scanoneboot.Rd 14c3631c3e3dc859b2a72b58123c5c6b *man/plot.scanoneperm.Rd db0d226dac51acbef28f62ee54ea8e8a *man/plot.scantwo.Rd 3d08b8ed50d0e354a692380e873f7dae *man/plot.scantwoperm.Rd 7865a9f4e52fae8e6dce6d9fca702ce3 *man/plotLodProfile.Rd 2038d82010b3d2e1cc4ce13439c93f99 *man/plotModel.Rd d57d5963d614a7c8e4edbdc336b996b6 *man/pull.argmaxgeno.Rd d6831e4937aa81bb8a0e433e2d14cd60 *man/pull.draws.Rd d0ffa1979385a65020f3689470f45650 *man/pull.geno.Rd fca5d511fd9fee07a9c5784e38200b44 *man/pull.genoprob.Rd 840aab67812c65951a5045b5e4c05488 *man/pull.map.Rd e0c2c53a7790ec286cf5b5e809ad58d5 *man/pull.markers.Rd 51c617390b79f0e24fb566a8d6f47f9e *man/pull.pheno.Rd dd983821a8a8f47b5a40f39f2fa608f8 *man/pull.rf.Rd b153aeb8d49a2a22918bc85122cff99d *man/qtl-internal.Rd 24421956717266483e6be42bacbae303 *man/qtlversion.Rd e81073d9c6c44dbe8d987e13a73c9093 *man/read.cross.Rd c6544ce2c6ebc227b204949a109ef447 *man/readMWril.Rd 80993c5131549ab97c5db3c1f7b7eb7a *man/reduce2grid.Rd 166b8fcc48e914568ec88666bb06228b *man/refineqtl.Rd 3938441b95e0a8c91c351a4c6415545e *man/reorderqtl.Rd 2d9a1697560029f2d3f13f554d9ad304 *man/replace.map.Rd 437e2f84e3bf40553f35e5d3483d0aac *man/replacemap.scanone.Rd b80926e6ddabe7387462af5770193e5a *man/replacemap.scantwo.Rd e0f2a4014fa7e0d9f99911c7f159371d *man/replaceqtl.Rd 40bac92e07d3a5909e2ee0b3bdf2d4a4 *man/rescalemap.Rd b4b08033abf123e1156c462f63068f84 *man/ripple.Rd a71450411b68f231afd13c0c36e62550 *man/scanPhyloQTL.Rd a4aebe044bfb89cb3ee1cf72c7bcf6cc *man/scanone.Rd b1dcbe4874dba1bb1db277c6517c5cdc *man/scanoneboot.Rd 46750e291fdd6ae237fcce3adb8114f4 *man/scanonevar.Rd 86a9e135fbce03b0ed9ffb7e2a95598d *man/scanonevar.meanperm.Rd d4ddd7c34bcfa7ceaa0a7e6b257b3093 *man/scanonevar.varperm.Rd 95de1f7101b85b13111ca3cbc6747a08 *man/scanqtl.Rd 64f2648ee72aa3d7bc09c1fd2b359645 *man/scantwo.Rd 0ea3204a729b28477ec727d951aaab82 *man/scantwopermhk.Rd 1d984a2d71702dfa8119193a58a9285a *man/shiftmap.Rd 356107ec76f230144508fadd43bab70d *man/sim.cross.Rd 42c7c56aa4cbdaa4828a0ab7b4ad55d3 *man/sim.geno.Rd 89481890e71c7f47159d124b793c588e *man/sim.map.Rd 5dde26fc1c704e620ca735fb5b54bc8f *man/simFounderSnps.Rd a9c872c86c7054e617b55446102ec468 *man/simPhyloQTL.Rd e07240c616dab8fb99631c9c861518da *man/simulateMissingData.Rd d92b463b3e3a6503053c895861443d7e *man/stepwiseqtl.Rd bdbf22aee8366eb49c977758804a38fa *man/strip.partials.Rd e2c579f70cd3c6d913af084146fce7e4 *man/subset.cross.Rd b4eae4cbeb7915f8a00cf50753099434 *man/subset.map.Rd 762fa9e96575b94f22c72a497622fee5 *man/subset.scanone.Rd 442e8e3eb236d3bf0cac63632ce5bd8f *man/subset.scanoneperm.Rd 91dfcb6ecad83926519ac0c8a220f15b *man/subset.scantwo.Rd 8571dc7ce386a559325c59de467a1461 *man/subset.scantwoperm.Rd d7666089700c05f9fd949251847a590c *man/summary.comparegeno.Rd 89d3e669529e0cd5399f36d386b56edd *man/summary.cross.Rd 608f4feb30e7853ceacde39977ea8b18 *man/summary.fitqtl.Rd e21bdb91600d3562fc8dcfa0b5ebfde2 *man/summary.map.Rd 9b375fa06892e355d19681145d780461 *man/summary.qtl.Rd 85ed7af2087a3dba4c8940b5365c77f9 *man/summary.ripple.Rd 96f3ca8d59a7b26fb360f59cdda4341e *man/summary.scanPhyloQTL.Rd f1f523a86b9a3b152b4834439d0be07d *man/summary.scanone.Rd ea50f9e360be546a7b10082741958ca0 *man/summary.scanoneboot.Rd 3a9410f101b9541e5aa23803d6ee0885 *man/summary.scanoneperm.Rd b7bc0c77f0d336bb33aab02ca3b6f364 *man/summary.scantwo.Rd cf5667b19b77592434aec71d29bc2349 *man/summary.scantwo.old.Rd b6b521313fb8da2ca075a1b2bca42990 *man/summary.scantwoperm.Rd edb5a9e9055c7e99b1740ef6b3c3937c *man/switch.order.Rd a659bbde4d0893a03cb893637ba3292c *man/switchAlleles.Rd e86e29d929cadfd8ce715171f353033f *man/table2map.Rd e25380b79f25b8066226b267c3987806 *man/top.errorlod.Rd 34e3fe425b861250ba05d330f48baf14 *man/totmar.Rd dda6df509a2c62465fc235985d222528 *man/transformPheno.Rd d5cb697f99ae807f37f91b0cef80b843 *man/tryallpositions.Rd cfe829ed2fa21d759eab76a69cb2fa69 *man/typingGap.Rd b7ffa05cd037031d9abb3d5f3ce47a3b *man/write.cross.Rd 16f3b8d72783156b2d52ca544dba6fac *man/xaxisloc.scanone.Rd 2a6f9e9e044a78154d3cfda5936d6f48 *src/Makevars 93c9a4b474933e50826e719684a03b95 *src/R_init.c 2c7d3ca04c874e826f7d64baa9456a1e *src/R_init.h 319b18d237a724442c3334904852dfe5 *src/countXO.c 0aaed39a89c578647ff5256798d34204 *src/countXO.h 3fad63f8624d0fff754b775b69a44e62 *src/discan.c cc1b8f0530ac6a6a2de49e5d25c47a70 *src/discan.h 64d3c7c88d2e84d8b28cc7bb7f9cb4b1 *src/discan_covar.c e32c99d76c228876c47c043289b9df59 *src/discan_covar.h 288dd85cac5595f09b9c02c3e622a801 *src/effectscan.c cec64a0383167ff081d6e5701fea37b9 *src/effectscan.h 91d0c646d29cfcdab1a35348ae688992 *src/fill_geno_nodblXO.c 5625aff805e480b0e7e5f12d7e8e35ff *src/fill_geno_nodblXO.h 1384f52a5e0fb23e3acdf59b17c416f7 *src/findDupMarkers_notexact.c f281b01dcdce998db1e98908434e39cc *src/findDupMarkers_notexact.h b0202319434ce7626d2d0662f072bbbc *src/fitqtl_hk.c b3a4c6d373aac7e2cb055d56eb1befe7 *src/fitqtl_hk.h 4ad3aec8942563fd468fb3d8c0d85073 *src/fitqtl_hk_binary.c 5a5583104fb9af02041cdce3dec1dbd4 *src/fitqtl_hk_binary.h e57fb133b5bbbf2a069e5967de5aeb7d *src/fitqtl_imp.c 6e369cbfbabd9a03d9b6c850c8368a40 *src/fitqtl_imp.h 990b602d638a54b6862e81d6db056aea *src/fitqtl_imp_binary.c 61e33070becd0b0cc34ce889250411ea *src/fitqtl_imp_binary.h 6b2f1d3bef55da72ddfe79cb3c6676fd *src/forwsel.c aeede8a526c90a31513b03cf0b448e05 *src/forwsel.h d3c217604a4a00a3074586ba7f3ebe40 *src/hmm_4way.c 2b0f1a76866d26663c24769e1e954208 *src/hmm_4way.h 731dbb6ac7d0ed1e9a2f4fef8047378a *src/hmm_bc.c 35305b4c312e94017d4e17a442e8ccf2 *src/hmm_bc.h 517aa2f0534361b8468f69e10ba48fcb *src/hmm_bci.c 9aad7974310927edb683ffc74becc216 *src/hmm_bci.h 1fb2550d624af56f389f303c7df56c93 *src/hmm_bcsft.c 586859fd1f2bef5de18a825408d4273f *src/hmm_bcsft.h 58c6438039bfac2e332d867b92ae19e4 *src/hmm_bgmagic16.c fc076c938068c339fe801f21fcab28f0 *src/hmm_bgmagic16.h 8607a7be83100dcd4fdd18e107721250 *src/hmm_f2.c 1221cca1b8a6a4ceefd715d7df6ce201 *src/hmm_f2.h d1338f24354970ea990db300eaf643ad *src/hmm_f2i.c e5309233b7c5b622d44b0c50504a48c4 *src/hmm_f2i.h e1eefcc4231864a68787d37eb8e8a129 *src/hmm_main.c f1e074aad662aadca914fbc915b271c0 *src/hmm_main.h 7088a28c5d0677be0e960aa9e479af71 *src/hmm_ri4self.c 01171347006c54a49b0921bd4ea38422 *src/hmm_ri4self.h b9981e0b11b8d4d469f4d2a2db5135c5 *src/hmm_ri4sib.c 54cdb43072337802951153e2d71e34a9 *src/hmm_ri4sib.h b64b3dd87e24d301fe728dd0bbe5e342 *src/hmm_ri8self.c c263e8d924b0d8b664fe565aee36df61 *src/hmm_ri8self.h e8571cbeffe3fcb04745cf9377c30698 *src/hmm_ri8selfIRIP1.c ec28f43648caaec816e1a831fa65b9c8 *src/hmm_ri8selfIRIP1.h e92ec6ea2bd7065c3dad9b75944222f5 *src/hmm_ri8sib.c 29137637a726e5a9562fcec338d8d4d9 *src/hmm_ri8sib.h 0e19aa23ea9d9ca32d3edf6df4d1c076 *src/hmm_util.c 9e5a387e330e1f4ed21df0ddbec303ef *src/hmm_util.h b8c72e28cccd0a51e7c6675c15ae0a71 *src/inferFounderHap.c c8febdc02d9cf116c7df6dac19943c88 *src/inferFounderHap.h dcc492e6edf2d1029027605ddfd942e7 *src/info.c 9bf82156882dcb0303db6607335a9a17 *src/info.h b0dead9922c5a7db6f304b6e5771dc50 *src/lapackutil.c 77940ed0df05e1c3d0bd8c6336fc05c3 *src/lapackutil.h 1f42b2427d1613ddbce94cf7a656b9ec *src/markerlrt.c 5f0df67e4b39c52fe4aadd5802df643a *src/markerlrt.h 507d03c39679c9be3dbab2cb097f813b *src/mqm.h 00fae0041b048d14be91992c08a60b1b *src/mqmaugment.cpp 94bc6b24317f613956501964d73e0384 *src/mqmaugment.h c658c31635807cafb6a6da2009817b38 *src/mqmdatatypes.cpp f38b0f763b801a709d43ae42cb816e0e *src/mqmdatatypes.h 46cd444ada9ac8e44913a38e52b6e291 *src/mqmeliminate.cpp 15841fc23bcf17ec011239cd11be2773 *src/mqmeliminate.h f491290c98972e63185b78da67b6b6dc *src/mqmmapqtl.cpp 233111cc86e4bf8a106a0253d03e9a68 *src/mqmmapqtl.h 6ff098870e76f8f7118436a7fc69a800 *src/mqmmixture.cpp c6a8fa0ea4c34862968cccdc2ef87477 *src/mqmmixture.h 68cf7bbc09634a621b1b4f16306a6314 *src/mqmprob.cpp 70ff1060b83ff81c9327d77cb081bcc1 *src/mqmprob.h 84034b2850a15615b4b93f9960b2a068 *src/mqmregression.cpp 988b640a0c63c6ccd2683637f0876453 *src/mqmregression.h cd6d54dcec747fe0acd6c518a9a110e1 *src/mqmscan.cpp 56a2f5f17927a5199152058b4517089a *src/mqmscan.h 4f3afa08828319520586ae7c0b295214 *src/pickMarkerSubset.c b2bf753d87d65b70d88d1528421a4684 *src/pickMarkerSubset.h 9ca3c047852d2fdf009e68b56b92db95 *src/ril48_reorg.c 377509d7abdd7d9eab4b0505bb2fb72e *src/ril48_reorg.h 6da2bdf6ade8a3a6358fef0da9d7688d *src/ripple.c 22db7e365242906fe31b3667efb84016 *src/ripple.h e380afa8990e1862f1bf1df6e0dcd6f7 *src/scanone_ehk.c d5144ae6975330943a6ccf0d3d41319a *src/scanone_ehk.h 67796aa99da02923b7c396b59d5d98ee *src/scanone_em.c b7dd97063f4b5163af749dad5e9937bc *src/scanone_em.h 3acaf81cf19b770b9f505677f493a545 *src/scanone_em_covar.c 677a6dbf438e2c5f43dcd4c4a4954aa4 *src/scanone_em_covar.h 0a92bf28565ff95ee34259ef29902da1 *src/scanone_hk.c 199dc17d39571c2e16074ed0d2533b0c *src/scanone_hk.h 27427ca1dda02302d9dae1f0cbbef9f5 *src/scanone_hk_binary.c edd445fd769727396f32948cdb28394b *src/scanone_hk_binary.h 71d4db93c6c9343d2fe309f2c52e40e1 *src/scanone_imp.c e03c1dac827d923d9ccb9e4c35a03c36 *src/scanone_imp.h 8a8e36005320aeb5798616b63d92ce39 *src/scanone_mr.c 9f53ddc3abba546032b0ec776043ecdc *src/scanone_mr.h ef892e748503c1673ffcf9312418bc6a *src/scanone_np.c 70e4d4ddd4b464f1e8e9b4746d1ef84f *src/scanone_np.h c35d7b106b21c37c25dc525dd1b3eff3 *src/scantwo_binary_em.c 99f75bf750810a1d9675472350e4e337 *src/scantwo_binary_em.h fc4d6cdba8ebd23789753908dab4c65b *src/scantwo_binary_hk.c 4325c03bfc26e9ac9b44c8a80d0c752e *src/scantwo_binary_hk.h d23daf183d219eb71572d306e89d4f32 *src/scantwo_em.c 9675a6e459347d31d8f3c2a40de897e0 *src/scantwo_em.h b48aae5ddd42e9887f4bdc7f7efb2696 *src/scantwo_hk.c 8d8409d693d71d0eb7a137fc0148fd5b *src/scantwo_hk.h 234067e64224e57f60ff1f463dfe8d8d *src/scantwo_imp.c df8e6d778ecd56f848f06605ae5b9bd7 *src/scantwo_imp.h 70e68462f1d7a842f6b06445fb0da5ef *src/scantwo_mr.c e289941b41e4161284ce41dac283b403 *src/scantwo_mr.h 13273cf1c3e3847c0c2c7259d27b98a3 *src/scantwopermhk.c e338a984de734d8b9fd86587229406b3 *src/scantwopermhk.h ec43802bf33e0cec60b34c8ce634fe33 *src/simulate.c bb44570826471e08309fb3fa2c78ee50 *src/simulate.h 75f48d92a286467a586cd3a9944346bd *src/simulate_ril.c 7434d4c941867daffff66c223b29ca91 *src/simulate_ril.h 27ba698367ab29159e2feb19845dffe9 *src/stahl_mf.c 1c63a6419e9adb623cf0b9e8bf66e262 *src/stahl_mf.h 5a9fbf593d1289f13b8b0d3ffb1662ca *src/standalone.h 009203746e8805eb38f82fee79cd0518 *src/summary_scantwo.c 645229bb47522e6c198dd10c603c25d1 *src/summary_scantwo.h 845c5433a9eb7bbc01a92ba395fc6c32 *src/test_bcsft.c d998a178319a9cd5b1f4904bd1ed5202 *src/util.c d00e596a6b5ded548cd672c357b0d7c8 *src/util.h a752e137e6514c25709667e8dc3d1af5 *src/vbscan.c 5fb15aa5b6d413aa8d80d1fdefbc86d5 *src/vbscan.h e80d8509c97c9a947b8a631942c730b4 *src/zeroin.c f4c317d3e5c2af5405243e66b5ed354a *src/zeroin.h f6a9eebc3f37d26e0a5b8ed672354712 *tests/gen.txt 9198bd35e7a221556c5e2008d00cf84c *tests/listeria.csv d04dd9a92564d4c9f61dc86df6a861ca *tests/listeria.map 8520b0234e8d59152126248b0cfa7566 *tests/listeria.raw a47368f05bf5a91580550b1d2c2f4bc5 *tests/listeria2.csv 1d9a688bc52515830ad0664ce1d4a0e5 *tests/listeria2.map a753f49fb90ca63e0a0adce9bdb3161f *tests/map.txt ffecb0696dd5873a13e48157180271fa *tests/phe.txt 054e7cc55d89114c4fb69d3b425c1c01 *tests/test_io.R 5b9d04dda3ed56e163694b2de7e8a4dd *tests/test_io.Rout.save b0ecd2f5f9694a0f61d9f370ac734a61 *tests/test_mapqtl_io.R 15546ea37fca6f7b591f081af224c17e *tests/test_mapqtl_io.Rout.save 9d487b394434c61b15806926325555fd *tests/test_qtl.R daeac5a62836a4bb905cd412989d81d7 *tests/test_scanonevar.R d8758c0fa31de2d1248141df4366f8b0 *tests/test_scanonevar.Rout.save 566406157c3c3b9b10a97c6ddb823e3d *tests/test_tidyIO.R 81a307e45c8cf8f8d19e5fe9d0caa7fb *tests/test_tidyIO.Rout.save 3001461196cd550e16acd9df7a1d5f98 *tests/testaugmentation.R f9001771f9c635f1e079cc830129e450 *tests/testthat.R 99e671bbe4b61dcd1225b1bdc35ce48f *tests/testthat/test-fliporder.R c7fa1e35580f7855e1f0c375f6cc0f43 *tests/testthat/test-scantwoperm.R 3c38de5a8a7c8f6ba1e77cb4fa1a64ba *tests/testthat/test-stepwiseqtl.R 504a78535def937ee020d9e8f1de9b55 *vignettes/bcsft.Rnw 0e3e2fcb99258ac5ca671d3cafc4ac67 *vignettes/genotypeprobabilities.pdf 36ea3b648f7f5e5ca0720876ef5a65a2 *vignettes/goldensectionsearch.pdf af7b55dc73d4866ee50f358467df740a *vignettes/plos.bst 184292403e1f03bf2e7ceb24b5ca46b2 *vignettes/recombinationcount.pdf 42c083fe6530877a8c1af63caf3347ed *vignettes/vignette.bib 6d4070e06aad8a67922d18ef1d835f01 *vignettes/why_we_need_a_new_program.pdf qtl/R/0000755000176200001440000000000014661346505011265 5ustar liggesusersqtl/R/scantwopermhk.R0000644000176200001440000004212713576241200014271 0ustar liggesusers## scantwopermhk.R scantwopermhk <- function(cross, chr, pheno.col=1, addcovar=NULL, weights=NULL, n.perm=1, batchsize=1000, perm.strata=NULL, perm.Xsp=NULL, verbose=FALSE, assumeCondIndep=FALSE) { if(!missing(chr) && !is.null(chr)) cross <- subset(cross, chr) # in RIL, treat X chromosome like an autosome chr.names <- chrnames(cross) chr_type <- sapply(cross$geno, chrtype) type <- crosstype(cross) if(any(chr_type=="X") && (type=="risib" || type=="riself")) for(i in which(chr_type=="X")) class(cross$geno[[i]]) <- chr_type[i] <- "A" if(any(chr_type=="X") && (type=="bc" || type=="f2")) # force stratified permutation test perm.strata <- force_sexstrata(cross, perm.strata) if(!assumeCondIndep) { # if reduce2grid was used, for assumeCondIndep # if reduced2grid, force assumeCondIndep=TRUE reduced2grid <- attr(cross$geno[[1]]$prob, "reduced2grid") if(!is.null(reduced2grid) && reduced2grid) { assumeCondIndep <- TRUE warning("Using assumeCondIndep=TRUE, since probabilities reduced to grid") } } if(is.null(perm.Xsp) || !perm.Xsp || !any(chr_type=="X")) { # all autosomes result <- .scantwopermhk(cross, pheno.col=pheno.col, addcovar=addcovar, weights=weights, n.perm=n.perm, batchsize=batchsize, perm.strata=perm.strata, verbose=verbose, assumeCondIndep=assumeCondIndep) } else { # separate A:A, A:X, and X:X # covariates for X chr Xcovar <- scanoneXnull(crosstype(cross), getsex(cross), attributes(cross))$sexpgmcovar # lengths of autosomes and X chr chrL <- sapply(cross$geno, function(a) diff(range(a$map))) AL <- sum(chrL[chr_type=="A"]) XL <- sum(chrL[chr_type=="X"]) AAL <- AL*AL/2 XXL <- XL*XL/2 AXL <- AL*XL n.permAA <- n.perm n.permXX <- ceiling(n.perm * AAL/XXL) n.permAX <- ceiling(n.perm * AAL/AXL) # names of autosomes and X chr Achr <- chr.names[chr_type=="A"] Xchr <- chr.names[chr_type=="X"] if(verbose) message("Running ", n.permAA, " A:A permutations") AAresult <- .scantwopermhk(cross, chr=Achr, pheno.col=pheno.col, addcovar=cbind(addcovar, Xcovar), # include X covariates weights=weights, n.perm=n.permAA, batchsize=batchsize, perm.strata=perm.strata, verbose=verbose, assumeCondIndep=assumeCondIndep) if(verbose) message("Running ", n.permXX, " X:X permutations") XXresult <- .scantwopermhk(cross, chr=Xchr, pheno.col=pheno.col, addcovar=addcovar, weights=weights, n.perm=n.permXX, batchsize=batchsize, perm.strata=perm.strata, verbose=verbose, assumeCondIndep=assumeCondIndep) if(verbose) message("Running ", n.permAX, " A:X permutations") AXresult <- .scantwopermhk(cross, chr=list(Achr, Xchr), pheno.col=pheno.col, addcovar=addcovar, weights=weights, n.perm=n.permAX, batchsize=batchsize, perm.strata=perm.strata, verbose=verbose, assumeCondIndep=assumeCondIndep) result <- list(AA=AAresult, AX=AXresult, XX=XXresult) attr(result, "L") <- c(A=AL, X=XL) attr(result, "LL") <- c(AA=AAL, AX=AXL, XX=XXL) names(chr_type) <- chr.names attr(result, "chrtype") <- chr_type } class(result) <- "scantwoperm" result } .scantwopermhk <- function(cross, chr, pheno.col=1, addcovar=NULL, weights=NULL, n.perm=1, batchsize=1000, perm.strata=NULL, verbose=FALSE, assumeCondIndep=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(n.perm > batchsize) { # run in batches if(missing(chr)) chr <- chrnames(cross) # determine size of batches: as equal as possible n.batches <- ceiling(n.perm/batchsize) batchsizes <- rep(ceiling(n.perm/n.batches), n.batches) batchsizes[n.batches] <- n.perm - sum(batchsizes[-n.batches]) result <- NULL if(verbose) message(" - perms in ", n.batches, " batches") for(i in seq(along=batchsizes)) { if(verbose) message(" -- batch ", i) thisresult <- .scantwopermhk(cross, chr, pheno.col=pheno.col, addcovar=addcovar, weights=weights, n.perm=batchsizes[i], batchsize=Inf, perm.strata=perm.strata, verbose=verbose, assumeCondIndep) if(is.null(result)) result <- thisresult else { for(j in seq(along=result)) result[[j]] <- rbind(result[[j]], thisresult[[j]]) } } return(result) } # pull out chromosomes to be scanned if(missing(chr)) chr1 <- chr2 <- chr <- names(cross$geno) else { thechr <- names(cross$geno) if(is.list(chr)) { # special case: do just specific pairs (each of chr1 vs each of chr2, except when chr2 < chr1) chr1 <- matchchr(chr[[1]], thechr) chr2 <- matchchr(chr[[2]], thechr) } else chr1 <- chr2 <- matchchr(chr, thechr) } # subset cross and check chr arguments cross <- subset(cross, unique(c(chr1, chr2))) thechr <- names(cross$geno) nchr1 <- match(chr1, thechr) nchr2 <- match(chr2, thechr) if(!any(sapply(nchr1, function(a,b) any(a <= b), nchr2))) stop("Need some of first chr to be <= some of second chr") # in RIL, treat X chromomse like an autosome chr_type <- sapply(cross$geno, chrtype) type <- crosstype(cross) if(any(chr_type=="X") && (type == "risib" || type == "riself")) for(i in which(chr_type=="X")) class(cross$geno[[i]]) <- "A" # check perm.strat if(!missing(perm.strata) && !is.null(perm.strata)) { if(length(perm.strata) != nind(cross)) stop("perm.strata, if given, must have length = nind(cross) [", nind(cross), "]") if(any(is.na(perm.strata))) stop("perm.strata cannot have missing values") } # grab phenotypes if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(length(pheno.col) > 1) stop("Only one phenotype column allowed") if(pheno.col < 1 || pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") # if stepwidth="variable" or stepwidth=="max" when calling calc.genoprob or sim.geno, # we force incl.markers=TRUE; I assume it is the same for all chromosomes stepwidth.var <- FALSE if("stepwidth" %in% names(attributes(cross$geno[[1]]$prob)) && attr(cross$geno[[1]]$prob, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } # omit individuals with missing phenotypes or covariates temp <- checkcovar(cross, pheno.col, addcovar, intcovar=NULL, perm.strata, ind.noqtl=NULL, weights, TRUE) cross <- temp[[1]] pheno <- temp[[2]] addcovar <- temp[[3]] n.addcovar <- temp[[5]] perm.strata <- temp[[7]] weights <- temp[[9]] n.ind <- length(pheno) n.chr <- nchr(cross) if(is.null(weights)) weights <- rep(1, n.ind) # null log likelihood if(n.addcovar > 0) resid0 <- lm(pheno ~ addcovar, weights=weights^2)$resid else resid0 <- lm(pheno ~ 1, weights=weights^2)$resid nllik0X <- nllik0 <- (n.ind/2)*log10(sum((resid0*weights)^2)) # reorganize perm.strata if(!missing(perm.strata) && !is.null(perm.strata)) { u <- unique(perm.strata) perm.strata <- match(perm.strata, u) # turn into integers in {1, ..., n.strata} n.strata <- length(u) } else { perm.strata <- rep(0, n.ind) n.strata <- 0 } # X chromosome covariates if(any(chr_type=="X")) { sexpgm <- getsex(cross) # get null loglik for X chr Xnullcovar <- scanoneXnull(crosstype(cross), sexpgm, attributes(cross))[[3]] adjcovar <- cbind(Xnullcovar, addcovar) if(!is.null(adjcovar) && ncol(adjcovar) > 0) { resid0 <- lm(pheno ~ adjcovar, weights=weights^2)$resid nllik0X <- (n.ind/2)*log10(sum((resid0*weights)^2)) } # covariates to use on X chr addcovarX <- revisecovar(sexpgm,addcovar) if(!is.null(addcovar) && (nd <- attr(addcovarX, "n.dropped")) > 0 && n.perm > -2) warning("Dropped ", nd, " additive covariates on X chromosome.") if(length(addcovarX)==0) { n.acX <- 0 addcovarX <- NULL } else n.acX <- ncol(addcovarX) for(i in 1:n.chr) { if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) { oldXchr <- subset(cross, chr=thechr[i]) cross$geno[[i]]$prob <- reviseXdata(type, "full", sexpgm, prob=cross$geno[[i]]$prob, cross.attr=attributes(cross)) } } } # no. genotypes and positions on each chromosome n.gen <- n.pos <- rep(0, n.chr) for(i in 1:n.chr) { n.pos[i] <- ncol(cross$geno[[i]]$prob) n.gen[i] <- dim(cross$geno[[i]]$prob)[3] } # create shuffled indices if(n.strata==0) permindex <- replicate(n.perm, sample(1:n.ind)) else { # stratified permutation permindex <- replicate(n.perm, 1:n.ind) for(i in 1:n.strata) permindex[perm.strata==i,] <- apply(permindex[perm.strata==i,], 2, sample) } permindex <- permindex-1 # begin loop over pairs of chromosomes result <- vector("list", length(nchr1)*length(nchr2)) k <- 0 for(i in nchr1) { # loop over the 1st chromosome for(j in nchr2) { # loop over the 2nd chromosome if(j < i) next k <- k + 1 if(chr_type[i]=="X" || chr_type[j]=="X") { ac <- addcovarX n.ac <- n.acX } else { ac <- addcovar n.ac <- n.addcovar } if(i==j && chr_type[i]=="X") { col2drop <- dropXcol(type, sexpgm, attributes(cross)) n.col2drop <- sum(col2drop) n.col2drop.addmodel <- sum(col2drop[1:(2*n.gen[i]-1)]) } else { col2drop <- rep(0,n.gen[i]*n.gen[j]) n.col2drop <- 0 } # print the current working pair if(verbose>1) cat(" (", names(cross$geno)[i], ",", names(cross$geno)[j],")\n",sep="") if(i==j) { # same chromosome if(verbose>2) cat(" --Calculating joint probs.\n") if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) { # calculate joint genotype probabilities for all pairs of positions stp <- attr(oldXchr$geno[[1]]$prob, "step") oe <- attr(oldXchr$geno[[1]]$prob, "off.end") err <- attr(oldXchr$geno[[1]]$prob, "error.prob") mf <- attr(oldXchr$geno[[1]]$prob, "map.function") if("stepwidth" %in% names(attributes(oldXchr$geno[[1]]$prob))) stpw <- attr(oldXchr$geno[[1]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(oldXchr$geno[[1]]$prob))) tmap <- attr(oldXchr$geno[[1]]$prob,"map") else tmap <- create.map(oldXchr$geno[[1]]$map, stp, oe, stpw) temp <- calc.pairprob(oldXchr,stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } else { # calculate joint genotype probabilities for all pairs of positions stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") err <- attr(cross$geno[[i]]$prob, "error.prob") mf <- attr(cross$geno[[i]]$prob, "map.function") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(cross$geno[[i]]$prob))) tmap <- attr(cross$geno[[i]]$prob,"map") else tmap <- create.map(cross$geno[[i]]$map, stp, oe, stpw) temp <- calc.pairprob(subset(cross,chr=thechr[i]),stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } # revise pair probilities for X chromosome if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) temp <- reviseXdata(type, "full", sexpgm, pairprob=temp, cross.attr=attributes(cross)) if(verbose>2) cat(" --Done.\n") thisz <- .C("R_scantwopermhk_1chr", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(cross$geno[[i]]$prob), as.double(temp), as.double(ac), as.integer(n.ac), as.double(pheno), as.integer(n.perm), as.integer(permindex), as.double(weights), result=as.double(rep(0,n.perm*6)), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") result[[k]] <- -matrix(thisz$result, nrow=n.perm) result[[k]][,c(1,4,6)] <- result[[k]][,c(1,4,6)] + ifelse(chr_type[i]=="X", nllik0X, nllik0) } # end same chromosome else { thisz <- .C("R_scantwopermhk_2chr", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob), as.double(cross$geno[[j]]$prob), as.double(ac), as.integer(n.ac), as.double(pheno), as.integer(n.perm), as.integer(permindex), as.double(weights), result=as.double(rep(0,n.perm*6)), PACKAGE="qtl") result[[k]] <- -matrix(thisz$result, nrow=n.perm) result[[k]][,c(1,4,6)] <- result[[k]][,c(1,4,6)] + ifelse(chr_type[i]=="X" || chr_type[j]=="X", nllik0X, nllik0) } # end diff chr } # end loop chr 2 } # end loop chr 1 result <- apply( array(unlist(result[1:k]), dim=c(n.perm, 6, k)), 1:2, max, na.rm=TRUE) result <- as.list(as.data.frame(result)) phename <- phenames(cross)[pheno.col] result <- lapply(result, function(a) { a <- as.matrix(a); colnames(a) <- phename; a }) names(result) <- c("full", "fv1", "int", "add", "av1", "one") class(result) <- c("scantwoperm", "list") result } # force stratified permutation test for X chr force_sexstrata <- function(cross, perm.strata) { type <- crosstype(cross) if(type!="bc" && type!="f2") return(perm.strata) Xcovar <- scanoneXnull(type, getsex(cross), attributes(cross))$sexpgmcovar if(!is.null(Xcovar)) { pastedcovar <- apply(Xcovar, 1, paste, collapse="") upastedcovar <- unique(pastedcovar) sexstrata <- match(pastedcovar, upastedcovar) if(is.null(perm.strata)) perm.strata <- sexstrata else { u <- unique(perm.strata) perm.strata <- match(perm.strata, u) m <- max(perm.strata) perm.strata <- perm.strata + m*(sexstrata-1) } } perm.strata } qtl/R/makeqtl.R0000644000176200001440000005265014104553671013052 0ustar liggesusers###################################################################### # # makeqtl.R # # copyright (c) 2002-2019, Hao Wu and Karl W. Broman # last modified Dec, 2019 # first written Apr, 2002 # # Modified by Danny Arends # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: makeqtl, replaceqtl, addtoqtl, dropfromqtl, locatemarker # print.qtl, summary.qtl, print.summary.qtl, reorderqtl # plot.qtl # print.compactqtl, summary.compactqtl, print.summary.compactqtl # ###################################################################### ###################################################################### # # This is the function to construct an object of class "qtl" # The phenotype data and genotype data for a given list of # chromosome and locations will be extracted from the input # "cross" object # ###################################################################### makeqtl <- function(cross, chr, pos, qtl.name, what=c("draws", "prob")) { if( !inherits(cross, "cross") ) stop("The first input variable must be an object of class cross") # cross type type <- crosstype(cross) chr_type <- sapply(cross$geno, chrtype) names(chr_type) <- names(cross$geno) sexpgm <- getsex(cross) what <- match.arg(what) themap <- pull.map(cross) # try to interpret chr argument if(!is.character(chr)) chr <- as.character(chr) # chr, pos and qtl.name must have the same length if(length(chr) != length(pos)) stop("Input chr and pos must have the same length.") else if( !missing(qtl.name) ) if( length(chr) != length(qtl.name) ) stop("Input chr and qtl.name must have the same length.") # local variables n.ind <- nrow(cross$pheno) # number of individuals n.pos <- length(chr) # number of selected markers n.gen <- NULL # initialize output object qtl <- NULL # take out the imputed genotypes and/or genoprobs for the # selected markers (if there are there) if(what == "draws") { # pull out draws if(!("draws" %in% names(cross$geno[[1]]))) stop("You must first run sim.geno.") # take out imputed genotype data n.draws <- dim(cross$geno[[1]]$draws)[3] # number of draws # initialize geno matrix for selected markers geno <- array(rep(0, n.ind*n.pos*n.draws), dim=c(n.ind, n.pos, n.draws)) for(i in 1:n.pos) { # get the index for this chromosome i.chr <- which(chr[i]==names(cross$geno)) if(length(i.chr) == 0) # no this chromosome in cross stop("There's no chromosome number ", chr[i], " in input cross object") i.pos <- pos[i] # marker position # make the genetic map for this chromosome if("map" %in% names(attributes(cross$geno[[i.chr]]$draws))) map <- attr(cross$geno[[i.chr]]$draws,"map") else { stp <- attr(cross$geno[[i.chr]]$draws, "step") oe <- attr(cross$geno[[i.chr]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i.chr]]$draws))) stpw <- attr(cross$geno[[i.chr]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i.chr]]$map,stp,oe,stpw) } # pull out the female map if there are sex-specific maps if(is.matrix(map)) map <- map[1,] # locate this marker (given chromosome and position) marker.idx <- locatemarker(map, i.pos, i.chr, flag="draws") if(length(marker.idx) > 1) stop("Multiple markers at the same position; run jittermap.") # if everything is all right, take the genotype geno[,i,] <- cross$geno[[i.chr]]$draws[,marker.idx,] pos[i] <- map[marker.idx] # no. genotypes n.gen[i] <- length(getgenonames(type,chr_type[i.chr],"full",sexpgm, attributes(cross))) # Fix up X chromsome here if(chr_type[i.chr]=="X" && (type=="bc" || type=="f2")) geno[,i,] <- reviseXdata(type,"full",sexpgm,draws=geno[,i,,drop=FALSE], cross.attr=attributes(cross)) } # give geno dimension names # the 2nd dimension called "Q1", "Q2", etc. dimnames(geno) <- list(NULL, paste("Q", 1:n.pos, sep=""), NULL) # output qtl$geno <- geno } else { # pull out probs if(!("prob" %in% names(cross$geno[[1]]))) stop("You must first run calc.genoprob.") # initialize prob matrix prob <- vector("list",n.pos) # locate the marker for(i in 1:n.pos) { # get the index for this chromosome i.chr <- which(chr[i]==names(cross$geno)) if(length(i.chr) == 0) # no this chromosome in cross stop("There's no chromosome number ", chr[i], " in input cross object") i.pos <- pos[i] # marker position if("map" %in% names(attributes(cross$geno[[i.chr]]$prob))) map <- attr(cross$geno[[i.chr]]$prob,"map") else { stp <- attr(cross$geno[[i.chr]]$prob, "step") oe <- attr(cross$geno[[i.chr]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i.chr]]$prob))) stpw <- attr(cross$geno[[i.chr]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i.chr]]$map,stp,oe,stpw) } # pull out the female map if there are sex-specific maps if(is.matrix(map)) map <- map[1,] # locate this marker (given chromosome and position) marker.idx <- locatemarker(map, i.pos, i.chr, flag="prob") if(length(marker.idx) > 1) stop("Multiple markers at the same position; run jittermap.") # take genoprob if(chr_type[i.chr]=="X" && (type=="bc" || type=="f2")) { # fix X chromosome probs prob[[i]] <- reviseXdata(type, "full", sexpgm, prob=cross$geno[[i.chr]]$prob[,marker.idx,,drop=FALSE], cross.attr=attributes(cross))[,1,] } else prob[[i]] <- cross$geno[[i.chr]]$prob[,marker.idx,] pos[i] <- map[marker.idx] # no. genotypes n.gen[i] <- ncol(prob[[i]]) } qtl$prob <- prob } if(missing(qtl.name)) { # no given qtl names dig <- 1 if(what=="draws") step <- attr(cross$geno[[i.chr]]$draws, "step") else step <- attr(cross$geno[[i.chr]]$prob, "step") if(!is.null(step)) { if(step > 0) dig <- max(dig, -floor(log10(step))) } else { if(what=="draws") stepw <- attr(cross$geno[[i.chr]]$draws, "stepwidth") else stepw <- attr(cross$geno[[i.chr]]$prob, "stepwidth") if(!is.null(stepw) && stepw > 0) dig <- max(dig, -floor(log10(stepw))) } # make qtl names qtl.name <- paste( paste(chr,sep=""), charround(pos,dig), sep="@") } # output object qtl$name <- qtl.name qtl$altname <- paste("Q", 1:n.pos, sep="") qtl$chr <- chr qtl$pos <- pos qtl$n.qtl <- n.pos qtl$n.ind <- nind(cross) qtl$n.gen <- n.gen qtl$chrtype <- chr_type[qtl$chr] names(qtl$chrtype) <- NULL class(qtl) <- "qtl" attr(qtl, "map") <- themap qtl } ###################################################################### # # This is the function to replace one QTL by another. # ###################################################################### replaceqtl <- function(cross, qtl, index, chr, pos, qtl.name, drop.lod.profile=TRUE) { if(!inherits(qtl, "qtl")) stop("qtl should have class \"qtl\".") if(any(index < 1 | index > qtl$n.qtl)) stop("index should be between 1 and ", qtl$n.qtl) if(length(index) != length(chr) || length(index) != length(pos)) stop("index, chr, and pos should all have the same length.") if(!missing(qtl.name) && length(index) != length(qtl.name)) stop("index and qtl.name should have the same length.") if("geno" %in% names(qtl)) what <- "draws" else what <- "prob" if(missing(qtl.name)) newqtl <- makeqtl(cross, chr, pos, what=what) else newqtl <- makeqtl(cross, chr, pos, qtl.name=qtl.name, what=what) if(what=="draws") { qtl$geno[,index,] <- newqtl$geno } else { qtl$prob[index] <- newqtl$prob } qtl$name[index] <- newqtl$name qtl$chr[index] <- newqtl$chr qtl$pos[index] <- newqtl$pos qtl$chrtype[index] <- newqtl$chrtype if(qtl$n.ind != newqtl$n.ind) stop("Mismatch in no. individuals") qtl$n.gen[index] <- newqtl$n.gen if(drop.lod.profile) attr(qtl, "lodprofile") <- NULL qtl } ###################################################################### # # This is the function to add a QTL to given qtl object # ###################################################################### addtoqtl <- function(cross, qtl, chr, pos, qtl.name, drop.lod.profile=TRUE) { if(!inherits(qtl, "qtl")) stop("qtl should have class \"qtl\".") if("geno" %in% names(qtl)) what <- "draws" else what <- "prob" if(missing(qtl.name)) newqtl <- makeqtl(cross, chr, pos, what=what) else newqtl <- makeqtl(cross, chr, pos, qtl.name=qtl.name, what=what) if(what=="draws") { do <- dim(qtl$geno) dn <- dim(newqtl$geno) if(do[1] != dn[1] || do[3] != dn[3]) stop("Mismatch in number of individuals or number of imputations.") temp <- array(dim=c(do[1], do[2]+dn[2], do[3])) temp[,1:ncol(qtl$geno),] <- qtl$geno temp[,-(1:ncol(qtl$geno)),] <- newqtl$geno colnames(temp) <- paste("Q", 1:ncol(temp), sep="") qtl$geno <- temp } else { qtl$prob <- c(qtl$prob, newqtl$prob) } qtl$name <- c(qtl$name, newqtl$name) qtl$chr <- c(qtl$chr, newqtl$chr) qtl$pos <- c(qtl$pos, newqtl$pos) qtl$n.qtl <- qtl$n.qtl + newqtl$n.qtl qtl$altname <- paste("Q", 1:qtl$n.qtl, sep="") qtl$chrtype <- c(qtl$chrtype, newqtl$chrtype) if(qtl$n.ind != newqtl$n.ind) stop("Mismatch in no. individuals") qtl$n.gen <- c(qtl$n.gen, newqtl$n.gen) attr(qtl, "formula") <- NULL attr(qtl, "pLOD") <- NULL if(drop.lod.profile) attr(qtl, "lodprofile") <- NULL qtl } ###################################################################### # # This is the function to drop a QTL from a given qtl object # ###################################################################### dropfromqtl <- function(qtl, index, chr, pos, qtl.name, drop.lod.profile=TRUE) { if(!inherits(qtl, "qtl")) stop("qtl should have class \"qtl\".") if(!missing(chr) || !missing(pos)) { if(missing(chr) || missing(pos)) stop("Give both chr and pos, or give name, or give a numeric index") if(!missing(qtl.name) || !missing(index)) stop("Give chr and pos or qtl.name or numeric index, but not multiple of these.") if(length(chr) != length(pos)) stop("chr and pos must have the same lengths.") todrop <- NULL for(i in seq(along=chr)) { m <- which(qtl$chr == chr[i]) if(length(m) < 1) stop("No QTL on chr ", chr[i], " in input qtl object.") for(j in seq(along=m)) { d <- abs(qtl$pos[m[j]] - pos[i]) if(min(d) > 10) stop("No qtl near position ", pos[i], " on chr ", chr[i]) wh <- m[d==min(d)] if(length(wh) > 1) stop("Multiple QTL matching chr ", chr[i], " at pos ", pos[i]) if(min(d) > 1) warning("No QTL on chr ", chr[i], " exactly at ", pos[i], "; dropping that at ", qtl$pos[wh]) todrop <- c(todrop, wh) } } todrop <- unique(todrop) } else if(!missing(qtl.name)) { if(!missing(index)) stop("Give chr and pos or qtl.name or numeric index, but not multiple of these.") m <- match(qtl.name, qtl$name) if(all(is.na(m))) # if no matches, try "altname" m <- match(qtl.name, qtl$altname) if(any(is.na(m))) warning("Didn't match QTL ", qtl.name[is.na(m)]) todrop <- m[!is.na(m)] } else { if(missing(index)) stop("Give chr and pos or qtl.name or numeric index, but not multiple of these.") if(any(index < 1 | index > qtl$n.qtl)) stop("index should be between 1 and ", qtl$n.qtl) todrop <- index } # input drop is an integer index # get the index for exclusing drop QTL idx <- setdiff(1:qtl$n.qtl, todrop) # result object qtl$name <- qtl$name[idx] qtl$chr <- qtl$chr[idx] qtl$chrtype <- qtl$chrtype[idx] qtl$pos <- qtl$pos[idx] qtl$n.qtl <- qtl$n.qtl - length(todrop) qtl$altname <- paste("Q", 1:qtl$n.qtl, sep="") qtl$n.ind <- qtl$n.ind qtl$n.gen <- qtl$n.gen[idx] if("geno" %in% names(qtl)) { qtl$geno <- qtl$geno[,idx,,drop=FALSE] colnames(qtl$geno) <- paste("Q", 1:ncol(qtl$geno), sep="") } if("prob" %in% names(qtl)) qtl$prob <- qtl$prob[idx] attr(qtl, "formula") <- NULL attr(qtl, "pLOD") <- NULL if(drop.lod.profile) attr(qtl, "lodprofile") <- NULL qtl } ################################################################## # # locate the marker on a genetic map. Choose the nearest # one if there's no marker or pseudomarker one the given # location # # This is the internal function and not supposed to be used by user # ################################################################### locatemarker <- function(map, pos, chr, flag) { marker.idx <- which(map == pos) if( length(marker.idx)==0 ) { # there's no this marker, take the nearest marker instead # if there's a tie, take the first nearst one m.tmp <- abs(pos-map) marker.idx <- which(m.tmp==min(m.tmp))[[1]] } if(length(marker.idx) > 1) marker.idx <- marker.idx[sample(length(marker.idx))] marker.idx } # print QTL object print.qtl <- function(x, ...) { print(summary(x)) } # summary of QTL object summary.qtl <- function(object, ...) { if(is.null(object) || length(object) == 0 || length(object$chr)==0) { object <- numeric(0) class(object) <- "summary.qtl" return(object) } if("geno" %in% names(object)) { type <- "draws" n.draws <- dim(object$geno)[3] } else type <- "prob" output <- data.frame(name=object$name, chr=object$chr, pos=object$pos, n.gen=object$n.gen, stringsAsFactors=TRUE) rownames(output) <- object$altname attr(output, "type") <- type if(!is.null(attr(object,"mqm"))) attr(output, "mqm") <- attr(object,"mqm") if(type=="draws") attr(output, "n.draws") <- n.draws class(output) <- c("summary.qtl", "data.frame") if("formula" %in% names(attributes(object))) attr(output, "formula") <- attr(object, "formula") if("pLOD" %in% names(attributes(object))) attr(output, "pLOD") <- attr(object, "pLOD") output } # print summary of QTL object print.summary.qtl <- function(x, ...) { if(is.null(x) || length(x) == 0) { cat(" Null QTL model\n") } else { type <- attr(x, "type") if(type=="draws") thetext <- paste("imputed genotypes, with", attr(x, "n.draws"), "imputations.") else thetext <- "genotype probabilities." if(!is.null(attr(x,"mqm"))) thetext <- paste("model created by mqmscan") cat(" QTL object containing", thetext, "\n\n") print.data.frame(x, digits=5) } if("formula" %in% names(attributes(x))) { form <- attr(x, "formula") if(!is.character(form)) form <- deparseQTLformula(form) cat("\n Formula:") w <- options("width")[[1]] printQTLformulanicely(form, " ", w+5, w) } if("pLOD" %in% names(attributes(x))) cat("\n pLOD: ", round(attr(x, "pLOD"),3), "\n") } ###################################################################### # plot locations of QTLs on the genetic map ###################################################################### plot.qtl <- function(x, chr, horizontal=FALSE, shift=TRUE, show.marker.names=FALSE, alternate.chrid=FALSE, justdots=FALSE, col="red", ...) { if(!inherits(x, "qtl")) stop("input should be a qtl object") if(length(x) == 0) stop(" There are no QTL to plot.") map <- attr(x, "map") if(is.null(map)) stop("qtl object doesn't contain a genetic map.") if(missing(chr)) chr <- names(map) else { chr <- matchchr(chr, names(map)) map <- map[chr] class(map) <- "map" } if(horizontal) plotMap(map, horizontal=horizontal, shift=shift, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, ylim=c(length(map)+0.5, 0), ...) else plotMap(map, horizontal=horizontal, shift=shift, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, xlim=c(0.5,length(map)+1), ...) whchr <- match(x$chr, names(map)) thepos <- x$pos thepos[is.na(whchr)] <- NA if(any(!is.na(thepos))) { whchr <- whchr[!is.na(whchr)] if(shift) thepos <- thepos - sapply(map[whchr], min) if(is.matrix(map[[1]])) whchr <- whchr - 0.3 if(length(grep("^.+@[0-9\\.]+$", x$name)) == length(x$name)) x$name <- x$altname if(!justdots) { if(horizontal) { arrows(thepos, whchr - 0.35, thepos, whchr, lwd=2, col=col, length=0.05) text(thepos, whchr-0.4, x$name, col=col, adj=c(0.5,0)) } else { arrows(whchr + 0.35, thepos, whchr, thepos, lwd=2, col=col, length=0.05) text(whchr+0.4, thepos, x$name, col=col, adj=c(0,0.5)) } } else { if(horizontal) points(thepos, whchr, pch=16, col=col) else { points(whchr, thepos, pch=16, col=col) } } } invisible() } ###################################################################### # # This is the function to reorder the QTL within a QTL object # ###################################################################### reorderqtl <- function(qtl, neworder) { if(!inherits(qtl, "qtl")) stop("qtl should have class \"qtl\".") if(missing(neworder)) { if(!("map" %in% names(attributes(qtl)))) stop("No map in the qtl object; you must provide argument 'neworder'.") chr <- names(attr(qtl, "map")) thechr <- match(qtl$chr, chr) if(any(is.na(thechr))) stop("Chr ", paste(qtl$chr[is.na(thechr)], " "), " not found.") neworder <- order(thechr, qtl$pos) } curorder <- seq(qtl$n.qtl) if(length(neworder) != qtl$n.qtl || !all(curorder == sort(neworder))) stop("neworder should be an ordering of the integers from 1 to ", qtl$n.qtl) if(qtl$n.qtl == 1) stop("Nothing to do; just one qtl.") if("geno" %in% names(qtl)) qtl$geno <- qtl$geno[,neworder,] else qtl$prob <- qtl$prob[neworder] qtl$name <- qtl$name[neworder] qtl$chr <- qtl$chr[neworder] qtl$pos <- qtl$pos[neworder] qtl$n.gen <- qtl$n.gen[neworder] qtl$chrtype <- qtl$chrtype[neworder] attr(qtl, "formula") <- NULL attr(qtl, "pLOD") <- NULL if("lodprofile" %in% names(attributes(qtl))) { lodprof <- attr(qtl, "lodprofile") if(length(lodprof) == length(neworder)) attr(qtl, "lodprofile") <- lodprof[neworder] } qtl } # print compact version of QTL object print.compactqtl <- function(x, ...) { print(summary(x)) } summary.compactqtl <- function(object, ...) { class(object) <- c("summary.compactqtl", "list") object } print.summary.compactqtl <- function(x, ...) { if(is.null(x) || length(x) == 0) cat("Null QTL model\n") else { temp <- as.data.frame(x, stringsAsFactors=TRUE) rownames(temp) <- paste("Q", 1:nrow(temp), sep="") print.data.frame(temp) } if("formula" %in% names(attributes(x))) { form <- attr(x, "formula") if(!is.character(form)) form <- deparseQTLformula(form) cat(" Formula:") w <- options("width")[[1]] printQTLformulanicely(form, " ", w+5, w) } if("pLOD" %in% names(attributes(x))) cat(" pLOD: ", round(attr(x, "pLOD"),3), "\n") } # nqtl: number of qtl nqtl <- function(qtl) ifelse(length(qtl)==0,0,length(qtl$chr)) # end of makeqtl.R qtl/R/plot.R0000644000176200001440000015610313576241200012362 0ustar liggesusers###################################################################### # # plot.R # # copyright (c) 2000-2019, Karl W Broman # [modifications of plot.cross from Brian Yandell] # last modified Dec, 2019 # first written Mar, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: plotMissing, plotMap, plot.cross, plotGeno, plotInfo, # plotPXG, plotPheno # ###################################################################### plotMissing <- function(x, chr, reorder=FALSE, main="Missing genotypes", alternate.chrid=FALSE, ...) { cross <- x if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross,chr=chr) # get full genotype data into one matrix Geno <- pull.geno(cross) # reorder the individuals according to their phenotype o <- 1:nrow(Geno) if(reorder) { # if reorder is a number, use the corresponding phenotype if(is.numeric(reorder)) { if(reorder < 1 || reorder > nphe(cross)) stop("reorder should be TRUE, FALSE, or an integer between 1 and", nphe(cross)) o <- order(cross$pheno[,reorder]) } # otherwise, order according to the sum of the numeric phenotypes else { wh <- sapply(cross$pheno, is.numeric) o <- order(apply(cross$pheno[,wh,drop=FALSE],1,sum)) } } # make matrix with 0 where genotype data is missing # 1 where data is not missing # 0.5 where data is partially missing type <- crosstype(cross) g <- t(Geno[o,]) g[is.na(g)] <- 0 if(type == "bc" || type=="risib" || type=="riself" || type=="bc") g[g > 0] <- 1 else if(type=="f2") { g[g > 0 & g < 4] <- 1 g[g > 3] <- 0.5 } else if(type=="4way") { g[g > 0 & g < 5] <- 1 g[g > 4] <- 0.5 } else { g[g > 0] <- 1 } old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) colors <- c("#000000", "gray80", "#FFFFFF") # plot grid with black pixels where there is missing data image(1:nrow(g),1:ncol(g),g,ylab="Individuals",xlab="Markers",col=colors,zlim=c(0,1)) # plot lines at the chromosome boundaries n.mar <- nmar(cross) n.chr <- nchr(cross) a <- c(0.5,cumsum(n.mar)+0.5) # the following makes the lines go slightly above the plotting region b <- par("usr") segments(a,b[3],a,b[4]+diff(b[3:4])*0.02) # this line adds a line above the image # (the image function seems to leave it out) abline(h=0.5+c(0,ncol(g)),xpd=FALSE) # add chromosome numbers a <- par("usr") wh <- cumsum(c(0.5,n.mar)) x <- 1:n.chr for(i in 1:n.chr) x[i] <- mean(wh[i+c(0,1)]) thechr <- names(cross$geno) if(!alternate.chrid || length(thechr) < 2) { for(i in seq(along=x)) axis(side=3, at=x[i], thechr[i], tick=FALSE, line=-0.5) } else { odd <- seq(1, length(x), by=2) even <- seq(2, length(x), by=2) for(i in odd) { axis(side=3, at=x[i], labels=thechr[i], line=-0.75, tick=FALSE) } for(i in even) { axis(side=3, at=x[i], labels=thechr[i], line=+0, tick=FALSE) } } title(main=main) invisible() } geno.image <- function(x, chr, reorder=FALSE, main="Genotype data", alternate.chrid=FALSE, col=NULL, ...) { cross <- x if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross,chr=chr) type <- crosstype(cross) # revise X chromosome data if(type=="bc" || type=="f2") { chr_type <- sapply(cross$geno, chrtype) if(any(chr_type=="X")) { for(i in which(chr_type=="X")) cross$geno[[i]]$data <- reviseXdata(type, "simple", getsex(cross), geno=cross$geno[[i]]$data, cross.attr=attributes(cross)) } } # get full genotype data into one matrix Geno <- pull.geno(cross) # colors to use maxgeno <- max(Geno, na.rm=TRUE) if(type != "4way") { thecolors <- c("white", "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00") thebreaks <- seq(-0.5, 5.5, by=1) } else { if(maxgeno <= 5) { thecolors <- c("white", "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00") thebreaks <- seq(-0.5, 5.5, by=1) } else { thecolors <- c("white", "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", "#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5", "#D9D9D9", "#BC80BD") thebreaks <- seq(-0.5, 10.5, by=1) } } thecolors <- thecolors[1:(maxgeno+1)] thebreaks <- thebreaks[1:(maxgeno+2)] if(!is.null(col)) { # colors provided if(length(col) < length(thecolors)) { warning("col should have length ", maxgeno+1) thecolors[seq_along(col)] <- col } else { thecolors <- col[1:(maxgeno+1)] } } # reorder the individuals according to their phenotype o <- 1:nrow(Geno) if(reorder) { # if reorder is a number, use the corresponding phenotype if(is.numeric(reorder)) { if(reorder < 1 || reorder > nphe(cross)) stop("reorder should be TRUE, FALSE, or an integer between 1 and ", nphe(cross)) o <- order(cross$pheno[,reorder]) } # otherwise, order according to the sum of the numeric phenotypes else { wh <- sapply(cross$pheno, is.numeric) o <- order(apply(cross$pheno[,wh,drop=FALSE],1,sum)) } } g <- t(Geno[o,]) g[is.na(g)] <- 0 # make matrix with 0 where genotype data is missing # 1 where data is not missing # 0.5 where data is partially missing old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) # plot grid with black pixels where there is missing data plot_image_sub <- function(g, ylab="Individuals",xlab="Markers", col=thecolors, ...) { if(length(thebreaks) != length(col)+1) stop("Must have one more break than color\n", "length(breaks) = ", length(thebreaks), "\nlength(col) = ", length(col)) image(1:nrow(g),1:ncol(g), g, col=col, xlab=xlab, ylab=ylab, breaks=thebreaks, ...) } plot_image_sub(g, ...) # plot lines at the chromosome boundaries n.mar <- nmar(cross) n.chr <- nchr(cross) a <- c(0.5,cumsum(n.mar)+0.5) # the following makes the lines go slightly above the plotting region b <- par("usr") segments(a,b[3],a,b[4]+diff(b[3:4])*0.02) # this line adds a line above the image # (the image function seems to leave it out) abline(h=0.5+c(0,ncol(g)),xpd=FALSE) # add chromosome numbers a <- par("usr") wh <- cumsum(c(0.5,n.mar)) x <- 1:n.chr for(i in 1:n.chr) x[i] <- mean(wh[i+c(0,1)]) thechr <- names(cross$geno) if(!alternate.chrid || length(thechr) < 2) { for(i in seq(along=x)) axis(side=3, at=x[i], thechr[i], tick=FALSE, line=-0.5) } else { odd <- seq(1, length(x), by=2) even <- seq(2, length(x), by=2) for(i in odd) axis(side=3, at=x[i], labels=thechr[i], line=-0.75, tick=FALSE) for(i in even) axis(side=3, at=x[i], labels=thechr[i], line=+0, tick=FALSE) } title(main=main) invisible() } plotMap <- plot.map <- function(x, map2, chr, horizontal=FALSE, shift=TRUE, show.marker.names=FALSE, alternate.chrid=FALSE, ...) { dots <- list(...) if("main" %in% names(dots)) { themain <- dots$main usemaindefault <- FALSE } else usemaindefault <- TRUE if("xlim" %in% names(dots)) { xlim <- dots$xlim usexlimdefault <- FALSE } else usexlimdefault <- TRUE if("ylim" %in% names(dots)) { ylim <- dots$ylim useylimdefault <- FALSE } else useylimdefault <- TRUE if("xlab" %in% names(dots)) xlab <- dots$xlab else { if(horizontal) xlab <- "Location (cM)" else xlab <- "Chromosome" } if("ylab" %in% names(dots)) ylab <- dots$ylab else { if(horizontal) ylab <- "Chromosome" else ylab <- "Location (cM)" } map <- x # figure out if the input is a cross (containing a map) # or is the map itself if(inherits(map, "cross")) map <- pull.map(map) if(!missing(map2) && inherits(map2, "cross")) map2 <- pull.map(map2) if(!inherits(map, "map") || (!missing(map2) && !inherits(map2, "map"))) warning("Input should have class \"cross\" or \"map\".") if(!missing(map2) && is.matrix(map[[1]]) != is.matrix(map2[[1]])) stop("Maps must be both sex-specific or neither sex-specific.") if(!missing(chr)) { map <- map[matchchr(chr, names(map))] if(!missing(map2)) map2 <- map2[matchchr(chr, names(map2))] } sex.sp <- FALSE if(is.matrix(map[[1]])) { # sex-specific map one.map <- FALSE sex.sp <- TRUE if(!missing(map2)) { if(is.logical(map2)) { horizontal <- map2 map2 <- lapply(map,function(a) a[2,]) map <- lapply(map,function(a) a[1,]) } else { Map1 <- lapply(map,function(a) a[1,,drop=TRUE]) Map2 <- lapply(map,function(a) a[2,,drop=TRUE]) Map3 <- lapply(map2,function(a) a[1,,drop=TRUE]) Map4 <- lapply(map2,function(a) a[2,,drop=TRUE]) old.mfrow <- par("mfrow") on.exit(par(mfrow=old.mfrow)) par(mfrow=c(2,1)) class(Map1) <- class(Map2) <- class(Map3) <- class(Map4) <- "map" plotMap(Map1,Map3,horizontal=horizontal,shift=shift, show.marker.names=show.marker.names,alternate.chrid=alternate.chrid) plotMap(Map2,Map4,horizontal=horizontal,shift=shift, show.marker.names=show.marker.names,alternate.chrid=alternate.chrid) return(invisible(NULL)) } } else { map2 <- lapply(map,function(a) a[2,]) map <- lapply(map,function(a) a[1,]) } } else { # single map # determine whether a second map was given if(!missing(map2)) one.map <- FALSE else one.map <- TRUE } if(one.map) { n.chr <- length(map) if(!show.marker.names) { # locations of chromosomes chrpos <- 1:n.chr thelim <- range(chrpos)+c(-0.5, 0.5) } else { chrpos <- seq(1, n.chr*2, by=2) thelim <- range(chrpos)+c(-0.35, 2.35) } if(shift) map <- lapply(map, function(a) a-a[1]) maxlen <- max(unlist(lapply(map,max))) if(horizontal) { old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE, las=1) on.exit(par(xpd=old.xpd,las=old.las)) if(usexlimdefault) xlim <- c(0,maxlen) if(useylimdefault) ylim <- rev(thelim) plot(0,0,type="n",xlim=xlim, ylim=ylim,yaxs="i", xlab=xlab, ylab=ylab, yaxt="n") a <- par("usr") for(i in 1:n.chr) { segments(min(map[[i]]), chrpos[i], max(map[[i]]), chrpos[i]) segments(map[[i]], chrpos[i]-0.25, map[[i]], chrpos[i]+0.25) if(show.marker.names) text(map[[i]], chrpos[i]+0.35, names(map[[i]]), srt=90, adj=c(1,0.5)) } # add chromosome labels if(!alternate.chrid || length(chrpos) < 2) { for(i in seq(along=chrpos)) axis(side=2, at=chrpos[i], labels=names(map)[i]) } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=2, at=chrpos[i], labels="") axis(side=2, at=chrpos[i], labels=names(map)[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=2, at=chrpos[i], labels="") axis(side=2, at=chrpos[i], labels=names(map)[i], line=+0.4, tick=FALSE) } } } else { old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) if(usexlimdefault) xlim <- thelim if(useylimdefault) ylim <- c(maxlen, 0) plot(0,0,type="n",ylim=ylim,xlim=xlim,xaxs="i", xlab=xlab, ylab=ylab, xaxt="n") a <- par("usr") for(i in 1:n.chr) { segments(chrpos[i], min(map[[i]]), chrpos[i], max(map[[i]])) segments(chrpos[i]-0.25, map[[i]], chrpos[i]+0.25, map[[i]]) if(show.marker.names) text(chrpos[i]+0.35, map[[i]], names(map[[i]]), adj=c(0,0.5)) } # add chromosome labels if(!alternate.chrid || length(chrpos) < 2) { for(i in seq(along=chrpos)) axis(side=1, at=chrpos[i], labels=names(map)[i]) } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=1, at=chrpos[i], labels="") axis(side=1, at=chrpos[i], labels=names(map)[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=1, at=chrpos[i], labels="") axis(side=1, at=chrpos[i], labels=names(map)[i], line=+0.4, tick=FALSE) } } } if(usemaindefault) title(main="Genetic map") else if(themain != "") title(main=themain) } else { map1 <- map # check that maps conform if(is.matrix(map2[[1]])) stop("Second map appears to be a sex-specific map.") if(length(map1) != length(map2)) stop("Maps have different numbers of chromosomes.") if(any(names(map1) != names(map2))) { cat("Map1: ", names(map1), "\n") cat("Map2: ", names(map2), "\n") stop("Maps have different chromosome names.") } if(shift) { map1 <- lapply(map1,function(a) a-a[1]) map2 <- lapply(map2,function(a) a-a[1]) } n.mar1 <- sapply(map1, length) n.mar2 <- sapply(map2, length) markernames1 <- lapply(map1, names) markernames2 <- lapply(map2, names) if(any(n.mar1 != n.mar2)) { if(show.marker.names) { warning("Can't show marker names because of different numbers of markers.") show.marker.names <- FALSE } } else if(any(unlist(markernames1) != unlist(markernames2))) { if(show.marker.names) { warning("Can't show marker names because markers in different orders.") show.marker.names <- FALSE } } n.chr <- length(map1) maxloc <- max(c(unlist(lapply(map1,max)),unlist(lapply(map2,max)))) if(!show.marker.names) { # locations of chromosomes chrpos <- 1:n.chr thelim <- range(chrpos)+c(-0.5, 0.5) } else { chrpos <- seq(1, n.chr*2, by=2) thelim <- range(chrpos)+c(-0.4, 2.4) } if(!horizontal) { old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) if(usexlimdefault) xlim <- thelim if(useylimdefault) ylim <- c(maxloc, 0) plot(0,0,type="n",ylim=ylim,xlim=xlim, xaxs="i", xlab=xlab, ylab=ylab, xaxt="n") a <- par("usr") for(i in 1:n.chr) { if(max(map2[[i]]) < max(map1[[i]])) map2[[i]] <- map2[[i]] + (max(map1[[i]])-max(map2[[i]]))/2 else map1[[i]] <- map1[[i]] + (max(map2[[i]])-max(map1[[i]]))/2 segments(chrpos[i]-0.3, min(map1[[i]]), chrpos[i]-0.3, max(map1[[i]])) segments(chrpos[i]+0.3, min(map2[[i]]), chrpos[i]+0.3, max(map2[[i]])) # lines between markers wh <- match(markernames1[[i]], markernames2[[i]]) for(j in which(!is.na(wh))) segments(chrpos[i]-0.3, map1[[i]][j], chrpos[i]+0.3, map2[[i]][wh[j]]) if(any(is.na(wh))) segments(chrpos[i]-0.4, map1[[i]][is.na(wh)], chrpos[i]-0.2, map1[[i]][is.na(wh)]) wh <- match(markernames2[[i]], markernames1[[i]]) if(any(is.na(wh))) segments(chrpos[i]+0.4, map2[[i]][is.na(wh)], chrpos[i]+0.2, map2[[i]][is.na(wh)]) if(show.marker.names) text(chrpos[i]+0.35, map2[[i]], names(map2[[i]]), adj=c(0,0.5)) } # add chromosome labels if(!alternate.chrid || length(chrpos) < 2) { for(i in seq(along=chrpos)) axis(side=1, at=chrpos[i], labels=names(map1)[i]) } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=1, at=chrpos[i], labels="") axis(side=1, at=chrpos[i], labels=names(map1)[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=1, at=chrpos[i], labels="") axis(side=1, at=chrpos[i], labels=names(map1)[i], line=+0.4, tick=FALSE) } } } else { old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) if(usexlimdefault) xlim <- c(0,maxloc) if(useylimdefault) ylim <- rev(thelim) plot(0,0,type="n",xlim=xlim,ylim=ylim, xlab=xlab, ylab=ylab, yaxt="n", yaxs="i") a <- par("usr") for(i in 1:n.chr) { if(max(map2[[i]]) < max(map1[[i]])) map2[[i]] <- map2[[i]] + (max(map1[[i]])-max(map2[[i]]))/2 else map1[[i]] <- map1[[i]] + (max(map2[[i]])-max(map1[[i]]))/2 segments(min(map1[[i]]), chrpos[i]-0.3, max(map1[[i]]), chrpos[[i]]-0.3) segments(min(map2[[i]]), chrpos[i]+0.3, max(map2[[i]]), chrpos[[i]]+0.3) # lines between markers wh <- match(markernames1[[i]], markernames2[[i]]) for(j in which(!is.na(wh))) segments(map1[[i]][j], chrpos[i]-0.3, map2[[i]][wh[j]], chrpos[i]+0.3) if(any(is.na(wh))) segments(map1[[i]][is.na(wh)], chrpos[i]-0.4, map1[[i]][is.na(wh)], chrpos[i]-0.2) wh <- match(markernames2[[i]], markernames1[[i]]) if(any(is.na(wh))) segments(map2[[i]][is.na(wh)], chrpos[i]+0.4, map2[[i]][is.na(wh)], chrpos[i]+0.2) if(show.marker.names) text(map2[[i]], chrpos[i]+0.35, names(map2[[i]]), srt=90, adj=c(1,0.5)) } # add chromosome labels if(!alternate.chrid || length(chrpos) < 2) { for(i in seq(along=chrpos)) axis(side=2, at=chrpos[i], labels=names(map1)[i]) } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=2, at=chrpos[i], labels="") axis(side=2, at=chrpos[i], labels=names(map1)[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=2, at=chrpos[i], labels="") axis(side=2, at=chrpos[i], labels=names(map1)[i], line=+0.4, tick=FALSE) } } } if(usemaindefault) { if(!sex.sp) title(main="Comparison of genetic maps") else title(main="Genetic map") } else if(themain != "") title(main=themain) } invisible() } plot.cross <- function (x, auto.layout = TRUE, pheno.col, alternate.chrid=TRUE, ...) { # look to see whether this should really be shipped to plotMap if(inherits(auto.layout, "map") && (inherits(x, "map") || inherits(x, "cross"))) { plotMap(x, auto.layout, alternate.chrid=alternate.chrid, ...) return(invisible()) } # make sure this is a cross if(!inherits(x, "cross")) stop("Input should have class \"cross\".") old.yaxt <- par("yaxt") old.mfrow <- par("mfrow") on.exit(par(yaxt = old.yaxt, mfrow = old.mfrow)) n.phe <- nphe(x) if(missing(pheno.col)) pheno.col <- 1:n.phe if(is.character(pheno.col)) { temp <- match(pheno.col, names(x$pheno)) if(any(is.na(temp))) warning("Some phenotypes not found:", paste(pheno.col[is.na(temp)], collapse=" ")) pheno.col <- temp[!is.na(temp)] } else pheno.col <- (1:nphe(x))[pheno.col] n.plot = length(pheno.col) + 2 # automatically choose row/column structure for the plots if(auto.layout) { nr <- ceiling(sqrt(n.plot)) nc <- ceiling((n.plot)/nr) par(mfrow = c(nr, nc)) } plotMissing(x,alternate.chrid=alternate.chrid) plotMap(x,alternate.chrid=alternate.chrid) for(i in pheno.col) plotPheno(x, pheno.col=i) invisible() } ##################################################r#################### # # plotGeno: Plot genotypes for a specified chromosome, with likely # genotyping errors indicated. # ###################################################################### plotGeno <- function(x, chr, ind, include.xo=TRUE, horizontal=TRUE, cutoff=4, min.sep=2, cex=1.2, ...) { cross <- x if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(missing(chr)) chr <- names(cross$geno)[1] cross <- subset(cross,chr=chr) if(nchr(cross) > 1) cross <- subset(cross,chr=names(cross$geno)[1]) if(!missing(ind)) { if(is.null(getid(cross))) cross$pheno$id <- 1:nind(cross) if(!is.logical(ind)) ind <- unique(ind) cross <- subset(cross, ind=ind) } id <- getid(cross) if(is.null(id)) id <- 1:nind(cross) use.id <- TRUE type <- crosstype(cross) old.las <- par("las") on.exit(par(las=old.las)) par(las=1) if(!("errorlod" %in% names(cross$geno[[1]]))) { warning("First running calc.errorlod.") cross <- calc.errorlod(cross,error.prob=0.01) } # indicators for apparent errors errors <- matrix(0,ncol=ncol(cross$geno[[1]]$data), nrow=nrow(cross$geno[[1]]$data)) dimnames(errors) <- dimnames(cross$geno[[1]]$data) top <- top.errorlod(cross,names(cross$geno)[1],cutoff,FALSE) if(length(top) > 0) for(i in 1:nrow(top)) errors[match(top[i,2],id),as.character(top[i,3])] <- 1 # map, data, errors map <- cross$geno[[1]]$map if(is.matrix(map)) map <- map[1,] # if sex-specific map L <- diff(range(map)) min.d <- L*min.sep/100 d <- diff(map) d[d < min.d] <- min.d map <- cumsum(c(0,d)) cross$geno[[1]]$map <- map n.ind <- nrow(errors) color <- c("white","gray60","black","green","orange","red") # revise X chr data for backcross/intercross data <- cross$geno[[1]]$data chr_type <- chrtype(cross$geno[[1]]) if(chr_type=="X" && (type=="f2" || type=="bc")) data <- reviseXdata(type, sexpgm=getsex(cross), geno=data, cross.attr=attributes(cross), force=TRUE) if(include.xo) { if(type != "4way") { # find crossover locations xoloc <- locateXO(cross) xoloc <- data.frame(ind=rep(1:length(xoloc),sapply(xoloc,length)), loc=unlist(xoloc), stringsAsFactors=TRUE) } else { # 4-way cross mcross <- dcross <- cross class(mcross) <- class(dcross) <- c("bc", "cross") mcross$geno[[1]]$data[!is.na(data) & data==1 | data==3 | data==5] <- 1 mcross$geno[[1]]$data[!is.na(data) & data==2 | data==4 | data==6] <- 2 mcross$geno[[1]]$data[!is.na(data) & data==7 | data==8 | data==9 | data==10] <- NA dcross$geno[[1]]$data[!is.na(data) & data==1 | data==2 | data==7] <- 1 dcross$geno[[1]]$data[!is.na(data) & data==3 | data==4 | data==8] <- 2 dcross$geno[[1]]$data[!is.na(data) & data==5 | data==6 | data==9 | data==10] <- NA mxoloc <- locateXO(mcross) mxoloc <- data.frame(ind=rep(1:length(mxoloc),sapply(mxoloc,length)), loc=unlist(mxoloc), stringsAsFactors=TRUE) dxoloc <- locateXO(dcross) dxoloc <- data.frame(ind=rep(1:length(dxoloc),sapply(dxoloc,length)), loc=unlist(dxoloc), stringsAsFactors=TRUE) } } # check for 'main' in the ... args <- list(...) if("main" %in% names(args)) themain <- args$main else themain <- paste("Chromosome",names(cross$geno)[1]) # check for 'xlim' and 'ylim' if("xlim" %in% names(args)) thexlim <- args$xlim else thexlim <- NULL if("ylim" %in% names(args)) theylim <- args$ylim else theylim <- NULL if(type=="4way") { jit <- 0.15 mdata <- data ddata <- data # mom's allele mdata[!is.na(data) & (data==1 | data==3 | data==5)] <- 1 mdata[!is.na(data) & (data==2 | data==4 | data==6)] <- 2 mdata[!is.na(data) & (data==7 | data==8)] <- NA # dad's allele ddata[!is.na(data) & (data==1 | data==2 | data==7)] <- 1 ddata[!is.na(data) & (data==3 | data==4 | data==8)] <- 2 ddata[!is.na(data) & (data==5 | data==6)] <- NA if(horizontal) { if(is.null(thexlim)) thexlim <- c(0, max(map)) if(is.null(theylim)) theylim <- c(n.ind+1, 0) plot(0,0,type="n",xlab="Location (cM)",ylab="Individual", main=themain, ylim=theylim,xlim=thexlim, yaxt="n", yaxs="i") segments(0, 1:n.ind-jit, max(map), 1:n.ind-jit) segments(0, 1:n.ind+jit, max(map), 1:n.ind+jit) if(use.id) axis(side=2, at=1:n.ind, labels=id) else axis(side=2, at=1:n.ind) # A alleles tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=1] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind-jit,pch=21,col="black", bg=color[1],cex=cex) # B alleles tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=2] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind-jit,pch=21,col="black", bg=color[3],cex=cex) # 9/10 genotypes tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=9] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind-jit,pch=21,col="black", bg=color[4],cex=cex) tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=10] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind-jit,pch=21,col="black", bg=color[5],cex=cex) # C alleles tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=1] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind+jit,pch=21,col="black", bg=color[1],cex=cex) # D alleles tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=2] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind+jit,pch=21,col="black", bg=color[3],cex=cex) # 9/10 genotypes tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=9] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind+jit,pch=21,col="black", bg=color[4],cex=cex) tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=10] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind+jit,pch=21,col="black", bg=color[5],cex=cex) # plot map u <- par("usr") segments(map,u[3],map,u[3]-1/2) segments(map,u[4],map,u[4]+1/2) if(any(errors != 0)) { ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA points(x,ind-jit,pch=0,col=color[6],cex=cex+0.4,lwd=2) points(x,ind+jit,pch=0,col=color[6],cex=cex+0.4,lwd=2) } if(include.xo) { points(mxoloc$loc,mxoloc$ind-jit,pch=4,col="blue",lwd=2) points(dxoloc$loc,dxoloc$ind+jit,pch=4,col="blue",lwd=2) } } else { if(is.null(theylim)) theylim <- c(max(map), 0) if(is.null(thexlim)) thexlim <- c(0, n.ind+1) plot(0,0,type="n",ylab="Location (cM)",xlab="Individual", main=themain, xlim=thexlim,ylim=theylim, xaxt="n", xaxs="i") segments(1:n.ind-jit, 0, 1:n.ind-jit, max(map)) segments(1:n.ind+jit, 0, 1:n.ind+jit, max(map)) if(use.id) axis(side=1, at=1:n.ind, labels=id) else axis(side=1, at=1:n.ind) # A alleles tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=1] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind-jit,y,pch=21,col="black",bg=color[1],cex=cex) # B alleles tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=2] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind-jit,y,pch=21,col="black",bg=color[3],cex=cex) # 9/10 genotypes tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=9] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind-jit,y,pch=21,col="black", bg=color[4],cex=cex) tind <- rep(1:n.ind,length(map));tind[is.na(mdata)] <- NA ind <- tind; ind[!is.na(mdata) & mdata!=10] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind-jit,y,pch=21,col="black", bg=color[5],cex=cex) # C alleles tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=1] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind+jit,y,pch=21,col="black", bg=color[1],cex=cex) # D alleles tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=2] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind+jit,y,pch=21,col="black", bg=color[3],cex=cex) # 9/10 genotypes tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=9] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind+jit,y,pch=21,col="black", bg=color[4],cex=cex) tind <- rep(1:n.ind,length(map));tind[is.na(ddata)] <- NA ind <- tind; ind[!is.na(ddata) & ddata!=10] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind+jit,y,pch=21,col="black", bg=color[5],cex=cex) # plot map u <- par("usr") segments(u[1],map,(u[1]+1)/2,map) segments(u[2],map,(n.ind+u[2])/2,map) if(any(errors != 0)) { ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA points(ind-jit,y,pch=0,col=color[6],cex=cex+0.4,lwd=2) points(ind+jit,y,pch=0,col=color[6],cex=cex+0.4,lwd=2) } if(include.xo) { points(mxoloc$ind-jit,mxoloc$loc,pch=4,col="blue",lwd=2) points(dxoloc$ind+jit,dxoloc$loc,pch=4,col="blue",lwd=2) } } } else { if(horizontal) { if(is.null(thexlim)) thexlim <- c(0, max(map)) if(is.null(theylim)) theylim <- c(n.ind+0.5,0.5) plot(0,0,type="n",xlab="Location (cM)",ylab="Individual", main=themain, ylim=theylim,xlim=thexlim, yaxt="n") segments(0, 1:n.ind, max(map), 1:n.ind) if(use.id) axis(side=2, at=1:n.ind, labels=id) else axis(side=2) # AA genotypes tind <- rep(1:n.ind,length(map));tind[is.na(data)] <- NA ind <- tind; ind[!is.na(data) & data!=1] <- NA x <- rep(map,rep(n.ind,length(map))) points(x,ind,pch=21,col="black", bg=color[1],cex=cex) # AB genotypes ind <- tind; ind[!is.na(data) & data!=2] <- NA if(type=="f2" || (type=="bc" && chr_type=="X")) points(x,ind,pch=21,col="black", bg=color[2],cex=cex) else points(x,ind,pch=21,col="black", bg=color[3],cex=cex) if(type=="f2" || (type=="bc" && chr_type=="X")) { # BB genotypes ind <- tind; ind[!is.na(data) & data!=3] <- NA points(x,ind,pch=21,col="black", bg=color[3],cex=cex) } if(type=="f2") { # not BB (D in mapmaker/qtl) genotypes ind <- tind; ind[!is.na(data) & data!=4] <- NA points(x,ind,pch=21,col="black", bg=color[4],cex=cex) # not AA (C in mapmaker/qtl) genotypes ind <- tind; ind[!is.na(data) & data!=5] <- NA points(x,ind,pch=21,col="black", bg=color[5],cex=cex) } # plot map u <- par("usr") segments(map,u[3],map,u[3]-1/2) segments(map,u[4],map,u[4]+1/2) if(any(errors != 0)) { ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA points(x,ind,pch=0,col=color[6],cex=cex+0.4,lwd=2) } if(include.xo) points(xoloc$loc,xoloc$ind,pch=4,col="blue",lwd=2) } else { if(is.null(theylim)) theylim <- c(max(map), 0) if(is.null(thexlim)) thexlim <- c(0.5,n.ind+0.5) plot(0,0,type="n",ylab="Location (cM)",xlab="Individual", main=themain, xlim=thexlim,ylim=theylim, xaxt="n") segments(1:n.ind,0,1:n.ind,max(map)) if(use.id) axis(side=1, at=1:n.ind, labels=id) else axis(side=1) # AA genotypes tind <- rep(1:n.ind,length(map));tind[is.na(data)] <- NA ind <- tind; ind[!is.na(data) & data!=1] <- NA y <- rep(map,rep(n.ind,length(map))) points(ind,y,pch=21,col="black", bg="white",cex=cex) # AB genotypes ind <- tind; ind[!is.na(data) & data!=2] <- NA if(type=="f2" || (type=="bc" && chr_type=="X")) points(ind,y,pch=21,col="black", bg=color[2],cex=cex) else points(ind,y,pch=21,col="black", bg=color[3],cex=cex) if(type=="f2" || (type=="bc" && chr_type=="X")) { # BB genotypes ind <- tind; ind[!is.na(data) & data!=3] <- NA points(ind,y,pch=21,col="black", bg=color[3],cex=cex) } if(type=="f2") { # not BB genotypes ind <- tind; ind[!is.na(data) & data!=4] <- NA points(ind,y,pch=21,col="black", bg=color[4],cex=cex) # not AA genotypes ind <- tind; ind[!is.na(data) & data!=5] <- NA points(ind,y,pch=21,col="black", bg=color[5],cex=cex) } # plot map u <- par("usr") segments(u[1],map,(u[1]+1)/2,map) segments(u[2],map,(n.ind+u[2])/2,map) if(any(errors != 0)) { ind <- rep(1:n.ind,length(map));ind[errors!=1]<-NA points(ind,y,pch=0,col=color[6],cex=cex+0.4,lwd=2) } if(include.xo) points(xoloc$ind,xoloc$loc,pch=4,col="blue",lwd=2) } } invisible() } ###################################################################### # # plotInfo: Plot the proportion of missing information in the # genotype data. # ###################################################################### plotInfo <- function(x,chr,method=c("entropy","variance","both"), step=1, off.end=0, error.prob=0.001, map.function=c("haldane","kosambi","c-f","morgan"), alternate.chrid=FALSE, fourwaycross=c("all", "AB", "CD"), include.genofreq=FALSE, ...) { cross <- x if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") method <- match(match.arg(method),c("entropy","variance","both"))-1 map.function <- match.arg(map.function) if(!missing(chr)) cross <- subset(cross,chr=chr) n.chr <- nchr(cross) results <- NULL cross <- calc.genoprob(cross, step=step, error.prob=error.prob, off.end=off.end, map.function=map.function) gap <- 25 # 4-way cross: can consider just A/B or just C/D fourwaycross <- match.arg(fourwaycross) n.ind <- nind(cross) if(include.genofreq) theprob <- NULL for(i in 1:n.chr) { n.gen <- dim(cross$geno[[i]]$prob)[3] n.pos <- ncol(cross$geno[[i]]$prob) # 4-way cross: can consider just A/B or just C/D if(n.gen==4 && (fourwaycross!="all")) { att <- attributes(cross$geno[[i]]$prob) if(fourwaycross == "AB") { cross$geno[[i]]$prob[,,1] <- cross$geno[[i]]$prob[,,1] + cross$geno[[i]]$prob[,,3] cross$geno[[i]]$prob[,,2] <- cross$geno[[i]]$prob[,,2] + cross$geno[[i]]$prob[,,4] } else { cross$geno[[i]]$prob[,,1] <- cross$geno[[i]]$prob[,,1] + cross$geno[[i]]$prob[,,2] cross$geno[[i]]$prob[,,2] <- cross$geno[[i]]$prob[,,3] + cross$geno[[i]]$prob[,,4] } cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,,1:2] n.gen <- 2 for(j in seq(along=att)) if(names(att)[j] != "dim" && names(att)[j] != "dimnames") attr(cross$geno[[i]]$prob, names(att)[j]) <- att[[j]] } # calculate information (between 0 and 1) info <- .C("R_info", as.integer(n.ind), as.integer(n.pos), as.integer(n.gen), as.double(cross$geno[[i]]$prob), info1=as.double(rep(0,n.pos)), info2=as.double(rep(0,n.pos)), as.integer(method), PACKAGE="qtl") if(method != 1) { # rescale entropy version if(n.gen==3) maxent <- 1.5*log(2) else maxent <- log(n.gen) info$info1 <- -info$info1/maxent } if(method != 0) { # rescale variance version maxvar <- c(0.25,0.5,1.25)[n.gen-1] info$info2 <- info$info2/maxvar } # reconstruct map if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) map <- map[1,] z <- data.frame(chr=rep(names(cross$geno)[i],length(map)), pos=as.numeric(map), "Missing information"=info$info1, "Missing information"=info$info2, stringsAsFactors=TRUE) w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") rownames(z) <- w results <- rbind(results, z) if(include.genofreq) { p <- cross$geno[[i]]$prob if(chrtype(cross$geno[[i]])=="X") p <- reviseXdata(crosstype(cross), expandX="full", sexpgm=getsex(cross), prob=p, cross.attr=attributes(cross)) p <- apply(p, 2:3, mean, na.rm=TRUE) if(is.null(theprob)) theprob <- p else { m1 <- match(colnames(p), colnames(theprob)) m2 <- match(colnames(theprob), colnames(p)) if(!any(is.na(m1)) && !any(is.na(m2))) { theprob <- rbind(theprob, p[,colnames(theprob)]) } else { # some differences in column names if(all(!is.na(m1))) { # need to add some new columns to p noldcol <- ncol(p) nnewcol <- sum(is.na(m2)) for(i in 1:nnewcol) p <- cbind(p, 0) colnames(p)[-(1:noldcol)] <- colnames(theprob)[is.na(m2)] theprob <- rbind(theprob, p[,colnames(theprob)]) } else if(all(!is.na(m2))) { # need to add some new columns to theprob noldcol <- ncol(theprob) nnewcol <- sum(is.na(m1)) for(i in 1:nnewcol) theprob <- cbind(theprob, 0) colnames(theprob)[-(1:noldcol)] <- colnames(p)[is.na(m1)] theprob <- rbind(theprob, p[,colnames(theprob)]) } else { # need to add some new columns to each noldcol <- ncol(theprob) nnewcol <- sum(is.na(m1)) oldcolnam <- colnames(theprob) for(i in 1:nnewcol) theprob <- cbind(theprob, 0) colnames(theprob)[-(1:noldcol)] <- colnames(p)[is.na(m1)] noldcol <- ncol(p) nnewcol <- sum(is.na(m2)) for(i in 1:nnewcol) p <- cbind(p, 0) colnames(p)[-(1:noldcol)] <- oldcolnam[is.na(m2)] theprob <- rbind(theprob, p[,colnames(theprob)]) } } } } # end of if(include.genofreq) } colnames(results)[3:4] <- c("misinfo.entropy","misinfo.variance") if(method==0) results <- results[,-4] if(method==1) results <- results[,-3] if(include.genofreq) results <- cbind(results, theprob) class(results) <- c("scanone","data.frame") # check whether main was included as an argument args <- list(...) if("main" %in% names(args)) hasmain <- TRUE else hasmain <- FALSE # check whether gap was included as an argument if(!("gap" %in% names(args))) { if(method==0) { if(hasmain) plot.scanone(results,ylim=c(0,1),gap=gap, alternate.chrid=alternate.chrid,...) else plot.scanone(results,ylim=c(0,1),gap=gap, main="Missing information", alternate.chrid=alternate.chrid,...) } else if(method==1) { if(hasmain) plot.scanone(results,ylim=c(0,1),gap=gap, alternate.chrid=alternate.chrid,...) else plot.scanone(results,ylim=c(0,1),gap=gap, main="Missing information", alternate.chrid=alternate.chrid,...) } else if(method==2) { if(hasmain) plot.scanone(results,results,lodcolumn=1:2,ylim=c(0,1),gap=gap, alternate.chrid=alternate.chrid,...) else plot.scanone(results,results,lodcolumn=1:2,ylim=c(0,1),gap=gap, main="Missing information", alternate.chrid=alternate.chrid,...) } } else { # gap was included in ... if(method==0) { if(hasmain) plot.scanone(results,ylim=c(0,1), alternate.chrid=alternate.chrid,...) else plot.scanone(results,ylim=c(0,1), main="Missing information", alternate.chrid=alternate.chrid,...) } else if(method==1) { if(hasmain) plot.scanone(results,ylim=c(0,1), alternate.chrid=alternate.chrid,...) else plot.scanone(results,ylim=c(0,1), main="Missing information", alternate.chrid=alternate.chrid,...) } else if(method==2) { if(hasmain) plot.scanone(results,results,lodcolumn=1:2,ylim=c(0,1), alternate.chrid=alternate.chrid,...) else plot.scanone(results,results,lodcolumn=1:2,ylim=c(0,1), main="Missing information", alternate.chrid=alternate.chrid,...) } } invisible(results) } # plot phenotypes against one or more markers plotPXG <- function(x, marker, pheno.col = 1, jitter = 1, infer = TRUE, pch, ylab, main, col, ...) { cross <- x if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") type <- crosstype(cross) if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("plotPXG can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") if(!is.numeric(cross$pheno[,pheno.col])) stop("phenotype \"", colnames(cross$pheno)[pheno.col], "\" is not numeric.") if(missing(pch)) pch <- par("pch") if(missing(ylab)) ylab <- colnames(cross$pheno)[pheno.col] oldlas <- par("las") on.exit(par(las = oldlas)) par(las = 1) # find chromosomes containing the markers o <- sapply(cross$geno, function(a, b) b %in% colnames(a$data), marker) if(length(marker)==1) o <- matrix(o,nrow=1) if(!all(apply(o,1,any))) { oo <- apply(o,1,any) stop("Marker ", marker[!oo], " not found") } n.mark <- length(marker) o <- apply(o, 1, which) chr <- names(cross$geno)[o] uchr <- unique(chr) cross <- subset(cross, chr=uchr) map <- pull.map(cross) pos <- NULL for(i in seq(length(chr))) pos[i] <- map[[chr[i]]][marker[i]] chr_type <- sapply(cross$geno, chrtype) names(chr_type) <- names(cross$geno) chr_type <- chr_type[chr] # if X chromosome and backcross or intercross, get sex/direction data if(any(chr_type == "X") && (type == "bc" || type == "f2")) sexpgm <- getsex(cross) else sexpgm <- NULL # number of possible genotypes gen.names <- list() for(i in seq(length(chr))) gen.names[[i]] <- getgenonames(type, chr_type[i], "full", sexpgm, attributes(cross)) n.gen <- sapply(gen.names, length) jitter <- jitter/10 if(any(n.gen == 2)) jitter <- jitter * 0.75 # function to determine whether genotype is fully known tempf <- function(x, type) { tmp <- is.na(x) if(type=="f2") tmp[!is.na(x) & x>3] <- TRUE if(type=="4way") tmp[!is.na(x) & x>4] <- TRUE tmp } # if infer=TRUE, fill in genotype data by a single imputation if(infer) { which.missing <- tempf(cross$geno[[chr[1]]]$data[, marker[1]],type) if(n.mark > 1) for(i in 2:n.mark) which.missing <- which.missing | tempf(cross$geno[[chr[i]]]$data[,marker[i]],type) which.missing <- as.numeric(which.missing) cross <- fill.geno(cross, method = "imp") } else which.missing <- rep(1,nind(cross)) # data to plot x <- cross$geno[[chr[1]]]$data[, marker[1]] if(n.mark > 1) for(i in 2:n.mark) x <- cbind(x, cross$geno[[chr[i]]]$data[, marker[i]]) else x <- as.matrix(x) y <- cross$pheno[, pheno.col] if(!infer) { # replace partially informative genotypes with NAs if(type == "f2") x[x > 3] <- NA if(type == "4way") x[x > 4] <- NA if(sum(!is.na(x)) == 0) stop("Can't use infer=FALSE as there are no fully informative genotypes") } # in case of X chromosome, recode some genotypes if(any(chr_type == "X") && (type == "bc" || type == "f2")) { ix = seq(n.mark)[chr_type == "X"] for(i in ix) x[, i] <- as.numeric(reviseXdata(type, "full", sexpgm, geno = as.matrix(x[, i]), cross.attr=attributes(cross))) } # save all of the data, returned invisibly data <- as.data.frame(x, stringsAsFactors=TRUE) names(data) <- marker for(i in marker) data[[i]] <- ordered(data[[i]]) data$pheno <- y data$inferred <- which.missing # re-code the multi-marker genotypes if(n.mark > 1) { for(i in 2:n.mark) x[, 1] <- n.gen[i] * (x[, 1] - 1) + x[, i] } x <- x[, 1] observed <- sort(unique(x)) # amount of jitter u <- runif(nind(cross), -jitter, jitter) r <- (1 - 2 * jitter)/2 # genotype names if(n.mark == 1) gnames <- gen.names[[1]] else { gnames <- array(gen.names[[n.mark]], c(prod(n.gen), n.mark)) for(i in (n.mark - 1):1) { tmpi <- rep(gen.names[[i]], rep(prod(n.gen[(i + 1):n.mark]), n.gen[i])) if(i > 1) tmpi <- rep(tmpi, prod(n.gen[1:(i - 1)])) gnames[, i] <- tmpi } gnames <- apply(gnames, 1, function(x) paste(x, collapse = "\n")) } # create plot plot(x + u, y, xlab = "Genotype", ylab = ylab, type = "n", main = "", xlim = c(1 - r + jitter, length(gnames) + r + jitter), xaxt = "n", ...) # marker names at top if(missing(main)) mtext(paste(marker, collapse = "\n"), line=0.5, cex = ifelse(n.mark==1, 1.2, 0.8)) else title(main=main) abline(v = 1:prod(n.gen), col = "gray", lty = 3) if(length(pch) == 1) pch = rep(pch, length(x)) if(infer) { points((x + u)[which.missing == 1], y[which.missing == 1], col = "red", pch = pch[which.missing == 1]) points((x + u)[which.missing == 0], y[which.missing == 0], pch = pch[which.missing == 0]) } else points(x + u, y, pch = pch) sux = sort(unique(x)) # add confidence intervals me <- se <- array(NA, length(gnames)) me[sux] <- tapply(y, x, mean, na.rm = TRUE) se[sux] <- tapply(y, x, function(a) sd(a, na.rm = TRUE)/sqrt(sum(!is.na(a)))) thecolors <- c("black", "blue", "red", "purple", "green", "orange") if(missing(col)) { col <- thecolors[1:n.gen[n.mark]] if(n.gen[n.mark] == 3) col <- c("blue", "purple", "red") else if(n.gen[n.mark] == 2) col <- c("blue", "red") } ng <- length(gnames) segments(seq(ng) + jitter * 2, me, seq(ng) + jitter * 4, me, lwd = 2, col = col) segments(seq(ng) + jitter * 3, me - se, seq(ng) + jitter * 3, me + se, lwd = 2, col = col) segments(seq(ng) + jitter * 2.5, me - se, seq(ng) + jitter * 3.5, me - se, lwd = 2, col = col) segments(seq(ng) + jitter * 2.5, me + se, seq(ng) + jitter * 3.5, me + se, lwd = 2, col = col) # add genotypes below u <- par("usr") cxaxis <- par("cex.axis") segments(seq(along=gnames), u[3], seq(along=gnames), u[3] - diff(u[3:4]) * 0.015, xpd = TRUE) axis(side=1, at=seq(along=gnames), labels=gnames, cex=ifelse(n.mark==1, cxaxis, cxaxis*0.8), tick=FALSE, line = (length(marker)-1)/2) invisible(data) } plotPheno <- function(x, pheno.col=1, ...) { if(!inherits(x, "cross")) stop("Input should have class \"cross\".") if(LikePheVector(pheno.col, nind(x), nphe(x))) { x$pheno <- cbind(pheno.col, x$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("Ignoring all but the first element in pheno.col.") } if(is.character(pheno.col)) { num <- find.pheno(x, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(x)) warning("pheno.col should be between 1 and ", nphe(x)) phe <- x$pheno[,pheno.col] u <- length(unique(phe)) if(u==2 || (u < 10 && nind(x) > 50)) phe <- as.factor(phe) plot_pheno_sub <- function(phe, xlab=paste("phe", pheno.col), main=colnames(x$pheno)[pheno.col], col="white", breaks=ceiling(2*sqrt(nind(x))), las=1, ...) { if(is.factor(phe)) { barplot(table(phe), xlab=xlab, main=main, col=col, las=las, ...) } else { phe <- as.numeric(phe)[1:nind(x)] hist(phe, breaks = breaks, xlab = xlab, main = main, las=las, ...) } } plot_pheno_sub(phe, ...) } # end of plot.R qtl/R/effectplot.R0000644000176200001440000007407213576241200013543 0ustar liggesusers###################################################################### # # effectplot.R # # copyright (c) 2002-2019, Hao Wu and Karl W. Broman # Last modified Dec, 2019 # first written Jul, 2002 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Modified by Hao Wu Feb 2005 for the following: # 1. function will take marker, pseudomarker or phenotype as input; # 2. separate functions to extract marker genodata given marker names # and calculate means and ses; # # Part of the R/qtl package # Contains: effectplot, effectplot.getmark, effectplot.calmeanse # ###################################################################### effectplot <- function (cross, pheno.col = 1, mname1, mark1, geno1, mname2, mark2, geno2, main, ylim, xlab, ylab, col, add.legend = TRUE, legend.lab, draw=TRUE, var.flag=c("pooled","group")) { if(!inherits(cross, "cross")) stop("The first input variable must be an object of class cross") if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } # if mname2 is given but not mname1, switch it around if((missing(mname1) && missing(mark1) && missing(geno1)) && any(!missing(mname2) || missing(mark2) || missing(geno2))) { if(!missing(mname2)) { mname1 <- mname2; mname2 <- NULL } if(!missing(mark2)) { mark1 <- mark2; mark2 <- NULL } if(!missing(geno2)) { geno1 <- geno2; geno2 <- NULL } } if(missing(mark2)) mark2 <- NULL if(missing(mname2)) mname2 <- NULL if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("effectplot can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") if(!is.numeric(cross$pheno[,pheno.col])) stop("phenotype \"", colnames(cross$pheno)[pheno.col], "\" is not numeric.") var.flag <- match.arg(var.flag) # local variables n.ind <- nind(cross) pheno <- cross$pheno[, pheno.col] type <- crosstype(cross) chr_type1 <- chr_type2 <- "A" gennames1 <- gennames2 <- NULL # If imputations are not available, create them if(!("draws" %in% names(cross$geno[[1]]))) { warning(" -Running sim.geno.") cross <- sim.geno(cross, n.draws=16) } #################################################### # get genotype data for markers given marker name # if marker genodata were given, this will be skipped #################################################### # used for alternative print name for pseudomarkers pm.pattern <- "^c.*\\.loc.*$" # pseudomarker names will be like "c1.loc10" dig <- 1 step <- attr(cross$geno[[1]]$draws, "step") if(!is.null(step)) { if(step > 0) dig <- max(dig, -floor(log10(step))) } else { stepw <- attr(cross$geno[[1]]$draws, "stepwidth") if(!is.null(stepw) && stepw > 0) dig <- max(dig, -floor(log10(stepw))) } printname1 <- printname2 <- NULL # Get marker 1 genotype data if(missing(mark1)) { # no data given if(missing(mname1)) # no marker data or marker name, have to stop stop("Either mname1 or mark1 must be specified.") # get marker data according to marker name tmp <- effectplot.getmark(cross, mname1) tmptmp <- attr(tmp, "mname") if(!is.null(tmptmp)) mname1 <- tmptmp mark1 <- tmp$mark gennames1 <- tmp$genname # perhaps alternative print name if(length(grep(pm.pattern, mname1))>0) { tmp <- find.pseudomarkerpos(cross, mname1, "draws") printname1 <- paste(tmp[1,1], charround(tmp[1,2],dig), sep="@") } } else { # make mark1 a matrix if it's not if(!is.matrix(mark1)) mark1 <- matrix(mark1, ncol=1) if(dim(mark1)[1] != n.ind) stop("Marker 1 data has the wrong dimension") if(missing(mname1)) mname1 <- "Marker 1" } if(is.null(printname1)) printname1 <- mname1 # Deal with marker 2 if(!is.null(mname2) || !is.null(mark2)) { if(is.null(mark2)) { # get marker data according to marker name tmp <- effectplot.getmark(cross, mname2) tmptmp <- attr(tmp, "mname") if(!is.null(tmptmp)) mname2 <- tmptmp mark2 <- tmp$mark gennames2 <- tmp$genname # perhaps alternative print name if(length(grep(pm.pattern, mname2))>0) { tmp <- find.pseudomarkerpos(cross, mname2, "draws") printname2 <- paste(tmp[1,1], charround(tmp[1,2],dig), sep="@") } } else { # mark2 data is given # make mark2 a matrix if it's not if(!is.matrix(mark2)) mark2 <- matrix(mark2, ncol=1) if(dim(mark2)[1] != n.ind) stop("Marker 2 data has the wrong dimension") if(is.null(mname2)) mname2 <- "Marker 2" } if(is.null(printname2)) printname2 <- mname2 } else { mark2 <- NULL geno2 <- NULL } ### till now, mark1 and mark2 are genotype data in matrix ######################################################## # deal with the data - if one of them is a pseudomarker, # make the other one the same number of draws ######################################################## # determine number of draws - this part of codes works even if mark2 is NULL ndraws1 <- dim(mark1)[2] if(is.null(mark2)) ndraws2 <- 1 else ndraws2 <- dim(mark2)[2] # make them the same number of draws if( (ndraws1>1) && (ndraws2>1) ) { # two pseudomarkers, they must have the same number of draws if(ndraws1 != ndraws2) stop("Input two pseudomarkers have different number of draws.") else ndraws <- ndraws1 } else if( (ndraws1>1) && (ndraws2==1) ) { # one pm and one typed marker if(!is.null(mark2)) mark2 <- matrix(rep(mark2,ndraws1), ncol=ndraws1) ndraws <- ndraws1 } else if( (ndraws1==1) && (ndraws2>1) ) { # one pm and one typed marker mark1 <- matrix(rep(mark1,ndraws2), ncol=ndraws2) ndraws <- ndraws2 } else # they are all real markers ndraws <- 1 # drop data for individuals with missing phenotypes or genotypes keepind <- !is.na(pheno) if(!is.null(mark1)) keepind <- keepind & apply(mark1, 1, function(a) all(!is.na(a))) if(!is.null(mark2)) keepind <- keepind & apply(mark2, 1, function(a) all(!is.na(a))) mark1 <- mark1[keepind,] mark2 <- mark2[keepind,] pheno <- pheno[keepind] ######################################################## # 1. get level names - this part will be executed when # user only input mark without mname and geno # 2. adjust marker data if the input is not numeric ######################################################## tmpf <- factor(mark1) if(!missing(geno1)) { # geno1 is given # check if it has the correct length if(length(geno1) < length(levels(tmpf))) stop("geno1 is too short.") } else { # geno1 is not given if(!is.null(gennames1)) # get it from genname1 geno1 <- gennames1 else if(is.factor(mark1)) { # or if it's factor, get it from level geno1 <- levels(mark1) mark1 <- as.numeric(mark1) } else if(!is.numeric(mark1)) { # if it's neither factor nor numeric, it must be a string vector # such like c("F","M","F")... geno1 <- levels(tmpf) } else { # otherwise, generate a standard one geno1 <- getgenonames(type, "A", cross.attr=attributes(cross)) if(length(levels(tmpf)) > length(geno1)) geno1 <- c(geno1, rep("?", length(levels(tmpf)) - length(geno1))) } } # adjust marker data - if the input is not numeric, convert them into numeric if(!is.numeric(mark1)) mark1 <- matrix(as.numeric(tmpf, levels=sort(levels(tmpf))), ncol=ndraws) # Now work on mark2 if(!is.null(mark2)) { tmpf <- factor(mark2) if(!missing(geno2)) { # geno2 is given # check if it has the correct length if(length(geno2) < length(levels(tmpf))) stop("geno2 is too short.") } else { # geno2 is not given if(!is.null(gennames2)) # get it from genname2 geno2 <- gennames2 else if(is.factor(mark2)) { # or if it's factor, get it from level geno2 <- levels(mark2) mark2 <- as.numeric(mark2) } else if(!is.numeric(mark2)) { # if it's neither factor nor numberic, it must be a string vector # such like c("F","M","F")... geno2 <- levels(tmpf) } else { # otherwise, generate a standard one geno2 <- getgenonames(type, "A", cross.attr=attributes(cross)) if(length(levels(tmpf)) > length(geno2)) geno2 <- c(geno2, rep("?", length(levels(tmpf)) - length(geno2))) } } # adjust marker data - if the input is not numeric, convert them into numeric if(!is.numeric(mark2)) mark2 <- matrix(as.numeric(tmpf, levels=sort(levels(tmpf))), ncol=ndraws) } # number of genotypes ngen1 <- length(geno1) if(!is.null(mark2)) ngen2 <- length(geno2) # calculate means and ses # and make output object # the output will be a data frame. For two-marker case, # the rows corresponding to the first marker and the columns # corresponding to the second marker result <- effectplot.calmeanse(pheno, mark1, mark2, geno1, geno2, ndraws, var.flag) means <- result$Means ses <- result$SEs # assign column and row names if(is.null(mark2)) { if(length(means) != length(geno1)) { warning("Number of genotypes is different than length(geno1).") if(length(means) < length(geno1)) geno1 <- geno1[1:length(means)] else geno1 <- c(geno1, rep("?", length(means) - length(geno1))) ngen1 <- length(geno1) } names(result$Means) <- paste(printname1, geno1, sep = ".") names(result$SEs) <- paste(printname1, geno1, sep = ".") } else { if(nrow(means) != length(geno1)) { warning("Number of genotypes in marker 1 is different than length(geno1).") if(nrow(means) < length(geno1)) geno1 <- geno1[1:nrow(means)] else geno1 <- c(geno1, rep("?", nrow(means) - length(geno1))) ngen1 <- length(geno1) } if(ncol(means) != length(geno2)) { warning("Number of genotypes in marker 2 is different than length(geno2).") if(ncol(means) < length(geno2)) geno2 <- geno2[1:ncol(means)] else geno2 <- c(geno2, rep("?", ncol(means) - length(geno2))) ngen2 <- length(geno2) } rownames(result$Means) <- paste(printname1, geno1, sep = ".") colnames(result$Means) <- paste(printname2, geno2, sep = ".") rownames(result$SEs) <- paste(printname1, geno1, sep = ".") colnames(result$SEs) <- paste(printname2, geno2, sep = ".") } # calculate lo's and hi's for plot lo <- means - ses hi <- means + ses ######### Draw the figure if requested ############ if(draw) { # graphics parameters old.xpd <- par("xpd") old.las <- par("las") par(xpd = FALSE, las = 1) on.exit(par(xpd = old.xpd, las = old.las)) # colors (for case of two markers) if(missing(col)) { if(ngen1 <= 5) { if(ngen1 == 1) int.color <- "black" else if(ngen1 == 2) int.color <- c("red", "blue") else int.color <- c("black", "red", "blue", "orange", "green")[1:ngen1] } else int.color <- c("black", rainbow(ngen1-1, start=0, end=2/3)) } else int.color <- col # plot title if(missing(main)) { if(is.null(mark2)) main <- paste("Effect plot for", printname1) else main <- paste("Interaction plot for", printname1, "and", printname2) } # y axis limits if(missing(ylim)) { ylimits <- range(c(lo, means, hi), na.rm = TRUE) ylimits[2] <- ylimits[2] + diff(ylimits) * 0.1 } else ylimits <- ylim # x axis limits if(is.null(mark2)) { # one marker u <- seq(along=geno1) d <- diff(u[1:2]) xlimits <- c(min(u) - d/4, max(u) + d/4) } else { # two markers u <- seq(along=geno2) d <- diff(u[1:2]) xlimits <- c(min(u) - d/4, max(u) + d/4) } ## fix of x limits d <- 1 xlimits <- c(1 - d/4, length(u) + d/4) if(is.null(mark2)) { # single marker if(missing(xlab)) xlab <- printname1 if(missing(ylab)) ylab <- names(cross$pheno)[pheno.col] if(missing(col)) col <- "black" # plot the means plot(1:ngen1, means, main = main, xlab = xlab, ylab = ylab, pch = 1, col = col[1], ylim = ylimits, xaxt = "n", type = "b", xlim = xlimits) # confidence limits for(i in 1:ngen1) { if(!is.na(lo[i]) && !is.na(hi[i])) lines(c(i, i), c(lo[i], hi[i]), pch = 3, col = col[1], type = "b", lty = 3) } # X-axis ticks a <- par("usr") ystart <- a[3] yend <- ystart - diff(a[3:4]) * 0.02 ytext <- ystart - diff(a[3:4]) * 0.05 # for(i in 1:ngen1) { # lines(x = c(i, i), y = c(ystart, yend), xpd = TRUE) # text(i, ytext, geno1[i], xpd = TRUE) # } axis(side=1, at=1:ngen1, labels=geno1) } else { # two markers if(missing(xlab)) xlab <- printname2 if(missing(ylab)) ylab <- names(cross$pheno)[pheno.col] # plot the first genotype of marker 1 plot(1:ngen2, means[1, ], main = main, xlab = xlab, ylab = ylab, pch = 1, col = int.color[1], ylim = ylimits, xaxt = "n", type = "b", xlim = xlimits) # confidence limits for(i in 1:ngen2) { if(!is.na(lo[1, i]) && !is.na(hi[1, i])) lines(c(i, i), c(lo[1, i], hi[1, i]), pch = 3, col = int.color[1], type = "b", lty = 3) } for(j in 2:ngen1) { # for the rest of genotypes for Marker 1 lines(1:ngen2, means[j, ], col = int.color[j], pch = 1, type = "b") # confidence limits for(i in 1:ngen2) { if(!is.na(lo[j, i]) && !is.na(hi[j, i])) lines(c(i, i), c(lo[j, i], hi[j, i]), pch = 3, col = int.color[j], type = "b", lty = 3) } } # draw X-axis ticks a <- par("usr") ystart <- a[3] yend <- ystart - diff(a[3:4]) * 0.02 ytext <- ystart - diff(a[3:4]) * 0.05 # for(i in 1:ngen2) { # lines(x = c(i, i), y = c(ystart, yend), xpd = TRUE) # text(i, ytext, geno2[i], xpd = TRUE) # } axis(side=1, at=1:ngen2, labels=geno2) # add legend if(add.legend) { col <- int.color[1:ngen1] # legend position x.leg <- a[1]*0.25+a[2]*0.75 y.leg <- a[4] - diff(a[3:4]) * 0.05 y.leg2 <- a[4] - diff(a[3:4]) * 0.03 legend(x.leg, y.leg, geno1, lty = 1, pch = 1, col = col, cex = 1, xjust = 0.5) if(missing(legend.lab)) legend.lab <- printname1 text(x.leg, y.leg2, legend.lab) } } } return(invisible(result)) } ############################################## # function to get genotype data for a marker # given marker name ############################################## effectplot.getmark <- function (cross, mname) { # cross type type <- crosstype(cross) # return variables mark <- NULL gennames <- NULL # for pseudomarkers refered to as "1@10.5": # - check that it is not a phenotype or marker name # - otherwise convert to the usual name via find.pseudomarker pmalt.pattern <- "@-*[0-9]+" # alternate way to refer to a pseudomarker ("1@10.5") if(length(grep(pmalt.pattern, mname))>0 && !(mname %in% names(cross$pheno) || mname %in% colnames(pull.geno(cross)))) { ss <- unlist(strsplit(mname, "@")) if(!(ss[1] %in% names(cross$geno))) stop("Don't understand the marker name ", mname) mname <- find.pseudomarker(cross, ss[1], as.numeric(ss[2]), "draws") } # determine marker type - it could be a marker, a pseudomarker or a phenotype mar.type <- "none" # regular expression pattern for a pseudomarker names pm.pattern <- "^c.*\\.loc.*$" # pseudomarker names will be like "c1.loc10" if(mname %in% names(cross$pheno)) { # this is a phenotype mar.type <- "pheno" idx.pos <- which(mname==names(cross$pheno)) } else if(length(grep(pm.pattern, mname)) > 0) { # like "c1.loc10", this is a pseudomarker # note that the column names for draws is like "loc10", # so I need to take the part after "." in mname tmp <- unlist(strsplit(mname, "loc")) chr <- substr(tmp[1],2,nchar(tmp[1])-1) # this will be like 1 or "X" if( !(chr %in% names(cross$geno)) ) stop("Couldn't find marker ", mname) mar.type <- "pm" chr_type <- chrtype(cross$geno[[chr]]) pm.name <- paste("loc", tmp[2],sep="") # this will be like loc10 idx.pos <- which(pm.name==colnames(cross$geno[[chr]]$draws)) if(length(idx.pos) == 0) stop("Couldn't find marker ", mname) else if(length(idx.pos)>1) # take the first one for multiple markers with the same name idx.pos <- idx.pos[1] } else { # this is a real marker name but it could be a observed or imputed for(i in 1:length(cross$geno)) { if(mname %in% colnames(cross$geno[[i]]$draws)) { # this is a pseudomarker mar.type <- "pm" chr <- i chr_type <- chrtype(cross$geno[[chr]]) idx.pos <- which(mname == colnames(cross$geno[[i]]$draws)) break } else if(mname %in% colnames(cross$geno[[i]]$data)) { # this is a typed marker mar.type <- "marker" chr <- i chr_type <- chrtype(cross$geno[[i]]) idx.pos <- which(mname == colnames(cross$geno[[i]]$data)) break } } } # if didn't find this marker if(mar.type == "none") stop("Marker ", mname, " not found") # get data from typed marker, pseudomarker or phenotype if(mar.type == "pheno") { # this is a phenotype mark <- cross$pheno[,idx.pos] # the phenotype need to be categorical if(length(unique(mark)) > 5) { # I'm using arbitrary number here stop("The input phenotype ", mname, " is not a categorical trait") } gennames <- sort(unique(mark)) } else if(mar.type=="marker") { # this is a real marker mark <- cross$geno[[chr]]$data[, idx.pos] # if X chr and backcross or intercross, get sex/dir data + revise data if(chr_type == "X" && (type %in% c("bc","f2","bcsft"))) { sexpgm <- getsex(cross) mark <- as.numeric(reviseXdata(type, "full", sexpgm, geno = as.matrix(mark), cross.attr=attributes(cross))) gennames <- getgenonames(type, chr_type, "full", sexpgm, attributes(cross)) } } else if(mar.type=="pm") { # this is a pseudomarker # get the imputed genotype data for this marker mark <- cross$geno[[chr]]$draws[,idx.pos,,drop=FALSE] # if X chr and backcross or intercross, get sex/dir data + revise data if(chr_type == "X" && (type %in% c("bc","f2","bcsft"))) { sexpgm <- getsex(cross) mark <- reviseXdata(type, "full", sexpgm, draws=mark, cross.attr=attributes(cross))[,1,] gennames <- getgenonames(type, chr_type, "full", sexpgm, attributes(cross)) } else mark <- mark[,1,] } else # none of the above stop("Couldn't find marker ", mname) # make mark a matrix if it's not one if(!is.matrix(mark)) mark <- matrix(mark, ncol=1) # return ret <- list(mark=mark, gennames=gennames) attr(ret, "mname") <- mname ret } ############################################## # function to calculate the means and ses # if ndraws is 1, it's easy # if ndraws > 1 (has pseudomarker), # loop thru the draws ############################################## effectplot.calmeanse <- function(pheno, mark1, mark2, geno1, geno2, ndraws, var.flag=c("pooled","group")) { # local variables nind <- length(pheno) # method to calculate variances for estimated QTL effects var.flag <- match.arg(var.flag) result <- NULL nind <- sum(!is.na(pheno)) # number of individuals if(is.null(mark2)) { # if mark2 is missing if(ndraws > 1) { # more than one draws mark1.level <- seq(along=geno1) # level for mark1 # init means.all <- matrix(NA, nrow=ndraws, ncol=length(mark1.level)) colnames(means.all) <- mark1.level vars.all <- matrix(NA, nrow=ndraws, ncol=length(mark1.level)) colnames(vars.all) <- mark1.level weight <- rep(0, ndraws) # weight for draws # loop thru draws for(i in 1:ndraws) { mark1.tmp <- mark1[,i] # data for current draw # fit a regression - this is used to calculate the weights mark1.factor <- factor(mark1.tmp, mark1.level) lm.tmp <- lm(pheno~mark1.factor-1) rss <- sum(lm.tmp$residuals^2) # compute the weight weight[i] <- (-nind/2)*log(rss) # group means means.tmp <- tapply(pheno, mark1.tmp, mean, na.rm = TRUE) # calculate group means and variances if(var.flag=="group") { # use variance in each group vars.tmp <- tapply(pheno, mark1.tmp, function(a) var(a,na.rm = TRUE)/length(a)) } else { # use pooled variance vars.tmp <- tapply(mark1.tmp, mark1.tmp, function(a) rss/nind/length(a)) } # note that there could be missing categories in draws means.all[i, names(means.tmp)] <- means.tmp vars.all[i, names(vars.tmp)] <- vars.tmp } # average across draws - for vars, it should be # mean of variance plus variance of means weight <- exp(weight-max(weight)) means <- apply(means.all, 2, function(a) weighted.mean(a,weight,na.rm=TRUE)) meanvar <- apply(vars.all, 2, function(a) weighted.mean(a,weight,na.rm=TRUE)) # mean of vars varmean <- apply(means.all, 2, function(a) weighted.mean((a-mean(a,na.rm=TRUE))^2,weight,na.rm=TRUE)) # var of means measured <- apply(means.all, 2, function(a) sum(!is.na(a))) means[measured==0] <- meanvar[measured==0] <- varmean[measured==0] <- NA # standard error ses <- sqrt(meanvar+varmean) } else { # ndraws is 1 u <- sort(unique(mark1)) if(any(!(u %in% seq(along=geno1)))) { newmark1 <- mark1 for(i in seq(along=u)) newmark1[mark1==u[i]] <- i mark1 <- newmark1 } means <- tapply(pheno, mark1, mean, na.rm = TRUE) if(var.flag == "group") { # use group variance ses <- tapply(pheno, mark1, function(a) sd(a, na.rm = TRUE)/sqrt(sum(!is.na(a)))) } else { # use pooled variance mark1.factor <- factor(mark1, seq(along=geno1)) lm.tmp <- lm(pheno~mark1.factor-1) rss <- sum(lm.tmp$residuals^2) ses <- tapply(mark1, mark1, function(a) sqrt(rss/nind/length(a))) } } } else { # with mark2 if(ndraws > 1) { mark1.level <- seq(along=geno1) # level for mark1 mark2.level <- seq(along=geno2) # level for mark2 u <- sort(unique(as.numeric(mark1))) if(any(!(u %in% seq(along=geno1)))) { newmark1 <- mark1 for(i in seq(along=u)) for(j in 1:ncol(mark2)) newmark1[mark1[,j]==u[i],j] <- i mark1 <- newmark1 } u <- sort(unique(as.numeric(mark2))) if(any(!(u %in% seq(along=geno2)))) { newmark2 <- mark2 for(i in seq(along=u)) for(j in 1:ncol(mark2)) newmark2[mark2[,j]==u[i],j] <- i mark2 <- newmark2 } # init means.all <- array(NA, c(length(mark1.level), length(mark2.level), ndraws)) dimnames(means.all) <- list(mark1.level, mark2.level, NULL) vars.all <- array(NA, c(length(mark1.level), length(mark2.level), ndraws)) dimnames(vars.all) <- list(mark1.level, mark2.level, NULL) weight <- rep(0, ndraws) # weight for draws # loop thru draws for(i in 1:ndraws) { mark1.tmp <- mark1[,i] # data for current draw mark2.tmp <- mark2[,i] # fit a regression - this is used to calculate the weights mark1.factor <- factor(mark1.tmp, mark1.level) mark2.factor <- factor(mark2.tmp, mark2.level) lm.tmp <- lm(pheno~mark1.factor+mark2.factor+1) rss <- sum(lm.tmp$residuals^2) # compute the weight weight[i] <- (-nind/2)*log(rss) # group means means.tmp <- tapply(pheno, list(mark1.tmp, mark2.tmp), mean, na.rm = TRUE) # calculate group means and variances if(var.flag=="group") { # use variance in each group vars.tmp <- tapply(pheno, list(mark1.tmp,mark2.tmp), function(a) var(a,na.rm = TRUE)/length(a)) } else { # use pooled variance vars.tmp <- tapply(mark1.tmp, list(mark1.tmp,mark2.tmp), function(a) rss/nind/length(a)) } # note that there could be missing categories in draws means.all[dimnames(means.tmp)[[1]], dimnames(means.tmp)[[2]],i] <- means.tmp vars.all[dimnames(vars.tmp)[[1]], dimnames(vars.tmp)[[2]], i] <- vars.tmp } # average across draws - for vars, it should be # mean of variance plus variance of means weight <- exp(weight-max(weight)) means <- apply(means.all, c(1,2), function(a) weighted.mean(a,weight,na.rm=TRUE)) meanvar <- apply(vars.all, c(1,2), function(a) weighted.mean(a,weight,na.rm=TRUE)) varmean <- apply(means.all, c(1,2), function(a) weighted.mean((a-mean(a,na.rm=TRUE))^2,weight,na.rm=TRUE)) # var of means measured <- apply(means.all, c(1,2), function(a) sum(!is.na(a))) means[measured==0] <- meanvar[measured==0] <- varmean[measured==0] <- NA # standard error ses <- sqrt(meanvar+varmean) } else { # ndraws is 1 u <- sort(unique(mark1)) if(any(!(u %in% seq(along=geno1)))) { newmark1 <- mark1 for(i in seq(along=u)) newmark1[mark1==u[i]] <- i mark1 <- newmark1 } u <- sort(unique(mark2)) if(any(!(u %in% seq(along=geno2)))) { newmark2 <- mark2 for(i in seq(along=u)) newmark2[mark2==u[i]] <- i mark2 <- newmark2 } mark1 <- factor(mark1, seq(along=geno1)) mark2 <- factor(mark2, seq(along=geno2)) means <- tapply(pheno, list(mark1, mark2), mean, na.rm = TRUE) if(var.flag=="group") { # use group variance ses <- tapply(pheno, list(mark1, mark2), function(a) sd(a, na.rm = TRUE)/sqrt(sum(!is.na(a)))) } else {# use pooled variance lm.tmp <- lm(pheno~mark1+mark2-1) rss <- sum(lm.tmp$residuals^2) ses <- tapply(mark1, list(mark1, mark2), function(a) sqrt(rss/nind/length(a))) } } } # result result$Means <- means result$SEs <- ses result } # end of effectplot.R qtl/R/read.cross.csvs.R0000644000176200001440000003234714502047163014431 0ustar liggesusers###################################################################### # # read.cross.csvs.R # # copyright (c) 2005-2020, Karl W Broman # last modified Feb, 2020 # first written Oct, 2005 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.csvs # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.csvs # # read data in comma-delimited format, with separate files for phenotype # and genotype data # ###################################################################### read.cross.csvs <- function(dir, genfile, phefile, na.strings=c("-","NA"), genotypes=c("A","H","B","D","C"), estimate.map=TRUE, rotate=FALSE, ...) { # create file names if(missing(genfile)) genfile <- "gen.csv" if(missing(phefile)) phefile <- "phe.csv" if(!missing(dir) && dir != "") { genfile <- file.path(dir, genfile) phefile <- file.path(dir, phefile) } args <- list(...) if("" %in% na.strings) { na.strings <- na.strings[na.strings != ""] warning("Including \"\" in na.strings will cause problems; omitted.") } # if user wants to use comma for decimal point, we need if(length(args) > 0 && "dec" %in% names(args)) { dec <- args[["dec"]] } else dec <- "." # read the data file if(length(args) < 1 || !("sep" %in% names(args))) { # "sep" not in the "..." argument and so take sep="," if(length(args) < 1 || !("comment.char" %in% names(args))) { gen <- read.table(genfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) pheno <- read.table(phefile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) } else { gen <- read.table(genfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) pheno <- read.table(phefile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } } else { if(length(args) < 1 || !("comment.char" %in% names(args))) { gen <- read.table(genfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) pheno <- read.table(phefile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) } else { gen <- read.table(genfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) pheno <- read.table(phefile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } } if(rotate) { gen <- as.data.frame(t(gen), stringsAsFactors=FALSE) pheno <- as.data.frame(t(pheno), stringsAsFactors=FALSE) } # We must make the first column have the individual IDs indname <- gen[1,1] if(gen[3,1] == "") { genind <- gen[-(1:3),1] map.included <- TRUE nondatrow <- 3 # last non-data row } else { genind <- gen[-(1:2),1] map.included <- FALSE nondatrow <- 2 # last non-data row } gen <- gen[,-1,drop=FALSE] wh <- which(pheno[1,] == indname) if(length(wh) < 1) stop("Can't find the individual ID column (expected '", indname, "') in the phenotype file.") pheind <- pheno[-1,wh[1]] if(length(genind) == length(pheind) && all(genind == pheind)) { if(length(genind) != length(unique(genind))) warning("Duplicate individual IDs") } else { if(any(is.na(genind)) && any(is.na(pheind))) stop("There are missing genotype and phenotype IDs") else if(any(is.na(genind))) stop("There are missing genotype IDs") else if(any(is.na(pheind))) stop("There are missing phenotype IDs") if(length(genind) != length(unique(genind)) && length(pheind) != length(unique(pheind))) stop("There are duplicate genotype and phenotype IDs, and they don't all line up.") else if(length(genind) != length(unique(genind))) stop("There are duplicate genotype IDs, and the genotype and phenotype IDs don't all line up.") else if(length(pheind) != length(unique(pheind))) stop("There are duplicate phenotype IDs, and the genotype and phenotype IDs don't all line up.") mgp <- match(genind, pheind) if(any(is.na(mgp))) { # individuals with genotypes but no phenotypes n.add <- sum(is.na(mgp)) pheind <- c(pheind, genind[is.na(mgp)]) pheno <- rbind(pheno, matrix(rep(NA, n.add*ncol(pheno)), ncol=ncol(pheno))) pheno[-1, wh[1]] <- pheind warning(n.add, " individuals with genotypes but no phenotypes\n ", paste(genind[is.na(mgp)], collapse="|"), "\n") } mpg <- match(pheind, genind) if(any(is.na(mpg))) { n.add <- sum(is.na(mpg)) genind <- c(genind, pheind[is.na(mpg)]) genadd <- matrix(rep(NA, n.add*ncol(gen)), ncol=ncol(gen)) colnames(genadd) <- colnames(gen) gen <- rbind(gen, genadd) warning(n.add, " individuals with phenotypes but no genotypes\n ", paste(pheind[is.na(mpg)], collapse="|"), "\n") } mgp <- match(genind, pheind) pheind <- pheind[mgp] pheno <- pheno[1+c(0,mgp),,drop=FALSE] } n.phe <- ncol(pheno) if(map.included) { map <- asnumericwithdec(unlist(gen[3,]), dec=dec) if(any(is.na(map))) { temp <- unique(unlist(gen[3,])[is.na(map)]) stop("There are missing marker positions.\n", " In particular, we see these value(s): ", paste("\"",paste(temp,collapse="\",\"",sep=""),"\"",collapse=" ",sep=""), " at position(s): ", paste(which(is.na(map)),colapse=",",sep=""),sep="") } } else map <- rep(0,ncol(gen)) colnames_pheno <- unlist(pheno[1,]) pheno <- apply(pheno, 2, function(a) { a[!is.na(a) & a==""] <- NA; a }) pheno <- as.data.frame(pheno[-1,], stringsAsFactors=TRUE) colnames(pheno) <- colnames_pheno # replace empty cells with NA gen <- sapply(gen,function(a) { a[!is.na(a) & a==""] <- NA; a }) # pull apart phenotypes, genotypes and map mnames <- unlist(gen[1,]) if(any(is.na(mnames))) stop("There are missing marker names. Check column(s) ",paste(which(is.na(mnames))+1+n.phe,collapse=","),sep="") chr <- unlist(gen[2,]) if(any(is.na(chr))) stop("There are missing chromosome IDs. Check column(s) ",paste(which(is.na(chr))+1+n.phe,collapse=","),sep="") if(any(is.na(chr))) { na.positions <- which(is.na(chr)) na.positions.str <- "" if (length(na.positions)<10) { na.positions.str <- paste(" at position(s) ", paste(na.positions,collapse=",",sep=""),sep="") } stop("There are ", length(na.positions), " missing chromosome IDs", na.positions.str, ".") } # look for strange entries in the genotype data if(length(genotypes) > 0) { temp <- unique(as.character(gen[-(1:nondatrow),,drop=FALSE])) temp <- temp[!is.na(temp)] wh <- !(temp %in% genotypes) if(any(wh)) { warn <- "The following unexpected genotype codes were treated as missing.\n " ge <- paste("|", paste(temp[wh],collapse="|"),"|",sep="") warn <- paste(warn,ge,"\n",sep="") warning(warn) } # convert genotype data allgeno <- matrix(match(gen[-(1:nondatrow),,drop=FALSE],genotypes), ncol=ncol(gen)) } else allgeno <- matrix(as.numeric(gen[-(1:nondatrow),,drop=FALSE]), ncol=ncol(gen)) pheno <- data.frame(lapply(pheno, sw2numeric, dec=dec), stringsAsFactors=TRUE) # re-order the markers by chr and position # try to figure out the chr labels if(all(chr %in% c(1:999,"X","x"))) { # 1...19 + X tempchr <- chr tempchr[chr=="X" | chr=="x"] <- 1000 tempchr <- as.numeric(tempchr) if(map.included) neworder <- order(tempchr, map) else neworder <- order(tempchr) } else { # don't let it reorder the chromosomes tempchr <- factor(chr, levels=unique(chr)) if(map.included) neworder <- order(tempchr, map) else neworder <- order(tempchr) } chr <- chr[neworder] map <- map[neworder] allgeno <- allgeno[,neworder,drop=FALSE] mnames <- mnames[neworder] # fix up dummy map if(!map.included) { map <- split(rep(0,length(chr)),chr)[unique(chr)] map <- unlist(lapply(map,function(a) seq(0,length=length(a),by=5))) names(map) <- NULL } # fix up map information # number of chromosomes uchr <- unique(chr) n.chr <- length(uchr) geno <- vector("list",n.chr) names(geno) <- uchr min.mar <- 1 allautogeno <- NULL for(i in 1:n.chr) { # loop over chromosomes # create map temp.map <- map[chr==uchr[i]] names(temp.map) <- mnames[chr==uchr[i]] # pull out appropriate portion of genotype data data <- allgeno[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE] min.mar <- min.mar + length(temp.map) colnames(data) <- names(temp.map) geno[[i]] <- list(data=data,map=temp.map) if(uchr[i] == "X" || uchr[i] == "x") class(geno[[i]]) <- "X" else { class(geno[[i]]) <- "A" if(is.null(allautogeno)) allautogeno <- data else allautogeno <- cbind(allautogeno,data) } } if(is.null(allautogeno)) allautogeno <- allgeno # check that data dimensions match n.mar1 <- sapply(geno,function(a) ncol(a$data)) n.mar2 <- sapply(geno,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(geno,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { cat(n.ind1,n.ind2,"\n") stop("Number of individuals in genotypes and phenotypes do not match."); } if(any(n.mar1 != n.mar2)) { cat(n.mar1,n.mar2,"\n") stop("Numbers of markers in genotypes and marker names files do not match."); } # print some information about the amount of data read cat(" --Read the following data:\n"); cat("\t", n.ind1, " individuals\n"); cat("\t", sum(n.mar1), " markers\n"); cat("\t", n.phe, " phenotypes\n"); if(all(is.na(allgeno))) warning("There is no genotype data!\n") # determine map type: f2 or bc or 4way? if(all(is.na(allgeno))) warning("There is no genotype data!\n") if(all(is.na(allautogeno)) || max(allautogeno,na.rm=TRUE)<=2) type <- "bc" else if(max(allautogeno,na.rm=TRUE)<=5) type <- "f2" else type <- "4way" cross <- list(geno=geno,pheno=pheno) class(cross) <- c(type,"cross") # check that nothing is strange in the genotype data if(type=="f2") max.gen <- 5 else if(type=="bc") max.gen <- 2 else max.gen <- 14 # check that markers are in proper order # if not, fix up the order for(i in 1:n.chr) { if(any(diff(cross$geno[[i]]$map)<0)) { o <- order(cross$geno[[i]]$map) cross$geno[[i]]$map <- cross$geno[[i]]$map[o] cross$geno[[i]]$data <- cross$geno[[i]]$data[,o,drop=FALSE] } } # estimate genetic map if(estimate.map && !map.included) estmap <- TRUE else estmap <- FALSE # return cross + indicator of whether to run est.map list(cross,estmap) } # end of read.cross.csvs.R qtl/R/scanonevar.meanperm.R0000644000176200001440000001057213576241200015345 0ustar liggesusers# scanonevar.meanperm # single-QTL genome scan for QTL affecting variance # with code from Lars Ronnegard scanonevar.meanperm <- function(cross, pheno.col=1, mean_covar = NULL, var_covar = NULL, maxit = 25 , tol=1e-6, n.mean.perm = 2, seed = 27517, quiet=TRUE) { set.seed(seed) # check input crosstype <- crosstype(cross) if(!(crosstype %in% c("bc", "dh", "f2", "haploid", "risib", "riself"))) stop('scanonevar not implemented for cross type "', crosstype, '"') chr_type <- sapply(cross$geno, chrtype) if(any(chr_type=="X")) { warning("Analysis of X chromosome not implemented for scanonevar; omitted.") cross <- subset(cross, chr=(chr_type != "X")) } # grab phenotype # if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { # cross$pheno <- cbind(pheno.col, cross$pheno) # pheno.col <- 1 # } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(is.matrix(pheno) && ncol(pheno) > 1) { pheno <- pheno[,1] warning('scanonevar requires a single phenotype; all but "', phenames(cross)[pheno.col[1]], '" omitted.') } N <- length(pheno) # No. individuals n.chr <- nchr(cross) #No. chromosomes chr.names <- chrnames(cross) # need to run calc.genoprob? if(!("prob" %in% names(cross$geno[[1]]))) { warning("First running calc.genoprob") cross <- calc.genoprob(cross) } scan.logPm <- scan.logPd <- chr.names.out <- NULL # set up data and formulas X <- cbind(pheno=pheno, mean.add=rep(0, length(pheno)), var.add=rep(0, length(pheno))) mean_formula <- "pheno ~ mean.add" var_formula <- "~ var.add" if(!is.null(mean_covar)) { ncolX <- ncol(X) X <- cbind(X, mean_covar) meancovarnames <- paste0("meancov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- meancovarnames mean_formula <- paste(mean_formula, "+", paste(meancovarnames, collapse="+")) } if(!is.null(var_covar)) { ncolX <- ncol(X) X <- cbind(X, var_covar) varcovarnames <- paste0("varcov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- varcovarnames var_formula <- paste(var_formula, "+", paste(varcovarnames, collapse="+")) } X <- as.data.frame(X) mean_formula <- as.formula(mean_formula) var_formula <- as.formula(var_formula) max.mean.neglog.ps <- rep(NA, n.mean.perm) for(perm.num in 1:n.mean.perm) { result <- NULL for(j in seq(along=cross$geno)) { # loop over chromosomes if(!quiet) message(" - Chr ", chr.names[j]) if (crosstype=="f2") { g11 <- cross$geno[[j]]$prob[,,1] g12 <- cross$geno[[j]]$prob[,,2] g13 <- cross$geno[[j]]$prob[,,3] a1 <- g11 + g12/2 d1 <- g12 - (g11+g13)/2 } else { a1 <- cross$geno[[j]]$prob[,,1] } n.loci <- dim(a1)[2] logP.m <- logP.d <- numeric(n.loci) for(i in 1:n.loci) { # loop over positions within chromosome # fill in genotype probs for this locus X$mean.add <- sample(a1[,i]) X$var.add <- a1[,i] d.fit <- DGLM_norm(m.form=mean_formula, d.form=var_formula, indata=X, maxiter=maxit, conv=tol) p.mean <- summary(d.fit$mean)$coef[2,4] p.disp<- summary(d.fit$disp)$coef[2,4] if (d.fit$iter < maxit) { logP.m[i]<- -log10(p.mean) logP.d[i]<- -log10(p.disp) } else { logP.m[i]<- -log10(p.mean) logP.d[i]<- 0 warning("dglm did not converge on chr", chr.names[j], " position ", i) } } max.mean.neglog.ps[perm.num] <- max(max.mean.neglog.ps[perm.num], logP.m, na.rm = TRUE) } } return(max.mean.neglog.ps) } qtl/R/effectscan.R0000644000176200001440000003060413626261114013504 0ustar liggesusers###################################################################### # # effectscan.R # # copyright (c) 2003-2020, Karl W. Broman # [completely re-written in Sep, 2007, based partly on code from Hao Wu] # last modified Feb, 2020 # first written Jan, 2003 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: effectscan # ###################################################################### effectscan <- function(cross, pheno.col=1, chr, get.se=FALSE, draw=TRUE, gap=25, ylim, mtick=c("line","triangle"), add.legend=TRUE, alternate.chrid=FALSE, ...) { type <- crosstype(cross) mtick <- match.arg(mtick) if(type == "4way") stop("effect scan not working for 4-way cross yet.") if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("effectscan can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") if(!is.numeric(cross$pheno[,pheno.col])) stop("phenotype \"", colnames(cross$pheno)[pheno.col], "\" is not numeric.") pheno <- cross$pheno[,pheno.col] wh <- is.na(pheno) if(any(wh)) { pheno <- pheno[!wh] cross <- subset.cross(cross, ind=(!wh)) } if(!missing(chr)) cross <- subset.cross(cross, chr=chr) chr_type <- sapply(cross$geno, chrtype) n.ind <- length(pheno) results <- NULL for(i in 1:nchr(cross)) { if(!("draws" %in% names(cross$geno[[i]]))) stop("You must first run sim.geno.") draws <- cross$geno[[i]]$draws # create map of positions if("map" %in% names(attributes(cross$geno[[i]]$draws))) map <- attr(cross$geno[[i]]$draws,"map") else { stp <- attr(cross$geno[[i]]$draws, "step") oe <- attr(cross$geno[[i]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$draws))) stpw <- attr(cross$geno[[i]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) { marnam <- colnames(map) map <- map[1,] } else marnam <- names(map) if(type == "risib" || type=="riself" || type=="dh" || type=="haploid") { mapping <- rbind(c(+1, -1), c(+1, +1)) colnames(mapping) <- c("intercept","a") dropcol <- 1 } else if(type=="bc") { if(chr_type[i] == "X") { sexpgm <- getsex(cross) draws <- reviseXdata(type, "full", sexpgm, draws=draws, cross.attr=attributes(cross)) if(is.null(sexpgm$sex) || all(sexpgm$sex==0) || all(sexpgm$sex==1)) { # all one sex mapping <- rbind(c(+1, -0.5), c(+1, +0.5)) colnames(mapping) <- c("intercept", "a") dropcol <- 1 } else { # some of each sex mapping <- rbind(c(+1, 0,-0.5, 0), c(+1, 0,+0.5, 0), c(+1,+1, 0, -0.5), c(+1,+1, 0, +0.5)) colnames(mapping) <- c("intercept", "sex", "a.female", "a.male") dropcol <- 1:2 } } # end bc X chr else { mapping <- rbind(c(+1, -0.5), c(+1, +0.5)) colnames(mapping) <- c("intercept", "a") dropcol <- 1 } # end bc autosome } # end bc else { # intercross if(chr_type[i] == "X") { sexpgm <- getsex(cross) draws <- reviseXdata(type, "full", sexpgm, draws=draws, cross.attr=attributes(cross)) if(is.null(sexpgm$pgm) || all(sexpgm$pgm==0) || all(sexpgm$pgm==1)) { # all one direction if(is.null(sexpgm$sex) || all(sexpgm$sex==0) || all(sexpgm$sex==1)) { # all one sex mapping <- rbind(c(+1, -0.5), c(+1, +0.5)) colnames(mapping) <- c("intercept", "a") dropcol <- 1 } else { mapping <- rbind(c(+1, 0,-0.5, 0), c(+1, 0,+0.5, 0), c(+1,+1, 0, -0.5), c(+1,+1, 0, +0.5)) colnames(mapping) <- c("intercept", "sex", "a.female", "a.male") dropcol <- 1:2 } } else { # some of each direction if(is.null(sexpgm$sex) || all(sexpgm$sex==0)) { # all female mapping <- rbind(c(+1, 0,-0.5, 0), c(+1, 0,+0.5, 0), c(+1,+1, 0,-0.5), c(+1,+1, 0,+0.5)) colnames(mapping) <- c("intercept","dir","a.forw","a.rev") dropcol <- 1:2 } else if(all(sexpgm$sex==1)) { # all male mapping <- rbind(c(+1, -0.5), c(+1, +0.5)) colnames(mapping) <- c("intercept", "a") dropcol <- 1 } else { # some of each sex mapping <- rbind(c(+1, 0, 0, -0.5, 0, 0), c(+1, 0, 0, +0.5, 0, 0), c(+1,+1, 0, 0,-0.5, 0), c(+1,+1, 0, 0,+0.5, 0), c(+1, 0,+1, 0, 0,-0.5), c(+1, 0,+1, 0, 0,+0.5)) colnames(mapping) <- c("intercept","dir","sex","a.femaleforw","a.femalerev","a.male") dropcol <- 1:3 } } } # end f2 X chr else { mapping <- rbind(c(+1, -1, 0), c(+1, 0, +1), c(+1, +1, 0)) colnames(mapping) <- c("intercept","a","d") dropcol <- 1 } # f2 autosome } # end f2 n.gen <- ncol(mapping) n.pos <- ncol(draws) n.imp <- dim(draws)[3] z <- .C("R_effectscan", as.integer(n.ind), as.integer(n.gen), as.integer(n.imp), as.integer(n.pos), as.integer(draws-1), as.double(pheno), as.double(mapping), beta=as.double(rep(0,n.pos*n.gen)), se=as.double(rep(0,n.pos*n.gen)), as.integer(get.se), PACKAGE="qtl") beta <- t(matrix(z$beta, ncol=n.pos)) colnames(beta) <- colnames(mapping) if(get.se) { se <- t(matrix(z$se, ncol=n.pos)) colnames(se) <- paste("se", colnames(mapping), sep=".") beta <- cbind(beta, se[,-dropcol,drop=FALSE]) } z <- beta[,-dropcol,drop=FALSE] w <- marnam o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") rownames(z) <- w z <- as.data.frame(z, stringsAsFactors=TRUE) z <- cbind(chr=factor(rep(names(cross$geno)[i],length(map)),levels=names(cross$geno)), pos=as.numeric(map), z) rownames(z) <- w if(i==1) results <- z else { w <- match(colnames(z), colnames(results)) if(any(is.na(w))) { curnam <- colnames(results) for(j in which(is.na(w))) results <- cbind(results, rep(NA, nrow(results))) colnames(results) <- c(curnam, colnames(z)[is.na(w)]) } w <- match(colnames(results), colnames(z)) if(any(is.na(w))) { curnam <- colnames(z) for(j in which(is.na(w))) z <- cbind(z, rep(NA, nrow(z))) colnames(z) <- c(curnam, colnames(results)[is.na(w)]) } results <- rbind(results, z) } } # end loop over chromosomes class(results) <- c("effectscan", "scanone", "data.frame") if(draw) { # make the figure if(missing(ylim)) plot.effectscan(results, gap=gap, mtick=mtick, add.legend=add.legend, alternate.chrid=alternate.chrid, ...) else plot.effectscan(results, gap=gap, mtick=mtick, add.legend=add.legend, ylim=ylim, alternate.chrid=alternate.chrid, ...) } invisible(results) } # function to make the effectscan plot plot.effectscan <- function(x, gap=25, ylim, mtick=c("line","triangle"), add.legend=TRUE, alternate.chrid=FALSE, ...) { col <- c("blue","red","darkorange","darkgreen","purple") lightcol <- c("lightblue", "pink", "peachpuff1", "palegreen1", "thistle1") results <- x eff <- 3:ncol(results) if(length(grep("^se", colnames(results)))>0) get.se <- TRUE else get.se <- FALSE if(get.se) { se <- grep("^se", colnames(results)[eff]) eff <- eff[-se] se <- se + 2 lo <- as.matrix(results[,eff]) - as.matrix(results[,se]) hi <- as.matrix(results[,eff]) + as.matrix(results[,se]) yl <- range(c(lo,hi), na.rm=TRUE) } else yl <- range(results[,eff], na.rm=TRUE) if(!missing(ylim)) yl <- ylim plot.scanone(results, lodcolumn=1, ylim=yl, gap=gap, mtick=mtick, alternate.chrid=alternate.chrid, col=col[1], ...) if(get.se) { begend <- matrix(unlist(tapply(results[,2],results[,1],range)),ncol=2,byrow=TRUE) rownames(begend) <- unique(results[,1]) chr <- unique(as.character(results[,1])) begend <- begend[as.character(chr),,drop=FALSE] len <- begend[,2]-begend[,1] if(length(len)>1) start <- c(0,cumsum(len+gap))-c(begend[,1],0) else start <- 0 x <- results[,2] for(i in seq(along=chr)) x[results[,1]==chr[i]] <- results[results[,1]==chr[i],2]+start[i] for(i in seq(along=chr)) { wh <- results[,1]==chr[i] for(j in 1:ncol(lo)) { if(any(!is.na(lo[wh,j]))) { xx <- c(x[wh], rev(x[wh])) yy <- c(lo[wh,j], rev(hi[wh,j])) polygon(xx, yy, col=lightcol[j], border=lightcol[j]) } } } # go back and add lines at edges for(i in seq(along=chr)) { wh <- results[,1]==chr[i] for(j in 1:ncol(lo)) { if(any(!is.na(lo[wh,j]))) { xx <- c(x[wh], rev(x[wh])) yy <- c(lo[wh,j], rev(hi[wh,j])) lines(xx, yy, col=lightcol[j]) } } } plot.scanone(results, lodcolumn=1, add=TRUE, col=col[1]) } if(length(eff) > 1) { for(i in seq(along=eff)[-1]) plot.scanone(results, lodcolumn=eff[i]-2, gap=gap, add=TRUE, col=col[i]) } if(add.legend) legend("top", legend=names(results)[eff], col=col[1:length(eff)], lwd=2) abline(h=0, lty=2) } # end of effectscan.R qtl/R/fitqtl.R0000644000176200001440000014142513576241200012710 0ustar liggesusers###################################################################### # # fitqtl.R # # copyright (c) 2002-2019, Hao Wu and Karl W. Broman # last modified Dec, 2019 # first written Apr, 2002 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: fitqtl, fitqtlengine, parseformula, summary.fitqtl, # print.summary.fitqtl, mybinaryrep, deparseQTLformula # printQTLformulanicely # ###################################################################### ###################################################################### # # This is the function to fit a model and generate some tables # # Only Haley-Knott regression and multiple imputation are implemented. # ###################################################################### fitqtl <- function(cross, pheno.col=1, qtl, covar=NULL, formula, method=c("imp", "hk"), model=c("normal", "binary"), dropone=TRUE, get.ests=FALSE, run.checks=TRUE, tol=1e-4, maxit=1000, forceXcovar=FALSE) { # some input checking stuff in here if( !inherits(cross, "cross") ) stop("The cross argument must be an object of class \"cross\".") if( !inherits(qtl, "qtl") ) stop("The qtl argument must be an object of class \"qtl\".") if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("fitqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") method <- match.arg(method) model <- match.arg(model) if(model=="binary" && any(!is.na(pheno) & pheno != 0 & pheno != 1)) stop("For model=\"binary\", phenotypes must by 0 or 1.") # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=dropone, get.ests=get.ests, run.checks=run.checks, cross.attr=attributes(cross), crosstype=crosstype(cross), sexpgm=getsex(cross), tol=tol, maxit=maxit, forceXcovar=forceXcovar) } fitqtlengine <- function(pheno, qtl, covar=NULL, formula, method=c("imp", "hk"), model=c("normal", "binary"), dropone=TRUE, get.ests=FALSE, run.checks=TRUE, cross.attr, crosstype, sexpgm, tol, maxit, forceXcovar=FALSE) { model <- match.arg(model) method <- match.arg(method) # local variables n.ind <- qtl$n.ind # number of individuals n.qtl <- qtl$n.qtl # number of selected markers n.gen <- qtl$n.gen # number of genotypes if(method=="imp") n.draws <- dim(qtl$geno)[3] # number of draws if( is.null(covar) ) # number of covariates n.covar <- 0 else n.covar <- ncol(covar) # if formula is missing, build one # all QTLs and covariates will be additive by default if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if (n.covar) { # if covariate is not empty tmp.C <- colnames(covar) # covariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } formula <- as.formula(formula) } # check input formula if(run.checks) { formula <- checkformula(formula, qtl$altname, colnames(covar)) if(qtl$n.ind != length(pheno)) stop("No. individuals in qtl object doesn't match length of input phenotype.") # drop covariates that are not in the formula if(!is.null(covar)) { theterms <- rownames(attr(terms(formula), "factors")) m <- match(colnames(covar), theterms) if(all(is.na(m))) covar <- NULL else covar <- covar[,!is.na(m),drop=FALSE] } # check phenotypes and covariates; drop ind'ls with missing values if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") pheno <- pheno[!hasmissing] n.ind <- qtl$n.ind <- sum(!hasmissing) if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] # subset sexpgm for(i in seq(along=sexpgm)) if(!is.null(sexpgm[[i]])) sexpgm[[i]] <- sexpgm[[i]][!hasmissing] } } } # parse the input formula p <- parseformula(formula, qtl$altname, colnames(covar)) # make an array n.gen.QC to represent the genotype numbers # for all input QTLs and covariates. For covariates the # number of genotyps is 1. This makes programming easier n.gen.QC <- c(n.gen[p$idx.qtl]-1, rep(1, p$n.covar)) # covariates to be passed to C function # This is done in case of that user input covar but has no covar in formula covar.C <- NULL if(!is.null(p$idx.covar)) covar.C <- as.matrix(covar[,p$idx.covar,drop=FALSE]) sizefull <- 1+sum(n.gen.QC) if(p$n.int > 0) { form <- p$formula.intmtx*n.gen.QC if(!is.matrix(form)) { sizefull <- sizefull + prod(form[form!=0]) } else { form <- apply(form,2,function(a) prod(a[a != 0])) sizefull <- sizefull + sum(form) } } if(method != "imp") { # form genotype probabilities as a matrix prob <- matrix(ncol=sum(qtl$n.gen[p$idx.qtl]), nrow=n.ind) curcol <- 0 for(i in p$idx.qtl) { prob[,curcol+1:n.gen[i]] <- qtl$prob[[i]] curcol <- curcol + n.gen[i] } } Xadjustment <- scanoneXnull(crosstype, sexpgm, cross.attr) n.origcovar <- p$n.covar if((sum(qtl$chrtype[p$idx.qtl]=="X") >= 1 || forceXcovar) && Xadjustment$adjustX) { # need to include X chromosome covariates adjustX <- TRUE n.newcovar <- ncol(Xadjustment$sexpgmcovar) n.gen.QC <- c(n.gen.QC, rep(1, n.newcovar)) p$n.covar <- p$n.covar + n.newcovar covar.C <- cbind(covar.C, Xadjustment$sexpgmcovar) sizefull <- sizefull + n.newcovar if(p$n.int==1) p$formula.intmtx <- c(p$formula.intmtx, rep(0,n.newcovar)) if(p$n.int>1) { for(i in 1:n.newcovar) p$formula.intmtx <- rbind(p$formula.intmtx, rep(0,p$n.int)) } } else adjustX <- FALSE # call C function to do the genome scan if(model=="normal") { if(method == "imp") { z <- .C("R_fitqtl_imp", as.integer(n.ind), # number of individuals as.integer(p$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.integer(n.draws), # number of draws as.integer(qtl$geno[,p$idx.qtl,]), # genotypes for selected marker as.integer(p$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p$formula.intmtx), # formula matrix for interactive terms as.integer(p$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(get.ests), # get estimates? # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom ests=as.double(rep(0,sizefull)), ests.cov=as.double(rep(0,sizefull*sizefull)), design.mat=as.double(rep(0,sizefull*n.ind)), matrix.rank=as.integer(0), # on return, minimum of matrix rank across imputations resid=as.double(rep(0,n.ind)), # on return, the average residuals across imputations PACKAGE="qtl") } else { z <- .C("R_fitqtl_hk", as.integer(n.ind), # number of individuals as.integer(p$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.double(prob), # QTL genotype probabilities as.integer(p$n.covar), # number of covariate as.double(covar.C), # covariates as.integer(p$formula.intmtx), # formula matrix for interactive terms as.integer(p$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(get.ests), # get estimates? # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom ests=as.double(rep(0,sizefull)), ests.cov=as.double(rep(0,sizefull*sizefull)), design.mat=as.double(rep(0,sizefull*n.ind)), matrix.rank=as.integer(0), # on return, rank of matrix resid=as.double(rep(0,n.ind)), # on return, residuals from the fit PACKAGE="qtl") } } else { if(method=="imp") { z <- .C("R_fitqtl_imp_binary", as.integer(n.ind), # number of individuals as.integer(p$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.integer(n.draws), # number of draws as.integer(qtl$geno[,p$idx.qtl,]), # genotypes for selected marker as.integer(p$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p$formula.intmtx), # formula matrix for interactive terms as.integer(p$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(get.ests), # get estimates? # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom ests=as.double(rep(0,sizefull)), ests.cov=as.double(rep(0,sizefull*sizefull)), design.mat=as.double(rep(0,sizefull*n.ind)), as.double(tol), as.integer(maxit), matrix.rank=as.integer(0), # on return, minimum of matrix rank across imputations PACKAGE="qtl") } else { z <- .C("R_fitqtl_hk_binary", as.integer(n.ind), # number of individuals as.integer(p$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.double(prob), # QTL genotype probabilities as.integer(p$n.covar), # number of covariate as.double(covar.C), # covariates as.integer(p$formula.intmtx), # formula matrix for interactive terms as.integer(p$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(get.ests), # get estimates? # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom ests=as.double(rep(0,sizefull)), ests.cov=as.double(rep(0,sizefull*sizefull)), design.mat=as.double(rep(0,sizefull*n.ind)), # convergence as.double(tol), as.integer(maxit), matrix.rank=as.integer(0), # on return, rank of matrix PACKAGE="qtl") } } matrix.rank <- z$matrix.rank matrix.ncol <- sizefull residuals <- z$resid if(get.ests) { # first, construct the new design matrix # X = the matrix used in the C coe # Z = the matrix we want thenames <- qtl$name[p$idx.qtl] if(n.covar > 0) thenames <- c(thenames,names(covar)[p$idx.covar]) ests <- z$ests ests.cov <- matrix(z$ests.cov,ncol=sizefull) if(adjustX) { keep <- 1:(length(ests)-n.newcovar) ests <- ests[keep] ests.cov <- ests.cov[keep,keep] } if(any(qtl$n.gen[p$idx.qtl]>=4)) { type <- crosstype if(type == "4way") genotypes <- c("AC","BC","AD","BD") else { genotypes <- cross.attr$genotypes if(is.null(genotypes)) genotypes <- as.character(1:max(qtl$n.gen)) } # just attach rownames for this case thenames <- "Intercept" if(length(p$idx.qtl) > 0) { # qtl names qtlnames <- vector("list", length(p$idx.qtl)) names(qtlnames) <- paste("Q", 1:length(p$idx.qtl), sep="") for(i in seq(along=p$idx.qtl)) { qtlnames[[i]] <- paste(qtl$name[p$idx.qtl[i]], genotypes[2:qtl$n.gen[p$idx.qtl[i]]], sep=".") thenames <- c(thenames, qtlnames[[i]]) } } if(p$n.covar > 0) { covnames <- colnames(covar)[p$idx.covar] thenames <- c(thenames, covnames) } if(p$n.int > 0) { # interactions if(!is.matrix(p$formula.intmtx)) { nam <- names(p$formula.intmtx) p$formula.intmtx <- matrix(p$formula.intmtx, nrow=p$n.int) colnames(p$formula.intmtx) <- nam } for(i in 1:p$n.int) { wh <- which(p$formula.intmtx[i,]==1) nam <- colnames(p$formula.intmtx)[wh] if(length(grep("^Q[0-9]+$", nam[1])) > 0) curnam <- qtlnames[[nam[1]]] else curnam <- nam[1] for(j in 2:length(nam)) { if(length(grep("Q[0-9]+", nam[j])) > 0) curnam <- paste(curnam, qtlnames[[nam[j]]], sep=".") else curnam <- paste(curnam, nam[j], sep=".") } thenames <- c(thenames, curnam) } } if(length(thenames) ==length(ests)) { names(ests) <- thenames dimnames(ests.cov) <- list(thenames, thenames) } else warning("Estimated QTL effects not yet made meaningful for this case.\n ") } else { X <- matrix(z$design.mat,ncol=sizefull) Z <- matrix(0,nrow=n.ind,ncol=sizefull) colnames(Z) <- rep("",sizefull) # mean column Z[,1] <- 1 colnames(Z)[1] <- "Intercept" # ZZ stores the main effects matrices, for creating the interactions ZZ <- vector("list",p$n.qtl+p$n.covar) curcol <- 1 # covariates if(p$n.covar > 0) { for(j in 1:p$n.covar) { Z[,curcol+j] <- ZZ[[p$n.qtl+j]] <- as.matrix(covar[,p$idx.covar[j],drop=FALSE]) colnames(Z)[curcol+j] <- colnames(ZZ[[p$n.qtl+j]]) <- names(covar)[p$idx.covar[j]] } curcol <- curcol + p$n.covar } # QTL main effects for(i in seq(along=p$idx.qtl)) { if(n.gen[i]==2) { if(method=="imp") { if(crosstype == "bc") { Z[qtl$geno[,p$idx.qtl[i],1]==1,curcol+1] <- -0.5 Z[qtl$geno[,p$idx.qtl[i],1]==2,curcol+1] <- 0.5 } else { Z[qtl$geno[,p$idx.qtl[i],1]==1,curcol+1] <- -1 Z[qtl$geno[,p$idx.qtl[i],1]==2,curcol+1] <- 1 } } else if(crosstype == "bc") { Z[,curcol+1] <- (qtl$prob[[p$idx.qtl[i]]][,2] - qtl$prob[[p$idx.qtl[i]]][,1])/2 } else { Z[,curcol+1] <- (qtl$prob[[p$idx.qtl[i]]][,2] - qtl$prob[[p$idx.qtl[i]]][,1]) } colnames(Z)[curcol+1] <- thenames[i] } else { # 3 genotypes if(method=="imp") { Z[qtl$geno[,p$idx.qtl[i],1]==1,curcol+1] <- -1 Z[qtl$geno[,p$idx.qtl[i],1]==3,curcol+1] <- 1 Z[qtl$geno[,p$idx.qtl[i],1]==2,curcol+2] <- 0.5 Z[qtl$geno[,p$idx.qtl[i],1]!=2,curcol+2] <- -0.5 } else { Z[,curcol+1] <- qtl$prob[[p$idx.qtl[i]]][,3] - qtl$prob[[p$idx.qtl[i]]][,1] Z[,curcol+2] <- (qtl$prob[[p$idx.qtl[i]]][,2] - qtl$prob[[p$idx.qtl[i]]][,1] - qtl$prob[[p$idx.qtl[i]]][,3])/2 } colnames(Z)[curcol+1:2] <- paste(thenames[i],c("a","d"),sep="") } ZZ[[i]] <- Z[,curcol+1:(n.gen[i]-1),drop=FALSE] curcol <- curcol + n.gen[i]-1 } if(p$n.int>0) { for(i in 1:p$n.int) { if(p$n.int==1) intform <- p$formula.intmtx else intform <- p$formula.intmtx[,i] tempZ <- matrix(1,ncol=1,nrow=nrow(Z)) colnames(tempZ) <- "" for(j in seq(along=intform)) { if(intform[j]==1) { tZ <- NULL for(k in 1:ncol(ZZ[[j]])) { tZZ <- tempZ * ZZ[[j]][,k] if(all(colnames(tempZ) == "")) colnames(tZZ) <- colnames(ZZ[[j]])[k] else colnames(tZZ) <- paste(colnames(tempZ),colnames(ZZ[[j]])[k],sep=":") tZ <- cbind(tZ,tZZ) } tempZ <- tZ } } Z[,curcol+1:ncol(tempZ)] <- tempZ colnames(Z)[curcol+1:ncol(tempZ)] <- colnames(tempZ) curcol <- curcol + ncol(tempZ) } } b <- solve(t(Z) %*% Z, t(Z) %*% X) ests <- as.numeric(b %*% ests) ests.cov <- b %*% ests.cov %*% t(b) names(ests) <- colnames(Z) dimnames(ests.cov) <- list(colnames(Z),colnames(Z)) } } ##### output ANOVA table for full model ##### result.full <- matrix(NA, 3, 7) colnames(result.full) <- c("df", "SS", "MS", "LOD", "%var", "Pvalue(Chi2)", "Pvalue(F)") rownames(result.full) <- c("Model", "Error", "Total") result.full[1,1] <- z$df # model degree of freedom if(model=="normal") { # compute the SS for total if(adjustX) { mpheno <- mean(pheno) Rss0 <- sum( (pheno-mpheno)^2 ) Rss0adj <- Rss0x <- sum( lm(pheno ~ Xadjustment$sexpgmcovar)$resid^2 ) OrigModellod <- z$lod Modellod <- z$lod + length(pheno)/2 * (log10(Rss0x) - log10(Rss0)) } else { mpheno <- mean(pheno) Rss0adj <- Rss0 <- sum( (pheno-mpheno)^2 ) OrigModellod <- Modellod <- z$lod } # third row, for Total result.full[3,1] <- length(pheno) - 1 # total degree of freedom result.full[3,2] <- Rss0adj # total sum of squares # first row, for Model result.full[1,1] <- z$df # df for Model # Variance explained by model result.full[1,5] <- 100 * (1 - exp(-2*Modellod*log(10)/n.ind)) result.full[1,2] <- Rss0adj * result.full[1,5]/100 # SS for model result.full[1,3] <- result.full[1,2]/z$df # MS for model result.full[1,4] <- Modellod # Model LOD score # Second row, for Error # df result.full[2,1] <- result.full[3,1] - result.full[1,1] # SS result.full[2,2] <- result.full[3,2] - result.full[1,2] # MS result.full[2,3] <- result.full[2,2] / result.full[2,1] # first row, P values # P value (chi2) for model result.full[1,6] <- 1 - pchisq(2*log(10)*Modellod, z$df) # P value (F statistics) for model df0 <- result.full[3,1]; df1 <- result.full[2,1]; Rss1 <- result.full[2,2] Fstat <- ((Rss0adj-Rss1)/(df0-df1)) / (Rss1/df1) result.full[1,7] <- 1 - pf(Fstat, df0-df1, df1) } else { # third row, for Total result.full[3,1] <- length(pheno) - 1 # total degree of freedom result.full[3,2] <- NA # total sum of squares # first row, for Model result.full[1,1] <- z$df # df for Model # Variance explained by model result.full[1,5] <- 100 * (1 - exp(-2*z$lod*log(10)/n.ind)) result.full[1,2] <- NA # SS for model result.full[1,3] <- NA # MS for model result.full[1,4] <- z$lod # Model LOD score OrigModellod <- Modellod <- z$lod # Second row, for Error # df result.full[2,1] <- result.full[3,1] - result.full[1,1] # SS result.full[2,2] <- NA # MS result.full[2,3] <- NA # first row, P values # P value (chi2) for model result.full[1,6] <- 1 - pchisq(2*log(10)*z$lod, z$df) # P value (F statistics) for model result.full[1,7] <- NA } ############# Finish ANOVA table for full model # initialize output object output <- NULL output$result.full <- result.full # drop one at a time? if(dropone && (p$n.qtl+n.origcovar)>1) { # user wants to do drop one term at a time and output anova table # get the terms etc. for input formula f.terms <- terms(formula) f.order <- attr(f.terms, "order") f.label <- attr(f.terms, "term.labels") # initialize output matrix # ANOVA table will have five columns, e.g., df,Type III SS, # LOD, %var, Pvalue for each dropping term # Full model result will not be in this table result <- matrix(0, length(f.order), 7) colnames(result) <- c("df", "Type III SS", "LOD", "%var", "F value", "Pvalue(Chi2)", "Pvalue(F)") rownames(result) <- rep("",length(f.order)) drop.term.name <- NULL formulas <- rep("", length(f.order)) lods <- rep(NA, length(f.order)) for( i in (1:length(f.order)) ) { # loop thru all terms in formula, from the highest order # the label of the term to be droped label.term.drop <- f.label[i] ### find the corresponding QTL name for this term ### # This is used for output ANOVA table if(f.order[i] == 1) { # this is a first order term # if the term label is like Q(q)1, Q(q)2, etc., then it's a QTL if( length(grep("Q[0-9]", label.term.drop, ignore.case=TRUE)) != 0) { idx.qtlname <- as.integer(substr(label.term.drop, 2, nchar(label.term.drop))) drop.term.name[i] <- qtl$name[idx.qtlname] } else { # this is a covariate drop.term.name[i] <- label.term.drop } } else { # this is a 2nd (or higher)order and the term is a string like "Q2:Q3:C1" # I use strsplit to split it to a string vector "Q2" "Q3" "C1". # then take out 2 and 3 as integer. Then find out the # QTL name from the input QTL object and concatenate them tmp.str <- strsplit(label.term.drop,":")[[1]] for(j in 1:length(tmp.str)) { if( length(grep("Q[0-9]", tmp.str[j], ignore.case=TRUE)) != 0 ) { # this is a QTL idx.qtlname <- as.integer(substr(tmp.str[j], 2, nchar(tmp.str[j]))) tmp.str[j] <- qtl$name[idx.qtlname] } if(j == 1) # first term drop.term.name[i] <- tmp.str[j] else # not the first term drop.term.name[i] <- paste(drop.term.name[i], tmp.str[j], sep=":") } } ### Finish QTL name ### # find the indices of the term(s) to be dropped # All terms contain label.term.drop will be dropped idx.term.drop <- NULL tmp.str.drop <- tolower(strsplit(label.term.drop,":")[[1]]) for(j in 1:length(f.label)) { tmp.str.label <- tolower(strsplit(f.label[j], ":")[[1]]) if(all(tmp.str.drop %in% tmp.str.label)) idx.term.drop <- c(idx.term.drop, j) } # the indices of term(s) to be kept idx.term.kept <- setdiff(1:length(f.order), idx.term.drop) #### regenerate a formula with the kept terms additive ### if(length(idx.term.kept) == 0) # nothing left after drop label.term.drop stop("There will be nothing left if drop ", drop.term.name[i]) else { # All terms for idx.term.kept will be additive formula.new <- as.formula(paste("y~", paste(f.label[idx.term.kept], collapse="+"), sep="")) } ### Start fitting model again # parse the input formula p.new <- parseformula(formula.new, qtl$altname, colnames(covar)) n.gen.QC <- c(n.gen[p.new$idx.qtl]-1, rep(1, p.new$n.covar)) formulas[i] <- deparseQTLformula(formula.new) # covariate to be passed to C function covar.C <- NULL if(!is.null(p.new$idx.covar)) covar.C <- as.matrix(covar[,p.new$idx.covar,drop=FALSE]) if(method != "imp") { # form genotype probabilities as a matrix prob <- matrix(ncol=sum(qtl$n.gen[p.new$idx.qtl]), nrow=n.ind) curcol <- 0 for(z in p.new$idx.qtl) { prob[,curcol+1:n.gen[z]] <- qtl$prob[[z]] curcol <- curcol + n.gen[z] } } if(adjustX) { # need to include X chromosome covariates n.newcovar <- ncol(Xadjustment$sexpgmcovar) n.gen.QC <- c(n.gen.QC, rep(1, n.newcovar)) p.new$n.covar <- p.new$n.covar + n.newcovar covar.C <- cbind(covar.C, Xadjustment$sexpgmcovar) sizefull <- sizefull + n.newcovar if(p.new$n.int==1) p.new$formula.intmtx <- c(p.new$formula.intmtx, rep(0,n.newcovar)) if(p.new$n.int>1) { for(i2 in 1:n.newcovar) p.new$formula.intmtx <- rbind(p.new$formula.intmtx, rep(0,p.new$n.int)) } } # call C function fit model if(model=="normal") { if(method == "imp") { z <- .C("R_fitqtl_imp", as.integer(n.ind), # number of individuals as.integer(p.new$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.integer(n.draws), # number of draws as.integer(qtl$geno[,p.new$idx.qtl,]), # genotypes for selected marker as.integer(p.new$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p.new$formula.intmtx), # formula matrix for interactive terms as.integer(p.new$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(0), # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom as.double(rep(0,sizefull)), as.double(rep(0,sizefull*sizefull)), as.double(rep(0,n.ind*sizefull)), matrix.rank=as.integer(0), resid=as.double(rep(0,n.ind)), # on return, the average residuals across imputations PACKAGE="qtl") } else { z <- .C("R_fitqtl_hk", as.integer(n.ind), # number of individuals as.integer(p.new$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.double(prob), as.integer(p.new$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p.new$formula.intmtx), # formula matrix for interactive terms as.integer(p.new$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(0), # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom as.double(rep(0,sizefull)), as.double(rep(0,sizefull*sizefull)), as.double(rep(0,n.ind*sizefull)), matrix.rank=as.integer(0), resid=as.double(rep(0,n.ind)), # on return, the residuals PACKAGE="qtl") } } else { # binary trait if(method=="imp") { z <- .C("R_fitqtl_imp_binary", as.integer(n.ind), # number of individuals as.integer(p.new$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.integer(n.draws), # number of draws as.integer(qtl$geno[,p.new$idx.qtl,]), # genotypes for selected marker as.integer(p.new$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p.new$formula.intmtx), # formula matrix for interactive terms as.integer(p.new$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(0), # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom as.double(rep(0,sizefull)), as.double(rep(0,sizefull*sizefull)), as.double(rep(0,n.ind*sizefull)), as.double(tol), as.integer(maxit), matrix.rank=as.integer(0), PACKAGE="qtl") } else { z <- .C("R_fitqtl_hk_binary", as.integer(n.ind), # number of individuals as.integer(p.new$n.qtl), # number of qtls as.integer(n.gen.QC), # number of genotypes QTLs and covariates as.double(prob), as.integer(p.new$n.covar), # number of covariate as.double(covar.C), # covariate as.integer(p.new$formula.intmtx), # formula matrix for interactive terms as.integer(p.new$n.int), # number of interactions in the formula as.double(pheno), # phenotype as.integer(0), # return variables lod=as.double(0), # LOD score df=as.integer(0), # degree of freedom as.double(rep(0,sizefull)), as.double(rep(0,sizefull*sizefull)), as.double(rep(0,n.ind*sizefull)), # convergence as.double(tol), as.integer(maxit), matrix.rank = as.integer(0), PACKAGE="qtl") } } if(model=="normal" && adjustX) # adjust for X chromosome covariates z$lod <- z$lod + length(pheno)/2 * (log10(Rss0x) - log10(Rss0)) # record the result for dropping this term # df result[i,1] <- result.full[1,1] - z$df # LOD score result[i,3] <- Modellod - z$lod # % variance explained result[i,4] <- result.full[1,5] - 100*(1 - 10^(-2*z$lod/n.ind)) # lod score for reduced model lods[i] <- z$lod # Type III SS for this term - computed from %var if(model=="normal") result[i,2] <- result.full[3,2] * result[i,4] / 100 else result[i,2] <- NA # F value if(model=="normal") { df0 <- length(pheno) - z$df - 1; df1 <- result.full[2,1]; Rss0p <- result.full[2,2] + result[i,2]; Rss1p <- result.full[2,2] Fstat <- ((Rss0p-Rss1p)/(df0-df1)) / (Rss1/df1) result[i,5] <- Fstat # P value (F) result[i,7] <- 1 - pf(Fstat, df0-df1, df1) } else # ignore F stat for binary trait result[i,c(5,7)] <- NA # P value (chi2) result[i,6] <- 1 - pchisq(2*log(10)*result[i,3], result[i,1]) # assign row name rownames(result)[i] <- drop.term.name[i] } # finish dropping terms loop attr(result, "formulas") <- formulas attr(result, "lods") <- lods # assign output object output$result.drop <- result } ## if(dropone) if(get.ests) output$ests <- list(ests=ests, covar=ests.cov) output$lod <- output$result.full[1,4] class(output) <- "fitqtl" attr(output, "method") <- method attr(output, "model") <- model attr(output, "formula") <- deparseQTLformula(formula) attr(output, "type") <- qtl$type attr(output, "nind") <- length(pheno) attr(output, "matrix.rank") <- matrix.rank attr(output, "matrix.ncol") <- matrix.ncol if(!is.null(residuals)) attr(output, "residuals") <- residuals output } ###################################################################### # checkformula # # check that input formula satisfies our imposed hiearchy: that # main effects for terms in any interactions are also included ###################################################################### checkformula <- function(formula, qtl.name, covar.name) { factors <- attr(terms(formula), "factors") altform <- deparseQTLformula(formula) if(sum(factors[1,])==0) factors <- factors[-1,,drop=FALSE] rn <- rownames(factors) # if mentions of "q1" or such, convert to "Q1" and such g <- grep("^[Qq][0-9]+$", rn) todrop <- NULL if(length(g) >= 1) { rownames(factors)[g] <- rn[g] <- toupper(rn[g]) if(any(table(rn) > 1)) { # now there are some duplicates urn <- unique(rn) for(i in urn) { wh <- which(rn == i) if(length(wh) > 1) { factors[wh[1],] <- apply(factors[wh,], 2, sum) todrop <- c(todrop, wh[-1]) rownames(factors)[wh[1]] <- rn[wh[1]] } } } } if(length(todrop) > 0) factors <- factors[-todrop,] rn <- rownames(factors) if(!missing(qtl.name) || !missing(covar.name)) { m <- match(rn, c(qtl.name, covar.name)) if(any(is.na(m))) warning("Terms ", paste(rn[is.na(m)], collapse=" "), " not understood.") } # paste rows together zo <- factors zo[zo>1] <- 1 pzo <- apply(zo, 2, paste, collapse="") nt <- apply(zo, 2, sum) # form binary representations maxnt <- max(nt) v <- vector("list", maxnt) for(i in 2:maxnt) { v[[i]] <- mybinaryrep(i) v[[i]] <- v[[i]][,-ncol(v[[i]])+c(0,1)] } # for each higher-order column, form all lower-order terms for(i in which(nt > 1)) { cur <- zo[,i] wh <- which(cur==1) z <- v[[nt[i]]] zz <- matrix(0, ncol=ncol(z), nrow=length(cur)) for(j in seq(along=wh)) zz[wh[j],] <- z[j,] pzo <- unique(c(pzo, apply(zz, 2, paste, collapse=""))) } zo <- matrix(as.numeric(unlist(strsplit(pzo, ""))), ncol=length(pzo)) nt <- apply(zo, 2, sum) zo <- zo[,order(nt, apply(1-zo, 2, paste, collapse="")), drop=FALSE] rownames(zo) <- rn # form column names theterms <- apply(zo, 2, function(a, b) paste(b[as.logical(a)], collapse=":"), rownames(zo)) as.formula(paste("y ~ ", paste(theterms, collapse=" + "))) } ##################################################################### # # parseformula # # Function to be called by fitqtl. It's used to # parse the input formula # # This is the internal function and not supposed to be used by user # ##################################################################### parseformula <- function(formula, qtl.dimname, covar.dimname) { # The terms for input formula f.formula <- terms(formula) order.term <- attr(f.formula, "order") # get the order of the terms idx.term <- which(order.term==1) # get the first order terms label.term <- attr(f.formula, "term.labels")[idx.term] formula.mtx <- attr(f.formula, "factors") # formula matrix idx.qtl <- NULL idx.covar <- NULL # loop thru all terms and find out how many QTLs and covariates # are there in the formula. Construct idx.qtl and idx.covar at the same time termisqtl <- rep(0, length(idx.term)) for (i in 1:length(idx.term)) { # find out if there term is a QTL or a covariate # ignore the case for QTLs, e.g., Q1 is equivalent to q1 idx.tmp <- grep(paste(label.term[i],"$", sep=""), qtl.dimname, ignore.case=TRUE) if( length(idx.tmp) ) { # it's a QTL idx.qtl <- c(idx.qtl, idx.tmp) termisqtl[i] <- 1 } else if(label.term[i] %in% covar.dimname) # it's a covariate idx.covar <- c(idx.covar, which(label.term[i]==covar.dimname)) else stop("Unrecognized term ", label.term[i], " in formula") } n.qtl <- length(idx.qtl) # number of QTLs in formula n.covar <- length(idx.covar) # number of covariates in formula # now idx.qtl and idx.covar are the indices for genotype # and covariate matrices according to input formula # loop thru all terms again and reorganize formula.mtx formula.idx <- NULL ii <- 1 jj <- 1 for (i in 1:length(idx.term)) { # if(label.term[i] %in% qtl.dimname) { # it's a QTL if(termisqtl[i]) { formula.idx <- c(formula.idx, ii) ii <- ii+1 } else { # it's a covariate formula.idx <- c(formula.idx, jj+n.qtl) jj <- jj+1 } } # reorganize formula.mtx according to formula.idx # remove the first row (for y) formula.mtx <- formula.mtx[2:nrow(formula.mtx),] # rearrange the rows according to formula.idx if there's more than one row if(length(formula.idx) > 1) formula.mtx <- formula.mtx[order(formula.idx),] # take out only part of the matrix for interactions and pass to C function # all the input QTLs and covariates for C function will be additive n.int <- length(order.term) - length(idx.term) # number of interactions if(n.int != 0) formula.intmtx <- formula.mtx[,(length(idx.term)+1):length(order.term)] else # no interaction terms formula.intmtx <- NULL # return object result <- NULL result$idx.qtl <- idx.qtl result$n.qtl <- n.qtl result$idx.covar <- idx.covar result$n.covar <- n.covar result$formula.intmtx <- formula.intmtx result$n.int <- n.int result } ##################################################################### # # summary.fitqtl # ##################################################################### summary.fitqtl <- function(object, pvalues=TRUE, simple=FALSE, ...) { if(!inherits(object, "fitqtl")) stop("Input should have class \"fitqtl\".") # this is just an interface. if("ests" %in% names(object)) { ests <- object$ests$ests se <- sqrt(diag(object$ests$covar)) object$ests <- cbind(est=ests, SE=se, t=ests/se) } class(object) <- "summary.fitqtl" if(simple) pvalues <- FALSE attr(object, "pvalues") <- pvalues attr(object, "simple") <- simple object } ##################################################################### # # print.summary.fitqtl # ##################################################################### print.summary.fitqtl <- function(x, ...) { cat("\n") cat("\t\tfitqtl summary\n\n") meth <- attr(x, "method") mod <- attr(x, "model") if(is.null(mod)) mod <- "normal" if(meth=="imp") meth <- "multiple imputation" else if(meth=="hk") meth <- "Haley-Knott regression" cat("Method:", meth, "\n") cat("Model: ", mod, "phenotype\n") cat("Number of observations :", attr(x, "nind"), "\n\n") # print ANOVA table for full model cat("Full model result\n") cat("---------------------------------- \n") cat("Model formula:") w <- options("width")[[1]] printQTLformulanicely(attr(x, "formula"), " ", w+5, w) cat("\n") pval <- attr(x, "pvalues") simple <- attr(x, "simple") if(!is.null(pval) && !pval) x$result.full <- x$result.full[,-ncol(x$result.full)+(0:1)] if(mod=="binary" || (!is.null(simple) && simple)) x$result.full <- x$result.full[1,-c(2:3,7),drop=FALSE] print(x$result.full, quote=FALSE, na.print="") cat("\n") # print ANOVA table for dropping one at a time analysis (if any) if("result.drop" %in% names(x)) { cat("\n") cat("Drop one QTL at a time ANOVA table: \n") cat("---------------------------------- \n") # use printCoefmat instead of print.data.frame # make sure the last column is P value if(!is.null(pval) && !pval) x$result.drop <- x$result.drop[,-ncol(x$result.drop)+(0:1)] if(mod=="binary" || (!is.null(simple) && simple)) x$result.drop <- x$result.drop[,-c(2,5,7),drop=FALSE] printCoefmat(x$result.drop, digits=4, cs.ind=1, P.values=TRUE, has.Pvalue=TRUE) cat("\n") } if("ests" %in% names(x)) { cat("\n") cat("Estimated effects:\n") cat("-----------------\n") printCoefmat(x$ests,digits=4) cat("\n") } } ###################################################################### # binary repreentation of the numbers 1...2^n; # used in checkformula ###################################################################### mybinaryrep <- function(n) { lx <- 2^n x <- 1:lx ans <- 0:(n-1) x <- matrix(rep(x,rep(n, lx)), ncol=lx) (x %/% 2^ans) %% 2 } ###################################################################### # deparseQTLformula: turn QTL formula into a string ###################################################################### deparseQTLformula <- function(formula, reorderterms=FALSE) { if(is.null(formula)) return(NULL) if(reorderterms) { if(is.character(formula)) formula <- as.formula(formula) factors <- colnames(attr(terms(formula), "factors")) wh <- grep("^[Qq][0-9]+$", factors) if(length(wh)>0) factors[wh] <- paste("Q", sort(as.numeric(substr(factors[wh], 2, nchar(factors[wh])))), sep="") wh <- grep(":", factors) if(length(wh)>0) { temp <- strsplit(factors[wh], ":") temp <- sapply(temp, function(a) { wh <- grep("^[Qq][0-9]+$", a) if(any(wh)) a[wh] <- paste("Q", sort(as.numeric(substr(a[wh], 2, nchar(a[wh])))), sep="") paste(a[order(is.na(match(seq(along=a),wh)))], collapse=":") }) factors[wh] <- temp } return(paste("y ~ ", paste(factors, collapse=" + "), sep="")) } if(is.character(formula)) return(formula) paste(as.character(formula)[c(2,1,3)], collapse=" ") } printQTLformulanicely <- function(formula, header, width, width2, sep=" ") { if(!is.character(formula)) formula <- deparseQTLformula(formula) thetext <- unlist(strsplit(formula, " ")) if(missing(width2)) width2 <- width nleft <- width - nchar(header) nsep <- nchar(sep) if(length(thetext) < 2) cat("", thetext, "\n", sep=sep) else { z <- paste("", thetext[1], sep=sep, collapse=sep) for(j in 2:length(thetext)) { if(nchar(z) + nsep + nchar(thetext[j]) > nleft) { cat(z, "\n") nleft <- width2 z <- paste(header, thetext[j], sep=sep) } else { z <- paste(z, thetext[j], sep=sep) } } cat(z, "\n") } } # end of fitqtl.R qtl/R/read.cross.R0000644000176200001440000005042514326313777013464 0ustar liggesusers###################################################################### # # read.cross.R # # copyright (c) 2000-2020, Karl W Broman # last modified Dec, 2020 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross, fixXgeno.bc, fixXgeno.f2, asnumericwithdec # [See read.cross.csv.R, read.cross.mm.R, read.cross.qtx.R, # qtlcart_io.R, read.cross.gary.R, and read.cross.karl.R # for the format-specific functions.] # ###################################################################### ###################################################################### # # read.cross: read data from an experimental cross # ###################################################################### read.cross <- function(format=c("csv", "csvr", "csvs", "csvsr", "mm", "qtx", "qtlcart", "gary", "karl", "mapqtl", "tidy"), dir="", file, genfile, mapfile, phefile, chridfile, mnamesfile, pnamesfile, na.strings=c("-","NA"), genotypes=c("A","H","B","D","C"), alleles=c("A","B"), estimate.map=FALSE, convertXdata=TRUE, error.prob=0.0001, map.function=c("haldane", "kosambi", "c-f", "morgan"), BC.gen = 0, F.gen = 0, crosstype=NULL, ...) { if(format == "csvrs") { format <- "csvsr" warning("Assuming you mean 'csvsr' rather than 'csvrs'.\n") } format <- match.arg(format) if(format=="csv" || format=="csvr") { # comma-delimited format cross <- read.cross.csv(dir, file, na.strings, genotypes, estimate.map, rotate=(format=="csvr"), ...) } else if(format=="csvs" || format=="csvsr") { # comma-delimited format # allow easier input of filenames into function arguments if(missing(phefile) && !missing(file) && !missing(genfile)) { # read.cross("format", "dir", "genfile", "phefile") phefile <- genfile genfile <- file } else if(missing(genfile) && !missing(file) && !missing(phefile)) { # read.cross("format", "dir", "genfile", phefile="phefile") genfile <- file } cross <- read.cross.csvs(dir, genfile, phefile, na.strings, genotypes, estimate.map, rotate=(format=="csvsr"), ...) } else if(format=="qtx") { # Mapmanager QTX format cross <- read.cross.qtx(dir,file,estimate.map) } else if(format=="qtlcart") { # QTL Cartographer format # if missing mapfile but genfile is specified, # use genfile as the map file. if(missing(mapfile) && !missing(genfile)) mapfile <- genfile cross <- read.cross.qtlcart(dir, file, mapfile) } else if(format=="karl") { # karl's format # if missing file names, use standard ones if(missing(genfile)) genfile <- "gen.txt" if(missing(mapfile)) mapfile <- "map.txt" if(missing(phefile)) phefile <- "phe.txt" cross <- read.cross.karl(dir,genfile,mapfile,phefile) } else if(format=="mm") { # mapmaker format # if missing mapfile but genfile is specified, # use genfile as the map file. if(missing(mapfile) && !missing(genfile)) mapfile <- genfile cross <- read.cross.mm(dir,file,mapfile,estimate.map) } else if(format=="gary") { # gary's format # if missing file names, use the standard ones if(missing(genfile)) genfile <- "geno.dat" if(missing(mnamesfile)) mnamesfile <- "mnames.txt" if(missing(chridfile)) chridfile <- "chrid.dat" if(missing(phefile)) phefile <- "pheno.dat" if(missing(pnamesfile)) pnamesfile <- "pnames.txt" if(missing(mapfile)) mapfile <- "markerpos.txt" cross <- read.cross.gary(dir,genfile,mnamesfile,chridfile, phefile,pnamesfile,mapfile,estimate.map,na.strings) } else if(format == "mapqtl") { # MapQTL format (same as JoinMap) cross <- read.cross.mq(dir=dir, locfile=genfile, mapfile=mapfile, quafile=phefile) } else if (format == "tidy") { # tidy format if(!missing(file) && !missing(genfile) && !missing(mapfile) && missing(phefile)) { phefile <- mapfile mapfile <- genfile genfile <- file } if(missing(genfile)) genfile <- "gen.csv" if(missing(phefile)) phefile <- "phe.csv" if(missing(mapfile)) mapfile <- "map.csv" cross <- read.cross.tidy(dir=dir, genfile=genfile, phefile=phefile, mapfile=mapfile, na.strings=na.strings, genotypes=genotypes) } estimate.map <- cross[[2]] cross <- cross[[1]] if(is.null(crosstype)) crosstype <- crosstype(cross) else class(cross) <- c(crosstype, "cross") # if chr names all start with "chr" or "Chr", remove that part chrnam <- names(cross$geno) if(all(regexpr("^[Cc][Hh][Rr]",chrnam)>0)){ chrnam <- substr(chrnam,4,nchar(chrnam)) if(all(regexpr("^[Oo][Mm][Oo][Ss][Oo][Mm][Ee]",chrnam)>0)) chrnam <- substr(chrnam,8,nchar(chrnam)) } # if chr named "x" make it "X" if(sum(chrnam=="x")>0) chrnam[chrnam=="x"] <- "X" names(cross$geno) <- chrnam # make sure the class of chromosomes named "X" is "X" for(i in 1:length(cross$geno)) if(names(cross$geno)[i] == "X") class(cross$geno[[i]]) <- "X" # Fix up the X chromosome data for a backcross or intercross chr_type <- sapply(cross$geno,chrtype) if(any(chr_type=="X") && convertXdata) { if(crosstype(cross)=="bc") cross <- fixXgeno.bc(cross) if(crosstype(cross)=="f2") { if(missing(alleles)) alleles <- c("A","B") cross <- fixXgeno.f2(cross, alleles) } } ## Pass through read.cross.bcsft for BCsFt (convert if appropriate). cross <- read.cross.bcsft(cross = cross, BC.gen = BC.gen, F.gen = F.gen, ...) if(crosstype=="risib") cross <- convert2risib(cross) else if(crosstype=="riself") cross <- convert2riself(cross) # store genotype data as integers for(i in 1:nchr(cross)) storage.mode(cross$geno[[i]]$data) <- "integer" # check alleles if(crosstype(cross) != "4way") { if(length(alleles) > 2) { warning("length of arg alleles should be 2") alleles <- alleles[1:2] } if(length(alleles) < 2) stop("length of arg alleles should be 2") } else { # 4-way cross if(missing(alleles)) alleles <- c("A","B","C","D") if(length(alleles) > 4) { warning("length of arg alleles should be 4 for a 4-way cross") alleles <- alleles[1:4] } if(length(alleles) < 4) stop("length of arg alleles should be 4 for a 4-way cross") } if(any(nchar(alleles)) != 1) { warning("Each item in arg alleles should be a single character") alleles <- substr(alleles, 1, 1) } attr(cross, "alleles") <- alleles # if 4-way cross, make the maps matrices if(crosstype=="4way") { for(i in seq_along(cross$geno)) { if(!is.matrix(cross$geno[[i]]$map) || nrow(cross$geno[[i]]$map) < 2) { cross$geno[[i]]$map <- rbind(cross$geno[[i]]$map, cross$geno[[i]]$map) } } } # re-estimate map? if(estimate.map) { cat(" --Estimating genetic map\n") map.function <- match.arg(map.function) newmap <- est.map(cross, error.prob=error.prob, map.function=map.function) cross <- replace.map(cross, newmap) } # run checks summary(cross) cat(" --Cross type:", crosstype(cross), "\n") cross } ############################## # fixXgeno.bc: fix up the X chromosome genotype data for backcross ############################## fixXgeno.bc <- function(cross) { omitX <- FALSE # pull out X chr genotype data chr_type <- sapply(cross$geno,chrtype) xchr <- which(chr_type=="X") Xgeno <- cross$geno[[xchr]]$data # find "sex" and "pgm" in the phenotype data sexpgm <- getsex(cross) if(!is.null(sexpgm$sex)) { # "sex" is provided malegeno <- Xgeno[sexpgm$sex==1,] if(any(!is.na(malegeno) & malegeno==2)) { n.omit <- sum(!is.na(malegeno) & malegeno==2) warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.") malegeno[!is.na(malegeno) & malegeno==2] <- NA } malegeno[!is.na(malegeno) & malegeno==3] <- 2 femalegeno <- Xgeno[sexpgm$sex==0,] if(any(!is.na(femalegeno) & femalegeno==3)) { n.omit <- sum(!is.na(femalegeno) & femalegeno==3) warning(" --Omitting ", n.omit, " BB genotypes from females on the X chromosome.") femalegeno[!is.na(femalegeno) & femalegeno==3] <- NA } Xgeno[sexpgm$sex==1,] <- malegeno Xgeno[sexpgm$sex==0,] <- femalegeno } else { # "sex" not provided if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males warning(" --Assuming that all individuals are male.\n") Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2 cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m")) } else if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==2)) { # look like females A:H warning(" --Assuming that all individuals are female.\n") cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m")) } else { # have some of each of the three genotypes warning(" --Can't figure out the X chromosome genotypes.\n You need to provide phenotypes \"sex\"\n See the help file for read.cross() for details.\n Omitting the X chr for now.\n ") omitX <- TRUE } } if(!omitX) { wh <- !is.na(Xgeno) & Xgeno!=1 & Xgeno!=2 if(any(wh)) { Xgeno[wh] <- NA n.omit <- sum(wh) warning(" --Omitted ", n.omit, " additional X chr genotype(s).") } cross$geno[[xchr]]$data <- Xgeno } else cross <- subset(cross,chr= -xchr) # <- omit the X chr completely cross } ############################## # fixXgeno.f2: fix up the X chromosome genotype data for intercross ############################## fixXgeno.f2 <- function(cross, alleles) { omitX <- FALSE # pull out X chr genotype data chr_type <- sapply(cross$geno,chrtype) xchr <- which(chr_type=="X") Xgeno <- cross$geno[[xchr]]$data # find "sex" and "pgm" in the phenotype data sexpgm <- getsex(cross) AA <- paste(rep(alleles[1], 2), collapse="") AB <- paste(alleles, collapse="") BB <- paste(rep(alleles[2], 2), collapse="") cross0 <- paste("(", alleles[1], "x", alleles[2], ")x(", alleles[1], "x", alleles[2], ")", sep="") cross1 <- paste("(", alleles[2], "x", alleles[1], ")x(", alleles[2], "x", alleles[1], ")", sep="") if(!is.null(sexpgm$sex) && !is.null(sexpgm$pgm)) { # both "sex" and "pgm" are provided if(any(sexpgm$sex == 1)) { # there are males malegeno <- Xgeno[sexpgm$sex==1,] if(any(!is.na(malegeno) & malegeno==2)) { n.omit <- sum(!is.na(malegeno) & malegeno==2) warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.") malegeno[!is.na(malegeno) & malegeno==2] <- NA } malegeno[!is.na(malegeno) & malegeno==3] <- 2 Xgeno[sexpgm$sex==1,] <- malegeno } if(any(sexpgm$sex==0)) { # there are females femalegeno0 <- Xgeno[sexpgm$sex==0 & sexpgm$pgm==0,] femalegeno1 <- Xgeno[sexpgm$sex==0 & sexpgm$pgm==1,] if((any(!is.na(femalegeno0) & femalegeno0==3) || any(!is.na(femalegeno1) & femalegeno1==1)) && !any(!is.na(femalegeno0) & femalegeno0==1) && !any(!is.na(femalegeno1) & femalegeno1==3)) { # appear to switched the "pgm" values warning(" --The 0/1 values for \"pgm\" appear to be switched; switching back.") sexpgm$pgm[sexpgm$pgm==1] <- 2 sexpgm$pgm[sexpgm$pgm==0] <- 1 sexpgm$pgm[sexpgm$pgm==2] <- 0 cross$pheno$pgm[cross$pheno$pgm==1] <- 2 cross$pheno$pgm[cross$pheno$pgm==0] <- 1 cross$pheno$pgm[cross$pheno$pgm==2] <- 0 temp <- femalegeno0 femalegeno0 <- femalegeno1 femalegeno1 <- temp } if(any(!is.na(femalegeno0) & femalegeno0==3)) { n.omit <- sum(!is.na(femalegeno0) & femalegeno0==3) warning(" --Omitting ", n.omit, " ", BB, " genotypes from females from cross ", cross0, " on the X chr.\n") femalegeno0[!is.na(femalegeno0) & femalegeno0==3] <- NA } if(any(!is.na(femalegeno1) & femalegeno1==1)) { n.omit <- sum(!is.na(femalegeno1) & femalegeno1==1) warning(" --Omitting ", n.omit, " ", AA, " genotypes from females from cross ", cross1, " on the X chr.\n") femalegeno1[!is.na(femalegeno1) & femalegeno1==1] <- NA } femalegeno1[!is.na(femalegeno1) & femalegeno1==3] <- 1 Xgeno[sexpgm$sex==0 & sexpgm$pgm==0,] <- femalegeno0 Xgeno[sexpgm$sex==0 & sexpgm$pgm==1,] <- femalegeno1 } } else if(!is.null(sexpgm$sex) && is.null(sexpgm$pgm)) { # "sex" is provided but not "pgm" if(any(sexpgm$sex == 1)) { # there are males malegeno <- Xgeno[sexpgm$sex==1,] if(any(!is.na(malegeno) & malegeno==2)) { n.omit <- sum(!is.na(malegeno) & malegeno==2) warning(" --Omitting ", n.omit, " male heterozygote genotypes on the X chromosome.") malegeno[!is.na(malegeno) & malegeno==2] <- NA } malegeno[!is.na(malegeno) & malegeno==3] <- 2 Xgeno[sexpgm$sex==1,] <- malegeno } if(any(sexpgm$sex==0)) { # there are females femalegeno <- Xgeno[sexpgm$sex==0,] if(any(!is.na(femalegeno) & femalegeno==3) & !any(!is.na(femalegeno) & femalegeno==1)) { # looks like (BxA)x(BxA) cross$pheno$pgm <- rep(1,nind(cross)) femalegeno[!is.na(femalegeno) & femalegeno==3] <- 1 } else if(any(!is.na(femalegeno) & femalegeno==1) & !any(!is.na(femalegeno) & femalegeno==3)) { # looks like (AxB)x(AxB) cross$pheno$pgm <- rep(0,nind(cross)) } else { # we have some 1's and some 3's warning(" --There appear to be some individuals of each cross direction, but \"pgm\" is not provided.\n Check the X chr genotype data and include a \"pgm\" column in the phenotype data.\n \"pgm\" was inferred (probably poorly).\n ") cross$pheno$pgm <- rep(0,nind(cross)) # females with no 3's -> assumed to be from (AxB)x(AxB) # females with both 3's and 1's -> assumed to be from (AxB)x(AxB); 3's tossed wh.have3 <- apply(femalegeno, 1, function(a) any(!is.na(a) & a==3)) cross$pheno$pgm[sexpgm$sex==0][wh.have3] <- 1 temp <- femalegeno[wh.have3,] temp[!is.na(temp) & temp==1] <- NA temp[!is.na(temp) & temp==3] <- 1 femalegeno[wh.have3,] <- temp } Xgeno[sexpgm$sex==0,] <- femalegeno } } else if(is.null(sexpgm$sex) && !is.null(sexpgm$pgm)) { # "pgm" is provided but not "sex" if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m")) Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2 } else { # assume all females cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m")) Xgeno.pgm0 <- Xgeno[sexpgm$pgm==0,] Xgeno.pgm1 <- Xgeno[sexpgm$pgm==1,] if(all(is.na(Xgeno.pgm0) | Xgeno.pgm0==2 | Xgeno.pgm0==3) && all(is.na(Xgeno.pgm1) | Xgeno.pgm1==1 | Xgeno.pgm1==2)) { cross$pheno$pgm <- 1 - sexpgm$pgm temp <- Xgeno.pgm0 Xgeno.pgm0 <- Xgeno.pgm1 Xgeno.pgm1 <- temp } Xgeno.pgm1[!is.na(Xgeno.pgm1) & Xgeno.pgm1==1] <- NA Xgeno.pgm1[!is.na(Xgeno.pgm1) & Xgeno.pgm1==3] <- 1 Xgeno.pgm0[!is.na(Xgeno.pgm0) & Xgeno.pgm0==3] <- NA Xgeno[sexpgm$pgm==0,] <- Xgeno.pgm0 Xgeno[sexpgm$pgm==1,] <- Xgeno.pgm1 } } else { # Neither "sex" and "pgm" provided if(all(is.na(Xgeno) | Xgeno==1 | Xgeno==3)) { # look like all males warning(" --Assuming that all individuals are male.\n") Xgeno[!is.na(Xgeno) & Xgeno==3] <- 2 cross$pheno$sex <- factor(rep("m",nind(cross)),levels=c("f","m")) cross$pheno$pgm <- rep(0,nind(cross)) } else if(all(is.na(Xgeno) | Xgeno==2 | Xgeno==3)) { # look like females H:B warning(" --Assuming that all individuals are female.\n") Xgeno[!is.na(Xgeno) & Xgeno==3] <- 1 cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m")) cross$pheno$pgm <- rep(1,nind(cross)) } else if(all(is.na(Xgeno) | Xgeno==2 | Xgeno==1)) { # looks like females A:H warning(" --Assuming that all individuals are female.\n") cross$pheno$sex <- factor(rep("f",nind(cross)),levels=c("f","m")) cross$pheno$pgm <- rep(0,nind(cross)) } else { # have some of each of the three genotypes warning(" --Can't figure out the X chromosome genotypes.\n You need to provide phenotypes \"sex\" and/or \"pgm\"\n See the help file for read.cross() for details.\n Omitting the X chr for now.\n ") omitX <- TRUE } } if(!omitX) { wh <- !is.na(Xgeno) & Xgeno!=1 & Xgeno!=2 if(any(wh)) { Xgeno[wh] <- NA n.omit <- sum(wh) warning(" --Omitted ", n.omit, " additional X chr genotype(s).") } cross$geno[[xchr]]$data <- Xgeno } else cross <- subset(cross,chr= -xchr) # <- omit the X chr completely cross } ###################################################################### # convert character to numeric, using dec as the decimal point ###################################################################### asnumericwithdec <- function(x, dec=".") { if(dec!=".") x <- gsub(paste0("\\", dec), ".", x) as.numeric(x) } # Fix up phenotypes sw2numeric <- function(x, dec) { x[x == ""] <- NA wh1 <- is.na(x) n <- sum(!is.na(x)) y <- suppressWarnings(asnumericwithdec(as.character(x), dec)) wh2 <- is.na(y) m <- sum(!is.na(y)) if(n==m || (n-m) < 2 || (n-m) < n*0.05) { if(sum(!wh1 & wh2) > 0) { u <- unique(as.character(x[!wh1 & wh2])) if(length(u) > 1) { themessage <- paste("The phenotype values", paste("\"", u, "\"", sep="", collapse=" ")) themessage <- paste(themessage, " were", sep="") } else { themessage <- paste("The phenotype value \"", u, "\" ", sep="") themessage <- paste(themessage, " was", sep="") } themessage <- paste(themessage, "interpreted as missing.") warning(themessage) } return(y) } else return(x) } # end of read.cross.R qtl/R/scanqtl.R0000644000176200001440000004171313576241200013051 0ustar liggesusers###################################################################### # # scanqtl.R # # copyright (c) 2002-2019, Hao Wu and Karl W. Broman # last modified Dec, 2019 # first written Apr, 2002 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: scanqtl # ###################################################################### scanqtl <- function(cross, pheno.col=1, chr, pos, covar=NULL, formula, method=c("imp", "hk"), model=c("normal", "binary"), incl.markers=FALSE, verbose=TRUE, tol=1e-4, maxit=1000, forceXcovar=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("scanqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") method <- match.arg(method) model <- match.arg(model) # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(method=="imp") { if(!("draws" %in% names(cross$geno[[1]]))) { if("prob" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("You need to first run sim.geno.") } } else { if(!("prob" %in% names(cross$geno[[1]]))) { if("draws" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("You need to first run calc.genoprob.") } } if(method=="imp") { if("stepwidth" %in% names(attributes(cross$geno[[1]]$draws)) && attr(cross$geno[[1]]$draws, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } else { if("stepwidth" %in% names(attributes(cross$geno[[1]]$prob)) && attr(cross$geno[[1]]$prob, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } type <- crosstype(cross) chr_type <- sapply(cross$geno, chrtype) # input data checking if( length(chr) != length(pos)) stop("Input chr and pos must have the same length") # note that input chr is a vector and pos is a list method <- match.arg(method) ichr <- match(chr, names(cross$geno)) if(any(is.na(ichr))) stop("There's no chromosome number ", chr[is.na(ichr)], " in input cross object") # if formula is missing, make one. # All QTLs and covariates will be additive by default n.qtl <- length(chr) n.covar <- length(covar) if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if (n.covar) { # if covariate is not empty tmp.C <- names(covar) # covariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } formula <- as.formula(formula) } else { # include all input QTLs and covariates in the formula additively formula.str <- deparseQTLformula(formula) # deparse formula as a string for(i in 1:n.qtl) { # loop thru the QTLs qtl.term <- paste("Q", i, sep="") if( length(grep(qtl.term, formula.str, ignore.case=TRUE))==0 ) # this term is not in the formula # add it to the formula formula.str <- paste(formula.str, qtl.term, sep="+") } if(n.covar) { # covariate is not empty for(i in 1:n.covar) { covar.term <- names(covar)[i] if( length(grep(covar.term, formula.str, ignore.case=TRUE))==0 ) # this term is not in the formula # add it to the formula formula.str <- paste(formula.str, covar.term, sep="+") } } formula <- as.formula(formula.str) } # check the formula formula <- checkformula(formula, paste("Q", 1:length(chr), sep=""), colnames(covar)) # drop covariates that are not in the formula if(!is.null(covar)) { theterms <- rownames(attr(terms(formula), "factors")) m <- match(colnames(covar), theterms) if(all(is.na(m))) covar <- NULL else covar <- covar[,!is.na(m),drop=FALSE] } # check phenotypes and covariates; drop ind'ls with missing values if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- cbind(pheno) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") cross <- subset(cross, ind=!hasmissing) pheno <- pheno[!hasmissing] if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] } } sexpgm <- getsex(cross) # find the chromosome with multiple QTLs # indices for chromosomes with multiple QTLs idx.varied <- NULL indices <- pos ## added by Karl 8/23/05 for(i in 1:length(pos)) { l <- length(pos[[i]] ) if( l >= 2 ) { # if there're more than two elements in pos, issue warning message if(l > 2) { msg <- "There are more than two elements in " msg <- paste(msg, i, "th input pos.") msg <- paste(msg, "The first two are taken as starting and ending position.") warning(msg) } # user specified a range # find all markers in this range idx.varied <- c(idx.varied, i) # make the genetic map on this chromosome # make genetic map if(method=="imp") { if("map" %in% names(attributes(cross$geno[[ichr[i]]]$draws))) map <- attr(cross$geno[[ichr[i]]]$draws,"map") else { stp <- attr(cross$geno[[ichr[i]]]$draws, "step") oe <- attr(cross$geno[[ichr[i]]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[ichr[i]]]$draws))) stpw <- attr(cross$geno[[ichr[i]]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[ichr[i]]]$map,stp,oe,stpw) } } else { if("map" %in% names(attributes(cross$geno[[ichr[i]]]$prob))) map <- attr(cross$geno[[ichr[i]]]$prob,"map") else { stp <- attr(cross$geno[[ichr[i]]]$prob, "step") oe <- attr(cross$geno[[ichr[i]]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[ichr[i]]]$prob))) stpw <- attr(cross$geno[[ichr[i]]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[ichr[i]]]$map,stp,oe,stpw) } } # pull out the female map if there are sex-specific maps if(is.matrix(map)) map <- map[1,] indices[[i]] <- seq(along=map) if(method=="imp") step <- attr(cross$geno[[ichr[i]]]$draws,"step") else step <- attr(cross$geno[[ichr[i]]]$prob,"step") if(!incl.markers && step>0) { # equally spaced positions eq.sp.pos <- seq(min(map), max(map), by=step) wh.eq.pos <- match(eq.sp.pos, map) map <- map[wh.eq.pos] indices[[i]] <- indices[[i]][wh.eq.pos] } # locate the markers given starting and ending postion # we should do this before or after incl.markers? start <- pos[[i]][1] end <- pos[[i]][2] # replace pos[[i]] (a range) by the marker positions within the range # extend the position to the nearest markers outside the ranges tmp <- which( (map - start)<=0 ) if(length(tmp) != 0) # starting position is after the first marker start <- map[max(tmp)] tmp <- which( (end-map) <= 0 ) if(length(tmp) != 0) # ending position is before the last marker end <- map[min(tmp)] pos[[i]] <- as.vector( map[(map>=start)&(map<=end)] ) indices[[i]] <- indices[[i]][(map>=start)&(map<=end)] } } # Now, pos contains all the marker positions for all chromosomes ######################### # Now start general scan ######################### # There might be several chromosomes with multiple QTLs # Use one loop sexpgm <- getsex(cross) cross.attr <- attributes(cross) # number of chromosomes with multiple positions to be scanned n.idx.varied <- length(idx.varied) n.loop <- 1 # total number of loops if(n.idx.varied != 0) { # there IS some chromosomes with multiple QTL # vector to indicate the positions indices for those chromosomes idx.pos <- rep(0, n.idx.varied) l.varied <- NULL for(i in 1:n.idx.varied) { l.varied[i] <- length(pos[[idx.varied[i]]]) n.loop <- n.loop * l.varied[i] } # initialize output variable result <- array(rep(0, n.loop), rev(l.varied)) matrix.rank <- matrix.ncol <- array(rep(0, n.loop), rev(l.varied)) } else { # fixed QTL model (no scanning) if(method=="imp") qtl <- makeqtl(cross, chr=chr, pos=unlist(pos), what="draws") else qtl <- makeqtl(cross, chr=chr, pos=unlist(pos), what="prob") result <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit, forceXcovar=forceXcovar) matrix.rank <- attr(result, "matrix.rank") matrix.ncol <- attr(result, "matrix.ncol") result <- result[[1]][1,4] names(result) <- "LOD" class(result) <- "scanqtl" attr(result, "method") <- method attr(result, "formula") <- deparseQTLformula(formula) attr(result, "matrix.rank") <- matrix.rank attr(result, "matrix.ncol") <- matrix.ncol return(result) } # loop thru all varied QTLs if(verbose) { cat(" ",n.loop, "models to fit\n") n.prnt <- floor(n.loop/20) if(n.prnt < 1) n.prnt <- 1 } current.pos <- NULL ## added by Karl 8/23/05 for(i in 1:n.loop) { # find the indices for positions remain <- i if(n.idx.varied > 1) { for(j in 1:(n.idx.varied-1)) { ns <- 1 for( k in (j+1):n.idx.varied ) ns <- ns * length(pos[[idx.varied[k]]]) idx.pos[j] <- floor(remain / ns) + 1 remain <- remain - (idx.pos[j]-1) * ns # remain cannot be zero if(remain == 0) { idx.pos[j] <- idx.pos[j] - 1 remain <- remain + ns } } } idx.pos[n.idx.varied] <- remain # make an QTL object pos.tmp <- NULL for(j in 1:length(pos)) { if(j %in% idx.varied) { idx.tmp <- which(j==idx.varied) pos.tmp <- c(pos.tmp, pos[[j]][idx.pos[idx.tmp]]) } else pos.tmp <- c(pos.tmp, pos[[j]]) } # this bit revised by Karl 8/23/05; now we make the qtl object # once, and copy stuff over otherwise if(is.null(current.pos)) { if(method=="imp") qtl.obj <- makeqtl(cross, chr, pos.tmp, what="draws") else qtl.obj <- makeqtl(cross, chr, pos.tmp, what="prob") current.pos <- pos.tmp } else { thew <- rep(NA, length(pos.tmp)) #### for(kk in seq(along=pos.tmp)) { if(pos.tmp[kk] != current.pos[kk]) { u <- abs(pos.tmp[kk]-pos[[kk]]) w <- indices[[kk]][u==min(u)] if(length(w) > 1) { warning("Confused about QTL positions. You should probably run jittermap to ensure that no two markers conincide.") w <- sample(w, 1) } if(method=="imp") qtl.obj$geno[,kk,] <- cross$geno[[ichr[kk]]]$draws[,w,] else qtl.obj$prob[[kk]] <- cross$geno[[ichr[kk]]]$prob[,w,] thew[kk] <- w #### if(chr_type[ichr[kk]]=="X" && (type=="bc" || type=="f2")) { if(method=="imp") qtl.obj$geno[,kk,] <- reviseXdata(type,"full",sexpgm,draws=qtl.obj$geno[,kk,,drop=FALSE], cross.attr=attributes(cross)) else { temp <- qtl.obj$prob[[kk]] temp <- array(temp, dim=c(nrow(temp),1,ncol(temp))) dimnames(temp) <- list(NULL,"loc", 1:ncol(qtl.obj$prob[[kk]])) qtl.obj$prob[[kk]] <- reviseXdata(type,"full",sexpgm,prob=temp, cross.attr=attributes(cross))[,1,] } } current.pos[kk] <- pos.tmp[kk] } } } # end of Karl's 8/23/05 addition # fit QTL, don't do drop one at a time fit <- fitqtlengine(pheno=pheno, qtl=qtl.obj, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit, forceXcovar=forceXcovar) matrix.rank[i] <- attr(fit, "matrix.rank") matrix.ncol[i] <- attr(fit, "matrix.ncol") if(verbose && ((i-1) %% n.prnt) == 0) cat(" ", i,"/", n.loop, "\n") # assign to result matrix # Note: [[1]][1,4] picks out the LOD score result[i] <- fit[[1]][1,4] } # make the row and column names for the result matrix dnames <- list(NULL) for(i in 1:n.idx.varied) { i.chr <- chr[idx.varied[n.idx.varied-i+1]] i.pos <- pos[[idx.varied[n.idx.varied-i+1]]] dnames[[i]] <- paste( paste("Chr", i.chr,sep=""), i.pos, sep="@") } dimnames(result) <- dnames class(result) <- "scanqtl" attr(result, "method") <- method attr(result, "formula") <- deparseQTLformula(formula) attr(result, "matrix.rank") <- matrix.rank attr(result, "matrix.ncol") <- matrix.ncol result } #summary.scanqtl <- function(object, ...) #{ #} #print.summary.qtl <- function(x, ...) #{ #} # end of scanqtl.R qtl/R/mqmpermutation.R0000644000176200001440000002467413621007641014475 0ustar liggesusers##################################################################### # # mqmpermutation.R # # Copyright (c) 2009-2019, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified Dec 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmscanfdr # mqmpermutation # mqmprocesspermutation # # ##################################################################### mqmscanfdr <- function(cross, scanfunction=mqmscanall, thresholds=c(1,2,3,4,5,7,10,15,20), n.perm = 10, verbose=FALSE, ...){ if(verbose){cat("Calculation of FDR estimate of threshold in multitrait analysis.\n")} results <- NULL above.in.real.res <- NULL res <- scanfunction(cross,...) for(threshold in thresholds){ above.in.real <- 0 for(x in 1:nphe(cross)){ above.in.real = above.in.real + sum(res[[x]][,3] > threshold) } above.in.real.res <- c(above.in.real.res,above.in.real) } perm <- cross if(verbose){cat("QTL's above threshold:",above.in.real,"\n")} above.in.perm.res <- rep(0,length(thresholds)) for(x in 1:n.perm){ if(verbose){cat("Starting permutation",x,"\n")} perm.res <- NULL neworder <- sample(nind(cross)) for(chr in 1:nchr(cross)){ perm$geno[[chr]]$data <- perm$geno[[chr]]$data[neworder,] } res <- scanfunction(perm, ...) for(threshold in thresholds){ above.in.perm <- 0 for(y in 1:nphe(cross)){ above.in.perm = above.in.perm + sum(res[[y]][,3] > threshold) } perm.res <- c(perm.res,above.in.perm) #if(verbose){cat("Permutation",x,"QTL's above threshold:",above.in.perm,"\n")} } above.in.perm.res <- above.in.perm.res+perm.res } above.in.perm.res <- above.in.perm.res/n.perm results <- cbind(above.in.real.res,above.in.perm.res,above.in.perm.res/above.in.real.res) rownames(results) <- thresholds results } ###################################################################### # # mqmpermutation: Shuffles phenotype or does parametric bootstrapping of mqmscan # ###################################################################### mqmpermutation <- function(cross,scanfunction=scanone,pheno.col=1,multicore=TRUE,n.perm=10,file="MQM_output.txt",n.cluster=1,method=c("permutation","simulation"),cofactors=NULL,plot=FALSE,verbose=FALSE,...) { bootmethod <- 0 supported <- c("permutation","simulation") bootmethod <- pmatch(method, supported)[1]-1 if(missing(cross)) stop("No cross file. Please supply a valid cross object.") crosstype <- crosstype(cross) if(crosstype == "f2" || crosstype == "bc" || crosstype == "riself"){ #Echo back the cross type if(verbose) { cat("------------------------------------------------------------------\n") cat("Starting permutation analysis\n") cat("Number of permutations:",n.perm,"\n") cat("n.cluster:",n.cluster,"\n") cat("------------------------------------------------------------------\n") cat("INFO: Received a valid cross file type:",crosstype,".\n") } b <- proc.time() if(!bootmethod){ if(verbose) cat("INFO: Shuffleling traits between individuals.\n") }else{ if(verbose) cat("INFO: Parametric permutation\nINFO: Calculating new traits for each individual.\n") } #Set the Phenotype under interest as the first cross$pheno[,1] <- cross$pheno[,pheno.col] names(cross$pheno)[1] <- names(cross$pheno)[pheno.col] #Scan the original #cross <- fill.geno(cross) # <- this should be done outside of this function res0 <- lapply(1, FUN=snowCoreALL,all.data=cross,scanfunction=scanfunction,verbose=verbose,cofactors=cofactors,...) #Setup bootstraps by generating a list of random numbers to set as seed for each bootstrap batchsize <- n.perm bootstraps <- runif(n.perm) batches <- length(bootstraps) %/% batchsize last.batch.num <- length(bootstraps) %% batchsize results <- NULL if(last.batch.num > 0){ batches = batches+1 } SUM <- 0 AVG <- 0 LEFT <- 0 if(multicore && n.cluster >1) { updateParallelRNG(n.cluster) if(verbose) cat("INFO: Using ",n.cluster," Cores/CPU's/PC's for calculation.\n") for(x in 1:(batches)){ start <- proc.time() if(verbose) { ourline() cat("INFO: Starting with batch",x,"/",batches,"\n") ourline() } if(x==batches && last.batch.num > 0){ boots <- bootstraps[((batchsize*(x-1))+1):((batchsize*(x-1))+last.batch.num)] }else{ boots <- bootstraps[((batchsize*(x-1))+1):(batchsize*(x-1)+batchsize)] } if(Sys.info()[1] == "Windows") { # Windows doesn't support mclapply, but it's faster if available cl <- makeCluster(n.cluster) on.exit(stopCluster(cl)) res <- clusterApply(cl, boots, snowCoreBOOT, all.data=cross, scanfunction=scanfunction, bootmethod=bootmethod, cofactors=cofactors, verbose=verbose, ...) } else { res <- mclapply(boots, snowCoreBOOT, all.data=cross, scanfunction=scanfunction, bootmethod=bootmethod, cofactors=cofactors, verbose=verbose, mc.cores=n.cluster, ...) } results <- c(results,res) if(plot){ temp <- c(res0,results) class(temp) <- c(class(temp),"mqmmulti") mqmplot.permutations(temp) } end <- proc.time() SUM <- SUM + (end-start)[3] AVG <- SUM/x LEFT <- AVG*(batches-x) if(verbose) { cat("INFO: Done with batch",x,"/",batches,"\n") cat("INFO: Calculation of batch",x,"took:",round((end-start)[3], digits=3),"seconds\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per batch:",round((AVG), digits=3)," per trait:",round((AVG %/% batchsize), digits=3),"seconds\n") cat("INFO: Estimated time left:",LEFT%/%3600,":",(LEFT%%3600)%/%60,":",round(LEFT%%60,digits=0),"(Hour:Min:Sec)\n") ourline() } } }else{ if(verbose) cat("INFO: Going into singlemode.\n") for(x in 1:(batches)){ start <- proc.time() if(verbose) { ourline() cat("INFO: Starting with batch",x,"/",batches,"\n") ourline() } if(x==batches && last.batch.num > 0){ boots <- bootstraps[((batchsize*(x-1))+1):((batchsize*(x-1))+last.batch.num)] }else{ boots <- bootstraps[((batchsize*(x-1))+1):(batchsize*(x-1)+batchsize)] } res <- lapply(boots, FUN=snowCoreBOOT,all.data=cross,scanfunction=scanfunction,bootmethod=bootmethod,cofactors=cofactors,verbose=verbose,...) results <- c(results,res) if(plot){ temp <- c(res0,results) class(temp) <- c(class(temp),"mqmmulti") mqmplot.permutations(temp) } end <- proc.time() SUM <- SUM + (end-start)[3] AVG <- SUM/x LEFT <- AVG*(batches-x) if(verbose) { cat("INFO: Done with batch",x,"/",batches,"\n") cat("INFO: Calculation of batch",x,"took:",round((end-start)[3], digits=3),"seconds\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per batch:",round((AVG), digits=3),",per run:",round((AVG %/% batchsize), digits=3),"seconds\n") cat("INFO: Estimated time left:",LEFT%/%3600,":",(LEFT%%3600)%/%60,":",round(LEFT%%60,digits=0),"(Hour:Min:Sec)\n") ourline() } } } res <- c(res0,results) #Set the class of the result to mqmmulti (so we can use our plotting routines) class(res) <- c(class(res),"mqmmulti") e <- proc.time() SUM <- (e-b)[3] AVG <- SUM/(n.perm+1) if(verbose) { cat("INFO: Done with MQM permutation analysis\n") cat("------------------------------------------------------------------\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per trait:",round(AVG, digits=3),"seconds\n") cat("------------------------------------------------------------------\n") } res }else{ stop("Currently only F2, BC, and selfed RIL crosses can be analyzed by MQM.") } } mqmprocesspermutation <- function(mqmpermutationresult = NULL){ if(!is.null(mqmpermutationresult) && inherits(mqmpermutationresult, "mqmmulti")){ result <- NULL result <- sapply(mqmpermutationresult[-1], function(a) max(a[,3], na.rm=TRUE)) result <- as.matrix(result) colnames(result) <- colnames(mqmpermutationresult[[2]])[3] rownames(result) <- 1:(length(mqmpermutationresult)-1) class(result) <- c("scanoneperm",class(result)) result }else{ stop("Please supply a valid resultobject (mqmmulti).") } } # end of mqmpermutation.R qtl/R/mqmaugment.R0000644000176200001440000002037713576241200013562 0ustar liggesusers##################################################################### # # mqmaugment.R # # Copyright (c) 2009-2019, Danny Arends # # Modified by Pjotr Prins; slight modification by Karl Broman # # # first written Februari 2009 # last modified Dec 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmaugment # # ##################################################################### ###################################################################### # # mqmaugment_on_cofactors: Data Augmentation routine for MQM only using the cofactors, the other markers are filled by fill.geno() # ###################################################################### mqmaugment_on_cofactors <- function(cross, cofactors, maxaugind=82, minprob=0.1, strategy=c("default","impute","drop"), verbose=FALSE, ...){ markernames <- as.character(unlist(lapply(pull.map(cross),names))) todrop <- markernames[which(cofactors==0)] toaugment <- drop.markers(cross,todrop) cross <- fill.geno(cross, ...) augmented <- mqmaugment(toaugment,maxaugind,minprob,strategy,verbose) newgenomatrix <- NULL for(marker in markernames){ if(marker %in% todrop){ newgenomatrix <- cbind(newgenomatrix,pull.geno(cross)[augmented$mqm[[3]],marker]) }else{ newgenomatrix <- cbind(newgenomatrix,pull.geno(augmented)[,marker]) } } colnames(newgenomatrix) <- markernames augmented$geno <- vector("list",nchr(cross)) for(chr in 1:length(cross$geno)){ cat(chr,"\n") augmented$geno[[chr]]$map <- cross$geno[[chr]]$map augmented$geno[[chr]]$data <- newgenomatrix[,names(cross$geno[[chr]]$map)] names(augmented$geno) <- names(cross$geno) class(augmented$geno[[chr]]) <- chrtype(cross$geno[[chr]]) } augmented } ###################################################################### # # mqmaugment: dataaugmentation routine for MQM # ###################################################################### mqmaugment <- function(cross,maxaugind=82, minprob=0.1, strategy=c("default","impute","drop"), verbose=FALSE) { # ---- check input supplied by user, start a timer if(minprob <= 0 || minprob > 1){ stop("Error minprob should be a value between 0 and 1.") } starttime <- proc.time() maxaug <- nind(cross) * maxaugind # maxaug is the maximum of individuals to augment to supported <- c("default","impute","drop") strategy <- pmatch(strategy, supported) # ---- check for supported crosses and set ctype isF2 = 1 isBC = 2 isRIL = 3 isAA = 1 isAB = 2 isH = 2 isBB = 3 isNOTBB = 4 isNOTAA = 5 isMISSING = 9 crosstype <- crosstype(cross) if (crosstype == "f2") { ctype = isF2 } else if (crosstype == "bc" || crosstype == "dh" || crosstype=="haploid") { ctype = isBC } else if (crosstype == "riself") { ctype = isRIL } else { stop("Currently only F2, BC, and selfed RIL crosses can be analyzed by MQM.") } if (verbose) cat("INFO: Received a valid cross file type:", crosstype,".\n") # ---- Check sex chromosome # check whether the X chromosome should be dropped # (backcross with one sex should be fine) chr_type <- sapply(cross$geno, chrtype) # Drop the X chromosome in F2 and related crosses if (any(chr_type == "X") && (ctype == isF2 || length(getgenonames(crosstype, "X", "full", getsex(cross), attributes(cross))) != 2)) { warning("MQM not yet available for the X chromosome; omitting chr ", paste(names(cross$geno)[chr_type == "X"], collapse=" ")) cross <- subset(cross, chr=(chr_type != "X")) } # ---- Count n.ind <- nind(cross) n.chr <- nchr(cross) n.aug <- maxaug if (verbose) { cat("INFO: Number of individuals:",n.ind,".\n") cat("INFO: Number of chr:",n.chr,".\n") } # ---- Genotype geno <- pull.geno(cross) chr <- rep(1:nchr(cross), nmar(cross)) dist <- unlist(pull.map(cross)) # Create a fake phenotype for augmentation pheno <- rep(1:n.ind) n.mark <- ncol(geno) if (verbose) cat("INFO: Number of markers:",n.mark,".\n") # Check for NA genotypes and replace them with a 9 geno[is.na(geno)] <- isMISSING if (ctype==isRIL) { nH = sum(geno==isH) if (nH>0) { #warning("RIL dataset contains ", nH," heterozygous genotypes") if (any(geno==isBB)) { # have 3/BB's, so replace 2/H's with missing values geno[geno==isH] <- isMISSING #warning("Removed heterozygous genotypes from RIL set") } else { #warning("Converting heterozygous genotypes to BB from RIL set") geno[geno==isH] <- isBB } } } # end if(RIL) # ---- Call data augmentation result <- .C("R_mqmaugment", as.integer(geno), as.double(dist), as.double(pheno), augGeno=as.integer(rep(0,n.mark*maxaug)), augPheno=as.double(rep(0,maxaug)), augIND=as.integer(rep(0,maxaugind*n.ind)), nind=as.integer(n.ind), naug=as.integer(n.aug), as.integer(n.mark), as.integer(1), # 1 phenotype as.integer(maxaug), as.integer(maxaugind), as.double(minprob), as.integer(chr), as.integer(ctype), as.integer(strategy), as.integer(verbose), PACKAGE="qtl") n.indold = n.ind n.ind = result$nind n.aug = result$naug markONchr <- 0 markdone <- 0 pheno <- NULL pnames <- phenames(cross) oldpheno <- pull.pheno(cross) result$augIND <- result$augIND+1 for(x in result$augPheno[1:n.aug]){ if(nphe(cross)>1){ pheno <- rbind(pheno,oldpheno[x,]) }else{ pheno <- c(pheno,oldpheno[x]) } } for(c in 1:n.chr){ #print(paste("Cromosome",c,"\n",sep="")) matri <- NULL markONchr <- dim(cross$geno[[c]]$data)[2] #print(paste("# markers",markONchr,"\n",sep="")) for(j in markdone:(markdone+markONchr-1)){ #print(paste("Start",markdone,":End",(markdone+markONchr-1),"\n",sep="")) ind2 <- NULL ind2 <- result$augGeno[(1+(j*maxaug)):(n.aug+(j*maxaug))] matri <- rbind(matri,ind2) } matri <- t(matri) if(markdone==0){ colnames(matri) <- colnames(geno)[markdone:(markdone+markONchr)] } else { #print(paste("Markdone",markdone,"End",(markdone+markONchr-1))) colnames(matri) <- colnames(geno)[(markdone+1):(markdone+markONchr)] } cross$geno[[c]]$data <- matri markdone <- (markdone+markONchr) } if(nphe(cross) > 1){ colnames(pheno) <- colnames(cross$pheno) } # Add the phenotype names if we have multiple phenotypes cross$pheno <- as.data.frame(pheno, stringsAsFactors=TRUE) # Store extra information (needed by the MQM algorithm) which individual was which original etc.. cross$mqm$Nind <- n.ind cross$mqm$Naug <- n.aug result$augIND <- result$augIND-1 cross$mqm$augIND <- result$augIND[1:n.aug] # ---- RESULTS endtime <- proc.time() if(n.ind != n.indold){ if(verbose) warning("SERIOUS WARNING: Dropped ",abs(n.ind - n.indold)," original individuals.\n Information lost, please increase minprob.") } if(verbose) cat("INFO: DATA-Augmentation took: ",round((endtime-starttime)[3], digits=3)," seconds\n") colnames(cross$pheno) <- pnames # fix up phenotype names problem cross # return cross type } qtl/R/mqmcofactors.R0000644000176200001440000001461112770016226014102 0ustar liggesusers##################################################################### # # mqmcofactors.R # # Copyright (c) 2009-2010, Danny Arends # # Modified by Karl Broman and Pjotr Prins # # # first written Februari 2009 # last modified April 2010 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: find.markerindex # mqmsetcofactors # mqmautocofactors # scoremissingmarkers # calculatedensity # mqmplot.cofactors # checkdistances # ##################################################################### ###################################################################### # # find.markerindex: Extracts the number of the marker when viewing the markers lineair # mqmcofactors: Prepares a cofactor list to use with mqmscan # mqmsetcofactors: Prepares a cofactor list to use with mqmscan # ###################################################################### find.markerindex <- function(cross, name) { match(name, markernames(cross)) } mqmsetcofactors <- function(cross,each = NULL,cofactors=NULL,sexfactors=NULL,verbose=FALSE){ if(is.null(each) && is.null(cofactors)) stop("Please set either the each parameter or the cofactors") if(missing(cross)) stop("No cross file. Please supply a valid cross object.") individuals <- nind(cross) n.chr <- nchr(cross) n.mark <- sum(nmar(cross)) cofactorlist <- rep(0,n.mark) if(!is.null(each) && each > n.mark) stop("Not enough markers to place cofactors at this wide an interval.") if(verbose) { cat("INFO: Found",individuals,"individuals in the cross object.\n") cat("INFO: Mamimum amount of cofactors",(individuals-15)," (each =",ceiling(sum(n.mark)/(individuals-15)),") leaves 15 Degrees of Freedom (no Dominance).\n") cat("INFO: Mamimum amount of cofactors",(individuals-15)/2," (each =",ceiling(sum(n.mark)/(individuals-15))*2,") leaves 15 Degrees of Freedom (Dominance).\n") } if(is.null(cofactors)){ cofactorlist <- rep(c(rep(0,each-1),1),(2*n.mark)/each) cofactorlist <- cofactorlist[1:n.mark] }else{ if(max(cofactors) > n.mark) stop("Trying to set a non-existent marker as a cofactor.") if(min(cofactors) <= 0) stop("Trying to set a non-existent marker as a cofactor.") cofactorlist[cofactors]=1 if(!is.null(sexfactors)){ cofactorlist[sexfactors]=2 } } if(sum(cofactorlist) > (individuals-15)){ warning("Trying to set: ",ceiling(sum(n.mark)/each)," markers as cofactor. This leaves less than 15 Degrees of Freedom.\n") } cofactorlist } scoremissingmarkers <- function(cross){ genotype <- pull.geno(cross) nind <- dim(genotype)[1] missing <- NULL for(x in 1:dim(genotype)[2]){ missing <- c(missing,sum(is.na(genotype[,x]))/nind) } missing } calculatedensity <- function(cross,distance=30){ genotype <- pull.geno(cross) densities <- NULL for(chr in 1:nchr(cross)){ map <- pull.map(cross)[[chr]] for(x in 1:length(map)){ densities <- c(densities,sum(map[which(map > map[x]-distance)] < map[x]+distance)) } } densities } mqmautocofactors <- function(cross, num=50, distance=5,dominance=FALSE,plot=FALSE,verbose=FALSE){ if(num > (nind(cross)-15) && !dominance){ stop("Trying to set: ",num," markers as cofactor. This leaves less than 15 Degrees of Freedom.\n") } if(num > ((nind(cross)-15)/2) && dominance){ stop("Trying to set: ",num," markers as cofactor. This leaves less than 15 Degrees of Freedom.\n") } if(distance < 0.1){ distance <- 0.1 } # r <- scanone(cross) cofactors <- rep(0,sum(nmar(cross))) missing <- scoremissingmarkers(cross) densities <- calculatedensity(cross,distance*2)*missing cnt <- 0 while(sum(cofactors) < num && cnt < num){ lefttoset <- num - sum(cofactors) if(verbose) cat("Cofactors left",lefttoset,"/",num,"\n") possible <- which(max(densities)==densities) if(length(possible) > lefttoset){ possible <- sample(possible,lefttoset) } cofactors[possible] <- 1 densities[which(cofactors==1)] <- 0 cofactors <- checkdistances(cross,cofactors,distance) cnt <- cnt+1 } if(cnt==num && verbose) cat("Solution by iteration, there might be less cofactors then requested\n") if(plot) mqmplot.cofactors(cross,cofactors) cofactors } checkdistances <- function(cross,cofactors,dist=5){ map <- unlist(pull.map(cross)) newcofactors <- cofactors cnt_dropped <- 0 for(x in which(cofactors==1)){ for(y in which(cofactors==1)){ if(x != y){ chr_x <- strsplit(names(map[x]),'.',fixed=TRUE)[[1]][1] loc_x <- as.double(map[x]) chr_y <- strsplit(names(map[y]),'.',fixed=TRUE)[[1]][1] loc_y <- as.double(map[y]) if(chr_x==chr_y && abs(loc_x-loc_y) < dist){ newcofactors[y] <- 0 cnt_dropped <- cnt_dropped+1 } } } } #cat("Dropped ",cnt_dropped," cofactors due to conflicting locations\n") newcofactors } mqmplot.cofactors <- function(cross,cofactors,...){ map <- pull.map(cross) qc <- NULL qn <- NULL qp <- NULL mapnames <- NULL for(x in 1:nchr(cross)){ mapnames <- c(mapnames,names(pull.map(cross)[[x]])) } chr <- 1 genotype <- pull.geno(cross) for(x in 1:length(cofactors)){ if(x > sum(nmar(cross)[1:chr])){ chr <- chr+1 } if(cofactors[x]>0){ qn <- c(qn, mapnames[x]) qc <- c(qc, as.character(names(map)[chr])) qp <- c(qp, as.double(unlist(map)[x])) } } plot(makeqtl(sim.geno(cross),qc,qp,qn),...) } # end of mqmcofactors.R qtl/R/add.cim.covar.R0000644000176200001440000000555612770016226014024 0ustar liggesusers###################################################################### # # add.cim.covar.R # # copyright (c) 2007-8, Karl W Broman # last modified Aug, 2008 # first written Mar, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: add.cim.covar # ###################################################################### ###################################################################### # Indicate the locations of the selected marker covariates # in a plot of CIM results (as obtained by plot.scanone) # # The chr and gap arguments must be identical to those used in the # call to plot.scanone. ###################################################################### add.cim.covar <- function(cimresult, chr, gap=25, ...) { cimcovar <- attr(cimresult, "marker.covar.pos") if(!missing(chr)) cimresult <- subset(cimresult, chr=chr) if(nrow(cimcovar) == 0) return(invisible(NULL)) chr <- as.character(unique(cimresult[,1])) dots <- list(...) ndots <- names(dots) u <- par("usr") if(length(chr)==1) { if(!("col" %in% ndots) && !("pch" %in% ndots)) points(cimcovar[,2], u[3], xpd=TRUE, col="red", pch=16, ...) else if(!("col" %in% ndots)) points(cimcovar[,2], u[3], xpd=TRUE, col="red", ...) else if(!("pch" %in% ndots)) points(cimcovar[,2], u[3], xpd=TRUE, pch=16, ...) else points(cimcovar[,2], u[3], xpd=TRUE, ...) } else { begend <- matrix(unlist(tapply(cimresult[,2],cimresult[,1],range)),ncol=2,byrow=TRUE) rownames(begend) <- chr begend <- begend[as.character(chr),,drop=FALSE] len <- begend[,2]-begend[,1] start <- c(0,cumsum(len+gap))-c(begend[,1],0) start <- start[-length(start)] names(start) <- chr for(i in 1:nrow(cimcovar)) { x <- start[cimcovar[i,1]] + cimcovar[i,2] if(!("col" %in% ndots) && !("pch" %in% ndots)) points(x, u[3], xpd=TRUE, col="red", pch=16, ...) else if(!("col" %in% ndots)) points(x, u[3], xpd=TRUE, col="red", ...) else if(!("pch" %in% ndots)) points(x, u[3], xpd=TRUE, pch=16, ...) else points(x, u[3], xpd=TRUE, ...) } } invisible(cimcovar) } # end of add.cim.covar.R qtl/R/errorlod.R0000644000176200001440000002121613576241200013230 0ustar liggesusers###################################################################### # # errorlod.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Apr, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: calc.errorlod, plotErrorlod, top.errorlod # ###################################################################### ###################################################################### # # calc.errorlod: Calculate LOD scores indicating likely genotyping # errors. # ###################################################################### calc.errorlod <- function(cross, error.prob=0.01, map.function=c("haldane","kosambi","c-f","morgan"), version=c("new","old")) { version <- match.arg(version) if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") origcross <- cross # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 0.5) { error.prob <- 0.5 warning("error.prob shouldn't be > 0.5.") } # map function map.function <- match.arg(map.function) n.ind <- nind(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) # calculate genotype probabilities one chromosome at a time for(i in 1:n.chr) { chr.type <- chrtype(cross$geno[[i]]) if(type=="bc" || type=="risib" || type=="riself" || type=="dh" || type=="haploid") cfunc <- "calc_errorlod_bc" else if(type=="f2" || type=="bcsft") { if(chr.type!="X") cfunc <- "calc_errorlod_f2" else cfunc <- "calc_errorlod_bc" } else if(type=="4way") cfunc <- "calc_errorlod_4way" else if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") cfunc <- paste("calc_errorlod_", type, sep="") else stop("calc.errorlod not available for cross type ", type, ".") # skip chromosomes with only 1 marker if(n.mar[i] < 2) next if(version=="old") { if((!("prob" %in% names(cross$geno[[i]])) || abs(attr(cross$geno[[i]]$prob,"error.prob") - error.prob) > 1e-9)) { # need to run calc.genoprob cross <- calc.genoprob(cross,error.prob=error.prob, map.function=map.function) } Pr <- cross$geno[[i]]$prob u <- grep("^loc-*[0-9]+",colnames(Pr)) if(length(u) > 0) Pr <- Pr[,-u,] } else { # new version cross <- calc.genoprob.special(cross,error.prob=error.prob, map.function=map.function) Pr <- cross$geno[[i]]$prob } nm <- dim(Pr)[2] dat <- cross$geno[[i]]$data dat[is.na(dat)] <- 0 z <- .C(cfunc, as.integer(n.ind), as.integer(nm), as.integer(dat), as.double(error.prob), as.double(Pr), errlod=as.double(rep(0,n.ind*nm)), PACKAGE="qtl") errlod <- array(z$errlod, dim=dim(Pr)[1:2]) if(version=="new") errlod[dat==0] <- -99 dimnames(errlod) <- list(NULL,colnames(cross$geno[[i]]$data)) origcross$geno[[i]]$errorlod <- errlod # attribute set to the error.prob value used, for later # reference. attr(origcross$geno[[i]]$errorlod,"error.prob") <- error.prob attr(origcross$geno[[i]]$errorlod,"map.function") <- map.function } origcross } ###################################################################### # # plotErrorlod # ###################################################################### plotErrorlod <- function(x, chr, ind, breaks=c(-Inf,2,3,4.5,Inf), col=c("white","gray85","hotpink","purple3"), alternate.chrid=FALSE, ...) { if(!inherits(x, "cross")) stop("Input should have class \"cross\".") if(length(breaks) != length(col)+1) stop("Length of breaks should be length(col)+1.") if(length(breaks) != length(col)+1) col <- col[1:(length(breaks)+1)] cross <- x if(!missing(chr)) cross <- subset(cross,chr=chr) use.id <- FALSE if(!missing(ind)) { if(is.null(getid(cross))) cross$pheno$id <- 1:nind(cross) cross <- subset(cross,ind=ind) use.id <- TRUE } # remove chromosomes with < 2 markers n.mar <- nmar(cross) cross <- subset(cross,chr=names(n.mar)[n.mar >= 2]) n.chr <- nchr(cross) errlod <- NULL for(i in 1:n.chr) { if(!("errorlod" %in% names(cross$geno[[i]]))) { # need to run calc.errorlod warning("First running calc.errorlod.") cross <- calc.errorlod(cross,error.prob=0.01,map.function="haldane") } errlod <- cbind(errlod,cross$geno[[i]]$errorlod) } errlod <- t(errlod) old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) # plot grid breaks[breaks==Inf] <- max(errlod) breaks[breaks==-Inf] <- min(errlod) image(1:nrow(errlod),1:ncol(errlod),errlod, ylab="Individuals",xlab="Markers",col=col, breaks=breaks, yaxt="n") if(use.id) axis(side=2, at=1:nind(cross), labels=getid(cross)) else axis(side=2) # plot lines at the chromosome boundaries n.mar <- nmar(cross) n.chr <- nchr(cross) chr.names <- names(cross$geno) a <- c(0.5,cumsum(n.mar)+0.5) # the following makes the lines go slightly above the plotting region b <- par("usr") segments(a,b[3],a,b[4]+diff(b[3:4])*0.02) # this line adds a line above and below the image # (the image function seems to leave these out) abline(h=0.5+c(0,ncol(errlod)),xpd=FALSE) # add chromosome numbers a <- par("usr") wh <- cumsum(c(0.5,n.mar)) chrpos <- (wh[-1]+wh[-length(wh)])/2 if(!alternate.chrid || length(chrpos) < 2) { for(i in seq(along=chrpos)) axis(side=3, at=chrpos[i], labels=chr.names[i]) } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=3, at=chrpos[i], labels="") axis(side=3, at=chrpos[i], labels=chr.names[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=3, at=chrpos[i], labels="") axis(side=3, at=chrpos[i], labels=chr.names[i], line=+0.4, tick=FALSE) } } title(main="Genotyping error LOD scores") invisible() } ###################################################################### # # top.errorlod # # Picks out the genotypes having errorlod values above some cutoff # ###################################################################### top.errorlod <- function(cross, chr, cutoff=4, msg=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross,chr=chr) id <- getid(cross) if(is.null(id)) id <- 1:nind(cross) mar <- ind <- lod <- chr <- NULL # remove chromosomes with < 2 markers n.mar <- nmar(cross) cross <- subset(cross,chr=names(n.mar)[n.mar >= 2]) flag <- 0 for(i in 1:nchr(cross)) { if(!("errorlod" %in% names(cross$geno[[i]]))) stop("You first need to run calc.errorlod.") el <- cross$geno[[i]]$errorlod if(any(el > cutoff)) { o <- (el > cutoff) mar <- c(mar,colnames(el)[col(el)[o]]) ind <- c(ind,as.character(id[row(el)][o])) lod <- c(lod,el[o]) chr <- c(chr,rep(names(cross$geno)[i],sum(o))) flag <- 1 } } if(!flag) { if(msg) cat("\tNo errorlods above cutoff.\n") return(invisible(NULL)) } suppressWarnings(asnum <- as.numeric(ind)) if(!any(is.na(asnum)) && all(ind==asnum)) ind <- asnum o <- data.frame(chr=chr,id=ind,marker=mar,errorlod=lod,stringsAsFactors=FALSE)[order(-lod,ind),] rownames(o) <- 1:nrow(o) o } # end of errorlod.R qtl/R/vbscan.R0000644000176200001440000001326713576241200012663 0ustar liggesusers###################################################################### # # vbscan.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written May, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: vbscan # ###################################################################### ###################################################################### # # vbscan: scan genome for a quantitative phenotype for which some # individuals' phenotype is undefined (for example, the size of a # lesion, where some individuals have no lesion). # ###################################################################### vbscan <- function(cross, pheno.col=1, upper=FALSE, method="em", maxit=4000, tol=1e-4) { method <- match.arg(method) type <- crosstype(cross) # check arguments are okay if(length(pheno.col) > 1) pheno.col <- pheno.col[1] if(pheno.col > nphe(cross)) stop("Specified phenotype column exceeds the number of phenotypes") y <- cross$pheno[,pheno.col] # modify phenotypes if(upper) { if(!any(y == Inf)) y[y==max(y)] <- Inf } else { if(!any(y == -Inf)) y[y==min(y)] <- -Inf } survived <- rep(0,length(y)) survived[y == -Inf | y == Inf] <- 1 # The following line is included since .C() doesn't accept Infs y[y == -Inf | y == Inf] <- 99999 n.chr <- nchr(cross) results <- NULL for(i in 1:n.chr) { # make sure inferred genotypes or genotype probabilities are available if(!("prob" %in% names(cross$geno[[i]]))) { cat(" -Calculating genotype probabilities\n") cross <- calc.genoprob(cross) } genoprob <- cross$geno[[i]]$prob n.pos <- dim(genoprob)[2] n.ind <- length(y) chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") sexpgm <- getsex(cross) else sexpgm <- NULL gen.names <- getgenonames(type,chr_type,"full", sexpgm, attributes(cross)) n.gen <- length(gen.names) # revise X chromosome genotypes if(chr_type=="X" && (type=="f2" || type=="bc")) genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob, cross.attr=attributes(cross)) z <- .C("R_vbscan", as.integer(n.pos), as.integer(n.ind), as.integer(n.gen), as.double(genoprob), as.double(y), as.integer(survived), lod=as.double(rep(0, n.pos*3)), as.integer(maxit), as.double(tol), PACKAGE="qtl") if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) map <- map[1,] res <- data.frame(chr=rep(names(cross$geno)[i],length(map)), pos = as.numeric(map), matrix(z$lod,nrow=n.pos,byrow=TRUE), stringsAsFactors=TRUE) colnames(res)[-(1:2)] <- c("lod.p.mu","lod.p","lod.mu") w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") rownames(res) <- w z <- res # get null log10 likelihood for the X chromosome if(chr_type=="X") { # determine which covariates belong in null hypothesis temp <- scanoneXnull(type, sexpgm, cross.attr=attributes(cross)) adjustX <- temp$adjustX parX0 <- temp$parX0 sexpgmcovar <- temp$sexpgmcovar sexpgmcovar.alt <- temp$sexpgmcovar.alt if(adjustX) { # get LOD-score adjustment n.gen <- ncol(sexpgmcovar)+1 genoprob <- matrix(0,nrow=n.ind,ncol=n.gen) for(i in 1:n.gen) genoprob[sexpgmcovar.alt==i,i] <- 1 nullz <- .C("R_vbscan", as.integer(1), as.integer(n.ind), as.integer(n.gen), as.double(genoprob), as.double(y), as.integer(survived), lod=as.double(rep(0,(4+2*n.gen))), as.integer(maxit), as.double(tol), PACKAGE="qtl") # adjust LOD curve for(i in 1:3) z[,i+2] <- z[,i+2] - nullz$lod[i] } } results <- rbind(results, z) } class(results) <- c("scanone","data.frame") attr(results,"method") <- method attr(results,"type") <- crosstype(cross) attr(results,"model") <- "twopart" results } # end of vbscan.R qtl/R/write.cross.mq.R0000644000176200001440000002405614525760136014314 0ustar liggesusers###################################################################### # write.cross.mq.R # # copyright (c) 2014, 2015, INRA (author: Timothee Flutre) # last modified March, 2015 # first written May, 2014 # # small modification by Karl Broman, 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: write.cross.mq, write.cross.mq.loc, write.cross.mq.map, # and write.cross.mq.qua # ###################################################################### ###################################################################### # # write.cross.mq: write data from an experimental cross in MapQTL (and # JoinMap) format. # # Three files are written: a "loc" file containing the genotype data, # a "map" file containing the linkage group assignments and map # positions, and a "qua" file containing the phenotypes. # # File formats are described in the MapQTL manual available online at # http://www.kyazma.nl/docs/MQ7Manual.pdf # Only 4-way crosses are supported ("CP" type in MapQTL/JoinMap). # ###################################################################### write.cross.mq <- function(cross, filestem, digits) { if(crosstype(cross) != "4way"){ msg <- paste("population type", crosstype(cross), "is not supported for writing in MapQTL format (yet)") stop(msg, call.=FALSE) } write.cross.mq.loc(cross, paste0(filestem, ".loc")) write.cross.mq.map(cross, paste0(filestem, ".map"), digits) write.cross.mq.qua(cross, paste0(filestem, ".qua"), digits) } write.cross.mq.loc <- function(cross, locfile) { sink(locfile) cat(paste0("name = cross", "\n")) if(crosstype(cross) == "4way"){ cat(paste0("popt = ", "CP", "\n")) } else{ sink() msg <- paste("population type", crosstype(cross), "is not supported (yet)") stop(msg, call.=FALSE) } cat(paste0("nloc = ", totmar(cross), "\n")) cat(paste0("nind = ", nind(cross), "\n")) cat("\n") for(chr in names(cross$geno)){ for(marker in colnames(cross$geno[[chr]]$data)){ cat(marker) tmp <- sort(names(table(cross$geno[[chr]]$data[,marker]))) if(length(tmp) == 4 && all(tmp == c("1","2","3","4"))){ cat("\t") # arbitrary choice cat("\t{00}") # arbitrary choice, could also be {01}, {10}, {11} for(i in 1:nind(cross)){ if(is.na(cross$geno[[chr]]$data[i, marker])){ cat("\t--") } else if(cross$geno[[chr]]$data[i, marker] == 1){ cat("\tac") } else if(cross$geno[[chr]]$data[i, marker] == 3){ cat("\tad") } else if(cross$geno[[chr]]$data[i, marker] == 2){ cat("\tbc") } else if(cross$geno[[chr]]$data[i, marker] == 4){ cat("\tbd") } } cat("\n") } else if((length(tmp) == 3 && all(tmp == c("1","10","4"))) || (length(tmp) == 5 && all(tmp == c("1","10","11","14","4")))){ cat("\t") cat("\t{00}") # arbitrary choice, could also be {11} for(i in 1:nind(cross)){ if(is.na(cross$geno[[chr]]$data[i, marker])){ cat("\t--") } else if(cross$geno[[chr]]$data[i, marker] == 1){ cat("\thh") } else if(cross$geno[[chr]]$data[i, marker] == 10){ cat("\thk") } else if(cross$geno[[chr]]$data[i, marker] == 4){ cat("\tkk") } else if(cross$geno[[chr]]$data[i, marker] == 14){ cat("\th-") } else if(cross$geno[[chr]]$data[i, marker] == 11){ cat("\tk-") } } cat("\n") } else if((length(tmp) == 3 && all(tmp == c("2","3","9"))) || (length(tmp) == 5 && all(tmp == c("12","13","2","3","9")))){ cat("\t") cat("\t{01}") # arbitrary choice, could also be {10} for(i in 1:nind(cross)){ if(is.na(cross$geno[[chr]]$data[i, marker])){ cat("\t--") } else if(cross$geno[[chr]]$data[i, marker] == 9){ cat("\thk") } else if(cross$geno[[chr]]$data[i, marker] == 3){ cat("\thh") } else if(cross$geno[[chr]]$data[i, marker] == 2){ cat("\tkk") } else if(cross$geno[[chr]]$data[i, marker] == 12){ cat("\th-") } else if(cross$geno[[chr]]$data[i, marker] == 13){ cat("\tk-") } } cat("\n") } else if(length(tmp) == 2 && all(tmp == c("5","6"))){ cat("\t") cat("\t{0-}") # arbitrary choice, could also be {1-} for(i in 1:nind(cross)){ if(is.na(cross$geno[[chr]]$data[i, marker])){ cat("\t--") } else if(cross$geno[[chr]]$data[i, marker] == 5){ cat("\tll") } else if(cross$geno[[chr]]$data[i, marker] == 6){ cat("\tlm") } } cat("\n") } else if(length(tmp) == 2 && all(tmp == c("7","8"))){ cat("\t") cat("\t{-0}") # arbitrary choice, could also be {-1} for(i in 1:nind(cross)){ if(is.na(cross$geno[[chr]]$data[i, marker])){ cat("\t--") } else if(cross$geno[[chr]]$data[i, marker] == 7){ cat("\tnn") } else if(cross$geno[[chr]]$data[i, marker] == 8){ cat("\tnp") } } cat("\n") } else{ sink() msg <- paste("unrecognized segregation type at marker", marker, "on chromosome", chr) stop(msg, call.=FALSE) } } } sink() } write.cross.mq.map <- function(cross, mapfile, digits=NULL) { if(is.matrix(cross$geno[[1]]$map)){ mapfile.female <- sub(pattern="\\.map", replacement="_female.map", x=mapfile) sink(mapfile.female) for(chr in names(cross$geno)){ cat(paste0("group ", chr, "\n")) for(m in 1:ncol(cross$geno[[chr]]$map)){ cat(paste0(colnames(cross$geno[[chr]]$map)[m], "\t", ifelse(is.null(digits), cross$geno[[chr]]$map[1,m], round(cross$geno[[chr]]$map[1,m], digits)), "\n")) } cat("\n") } sink() mapfile.male <- sub(pattern="\\.map", replacement="_male.map", x=mapfile) sink(mapfile.male) for(chr in names(cross$geno)){ cat(paste0("group ", chr, "\n")) for(m in 1:ncol(cross$geno[[chr]]$map)){ cat(paste0(colnames(cross$geno[[chr]]$map)[m], "\t", ifelse(is.null(digits), cross$geno[[chr]]$map[2,m], round(cross$geno[[chr]]$map[2,m], digits)), "\n")) } cat("\n") } sink() } else{ sink(mapfile) for(chr in names(cross$geno)){ cat(paste0("group ", chr, "\n")) for(m in 1:length(cross$geno[[chr]]$map)){ cat(paste0(names(cross$geno[[chr]]$map)[m], "\t", ifelse(is.null(digits), cross$geno[[chr]]$map[m], round(cross$geno[[chr]]$map[m], digits)), "\n")) } cat("\n") } sink() } } write.cross.mq.qua <- function(cross, quafile, digits=NULL) { sink(quafile) cat(paste0("ntrt = ", nphe(cross), "\n")) cat(paste0("nind = ", nind(cross), "\n")) cat(paste0("miss = ", NA, "\n")) cat("\n") colnames(cross$pheno) <- gsub(pattern=" ", replacement="_", x=colnames(cross$pheno)) if(any(nchar(colnames(cross$pheno)) > 20)){ sink() msg <- paste("phenotype name", colnames(cross$pheno)[which(nchar(colnames(cross$pheno)) > 20)[1]], "is longer than 20 characters") stop(msg, call.=FALSE) } cat(colnames(cross$pheno)[1]) if(ncol(cross$pheno) > 1) for(j in 2:ncol(cross$pheno)) cat(paste0("\t", colnames(cross$pheno)[j])) cat("\n") cat("\n") if(is.null(digits)){ write.table(x=cross$pheno, file=quafile, append=TRUE, quote=FALSE, sep="\t", row.names=FALSE, col.names=FALSE) } else write.table(x=format(x=cross$pheno, digits=digits, trim=TRUE), file=quafile, append=TRUE, quote=FALSE, sep="\t", row.names=FALSE, col.names=FALSE) sink() } # end of write.cross.mq.R qtl/R/fitstahl.R0000644000176200001440000003657313576241200013232 0ustar liggesusers###################################################################### # # fitstahl.R # # copyright (c) 2006-2019, Karl W Broman # last modified Dec, 2019 # first written Aug, 2006 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: fitstahl, fitstahl.estp, fitstahl.este, fitstahl.estpe, # fitstahl.estp.sub, fitstahl.este.sub, fitstahl.estpe.sub # ###################################################################### ###################################################################### # fitstahl # # Fit the Stahl model for crossover interference (or the chi-square # model, which is a special case) # # cross: the cross object # # chr: Chromosome(s) to use; if unspecified, pooled estimates for # all chromosomes are obtained # # m: Interference parameter (a non-negative integer); if unspecified, # this is estimated # # p: The proportion of chiasmata coming from the no interference # mechanism in the Stahl model (0 <= p <= 1). p=0 gives the # chi-square model. If unspecified, this is estimated # # error.prob The genotyping error probability. If = NULL, it is # estimated # # NOTE: If m, p, error.prob are all specified, they can be vectors # or have length 1; any with length > 1 should all have the # same length # # maxit Maximum number of iterations # # tol Tolerance for convergence # # maxm Maximum value of m to consider, if m is unspecified. # ###################################################################### fitstahl <- function(cross, chr, m, p, error.prob=0.0001, maxit=4000, tol=1e-4, maxm=15, verbose=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") type <- crosstype(cross) if(type != "bc" && type != "f2") stop("fitstahl only working for backcrosses and intercrosses.") if(!missing(chr)) cross <- subset(cross, chr) if(!missing(error.prob) && any(error.prob > 0.5)) warning("You probably want to use error.prob <= 0.5.") if(!missing(m)) { # m was specified if(!missing(p)) { # p was specified # m, p, error.prob all specified if(!is.null(error.prob)) { n <- c(length(m), length(p), length(error.prob)) mn <- max(n) if(mn > 1) { if(any(n > 1 & n < mn)) stop("Any m, p, error.prob with length > 1 must have same length") if(length(m) == 1) m <- rep(m, mn) if(length(p) == 1) p <- rep(p, mn) if(length(error.prob) == 1) error.prob <- rep(error.prob, mn) } result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { temp <- fitstahl.estp.sub(p[i], cross, error.prob[i], m[i], tol, maxit) result[i,] <- c(m[i], p[i], error.prob[i], as.numeric(temp)) cross <- replace.map(cross, attr(temp, "map")) if(verbose) cat(i,result[i,], "\n") } } # m,p specified but error.prob wasn't else { if(length(m) == 1) m <- rep(m, length(p)) else { if(length(p) == 1) p <- rep(p, length(m)) else if(length(m) != length(p)) stop("Any m, p, error.prob with length > 1 must have same length") } mn <- length(m) result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { temp <- fitstahl.este(cross, m[i], p[i], tol, maxit) cross <- replace.map(cross, attr(temp, "map")) result[i,] <- c(m[i], p[i], temp$est, temp$loglik) if(verbose) cat(i, result[i,], "\n") } } } else { # m, error.prob specified; p unspecified if(!is.null(error.prob)) { if(length(m) == 1) m <- rep(m, length(error.prob)) else { if(length(error.prob) == 1) error.prob <- rep(error.prob, length(m)) else if(length(m) != length(error.prob)) stop("Any m, p, error.prob with length > 1 must have same length") } mn <- length(m) result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { temp <- fitstahl.estp(cross, error.prob[i], m[i], tol, maxit) cross <- replace.map(cross, attr(temp, "map")) result[i,] <- c(m[i], temp$est, error.prob[i], temp$loglik) if(verbose) cat(i, result[i,], "\n") } } # only m specified else { result <- matrix(ncol=4, nrow=length(m)) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:length(m)) { temp <- fitstahl.estpe(cross, m[i], tol, maxit) cross <- replace.map(cross, attr(temp, "map")) result[i,] <- c(m[i], temp$est, temp$loglik) if(verbose) cat(i, result[i,], "\n") } } } } else { # m unspecified if(!missing(p)) { # p was specified # p, e specified if(!is.null(error.prob)) { if(length(p) == 1) p <- rep(p, length(error.prob)) else { if(length(error.prob) == 1) error.prob <- rep(error.prob, length(p)) else if(length(p) != length(error.prob)) stop("Any m, p, error.prob with length > 1 must have same length") } mn <- length(p) result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { # fit the case m=0 maxll <- fitstahl.estp.sub(p[i], cross, error.prob[i], 0, tol, maxit) cross <- replace.map(cross, attr(maxll, "map")) themax <- 0 if(verbose) cat(i, 0, maxll, "\n") for(j in 1:maxm) { curll <- fitstahl.estp.sub(p[i], cross, error.prob[i], j, tol, maxit) cross <- replace.map(cross, attr(curll, "map")) if(verbose) cat(i, j, curll, "\n") if(curll < maxll) break if(curll > maxll) { maxll <- curll themax <- j } } result[i,] <- c(themax, p[i], error.prob[i], maxll) if(verbose) cat(i, result[i,], "\n") } } # only p specified else { mn <- length(p) result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { # fit the case m=0 temp <- fitstahl.este(cross, 0, p[i], tol, maxit) cross <- replace.map(cross, attr(temp, "map")) maxll <- temp$loglik themax <- 0 themaxe <- temp$est if(verbose) cat(i, 0, 0, temp$est, maxll, "\n") for(j in 1:maxm) { temp <- fitstahl.este(cross, j, p[i], tol, maxit) cross <- replace.map(cross, attr(temp, "map")) curll <- temp$loglik if(verbose) cat(i, j, p[i], temp$est, curll, "\n") if(curll < maxll) break if(curll > maxll) { maxll <- curll themax <- j themaxe <- temp$est } } result[i,] <- c(themax, p[i], themaxe, maxll) if(verbose) cat(i, result[i,], "\n") } } } else { if(!is.null(error.prob)) { # error.prob specified; p unspecified mn <- length(error.prob) result <- matrix(ncol=4, nrow=mn) colnames(result) <- c("m", "p", "error.prob", "loglik") for(i in 1:mn) { # fit the case m=0 (in which case p doesn't matter) maxll <- fitstahl.estp.sub(0, cross, error.prob[i], 0, tol, maxit) cross <- replace.map(cross, attr(maxll, "map")) themax <- 0 themaxp <- 0 if(verbose) cat(i, 0, 0, error.prob[i], maxll, "\n") for(j in 1:maxm) { temp <- fitstahl.estp(cross, error.prob[i], j, tol, maxit) cross <- replace.map(cross, attr(temp, "map")) curll <- temp$loglik if(verbose) cat(i, j, temp$est, error.prob[i], curll, "\n") if(curll < maxll) break if(curll > maxll) { maxll <- curll themax <- j themaxp <- temp$est } } result[i,] <- c(themax, themaxp, error.prob[i], maxll) if(verbose) cat(i, result[i,], "\n") } } else { # nothing specified result <- matrix(ncol=4, nrow=1) colnames(result) <- c("m", "p", "error.prob", "loglik") # fit the case m=0 (in which case p doesn't matter) temp <- fitstahl.este(cross, 0, 0, tol, maxit) cross <- replace.map(cross, attr(temp, "map")) maxll <- temp$loglik themax <- 0 themaxest <- c(0, temp$est) if(verbose) cat(0, 0, temp$est, maxll, "\n") for(j in 1:maxm) { temp <- fitstahl.estpe(cross, j, tol, maxit) cross <- replace.map(cross, attr(temp, "map")) curll <- temp$loglik if(verbose) cat(j, temp$est, curll, "\n") if(curll < maxll) break if(curll > maxll) { maxll <- curll themax <- j themaxest <- temp$est } } result[1,] <- c(themax, themaxest, maxll) if(verbose) cat(1, result[1,], "\n") } } } as.data.frame(result, stringsAsFactors=TRUE) } ###################################################################### # fitstahl.estp: estimate p for fixed m and error.prob ###################################################################### fitstahl.estp <- function(cross, error.prob=0.0001, m=0, tol=1e-4, maxit=4000) { out <- optimize(fitstahl.estp.sub, interval=c(0,1), maximum=TRUE, cross=cross, m=m, error.prob=error.prob, thetol=tol, maxit=maxit) # make sure we fit p=0 temp <- fitstahl.estp.sub(0, cross, error.prob, m, tol, maxit) if(temp >= out[[2]]) { est <- 0 loglik <- temp themap <- attr(temp, "map") } else { est <- out[[1]] loglik <- out[[2]] themap <- attr(out[[2]], "map") } out <- list(est=est, loglik=loglik) attr(out, "map") <- themap out } fitstahl.estp.sub <- function(p, cross, error.prob=0.0001, m=0, thetol=1e-4, maxit=4000) { newmap <- est.map(cross, error.prob=error.prob, m=m, p=p, tol=thetol, maxit=maxit) out <- sum(sapply(newmap, function(a) attr(a, "loglik"))) attr(out, "map") <- newmap out } ###################################################################### # fitstahl.este: estimate error.prob for fixed m and p ###################################################################### fitstahl.este <- function(cross, m=0, p=0, tol=1e-4, maxit=4000) { out <- optimize(fitstahl.este.sub, interval=c(0,0.5), maximum=TRUE, cross=cross, m=m, p=p, thetol=tol, maxit=maxit) # make sure we fit error.prob=0 temp <- fitstahl.este.sub(0, cross, m, p, tol, maxit) if(temp >= out[[2]]) { est <- 0 loglik <- temp themap <- attr(temp, "map") } else { est <- out[[1]] loglik <- out[[2]] themap <- attr(out[[2]], "map") } out <- list(est=est, loglik=loglik) attr(out, "map") <- themap out } fitstahl.este.sub <- function(error.prob, cross, m=0, p=0, thetol=1e-4, maxit=4000) { newmap <- est.map(cross, error.prob=error.prob, m=m, p=p, tol=thetol, maxit=maxit) out <- sum(sapply(newmap, function(a) attr(a, "loglik"))) attr(out, "map") <- newmap out } ###################################################################### # fitstahl.estpe: estimate p and error.prob for fixed m ###################################################################### fitstahl.estpe <- function(cross, m=0, tol=1e-4, maxit=4000) { if(m==0) { # don't need to estimate p out <- fitstahl.este(cross, 0, 0, tol, maxit) out$est <- c(0, out$est) return(out) } out <- optim(c(0.1,0.01), fitstahl.estpe.sub, method="L-BFGS-B", lower=c(0,0), upper=c(1,0.5), control=list(fnscale=-1, maxit=maxit, factr=tol/1e-15), cross=cross, m=m, thetol=tol, maxit=maxit) if(out$convergence !=0) warning(" Didn't converge.") # make sure we fit the case p=0 temp <- fitstahl.este(cross, m, 0, tol, maxit) templl <- temp$loglik if(templl >= out$value) { est <- c(0, temp$est) loglik <- templl themap <- attr(temp, "map") } else { est <- out$par loglik <- out$value themap <- est.map(cross, error.prob=out$par[2], m=m, p=out$par[1], maxit=maxit, tol=tol) } names(est) <- c("p", "error.prob") out <- list(est=est, loglik=loglik) attr(out, "map") <- themap out } fitstahl.estpe.sub <- function(x, cross, m=0, thetol=1e-4, maxit=4000) { newmap <- est.map(cross, error.prob=x[2], m=m, p=x[1], tol=thetol, maxit=maxit) out <- sum(sapply(newmap, function(a) attr(a, "loglik"))) attr(out, "map") <- newmap out } # end of fitstahl.R qtl/R/stepwiseqtlX.R0000644000176200001440000010603214026661275014125 0ustar liggesusers###################################################################### # stepwiseqtlX.R # # copyright (c) 2013-2021, Karl W Broman and Quoc Tran # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # # Functions related to stepwise QTL analysis but with separate # penalties for autosome and X chromosome # # Contains: countqtltermsX, calc.penalties.X, stepwiseqtlX, calc.plod.X ###################################################################### ###################################################################### # count terms in a model, for use by plod, Quoc editted ###################################################################### countqtltermsX <- function(formula, qtl, ignore.covar=TRUE) # qtl is used to extract a logical vector: on "X" chr == 1 { if(is.character(formula)) formula <- as.formula(formula) factors <- attr(terms(formula), "factors")[-1,,drop=FALSE] if(any(factors > 1)) { warning("some formula terms > 1; may be a problem with the formula:\n ", deparseQTLformula(formula)) factors[factors > 1] <- 1 } nterm <- apply(factors, 2, sum) if(any(nterm>2)) stop("Can't deal with higher-order interactions\n") # need to check for QTL x covariate interactions in here! if(ignore.covar) { cn <- colnames(factors) wh <- c(grep("^[Qq][0-9]+$", cn), grep("^[Qq][0-9]+:[Qq][0-9]+$", cn)) rn <- rownames(factors) wh2 <- c(grep("^[Qq][0-9]+$", rn), grep("^[Qq][0-9]+:[Qq][0-9]+$", rn)) factors <- factors[wh2,wh, drop=FALSE] } nterm <- apply(factors, 2, sum) nmain <- sum(nterm==1) qtltype <- qtl$chrtype names(qtltype) <- qtl$altname factors.main <- factors[,nterm==1, drop=FALSE] # Get first order factors nmainA <- sum(qtltype[colnames(factors.main)]=="A") nmainX <- sum(qtltype[colnames(factors.main)]=="X") if(all(nterm==1)) return(c(mainA=nmainA, mainX=nmainX, intH=0, intL=0, intAX=0, intXX=0, inttot=0)) n.int <- sum(nterm==2) if(n.int <=0) # 0 interactions, so no need to figure them out return(c(mainA=nmainA, mainX=nmainX, intH=0, intL=n.int, intAX=0, intXX=0, inttot=n.int)) factors <- factors[, nterm==2, drop=FALSE] # Get second order factors wh <- apply(factors, 2, function(a) which(a==1)) # Get the location of interaction, check for X here. if(n.int ==1){ # 1 interaction, check if it is AA AX or XX int.type <- sum(qtltype[rownames(factors)[wh[,1]]]=="X") #0 is AA, 1 is AX, 2 is XX if (int.type == 0) return(c(mainA=nmainA, mainX=nmainX, intH=0, intL=1, intAX=0, intXX=0, inttot=n.int)) else if (int.type == 1) return(c(mainA=nmainA, mainX=nmainX, intH=0, intL=0, intAX=1, intXX=0, inttot=n.int)) else return(c(mainA=nmainA, mainX=nmainX, intH=0, intL=0, intAX=0, intXX=1, inttot=n.int)) } u <- sort(unique(as.numeric(wh))) # Unique nodes with interactions, in increasing order; does not contain isolated nodes grp <- rep(NA, length(u)) # Group member, length = number of node names(grp) <- u ngrp <- 0 # Number of group nintAA <- NULL # Number of AA interaction of specific group nintAX <- NULL # Number of AX interaction of specific group nintXX <- NULL # Number of XX interaction of specific group for(i in 1:ncol(wh)) { thegrp <- grp[as.character(wh[,i])] int.type <- sum(qtltype[rownames(factors)[wh[,i]]]=="X") #0 is AA, 1 is AX, 2 is XX if(all(!is.na(thegrp))) { # Merge 2 groups nintAA[as.character(thegrp[1])] <- sum(nintAA[unique(as.character(thegrp))]) nintAX[as.character(thegrp[1])] <- sum(nintAX[unique(as.character(thegrp))]) nintXX[as.character(thegrp[1])] <- sum(nintXX[unique(as.character(thegrp))]) if (int.type==0) nintAA[as.character(thegrp[1])] <- nintAA[as.character(thegrp[1])] + 1 if (int.type==1) nintAX[as.character(thegrp[1])] <- nintAX[as.character(thegrp[1])] + 1 if (int.type==2) nintXX[as.character(thegrp[1])] <- nintXX[as.character(thegrp[1])] + 1 grp[grp==thegrp[1] | grp==thegrp[2]] <- thegrp[1] } # two connected group become one group and has the name of the first group, number of interaction is updated else if(any(!is.na(thegrp))) { # add 1 more interaction to current group grp[as.character(wh[,i])] <- thegrp[!is.na(thegrp)] if (int.type==0) nintAA[as.character(thegrp[!is.na(thegrp)])] <- nintAA[as.character(thegrp[!is.na(thegrp)])] + 1 if (int.type==1) nintAX[as.character(thegrp[!is.na(thegrp)])] <- nintAX[as.character(thegrp[!is.na(thegrp)])] + 1 if (int.type==2) nintXX[as.character(thegrp[!is.na(thegrp)])] <- nintXX[as.character(thegrp[!is.na(thegrp)])] + 1 } else { # introduce new group ngrp <- ngrp+1 grp[as.character(wh[,i])] <- ngrp # Initialize nint nintAA[as.character(ngrp)] <- 0 nintAX[as.character(ngrp)] <- 0 nintXX[as.character(ngrp)] <- 0 if (int.type==0) nintAA[as.character(ngrp)] <- 1 if (int.type==1) nintAX[as.character(ngrp)] <- 1 if (int.type==2) nintXX[as.character(ngrp)] <- 1 } } nintAA <- nintAA[as.character(unique(grp))] nintAX <- nintAX[as.character(unique(grp))] nintXX <- nintXX[as.character(unique(grp))] nL <- sum(nintAA>0) nH <- sum(nintAA)-nL c(mainA=nmainA, mainX=nmainX, intH=nH, intL=nL, intAX=sum(nintAX), intXX=sum(nintXX), inttot=nH+nL+sum(nintAX)+sum(nintXX)) } ###################################################################### # calculate penalties for pLOD using scantwo permutation results, Quoc editted ###################################################################### calc.penalties.X <- function(perms, alpha=0.05, lodcolumn) { if(missing(perms) || !("scantwoperm" %in% class(perms))) stop("You must include permutation results from scantwo.") if(!("AA" %in% names(perms))) stop("perms need to be X-chr-specific") if(length(alpha) > 1) { alpha <- alpha[1] warning("alpha needs to be a single value; only the first will be used.") } if(missing(lodcolumn) || is.null(lodcolumn)) { if(is.matrix(perms[[1]][[1]]) && ncol(perms[[1]][[1]]) > 1) lodcolumn <- 1:ncol(perms[[1]][[1]]) else lodcolumn <- 1 } if(length(lodcolumn)>1) { result <- NULL for(i in seq(along=lodcolumn)) { temp <- calc.penalties.X(perms, alpha, lodcolumn[i]) result <- rbind(result, temp) } dimnames(result) <- list(colnames(perms[[1]][[1]])[lodcolumn], names(temp)) return(result) } if(is.matrix(perms[[1]][[1]]) && ncol(perms[[1]][[1]]) >1) { if(lodcolumn < 1 || lodcolumn > ncol(perms[[1]][[1]])) stop("lodcolumn misspecified") for(j in 1:3) { for(i in seq(along=perms[[j]])) perms[[j]][[i]] <- perms[[j]][[i]][,lodcolumn,drop=FALSE] } } qu <- summary(perms, alpha=alpha) c(mainA=qu$AA$one, mainX=qu$XX$one, intH=qu$AA$int, intL=qu$AA$fv1 - qu$AA$one, intAX=qu$AX$int, intXX=qu$XX$int) } ###################################################################### # stepwiseqtlX, work for data with both A and X chromosomes, # Need a check for X chromosome to switch back to standard stepwiseqtl # This is derived from stepwiseqtl (R/qtl v1.25.14) # 2 more variables than stepwiseqtl: # stop.rule (default at 0), 0 - no early stopping rule, # 1 - early stoping rule; plod<-k_f*mainA, # 2 - early stoping rule; plod 1) stop("Chromosomes ", paste(wh, collapse=", "), " (in QTL object) not in cross object.") else stop("Chromosome ", wh, " (in QTL object) not in cross object.") } if(is.null(formula)) { # create a formula with all covariates and all QTL add've if(!is.null(covar)) formula <- paste("y ~ ", paste(names(covar), collapse="+"), "+") else formula <- "y ~ " formula <- paste(formula, paste(paste("Q", 1:length(qtl$chr), sep=""), collapse="+")) } else { temp <- checkStepwiseqtlStart(qtl, formula, covar) qtl <- temp$qtl formula <- temp$formula } startatnull <- FALSE } else { if(!is.null(formula)) warning("formula ignored if qtl is not provided.") startatnull <- TRUE } # revise names in qtl object if(!startatnull) qtl$name <- qtl$altname # check that we have the right stuff for the selected method if(method=="imp") { if(!("draws" %in% names(cross$geno[[1]]))) { if("prob" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("You need to first run sim.geno.") } } else { if(!("prob" %in% names(cross$geno[[1]]))) { if("draws" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("You need to first run calc.genoprob.") } } if(method=="imp") qtlmethod <- "draws" else qtlmethod <- "prob" if(!is.null(qtl) && qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(!is.null(qtl) && method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } # check that qtl object matches the method if(!startatnull) { if(method=="imp" && !("geno" %in% names(qtl))) stop("The qtl object doesn't contain imputations; re-run makeqtl with what=\"draws\".") else if(method=="hk" && !("prob" %in% names(qtl))) stop("The qtl object doesn't contain QTL genotype probabilities; re-run makeqtl with what=\"prob\".") } # check phenotypes and covariates; drop ind'ls with missing values if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("stepwiseqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { pheno <- pheno[!hasmissing] cross <- subset(cross, ind=!hasmissing) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] if(!startatnull) { if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else { for(i in seq(along=qtl$prob)) qtl$prob[[i]] <- qtl$prob[[i]][!hasmissing,,drop=FALSE] } qtl$n.ind <- sum(!hasmissing) } } if(max.qtl < 1) stop("Need max.qtl > 0 if we are to scan for qtl") if(is.null(covar)) { lod0 <- 0 if(startatnull) firstformula <- y~Q1 else firstformula <- formula } else { nullformula <- as.formula(paste("y~", paste(names(covar), collapse="+"))) tempqtl <- makeqtl(cross, chrnames(cross)[1], 0, what=ifelse(method=="imp", "draws", "prob")) fit <- fitqtl(cross, pheno.col, tempqtl, covar=covar, formula=nullformula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod0 <- fit$result.full[1,4] if(startatnull) firstformula <- as.formula(paste("y~", paste(names(covar), collapse="+"), "+", "Q1")) else firstformula <- formula } cross.type <- class(cross)[1] if(verbose > 2) verbose.scan <- TRUE else verbose.scan <- FALSE curbest <- NULL curbestplod <- 0 # initial scan : either 1d or 2d if(verbose) cat(" -Initial scan\n") if(startatnull) { # Quoc: changed if(forceXcovar) { if(is.null(covar)) covar.w.X <- Xcovar else covar.w.X <- cbind(covar, Xcovar) } else covar.w.X <- covar suppressWarnings(out.scanone <- scanone(cross, pheno.col=pheno.col, method=method, model=model, addcovar=covar.w.X)) out.A <- subset(out.scanone, chr='-X') out.X <- subset(out.scanone, chr='X') formula <- firstformula n.qtl <- 1 # Calculate max plod in Autosome lod.A <- max(out.A[,3], na.rm=TRUE) wh <- which(!is.na(out.A[,3]) & out.A[,3]==lod.A) if(length(wh) > 1) wh <- sample(wh, 1) qtl.A <- makeqtl(cross, as.character(out.A[wh,1]), out.A[wh,2], "Q1", what=qtlmethod) # update Autosome plod after choosing formula and qtl curplod.A <- calc.plod.X(lod.A, formula=firstformula, qtl=qtl.A, penalties=penalties) # Calculate max plod in X chr lod.X <- max(out.X[,3], na.rm=TRUE) wh <- which(!is.na(out.X[,3]) & out.X[,3]==lod.X) if(length(wh) > 1) wh <- sample(wh, 1) qtl.X <- makeqtl(cross, as.character(out.X[wh,1]), out.X[wh,2], "Q1", what=qtlmethod) # update X chr plod after choosing formula and qtl curplod.X <- calc.plod.X(lod.X, formula=firstformula, qtl=qtl.X, penalties=penalties) # Compare and choose plod between Autosome and X Chr if (curplod.X > curplod.A) { curplod <- curplod.X qtl <- qtl.X lod <- lod.X } else { curplod <- curplod.A qtl <- qtl.A lod <- lod.A } if(verbose) cat("initial lod: ", lod, "\n") } # start at null, Quoc: changed else { if(verbose) cat(" ---Starting at a model with", length(qtl$chr), "QTL\n") if(refine.locations) { if(verbose) cat(" ---Refining positions\n") rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") } qtl <- rqtl } fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod.X(lod, formula=formula, qtl=qtl, penalties=penalties) # Quoc changed attr(qtl, "pLOD") <- curplod n.qtl <- length(qtl$chr) } attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- curplod if(curplod > 0) { curbest <- qtl curbestplod <- curplod if(verbose) cat("** new best ** (pLOD increased by ", round(curplod, 4), ")\n", sep="") } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod attr(temp, "LOD") <- lod # check LOD class(temp) <- c("compactqtl", "list") thetrace <- list("0"=temp) } if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep="@"), "\n") # start stepwise search i <- 0 while(n.qtl < max.qtl) { i <- i+1 if(verbose) { cat(" -Step", i, "\n") cat(" ---Scanning for additive qtl\n") } curformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, sep="")) # Add QTL in X chr out.X <- addqtl(cross, chr="X", pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) curlod.X <- max(out.X[,3], na.rm=TRUE) wh <- which(!is.na(out.X[,3]) & out.X[,3]==curlod.X) if(length(wh) > 1) wh <- sample(wh,1) qtl.X <- addtoqtl(cross, qtl, as.character(out.X[wh,1]), out.X[wh,2], paste("Q", n.qtl+1, sep="")) curlod.X <- curlod.X+lod plod.X <- calc.plod.X(curlod.X, formula=curformula, qtl=qtl.X, penalties=penalties) # Add QTL in Autosome chr out.A <- addqtl(cross, chr="-X", pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) curlod.A <- max(out.A[,3], na.rm=TRUE) wh <- which(!is.na(out.A[,3]) & out.A[,3]==curlod.A) if(length(wh) > 1) wh <- sample(wh,1) qtl.A <- addtoqtl(cross, qtl, as.character(out.A[wh,1]), out.A[wh,2], paste("Q", n.qtl+1, sep="")) curlod.A <-curlod.A+lod plod.A <- calc.plod.X(curlod.A, formula=curformula, qtl=qtl.A, penalties=penalties) if (plod.X > plod.A) { curplod <- plod.X curqtl <- qtl.X curlod <- curlod.X } else { curplod <- plod.A curqtl <- qtl.A curlod <- curlod.A } if(verbose) cat(" plod =", curplod, "\n") curnqtl <- n.qtl+1 if(!additive.only) { for(j in 1:n.qtl) { if(verbose) cat(" ---Scanning for QTL interacting with Q", j, "\n", sep="") thisformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, "+Q", j, ":Q", n.qtl+1, sep="")) # Scanning for QTL interacting with Qj in Autosome if(verbose) cat(" ---Scanning for QTL in Autosome interacting with Q", j, "\n", sep="") out <- addqtl(cross, chr="-X", pheno.col=pheno.col, qtl=qtl, covar=covar, formula=thisformula, method=method, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) thislod <- max(out[,3], na.rm=TRUE) wh <- which(!is.na(out[,3]) & out[,3]==thislod) if(length(wh) > 1) wh <- sample(wh,1) thisqtl <- addtoqtl(cross, qtl, as.character(out[wh,1]), out[wh,2], paste("Q", n.qtl+1, sep="")) thislod <- thislod + lod thisplod <- calc.plod.X(thislod, formula=thisformula, qtl=thisqtl, penalties=penalties) if(verbose) cat(" plod =", thisplod, "\n") if(thisplod > curplod) { curformula <- thisformula curplod <- thisplod curlod <- thislod curqtl <- thisqtl curnqtl <- n.qtl+1 } # End: Scanning for QTL interacting with Qj in Autosome # Scanning for QTL interacting with Qj in X chromosome if(verbose) cat(" ---Scanning for QTL in X chromosome interacting with Q", j, "\n", sep="") out <- addqtl(cross, chr="X", pheno.col=pheno.col, qtl=qtl, covar=covar, formula=thisformula, method=method, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) thislod <- max(out[,3], na.rm=TRUE) wh <- which(!is.na(out[,3]) & out[,3]==thislod) if(length(wh) > 1) wh <- sample(wh,1) thisqtl <- addtoqtl(cross, qtl, as.character(out[wh,1]), out[wh,2], paste("Q", n.qtl+1, sep="")) thislod <- thislod + lod thisplod <- calc.plod.X(thislod, formula=thisformula, qtl=thisqtl, penalties=penalties) if(verbose) cat(" plod =", thisplod, "\n") if(thisplod > curplod) { curformula <- thisformula curplod <- thisplod curlod <- thislod curqtl <- thisqtl curnqtl <- n.qtl+1 } # End: Scanning for QTL interacting with Qj in X chromosome } if(n.qtl > 1) { if(verbose) cat(" ---Look for additional interactions\n") temp <- addint(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, qtl.only=TRUE, verbose=verbose.scan, require.fullrank=require.fullrank) if(!is.null(temp)) { formula.addint <- paste(deparseQTLformula(formula), "+", rownames(temp)) # formula of addint model thelod <- temp[,3] thelod <- thelod + lod # browser() plod.addint <- mapply(FUN=calc.plod.X, lod=thelod, formula=formula.addint, MoreArgs=list(qtl=qtl,penalties=penalties)) thisplod <- max(plod.addint, na.rm=TRUE) wh <- which(!is.na(thelod) & plod.addint==thisplod) if(length(wh) > 1) wh <- sample(wh, 1) thisformula <- as.formula(formula.addint[wh]) thislod <- thelod[wh] if(verbose) cat(" plod =", thisplod, "\n") if(thisplod > curplod) { curformula <- thisformula curplod <- thisplod curlod <- thislod curqtl <- qtl curnqtl <- n.qtl } } } } qtl <- curqtl n.qtl <- curnqtl attr(qtl, "formula") <- deparseQTLformula(curformula) attr(qtl, "pLOD") <- curplod formula <- curformula lod <- curlod if(refine.locations) { if(verbose) cat(" ---Refining positions\n") rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") qtl <- rqtl fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod.X(lod, formula=formula, qtl=qtl, penalties=penalties) attr(qtl, "pLOD") <- curplod } } if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep="@"), "\n") if(curplod > curbestplod) { if(verbose) cat("** new best ** (pLOD increased by ", round(curplod - curbestplod, 4), ")\n", sep="") curbest <- qtl curbestplod <- curplod } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod attr(temp, "LOD") <- lod # check LOD class(temp) <- c("compactqtl", "list") temp <- list(temp) names(temp) <- i thetrace <- c(thetrace, temp) } if(n.qtl >= max.qtl) break if (stop.rule==1) if(curplod < -k_f*penalties[1]) break # Add 1 Early stoping rule; plod<-k_f*mainA; k_f default at 3. if (stop.rule==2) if(curplod < (curbestplod-k_f*penalties[1])) break # Add 1 Early stoping rule; plod 1) { i <- i+1 out <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=TRUE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar)$result.drop formulas <- attr(out, "formulas") # Extract formula of dropone model # lods <- attr(out, "lods") rn <- rownames(out) # ignore things with covariates wh <- c(grep("^[Qq][0-9]+$", rn), grep("^[Qq][0-9]+:[Qq][0-9]+$", rn)) out <- out[wh,,drop=FALSE] formulas <- formulas[wh,drop=FALSE] # lods <- lods[wh,drop=FALSE] thelod <- out[,3] plod.dropone <- mapply(FUN=calc.plod.X, lod=lod-thelod, formula=formulas, MoreArgs=list(qtl=qtl,penalties=penalties)) maxplod <- max(plod.dropone, na.rm=TRUE) wh <- which(!is.na(thelod) & plod.dropone==maxplod) if(length(wh) > 1) wh <- sample(wh, 1) lod <- lod - thelod[wh] # End of Quoc change, below code is unchanged. todrop <- rownames(out)[wh] if(verbose) cat(" ---Dropping", todrop, "\n") if(length(grep(":", todrop)) > 0) { # dropping an interaction theterms <- attr(terms(formula), "factors") wh <- colnames(theterms)==todrop if(!any(wh)) stop("Confusion about what interation to drop!") theterms <- colnames(theterms)[!wh] formula <- as.formula(paste("y~", paste(theterms, collapse="+"))) } else { numtodrop <- as.numeric(substr(todrop, 2, nchar(todrop))) theterms <- attr(terms(formula), "factors") cn <- colnames(theterms) g <- c(grep(paste("^[Qq]", numtodrop, "$", sep=""), cn), grep(paste("^[Qq]", numtodrop, ":", sep=""), cn), grep(paste(":[Qq]", numtodrop, "$", sep=""), cn)) cn <- cn[-g] formula <- as.formula(paste("y~", paste(cn, collapse="+"))) if(n.qtl > numtodrop) { for(j in (numtodrop+1):n.qtl) formula <- reviseqtlnuminformula(formula, j, j-1) } qtl <- dropfromqtl(qtl, index=numtodrop) qtl$name <- qtl$altname <- paste("Q", 1:qtl$n.qtl, sep="") n.qtl <- n.qtl - 1 } curplod <- calc.plod.X(lod, formula=formula, qtl=qtl, penalties=penalties) # browser() if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep=":"), "\n") attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- curplod if(refine.locations) { if(verbose) cat(" ---Refining positions\n") if(!is.null(qtl)) { rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") qtl <- rqtl fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod.X(lod, formula=formula, qtl=qtl, penalties=penalties) attr(qtl, "pLOD") <- curplod } } } if(curplod > curbestplod) { if(verbose) cat("** new best ** (pLOD increased by ", round(curplod - curbestplod, 4), ")\n", sep="") # browser() curbestplod <- curplod curbest <- qtl } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod attr(temp, "LOD") <- lod # check LOD class(temp) <- c("compactqtl", "list") temp <- list(temp) names(temp) <- i thetrace <- c(thetrace, temp) } } # re-form the qtl if(!is.null(curbest)) { chr <- curbest$chr pos <- curbest$pos o <- order(factor(chr, levels=names(cross$geno)), pos) qtl <- makeqtl(cross, chr[o], pos[o], what=qtlmethod) # need to redo numbering in formula formula <- as.formula(attr(curbest, "formula")) if(length(chr) > 1) { n.qtl <- length(chr) for(i in 1:n.qtl) formula <- reviseqtlnuminformula(formula, i, n.qtl+i) for(i in 1:n.qtl) formula <- reviseqtlnuminformula(formula, n.qtl+o[i], i) } if(keeplodprofile) { if(verbose) cat(" ---One last pass through refineqtl\n") qtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=TRUE, forceXcovar=forceXcovar) } attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- attr(curbest, "pLOD") curbest <- qtl } else { curbest <- numeric(0) class(curbest) <- "qtl" attr(curbest,"pLOD") <- 0 } if(keeptrace) attr(curbest, "trace") <- thetrace attr(curbest, "formula") <- deparseQTLformula(attr(curbest, "formula"), TRUE) attr(curbest, "penalties") <- penalties curbest } ###################################################################### # penalized LOD score, Quoc changed, now central function for pLOD ###################################################################### calc.plod.X <- function(lod, nterms, type=c("f2","bc"), penalties, formula, qtl) { if (missing(nterms) && (!missing(formula) && !is.null(formula)) && !missing(qtl)) nterms <- countqtltermsX(formula, qtl) nterms <- nterms[1:6] if(any(penalties==Inf & nterms > 0)) return(-Inf) as.numeric(lod - sum((nterms*penalties)[nterms > 0])) } # end of stepwiseqtlX.R qtl/R/mqmcircleplot.R0000644000176200001440000002556513576241200014266 0ustar liggesusers##################################################################### # # mqmcircleplot.R # # Copyright (c) 2009-2019, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified December 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmplot_c # mqmplotcircle # mqmplot_circle # circlelocations # drawspline # getchromosomelength # getgenomelength # locationtocircle # drawcirculargenome # loopthroughmulti # # ##################################################################### mqmplot.circle <- function(cross, result, highlight=0, spacing=25, interactstrength=2, axis.legend = TRUE, col.legend=FALSE, verbose=FALSE, transparency=FALSE){ if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } retresults <- NULL lod<-FALSE if(inherits(result, "mqmmulti")){ if(highlight > 0){ templateresult <- mqmextractmarkers(result[[highlight]]) lod<-TRUE }else{ templateresult <- mqmextractmarkers(result[[1]]) lod<-FALSE } }else{ templateresult <- mqmextractmarkers(result) lod<-TRUE } if(!inherits(templateresult, "scanone")) { stop("Wrong type of result file, please supply a valid scanone object.") } if(transparency){ colorz <- rainbow(length(result), alpha=0.8) }else{ colorz <- rainbow(length(result)) } if(!col.legend){ totallength <- getgenomelength(templateresult) nchr <- length(unique(templateresult[,1])) cvalues <- circlelocations(totallength+(nchr*spacing)) drawcirculargenome(templateresult,spacing=spacing,lodmarkers=lod) if(inherits(result, "mqmmulti")){ #multiple scan results, so plot em all todo <- 1:length(result) if(highlight!=0){ #Unless we highlight only one of them todo <- highlight } for(x in todo){ model <- mqmgetmodel(result[[x]]) if(!is.null(model)){ if(verbose) cat("Model found for trait ",x,"\n") if(!is.null(cross$locations)){ if(verbose) cat("Locations of traits available\n") location <- cross$locations[[x]] traitl <- locationtocircle(templateresult,location[[1]],location[[2]],spacing=spacing) }else{ if(verbose) cat("Locations of traits not available\n") traitl <- t(c(0,0+0.25*(0.5-(x/length(result))))) } if(highlight==0){ col=colorz[x] }else{ col=rgb(0.1, 0.1, 0.1, 0.1) if(highlight==x) title(main = paste("Circleplot of:",colnames(cross$pheno)[x])) } for(y in 1:length(model[[4]])){ qtll <- locationtocircle(templateresult,model[[4]][y],model[[5]][y],spacing=spacing) if(highlight==x){ for(z in y:length(model[[4]])){ if(!z==y){ cross <- sim.geno(cross) eff <- effectplot(cross,pheno.col=x,mname1=model$name[y],mname2=model$name[z],draw=FALSE) changeA <- (eff$Means[1,2]-eff$Means[1,1]) changeB <- (eff$Means[2,2]-eff$Means[2,1]) #interaction qtl2 <- locationtocircle(templateresult,model[[4]][z],model[[5]][z],spacing=spacing) if(!is.na(changeA) && !is.na(changeB) && !any(is.na(eff$SEs))){ col <- "blue" if(changeA/abs(changeA) < changeB/abs(changeB)) col <- "green" if(abs(abs(changeA)-abs(changeB)) > interactstrength*mean(eff$SEs)){ retresults <- rbind(retresults,c(model$name[y],model$name[z],changeA,changeB,mean(eff$SEs))) drawspline(qtll,qtl2,lwd=2,col=col) } } } } } if(highlight==0){ points(traitl,col=col,pch=24,cex=1) drawspline(traitl,qtll,col=col) points(qtll*(1+0.1*((x/length(result)))),col=col,pch=19,cex=1) } } }else{ if(verbose) cat("Trait ",x," has no model\n") } } if(axis.legend) legend("topleft",c("Trait","QTL"),col=c("black","black"),pch=c(24,19),cex=1) } if(inherits(result, "scanone") || highlight > 0){ #single scan result or highlighting one of the multiple if(!inherits(result, "scanone")){ #Just highlight the template result result <- templateresult } model <- mqmgetmodel(result) if(!is.null(model)){ for(y in 1:length(model[[4]])){ qtll <- locationtocircle(templateresult,model[[4]][y],model[[5]][y],spacing=spacing) points(qtll,col="red",pch=19,cex=1) text(qtll*1.15,model[[2]][y],col="red",cex=0.7) if(!is.null(cross$locations)){ location <- cross$locations[[highlight]] traitl <- locationtocircle(templateresult,location[[1]],location[[2]],spacing=spacing) points(traitl,col="red",lwd=2,pch=24,cex=1.5) }else{ traitl <- c(0,0) } if(!(highlight>0))drawspline(traitl,qtll,col="red") } } if(axis.legend) legend("topright",c("Selected cofactor(s)","Epistasis (+)","Epistasis (-)"), col=c("red", "blue", "green"), pch=19, lwd=c(0,1,2), cex=0.75) if(axis.legend) legend("bottomright",c("LOD 3","LOD 6","LOD 9","LOD 12"), pch=19, lwd=0, pt.cex = c(1, 2, 3, 4), cex=0.75) if(highlight==0) title(sub = "Single trait") } }else{ plot(c(-1,1), c(-1, 1), type = "n", axes = FALSE, xlab = "", ylab = "") title(main = "Legend to circular genome plot") legend("center", paste(colnames(cross$pheno)), col=colorz, pch=19, cex=0.75) } if(!is.null(retresults)){ colnames(retresults) <- c("Marker","Marker","Change","Change","SEs") retresults <- as.data.frame(retresults, stringsAsFactors=TRUE) return(invisible(retresults)) } } circlelocations <- function(nt){ medpoints <- matrix(nrow = nt, ncol = 2) phi <- seq(0, 2 * pi, length = (nt + 1)) complex.circle <- complex(modulus = 1, argument = phi) for (j in 1:nt) { medpoints[j, ] <- c(Im(complex.circle[j]), Re(complex.circle[j])) } medpoints } drawspline <- function (cn1, cn2, lwd = 1,col="blue",...){ x <- cbind(cn1[1],0,cn2[1]) y <- cbind(cn1[2],0,cn2[2]) r <- xspline(x, y, lty=1, shape=1, lwd=lwd, border=col,...) } getchromosomelength <- function(result, chr){ l <- ceiling(max(result[which(result[,1]==chr),2])) l } getgenomelength <- function(result){ l <- 1 for(x in unique(result[,1])){ l <- l + getchromosomelength(result,x) } l } locationtocircle <- function(result, chr, loc, spacing=50, fixoutofbounds=TRUE, verbose=FALSE){ templateresult <- result totallength <- getgenomelength(result) nchr <- length(unique(templateresult[,1])) cvalues <- circlelocations(totallength+(nchr*spacing)) l <- 1 for(x in unique(templateresult[,1])){ if(x==chr){ if(loc < getchromosomelength(result,x)){ return(t(cvalues[(l+loc),])) }else{ if(verbose) cat("Location out of chromosome bounds",loc," ",getchromosomelength(result,x),"\n") if(fixoutofbounds) return(t(cvalues[(l+getchromosomelength(result,x)),])) stop(paste("Location out of chromosome bounds",loc," ",getchromosomelength(result,x),"\n")) } } l <- l + getchromosomelength(result,x) + spacing } stop("No such chromosome") } drawcirculargenome <- function(result,lodmarkers=FALSE,spacing=50){ result <- mqmextractmarkers(result) plot(c(-1.1, 1.1), c(-1.1, 1.1), type = "n", axes = FALSE, xlab = "", ylab = "") totallength <- getgenomelength(result) nchr <- length(unique(result[,1])) cvalues <- circlelocations(totallength+(nchr*spacing)) l <- 1 for(x in unique(result[,1])){ #Draw chromosomes nl <- l+getchromosomelength(result,x) lines(cvalues[l:nl,],cex=0.01) l <- nl + spacing } for(x in 1:nrow(result)){ #Draw markers if(lodmarkers){ points(locationtocircle(result,result[x,1],result[x,2],spacing=spacing),pch=20,cex=min(c((result[x,3]),4))) }else{ points(locationtocircle(result,result[x,1],result[x,2],spacing=spacing),pch=20) } } for(x in unique(result$chr)) { chrnumberloc <- locationtocircle(result,x,getchromosomelength(result,x)/2,spacing=spacing) points(t(c(-1.1, -1.15))) points(t(c(-0.9, -1.15))) points(t(c(-0.7, -1.15))) text(t(c(-0.9, -1.0)),paste("Distances in cM"),cex=0.8) text(t(c(-1.1, -1.1)),paste("0 cM"),cex=0.7) text(t(c(-0.9, -1.1)),paste(round((totallength+(nchr*spacing))*(0.2/(2*pi)),digits=1),"cM"),cex=0.7) text(t(c(-0.7, -1.1)),paste(round((totallength+(nchr*spacing))*(0.4/(2*pi)),digits=1),"cM"),cex=0.7) text(0.9*chrnumberloc,paste("Chr",x),cex=0.8) } } loopthroughmulti <- function(cross,result,save=FALSE,spacing=100){ n <- 1 while(n <= length(result)){ if(save) png(filename=paste("circleplotT",n,".png",sep=""),width=1024,height=768) mqmplot.circle(cross,result,spacing=spacing,highlight=n) if(save) dev.off() n <- n+1 } } qtl/R/compareorder.R0000644000176200001440000000577412770016226014100 0ustar liggesusers###################################################################### # # compareorder.R # # copyright (c) 2007-2011, Karl W Broman # last modified May, 2011 # first written Oct, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: compareorder # ###################################################################### ###################################################################### # Calculate likelihood for a fixed order of markers on a given # chromosome versus the current one ###################################################################### compareorder <- function(cross, chr, order, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), maxit=4000, tol=1e-6, sex.sp=TRUE) { if(missing(chr)) chr <- names(cross$geno)[1] if(length(chr) > 1) { chr <- chr[1] warning("compareorder works on a single chromosome.") } map.function <- match.arg(map.function) cross <- subset(cross, chr) if(length(order) != totmar(cross)) { if(length(order) == totmar(cross)+1 || length(order) == totmar(cross)+2) order <- order[1:totmar(cross)] else stop("Argument 'order' should have length ", totmar(cross)) } if(any(is.na(match(1:totmar(cross), order)))) stop("order should be a permutation of the numbers 1, 2, ..., ", totmar(cross)) orig <- est.map(cross, error.prob=error.prob, map.function=map.function, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE) cross$geno[[1]]$data <- cross$geno[[1]]$data[,order] new <- est.map(cross, error.prob=error.prob, map.function=map.function, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE) result <- matrix(0, ncol=2, nrow=2) dimnames(result) <- list(c("orig","new"), c("LOD", "length")) result[2,1] <- (attr(new[[1]], "loglik") - attr(orig[[1]], "loglik"))/log(10) if(is.matrix(orig[[1]])) { result[,2] <- c(diff(range(orig[[1]][1,])), diff(range(new[[1]][1,]))) if(sex.sp) { result <- cbind(result, c(diff(range(orig[[1]][2,])), diff(range(new[[1]][2,])))) colnames(result)[2:3] <- c("femaleLength","maleLength") } } else result[,2] <- c(diff(range(orig[[1]])), diff(range(new[[1]]))) as.data.frame(result, stringsAsFactors=TRUE) } # end of compareorder.R qtl/R/est.map.R0000644000176200001440000002764713576241200012765 0ustar liggesusers###################################################################### # # est.map.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Apr, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: est.map # ###################################################################### ###################################################################### # # est.map: re-estimate the genetic map for an experimental cross # ###################################################################### est.map <- function(cross, chr, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), m=0, p=0, maxit=10000, tol=1e-6, sex.sp=TRUE, verbose=FALSE, omit.noninformative=TRUE, offset, n.cluster=1) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) type <- crosstype(cross) if(!missing(offset)) { if(length(offset)==1) offset <- rep(offset, nchr(cross)) else if(length(offset) != nchr(cross)) stop("offset must have length 1 or n.chr (", nchr(cross), ")") } if(m < 0 || p < 0 || p > 1) stop("Must have m >=0 and 0 <= p <= 1") if(m > 0 && p < 1 && type != "bc" && type != "f2") { warning("m and p currently used only for backcrosses and intercrosses.") m <- p <- 0 } if(m > 0 && p < 1 && !missing(map.function)) warning("Map function not used with interference model.") if(m > 0 && p < 1) interf.model <- TRUE else interf.model <- FALSE # map function map.function <- match.arg(map.function) if(map.function=="kosambi") { mf <- mf.k; imf <- imf.k } else if(map.function=="c-f") { mf <- mf.cf; imf <- imf.cf } else if(map.function=="morgan") { mf <- mf.m; imf <- imf.m } else { mf <- mf.h; imf <- imf.h } # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.mar <- nmar(cross) n.chr <- nchr(cross) newmap <- vector("list",n.chr) names(newmap) <- names(cross$geno) chr_type <- sapply(cross$geno, chrtype) if(n.cluster > 1 && nchr(cross) > 1) { cat(" -Running est.map via a cluster of", n.cluster, "nodes.\n") cl <- makeCluster(n.cluster) clusterStopped <- FALSE on.exit(if(!clusterStopped) stopCluster(cl)) clusterEvalQ(cl, library(qtl, quietly=TRUE)) chr <- names(cross$geno) # temporary definition of est.map temp.est.map <- function(chr, cross, error.prob, map.function, m, p, maxit, tol, sex.sp, omit.noninformative) est.map(cross=cross, chr=chr, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, omit.noninformative=omit.noninformative, verbose=FALSE)#, n.cluster=1) newmap <- clusterApplyLB(cl, chr, temp.est.map, cross, error.prob, map.function, m, p, maxit, tol, sex.sp, omit.noninformative) for(i in seq(along=newmap)) { newmap[[i]] <- newmap[[i]][[1]] class(newmap[[i]]) <- class(cross$geno[[i]]) } names(newmap) <- chr if(!missing(offset)) { # shift map start positions for(i in seq(along=newmap)) if(is.matrix(newmap[[i]])) { for(j in 1:2) newmap[[i]][j,] <- newmap[[i]][j,] - newmap[[i]][j,1] + offset[i] } else { newmap[[i]] <- newmap[[i]] - newmap[[i]][1] + offset[i] } } class(newmap) <- "map" return(newmap) } # calculate genotype probabilities one chromosome at a time for(i in 1:n.chr) { if(n.mar[i] < 2) { newmap[[i]] <- cross$geno[[i]]$map next } # which type of cross is this? if(type == "f2") { one.map <- TRUE if(chr_type[i] != "X") # autosomal cfunc <- "est_map_f2" else # X chromsome cfunc <- "est_map_bc" } else if(type == "bc" || type=="riself" || type=="risib" || type=="dh" || type=="haploid") { one.map <- TRUE cfunc <- "est_map_bc" } else if(type == "4way") { one.map <- FALSE cfunc <- "est_map_4way" } else if(type=="ri8sib" || type=="ri4sib" || type=="ri8self" || type=="ri4self" || type=="bgmagic16") { cfunc <- paste("est_map_", type, sep="") one.map <- TRUE if(chr_type[i] == "X") warning("est.map not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE interf.model <- FALSE cfunc <- "est_map_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(chr_type[i] == "X") { # X chromsome cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 } ## Tolerance: need two values. if(length(tol) == 1) { tol[2] <- 1e-6 } } else stop("est.map not available for cross type ", type, ".") # genotype data gen <- cross$geno[[i]]$data gen[is.na(gen)] <- 0 # remove individuals that have less than two typed markers if(omit.noninformative) { o <- apply(gen,1,function(a) sum(a!=0)>1) gen <- gen[o,,drop=FALSE] } # recombination fractions if(one.map) { # recombination fractions rf <- mf(diff(cross$geno[[i]]$map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf, sub("^ri", "", type), chr_type[i]) rf[rf < 1e-14] <- 1e-14 } else { orig <- cross$geno[[i]]$map # randomize the maps a bit [we no longer do this] # cross$geno[[i]]$map <- cross$geno[[i]]$map + # runif(length(cross$geno[[i]]$map), -0.2, 0.2) rf <- mf(diff(cross$geno[[i]]$map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(cross$geno[[i]]$map[2,])) rf2[rf2 < 1e-14] <- 1e-14 if(!sex.sp && chr_type[i]=="X") temp.sex.sp <- TRUE else temp.sex.sp <- sex.sp } if(interf.model) d <- diff(cross$geno[[i]]$map) if(verbose) cat(paste("Chr ", names(cross$geno)[i], ":\n",sep="")) # call the C function if(one.map && !interf.model) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- 0 if(type == "bcsft") temp[1] <- cross.scheme[1] * 1000 + cross.scheme[2] z <- .C(cfunc, as.integer(nrow(gen)), # number of individuals as.integer(n.mar[i]), # number of markers as.integer(gen), # genotype data rf=as.double(rf), # recombination fractions as.double(error.prob), loglik=as.double(temp), # log likelihood as.integer(maxit), as.double(tol), as.integer(verbose), PACKAGE="qtl") z$rf[z$rf < 1e-14] <- 1e-14 if(type=="riself" || type=="risib") z$rf <- adjust.rf.ri(z$rf, substr(type, 3, nchar(type)), chr_type[i], expand=FALSE) newmap[[i]] <- cumsum(c(min(cross$geno[[i]]$map),imf(z$rf))) names(newmap[[i]]) <- names(cross$geno[[i]]$map) attr(newmap[[i]],"loglik") <- z$loglik } else if(interf.model) { # Chi-square / Stahl model if(type=="bc" || (type=="f2" && chr_type[i]=="X")) { z <- .C("R_est_map_bci", as.integer(nrow(gen)), # number of individuals as.integer(n.mar[i]), # number of markers as.integer(gen), # genotype data d=as.double(d), # cM distances as.integer(m), as.double(p), as.double(error.prob), loglik=as.double(0), # log likelihood as.integer(maxit), as.double(tol), as.integer(verbose), PACKAGE="qtl") } else { z <- .C("R_est_map_f2i", as.integer(nrow(gen)), # number of individuals as.integer(n.mar[i]), # number of markers as.integer(gen), # genotype data d=as.double(d), # cM distances as.integer(m), as.double(p), as.double(error.prob), loglik=as.double(0), # log likelihood as.integer(maxit), as.double(tol), as.integer(verbose), PACKAGE="qtl") } z$d[z$d < 1e-14] <- 1e-14 newmap[[i]] <- cumsum(c(min(cross$geno[[i]]$map),z$d)) names(newmap[[i]]) <- names(cross$geno[[i]]$map) attr(newmap[[i]], "loglik") <- z$loglik attr(newmap[[i]], "m") <- m attr(newmap[[i]], "p") <- p } else { z <- .C(cfunc, as.integer(nrow(gen)), # number of individuals as.integer(n.mar[i]), # number of markers as.integer(gen), # genotype data rf=as.double(rf), # recombination fractions rf2=as.double(rf2), # recombination fractions as.double(error.prob), loglik=as.double(0), # log likelihood as.integer(maxit), as.double(tol), as.integer(temp.sex.sp), as.integer(verbose), PACKAGE="qtl") z$rf[z$rf<1e-14] <- 1e-14 z$rf2[z$rf2<1e-14] <- 1e-14 if(!temp.sex.sp) z$rf2 <- z$rf newmap[[i]] <- rbind(cumsum(c(min(orig[1,]),imf(z$rf))), cumsum(c(min(orig[2,]),imf(z$rf2)))) dimnames(newmap[[i]]) <- dimnames(cross$geno[[i]]$map) attr(newmap[[i]],"loglik") <- z$loglik } class(newmap[[i]]) <- chr_type[i] } # end loop over chromosomes if(!missing(offset)) { # shift map start positions for(i in seq(along=newmap)) if(is.matrix(newmap[[i]])) { for(j in 1:2) newmap[[i]][j,] <- newmap[[i]][j,] - newmap[[i]][j,1] + offset[i] } else { newmap[[i]] <- newmap[[i]] - newmap[[i]][1] + offset[i] } } class(newmap) <- "map" newmap } # end of est.map.R qtl/R/sim.geno.R0000644000176200001440000001711613576241200013123 0ustar liggesusers###################################################################### # # sim.geno.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: sim.geno # ###################################################################### ###################################################################### # # sim.geno: simulate from the joint distribution Pr(g | O) # ###################################################################### sim.geno <- function(cross, n.draws=16, step=0, off.end=0, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), stepwidth=c("fixed", "variable", "max")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # map function map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h stepwidth <- match.arg(stepwidth) # don't let error.prob be exactly zero, just in case if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) # calculate genotype probabilities one chromosome at a time for(i in 1:n.chr) { if(n.mar[i]==1) temp.offend <- max(c(off.end,5)) else temp.offend <- off.end chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") xchr <- TRUE else xchr <- FALSE # which type of cross is this? if(type == "f2") { n.gen <- 3 one.map <- TRUE if(!xchr) # autosomal cfunc <- "sim_geno_f2" else # X chromsome cfunc <- "sim_geno_bc" } else if(type == "bc" || type=="riself" || type=="risib" || type=="dh" || type=="haploid") { cfunc <- "sim_geno_bc" n.gen <- 2 one.map <- TRUE } else if(type == "4way") { n.gen <- 4 cfunc <- "sim_geno_4way" one.map <- FALSE } else if(type=="ri8sib" || type=="ri4sib" || type=="ri8self" || type=="ri4self" || type=="bgmagic16") { cfunc <- paste("sim_geno_", type, sep="") if(type=="bgmagic16") n.gen <- 16 else n.gen <- as.numeric(substr(type, 3, 3)) one.map <- TRUE if(xchr) warning("sim.geno not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE cfunc <- "sim_geno_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(!xchr) {# autosomal n.gen <- 3 - (cross.scheme[1] == 0) } else { # X chromsome cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 n.gen <- 2 } } else stop("sim_geno not available for cross type ", type, ".") # genotype data gen <- cross$geno[[i]]$data gen[is.na(gen)] <- 0 # recombination fractions if(one.map) { # recombination fractions map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf, sub("^ri", "", type), chr_type) rf[rf < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=length(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,names(map)) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) } else { map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(map[1,])) rf2[rf2 < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=ncol(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,colnames(map)) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) } # call C function if(one.map) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- as.integer(rep(0,n.draws*n.ind*n.pos)) if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.draws), # number of simulation replicates as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(error.prob), # draws=as.integer(temp), PACKAGE="qtl") cross$geno[[i]]$draws <- array(z$draws,dim=c(n.ind,n.pos,n.draws)) dimnames(cross$geno[[i]]$draws) <- list(NULL, names(map), NULL) } else { z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.draws), # number of simulation replicates as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(rf2), # recombination fractions as.double(error.prob), # draws=as.integer(rep(0,n.draws*n.ind*n.pos)), PACKAGE="qtl") cross$geno[[i]]$draws <- array(z$draws,dim=c(n.ind,n.pos,n.draws)) dimnames(cross$geno[[i]]$draws) <- list(NULL, colnames(map), NULL) } # attribute set to the error.prob value used, for later # reference attr(cross$geno[[i]]$draws, "map") <- map attr(cross$geno[[i]]$draws,"error.prob") <- error.prob attr(cross$geno[[i]]$draws,"step") <- step attr(cross$geno[[i]]$draws,"off.end") <- temp.offend attr(cross$geno[[i]]$draws,"map.function") <- map.function attr(cross$geno[[i]]$draws,"stepwidth") <- stepwidth } # store simulated genotypes as integers for(i in 1:nchr(cross)) storage.mode(cross$geno[[i]]$draws) <- "integer" return(cross) # 4- and 8-way RIL: reorganize the results if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") cross <- reorgRIdraws(cross) cross } # end of sim.geno.R qtl/R/phyloqtl_scan.R0000644000176200001440000002746113762276154014305 0ustar liggesusers###################################################################### # phyloqtl_scan.R # # copyright (c) 2009-2020, Karl W Broman # last modified Dec, 2020 # first written May, 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Single-QTL scan to map QTL to a phylogenetic tree # # Part of the R/qtl package # Contains: scanPhyloQTL, max.scanPhyloQTL, plot.scanPhyloQTL, # inferredpartitions # ###################################################################### scanPhyloQTL <- function(crosses, partitions, chr, pheno.col=1, model=c("normal","binary"), method=c("em","imp","hk"), addcovar, maxit=4000, tol=0.0001, useAllCrosses=TRUE, verbose=FALSE) { if(missing(chr)) chr <- names(crosses[[1]]$geno) model <- match.arg(model) method <- match.arg(method) thecrosses <- names(crosses) taxa <- sort(unique(unlist(strsplit(thecrosses, "")))) thecrosses <- names(crosses) <- checkPhyloCrosses(thecrosses, taxa) if(missing(partitions)) { # generate all partitions partitions <- genAllPartitions(length(taxa), taxa) } checkPhyloPartition(partitions, taxa) crossmat <- qtlByPartition(thecrosses, partitions) dimnames(crossmat) <- list(thecrosses, partitions) if(!missing(addcovar)) { if(!is.list(addcovar) || length(addcovar) != length(crosses)) stop("addcovar must be a list with the same length as crosses (", length(crosses), ")") n.ind <- sapply(crosses, nind) if(is.matrix(addcovar[[1]])) { nind.addcovar <- sapply(addcovar, nrow) n.addcovar <- sapply(addcovar, ncol) } else { nind.addcovar <- sapply(addcovar, length) n.addcovar <- 1 } if(any(nind.addcovar != n.ind)) { err <- paste("crosses: ", paste(n.ind, collapse=" "), "\n", "addcovar:", paste(n.addcovar, collapse=" "), "\n") stop("Mismatch between no. individuals in addcovar and crosses.\n", err) } if(length(unique(n.addcovar)) > 1) stop("Mismatch in no. add've covariates: ", paste(n.addcovar, collapse=" ")) } # check that the marker maps are all exactly the same n.chr <- sapply(crosses, nchr) if(!all(n.chr == n.chr[1])) stop("Different numbers of chromosomes") chrnam1 <- chrnames(crosses[[1]]) for(j in 2:length(crosses)) { chrnam2 <- chrnames(crosses[[j]]) if(!all(chrnam1 == chrnam2)) stop("Different chromosome names") } n.mar1 <- nmar(crosses[[1]]) for(j in 2:length(crosses)) { n.mar2 <- nmar(crosses[[j]]) if(!all(n.mar1 == n.mar2)) stop("Different numbers of markers") } mn1 <- markernames(crosses[[1]]) for(j in 2:length(crosses)) { mn2 <- markernames(crosses[[j]]) if(!all(mn1 == mn2)) stop("Different marker names") } mp1 <- unlist(pull.map(crosses[[1]])) for(j in 2:length(crosses)) { mp2 <- unlist(pull.map(crosses[[j]])) if(!all(mp1 == mp2)) stop("Different marker positions") } out <- vector("list", length(partitions)) for(i in seq(along=partitions)) { if(verbose) cat("Partition", i, "of", length(partitions), "\n") cm <- crossmat[,i] # if all crosses need to be flipped, don't flip any of them if(!any(cm > 0)) cm <- -cm if(!useAllCrosses) { whcm <- which(cm != 0) x <- crosses[whcm] cm <- cm[whcm] } else { o <- order(abs(cm), decreasing=TRUE) cm <- cm[o] whcm <- seq(along=cm) x <- crosses[o] if(!missing(addcovar)) addcovar <- addcovar[o] } # flip crosses if necessary if(any(cm < 0)) for(j in which(cm < 0)) x[[j]] <- flipcross(x[[j]]) # combine the crosses xx <- x[[1]] n.phe <- nphe(x[[1]]) if(length(x) > 1) { for(j in 2:length(x)) { xx <- c(xx, x[[j]]) xx$pheno <- xx$pheno[,1:n.phe,drop=FALSE] } } # create cross indicators (as additive covariates) if(length(x)==1) alladdcovar<-NULL else { ni <- sapply(x, nind) alladdcovar <- matrix(0, ncol=length(x)-1, nrow=sum(ni)) thestart <- cumsum(c(1,ni)) end <- cumsum(ni) for(j in 2:length(x)) alladdcovar[thestart[j]:end[j],j-1] <- 1 } if(!missing(addcovar)) { theaddcovar <- as.matrix(addcovar[[whcm[1]]]) if(length(whcm) > 1) for(j in 2:length(whcm)) theaddcovar <- rbind(theaddcovar, as.matrix(addcovar[[whcm[j]]])) # quick check to be sure that it's not a column with all one value if(ncol(theaddcovar)>1 || length(unique(theaddcovar))>1) alladdcovar <- cbind(alladdcovar, theaddcovar) } # ind with no QTL effect ind.noqtl <- rep(cm == 0, sapply(x, nind)) # do the scan out[[i]] <- scanone(xx, chr=chr, pheno.col=pheno.col, addcovar=alladdcovar, model=model, method=method, maxit=maxit, tol=tol, ind.noqtl=ind.noqtl) } # just one partition if(length(out) == 1) return(out[[1]]) # multiple partitions result <- out[[1]] for(j in 2:length(out)) result <- c(result, out[[j]]) colnames(result)[-(1:2)] <- partitions class(result) <- c("scanPhyloQTL", "scanone", "data.frame") result } max.scanPhyloQTL <- function(object, chr, format=c("postprob", "lod"), ...) { format <- match.arg(format) if(!missing(chr)) object <- subset.scanone(object, chr=chr) mx <- summary.scanPhyloQTL(object, format=format) if(nrow(mx) > 1) { nc <- ncol(mx) mx <- mx[!is.na(mx[,nc]) & mx[,nc]==max(mx[,nc], na.rm=TRUE),,drop=FALSE] } class(mx) <- c("summary.scanPhyloQTL", "summary.scanone", "data.frame") mx } summary.scanPhyloQTL <- function(object, format=c("postprob", "lod"), threshold, ...) { format <- match.arg(format) themax <- apply(object[,-(1:2)], 2, tapply, object[,1], max, na.rm=TRUE) if(length(unique(object[,1]))==1) { themax <- as.data.frame(matrix(themax, nrow=1), stringsAsFactors=TRUE) names(themax) <- colnames(object)[-(1:2)] } wh <- apply(themax, 1, function(a) { a <- which(a==max(a)); if(length(a) > 1) a <- sample(a, 1); a }) whpos <- rep(NA, length(wh)) names(whpos) <- unique(object[,1]) for(i in seq(along=whpos)) { temp <- object[object[,1]==names(whpos)[i],,drop=FALSE] temp2 <- which(temp[,wh[i]+2]==max(temp[,wh[i]+2],na.rm=TRUE)) if(length(temp2) > 1) temp2 <- sample(temp2, 1) whpos[i] <- temp[temp2,2] names(whpos)[i] <- rownames(temp)[temp2] } if(format=="lod") { out <- data.frame(chr=unique(object[,1]), pos=whpos, themax, loddif=apply(themax, 1, function(a) -diff(sort(a, decreasing=TRUE)[1:2])), inferred=colnames(object)[wh+2], maxlod=apply(themax, 1, max), stringsAsFactors=TRUE) } else { out <- data.frame(chr=unique(object[,1]), pos=whpos, themax, inferred=colnames(object)[wh+2], maxlod=apply(themax, 1, max), stringsAsFactors=TRUE) temp <- out[,-c(1:2, ncol(out)-0:1)] out[,-c(1:2, ncol(out)-0:1)] <- t(apply(temp, 1, function(a) 10^a/sum(10^a))) } colnames(out)[(1:ncol(themax))+2] <- colnames(themax) rownames(out) <- names(whpos) if(!missing(threshold)) out <- out[out$maxlod >= threshold,,drop=FALSE] class(out) <- c("summary.scanPhyloQTL", "summary.scanone", "data.frame") out } # plot results of scanPhyloQTL plot.scanPhyloQTL <- function(x, chr, incl.markers=TRUE, col, xlim, ylim, lwd=2, gap=25, mtick=c("line", "triangle"), show.marker.names=FALSE, alternate.chrid=FALSE, legend=TRUE, ...) { mtick <- match.arg(mtick) if(!missing(chr)) x <- subset(x, chr=chr) if(missing(col)) { col <- c("black","blue","red","green","orange","brown","gray","cyan","magenta") if(ncol(x)-2 > length(col)) stop("Please give a list of colors") col <- col[1:(ncol(x)-2)] } if(missing(ylim)) ylim <- c(0, max(apply(x[,-(1:2)], 2, max))) dots <- list(...) if(missing(xlim)) { if("ylab" %in% names(dots)) plot.scanone(x, incl.markers=incl.markers, col=col[1], lodcolumn=1, ylim=ylim, lwd=lwd, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, ...) else plot.scanone(x, incl.markers=incl.markers, col=col[1], lodcolumn=1, ylim=ylim, lwd=lwd, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, ylab="LOD score", ...) } else { if("ylab" %in% names(dots)) plot.scanone(x, incl.markers=incl.markers, col=col[1], lodcolumn=1, ylim=ylim, xlim=xlim, lwd=lwd, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, ...) else plot.scanone(x, incl.markers=incl.markers, col=col[1], lodcolumn=1, ylim=ylim, xlim=xlim, lwd=lwd, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, ylab="LOD score", ...) } if(ncol(x) > 3) for(i in 2:(ncol(x)-2)) plot.scanone(x, col=col[i], lodcolumn=i, add=TRUE, ...) if(is.character(legend) || legend) { if(is.character(legend)) legend(legend, legend=colnames(x)[-(1:2)], col=col, lwd=lwd) else legend("topright", legend=colnames(x)[-(1:2)], col=col, lwd=lwd) } invisible() } inferredpartitions <- function(output, chr, lodthreshold, probthreshold=0.9) { if(!inherits(output, "scanPhyloQTL")) stop("Argument 'output' must be of class \"scanPhyloQTL\", as output by scanPhyloQTL.") if(missing(chr)) { chr <- output[1,1] warning("Missing chromosome; using ", chr) } else if(!any(output[,1]==chr)) stop("Chromosome \"", chr, "\" not found.") if(missing(lodthreshold)) { warning("No lodthreshold given; using lodthreshold=0.") lodthreshold=0 } if(probthreshold >= 1 || probthreshold <= 0) { stop("probthreshold should be in (0,1)") } output <- output[output[,1]==chr,] output[,1] <- as.factor(as.character(output[,1])) output <- summary(output, format="postprob") if(output$maxlod < lodthreshold) return("null") prob <- sort(unlist(output[,3:(ncol(output)-2)]), decreasing=TRUE) cs <- cumsum(as.numeric(prob)) if(!any(cs >= probthreshold)) { warning("No values >= probthreshold") return(NULL) } wh <- min(which(cs >= probthreshold)) names(prob)[seq_len(wh)] } # end of phyloqtl_scan.R qtl/R/map_construction.R0000644000176200001440000002367313576241200015000 0ustar liggesusers###################################################################### # # map_construction.R # # copyright (c) 2008-2019, Karl W Broman # last modified Dec, 2019 # first written Oct, 2008 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: formLinkageGroups, orderMarkers, orderMarkers.sub # ###################################################################### ###################################################################### # formLinkageGroups # # Use the estimated recombination fractions between pairs of markers # (and LOD scores for a test of rf = 1/2) to partition the markers # into a set of linkage groups. # # Two markers are placed in the same linkage group if rf <= max.rf # and LOD >= min.lod. The transitive property (if A is linked to B # and B is linked to C then A is linked to C) is used to close the # groups. # # If reorgMarkers=FALSE, the output is a data frame with two columns: # the initial chromosome assignments and the linkage group assigments # determined from the pairwise recombination fractions. # # If reorgMarkers=TRUE, the output is an experimental cross object, # with the data reorganized according to the inferred linkage groups. # # The linkage groups are sorted by the number of markers they contain # (from largest to smallest). # # If verbose=TRUE, tracing information is printed. ###################################################################### formLinkageGroups <- function(cross, max.rf=0.25, min.lod=3, reorgMarkers=FALSE, verbose=FALSE) { if(!("rf" %in% names(cross))) { warning("Running est.rf.") cross <- est.rf(cross) } n.mar <- nmar(cross) tot.mar <- totmar(cross) rf <- cross$rf diagrf <- diag(rf) if(ncol(rf) != tot.mar) stop("dimension of recombination fractions inconsistent with no. markers in cross.") onlylod <- attr(cross$rf, "onlylod") if(!is.null(onlylod) && onlylod) { # results of markerlrt() if(!missing(max.rf)) warning("max.rf ignored, as markerlrt() was used.") max.rf <- Inf } marnam <- colnames(rf) chrstart <- rep(names(cross$geno), n.mar) lod <- rf lod[lower.tri(rf)] <- t(rf)[lower.tri(rf)] rf[upper.tri(rf)] <- t(rf)[upper.tri(rf)] diag(rf) <- 1 diag(lod) <- 0 ingrp <- 1:tot.mar for(i in 1:tot.mar) { if(verbose) { if(tot.mar > 100) if(i==round(i,-2)) cat(i,"of", tot.mar, "\n") else if(i==round(i,-1)) cat(i,"of", tot.mar, "\n") } wh <- (rf[,i]<=max.rf & lod[,i] > min.lod) if(any(wh) && length(unique(ingrp[c(i, which(wh))]))>1) { oldgrp <- ingrp[wh] ingrp[wh] <- ingrp[i] u <- unique(oldgrp[oldgrp != ingrp[i]]) ingrp[!is.na(match(ingrp, u))] <- ingrp[i] } } tab <- sort(table(ingrp), decreasing=TRUE) u <- names(tab) revgrp <- ingrp for(i in seq(along=u)) revgrp[ingrp==u[i]] <- i if(reorgMarkers) { cross <- clean(cross) chr_type <- rep(sapply(cross$geno, chrtype), n.mar) crosstype <- crosstype(cross) g <- pull.geno(cross) cross$geno <- vector("list", max(revgrp)) names(cross$geno) <- 1:max(revgrp) for(i in 1:max(revgrp)) { cross$geno[[i]]$data <- g[,revgrp==i,drop=FALSE] cross$geno[[i]]$map <- seq(0, by=10, length=tab[i]) if(crosstype=="4way") { cross$geno[[i]]$map <- rbind(cross$geno[[i]]$map, cross$geno[[i]]$map) colnames(cross$geno[[i]]$map) <- colnames(cross$geno[[i]]$data) } else names(cross$geno[[i]]$map) <- colnames(cross$geno[[i]]$data) thechrtype <- unique(chr_type[revgrp==i]) if(length(thechrtype) > 1) warning("Problem with linkage group ", i, ": A or X?\n", paste(thechrtype, collapse=" ")) else class(cross$geno[[i]]) <- thechrtype } mname <- markernames(cross) m <- match(mname, marnam) rf <- rf[m,m] lod <- lod[m,m] rf[upper.tri(rf)] <- lod[upper.tri(lod)] diag(rf) <- diagrf[m] cross$rf <- rf return(cross) } else { result <- data.frame(origchr=factor(chrstart, levels=names(cross$geno)), LG=factor(revgrp, levels=1:max(revgrp)), stringsAsFactors=TRUE) rownames(result) <- marnam return(result) } } ###################################################################### # orderMarkers # # For each of the selected chromosomes, construct a new genetic map # from scratch. Marker order is determined in by an expedient and not # necessarily good algorithm, with orders compared by the number of # obligate crossovers. ###################################################################### orderMarkers <- function(cross, chr, window=7, use.ripple=TRUE, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), maxit=4000, tol=1e-4, sex.sp=TRUE, verbose=FALSE) { map.function <- match.arg(map.function) if(!missing(chr)) chr <- matchchr(chr, names(cross$geno)) else chr <- names(cross$geno) n.mar <- nmar(cross) if(verbose > 1) verbose.sub <- TRUE else verbose.sub <- FALSE for(i in chr) { if(verbose && length(chr) > 1) cat(" - Chr", i,"\n") if(n.mar[i] > 2) { neworder <- orderMarkers.sub(cross, i, window=window, use.ripple=use.ripple, verbose=verbose.sub) cross <- switch.order(cross, i, neworder, error.prob=error.prob, map.function=map.function, maxit=maxit, tol=tol, sex.sp=sex.sp) } } cross } ###################################################################### # orderMarkers.sub # For the markers on a chromosome, use a greedy algorithm to order # the markers de novo, possibly running ripple() to refine the order. ###################################################################### orderMarkers.sub <- function(cross, chr, window=7, use.ripple=TRUE, verbose=FALSE) { if(missing(chr)) chr <- names(cross$geno)[1] if(length(chr) > 1) { if(length(grep("^-", chr)) > 0) stop("Need to give a single chromosome name.") warning("Need to give a single chromosome name; using just the first") chr <- chr[1] } if(length(matchchr(chr, names(cross$geno)))>1) stop("Chr ", chr, " not found.") cross <- subset(cross, chr=chr) names(cross$geno)[1] <- "1" n.mar <- totmar(cross) if(n.mar < 3) return(1:n.mar) if(use.ripple && n.mar <= window) { # just use ripple rip <- summary(ripple(cross, chr=1, window=window, verbose=FALSE)) nxo <- rip[1:2,ncol(rip)] if(nxo[1] <= nxo[2]) return(1:n.mar) else return(rip[2,1:(ncol(rip)-1)]) } nt <- ntyped(cross, "mar") # start with the most typed markers and move down themar <- order(nt, decreasing=TRUE) marnam <- markernames(cross) if(n.mar > 3) { for(i in 4:n.mar) cross <- movemarker(cross, marnam[themar[i]], 2) } # create matrix of orders to test makeorders <- function(n) { orders <- matrix(ncol=n, nrow=n) for(k in 1:n) { orders[k,n-k+1] <- n; orders[k,-(n-k+1)] <- 1:(n-1) } orders } # simple switch of marker order on chr 1 simpleswitch <- function(cross, neworder) { cross$geno[[1]]$data <- cross$geno[[1]]$data[,neworder] if(is.matrix(cross$geno[[1]]$map)) cross$geno[[1]]$map <- cross$geno[[1]]$map[,neworder] else cross$geno[[1]]$map <- cross$geno[[1]]$map[neworder] cross } # work on marker 3 if(verbose) cat(" --- Adding marker 3 of", n.mar, "\n") orders <- makeorders(3) nxo <- rep(NA, nrow(orders)) nxo[1] <- sum(countXO(cross, 1)) temp <- cross for(kk in 2:nrow(orders)) { temp$geno[[1]]$data <- temp$geno[[1]]$data[,orders[kk,]] nxo[kk] <- sum(countXO(cross, 1)) } wh <- which(nxo==min(nxo)) if(length(wh) > 1) wh <- sample(wh, 1) if(wh > 1) cross <- simpleswitch(cross, orders[wh,]) # rest of the markers if(n.mar > 3) { for(k in 4:n.mar) { if(verbose) cat(" --- Adding marker", k, "of", n.mar, "\n") cross <- movemarker(cross, marnam[themar[k]], 1) orders <- makeorders(k) nxo <- rep(NA, nrow(orders)) nxo[1] <- sum(countXO(cross, 1)) temp <- cross for(kk in 2:nrow(orders)) { temp$geno[[1]]$data <- cross$geno[[1]]$data[,orders[kk,]] nxo[kk] <- sum(countXO(temp, 1)) } wh <- which(nxo==min(nxo)) if(length(wh) > 1) wh <- sample(wh, 1) if(wh > 1) cross <- simpleswitch(cross, orders[wh,]) } } if(use.ripple) { dif <- -8 while(dif < 0) { rip <- summary(ripple(cross, chr=1, window=window, verbose=FALSE)) dif <- diff(rip[1:2, ncol(rip)]) if(dif < 0) cross <- simpleswitch(cross, rip[2,1:(ncol(rip)-1)]) } } match(colnames(cross$geno[[1]]$data), marnam) } # end of map_construction.R qtl/R/pickMarkerSubset.R0000644000176200001440000000354312770016226014664 0ustar liggesusers##################################################################### # # pickMarkerSubset.R # # copyright (c) 2011-2013, Karl W Broman # last modified Apr, 2013 # first written Nov, 2011 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # ###################################################################### pickMarkerSubset <- function(locations, min.distance, weights) { n.loc <- length(locations) if(n.loc==1) return(names(locations)) # just one marker if(missing(weights)) weights <- rep(1, n.loc) else { if(n.loc != length(weights)) stop("length(locations) != length(weights) [", n.loc, " != ", length(weights), "]") } if(is.null(names(locations))) names(locations) <- 1:n.loc if(any(diff(locations) < 0)) { o <- order(locations) weights <- weights[o] locations <- locations[o] warning("Markers are not in order; sorting them.") } z <- .C("R_pickMarkerSubset", as.double(locations), as.integer(n.loc), as.double(weights), as.double(min.distance), path=as.integer(rep(0, n.loc)), n.path=as.integer(0), PACKAGE="qtl") path <- rev(z$path[1:z$n.path]+1) # reverse and add 1 return(names(locations)[path]) } # end of pickMarkerSubset.R qtl/R/simulate.R0000644000176200001440000006771413576241200013240 0ustar liggesusers###################################################################### # # simulate.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Apr, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: sim.map, sim.cross, sim.cross.bc, sim.cross.f2, # sim.cross.4way, sim.bcg # ###################################################################### ###################################################################### # # sim.map: simulate a genetic map # ###################################################################### sim.map <- function(len=rep(100,20), n.mar=10, anchor.tel=TRUE, include.x=TRUE, sex.sp=FALSE, eq.spacing=FALSE) { if(length(len)!=length(n.mar) && length(len)!=1 && length(n.mar)!=1) stop("Lengths of vectors len and n.mar do not conform.") # make vectors the same length if(length(len) == 1) len <- rep(len,length(n.mar)) else if(length(n.mar) == 1) n.mar <- rep(n.mar,length(len)) n.chr <- length(n.mar) map <- vector("list",n.chr) names(map) <- as.character(1:n.chr) if(include.x) names(map)[n.chr] <- "X" for(i in 1:n.chr) { if(anchor.tel) { if(n.mar[i] < 2) n.mar[i] <- 2 map[[i]] <- c(0,len[i]) if(n.mar[i] > 2) { if(!eq.spacing) map[[i]] <- sort(c(map[[i]],runif(n.mar[i]-2,0,len[i]))) else # equal spacing map[[i]] <- seq(0,len[i],length=n.mar[i]) } } else { if(!eq.spacing) { map[[i]] <- sort(runif(n.mar[i],0,len[i])) map[[i]] <- map[[i]] - min(map[[i]]) } else { # equal spacing map[[i]] <- seq(0,len[i],length=n.mar[i]+1) map[[i]] <- map[[i]][-1] - map[[i]][2]/2 } } names(map[[i]]) <- paste("D", names(map)[i], "M", 1:n.mar[i], sep="") class(map[[i]]) <- "A" } if(sex.sp) { for(i in 1:n.chr) { if(eq.spacing) tempmap <- map[[i]] else { if(anchor.tel) { if(n.mar[i] < 2) n.mar[i] <- 2 tempmap <- c(0,len[i]) if(n.mar[i] > 2) tempmap <- sort(c(tempmap,runif(n.mar[i]-2,0,len[i]))) } else { tempmap <- sort(runif(n.mar[i],0,len[i])) tempmap <- tempmap - min(tempmap) } } map[[i]] <- rbind(map[[i]],tempmap) dimnames(map[[i]]) <- list(NULL,paste("D", names(map)[i], "M", 1:n.mar[i], sep="")) class(map[[i]]) <- "A" if(include.x && i==n.chr) # if X chromosome, force no recombination in male map[[i]][2,] <- rep(0,ncol(map[[i]])) } } if(include.x) class(map[[n.chr]]) <- "X" class(map) <- "map" map } ###################################################################### # # sim.cross: Simulate an experimental cross # # Note: These functions are a bit of a mess. I was in the "get it to # work without worrying about efficiency" mode while writing it. # Sorry! # ###################################################################### sim.cross <- function(map, model=NULL, n.ind=100, type=c("f2", "bc", "4way", "risib", "riself", "ri4sib", "ri4self", "ri8sib", "ri8self","bcsft"), error.prob=0, missing.prob=0, partial.missing.prob=0, keep.qtlgeno=TRUE, keep.errorind=TRUE, m=0, p=0, map.function=c("haldane","kosambi","c-f","morgan"), founderGeno, random.cross=TRUE, ...) { type <- match.arg(type) map.function <- match.arg(map.function) # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } # 2-way RIL by sibmating or selfing if(type=="risib" || type=="riself") { if(!is.null(model)) warning('"model" argument currently ignored in simulating RILs') if(type=="risib") type <- "sibmating" else type <- "selfing" cross <- sim.ril(map, n.ind, type, "2", m=m, p=p, error.prob=error.prob, missing.prob=missing.prob) cross$cross <- NULL return(cross) } # 4- or 8-way RIL by sibmating or selfing if(type=="ri4sib" || type=="ri4self" || type=="ri8sib" || type=="ri8self") { if(!is.null(model)) warning('"model" argument currently ignored in simulating RILs') if(substr(type, 4, nchar(type))=="self") crosstype <- "selfing" else crosstype <- "sibmating" n.str <- substr(type, 3, 3) cross <- sim.ril(map, n.ind, crosstype, n.str, m=m, p=p, random.cross=random.cross, error.prob=0, missing.prob=missing.prob) rcross <- convertMWril(cross, founderGeno, error.prob=error.prob) for(i in names(cross$geno)) if(!("truegeno" %in% names(rcross$geno[[i]]))) rcross$geno[[i]]$truegeno <- cross$geno[[i]]$data # remove "un" from cross type class(rcross) <- c(sub("un$", "", crosstype(cross)), "cross") fg <- t(founderGeno[[1]]) if(length(founderGeno)>1) for(i in 2:length(founderGeno)) fg <- cbind(fg, t(founderGeno[[i]])) colnames(fg) <- markernames(rcross) rcross$founderGeno <- fg return(rcross) } # sort the model matrix if(!is.null(model) && is.matrix(model)) model <- model[order(model[,1],model[,2]),] if(type=="bc") cross <- sim.cross.bc(map,model,n.ind,error.prob,missing.prob, keep.errorind,m,p,map.function) else if(type=="f2") cross <- sim.cross.f2(map,model,n.ind,error.prob,missing.prob, partial.missing.prob,keep.errorind, m,p,map.function) else if(type=="bcsft") cross <- sim.cross.bcsft(map,model,n.ind,error.prob,missing.prob, partial.missing.prob,keep.errorind, m,p,map.function, ...) else cross <- sim.cross.4way(map,model,n.ind,error.prob,missing.prob, partial.missing.prob,keep.errorind, m,p,map.function) # remove QTL genotypes from data and, if keep.qtlgeno=TRUE, # place them in cross$qtlgeno qtlgeno <- NULL for(i in 1:nchr(cross)) { o <- grep("^QTL[0-9]+", colnames(cross$geno[[i]]$data)) if(length(o) != 0) { qtlgeno <- cbind(qtlgeno, cross$geno[[i]]$data[,o,drop=FALSE]) cross$geno[[i]]$data <- cross$geno[[i]]$data[,-o,drop=FALSE] if(is.matrix(cross$geno[[i]]$map)) cross$geno[[i]]$map <- cross$geno[[i]]$map[,-o,drop=FALSE] else cross$geno[[i]]$map <- cross$geno[[i]]$map[-o] } } if(keep.qtlgeno) cross$qtlgeno <- qtlgeno # store genotype data as integers for(i in 1:nchr(cross)) storage.mode(cross$geno[[i]]$data) <- "integer" if(is.null(names(cross$geno))) names(cross$geno) <- 1:length(cross$geno) cross } ###################################################################### # # sim.cross.bc # ###################################################################### sim.cross.bc <- function(map,model,n.ind,error.prob,missing.prob, keep.errorind,m,p,map.function) { if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h if(any(sapply(map,is.matrix))) stop("Map must not be sex-specific.") chr.type <- sapply(map, chrtype) n.chr <- length(map) if(is.null(model)) n.qtl <- 0 else { if(!((!is.matrix(model) && length(model) == 3) || (is.matrix(model) && ncol(model) == 3))) stop("Model must be a matrix with 3 columns (chr, pos and effect).") if(!is.matrix(model)) model <- rbind(model) n.qtl <- nrow(model) if(any(model[,1] < 0 | model[,1] > n.chr)) stop("Chromosome indicators in model matrix out of range.") model[,2] <- model[,2]+1e-14 # so QTL not on top of marker } # if any QTLs, place qtls on map if(n.qtl > 0) { for(i in 1:n.qtl) { temp <- map[[model[i,1]]] if(model[i,2] < min(temp)) { temp <- c(model[i,2],temp) names(temp)[1] <- paste("QTL",i,sep="") } else if(model[i,2] > max(temp)) { temp <- c(temp,model[i,2]) names(temp)[length(temp)] <- paste("QTL",i,sep="") } else { j <- max((seq(along=temp))[temp < model[i,2]]) temp <- c(temp[1:j],model[i,2],temp[(j+1):length(temp)]) names(temp)[j+1] <- paste("QTL",i,sep="") } map[[model[i,1]]] <- temp } } geno <- vector("list", n.chr) names(geno) <- names(map) n.mar <- sapply(map,length) mar.names <- lapply(map,names) for(i in 1:n.chr) { # simulate genotype data thedata <- sim.bcg(n.ind, map[[i]], m, p, map.function) dimnames(thedata) <- list(NULL,mar.names[[i]]) geno[[i]] <- list(data = thedata, map = map[[i]]) class(geno[[i]]) <- chr.type[i] class(geno[[i]]$map) <- NULL } # end loop over chromosomes # simulate phenotypes pheno <- rnorm(n.ind,0,1) if(n.qtl > 0) { # find QTL positions in genotype data QTL.chr <- QTL.loc <- NULL for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) { QTL.chr <- c(QTL.chr,rep(i,length(o))) QTL.loc <- c(QTL.loc,o) } } # incorporate QTL effects for(i in 1:n.qtl) { QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]] pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,3] } } # end simulate phenotype n.mar <- sapply(geno, function(a) length(a$map)) # add errors if(error.prob > 0) { for(i in 1:n.chr) { a <- sample(0:1,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob)) geno[[i]]$data[a == 1] <- 3 - geno[[i]]$data[a == 1] if(keep.errorind) { errors <- matrix(0,n.ind,n.mar[i]) errors[a==1] <- 1 colnames(errors) <- colnames(geno[[i]]$data) geno[[i]]$errors <- errors } } } # add missing if(missing.prob > 0) { for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) x <- geno[[i]]$data[,o] geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,replace=TRUE, prob=c(missing.prob,1-missing.prob))] <- NA if(length(o)>0) geno[[i]]$data[,o] <- x } } pheno <- data.frame(phenotype=pheno, stringsAsFactors=TRUE) cross <- list(geno=geno,pheno=pheno) class(cross) <- c("bc","cross") cross } ###################################################################### # # sim.cross.f2 # ###################################################################### sim.cross.f2 <- function(map,model,n.ind,error.prob,missing.prob,partial.missing.prob, keep.errorind,m,p,map.function) { if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h if(any(sapply(map,is.matrix))) stop("Map must not be sex-specific.") # chromosome types chr.type <- sapply(map, chrtype) n.chr <- length(map) if(is.null(model)) n.qtl <- 0 else { if(!((!is.matrix(model) && length(model) == 4) || (is.matrix(model) && ncol(model) == 4))) { stop("Model must be a matrix with 4 columns (chr, pos and effects).") } if(!is.matrix(model)) model <- rbind(model) n.qtl <- nrow(model) if(any(model[,1] < 0 | model[,1] > n.chr)) stop("Chromosome indicators in model matrix out of range.") model[,2] <- model[,2]+1e-14 # so QTL not on top of marker } # if any QTLs, place qtls on map if(n.qtl > 0) { for(i in 1:n.qtl) { temp <- map[[model[i,1]]] if(model[i,2] < min(temp)) { temp <- c(model[i,2],temp) names(temp)[1] <- paste("QTL",i,sep="") } else if(model[i,2] > max(temp)) { temp <- c(temp,model[i,2]) names(temp)[length(temp)] <- paste("QTL",i,sep="") } else { j <- max((seq(along=temp))[temp < model[i,2]]) temp <- c(temp[1:j],model[i,2],temp[(j+1):length(temp)]) names(temp)[j+1] <- paste("QTL",i,sep="") } map[[model[i,1]]] <- temp } } geno <- vector("list", n.chr) names(geno) <- names(map) n.mar <- sapply(map,length) mar.names <- lapply(map,names) for(i in 1:n.chr) { # simulate genotype data thedata <- sim.bcg(n.ind, map[[i]], m, p, map.function) dimnames(thedata) <- list(NULL,mar.names[[i]]) if(chr.type[i] != "X") thedata <- thedata + sim.bcg(n.ind, map[[i]], m, p, map.function) - 1 geno[[i]] <- list(data = thedata, map = map[[i]]) class(geno[[i]]) <- chr.type[i] class(geno[[i]]$map) <- NULL } # end loop over chromosomes # simulate phenotypes pheno <- rnorm(n.ind,0,1) if(n.qtl > 0) { # find QTL positions in genotype data QTL.chr <- QTL.loc <- NULL for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) { QTL.chr <- c(QTL.chr,rep(i,length(o))) QTL.loc <- c(QTL.loc,o) } } # incorporate QTL effects for(i in 1:n.qtl) { QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]] pheno[QTL.geno==1] <- pheno[QTL.geno==1] - model[i,3] pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,4] pheno[QTL.geno==3] <- pheno[QTL.geno==3] + model[i,3] } } # end simulate phenotype n.mar <- sapply(geno, function(a) length(a$map)) # add errors if(error.prob > 0) { for(i in 1:n.chr) { if(chr.type[i]=="X") { a <- sample(0:1,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob)) geno[[i]]$data[a == 1] <- 3 - geno[[i]]$data[a == 1] } else { a <- sample(0:2,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob/2,error.prob/2)) if(any(a>0 & geno[[i]]$data==1)) geno[[i]]$data[a>0 & geno[[i]]$data==1] <- (geno[[i]]$data+a)[a>0 & geno[[i]]$data==1] if(any(a>0 & geno[[i]]$data==2)) { geno[[i]]$data[a>0 & geno[[i]]$data==2] <- (geno[[i]]$data+a)[a>0 & geno[[i]]$data==2] geno[[i]]$data[geno[[i]]$data>3] <- 1 } if(any(a>0 & geno[[i]]$data==3)) geno[[i]]$data[a>0 & geno[[i]]$data==3] <- (geno[[i]]$data-a)[a>0 & geno[[i]]$data==3] } if(keep.errorind) { errors <- matrix(0,n.ind,n.mar[i]) errors[a>0] <- 1 colnames(errors) <- colnames(geno[[i]]$data) geno[[i]]$errors <- errors } } # end loop over chromosomes } # end simulate genotyping errors # add partial missing if(partial.missing.prob > 0) { for(i in 1:n.chr) { if(chr.type[i] != "X") { o <- sample(c(TRUE,FALSE),n.mar[i],replace=TRUE, prob=c(partial.missing.prob,1-partial.missing.prob)) if(any(o)) { o2 <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o2)>0) x <- geno[[i]]$data[,o2] m <- (1:n.mar[i])[o] for(j in m) { if(runif(1) < 0.5) geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==2,j] <- 4 else geno[[i]]$data[geno[[i]]$data[,j]==3 | geno[[i]]$data[,j]==2,j] <- 5 } if(length(o2)>0) geno[[i]]$data[,o2] <- x } } } # end loop over chromosomes } # end simulate partially missing data # add missing if(missing.prob > 0) { for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) x <- geno[[i]]$data[,o] geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,replace=TRUE, prob=c(missing.prob,1-missing.prob))] <- NA if(length(o)>0) geno[[i]]$data[,o] <- x } } pheno <- data.frame(phenotype=pheno, stringsAsFactors=TRUE) cross <- list(geno=geno,pheno=pheno) class(cross) <- c("f2","cross") cross } ###################################################################### # # sim.cross.4way # ###################################################################### sim.cross.4way <- function(map,model,n.ind,error.prob,missing.prob,partial.missing.prob, keep.errorind,m,p,map.function) { if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h if(!all(sapply(map,is.matrix))) stop("Map must be sex-specific.") n.chr <- length(map) if(is.null(model)) n.qtl <- 0 else { if(!((!is.matrix(model) && length(model) == 5) || (is.matrix(model) && ncol(model) == 5))) { stop("Model must be a matrix with 5 columns (chr, pos and effects).") } if(!is.matrix(model)) model <- rbind(model) n.qtl <- nrow(model) if(any(model[,1] < 0 | model[,1] > n.chr)) stop("Chromosome indicators in model matrix out of range.") model[,2] <- model[,2]+1e-14 # so QTL not on top of marker } chr.type <- sapply(map, chrtype) # if any QTLs, place qtls on map if(n.qtl > 0) { for(i in 1:n.qtl) { temp <- map[[model[i,1]]] temp1 <- temp[1,] temp2 <- temp[2,] qtlloc <- model[i,2] if(qtlloc < min(temp1)) { temp1 <- c(qtlloc,temp1) temp2 <- min(temp2) - (min(temp1)-qtlloc)/diff(range(temp1))*diff(range(temp2)) temp1 <- temp1-min(temp1) temp2 <- temp2-min(temp2) n <- c(paste("QTL",i,sep=""),colnames(temp)) } else if(qtlloc > max(temp1)) { temp1 <- c(temp1,qtlloc) temp2 <- (qtlloc-max(temp1))/diff(range(temp1))*diff(range(temp2))+max(temp2) n <- c(colnames(temp),paste("QTL",i,sep="")) } else { temp1 <- c(temp1,qtlloc) o <- order(temp1) wh <- (seq(along=temp1))[order(temp1)==length(temp1)] temp2 <- c(temp2[1:(wh-1)],NA,temp2[-(1:(wh-1))]) temp2[wh] <- temp2[wh-1] + (temp1[wh]-temp1[wh-1])/(temp1[wh+1]-temp1[wh-1]) * (temp2[wh+1]-temp2[wh-1]) temp1 <- sort(temp1) n <- c(colnames(temp),paste("QTL",i,sep=""))[o] } map[[model[i,1]]] <- rbind(temp1,temp2) dimnames(map[[model[i,1]]]) <- list(NULL, n) } } geno <- vector("list", n.chr) names(geno) <- names(map) n.mar <- sapply(map,ncol) mar.names <- lapply(map,function(a) colnames(a)) for(i in 1:n.chr) { # simulate sex sex <- NULL if(chr.type[i]=="X") sex <- rep(0,n.ind) # simulate genotype data thedata <- sim.bcg(n.ind, map[[i]], m, p, map.function) dimnames(thedata) <- list(NULL,mar.names[[i]]) if(chr.type[i] != "X") thedata <- thedata + 2*sim.bcg(n.ind, map[[i]][2:1,], m, p, map.function) - 2 dimnames(thedata) <- list(NULL,mar.names[[i]]) geno[[i]] <- list(data = thedata, map = map[[i]]) class(geno[[i]]) <- chr.type[i] class(geno[[i]]$map) <- NULL } # end loop over chromosomes # simulate phenotypes pheno <- rnorm(n.ind,0,1) if(n.qtl > 0) { # find QTL positions QTL.chr <- QTL.loc <- NULL for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) { QTL.chr <- c(QTL.chr,rep(i,length(o))) QTL.loc <- c(QTL.loc,o) } } # incorporate QTL effects for(i in 1:n.qtl) { QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]] pheno[QTL.geno==1] <- pheno[QTL.geno==1] + model[i,3] pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,4] pheno[QTL.geno==3] <- pheno[QTL.geno==3] + model[i,5] } } # end simulate phenotype n.mar <- sapply(geno, function(a) ncol(a$map)) # add errors if(error.prob > 0) { for(i in 1:n.chr) { if(chr.type[i] != "X") { # 4-way cross; autosomal a <- sample(0:3,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,rep(error.prob/3,3))) if(any(a>0 & geno[[i]]$data==1)) geno[[i]]$data[a>0 & geno[[i]]$data==1] <- geno[[i]]$data[a>0 & geno[[i]]$data==1] + a[a>0 & geno[[i]]$data==1] if(any(a>0 & geno[[i]]$data==2)) geno[[i]]$data[a>0 & geno[[i]]$data==2] <- geno[[i]]$data[a>0 & geno[[i]]$data==2] + c(-1,1,2)[a[a>0 & geno[[i]]$data==2]] if(any(a>0 & geno[[i]]$data==3)) geno[[i]]$data[a>0 & geno[[i]]$data==3] <- geno[[i]]$data[a>0 & geno[[i]]$data==3] + c(-2,-1,1)[a[a>0 & geno[[i]]$data==3]] if(any(a>0 & geno[[i]]$data==4)) geno[[i]]$data[a>0 & geno[[i]]$data==4] <- geno[[i]]$data[a>0 & geno[[i]]$data==4] - a[a>0 & geno[[i]]$data==4] } else { a <- sample(0:1,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob)) if(any(a>0 & geno[[i]]$data==1)) geno[[i]]$data[a>0 & geno[[i]]$data==1] <- geno[[i]]$data[a>0 & geno[[i]]$data==1] + 1 if(any(a>0 & geno[[i]]$data==2)) geno[[i]]$data[a>0 & geno[[i]]$data==2] <- geno[[i]]$data[a>0 & geno[[i]]$data==2] - 1 if(any(a>0 & geno[[i]]$data==3)) geno[[i]]$data[a>0 & geno[[i]]$data==3] <- geno[[i]]$data[a>0 & geno[[i]]$data==3] + 1 if(any(a>0 & geno[[i]]$data==4)) geno[[i]]$data[a>0 & geno[[i]]$data==4] <- geno[[i]]$data[a>0 & geno[[i]]$data==4] - 1 } if(keep.errorind) { errors <- matrix(0,n.ind,n.mar[i]) errors[a>0] <- 1 colnames(errors) <- colnames(geno[[i]]$data) geno[[i]]$errors <- errors } } # end loop over chromosomes } # end simulate genotyping errors # add partial missing if(partial.missing.prob > 0) { for(i in 1:n.chr) { if(chr.type[i] != "X") { o <- sample(c(TRUE,FALSE),n.mar[i],replace=TRUE, prob=c(partial.missing.prob,1-partial.missing.prob)) if(any(o)) { o2 <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o2)>0) x <- geno[[i]]$data[,o2] m <- (1:n.mar[i])[o] for(j in m) { a <- sample(1:4,1) if(a==1) { # AB:AA marker geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==3,j] <- 5 geno[[i]]$data[geno[[i]]$data[,j]==2 | geno[[i]]$data[,j]==4,j] <- 6 } else if(a==2) { # AA:AB marker geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==2,j] <- 7 geno[[i]]$data[geno[[i]]$data[,j]==3 | geno[[i]]$data[,j]==4,j] <- 8 } else if(a==3) # AB:AB marker geno[[i]]$data[geno[[i]]$data[,j]==2 | geno[[i]]$data[,j]==3,j] <- 10 else # AB:BA marker geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==4,j] <- 9 } if(length(o2) > 0) geno[[i]]$data[,o2] <- x } } } # end loop over chromosomes } # end simulate partially missing data # add missing if(missing.prob > 0) { for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) x <- geno[[i]]$data[,o] geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,replace=TRUE, prob=c(missing.prob,1-missing.prob))] <- NA if(length(o)>0) geno[[i]]$data[,o] <- x } } if(!is.null(sex)) { pheno <- cbind(pheno,sex) dimnames(pheno) <- list(NULL, c("phenotype", "sex")) } else { pheno <- cbind(pheno) dimnames(pheno) <- list(NULL, "phenotype") } pheno <- as.data.frame(pheno, stringsAsFactors=TRUE) cross <- list(geno=geno,pheno=pheno) class(cross) <- c("4way","cross") cross } ###################################################################### # sim.bcg # # simulate backcross genotype data for a single chromosome; # output is a matrix of 1's and 0's ###################################################################### sim.bcg <- function(n.ind, map, m, p, map.function=c("haldane","kosambi","c-f","morgan")) { map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h if(m < 0 || p < 0 || p > 1) stop("Must have m >= 0 and 0 <= p <= 1") if(is.matrix(map)) map <- map[1,] map <- map-map[1] n.mar <- length(map) if(m==0 || p==1) { # no interference g <- .C("R_sim_bc_ni", as.integer(n.mar), as.integer(n.ind), as.double(mf(diff(map))), g=as.integer(rep(0, n.mar*n.ind)), PACKAGE="qtl")$g } else { g <- .C("R_sim_bc", as.integer(n.mar), as.integer(n.ind), as.double(map), as.integer(m), as.double(p), g=as.integer(rep(0, n.mar*n.ind)), PACKAGE="qtl")$g } matrix(g, ncol=n.mar) } # end of simulate.R qtl/R/phyloqtl_sim.R0000644000176200001440000001167712770016226014141 0ustar liggesusers###################################################################### # phyloqtl_sim.R # # copyright (c) 2009, Karl W Broman # last modified May, 2009 # first written May, 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Simulating multiple crosses with multiple taxa with diallelic QTL # located on a phylogenetic tree # # Part of the R/qtl package # Contains: simPhyloQTL # ###################################################################### ###################################################################### # simPhyloQTL # # function for simulating data on multiple intercrosses, for a single # diallelic QTL # # n.taxa = # partition = character string of the form "AB|CD" or "A|BCD" # if missing, simulate under the null # crosses = set of two-character strings indicating the crosses to do # (of the form "AB", AC", etc.) # these will be sorted and then only unique ones used # if missing, we'll do all crosses ###################################################################### simPhyloQTL <- function(n.taxa=3, partition, crosses, map, n.ind=100, model, error.prob=0, missing.prob=0, partial.missing.prob=0, keep.qtlgeno=FALSE, keep.errorind=TRUE, m=0, p=0, map.function=c("haldane", "kosambi", "c-f", "morgan")) { if(n.taxa < 3) stop("Should have 3 or more taxa.") if(n.taxa > 26) stop("We can only deal with 3-26 taxa.") map.function <- match.arg(map.function) if(!missing(model)) { if((is.matrix(model) && ncol(model)!=4) || (!is.matrix(model) && length(model) != 4)) stop("model should have QTL chr, pos, and additive and dominance effects.") if(is.matrix(model)) n.qtl <- nrow(model) else { n.qtl <- 1 model <- rbind(model) } } else { model <- NULL n.qtl <- 0 } taxa <- LETTERS[1:n.taxa] if(missing(partition) || is.null(partition) || partition=="") { partition <- NULL if(!is.null(model)) warning("partition is NULL, so model is ignored and data are simulated with no QTL.") } else { if(is.null(model)) { warning("model is NULL, so partition is ignored and data are simulated with no QTL.") partition <- NULL } else { if(length(partition)==1 && n.qtl > 1) partition <- rep(partition, n.qtl) if(length(partition)>1 && n.qtl == 1) stop("Model indicates just one QTL, so partition should have length 1.") if(length(partition)>1 && n.qtl != length(partition)) stop("No. QTL in model should match the length of partition.") for(i in unique(partition)) checkPhyloPartition(i, taxa) } } if(missing(crosses) || is.null(crosses)) { # use all possible crosses crosses <- NULL for(i in 1:(n.taxa-1)) for(j in (i+1):n.taxa) crosses <- c(crosses, paste(taxa[i], taxa[j], sep="")) } else # check that the crosses are correct and sufficient crosses <- checkPhyloCrosses(crosses, taxa) if(length(n.ind) > 1 && length(n.ind) != length(crosses)) stop("n.ind should have length 1 or have length equal to the number of crosses.") if(length(n.ind)==1) n.ind <- rep(n.ind, length(crosses)) if(n.qtl > 0) { # for each partition, determine which crosses have the QTL crossmat <- qtlByPartition(crosses, partition) models <- vector("list", length(crosses)) for(i in seq(along=crosses)) { models[[i]] <- model models[[i]][crossmat[i,] <0,3] <- -models[[i]][crossmat[i,] <0,3] models[[i]] <- models[[i]][crossmat[i,]!=0,,drop=FALSE] } } else models <- vector("list", length(crosses)) thedata <- vector("list", length(crosses)) names(thedata) <- crosses if(missing(map)) stop("Must provide a genetic map") for(i in seq(along=crosses)) thedata[[i]] <- sim.cross(map, models[[i]], n.ind=n.ind[i], type="f2", error.prob=error.prob, missing.prob=missing.prob, partial.missing.prob=partial.missing.prob, keep.qtlgeno = keep.qtlgeno, keep.errorind=keep.errorind, m=m, p=p, map.function=map.function) thedata } # end of phyloqtl_sim.R qtl/R/ril48_reorg.R0000644000176200001440000002236713576241200013550 0ustar liggesusers##################################################################### # # ril48_reorg.R # # copyright (c) 2009-2019, Karl W Broman # last modified Dec, 2019 # first written Apr, 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: reorgRIgenoprob, reorgRIdraws, reorgRIimp, reorgRIpairprob # ###################################################################### ###################################################################### # reorgRIgenoprob # # For 4- and 8-way RIL, reorganize the QTL genotype probabilities # using the information on the order of the founder strains in each # cross. ###################################################################### reorgRIgenoprob <- function(cross) { crosses <- cross$cross flag <- 0 for(i in 1:ncol(crosses)) { if(any(crosses[,i] != i)) { flag <- 1 break } } if(!flag) return(cross) # no need to reorder crosstype <- crosstype(cross) if(crosstype != "ri4sib" && crosstype != "ri4self" && crosstype != "ri8sib" && crosstype != "ri8self" && crosstype != "bgmagic16") stop("reorgRIgenoprob not appropriate for cross type ", crosstype) if(crosstype=="bgmagic16") n.str <- 16 else n.str <- as.numeric(substr(crosstype, 3, 3)) n.ind <- nind(cross) for(i in names(cross$geno)) { # loop over chromosomes chr_type <- chrtype(cross$geno[[i]]) if(chr_type == "X") warning("reorgRIgenoprob not working properly for the X chromosome.") if(!("prob" %in% names(cross$geno[[i]]))) { warning("No QTL genotype probabilities within cross.") return(cross) } prob <- cross$geno[[i]]$prob att <- attributes(prob) n.mar <- dim(prob)[2] if(dim(prob)[1] != n.ind) stop("Mismatch between no. individuals in cross and in genoprobs.") if(dim(crosses)[2] != n.str) stop("Invalid no. of founder strains specified") if(dim(prob)[3] != n.str) { warning("Odd no. columns in genoprobs for chromosome ", i) next } prob <- .C("R_reorgRIgenoprob", as.integer(n.ind), as.integer(n.mar), as.integer(n.str), prob=as.double(prob), as.integer(crosses), PACKAGE="qtl")$prob prob <- array(prob, dim=c(n.ind, n.mar, n.str)) for(j in names(att)) attr(prob, j) <- att[[j]] cross$geno[[i]]$prob <- prob } cross } ###################################################################### # reorgRIdraws # # For 4- and 8-way RIL, reorganize the imputed QTL genotypes # using the information on the order of the founder strains in each # cross. ###################################################################### reorgRIdraws <- function(cross) { crosses <- cross$cross flag <- 0 for(i in 1:ncol(crosses)) { if(any(crosses[,i] != i)) { flag <- 1 break } } if(!flag) return(cross) # no need to reorder crosstype <- crosstype(cross) if(crosstype != "ri4sib" && crosstype != "ri4self" && crosstype != "ri8sib" && crosstype != "ri8self" && crosstype != "bgmagic16") stop("reorgRIdraws not appropriate for cross type ", crosstype) if(crosstype=="bgmagic16") n.str <- 16 else n.str <- as.numeric(substr(crosstype, 3, 3)) n.ind <- nind(cross) for(i in names(cross$geno)) { # loop over chromosomes chr_type <- chrtype(cross$geno[[i]]) if(chr_type == "X") warning("reorgRIdraws not working properly for the X chromosome.") if(!("draws" %in% names(cross$geno[[i]]))) { warning("No imputations within cross.") return(cross) } draws <- cross$geno[[i]]$draws att <- attributes(draws) n.mar <- dim(draws)[2] n.imp <- dim(draws)[3] if(dim(draws)[1] != n.ind) stop("Mismatch between no. individuals in cross and in draws.") if(dim(crosses)[2] != n.str) stop("Invalid no. of founder strains specified") draws <- .C("R_reorgRIdraws", as.integer(n.ind), as.integer(n.mar), as.integer(n.str), as.integer(n.imp), draws=as.integer(draws), as.integer(crosses), PACKAGE="qtl")$draws draws <- array(draws, dim=c(n.ind, n.mar, n.imp)) for(j in names(att)) attr(draws, j) <- att[[j]] cross$geno[[i]]$draws <- draws } cross } ###################################################################### # reorgRIargmax # # For 4- and 8-way RIL, reorganize the results of argmax.geno # using the information on the order of the founder strains in each # cross. ###################################################################### reorgRIargmax <- function(cross) { crosses <- cross$cross flag <- 0 for(i in 1:ncol(crosses)) { if(any(crosses[,i] != i)) { flag <- 1 break } } if(!flag) return(cross) # no need to reorder crosstype <- crosstype(cross) if(crosstype != "ri4sib" && crosstype != "ri4self" && crosstype != "ri8sib" && crosstype != "ri8self" && crosstype != "bgmagic16") stop("reorgRIargmax not appropriate for cross type ", crosstype) if(crosstype=="bgmagic16") n.str <- 16 else n.str <- as.numeric(substr(crosstype, 3, 3)) n.ind <- nind(cross) for(i in names(cross$geno)) { # loop over chromosomes chr_type <- chrtype(cross$geno[[i]]) if(chr_type == "X") warning("reorgRIargmax not working properly for the X chromosome.") if(!("argmax" %in% names(cross$geno[[i]]))) { warning("No argmax.geno results within cross.") return(cross) } argmax <- cross$geno[[i]]$argmax att <- attributes(argmax) n.mar <- dim(argmax)[2] if(dim(argmax)[1] != n.ind) stop("Mismatch between no. individuals in cross and in argmax.") if(dim(crosses)[2] != n.str) stop("Invalid no. of founder strains specified") argmax <- .C("R_reorgRIdraws", as.integer(n.ind), as.integer(n.mar), as.integer(n.str), as.integer(1), argmax=as.integer(argmax), as.integer(crosses), PACKAGE="qtl")$argmax argmax <- matrix(argmax, nrow=n.ind, ncol=n.mar) for(j in names(att)) attr(argmax, j) <- att[[j]] cross$geno[[i]]$argmax <- argmax } cross } ###################################################################### # reorgRIpairprob # # For 4- and 8-way RIL, reorganize the results of calc.pairprob # using the information on the order of the founder strains in each # cross. ###################################################################### reorgRIpairprob <- function(cross, pairprob) { crosses <- cross$cross flag <- 0 for(i in 1:ncol(crosses)) { if(any(crosses[,i] != i)) { flag <- 1 break } } if(!flag) return(pairprob) # no need to reorder crosstype <- crosstype(cross) if(crosstype != "ri4sib" && crosstype != "ri4self" && crosstype != "ri8sib" && crosstype != "ri8self" && crosstype != "bgmagic16") stop("reorgRIargmax not appropriate for cross type ", crosstype) if(crosstype=="bgmagic16") n.str <- 16 else n.str <- as.numeric(substr(crosstype, 3, 3)) n.ind <- nind(cross) thedim <- dim(pairprob) chr_type <- chrtype(cross$geno[[1]]) if(chr_type == "X") warning("reorgRIpairprob not working properly for the X chromosome.") att <- attributes(pairprob) if(thedim[1] != n.ind) stop("Mismatch between no. individuals in cross and in pairprob.") if(thedim[3] != n.str || thedim[4] != n.str) stop("Mismatch between no. founder strains in cross and in pairprob.") if(dim(crosses)[2] != n.str) stop("Invalid no. of founder strains specified") n.mar <- nmar(cross)[1] if(n.mar*(n.mar-1)/2 != thedim[2]) stop("Mismatch between no. markers in cross and in pairprob.") pairprob <- .C("R_reorgRIpairprob", as.integer(n.ind), as.integer(n.mar), # no. prob as.integer(n.str), pairprob=as.double(pairprob), as.integer(crosses), PACKAGE="qtl")$pairprob pairprob <- array(pairprob, dim=thedim) for(j in names(att)) attr(pairprob, j) <- att[[j]] pairprob } # end of ril48_reorg.R qtl/R/summary.scantwo.old.R0000644000176200001440000002746213576241200015340 0ustar liggesusers###################################################################### # # summaryScantwoOld.R # # copyright (c) 2001-2019, Karl W Broman, Hao Wu, and Brian Yandell # last modified Dec, 2019 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Hao Wu (The Jackson Lab) wrote the initial code for summary.scantwo # function. Brian Yandell made further modifications/enhancements to # summary.scantwo, but Karl re-wrote most of it later. # # Part of the R/qtl package # Contains: summaryScantwoOld, print.summary.scantwo.old # ###################################################################### summaryScantwoOld <- function (object, thresholds = c(0, 0, 0), lodcolumn=1, type = c("joint","interaction"), ...) { warning("This function is provided solely for continuity of the software;\n", "it is not recommended.\n") if(!inherits(object, "scantwo")) stop("Input should have class \"scantwo\".") type <- match.arg(type) if(length(dim(object$lod)) > 2) { # results from multiple phenotypes if(length(lodcolumn) > 1) { warning("Argument lodcolumn should be of length 1.") lodcolumn <- lodcolumn[1] } if(lodcolumn < 0 || lodcolumn > dim(object$lod)[3]) stop("Argument lodcolumn misspecified.") object$lod <- object$lod[,,lodcolumn] } if(length(thresholds) < 3) { if(length(thresholds) == 1) thresholds <- c(thresholds, 0, 0) else stop("You must give three thresholds: full, interaction and main\n") } thrfull <- thresholds[1] thrint <- thresholds[2] thrcond <- thresholds[3] lod <- object$lod map <- object$map # backward compatibility for previous version of R/qtl if(is.na(match("scanoneX",names(object)))) { warning("It would be best to re-run scantwo() with the R/qtl version 0.98 or later.") scanoneX <- NULL } else scanoneX <- object$scanoneX # deal with bad LOD score values if(any(is.na(lod) | lod < -1e-06 | lod == Inf)) warning("Some LOD scores NA, Inf or < 0; set to 0") lod[is.na(lod) | lod < 0 | lod == Inf] <- 0 # if there's no mainscan result, ignore the thresholds # and don't include the 4 conditional LOD columns if(all(is.na(diag(lod)) | diag(lod) < 1e-10)) includes.scanone <- FALSE else includes.scanone <- TRUE # change lod scores to old version u <- upper.tri(lod) lod[u] <- t(lod)[u] - lod[u] # If scanone results available, calculate conditional LOD scores if(includes.scanone) { d <- diag(lod) q1 <- matrix(rep(d,length(d)),ncol=length(d)) q2 <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE) if(!is.null(scanoneX) && any(map[,4])) { d <- scanoneX q1X <- matrix(rep(d,length(d)),ncol=length(d)) q2X <- matrix(rep(d,length(d)),ncol=length(d),byrow=TRUE) q1[map[,4],] <- q1X[map[,4],] q2[,map[,4]] <- q2X[,map[,4]] } q1[lower.tri(q1)] <- t(q2)[lower.tri(q2)] condlod <- abs(lod - t(lod)) - q1 diag(condlod) <- 0 } else condlod <- NULL # Negative thresholds are interpreted relative to the maximum LOD score if(thrfull < 0) thrfull <- max(0,max(lod[lower.tri(lod)]) + thrfull) if(thrint < 0) thrint <- max(0,max(lod[upper.tri(lod)]) + thrint) if(thrcond < 0 && includes.scanone) thrcond <- max(0,max(condlod) + thrcond) crosstype <- attr(object, "type") if(is.null(crosstype)) { warning("No type attribute in input data; assuming backcross.") crosstype <- "bc" } # calculate the degree of freedom if(crosstype == "bc" || crosstype == "riself" || crosstype == "risib" || crosstype=="dh") { df.int <- 1 df.add <- 1 } else if(crosstype == "f2") { df.int <- 4 df.add <- 2 } else if(crosstype == "4way") { df.int <- 9 df.add <- 3 } else { stop("Don't know what to do with cross type ", crosstype) } # chromsomes in the result chr <- unique(map[, 1]) n.chr <- length(chr) # calculate the locations of each chromosome within the LOD matrix wh.index <- vector("list", n.chr) n <- nrow(map) for(i in 1:n.chr) wh.index[[i]] <- which(map[, 1] == chr[i]) results <- NULL # go through each pair of chromosomes for(i in 1:n.chr) { for(j in i:n.chr) { tmplod1 <- lod[wh.index[[j]], wh.index[[i]],drop=FALSE] if(!is.null(condlod)) { if(i==j) tmpcondlod <- condlod[wh.index[[i]],wh.index[[i]],drop=FALSE] else { tmpcondlod1 <- condlod[wh.index[[j]],wh.index[[i]],drop=FALSE] tmpcondlod2 <- condlod[wh.index[[i]],wh.index[[j]],drop=FALSE] } } if(i != j) tmplod2 <- lod[wh.index[[i]], wh.index[[j]],drop=FALSE] else tmplod2 <- tmplod1 if(type == "joint") { if(i == j) { tri <- lower.tri(tmplod1) lod.joint <- max(tmplod1[tri]) idx <- which(tmplod1 == lod.joint & tri, arr.ind=TRUE) if(!is.matrix(idx)) { cat("problem\n") return(tmplod1) } } else { lod.joint <- max(tmplod1) idx <- which(tmplod1 == lod.joint, arr.ind=TRUE) if(!is.matrix(idx)) { cat("problem\n") return(tmplod1) } } if(nrow(idx)>1) idx <- idx[sample(nrow(idx),1),,drop=FALSE] idx.row <- idx[1] idx.col <- idx[2] lod.int <- tmplod2[idx.col, idx.row,drop=FALSE] } else { # interaction lod if(i == j) { tri <- upper.tri(tmplod2) lod.int <- max(tmplod2[tri]) idx <- which(tmplod2 == lod.int & tri, arr.ind=TRUE) } else { lod.int <- max(tmplod2) idx <- which(tmplod2 == lod.int) } if(nrow(idx)>1) idx <- idx[sample(nrow(idx),1),,drop=FALSE] idx.row <- idx[2] idx.col <- idx[1] lod.joint <- tmplod1[idx.row, idx.col,drop=FALSE] } full.idx.row <- idx.row + wh.index[[j]][1] - 1 full.idx.col <- idx.col + wh.index[[i]][1] - 1 flag <- FALSE # a flag to indicate whether there's any peak on this pair if(lod.joint >= thrfull) { if(includes.scanone) { if(i==j) { lod.q1 <- tmpcondlod[idx.row,idx.col,drop=FALSE] lod.q2 <- tmpcondlod[idx.col,idx.row,drop=FALSE] } else { lod.q1 <- tmpcondlod1[idx.row,idx.col,drop=FALSE] lod.q2 <- tmpcondlod2[idx.col,idx.row,drop=FALSE] } if(lod.int >= thrint || min(c(lod.q1, lod.q2)) >= thrcond) { flag <- TRUE i.pos <- map[full.idx.col, 2] j.pos <- map[full.idx.row, 2] results <- rbind(results, data.frame(chr[i], chr[j], i.pos, j.pos, lod.joint, 1 - pchisq(2 * log(10) * lod.joint, df.int + 2 * df.add), lod.int, 1 - pchisq(2 * log(10) * lod.int, df.int), lod.q1, 1 - pchisq(2 * log(10) * lod.q1, df.add), lod.q2, 1 - pchisq(2 * log(10) * lod.q2, df.add), stringsAsFactors=TRUE) ) } } else { # no scanone output flag <- TRUE i.pos <- map[full.idx.col, 2] j.pos <- map[full.idx.row, 2] results <- rbind(results, data.frame(chr[i], chr[j], i.pos, j.pos, lod.joint, 1 - pchisq(2 * log(10) * lod.joint, df.int + 2 * df.add), lod.int, 1 - pchisq(2 * log(10) * lod.int, df.int), stringsAsFactors=TRUE) ) } # give the new row (if any) a name if(flag) { mname <- rownames(map) rownames(results)[nrow(results)] <- paste(mname[full.idx.col], ":", mname[full.idx.row], sep="") } } # lod joint above threshold } # end loop over chromosomes } if(is.null(results)) { results <- numeric(0) } else { if(includes.scanone) colnames(results) <- c("chr1", "chr2", "pos1", "pos2", "lod.joint", "p.joint", "lod.int", "p.int", "lod.q1", "p.q1", "lod.q2", "p.q2") else colnames(results) <- c("chr1", "chr2", "pos1", "pos2", "lod.joint", "p.joint", "lod.int", "p.int") results <- as.data.frame(results, stringsAsFactors=TRUE) } class(results) <- c("summary.scantwo.old", "data.frame") results } print.summary.scantwo.old <- function(x,...) { if(length(x)==0) { cat(" There were no pairs of loci meeting the criteria.\n") return(invisible(NULL)) } # column names cnames <- c("pos1", "pos2", " LODjnt", "-logP", " LODint", "-logP", " LODq1", "-logP", " LODq2", "-logP") # chr names chr1 <- paste("c",x[,1],sep="") chr2 <- paste("c",x[,2],sep="") # pad chr names with spaces; this isn't really necessary nchar.c1 <- nchar(chr1); max.nchar.c1 <- max(nchar.c1) nchar.c2 <- nchar(chr2); max.nchar.c2 <- max(nchar.c2) if(any(nchar.c1 < max.nchar.c1 | nchar.c2 < max.nchar.c2)) { for(i in 1:length(nchar.c2)) { if(nchar.c1[i] < max.nchar.c1) chr1[i] <- paste(paste(rep(" ", max.nchar.c1-nchar.c1[i]),collapse=""), chr1[i],sep="") if(nchar.c2[i] < max.nchar.c2) chr2[i] <- paste(paste(rep(" ", max.nchar.c2-nchar.c2[i]),collapse=""), chr2[i],sep="") } } chr <- paste(chr1,chr2,sep=":") # round the rest; take -log10(P-values) for(j in 3:ncol(x)) { if(j<5) x[,j] <- round(x[,j]) else if(j %% 2) # odd x[,j] <- round(x[,j],2) else x[,j] <- -round(log10(x[,j]),1) } res <- as.data.frame(x[,-(1:2)], stringsAsFactors=TRUE) names(res) <- cnames[1:ncol(res)] rownames(res) <- chr cat("\n") print.data.frame(res) cat("\n") } # end of summary.scantwo.old.R qtl/R/mqmscanall.R0000644000176200001440000001600513576241200013530 0ustar liggesusers##################################################################### # # mqmscanall.R # # Copyright (c) 2009-2019, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # first written Februari 2009 # last modified Dec 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmscanall # scanall # # ##################################################################### mqmscanall <- function(cross, multicore=TRUE, n.clusters=1, batchsize=10,cofactors=NULL, ...) { scanall(cross=cross, multicore=multicore, n.clusters=n.clusters, batchsize=batchsize,cofactors=cofactors, ..., scanfunction=mqmscan) } scanall <- function(cross, scanfunction=scanone, multicore=TRUE, n.clusters=1, batchsize=10, FF=0,cofactors=NULL, ..., plot=FALSE, verbose=FALSE) { if(missing(cross)){ ourstop("No cross file. Please supply a valid cross object.") } crosstype <- crosstype(cross) if(!(crosstype == "f2" || crosstype == "bc" || crosstype == "riself")) stop("Currently only F2, BC, and selfed RIL crosses can be analyzed by MQM.") cross <- omit_x_chr(cross) start <- proc.time() n.pheno <- nphe(cross) if(verbose) { ourline() cat("Starting R/QTL multitrait analysis\n") cat("Number of phenotypes:",n.pheno,"\n") cat("Batchsize:",batchsize," & n.clusters:",n.clusters,"\n") ourline() } result <- NULL #BATCH result variable res <- NULL #GLOBAL result variable all.data <- cross bootstraps <- 1:n.pheno batches <- length(bootstraps) %/% batchsize last.batch.num <- length(bootstraps) %% batchsize if(last.batch.num > 0){ batches = batches+1 } #INIT TIME VARS SUM <- 0 AVG <- 0 LEFT <- 0 #TEST FOR SNOW CAPABILITIES if(multicore && n.clusters >1) { updateParallelRNG(n.clusters) if(verbose) cat("INFO: Using ",n.clusters," Cores/CPU's/PC's for calculation.\n") for(x in 1:(batches)){ start <- proc.time() if(verbose) cat("INFO: Starting with batch",x,"/",batches,"\n") if(x==batches && last.batch.num > 0){ boots <- bootstraps[((batchsize*(x-1))+1):((batchsize*(x-1))+last.batch.num)] }else{ boots <- bootstraps[((batchsize*(x-1))+1):(batchsize*(x-1)+batchsize)] } if(Sys.info()[1] == "Windows") { # Windows doesn't support mclapply, but it's faster if available cl <- makeCluster(n.clusters) on.exit(stopCluster(cl)) result <- clusterApply(cl, boots, snowCoreALL, all.data=all.data, scanfunction=scanfunction, cofactors=cofactors, verbose=verbose, ...) } else { result <- mclapply(boots, snowCoreALL, all.data=all.data, scanfunction=scanfunction, cofactors=cofactors, verbose=verbose, mc.cores=n.clusters, ...) } if(plot){ temp <- result class(temp) <- c(class(temp),"mqmmulti") mqmplot.multitrait(temp) } res <- c(res,result) end <- proc.time() SUM <- SUM + (end-start)[3] AVG <- SUM/x LEFT <- AVG*(batches-x) if(verbose) { cat("INFO: Done with batch",x,"/",batches,"\n") cat("INFO: Calculation of batch",x,"took:",round((end-start)[3], digits=3),"seconds\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per batch:",round((AVG), digits=3)," per trait:",round((AVG %/% batchsize), digits=3),"seconds\n") cat("INFO: Estimated time left:",LEFT%/%3600,":",(LEFT%%3600)%/%60,":",round(LEFT%%60,digits=0),"(Hour:Min:Sec)\n") ourline() } } }else{ if(verbose) cat("INFO: Going into singlemode.\n") for(x in 1:(batches)){ start <- proc.time() if(verbose) cat("INFO: Starting with batch",x,"/",batches,"\n") if(x==batches && last.batch.num > 0){ boots <- bootstraps[((batchsize*(x-1))+1):((batchsize*(x-1))+last.batch.num)] }else{ boots <- bootstraps[((batchsize*(x-1))+1):(batchsize*(x-1)+batchsize)] } result <- lapply(boots, FUN=snowCoreALL,all.data=all.data,scanfunction=scanfunction,cofactors=cofactors,verbose=verbose,...) if(plot){ temp <- result class(temp) <- c(class(temp),"mqmmulti") mqmplot.multitrait(temp) } res <- c(res,result) end <- proc.time() SUM <- SUM + (end-start)[3] AVG <- SUM/x LEFT <- AVG*(batches-x) if(verbose) { cat("INFO: Done with batch",x,"/",batches,"\n") cat("INFO: Calculation of batch",x,"took:",round((end-start)[3], digits=3),"seconds\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per batch:",round((AVG), digits=3)," per trait:",round((AVG %/% batchsize), digits=3),"seconds\n") cat("INFO: Estimated time left:",LEFT%/%3600,":",(LEFT%%3600)%/%60,":",round(LEFT%%60,digits=0),"(Hour:Min:Sec)\n") ourline() } } } if(FF){ if(verbose) cat(rownames(res[[1]]),"\n",res[[1]][,1],"\n",res[[1]][,2],"\n",file="out.frank") for(i in 1:length(res)){ if(verbose) cat("INFO: Saving trait",i,"in frankformat\n") qtl <- res[[i]] if(verbose) cat(colnames(qtl)[3],qtl[,3],"\n",file="out.frank",append = TRUE) } } #Return the results if(length(res) > 1){ class(res) <- c(class(res),"mqmmulti") }else{ class(res) <- c(class(res),"scanone") } #All done now plot the results end <- proc.time() SUM <- SUM + (end-start)[3] AVG <- SUM/n.pheno if(verbose) { cat("------------------------------------------------------------------\n") cat("INFO: Elapsed time:",(SUM%/%3600),":",(SUM%%3600)%/%60,":",round(SUM%%60, digits=0),"(Hour:Min:Sec)\n") cat("INFO: Average time per trait:",round(AVG, digits=3),"seconds\n") cat("------------------------------------------------------------------\n") } res } # end of scanall.R qtl/R/summary.scanone.R0000644000176200001440000011333714454577746014557 0ustar liggesusers###################################################################### # # summary.scanone.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Sep, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: summary.scanone, print.summary.scanone, # max.scanone, c.scanone, subset.scanone, # summary.scanoneperm, print.summary.scanoneperm # c.scanoneperm, rbind.scanoneperm, cbind.scanoneperm # grab.arg.names, subset.scanoneperm, [.scanoneperm # ###################################################################### ################################################################## # summarize scanone results ################################################################## summary.scanone <- function(object, threshold, format=c("onepheno", "allpheno", "allpeaks", "tabByCol", "tabByChr"), perms, alpha, lodcolumn=1, pvalues=FALSE, ci.function=c("lodint", "bayesint"), ...) { if(!inherits(object, "scanone")) stop("Input should have class \"scanone\".") format <- match.arg(format) ncol.object <- ncol(object)-2 cn.object <- colnames(object)[-(1:2)] if(ncol.object==1 && (format == "allpeaks" || format == "allpheno")) { warning("With just one LOD column, format=\"onepheno\" used.") format <- "onepheno" } if(format != "onepheno" && !missing(lodcolumn)) warning("lodcolumn ignored except when format=\"onepheno\".") if(!missing(perms)) { if(inherits(perms, "scantwoperm")) perms <- scantwoperm2scanoneperm(perms) else if(!inherits(perms, "scanoneperm")) warning("perms need to be in scanoneperm format.") } # check input if(missing(perms) && !missing(alpha)) stop("If alpha is to be used, permutation results must be provided.") if(!missing(threshold) && !missing(alpha)) stop("Only one of threshold and alpha should be specified.") if(format == "onepheno") { if(!missing(lodcolumn) && length(lodcolumn) > 1) { warning("With format=\"onepheno\", lodcolumn should have length 1.") lodcolumn <- lodcolumn[1] } if(lodcolumn < 1 || lodcolumn > ncol.object) stop("lodcolumn should be between 1 and no. LOD columns.") } if(!missing(alpha) && length(alpha) > 1) { warning("alpha should have length 1.") alpha <- alpha[1] } if(!missing(perms)) { if("xchr" %in% names(attributes(perms))) { ncol.perms <- ncol(perms$A) cn.perms <- colnames(perms$A) } else { ncol.perms <- ncol(perms) cn.perms <- colnames(perms) } if(ncol.object != ncol.perms) { if(ncol.perms==1) { # reuse the multiple columns origperms <- perms if("xchr" %in% names(attributes(perms))) { for(j in 2:ncol.object) { perms$A <- cbind(perms$A, origperms$A) perms$X <- cbind(perms$X, origperms$X) } cn.perms <- colnames(perms$A) <- colnames(perms$X) <- cn.object } else { for(j in 2:ncol.object) perms <- cbind(perms, origperms) cn.perms <- colnames(perms) <- cn.object } warning("Just one column of permutation results; reusing for all LOD score columns.") } else { if(ncol.object == 1) { warning("Using just the first column in the perms input") if("xchr" %in% names(attributes(perms))) { perms$A <- perms$A[,1,drop=FALSE] perms$X <- perms$X[,1,drop=FALSE] } else { clp <- class(perms) perms <- perms[,1,drop=FALSE] class(perms) <- clp } } else stop("scanone input has different number of LOD columns as perms input.") } } if(!all(cn.object == cn.perms)) warning("Column names in scanone input do not match those in perms input.") } if(format != "onepheno") { if(!missing(threshold)) { if(length(threshold)==1) threshold <- rep(threshold, ncol.object) else if(length(threshold) != ncol.object) stop("threshold should have length 1 or match number LOD scores in scanone input.") } } if(missing(perms) && pvalues) { warning("Can show p-values only if perms are provided.") pvalues <- FALSE } # end of check of input # chromosome IDs as a character string chr <- as.character(object[,1]) if(format=="onepheno") { lodcolumn <- lodcolumn+2 # pull out max on each chromosome wh <- NULL for(i in unique(chr)) { if(any(!is.na(object[chr==i,lodcolumn]))) { mx <- max(object[chr==i,lodcolumn],na.rm=TRUE) tmp <- which(chr==i & object[,lodcolumn]==mx) if(length(tmp) > 1) tmp <- sample(tmp, 1) # if multiple, pick at random wh <- c(wh, tmp) } } thechr <- as.character(object[wh,1]) if(!missing(threshold)) { if(length(threshold) > 1) { warning('when format="allpheno", threshold should have length 1') threshold <- threshold[1] } wh <- wh[object[wh,lodcolumn] > threshold] } else if(!missing(alpha)) { thr <- summary(perms, alpha) if("xchr" %in% names(attributes(perms))) { thr <- sapply(thr, function(a,b) a[,b], lodcolumn-2) xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] xchr <- thechr %in% xchr wh <- wh[(!xchr & object[wh,lodcolumn] > thr[1]) | (xchr & object[wh,lodcolumn] > thr[2])] } else { thr <- thr[,lodcolumn-2] wh <- wh[object[wh,lodcolumn] > thr] } } result <- object[wh,] } # end of "onepheno" format else if(format=="allpheno") { # pull out max on each chromosome wh <- vector("list", ncol.object) for(lodcolumn in 1:ncol.object+2) { for(i in unique(chr)) { if(any(!is.na(object[chr==i,lodcolumn]))) { mx <- max(object[chr==i,lodcolumn],na.rm=TRUE) tmp <- which(chr==i & object[,lodcolumn]==mx) if(length(tmp) > 1) tmp <- sample(tmp, 1) wh[[lodcolumn-2]] <- c(wh[[lodcolumn-2]], tmp) } } } if(!missing(threshold)) { # rows with at least one LOD > threshold for(lodcolumn in 1:ncol.object) { temp <- wh[[lodcolumn]] wh[[lodcolumn]] <- temp[object[temp,lodcolumn+2] > threshold[lodcolumn]] } } else if(!missing(alpha)) { thr <- summary(perms, alpha) if("xchr" %in% names(attributes(perms))) { xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] for(lodcolumn in 1:ncol.object) { temp <- wh[[lodcolumn]] thechr <- as.character(object[temp,1]) xchr <- thechr %in% xchr wh[[lodcolumn]] <- temp[(!xchr & object[temp,lodcolumn+2] > thr$A[lodcolumn]) | (xchr & object[temp,lodcolumn+2] > thr$X[lodcolumn])] } } else { for(lodcolumn in 1:ncol.object) { temp <- wh[[lodcolumn]] wh[[lodcolumn]] <- temp[object[temp,lodcolumn+2] > thr[lodcolumn]] } } } wh <- sort(unique(unlist(wh))) result <- object[wh,] } # end of format=="allpheno" else if(format=="allpeaks") { # pull out max on each chromosome wh <- vector("list", ncol.object) for(lodcolumn in (1:ncol.object)+2) { for(i in unique(chr)) { if(any(!is.na(object[chr==i,lodcolumn]))) { mx <- max(object[chr==i,lodcolumn],na.rm=TRUE) temp <- which(chr==i & object[,lodcolumn]==mx) if(length(temp)>1) temp <- sample(temp, 1) wh[[lodcolumn-2]] <- c(wh[[lodcolumn-2]], temp) } else wh[[lodcolumn-2]] <- c(wh, NA) } } pos <- sapply(wh, function(a,b) b[a], object[,2]) if(!is.matrix(pos)) pos <- as.matrix(pos) lod <- pos for(i in 1:ncol(pos)) lod[,i] <- object[wh[[i]],i+2] thechr <- as.character(unique(object[,1])) if(!missing(threshold)) { # rows with at least one LOD > threshold keep <- NULL for(i in seq(along=thechr)) if(any(lod[i,] > threshold)) keep <- c(keep, i) } else if(!missing(alpha)) { keep <- NULL thr <- summary(perms, alpha) if("xchr" %in% names(attributes(perms))) { xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] xchr <- thechr %in% xchr for(i in seq(along=thechr)) { if((xchr[i] && any(lod[i,] > thr$X)) || (!xchr[i] && any(lod[i,] > thr$A))) keep <- c(keep, i) } } else { for(i in seq(along=thechr)) { if(any(lod[i,] > thr)) keep <- c(keep, i) } } } else keep <- seq(along=thechr) if(is.null(keep)) result <- object[NULL,,drop=FALSE] else { pos <- pos[keep,,drop=FALSE] lod <- lod[keep,,drop=FALSE] thechr <- thechr[keep] result <- as.data.frame(matrix(ncol=ncol.object*2+1,nrow=length(keep)), stringsAsFactors=TRUE) names(result)[1] <- "chr" names(result)[(1:ncol.object)*2] <- "pos" names(result)[(1:ncol.object)*2+1] <- names(object)[-(1:2)] result[,1] <- thechr result[,(1:ncol.object)*2] <- pos result[,(1:ncol.object)*2+1] <- lod } } else { # format=="tabByChr" or =="tabByCol" result <- vector("list", ncol.object) names(result) <- names(object)[-(1:2)] # pull out max on each chromosome wh <- vector("list", ncol.object) for(lodcolumn in (1:ncol.object)+2) { for(i in unique(chr)) { if(any(!is.na(object[chr==i,lodcolumn]))) { mx <- max(object[chr==i,lodcolumn],na.rm=TRUE) temp <- which(chr==i & object[,lodcolumn]==mx) if(length(temp)>1) temp <- sample(temp, 1) wh[[lodcolumn-2]] <- c(wh[[lodcolumn-2]], temp) } else wh[[lodcolumn-2]] <- c(wh, NA) } } pos <- sapply(wh, function(a,b) b[a], object[,2]) if(!is.matrix(pos)) pos <- as.matrix(pos) lod <- pos for(i in 1:ncol(pos)) lod[,i] <- object[wh[[i]],i+2] thechr <- as.character(unique(object[,1])) for(i in 1:ncol.object) result[[i]] <- object[wh[[i]],c(1,2,i+2)] } if(pvalues) { if(format != "tabByCol" && format != "tabByChr") { if(nrow(result) > 0) { # get p-values and add to the results rn <- rownames(result) if("xchr" %in% names(attributes(perms))) { xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] xchr <- as.character(result[,1]) %in% xchr L <- attr(perms, "L") Lt <- sum(L) if(format=="allpeaks") thecol <- (1:ncol.object)*2+1 else thecol <- (1:ncol.object)+2 if(any(xchr)) { tempX <- calcPermPval(result[xchr,thecol,drop=FALSE], perms$X) tempX <- as.data.frame(1-(1-tempX)^(Lt/L[2]), stringsAsFactors=TRUE) } else tempX <- NULL if(any(!xchr)) { tempA <- calcPermPval(result[!xchr,thecol,drop=FALSE], perms$A) tempA <- as.data.frame(1-(1-tempA)^(Lt/L[1]), stringsAsFactors=TRUE) } else tempA <- NULL pval <- rbind(tempA, tempX) if(any(xchr)) pval[xchr,] <- tempX if(any(!xchr)) pval[!xchr,] <- tempA } else { if(format=="allpeaks") thecol <- (1:ncol.object)*2+1 else thecol <- (1:ncol.object)+2 pval <- as.data.frame(calcPermPval(result[,thecol,drop=FALSE], perms), stringsAsFactors=TRUE) } if(format == "allpeaks") { temp <- as.data.frame(matrix(nrow=nrow(result), ncol=ncol.object*3+1), stringsAsFactors=TRUE) names(temp)[1] <- names(result)[1] temp[,1] <- result[,1] for(i in 1:ncol.object) { names(temp)[i*3+(-1:1)] <- c(names(result)[i*2+(0:1)], "pval") temp[,i*3-1:0] <- result[,i*2+(0:1)] temp[,i*3+1] <- pval[[i]] } } else if(format != "tabByCol" && format != "tabByChr") { temp <- as.data.frame(matrix(nrow=nrow(result), ncol=ncol.object*2+2), stringsAsFactors=TRUE) names(temp)[1:2] <- names(result)[1:2] temp[,1:2] <- result[,1:2] for(i in 1:ncol.object) { names(temp)[i*2+1:2] <- c(names(result)[i+2], "pval") temp[,i*2+1] <- result[,i+2] temp[,i*2+2] <- pval[[i]] } } result <- temp rownames(result) <- rn } } else { # format=="tabByCol" || format=="tabByChr" peaks <- as.data.frame(lapply(result, function(a) a[,3]), stringsAsFactors=TRUE) if("xchr" %in% names(attributes(perms))) { xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] xchr <- as.character(result[[1]][,1]) %in% xchr L <- attr(perms, "L") Lt <- sum(L) if(any(xchr)) { tempX <- as.data.frame(calcPermPval(peaks[xchr,,drop=FALSE], perms$X), stringsAsFactors=TRUE) tempX <- 1-(1-tempX)^(Lt/L[2]) } else tempX <- NULL if(any(!xchr)) { tempA <- as.data.frame(calcPermPval(peaks[!xchr,,drop=FALSE], perms$A), stringsAsFactors=TRUE) tempA <- 1-(1-tempA)^(Lt/L[1]) } else tempA <- NULL pval <- rbind(tempA, tempX) if(any(xchr)) pval[xchr,] <- tempX if(any(!xchr)) pval[!xchr,] <- tempA } else pval <- as.data.frame(calcPermPval(peaks, perms), stringsAsFactors=TRUE) for(i in seq(along=result)) result[[i]] <- cbind(as.data.frame(result[[i]]), pval=pval[,i], stringsAsFactors=TRUE) } } if(format=="tabByCol" || format=="tabByChr") { # drop insignificant peaks if(!missing(threshold)) { # rows with at least one LOD > threshold for(i in seq(along=result)) result[[i]] <- result[[i]][lod[,i] > threshold[i],,drop=FALSE] } else if(!missing(alpha)) { keep <- NULL thr <- summary(perms, alpha) if("xchr" %in% names(attributes(perms))) { xchr <- attr(perms, "xchr") xchr <- names(xchr)[xchr] xchr <- thechr %in% xchr for(i in seq(along=result)) result[[i]] <- result[[i]][(lod[,i] > thr$A[i] & !xchr) | (lod[,i] > thr$X[i] & xchr), , drop=FALSE] } else { for(i in seq(along=result)) result[[i]] <- result[[i]][lod[,i] > thr[i],,drop=FALSE] } } # add intervals ci.function <- match.arg(ci.function) if(ci.function=="lodint") cif <- lodint else cif <- bayesint for(i in seq(along=result)) { if(nrow(result[[i]]) == 0) next lo <- hi <- rep(NA, nrow(result[[i]])) for(j in 1:nrow(result[[i]])) { temp <- cif(object, chr=as.character(result[[i]][j,1]), lodcolumn=i, ...) lo[j] <- temp[1,2] hi[j] <- temp[nrow(temp),2] } result[[i]] <- cbind(as.data.frame(result[[i]]), ci.low=lo, ci.high=hi, stringsAsFactors=TRUE) colnames(result[[i]])[3] <- "lod" } if(format=="tabByChr" && length(result)==1) format <- "tabByCol" # no need to do by chr in this case if(format=="tabByChr") { temp <- vector("list", length(thechr)) names(temp) <- thechr for(i in seq(along=result)) { if(nrow(result[[i]])==0) next rownames(result[[i]]) <- paste(names(result)[i], rownames(result[[i]]), sep=" : ") for(j in 1:nrow(result[[i]])) { thischr <- match(result[[i]][j,1], thechr) if(length(temp[[thischr]])==0) temp[[thischr]] <- result[[i]][j,,drop=FALSE] else temp[[thischr]] <- rbind(temp[[thischr]], result[[i]][j,,drop=FALSE]) } } result <- temp } # move CI to before the lod score for(i in seq(along=result)) { if(is.null(result[[i]]) || nrow(result[[i]])==0) next nc <- ncol(result[[i]]) result[[i]] <- result[[i]][,c(1,2,nc-1,nc,3:(nc-2)),drop=FALSE] } attr(result, "tab") <- format } if(format=="allpeaks") rownames(result) <- as.character(result$chr) if(format=="tabByCol" || format=="tabByChr") class(result) <- c("summary.scanone", "list") else class(result) <- c("summary.scanone", "data.frame") result } # print output of summary.scanone print.summary.scanone <- function(x, ...) { tab <- attr(x, "tab") if(is.null(tab) && nrow(x) == 0) { cat(" There were no LOD peaks above the threshold.\n") return(invisible(NULL)) } flag <- FALSE if(is.null(tab)) { print.data.frame(x,digits=3) flag <- TRUE } else if(tab=="tabByChr") { for(i in seq(along=x)) { if(is.null(x[[i]])) next else { flag <- TRUE cat("Chr ", names(x)[i], ":\n", sep="") print(x[[i]], digits=3) cat("\n") } } } else if(tab=="tabByCol") { for(i in seq(along=x)) { if(nrow(x[[i]])==0) next else { flag <- TRUE if(length(x) > 1) cat(names(x)[i], ":\n", sep="") print(x[[i]], digits=3) if(length(x) > 1) cat("\n") } } } if(!flag) cat(" There were no LOD peaks above the threshold.\n") } # pull out maximum LOD peak, genome-wide max.scanone <- function(object, chr, lodcolumn=1, na.rm=TRUE, ...) { if(!inherits(object, "scanone")) stop("Input must have class \"scanone\".") if(lodcolumn < 1 || lodcolumn+2 > ncol(object)) stop("Argument lodcolumn should be between 1 and ", ncol(object)-2) if(!missing(chr)) object <- subset(object, chr=chr) maxlod <- max(object[,lodcolumn+2],na.rm=TRUE) wh <- which(!is.na(object[,lodcolumn+2]) & object[,lodcolumn+2]==maxlod) if(length(wh) > 1) wh <- sample(wh, 1) object <- object[wh,] object[,1] <- factor(as.character(unique(object[,1]))) summary.scanone(object,threshold=0,lodcolumn=lodcolumn) } ###################################################################### # subset.scanone ###################################################################### subset.scanone <- function(x, chr, lodcolumn, ...) { if(!inherits(x, "scanone")) stop("Input should have class \"scanone\".") if(missing(chr) && missing(lodcolumn)) stop("You must specify either chr or lodcolumn.") y <- x if(!missing(chr)) { chr <- matchchr(chr, unique(x[,1])) x <- x[!is.na(match(x[,1],chr)), ,drop=FALSE] thechr <- as.character(x[,1]) x[,1] <- factor(thechr, levels=unique(thechr)) } if(!missing(lodcolumn)) { if(any(lodcolumn>0) && any(lodcolumn<0)) stop("lodcolumn values can't be both >0 and <0.") if(any(lodcolumn<0) || is.logical(lodcolumn)) lodcolumn <- (1:(ncol(x)-2))[lodcolumn] if(length(lodcolumn)==0) stop("You must retain at least one LOD column.") if(any(lodcolumn < 1 || lodcolumn > ncol(x)-2)) stop("lodcolumn values must be >=1 and <=",ncol(x)-2) x <- x[,c(1,2,lodcolumn+2)] } class(x) <- class(y) nam <- names(attributes(y)) if("method" %in% nam) attr(x, "method") <- attr(y,"method") if("type" %in% nam) attr(x, "type") <- attr(y,"type") if("model" %in% nam) attr(x, "model") <- attr(y,"model") x } ###################################################################### # c.scanone # # Combine the results of multiple runs of scanone into single object # (pasting the columns together). ###################################################################### c.scanone <- function(..., labels) { dots <- list(...) if(length(dots)==1 && is.list(dots[[1]])) dots <- dots[[1]] if(length(dots)==1) return(dots[[1]]) for(i in seq(along=dots)) { if(!inherits(dots[[i]], "scanone")) stop("Input should have class \"scanone\".") } if(!missing(labels)) { if(length(labels)==1) labels <- rep(labels, length(dots)) if(length(labels) != length(dots)) stop("labels needs to be the same length as the number of objects input.") gavelabels <- TRUE } else { labels <- grab.arg.names(...) gavelabels <- FALSE } nr <- sapply(dots, nrow) if(length(unique(nr)) != 1) stop("The input must all have the same number of rows.") chr <- lapply(dots, function(a) a$chr) pos <- lapply(dots, function(a) a$pos) for(i in 2:length(dots)) { if(any(chr[[1]] != chr[[i]]) || any(pos[[1]] != pos[[i]])) { cat("The input must conform exactly (same chr and positions\n") stop("(That is, calc.genoprob and/or sim.geno must have used the same step and off.end)\n") } } cl <- class(dots[[1]]) thenam <- unlist(lapply(dots, function(a) colnames(a)[-(1:2)])) if(length(unique(thenam)) == length(thenam)) repeats <- FALSE else repeats <- TRUE if(repeats || gavelabels) { for(i in 1:length(dots)) { colnames(dots[[i]])[-(1:2)] <- paste(colnames(dots[[i]])[-(1:2)], labels[i], sep=".") dots[[i]] <- as.data.frame(dots[[i]], stringsAsFactors=TRUE) } } result <- dots[[1]] for(i in 2:length(dots)) result <- cbind(as.data.frame(result, stringsAsFactors=TRUE), as.data.frame(dots[[i]][,-(1:2),drop=FALSE], stringsAsFactors=TRUE)) class(result) <- cl result } cbind.scanone <- c.scanone grab.arg.names <- function(...) { # pull out the names from the input temp <- deparse(substitute(c(...))) temp <- unlist(strsplit(temp, ",")) for(i in seq(along=temp)) temp[i] <- paste(unlist(strsplit(temp[i]," ")),collapse="") temp[1] <- substr(temp[1], 3, nchar(temp[1])) temp[length(temp)] <- substr(temp[length(temp)], 1, nchar(temp[length(temp)])-1) temp } ###################################################################### # summary.scanoneperm # # Give genome-wide LOD thresholds on the basis of the results of # scanone permutation test (from scanone with n.perm > 0) ###################################################################### summary.scanoneperm <- function(object, alpha=c(0.05, 0.10), controlAcrossCol=FALSE, ...) { if(!inherits(object, "scanoneperm")) stop("Input should have class \"scanoneperm\".") if(any(alpha < 0 | alpha > 1)) stop("alpha should be between 0 and 1.") if("xchr" %in% names(attributes(object))) { # X-chromosome-specific results L <- attr(object, "L") thealpha <- cbind(1 - (1-alpha)^(L[1]/sum(L)), 1 - (1-alpha)^(L[2]/sum(L))) v <- c("A","X") quant <- vector("list", 2) names(quant) <- c("A","X") for(k in 1:2) { if(!is.matrix(object[[v[k]]])) object[[v[k]]] <- as.matrix(object[[v[k]]]) if(controlAcrossCol) { if(any(is.na(object[[v[k]]]))) object[[v[k]]] <- object[[v[k]]][apply(object[[v[k]]],1,function(a) !any(is.na(a))),,drop=FALSE] r <- apply(object[[v[k]]], 2, rank, ties.method="random", na.last=FALSE) print(is.matrix(r)) rmax <- apply(r, 1, max) rqu <- quantile(rmax, 1-thealpha[,k], na.rm=TRUE) qu <- matrix(nrow=length(thealpha[,k]), ncol=ncol(object[[v[k]]])) object.sort <- apply(object[[v[k]]], 2, sort, na.last=FALSE) for(i in seq(along=rqu)) { if(fl==ce) # exact qu[i,] <- object.sort[rqu[i],] else # need to interpolate qu[i,] <- object.sort[fl,]*(1-(ce-fl)) + object.sort[ce,]*(ce-fl) } colnames(qu) <- colnames(object[[v[k]]]) } else qu <- apply(object[[v[k]]], 2, quantile, 1-thealpha[,k], na.rm=TRUE) if(!is.matrix(qu)) { nam <- names(qu) qu <- matrix(qu, nrow=length(alpha)) dimnames(qu) <- list(paste(100*alpha,"%", sep=""), nam) } else rownames(qu) <- paste(100*alpha, "%", sep="") quant[[k]] <- qu } attr(quant, "n.perm") <- c("A"=nrow(object$A), "X"=nrow(object$X)) class(quant) <- "summary.scanoneperm" } else { if(!is.matrix(object)) object <- as.matrix(object) if(controlAcrossCol) { if(any(is.na(object))) object <- object[apply(object,1,function(a) !any(is.na(a))),,drop=FALSE] r <- apply(object, 2, rank, ties.method="random", na.last=FALSE) rmax <- apply(r, 1, max) rqu <- quantile(rmax, 1-alpha, na.rm=TRUE) quant <- matrix(nrow=length(alpha), ncol=ncol(object)) object.sort <- apply(object, 2, sort, na.last=FALSE) for(i in seq(along=rqu)) { fl <- floor(rqu[i]) ce <- ceiling(rqu[i]) if(fl==ce) # exact quant[i,] <- object.sort[rqu[i],] else # need to interpolate quant[i,] <- object.sort[fl,]*(1-(ce-fl)) + object.sort[ce,]*(ce-fl) } colnames(quant) <- colnames(object) } else quant <- apply(object, 2, quantile, 1-alpha, na.rm=TRUE) if(!is.matrix(quant)) { nam <- names(quant) quant <- matrix(quant, nrow=length(alpha)) dimnames(quant) <- list(paste(100*alpha,"%", sep=""), nam) } else rownames(quant) <- paste(100*alpha, "%", sep="") attr(quant, "n.perm") <- nrow(object) class(quant) <- "summary.scanoneperm" } quant } print.summary.scanoneperm <- function(x, ...) { n.perm <- attr(x, "n.perm") if(length(n.perm)==2) { cat("Autosome LOD thresholds (", n.perm[1], " permutations)\n", sep="") x$A <- x$A[1:nrow(x$A),,drop=FALSE] print(x$A, digits=3) cat("\nX chromosome LOD thresholds (", n.perm[2], " permutations)\n", sep="") x$X <- x$X[1:nrow(x$X),,drop=FALSE] print(x$X, digits=3) } else { cat("LOD thresholds (", n.perm, " permutations)\n", sep="") x <- x[1:nrow(x),,drop=FALSE] print(x, digits=3) } } ###################################################################### # combine scanoneperm results ... paste the rows together ###################################################################### rbind.scanoneperm <- c.scanoneperm <- function(...) { dots <- list(...) if(length(dots)==1 && is.list(dots[[1]])) dots <- dots[[1]] if(length(dots)==1) return(dots[[1]]) for(i in seq(along=dots)) { if(!inherits(dots[[i]], "scanoneperm")) stop("Input should have class \"scanoneperm\".") } if("xchr" %in% names(attributes(dots[[1]]))) { xchr <- lapply(dots, attr, "xchr") L <- lapply(dots, attr, "L") for(i in 2:length(dots)) { if(length(xchr[[1]]) != length(xchr[[i]]) || any(xchr[[1]] != xchr[[i]])) stop("xchr attributes in the input must be consistent.") if(length(L[[1]]) != length(L[[i]]) || any(L[[1]] != L[[i]])) stop("L attributes in the input must be consistent.") } for(i in 1:length(dots)) dots[[i]] <- unclass(dots[[i]]) ncA <- sapply(dots, function(a) ncol(a$A)) ncX <- sapply(dots, function(a) ncol(a$X)) if(length(unique(ncA)) != 1 || length(unique(ncX)) != 1) stop("The input must all have the same number of columns.") result <- dots[[1]] for(i in 2:length(dots)) { result$A <- rbind(result$A, dots[[i]]$A) result$X <- rbind(result$X, dots[[i]]$X) } class(result) <- "scanoneperm" attr(result, "xchr") <- xchr[[1]] attr(result, "L") <- L[[1]] } else { nc <- sapply(dots, ncol) if(length(unique(nc)) != 1) stop("The input must all have the same number of columns.") for(i in 1:length(dots)) dots[[i]] <- unclass(dots[[i]]) result <- dots[[1]] for(i in 2:length(dots)) result <- rbind(result, dots[[i]]) class(result) <- "scanoneperm" } result } ###################################################################### # combine scanoneperm results ... paste the columns together ###################################################################### cbind.scanoneperm <- function(..., labels) { dots <- list(...) if(length(dots)==1) return(dots[[1]]) for(i in seq(along=dots)) { if(!inherits(dots[[i]], "scanoneperm")) stop("Input should have class \"scanoneperm\".") } if(!missing(labels)) { if(length(labels)==1) labels <- rep(labels, length(dots)) if(length(labels) != length(dots)) stop("labels needs to be the same length as the number of objects input.") gavelabels <- TRUE } else { labels <- grab.arg.names(...) gavelabels <- FALSE } if("xchr" %in% names(attributes(dots[[1]]))) { xchr <- lapply(dots, attr, "xchr") L <- lapply(dots, attr, "L") for(i in 2:length(dots)) { if(length(xchr[[1]]) != length(xchr[[i]]) || any(xchr[[1]] != xchr[[i]])) stop("xchr attributes in the input must be consistent.") if(length(L[[1]]) != length(L[[i]]) || any(L[[1]] != L[[i]])) stop("L attributes in the input must be consistent.") } for(i in 1:length(dots)) dots[[i]] <- unclass(dots[[i]]) nr <- sapply(dots, function(a) nrow(a$A)) mnr <- max(nr) if(any(nr < mnr)) { # pad with NAs for(i in which(nr < mnr)) dots[[i]]$A <- rbind(dots[[i]]$A, matrix(NA, ncol=ncol(dots[[i]]$A), nrow=mnr-nr[i])) } nr <- sapply(dots, function(a) nrow(a$X)) mnr <- max(nr) if(any(nr < mnr)) { # pad with NAs for(i in which(nr < mnr)) dots[[i]]$X <- rbind(dots[[i]]$X, matrix(NA, ncol=ncol(dots[[i]]$X), nrow=mnr-nr[i])) } thenamA <- unlist(lapply(dots, function(a) colnames(a$A))) thenamX <- unlist(lapply(dots, function(a) colnames(a$X))) if(length(unique(thenamA)) == length(thenamA) && length(unique(thenamX)) == length(thenamX)) repeats <- FALSE else repeats <- TRUE if(repeats || gavelabels) { colnames(dots[[1]]$A) <- paste(colnames(dots[[1]]$A),labels[1],sep=".") colnames(dots[[1]]$X) <- paste(colnames(dots[[1]]$X),labels[1],sep=".") for(i in 2:length(dots)) { colnames(dots[[i]]$A) <- paste(colnames(dots[[i]]$A),labels[i],sep=".") colnames(dots[[i]]$X) <- paste(colnames(dots[[i]]$X),labels[i],sep=".") } } result <- dots[[1]] for(i in 2:length(dots)) { result$A <- cbind(result$A, dots[[i]]$A) result$X <- cbind(result$X, dots[[i]]$X) } class(result) <- "scanoneperm" attr(result, "xchr") <- xchr[[1]] attr(result, "L") <- L[[1]] } else { for(i in 1:length(dots)) dots[[i]] <- unclass(dots[[i]]) nr <- sapply(dots, nrow) mnr <- max(nr) if(any(nr < mnr)) { # pad with NAs for(i in which(nr < mnr)) dots[[i]] <- rbind(dots[[i]], matrix(NA, ncol=ncol(dots[[i]]), nrow=mnr-nr[i])) } thenam <- unlist(lapply(dots, colnames)) if(length(unique(thenam)) == length(thenam)) repeats <- FALSE else repeats <- TRUE if(repeats || gavelabels) { colnames(dots[[1]]) <- paste(colnames(dots[[1]]),labels[1],sep=".") for(i in 2:length(dots)) colnames(dots[[i]]) <- paste(colnames(dots[[i]]), labels[i], sep=".") } result <- dots[[1]] for(i in 2:length(dots)) result <- cbind(result, dots[[i]]) class(result) <- "scanoneperm" } result } ############################## # subset.scanoneperm: pull out a set of lodcolumns ############################## subset.scanoneperm <- function(x, repl, lodcolumn, ...) { att <- attributes(x) if(is.list(x)) { if(any(!sapply(x, is.matrix))) x <- lapply(x, as.matrix) if(missing(lodcolumn)) lodcolumn <- 1:ncol(x[[1]]) else if(!check_colindex(lodcolumn, x[[1]])) stop("lodcolumn misspecified.") if(missing(repl)) repl <- 1:nrow(x[[1]]) else if(!check_rowindex(repl, x[[1]])) stop("repl misspecified.") cl <- class(x) x <- lapply(x, function(a,b,d) unclass(a)[b,d,drop=FALSE], repl, lodcolumn) class(x) <- cl } else { if(!is.matrix(x)) x <- as.matrix(x) if(missing(lodcolumn)) lodcolumn <- 1:ncol(x) else if(!check_colindex(lodcolumn, x)) stop("lodcolumn misspecified.") if(missing(repl)) repl <- 1:nrow(x) else if(!check_rowindex(repl, x)) stop("repl misspecified.") cl <- class(x) x <- unclass(x)[repl,lodcolumn,drop=FALSE] class(x) <- cl } for(i in seq(along=att)) { if(names(att)[i] == "dim" || length(grep("names", names(att)[i]))>0) next attr(x, names(att)[i]) <- att[[i]] } x } # subset.scanoneperm using [,] `[.scanoneperm` <- function(x, repl, lodcolumn) subset.scanoneperm(x, repl, lodcolumn) # function to check if column indices are okay check_colindex <- function(index, mat) { if(any(is.na(index))) return(FALSE) n <- ncol(mat) if(is.logical(index) && length(index) != n) return(FALSE) if(is.numeric(index)) { if(any(index <= 0) && !all(index < 0)) return(FALSE) # don't mix pos and neg if(all(index < 0) && any(index < -n)) return(FALSE) # out of bounds if(all(index > 0) && any(index > n)) return(FALSE) # out of bounds } if(is.character(index) && !all(index %in% colnames(mat))) return(FALSE) TRUE } # function to check if row indices are okay check_rowindex <- function(index, mat) { if(any(is.na(index))) return(FALSE) n <- nrow(mat) if(is.logical(index) && length(index) != n) return(FALSE) if(is.numeric(index)) { if(any(index <= 0) && !all(index < 0)) return(FALSE) # don't mix pos and neg if(all(index < 0) && any(index < -n)) return(FALSE) # out of bounds if(all(index > 0) && any(index > n)) return(FALSE) # out of bounds } if(is.character(index) && !all(index %in% rownames(mat))) return(FALSE) TRUE } # end of summary.scanone.R qtl/R/read.cross.csv.R0000644000176200001440000002323413626261114014241 0ustar liggesusers###################################################################### # # read.cross.csv.R # # copyright (c) 2000-2020, Karl W Broman # last modified Feb, 2020 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.csv # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.csv # # read data in comma-delimited format # ###################################################################### read.cross.csv <- function(dir, file, na.strings=c("-","NA"), genotypes=c("A","H","B","D","C"), estimate.map=TRUE, rotate=FALSE, ...) { # create file names if(missing(file)) file <- "data.csv" if(!missing(dir) && dir != "") { file <- file.path(dir, file) } args <- list(...) if("" %in% na.strings) { na.strings <- na.strings[na.strings != ""] warning("Including \"\" in na.strings will cause problems; omitted.") } # if user wants to use comma for decimal point, we need if(length(args) > 0 && "dec" %in% names(args)) { dec <- args[["dec"]] } else dec <- "." # read the data file if(length(args) < 1 || !("sep" %in% names(args))) { # "sep" not in the "..." argument and so take sep="," if(length(args) < 1 || !("comment.char" %in% names(args))) data <- read.table(file, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) else data <- read.table(file, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } else { if(length(args) < 1 || !("comment.char" %in% names(args))) data <- read.table(file, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) else data <- read.table(file, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } if(rotate) data <- as.data.frame(t(data), stringsAsFactors=FALSE) empty <- grep("^\\s*$", data[2, ]) if( ! 1 %in% empty) stop("You must include at least one phenotype (e.g., an index). ", "There was this value in the first column of the second row '", data[2,1],"' where was supposed to be nothing.",sep="") # determine number of phenotypes based on initial blanks in row 2 if(length(empty)==ncol(data)) stop("Second row has all blank cells; you need to include chromosome IDs for the markers.") n.phe <- min((1:ncol(data))[-empty])-1 empty <- rep(FALSE, n.phe) empty[grep("^\\s*$", data[3,1:n.phe])] <- TRUE # Is map included? yes if first n.phe columns in row 3 are all blank if(all(empty)) { map.included <- TRUE map <- asnumericwithdec(unlist(data[3,-(1:n.phe)]), dec=dec) if(any(is.na(map))) { temp <- unique(unlist(data[3,-(1:n.phe)])[is.na(map)]) stop("There are missing marker positions.\n", " In particular, we see these value(s): ", paste("\"",paste(temp,collapse="\",\"",sep=""),"\"",collapse=" ",sep=""), " at position(s): ", paste(which(is.na(map)),colapse=",",sep=""),sep="") } nondatrow <- 3 } else { map.included <- FALSE map <- rep(0,ncol(data)-n.phe) nondatrow <- 2 # last non-data row } # replace empty cells with NA data <- sapply(data,function(a) { a[!is.na(a) & a==""] <- NA; a }) pheno <- as.data.frame(data[-(1:nondatrow),1:n.phe,drop=FALSE], stringsAsFactors=TRUE) colnames(pheno) <- data[1,1:n.phe] # pull apart phenotypes, genotypes and map mnames <- data[1,-(1:n.phe)] if(any(is.na(mnames))) stop("There are missing marker names. Check column(s) ",paste(which(is.na(mnames))+1+n.phe,collapse=","),sep="") chr <- data[2,-(1:n.phe)] if(any(is.na(chr))) stop("There are missing chromosome IDs. Check column(s) ",paste(which(is.na(chr))+1+n.phe,collapse=","),sep="") if(length(genotypes) > 0) { # look for strange entries in the genotype data temp <- unique(as.character(data[-(1:nondatrow),-(1:n.phe),drop=FALSE])) temp <- temp[!is.na(temp)] wh <- !(temp %in% genotypes) if(any(wh)) { warn <- "The following unexpected genotype codes were treated as missing.\n " ge <- paste("|", paste(temp[wh],collapse="|"),"|",sep="") warn <- paste(warn,ge,"\n",sep="") warning(warn) } # convert genotype data allgeno <- matrix(match(data[-(1:nondatrow),-(1:n.phe)],genotypes), ncol=ncol(data)-n.phe) } else allgeno <- matrix(as.numeric(data[-(1:nondatrow),-(1:n.phe)]), ncol=ncol(data)-n.phe) oldpheno <- pheno pheno <- data.frame(lapply(pheno, sw2numeric, dec=dec), stringsAsFactors=TRUE) # re-order the markers by chr and position # try to figure out the chr labels if(all(chr %in% c(1:999,"X","x"))) { # 1...19 + X tempchr <- chr tempchr[chr=="X" | chr=="x"] <- 1000 tempchr <- as.numeric(tempchr) if(map.included) neworder <- order(tempchr, map) else neworder <- order(tempchr) } else { # don't let it reorder the chromosomes tempchr <- factor(chr, levels=unique(chr)) if(map.included) neworder <- order(tempchr, map) else neworder <- order(tempchr) } chr <- chr[neworder] map <- map[neworder] allgeno <- allgeno[,neworder,drop=FALSE] mnames <- mnames[neworder] # fix up dummy map if(!map.included) { map <- split(rep(0,length(chr)),chr)[unique(chr)] map <- unlist(lapply(map,function(a) seq(0,length=length(a),by=5))) names(map) <- NULL } # fix up map information # number of chromosomes uchr <- unique(chr) n.chr <- length(uchr) geno <- vector("list",n.chr) names(geno) <- uchr min.mar <- 1 allautogeno <- NULL for(i in 1:n.chr) { # loop over chromosomes # create map temp.map <- map[chr==uchr[i]] names(temp.map) <- mnames[chr==uchr[i]] # pull out appropriate portion of genotype data data <- allgeno[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE] min.mar <- min.mar + length(temp.map) colnames(data) <- names(temp.map) geno[[i]] <- list(data=data,map=temp.map) if(uchr[i] == "X" || uchr[i] == "x") class(geno[[i]]) <- "X" else { class(geno[[i]]) <- "A" if(is.null(allautogeno)) allautogeno <- data else allautogeno <- cbind(allautogeno,data) } } if(is.null(allautogeno)) allautogeno <- allgeno # check that data dimensions match n.mar1 <- sapply(geno,function(a) ncol(a$data)) n.mar2 <- sapply(geno,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(geno,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { cat(n.ind1,n.ind2,"\n") stop("Number of individuals in genotypes and phenotypes do not match.") } if(any(n.mar1 != n.mar2)) { cat(n.mar1,n.mar2,"\n") stop("Numbers of markers in genotypes and marker names files do not match.") } # print some information about the amount of data read cat(" --Read the following data:\n") cat("\t",n.ind1," individuals\n") cat("\t",sum(n.mar1)," markers\n") cat("\t",n.phe," phenotypes\n") # determine map type: f2 or bc or 4way? if(all(is.na(allgeno))) warning("There is no genotype data!\n") if(all(is.na(allautogeno)) || max(allautogeno,na.rm=TRUE)<=2) type <- "bc" else if(max(allautogeno,na.rm=TRUE)<=5) type <- "f2" else type <- "4way" cross <- list(geno=geno,pheno=pheno) class(cross) <- c(type,"cross") # check that nothing is strange in the genotype data if(type=="f2") max.gen <- 5 else if(type=="bc") max.gen <- 2 else max.gen <- 14 # check that markers are in proper order # if not, fix up the order for(i in 1:n.chr) { if(any(diff(cross$geno[[i]]$map)<0)) { o <- order(cross$geno[[i]]$map) cross$geno[[i]]$map <- cross$geno[[i]]$map[o] cross$geno[[i]]$data <- cross$geno[[i]]$data[,o,drop=FALSE] } } # estimate genetic map if(estimate.map && !map.included) estmap <- TRUE else estmap <- FALSE # return cross + indicator of whether to run est.map list(cross,estmap) } # end of read.cross.csv.R qtl/R/ripple.R0000644000176200001440000003230713576241200012676 0ustar liggesusers###################################################################### # # ripple.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Oct, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: ripple, summary.ripple, print.summary.ripple # ripple.perm1, ripple.perm2, ripple.perm.sub # ###################################################################### ###################################################################### # # ripple: Check marker orders for a given chromosome, comparing all # possible permutations of a sliding window of markers # ###################################################################### ripple <- function(cross, chr, window=4, method=c("countxo","likelihood"), error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), maxit=4000, tol=1e-6, sex.sp=TRUE, verbose=TRUE, n.cluster=1) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # pull out relevant chromosome if(missing(chr)) { chr <- names(cross$geno)[1] warning("chr argument not provided; assuming you want chr ", chr) } else { if(length(chr) > 1) stop("ripple only works for one chromosome at a time.") if(!testchr(chr, names(cross$geno))) stop("Chr ", chr, " not found.") } cross <- subset(cross,chr=chr) chr.name <- names(cross$geno)[1] if(nmar(cross)[1] < 3) { warning("Less than three markers.") return(NULL) } # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } # make sure window is an integer >= 2 if(window < 2) { warning("The window argument must be > 1; using window=2.") window <- 2 } window <- round(window) method <- match.arg(method) map.function <- match.arg(map.function) # get marker orders to test n.mar <- totmar(cross) if(n.mar <= window) # look at all possible orders orders <- ripple.perm2(n.mar) else { temp <- ripple.perm1(window) n <- nrow(temp) orders <- cbind(temp,matrix(rep((window+1):n.mar,n), byrow=TRUE,ncol=n.mar-window)) for(i in 2:(n.mar-window+1)) { left <- matrix(rep(1:(i-1),n),byrow=TRUE,ncol=i-1) if(i < n.mar-window+1) right <- matrix(rep((i+window):n.mar,n),byrow=TRUE,ncol=n.mar-window-i+1) else right <- NULL orders <- rbind(orders,cbind(left,temp+i-1,right)) } # keep only distinct orders orders <- as.numeric(unlist(strsplit(unique(apply(orders,1,paste,collapse=":")),":"))) orders <- matrix(orders,ncol=n.mar,byrow=TRUE) } n.orders <- nrow(orders) # how often to print information about current order being considered if(n.orders > 49) print.by <- 10 else if(n.orders > 14) print.by <- 5 else print.by <- 2 if(method=="likelihood") { # calculate log likelihoods (and est'd chr length) for each marker order loglik <- 1:n.orders chrlen <- 1:n.orders # create temporary cross m <- seq(0,by=5,length=n.mar) temcross <- cross if(is.matrix(cross$geno[[1]]$map)) temcross$geno[[1]]$map <- rbind(m,m) else temcross$geno[[1]]$map <- m if(verbose) cat(" ", n.orders,"total orders\n") if(n.cluster > 1) { # parallelize if(n.orders <= n.cluster) n.cluster <- n.orders cl <- makeCluster(n.cluster) clusterStopped <- FALSE on.exit(if(!clusterStopped) stopCluster(cl)) if(verbose) cat(" Running in", n.cluster, "clusters\n") clusterEvalQ(cl, library(qtl, quietly=TRUE)) whclust <- sort(rep(1:n.cluster, ceiling(n.orders/n.cluster))[1:n.orders]) order.split <- vector("list", n.cluster) for(i in 1:n.cluster) order.split[[i]] <- orders[whclust==i,,drop=FALSE] result <- parLapply(cl, order.split, rippleSnowLik, cross=temcross, error.prob=error.prob, map.function=map.function, maxit=maxit, tol=tol, sex.sp=sex.sp) loglik <- unlist(lapply(result, function(a) a$loglik)) chrlen <- unlist(lapply(result, function(a) a$chrlen)) } else { for(i in 1:n.orders) { if(verbose && (i %/% print.by)*print.by == i) cat(" --Order", i, "\n") temcross$geno[[1]]$data <- cross$geno[[1]]$data[,orders[i,]] newmap <- est.map(temcross, error.prob=error.prob, map.function=map.function, m=0, p=0, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE) loglik[i] <- attr(newmap[[1]],"loglik") chrlen[i] <- diff(range(newmap[[1]])) } } # re-scale log likelihoods and convert to lods loglik <- (loglik - loglik[1])/log(10) # sort orders by lod o <- order(loglik[-1], decreasing=TRUE)+1 # create output orders <- cbind(orders,LOD=loglik,chrlen)[c(1,o),] } else { # count obligate crossovers for each order # which type of cross is this? type <- crosstype(cross) is.bcs <- type == "bcsft" if(is.bcs) is.bcs <- (attr(cross, "scheme")[2] == 0) if(type == "f2" || (type == "bcsft" && !is.bcs)) { if(chrtype(cross$geno[[1]]) == "A") # autosomal func <- "R_ripple_f2" else func <- "R_ripple_bc" # X chromsome } else if(type %in% c("bc", "riself", "risib", "dh", "haploid", "bcsft")) func <- "R_ripple_bc" else if(type == "4way") func <- "R_ripple_4way" else if(type=="ri4self" || type=="ri8self" || type=="ri4sib" || type=="ri8sib" || type=="bgmagic16") func <- "R_ripple_ril48" else stop("ripple not available for cross ", type) # data to be input genodat <- cross$geno[[1]]$data genodat[is.na(genodat)] <- 0 n.ind <- nind(cross) if(verbose) cat(" ", n.orders,"total orders\n") if(n.cluster > 1) { # parallelize if(n.orders <= n.cluster) n.cluster <- n.orders cl <- makeCluster(n.cluster) clusterStopped <- FALSE on.exit(if(!clusterStopped) stopCluster(cl)) if(verbose) cat(" Running in", n.cluster, "clusters\n") clusterEvalQ(cl, library(qtl, quietly=TRUE)) whclust <- sort(rep(1:n.cluster, ceiling(n.orders/n.cluster))[1:n.orders]) order.split <- vector("list", n.cluster) for(i in 1:n.cluster) order.split[[i]] <- orders[whclust==i,,drop=FALSE] oblxo <- unlist(parLapply(cl, order.split, rippleSnowCountxo, genodat=genodat, func=func)) stopCluster(cl) clusterStopped <- TRUE } else { z <- .C(func, as.integer(n.ind), as.integer(n.mar), as.integer(genodat), as.integer(n.orders), as.integer(orders-1), oblxo=as.integer(rep(0,n.orders)), as.integer(print.by), PACKAGE="qtl") oblxo <- z$oblxo } # sort orders by lod o <- order(oblxo[-1])+1 # create output orders <- cbind(orders,obligXO=oblxo)[c(1,o),] } rownames(orders) <- c("Initial", paste(1:(nrow(orders)-1))) class(orders) <- c("ripple","matrix") attr(orders,"chr") <- chr.name attr(orders,"window") <- window attr(orders,"error.prob") <- error.prob attr(orders,"method") <- method # make sure, for each order considered, that the proximal marker # (in the original order) is to the left of the distal marker # (in the original order) orders[,1:n.mar] <- t(apply(orders[,1:n.mar,drop=FALSE],1, function(a) { n <- length(a) if((1:n)[a==1] > (1:n)[a==n]) return(rev(a)) else return(a) })) orders } ###################################################################### # function for method="likelihood", for parallel processing (formerly with snow pkg) ###################################################################### rippleSnowLik <- function(orders, cross, error.prob, map.function, maxit, tol, sex.sp) { n.orders <- nrow(orders) temcross <- cross loglik <- chrlen <- rep(NA, n.orders) for(i in 1:n.orders) { temcross$geno[[1]]$data <- cross$geno[[1]]$data[,orders[i,]] newmap <- est.map(temcross, error.prob=error.prob, map.function=map.function, m=0, p=0, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE) loglik[i] <- attr(newmap[[1]],"loglik") chrlen[i] <- diff(range(newmap[[1]])) } list(loglik=loglik, chrlen=chrlen) } ###################################################################### # function for method="countxo", for parallel processing (formerly with snow pkg) ###################################################################### rippleSnowCountxo <- function(orders, genodat, func) { func <- func # this avoids a Note from R CMD check .C(func, as.integer(nrow(genodat)), as.integer(ncol(genodat)), as.integer(genodat), as.integer(nrow(orders)), as.integer(orders-1), oblxo=as.integer(rep(0, nrow(orders))), as.integer(0), PACKAGE="qtl")$oblxo } ###################################################################### # # summary.ripple: print top results from ripple(). We do this so # that we can return *all* results but allow easy # view of only the important ones # ###################################################################### summary.ripple <- function(object, lod.cutoff = -1, ...) { if(!inherits(object, "ripple")) stop("Input should have class \"ripple\".") n <- ncol(object) if("obligXO" %in% colnames(object)) # counts of crossovers o <- (object[-1,n] <= (object[1,n] - lod.cutoff*2)) else o <- (object[-1,n-1] >= lod.cutoff) # likelihood analysis if(!any(o)) object <- object[1:2,,drop=FALSE] else # make sure first row is included object <- object[c(TRUE,o),,drop=FALSE] rownames(object) <- c("Initial ", paste(1:(nrow(object)-1))) class(object) <- c("summary.ripple","matrix") object } ###################################################################### # # print.summary.ripple # ###################################################################### print.summary.ripple <- function(x, ...) { n <- ncol(x) x <- round(x,1) max.row <- 6 if(!("obligXO" %in% colnames(x))) colnames(x)[n-1] <- " LOD" class(x) <- "matrix" if(nrow(x) > max.row) { print(x[1:max.row,]) cat("... [", nrow(x)-max.row, " additional rows] ...\n") } else print(x) } ###################################################################### # # ripple.perm1: Utility function for ripple(). Returns all possible # permutations of {1, 2, ..., n} # ###################################################################### ripple.perm1 <- function(n) { if(n == 1) return(rbind(1)) o <- rbind(c(n-1,n),c(n,n-1)) if(n > 2) for(i in (n-2):1) o <- ripple.perm.sub(i,o) dimnames(o) <- NULL o } ###################################################################### # # ripple.perm2: Utility function for ripple(). Returns all possible # permutations of {1, 2, ..., n}, up to orientation of # the entire group # ###################################################################### ripple.perm2 <- function(n) { if(n < 3) return(rbind(1:n)) o <- rbind(c(n-2,n-1,n),c(n-1,n-2,n),c(n-1,n,n-2)) if(n > 3) for(i in (n-3):1) o <- ripple.perm.sub(i,o) dimnames(o) <- NULL o } ###################################################################### # # ripple.perm.sub: Subroutine used for ripple(). I'm too tired to # explain. # ###################################################################### ripple.perm.sub <- function(x,mat) { res <- cbind(x,mat) if(ncol(mat) > 1) { for(i in 1:ncol(mat)) res <- rbind(res,cbind(mat[,1:i],x,mat[,-(1:i)])) } res } # end of ripple.R qtl/R/read.cross.tidy.R0000644000176200001440000002046213576241200014415 0ustar liggesusers###################################################################### # # read.cross.tidy.R # # copyright (c) 2005-2019, Karl W Broman # last modified Dec, 2019 # first written Aug, 2014 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.tidy # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.tidy # # read data in comma-delimited format, with separate files for phenotype, # genotype, and map data # ###################################################################### read.cross.tidy <- function(dir, genfile, phefile, mapfile, na.strings=c("-","NA"), genotypes=c("A","H","B","D","C"), ...) { # create file names if(missing(genfile)) genfile <- "gen.csv" if(missing(phefile)) phefile <- "phe.csv" if(missing(mapfile)) mapfile <- "map.csv" if(!missing(dir) && dir != "") { genfile <- file.path(dir, genfile) phefile <- file.path(dir, phefile) mapfile <- file.path(dir, mapfile) } args <- list(...) if("" %in% na.strings) { na.strings <- na.strings[na.strings != ""] warning("Including \"\" in na.strings will cause problems; omitted.") } # if user wants to use comma for decimal point, we need dec <- ifelse("dec" %in% names(args), args[["dec"]], ".") # "sep" not in the "..." argument and so take sep="," sep <- ifelse("sep" %in% names(args), args[["sep"]], ",") # read the data files args <- c(args, list(sep = sep, na.strings = na.strings, row.names = 1, header = TRUE, stringsAsFactors = FALSE)) gen <- do.call("read.table", c(args, list(file = genfile))) pheno <- do.call("read.table", c(args, list(file = phefile))) map <- do.call("read.table", c(args, list(file = mapfile))) # Check individual IDs mp <- setdiff(colnames(gen), colnames(pheno)) if (length(mp) > 0) { warning(length(mp), " individuals with genotypes but no phenotypes\n ", paste(mp, collapse="|"), "\n") pheno[mp] <- NA } mg <- setdiff(colnames(pheno), colnames(gen)) if (length(mg) > 0) { warning(length(mg), " individuals with phenotypes but no genotypes\n ", paste(mg, collapse="|"), "\n") gen[mg] <- NA } # ensure individual order is consistent ids <- colnames(pheno) pheno <- pheno[, ids] gen <- gen[, ids] # Check markers genm <- rownames(gen) mapm <- rownames(map) mnames <- intersect(genm, mapm) mg <- setdiff(mapm, genm) if (length(mg) > 0) warning("Removing ", length(mg), " genotyped markers with missing positions\n") mm <- setdiff(genm, mapm) if (length(mm) > 0) warning("Removing", length(mm), " mapped markers with no genotypes\n") map[[2]] <- asnumericwithdec(map[[2]], dec) # replace empty cells with NA add_na <- function(x) replace(x, !is.na(x) & x == "", NA) pheno <- add_na(pheno) gen <- add_na(gen) # check chromosomes chr <- map[[1]] if(any(is.na(chr))) { stop("There are missing chromosome IDs. Check row(s) ", paste(which(is.na(chr)), collapse=","), sep = "") } # look for strange entries in the genotype data if(length(genotypes) > 0) { temp <- Filter(Negate(is.na), unique(unlist(gen))) wh <- !(temp %in% genotypes) if(any(wh)) { warn <- "The following unexpected genotype codes were treated as missing.\n " ge <- paste("|", paste(temp[wh],collapse="|"),"|",sep="") warn <- paste(warn,ge,"\n",sep="") warning(warn) } # convert genotype data gen <- as.matrix(gen) allgeno <- matrix(match(gen, genotypes), ncol = ncol(gen), dimnames = dimnames(gen)) } else { genotypes <- Filter(Negate(is.na), unique(unlist(gen))) gen <- as.data.frame(lapply(gen, factor, levels = genotypes), rownames(gen)) allgeno <- data.matrix(gen) } # convert phenotype data # pheno must be rotated to allow for numeric and factor variables pheno <- data.frame(t(pheno)) pheno <- data.frame(lapply(pheno, sw2numeric, dec = dec), row.names = NULL, stringsAsFactors = TRUE) # add id column if informative identifiers are provided default.ids <- make.names(seq_len(nrow(pheno))) if (!all(ids %in% default.ids)) pheno$id <- ids # re-order the markers by chr and position # try to figure out the chr labels if(all(chr %in% c(1:999,"X","x"))) { # 1...19 + X tempchr <- chr tempchr[chr=="X" | chr=="x"] <- 1000 tempchr <- as.numeric(tempchr) neworder <- order(tempchr, map[[2]]) } else { # prevent reordering of chromosomes tempchr <- factor(chr, levels=unique(chr)) neworder <- order(tempchr, map[[2]]) } chr <- chr[neworder] map <- map[neworder, ] allgeno <- allgeno[rownames(map), , drop = FALSE] mnames <- mnames[neworder] # fix up map information # number of chromosomes uchr <- unique(chr) n.chr <- length(uchr) geno <- vector("list", n.chr) names(geno) <- uchr min.mar <- 1 allautogeno <- NULL for(i in 1:n.chr) { # loop over chromosomes # create map temp.map <- map[[2]][chr==uchr[i]] names(temp.map) <- mnames[chr==uchr[i]] # pull out appropriate portion of genotype data data <- t(allgeno[names(temp.map), ]) # drop genotype rownames rownames(data) <- NULL geno[[i]] <- list(data=data, map=temp.map) if(uchr[i] == "X" || uchr[i] == "x") class(geno[[i]]) <- "X" else { class(geno[[i]]) <- "A" if(is.null(allautogeno)) allautogeno <- data else allautogeno <- cbind(allautogeno,data) } } if(is.null(allautogeno)) allautogeno <- allgeno # check that data dimensions match n.mar1 <- sapply(geno,function(a) ncol(a$data)) n.mar2 <- sapply(geno,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(geno,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { cat(n.ind1,n.ind2,"\n") stop("Number of individuals in genotypes and phenotypes do not match."); } if(any(n.mar1 != n.mar2)) { cat(n.mar1,n.mar2,"\n") stop("Numbers of markers in genotypes and marker names files do not match."); } # print some information about the amount of data read cat(" --Read the following data:\n"); cat("\t", n.ind1, " individuals\n"); cat("\t", sum(n.mar1), " markers\n"); cat("\t", n.phe, " phenotypes\n"); if(all(is.na(allgeno))) warning("There is no genotype data!\n") # determine map type: f2 or bc or 4way? if(all(is.na(allgeno))) warning("There is no genotype data!\n") if(all(is.na(allautogeno)) || max(allautogeno,na.rm=TRUE)<=2) type <- "bc" else if(max(allautogeno,na.rm=TRUE)<=5) type <- "f2" else type <- "4way" cross <- list(geno=geno,pheno=pheno) class(cross) <- c(type,"cross") # check that nothing is strange in the genotype data if(type=="f2") max.gen <- 5 else if(type=="bc") max.gen <- 2 else max.gen <- 14 # check that markers are in proper order # if not, fix up the order for(i in 1:n.chr) { if(any(diff(cross$geno[[i]]$map)<0)) { o <- order(cross$geno[[i]]$map) cross$geno[[i]]$map <- cross$geno[[i]]$map[o] cross$geno[[i]]$data <- cross$geno[[i]]$data[,o,drop=FALSE] } } # return cross + indicator of whether to run est.map list(cross,FALSE) } # end of read.cross.tidy.R qtl/R/addmarker.R0000644000176200001440000000560513576241200013336 0ustar liggesusers##################################################################### # # addmarker.R # # copyright (c) 2013-2019, Karl W Broman # last modified Dec, 2019 # first written May, 2013 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: addmarker.R ###################################################################### ###################################################################### # add a marker to a cross object # # cross: the cross object # genotypes: vector of numeric genotypes # markername: character string with the marker name # chr: character string with the chromosome ID # pos: position of the marker ###################################################################### addmarker <- function(cross, genotypes, markername, chr, pos) { if(!inherits(cross, "cross")) stop("cross must have class \"cross\"") chr <- matchchr(chr, names(cross$geno)) if(length(chr) != 1) stop("Only 1 chromosome should be specified.") if(length(pos) != 1) stop("length(pos) != 1: length(pos) = ", length(pos)) if(length(markername) != 1) stop("length(markername) != 1: length(markername) = ", length(markername)) if(length(genotypes) != nind(cross)) stop("length(genotypes) != nind(cross): length(genotypes) = ", length(genotypes), ", nind(cross) = ", nind(cross)) map <- cross$geno[[chr]]$map where <- sum(map < pos) g <- cross$geno[[chr]]$data if(where == 0) { map <- c("tmp"=pos, map) names(map)[1] <- markername cross$geno[[chr]]$map <- map g <- cbind("tmp"=genotypes, g) colnames(g)[1] <- markername cross$geno[[chr]]$data <- g } else if(where == length(map)) { map <- c(map,"tmp"=pos) names(map)[length(map)] <- markername cross$geno[[chr]]$map <- map g <- cbind(g, "tmp"=genotypes) colnames(g)[length(map)] <- markername cross$geno[[chr]]$data <- g } else { mnames <- names(map) map <- c(map[1:where], "tmp"=pos, map[-(1:where)]) names(map) <- c(mnames[1:where], markername, mnames[-(1:where)]) cross$geno[[chr]]$map <- map g <- cbind(g[,1:where, drop=FALSE], genotypes, g[,-(1:where), drop=FALSE]) colnames(g) <- names(map) cross$geno[[chr]]$data <- g } cross } # end of addmarker.R qtl/R/scantwo.R0000644000176200001440000023342613626261114013070 0ustar liggesusers###################################################################### # # scantwo.R # # copyright (c) 2001-2020, Karl W Broman and Hao Wu # last modified Feb, 2020 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Hao Wu (The Jackson Lab) wrote the initial code for the imputation # method. # # Part of the R/qtl package # Contains: scantwo, scantwo.perm, scantwo.perm.engine # ###################################################################### ###################################################################### # # scantwo: Do 2-dimensional genome scan with a two-QTL model, # calculating joint LOD scores and LOD scores testing # epistasis. # ###################################################################### scantwo <- function(cross, chr, pheno.col=1, model=c("normal","binary"), method=c("em","imp","hk","mr","mr-imp","mr-argmax"), addcovar=NULL, intcovar=NULL, weights=NULL, use=c("all.obs", "complete.obs"), incl.markers=FALSE, clean.output=FALSE, clean.nmar=1, clean.distance=0, maxit=4000, tol=1e-4, verbose=TRUE, n.perm, perm.Xsp=FALSE, perm.strata=NULL, assumeCondIndep=FALSE, batchsize=250, n.cluster=1) { if(batchsize < 1) stop("batchsize must be >= 1.") if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") method <- match.arg(method) model <- match.arg(model) use <- match.arg(use) # pull out chromosomes to be scanned if(missing(chr)) chr1 <- chr2 <- chr <- names(cross$geno) else { thechr <- names(cross$geno) if(is.list(chr)) { # special case: do just specific pairs (each of chr1 vs each of chr2, except when chr2 < chr1) chr1 <- matchchr(chr[[1]], thechr) chr2 <- matchchr(chr[[2]], thechr) } else chr1 <- chr2 <- matchchr(chr, thechr) } cross <- subset(cross, unique(c(chr1, chr2))) thechr <- names(cross$geno) nchr1 <- match(chr1, thechr) nchr2 <- match(chr2, thechr) if(!any(sapply(nchr1, function(a,b) any(a <= b), nchr2))) stop("Need some of first chr to be <= some of second chr") if(missing(n.perm)) n.perm <- 0 if((method=="hk" || method=="em") && !assumeCondIndep) { # if reduce2grid was used, for assumeCondIndep # if reduced2grid, force assumeCondIndep=TRUE reduced2grid <- attr(cross$geno[[1]]$prob, "reduced2grid") if(!is.null(reduced2grid) && reduced2grid) { assumeCondIndep <- TRUE warning("Using assumeCondIndep=TRUE, since probabilities reduced to grid") } } # in RIL, treat X chromomse like an autosome chr_type <- sapply(cross$geno, chrtype) crosstype <- crosstype(cross) if(any(chr_type=="X") && (crosstype == "risib" || crosstype == "riself")) for(i in which(chr_type=="X")) class(cross$geno[[i]]) <- "A" # X-chr-specific perms (actually A:A, A:X, and X:X specific) if(perm.Xsp && n.perm > 0 && !(all(chr_type=="X") || all(chr_type=="A"))) { # no need for x-chr-specific perms if(length(chr1) != length(chr2) || any(chr1 != chr2)) stop("With perm.Xsp=TRUE, chr can't be a list") chr.names <- chrnames(cross) chrL <- sapply(cross$geno, function(a) diff(range(a$map))) AL <- sum(chrL[chr_type=="A"]) XL <- sum(chrL[chr_type=="X"]) AAL <- AL*AL/2 XXL <- XL*XL/2 AXL <- AL*XL n.permAA <- n.perm n.permXX <- ceiling(n.perm * AAL/XXL) n.permAX <- ceiling(n.perm * AAL/AXL) # names of autosomes and X chr Achr <- chr.names[chr_type=="A"] Xchr <- chr.names[chr_type=="X"] # X chr covariates Xnull <- scanoneXnull(crosstype(cross), getsex(cross), attributes(cross)) Xcovar <- Xnull$sexpgmcovar if(verbose) message("Running ", n.permAA, " A:A permutations") AAresult <- scantwo(cross, chr=Achr, pheno.col=pheno.col, model=model, method=method, addcovar=cbind(addcovar, Xcovar), intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.permAA, perm.Xsp=FALSE, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=n.cluster) if(verbose) message("Running ", n.permXX, " X:X permutations") XXresult <- scantwo(cross, chr=Xchr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.permXX, perm.Xsp=FALSE, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=n.cluster) if(verbose) message("Running ", n.permAX, " A:X permutations") AXresult <- scantwo(cross, chr=list(Achr, Xchr), pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.permAX, perm.Xsp=FALSE, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=n.cluster) result <- list(AA=AAresult, AX=AXresult, XX=XXresult) attr(result, "L") <- c(A=AL, X=XL) attr(result, "LL") <- c(AA=AAL, AX=AXL, XX=XXL) names(chr_type) <- chr.names attr(result, "chrtype") <- chr_type class(result) <- c("scantwoperm", "list") return(result) } if(!missing(n.perm) && n.perm > 0 && n.cluster > 1) { cat(" -Running permutations via a cluster of", n.cluster, "nodes.\n") updateParallelRNG(n.cluster) n.perm <- ceiling(n.perm/n.cluster) scantwoPermInParallel <- function(n.perm, cross, chr, pheno.col, model, method, addcovar, intcovar, weights, incl.markers, clean.output, clean.nmar, clean.distance, maxit, tol, perm.strata, assumeCondIndep, batchsize) scantwo(cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=0, verbose=FALSE, n.perm=n.perm) if(Sys.info()[1] == "Windows") { # Windows doesn't support mclapply, but it's faster if available cl <- makeCluster(n.cluster) on.exit(stopCluster(cl)) operm <- clusterApply(cl, rep(n.perm, n.cluster), scantwoPermInParallel, cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize) } else { operm <- mclapply(rep(n.perm, n.cluster), scantwoPermInParallel, cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, mc.cores=n.cluster) } for(j in 2:length(operm)) operm[[1]] <- c(operm[[1]], operm[[j]]) return(operm[[1]]) } # check perm.strat if(!missing(perm.strata) && !is.null(perm.strata)) { if(length(perm.strata) != nind(cross)) stop("perm.strata, if given, must have length = nind(cross) [", nind(cross), "]") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } origcross <- cross fullmap <- pull.map(cross) if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") # if stepwidth="variable" or stepwidth=="max" when calling calc.genoprob or sim.geno, # we force incl.markers=TRUE; I assume it is the same for all chromosomes stepwidth.var <- FALSE if(method=="em" || method=="hk") { if("stepwidth" %in% names(attributes(cross$geno[[1]]$prob)) && attr(cross$geno[[1]]$prob, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } } else if(method=="imp") { if("stepwidth" %in% names(attributes(cross$geno[[1]]$draws)) && attr(cross$geno[[1]]$draws, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } } if(length(pheno.col)==1 && n.perm>=0) use <- "complete.obs" if(n.perm >= 0) { # not in the midst of a permutation test # If use="all.obs", check whether there are individuals missing some # phenotypes but not others. If not, act like "complete.obs". if(use=="all.obs" && length(pheno.col) > 1) { n.phe <- length(pheno.col) temp <- apply(cross$pheno[,pheno.col], 1, function(a) sum(is.na(a))) if(all(temp==0 | temp==n.phe)) use <- "complete.obs" } # If use="complete.obs", drop individuals with any missing phenotypes if(use=="complete.obs") { temp <- checkcovar(cross, pheno.col, addcovar, intcovar, perm.strata, ind.noqtl=NULL, weights, TRUE) cross <- temp[[1]] pheno <- temp[[2]] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] weights <- temp[[9]] } } # use all observations; not in a permutation test; different phenotypes have different sets of missing values # -> want to do in batches, but need to define batches by the pattern of missing data if(n.perm <= 0 && use=="all.obs" && length(pheno.col) > 1 && (method=="hk" || method=="imp")) { # drop individuals with missing covariates cross$pheno <- cbind(cross$pheno, rep(1, nind(cross))) temp <- checkcovar(cross, nphe(cross), addcovar, intcovar, perm.strata, ind.noqtl=NULL, weights, TRUE) cross <- temp[[1]] pheno <- cross$pheno[,pheno.col, drop=FALSE] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] weights <- temp[[9]] # determine the batches (defined by the pattern of missing data) patterns <- apply(pheno, 2, function(a) paste(!is.na(a), collapse=":")) upat <- unique(patterns) m <- match(patterns, upat) batches <- vector("list", length(upat)) upat <- lapply(strsplit(upat, ":"), function(a) as.logical(a)) for(i in seq(along=batches)) batches[[i]] <- pheno.col[m==i] # run scanone for one batch at a time out <- NULL for(i in seq(along=batches)) { if(!is.null(addcovar)) { if(!is.matrix(addcovar)) addcovar <- as.matrix(addcovar) tempac <- addcovar[upat[[i]],,drop=FALSE] } else tempac <- addcovar if(!is.null(intcovar)) { if(!is.matrix(intcovar)) intcovar <- as.matrix(intcovar) tempic <- intcovar[upat[[i]],,drop=FALSE] } else tempic <- intcovar temp <- scantwo(subset(cross, ind=upat[[i]]), chr=chr, pheno.col=batches[[i]], model=model, method=method, addcovar=tempac, intcovar=tempic, weights=weights[upat[[i]]], use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.perm, perm.strata=perm.strata[upat[[i]]], assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=n.cluster) if(is.null(out)) out <- temp else out <- cbind(out, temp) } # reorder LOD score columns and make sure that the names are correct dimnames(out$lod) <- list(NULL, NULL, colnames(cross$pheno)[unlist(batches)]) out$lod <- out$lod[,,colnames(cross$pheno)[pheno.col]] dimnames(out$lod)[[3]] <- colnames(cross$pheno)[pheno.col] attr(out,"phenotypes") <- colnames(cross$pheno)[pheno.col] return(out) } # multiple phenotype for methods other than imp and hk if(length(pheno.col)>1 && n.perm <= 0 && (model != "normal" || (method!="imp" && method != "hk"))) { n.phe <- length(pheno.col) if(verbose) cat(" -Phenotype 1\n") output <- scantwo(cross, pheno.col=pheno.col[1], model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.perm, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=0) temp <- array(dim=c(nrow(output$lod), ncol(output$lod), n.phe)) temp[,,1] <- output$lod output$lod <- temp for(i in 2:n.phe) { if(verbose) cat(" -Phenotype ", i, "\n") temp <- scantwo(cross, pheno.col=pheno.col[i], model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.perm, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=0) output$lod[,,i] <- temp$lod if(!is.null(output$scanoneX)) output$scanoneX <- cbind(output$scanoneX, temp$scanoneX) } attr(output,"fullmap") <- fullmap attr(output,"phenotypes") <- colnames(cross$pheno)[pheno.col] names(output$map)[2] <- "pos" dimnames(output$lod) <- list(NULL, NULL, colnames(cross$pheno)[pheno.col]) return(output) } # if n.perm specified, do a permutation test if(n.perm>0) { return(scantwo.perm(cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, n.perm=n.perm, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, chr=chr)) } if(n.perm < 0) { # in the midst of permutations if(use=="all.obs") { temp <- checkcovar(cross, pheno.col, addcovar, intcovar, perm.strata, ind.noqtl=NULL, weights, n.perm==-1) cross <- temp[[1]] pheno <- temp[[2]] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] weights <- temp[[9]] } else { pheno <- as.matrix(cross$pheno[,pheno.col]) if(is.null(addcovar)) n.addcovar <- 0 else n.addcovar <- ncol(addcovar) if(is.null(intcovar)) n.intcovar <- 0 else n.intcovar <- ncol(intcovar) } } n.chr <- nchr(cross) n.ind <- nind(cross) n.phe <- length(pheno.col) type <- crosstype(cross) chr_type <- sapply(cross$geno,chrtype) is.bcs <- FALSE if(type == "bcsft") { cross.scheme <- attr(cross, "scheme") is.bcs <- (cross.scheme[2] == 0) } if(any(chr_type=="X")) { sexpgm <- getsex(cross) addcovarX <- revisecovar(sexpgm,addcovar) if(!is.null(addcovar) && (nd <- attr(addcovarX, "n.dropped")) > 0 && n.perm > -2) warning("Dropped ", nd, " additive covariates on X chromosome.") if(length(addcovarX)==0) { n.acX <- 0 addcovarX <- NULL } else n.acX <- ncol(addcovarX) intcovarX <- revisecovar(sexpgm,intcovar) if(!is.null(intcovar) && (nd <- attr(intcovarX, "n.dropped")) > 0 && n.perm > -2) warning("Dropped ", nd, " interactive covariates on X chromosome.") if(length(intcovarX)==0) { n.icX <- 0 intcovarX <- NULL } else n.icX <- ncol(intcovarX) } if(model=="binary") { if(method != "em" && method != "hk") { method <- "em" if(n.perm > -2) warning("Only EM algorithm and Haley-Knott regression coded for binary traits; using EM") } if(!is.null(weights)) { weights <- NULL if(n.perm > -2) warning("weights ignored for binary traits.") } u <- unique(pheno) if(any(u!=0 & u!=1)) stop("Phenotypes must be either 0 or 1.") } if(n.perm == 0) { # not in the midst of permutations if(method=="mr-argmax") cross <- fill.geno(cross,method="argmax") if(method=="mr-imp") cross <- fill.geno(cross,method="imp") } # weights of individuals if(model == "normal") { if(is.null(weights)) weights <- rep(1, nind(cross)) if(length(weights) != nind(cross)) stop("weights should either be NULL or a vector of length n.ind") if(any(weights <= 0)) stop("weights should be entirely positive") weights <- sqrt(weights) } if(verbose) cat(" --Running scanone\n") temp <- scanone(cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, maxit=maxit, tol=tol, verbose=FALSE) out.scanone <- temp[,-(1:2),drop=FALSE] if(verbose) cat(" --Running scantwo\n") if(method=="mr" || method=="mr-imp" || method=="mr-argmax") { # marker regression # number of genotypes on each chromosome, # combine the genetic maps for all chromosomes map <- unlist(pull.map(cross)) names(map) <- unlist(lapply(pull.map(cross),names)) n.pos <- nmar(cross) gmap <- data.frame(chr=rep(names(cross$geno),n.pos), pos=map, eq.spacing=rep(1,sum(n.pos)), xchr=rep(sapply(cross$geno,chrtype)=="X",nmar(cross)), stringsAsFactors=TRUE) # number of possible genotypes for each chromosome n.gen <- 1:n.chr for(i in 1:n.chr) { gen.names <- getgenonames(type, chr_type[i], "full", sexpgm, attributes(cross)) n.gen[i] <- length(gen.names) } } # end of if(method=="mr") else { # all methods except "mr" # check for genotype probabilities or simulated genotypes steps <- rep(0,n.chr) # step length on each chromosome if(method=="imp") { for(i in 1:n.chr) { if(!("draws" %in% names(cross$geno[[i]]))) { # need to run sim.geno if(n.perm > -2) warning("First running sim.geno.") cross <- sim.geno(cross) } steps[i] <- attr(cross$geno[[i]]$draws,"step") } # make sure all chromosomes have the same number of imputations n.draws <- sapply(cross$geno, function(a) dim(a$draws)[3]) if(length(unique(n.draws)) > 1) { if(n.perm > -2) warning("Re-running sim.geno to have a fixed number of imputations.") cross <- sim.geno(cross, n.draws=max(n.draws), step=attr(cross$geno[[1]]$draws,"step"), off.end=attr(cross$geno[[1]]$draws,"off.end")) } n.draws <- max(n.draws) } else { # H-K or EM for(i in 1:n.chr) { if(!("prob" %in% names(cross$geno[[i]]))) { # need to run calc.genoprob if(n.perm > -2) warning("First running calc.genoprob.") cross <- calc.genoprob(cross) } steps[i] <- attr(cross$geno[[i]]$prob,"step") } } # number of genotypes on each chromosome, # construct the genetic map for all chromosomes # and possibly drop marker positions gmap <- NULL n.pos <- n.gen <- rep(0,n.chr) keep.pos <- vector("list",n.chr) some.dropped <- rep(FALSE,n.chr) for(i in 1:n.chr) { gen.names <- getgenonames(type, chr_type[i], "full", sexpgm, attributes(cross)) n.gen[i] <- length(gen.names) # construct the genetic map for this chromesome if(method=="imp") { if("map" %in% names(attributes(cross$geno[[i]]$draws))) map <- attr(cross$geno[[i]]$draws,"map") else { stp <- attr(cross$geno[[i]]$draws, "step") oe <- attr(cross$geno[[i]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$draws))) stpw <- attr(cross$geno[[i]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } } else { if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } } if(is.matrix(map)) map <- map[1,] # in case of sex-specific map w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") map <- cbind(chr=factor(rep(names(cross$geno)[i],length(map)),levels=names(cross$geno)), pos=as.data.frame(as.numeric(map), stringsAsFactors=TRUE) ) rownames(map) <- w # equally spaced positions if(steps[i]==0 || stepwidth.var) # just use markers eq.sp.pos <- rep(1,nrow(map)) else { eq.sp.pos <- seq(min(map[,2]),max(map[,2]),by=steps[i]) wh.eq.sp <- match(eq.sp.pos,map[,2]) if(any(is.na(wh.eq.sp))) { # this shouldn't happen if(n.perm > -2) warning("Possible error in determining the equally spaced positions.") wh.eq.sp <- wh.eq.sp[!is.na(wh.eq.sp)] } eq.sp.pos <- rep(0,nrow(map)) eq.sp.pos[wh.eq.sp] <- 1 } if(!incl.markers && any(eq.sp.pos==0)) { keep.pos[[i]] <- (seq(along=eq.sp.pos))[eq.sp.pos==1] map <- map[eq.sp.pos==1,] eq.sp.pos <- eq.sp.pos[eq.sp.pos==1] some.dropped[i] <- TRUE # indicates some positions were dropped } else keep.pos[[i]] <- seq(along=eq.sp.pos) gmap <- rbind(gmap, cbind(map,eq.spacing=eq.sp.pos, xchr=(chrtype(cross$geno[[i]])=="X"))) n.pos[i] <- length(keep.pos[[i]]) # Revise X chromosome genotype probabilities or imputations if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) { if(method=="imp") cross$geno[[i]]$draws <- reviseXdata(type, "full", sexpgm, draws=cross$geno[[i]]$draws, cross.attr=attributes(cross)) else if(method=="hk" || method=="em") { oldXchr <- subset(cross, chr=thechr[i]) cross$geno[[i]]$prob <- reviseXdata(type, "full", sexpgm, prob=cross$geno[[i]]$prob, cross.attr=attributes(cross)) } else cross$geno[[i]]$data <- reviseXdata(type, "full", sexpgm, geno=cross$geno[[i]]$data, cross.attr=attributes(cross)) } } # end loop over chromosomes } # end of if/else for method="mr" vs other # columns in result matrix for each chromosome wh.col <- vector("list",n.chr) first.pos <- cumsum(c(1,n.pos)) for(i in 1:n.chr) wh.col[[i]] <- seq(first.pos[i],by=1,length=n.pos[i]) # initialize the results matrix if(n.phe > 1) results <- array(NA,dim=c(sum(n.pos),sum(n.pos), n.phe)) else results <- matrix(NA,sum(n.pos),sum(n.pos)) # do the 2-dimensional genome scan do.nllik0 <- TRUE for(i in nchr1) { # loop over the 1st chromosome for(j in nchr2) { # loop over the 2nd chromosome if(j < i) next if(chr_type[i]=="X" || chr_type[j]=="X") { ac <- addcovarX n.ac <- n.acX ic <- intcovarX n.ic <- n.icX } else { ac <- addcovar n.ac <- n.addcovar ic <- intcovar n.ic <- n.intcovar } if(i==j && chr_type[i]=="X") { col2drop <- dropXcol(type, sexpgm, attributes(cross)) n.col2drop <- sum(col2drop) n.col2drop.addmodel <- sum(col2drop[1:(2*n.gen[i]-1)]) } else { col2drop <- rep(0,n.gen[i]*n.gen[j]) n.col2drop <- 0 } # print the current working pair if(verbose) cat(" (", names(cross$geno)[i], ",", names(cross$geno)[j],")\n",sep="") if(method=="imp") { if(n.phe > batchsize) { firstcol <- 1 z <- NULL while(firstcol <= n.phe) { thiscol <- firstcol + 0:(batchsize-1) thiscol <- thiscol[thiscol <= n.phe] thisz <- .C("R_scantwo_imp", as.integer(n.ind), as.integer(i==j), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.integer(n.draws), as.integer(cross$geno[[i]]$draws[,keep.pos[[i]],]), as.integer(cross$geno[[j]]$draws[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno[,thiscol]), as.integer(length(thiscol)), as.double(weights), result=as.double(rep(0,2*n.pos[i]*n.pos[j]*length(thiscol))), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") firstcol <- firstcol + batchsize if(is.null(z)) z <- array(NA, dim=c(n.pos[i], n.pos[j], 2*n.phe)) thisz$result <- array(thisz$result, dim=c(n.pos[i], n.pos[j], 2*length(thiscol))) z[,,thiscol] <- thisz$result[,,1:length(thiscol)] z[,,n.phe+thiscol] <- thisz$result[,,length(thiscol)+1:length(thiscol)] } } else { z <- .C("R_scantwo_imp", as.integer(n.ind), as.integer(i==j), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.integer(n.draws), as.integer(cross$geno[[i]]$draws[,keep.pos[[i]],]), as.integer(cross$geno[[j]]$draws[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.integer(n.phe), as.double(weights), result=as.double(rep(0,2*n.pos[i]*n.pos[j]*n.phe)), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") z <- array(z$result,dim=c(n.pos[i], n.pos[j], 2*n.phe)) # rearrange the result } # do this just once: do null model and get neg log10 likelihood if(do.nllik0) { do.nllik0 <- FALSE if(n.ac > 0) resid0 <- lm(pheno ~ ac, weights=weights^2)$resid else resid0 <- lm(pheno ~ 1, weights=weights^2)$resid sig0 <- sqrt(sum((resid0*weights)^2)/n.ind) nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10) } # update the final result matrix if(i == j) { # on same chromosome if(n.phe > 1) results[wh.col[[i]],wh.col[[j]],] <- z[,,1:n.phe] else results[wh.col[[i]],wh.col[[j]]] <- z[,,1] } else { # on different chromosomes if(n.phe > 1) { # full lod results[wh.col[[i]],wh.col[[j]],] <- z[,,1:n.phe] # epistasis lod - need to reshape the matrix results[wh.col[[j]],wh.col[[i]],] <- array(z[,,1:n.phe+n.phe], c(n.pos[j],n.pos[i], n.phe)) } else { # only one phenotype, result is a matrix # full lod results[wh.col[[i]],wh.col[[j]]] <- z[,,1] # epistasis - need to reshape the matrix results[wh.col[[j]],wh.col[[i]]] <- matrix(z[,,2],n.pos[j],n.pos[i]) } } } else if(model=="normal" && (method=="hk" || method=="em")) { if(do.nllik0) { # first time! do null model and get neg log10 likelihood do.nllik0 <- FALSE if(n.ac > 0) resid0 <- lm(pheno ~ ac, weights=weights^2)$resid else resid0 <- lm(pheno ~ 1, weights=weights^2)$resid if(method=="hk") { if(n.phe == 1) nllik0 <- (n.ind/2)*log10(sum((resid0*weights)^2)) else # multiple phenotypes nllik0 <- apply(resid0, 2, function(x) (n.ind/2)*log10(sum((x*weights)^2))) } else { sig0 <- sqrt(sum((resid0*weights)^2)/n.ind) nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10) } } if(i==j) { # same chromosome if(verbose>1) cat(" --Calculating joint probs.\n") if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) { # calculate joint genotype probabilities for all pairs of positions stp <- attr(oldXchr$geno[[1]]$prob, "step") oe <- attr(oldXchr$geno[[1]]$prob, "off.end") err <- attr(oldXchr$geno[[1]]$prob, "error.prob") mf <- attr(oldXchr$geno[[1]]$prob, "map.function") if("stepwidth" %in% names(attributes(oldXchr$geno[[1]]$prob))) stpw <- attr(oldXchr$geno[[1]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(oldXchr$geno[[1]]$prob))) tmap <- attr(oldXchr$geno[[1]]$prob,"map") else tmap <- create.map(oldXchr$geno[[1]]$map, stp, oe, stpw) temp <- calc.pairprob(oldXchr,stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } else { # calculate joint genotype probabilities for all pairs of positions stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") err <- attr(cross$geno[[i]]$prob, "error.prob") mf <- attr(cross$geno[[i]]$prob, "map.function") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(cross$geno[[i]]$prob))) tmap <- attr(cross$geno[[i]]$prob,"map") else tmap <- create.map(cross$geno[[i]]$map, stp, oe, stpw) temp <- calc.pairprob(subset(cross,chr=thechr[i]),stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } # pull out positions from genotype probs if(some.dropped[i]) { # figure out pos'ns corresponding to columns of temp nc <- ncol(cross$geno[[i]]$prob) ind <- matrix(rep(1:nc,nc),ncol=nc) w <- lower.tri(ind) ind <- cbind(first=t(ind)[w],second=ind[w]) # which part to keep keep <- apply(ind,1,function(a,b) all(a %in% b), keep.pos[[i]]) temp <- temp[,keep,,] } # revise pair probilities for X chromosome if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) temp <- reviseXdata(type, "full", sexpgm, pairprob=temp, cross.attr=attributes(cross)) if(verbose>1) cat(" --Done.\n") if(method=="hk") { if(n.phe > batchsize) { firstcol <- 1 z <- NULL while(firstcol <= n.phe) { thiscol <- firstcol + 0:(batchsize-1) thiscol <- thiscol[thiscol <= n.phe] thisz <- .C("R_scantwo_1chr_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(temp), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno[,thiscol]), as.integer(length(thiscol)), as.double(weights), result=as.double(rep(0,n.pos[i]^2*length(thiscol))), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") firstcol <- firstcol + batchsize if(is.null(z)) { z <- thisz z$result <- array(NA, dim=c(n.pos[i], n.pos[i], n.phe)) } z$result[,,thiscol] <- array(thisz$result, dim=c(n.pos[i], n.pos[i], length(thiscol))) } } else { z <- .C("R_scantwo_1chr_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(temp), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.integer(n.phe), as.double(weights), result=as.double(rep(0,n.pos[i]^2*n.phe)), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") } ## fill results matrix if(n.phe == 1) results[wh.col[[i]],wh.col[[i]]] <- matrix(z$result,ncol=n.pos[i]) else # multiple phenotypes results[wh.col[[i]],wh.col[[i]],] <- array(z$result,c(n.pos[i],n.pos[i], n.phe)) z <- 0 } else { z <- .C("R_scantwo_1chr_em", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(temp), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.double(weights), result=as.double(rep(0,n.pos[i]^2)), as.integer(maxit), as.double(tol), as.integer(verbose), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") # re-organize results results[wh.col[[i]],wh.col[[i]]] <- matrix(z$result,ncol=n.pos[i]) } z <- 0 temp <- 0 # remove the joint genotype probabilities } # end same chromosome else { if(method=="hk") { if(n.phe > batchsize) { firstcol <- 1 z <- NULL while(firstcol <= n.phe) { thiscol <- firstcol + 0:(batchsize-1) thiscol <- thiscol[thiscol <= n.phe] thisz <- .C("R_scantwo_2chr_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno[,thiscol]), as.integer(length(thiscol)), as.double(weights), full=as.double(rep(0,n.pos[i]*n.pos[j]*length(thiscol))), int=as.double(rep(0,n.pos[i]*n.pos[j]*length(thiscol))), PACKAGE="qtl") firstcol <- firstcol + batchsize if(is.null(z)) { z <- thisz z$full <- z$int <- array(NA, dim=c(n.pos[j], n.pos[i], n.phe)) } z$full[,,thiscol] <- array(thisz$full, dim=c(n.pos[j], n.pos[i], length(thiscol))) z$int[,,thiscol] <- array(thisz$int, dim=c(n.pos[j], n.pos[i], length(thiscol))) } } else { z <- .C("R_scantwo_2chr_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.integer(n.phe), as.double(weights), full=as.double(rep(0,n.pos[i]*n.pos[j]*n.phe)), int=as.double(rep(0,n.pos[i]*n.pos[j]*n.phe)), PACKAGE="qtl") } ## reorgnize results if(n.phe == 1) { results[wh.col[[j]],wh.col[[i]]] <- matrix(z$full,ncol=n.pos[j]) results[wh.col[[i]],wh.col[[j]]] <- matrix(z$int,ncol=n.pos[j]) } else { # multiple phenotypes results[wh.col[[j]],wh.col[[i]],] <- array(z$full,c(n.pos[j], n.pos[i], n.phe)) results[wh.col[[i]],wh.col[[j]],] <- array(z$int,c(n.pos[j], n.pos[i], n.phe)) } z <- 0 } else { z <- .C("R_scantwo_2chr_em", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.double(weights), full=as.double(rep(0,n.pos[i]*n.pos[j])), int=as.double(rep(0,n.pos[i]*n.pos[j])), as.integer(maxit), as.double(tol), as.integer(verbose), PACKAGE="qtl") results[wh.col[[j]],wh.col[[i]]] <- t(matrix(z$full,ncol=n.pos[j])) results[wh.col[[i]],wh.col[[j]]] <- matrix(z$int,ncol=n.pos[j]) z <- 0 } } # end different chromosome } else if(model=="binary") { if(do.nllik0) { # first time! do null model and get neg log10 likelihood do.nllik0 <- FALSE if(n.ac > 0) nullfit <- glm(pheno ~ ac, family=binomial(link="logit")) else nullfit <- glm(pheno ~ 1, family=binomial(link="logit")) fitted <- nullfit$fitted nullcoef <- nullfit$coef nllik0 <- -sum(pheno*log10(fitted) + (1-pheno)*log10(1-fitted)) if(verbose > 1) cat("null log lik: ", nllik0, "\n") } if(i==j) { # same chromosome start <- c(rep(nullcoef[1],n.gen[i]),rep(0,n.gen[i]-1), nullcoef[-1],rep(0,n.gen[i]*n.gen[i]+ (n.gen[i]*(n.gen[i]-1)*n.ic))) if(n.col2drop) start <- c(start[!col2drop], rep(0,sum(col2drop))) if(verbose>1) cat(" --Calculating joint probs.\n") if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) { # calculate joint genotype probabilities for all pairs of positions stp <- attr(oldXchr$geno[[1]]$prob, "step") oe <- attr(oldXchr$geno[[1]]$prob, "off.end") err <- attr(oldXchr$geno[[1]]$prob, "error.prob") mf <- attr(oldXchr$geno[[1]]$prob, "map.function") if("stepwidth" %in% names(attributes(oldXchr$geno[[1]]$prob))) stpw <- attr(oldXchr$geno[[1]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(oldXchr$geno[[1]]$prob))) tmap <- attr(oldXchr$geno[[1]]$prob,"map") else tmap <- create.map(oldXchr$geno[[1]]$map, stp, oe, stpw) temp <- calc.pairprob(oldXchr,stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } else { # calculate joint genotype probabilities for all pairs of positions stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") err <- attr(cross$geno[[i]]$prob, "error.prob") mf <- attr(cross$geno[[i]]$prob, "map.function") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" if("map" %in% names(attributes(cross$geno[[i]]$prob))) tmap <- attr(cross$geno[[i]]$prob,"map") else tmap <- create.map(cross$geno[[i]]$map, stp, oe, stpw) temp <- calc.pairprob(subset(cross,chr=thechr[i]),stp,oe,err,mf,tmap, assumeCondIndep=assumeCondIndep) } # pull out positions from genotype probs if(some.dropped[i]) { # figure out pos'ns corresponding to columns of temp nc <- ncol(cross$geno[[i]]$prob) ind <- matrix(rep(1:nc,nc),ncol=nc) w <- lower.tri(ind) ind <- cbind(first=t(ind)[w],second=ind[w]) # which part to keep keep <- apply(ind,1,function(a,b) all(a %in% b), keep.pos[[i]]) temp <- temp[,keep,,] } # revise pair probilities for X chromosome if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) temp <- reviseXdata(type, "full", sexpgm, pairprob=temp, cross.attr=attributes(cross)) if(verbose>1) cat(" --Done.\n") if(method=="em") z <- .C("R_scantwo_1chr_binary_em", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(temp), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.integer(pheno), as.double(start), result=as.double(rep(0,n.pos[i]^2)), as.integer(maxit), as.double(tol), as.integer(verbose), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") else # h-k regression z <- .C("R_scantwo_1chr_binary_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(temp), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), result=as.double(rep(0,n.pos[i]^2)), as.integer(n.col2drop), as.integer(col2drop), as.double(tol), as.integer(maxit), as.integer(verbose), PACKAGE="qtl") # re-organize results results[wh.col[[i]],wh.col[[i]]] <- matrix(z$result,ncol=n.pos[i]) z <- 0 temp <- 0 # remove the joint genotype probabilities } # end same chromosome else { start <- c(rep(nullcoef[1],n.gen[i]),rep(0,n.gen[j]-1), nullcoef[-1],rep(0,n.gen[i]*n.gen[j]+ (n.gen[i]*(n.gen[j]-1)*n.intcovar))); if(method=="em") z <- .C("R_scantwo_2chr_binary_em", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.integer(pheno), as.double(start), full=as.double(rep(0,n.pos[i]*n.pos[j])), int=as.double(rep(0,n.pos[i]*n.pos[j])), as.integer(maxit), as.double(tol), as.integer(verbose), PACKAGE="qtl") else # h-k regression z <- .C("R_scantwo_2chr_binary_hk", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.double(cross$geno[[i]]$prob[,keep.pos[[i]],]), as.double(cross$geno[[j]]$prob[,keep.pos[[j]],]), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), full=as.double(rep(0,n.pos[i]*n.pos[j])), int=as.double(rep(0,n.pos[i]*n.pos[j])), as.double(tol), as.integer(maxit), as.integer(verbose), PACKAGE="qtl") results[wh.col[[j]],wh.col[[i]]] <- t(matrix(z$full,ncol=n.pos[j])) results[wh.col[[i]],wh.col[[j]]] <- matrix(z$int,ncol=n.pos[j]) z <- 0 } # end same chromosome } else { # marker regression # replace missing and partially informative genotypes with 0's datai <- cross$geno[[i]]$data datai[is.na(datai)] <- 0 if(type=="f2" || (type=="bcsft" & !is.bcs)) datai[datai>3] <- 0 else if(type=="4way") datai[datai>4] <- 0 if(chr_type[i]=="X" && (type %in% c("bc","f2","bcsft"))) datai <- reviseXdata(type, "full", sexpgm, geno=datai, cross.attr=attributes(cross)) if(i==j) { # same chromosome z <- .C("R_scantwo_1chr_mr", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.gen[i]), as.integer(datai), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.double(weights), result=as.double(rep(0,n.pos[i]^2)), as.integer(n.col2drop), as.integer(col2drop), PACKAGE="qtl") # re-organize results results[wh.col[[i]],wh.col[[i]]] <- matrix(z$result,ncol=n.pos[i]) z <- 0 } # end same chromosome else { # replace missing and partially informative genotypes with 0's dataj <- cross$geno[[j]]$data dataj[is.na(dataj)] <- 0 if(type=="f2" || (type=="bcsft" && !is.bcs)) dataj[dataj>3] <- 0 else if(type=="4way") dataj[dataj>4] <- 0 if(chr_type[j]=="X" && (type %in% c("bc","f2","bcsft"))) dataj <- reviseXdata(type, "full", sexpgm, geno=dataj, cross.attr=attributes(cross)) z <- .C("R_scantwo_2chr_mr", as.integer(n.ind), as.integer(n.pos[i]), as.integer(n.pos[j]), as.integer(n.gen[i]), as.integer(n.gen[j]), as.integer(datai), as.integer(dataj), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.double(weights), full=as.double(rep(0,n.pos[i]*n.pos[j])), int=as.double(rep(0,n.pos[i]*n.pos[j])), PACKAGE="qtl") results[wh.col[[j]],wh.col[[i]]] <- t(matrix(z$full,ncol=n.pos[j])) results[wh.col[[i]],wh.col[[j]]] <- matrix(z$int,ncol=n.pos[j]) z <- 0 } } } # end loop over second chr } # end loop over first chromosome # subtract null neg log lik from lower tri if(method=="em") { offdiag <- lower.tri(results) | upper.tri(results) results[offdiag] <- nllik0 - results[offdiag] } else if(method=="hk") { if(n.phe == 1) { offdiag <- lower.tri(results) | upper.tri(results) results[offdiag] <- nllik0 - results[offdiag] } else { # multiple phenotypes offdiag <- lower.tri(results[,,1]) | upper.tri(results[,,1]) for(itmp in 1:n.phe) { # I'm doing a loop here. I should put null model back to C function results[,,itmp][offdiag] <- nllik0[itmp] - results[,,itmp][offdiag] } } } # If the X chromosome was included, need to do an adjustment... scanoneX <- NULL if(any(gmap[,4])) { # the X chromosome was included # determine which covariates belong in null hypothesis temp <- scanoneXnull(type, sexpgm, cross.attr=attributes(cross)) adjustX <- temp$adjustX parX0 <- temp$parX0 sexpgmcovar <- temp$sexpgmcovar if(adjustX) { if(method=="mr" && any(is.na(pull.geno(cross)))) if(n.perm > -2) warning("Scantwo with the X chr doesn't work quite right when method=\"mr\"\n", " when there is missing genotype data.") if(model=="binary") { if(n.ac > 0) { nullfitX <- glm(pheno ~ ac+sexpgmcovar, family=binomial(link="logit")) parX0 <- lm(pheno ~ ac+sexpgmcovar)$rank } else { nullfitX <- glm(pheno ~ sexpgmcovar, family=binomial(link="logit")) parX0 <- ncol(sexpgmcovar) } fittedX <- nullfitX$fitted nullcoefX <- nullfitX$coef nllikX <- -sum(pheno*log10(fittedX) + (1-pheno)*log10(1-fittedX)) if(verbose > 1) cat("X chr null log lik: ", nllikX, "\n") } else { if(n.ac > 0) { outX <- lm(pheno ~ ac+sexpgmcovar, weights=weights^2) residX <- outX$resid parX0 <- outX$rank } else residX <- lm(pheno ~ sexpgmcovar, weights=weights^2)$resid if(method=="hk") { if(n.phe==1) nllikX <- (n.ind/2)*log10(sum((residX*weights)^2)) else nllikX <- (n.ind/2)*apply(residX, 2, function(a,b) log10(sum((a*b)^2)), weights) } else { if(method=="imp" || method=="mr") { if(n.ac > 0) { out0 <- lm(pheno ~ ac, weights=weights^2) resid0 <- out0$resid } else { out0 <- lm(pheno ~ 1, weights=weights^2) resid0 <- out0$resid } if(n.phe > 1) { sig0 <- sqrt(apply(resid0, 2, function(a,b) sum((a*b)^2),weights)/n.ind) nllik0 <- sig0 for(i in seq(along=nllik0)) nllik0[i] <- -sum(dnorm(resid0[,i],0,sig0[i]/weights,log=TRUE))/log(10) } else { sig0 <- sqrt(sum((resid0*weights)^2)/n.ind) nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10) } } if(n.phe > 1) { sigX <- sqrt(apply(residX, 2, function(a,b) sum((a*b)^2),weights)/n.ind) nllikX <- sigX for(i in seq(along=nllikX)) nllikX[i] <- -sum(dnorm(residX[,i],0,sigX[i]/weights,log=TRUE))/log(10) } else { sigX <- sqrt(sum((residX*weights)^2)/n.ind) nllikX <- -sum(dnorm(residX,0,sigX/weights,log=TRUE))/log(10) } } } if(n.phe > 1) wh <- ((gmap[row(results[,,1]),4] | gmap[col(results[,,1]),4]) & (lower.tri(results[,,1]) | upper.tri(results[,,1]))) else wh <- ((gmap[row(results),4] | gmap[col(results),4]) & (lower.tri(results) | upper.tri(results))) if(n.phe > 1) { for(i in 1:n.phe) results[,,i][wh] <- results[,,i][wh] + nllikX[i] - nllik0[i] } else results[wh] <- results[wh] + nllikX - nllik0 notxchr <- names(cross$geno)[sapply(cross$geno,chrtype)!="X"] if(length(notxchr) > 0) { if(verbose) cat(" --Running scanone with special X chr covariates\n") temp <- scanone(subset(cross,chr=notxchr), pheno.col=pheno.col, model=model, method=method, addcovar=cbind(ac,sexpgmcovar), intcovar=ic, weights=weights, use=use, maxit=maxit, tol=tol, verbose=FALSE) scanoneX <- temp[,-(1:2),drop=FALSE] scanoneX <- rbind(scanoneX, out.scanone[rownames(gmap),,drop=FALSE][gmap[,4],,drop=FALSE]) scanoneX <- scanoneX[rownames(gmap),,drop=FALSE] } else { scanoneX <- out.scanone[rownames(gmap),,drop=FALSE][gmap[,4],,drop=FALSE] scanoneX <- scanoneX[rownames(gmap),,drop=FALSE] } } } # if(any(is.na(results)) && n.perm > -2) # warning("Some LOD scores NA") # if(any(!is.na(results) & results < 0) && n.perm > -2) # warning("Some LOD scores < 0") # if(any(!is.na(results) & (results == Inf | results == -Inf)) && n.perm > -2) # warning("Some LOD scores = Inf or -Inf") if(!is.null(scanoneX)) scanoneX <- as.matrix(scanoneX) # output has 2 fields, lod and map out <- list(lod=results,map=gmap,scanoneX=scanoneX) # fill in scanone result if(n.phe == 1) diag(out$lod) <- out.scanone[rownames(out$map),] else { for(iphe in 1:n.phe) { if(nrow(out$lod)==1) out$lod[1,1,iphe] <- out.scanone[rownames(out$map),iphe] else diag(out$lod[,,iphe]) <- out.scanone[rownames(out$map),iphe] } } attr(out,"method") <- method attr(out,"type") <- type attr(out, "fullmap") <- fullmap class(out) <- "scantwo" if(clean.output) # remove NA, 0 out positions between markers out <- clean(out, clean.nmar, clean.distance) attr(out, "phenotypes") <- colnames(pheno) if(length(colnames(pheno)) > 1) dimnames(out$lod) <- list(NULL, NULL, colnames(pheno)) names(out$map)[2] <- "pos" out } ###################################################################### # # scantwo.perm: Permutation test of scantwo # ###################################################################### scantwo.perm <- function(cross, pheno.col=1, model=c("normal","binary"), method=c("em","imp","hk","mr","mr-imp","mr-argmax"), addcovar=NULL, intcovar=NULL, weights=NULL, use=c("all.obs", "complete.obs"), incl.markers=FALSE, clean.output=FALSE, clean.nmar=1, clean.distance=0, maxit=4000, tol=1e-4, verbose=FALSE, n.perm=1000, perm.strata, assumeCondIndep=FALSE, batchsize=250, chr) { method <- match.arg(method) model <- match.arg(model) use <- match.arg(use) if(missing(chr)) chr <- names(chr$geno) scantwo.perm.engine(n.perm, cross=cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol, verbose=verbose, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, chr=chr) } ###################################################################### # # Engine function to scantwo permutation # ###################################################################### scantwo.perm.engine <- function(n.perm, cross, pheno.col, model, method, addcovar, intcovar, weights, use, incl.markers, clean.output, clean.nmar=1, clean.distance=0, maxit, tol, verbose, perm.strata, assumeCondIndep=FALSE, batchsize=250, chr) { if(missing(chr)) chr <- names(chr$geno) ## local variables n.phe <- length(pheno.col) n.ind <- dim(cross$pheno)[1] pn <- colnames(cross$pheno)[pheno.col] ## if there's only one phenotype, no covariate, and method is imp or hk, ## generate permuted phenotype as a matrix and do permutation ## as multiple phenotypes ## we also need one sex and one direction, or that the ## stratification is within those groups batch.mode <- FALSE if( (n.phe==1) && ((method=="imp") || (method=="hk")) && model=="normal" && is.null(addcovar) && is.null(intcovar) ) { chr_type <- sapply(cross$geno, chrtype) sexpgm <- getsex(cross) sex <- sexpgm$sex pgm <- sexpgm$pgm if(all(chr_type=="A")) batch.mode <- TRUE else if((is.null(sex) || length(unique(sex))==1) && (is.null(pgm) || length(unique(pgm))==1)) batch.mode <- TRUE else if(!is.null(perm.strata)) { sp <- paste(sex, pgm, sep=":") tab <- table(sp, perm.strata) if(all(apply(tab, 2, function(a) sum(a != 0))==1)) batch.mode <- TRUE } } if(batch.mode) { if(verbose) cat("Doing permutation in batch mode ...\n") ord <- matrix(0, n.ind, n.perm) if(!is.null(perm.strata)) { # stratified permutation test if(length(perm.strata) != n.ind) stop("perm.strata must be NULL or have length nind(cross).") u <- unique(perm.strata) theindex <- 1:n.ind if(length(u)==n.ind) stop("All elements of perm.strata are unique, so there will be no real permutation.") if(length(u)==1) warning("Just one unique element in perm.strata, so the perms are not stratified.") for(iperm in 1:n.perm) { for(j in u) { wh <- perm.strata==j if(sum(wh)==1) ord[wh,iperm] <- theindex[wh] else ord[wh,iperm] <- sample(theindex[wh]) } } } else { for(iperm in 1:n.perm) ord[,iperm] <- sample(n.ind) } cross$pheno <- cbind(matrix(cross$pheno[,pheno.col][ord], nrow=n.ind), cross$pheno) pheno.col <- 1:n.perm if(is.list(chr)) { chr1 <- chr[[1]] chr2 <- chr[[2]] } else chr1 <- chr2 <- chr thechr <- names(cross$geno) nchr1 <- match(chr1, thechr) nchr2 <- match(chr2, thechr) perm.result <- NULL for(i in nchr1) { for(j in nchr2) { if(j < i) next tem <- scantwo(cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol,verbose=FALSE, n.perm=-1, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=0, chr=list(thechr[i],thechr[j])) if(clean.output) tem <- clean(tem, clean.nmar, clean.distance) ## find the maximum LOD on each permutation if(is.null(perm.result)) { perm.result <- lapply(subrousummaryscantwo(tem,for.perm=TRUE), as.matrix) } else { tem <- lapply(subrousummaryscantwo(tem,for.perm=TRUE), as.matrix) for(k in seq(along=perm.result)) perm.result[[k]] <- as.matrix(apply(cbind(perm.result[[k]], tem[[k]]), 1, max, na.rm=TRUE)) } } } } else { ## all other cases, do one permutation at a time if(method=="mr-imp") # save version with missing genotypes tempcross <- cross if(method=="mr-argmax") # impute genotypes cross <- fill.geno(cross,method="argmax") if(!is.null(addcovar)) addcovar <- as.matrix(addcovar) if(!is.null(intcovar)) intcovar <- as.matrix(intcovar) addcovarp <- addcovar intcovarp <- intcovar ## initialize result temp <- matrix(ncol=n.phe, nrow=n.perm) perm.result <- list("full"=temp, "fv1"=temp, "int"=temp, "add"=temp, "av1"=temp, "one"=temp) if(is.list(chr)) { chr1 <- chr[[1]] chr2 <- chr[[2]] } else chr1 <- chr2 <- chr thechr <- names(cross$geno) nchr1 <- match(chr1, thechr) nchr2 <- match(chr2, thechr) ## permutation loop for(i in 1:n.perm) { if(verbose) cat("Permutation", i, "\n") ## impute genotypes for method "mr-imp" if(method=="mr-imp") cross <- fill.geno(tempcross) if(!is.null(perm.strata)) { # stratified permutation test if(length(perm.strata) != n.ind) stop("perm.strata must be NULL or have length nind(cross).") u <- unique(perm.strata) theindex <- 1:n.ind if(length(u)==n.ind) stop("All elements of perm.strata are unique, so no real permutations.") if(length(u)==1 && i==1) warning("Just one unique element in perm.strata, so the perms are not stratified.") o <- 1:n.ind for(j in u) { wh <- perm.strata==j if(sum(wh)>1) o[wh] <- sample(o[wh]) } } else o <- sample(1:n.ind) cross$pheno <- cross$pheno[o,,drop=FALSE] if(!is.null(addcovar)) addcovarp <- addcovarp[o,,drop=FALSE] if(!is.null(intcovar)) intcovarp <- intcovarp[o,,drop=FALSE] temp <- NULL for(ii in nchr1) { for(jj in nchr2) { if(jj < ii) next tem <- scantwo(cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, incl.markers=incl.markers, clean.output=clean.output, clean.nmar=clean.nmar, clean.distance=clean.distance, maxit=maxit, tol=tol,verbose=FALSE, n.perm=-i, perm.strata=perm.strata, assumeCondIndep=assumeCondIndep, batchsize=batchsize, n.cluster=0, chr=list(thechr[ii],thechr[jj])) if(clean.output) tem <- clean(tem, clean.nmar, clean.distance) ## find the maximum LOD on each permutation if(is.null(temp)) { temp <- lapply(subrousummaryscantwo(tem,for.perm=TRUE), as.matrix) } else { tem <- lapply(subrousummaryscantwo(tem,for.perm=TRUE), as.matrix) for(k in seq(along=temp)) temp[[k]] <- as.matrix(apply(cbind(temp[[k]], tem[[k]]), 1, max, na.rm=TRUE)) } } } # maxima for(j in 1:6) perm.result[[j]][i,] <- temp[[j]] } } ## make result attr(perm.result,"method") <- method class(perm.result) <- c("scantwoperm", "list") ## add column names for(i in 1:length(perm.result)) colnames(perm.result[[i]]) <- pn perm.result } # end of scantwo.R qtl/R/discan.R0000644000176200001440000002627013576241200012646 0ustar liggesusers###################################################################### # # discan.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Oct, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: discan # ###################################################################### ###################################################################### # # discan: scan genome, calculating LOD scores with single QTL model # for a dichotomous trait # ###################################################################### discan <- function(cross, pheno, method=c("em","hk","mr"), addcovar=NULL, intcovar=NULL, maxit=4000, tol=1e-4, verbose=FALSE, give.warnings=TRUE, ind.noqtl) { method <- match.arg(method) n.ind <- nind(cross) n.chr <- nchr(cross) type <- crosstype(cross) if(is.null(addcovar)) n.addcovar <- 0 else n.addcovar <- ncol(addcovar) if(is.null(intcovar)) n.intcovar <- 0 else n.intcovar <- ncol(intcovar) # individuals with no QTL effect if(missing(ind.noqtl)) ind.noqtl <- rep(FALSE, nind(cross)) else { if(!is.logical(ind.noqtl) || length(ind.noqtl) != nind(cross)) stop("ind.noqtl be a logical vector of length n.ind (", nind(cross), ")") if(sum(ind.noqtl) > 1) { if(method == "mr") { ind.noqtl <- rep(FALSE, nind(cross)) warning("ind.noqtl ignored for method=", method, ", model=binary") } else if(is.null(addcovar) && (!is.logical(ind.noqtl) || any(ind.noqtl))) { ind.noqtl <- rep(FALSE, nind(cross)) warning("ind.noqtl ignored when no additive covariates") } } } if(method=="mr" && n.addcovar+n.intcovar>0) { if(give.warnings) warning("Covariates ignored with method=\"mr\"; use \"em\" instead") n.addcovar <- n.intcovar <- addcovar <- intcovar <- 0 } u <- unique(pheno) if(any(u != 0 & u != 1)) stop("Phenotypes must be either 0 or 1.") results <- NULL llik0 <- c("A"=NA,"X"=NA) nullcoef <- list("A"=NA,"X"=NA) for(i in 1:n.chr) { chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") { sexpgm <- getsex(cross) ac <- revisecovar(sexpgm,addcovar) if(!is.null(addcovar) && (nd <- attr(ac, "n.dropped")) > 0 && give.warnings) warning("Dropped ", nd, " additive covariates on X chromosome.") if(length(ac)==0) { n.ac <- 0 ac <- NULL } else n.ac <- ncol(ac) ic <- revisecovar(sexpgm,intcovar) if(!is.null(intcovar) && (nd <- attr(ic, "n.dropped")) > 0 && give.warnings) warning("Dropped ", nd, " interactive covariates on X chromosome.") if(length(ic)==0) { n.ic <- 0 ic <- NULL } else n.ic <- ncol(ic) } else { sexpgm <- NULL ac <- addcovar n.ac <- n.addcovar ic <- intcovar n.ic <- n.intcovar } # get null log liklihood if(is.na(llik0[chr_type])) { if(n.ac > 0) nullfit <- glm(pheno ~ ac, family=binomial(link="logit")) else if(i==1) nullfit <- glm(pheno ~ 1, family=binomial(link="logit")) fitted <- nullfit$fitted nullcoef[[chr_type]] <- nullfit$coef llik0[chr_type] <- sum(pheno*log10(fitted) + (1-pheno)*log10(1-fitted)) } # get genotype names gen.names <- getgenonames(type,chr_type,"full",sexpgm,attributes(cross)) n.gen <- length(gen.names) # pull out genotype data (mr) # or genotype probabilities (em) if(method == "mr") { newgeno <- cross$geno[[i]]$data newgeno[is.na(newgeno)] <- 0 # discard partially informative genotypes if(type=="f2") newgeno[newgeno>3] <- 0 if(type=="4way") newgeno[newgeno>4] <- 0 # revise X chromosome genotypes if(chr_type=="X" && (type=="bc" || type=="f2")) newgeno <- reviseXdata(type, "full", sexpgm, geno=newgeno, cross.attr=attributes(cross)) n.pos <- ncol(newgeno) map <- cross$geno[[i]]$map if(is.matrix(map)) map <- map[1,] z <- .C("R_discan_mr", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.integer(newgeno), # genotype data as.integer(pheno), # phenotype data result=as.double(rep(0,n.pos*(n.gen+1))), PACKAGE="qtl") } else { if(!("prob" %in% names(cross$geno[[i]]))) { # need to run calc.genoprob if(give.warnings) warning("First running calc.genoprob.") cross <- calc.genoprob(cross) } genoprob <- cross$geno[[i]]$prob n.pos <- ncol(genoprob) # revise X chromosome genotypes if(chr_type=="X" && (type=="bc" || type=="f2")) genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob, cross.attr=attributes(cross)) if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) map <- map[1,] if(method=="hk") { z <- .C("R_scanone_hk_binary", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), # phenotype data result=as.double(rep(0,n.pos)), as.double(tol), as.integer(maxit), as.integer(verbose), as.integer(ind.noqtl), PACKAGE="qtl") } else if(n.ac + n.ic > 0) { start <- rep(nullcoef[[chr_type]][1],n.gen) if(n.ac > 0) start <- c(start, nullcoef[[chr_type]][-1]) if(n.ic > 0) start <- c(start, rep(0, n.ic*(n.gen-1))) z <- .C("R_discan_covar", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.integer(pheno), # phenotype data as.double(start), result=as.double(rep(0,n.pos)), as.integer(maxit), as.double(tol), as.integer(verbose), as.integer(ind.noqtl), PACKAGE="qtl") } else { z <- .C("R_discan_im", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.integer(pheno), # phenotype data result=as.double(rep(0,n.pos)), as.integer(maxit), as.double(tol), PACKAGE="qtl") } } z <- matrix(z$result,nrow=n.pos) if(method != "mr") z[,1] <- z[,1] - llik0[chr_type] z[is.na(z[,1]),1] <- 0 z <- z[,1,drop=FALSE] colnames(z)[1] <- "lod" # get null log10 likelihood for the X chromosome adjustX <- FALSE if(chr_type=="X") { # determine which covariates belong in null hypothesis temp <- scanoneXnull(type, sexpgm, cross.attr=attributes(cross)) adjustX <- temp$adjustX parX0 <- temp$parX0+n.ac sexpgmcovar <- temp$sexpgmcovar sexpgmcovar.alt <- temp$sexpgmcovar.alt if(adjustX) { # get LOD-score adjustment if(n.ac > 0) { nullfitX <- glm(pheno ~ ac+sexpgmcovar, family=binomial(link="logit")) parX0 <- lm(pheno~ac+sexpgmcovar)$rank } else nullfitX <- glm(pheno ~ sexpgmcovar, family=binomial(link="logit")) fittedX <- nullfitX$fitted llik0X <- sum(pheno*log10(fittedX) + (1-pheno)*log10(1-fittedX)) # adjust LOD curve z <- z - (llik0X - llik0["X"]) } } w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") z <- data.frame(chr=rep(names(cross$geno)[i],length(map)), pos=as.numeric(map), z, stringsAsFactors=TRUE) rownames(z) <- w results <- rbind(results, z) } # loop over chromosomes class(results) <- c("scanone","data.frame") attr(results,"method") <- method attr(results,"type") <- type attr(results,"model") <- "binary" attr(results,"null.log10.lik") <- llik0["A"] if(adjustX) attr(results,"null.log10.lik.X") <- llik0X results } # end of discan.R qtl/R/sim_ril.R0000644000176200001440000002033514256673054013053 0ustar liggesusers##################################################################### # # sim_ril.R # # copyright (c) 2004-2022, Karl W Broman # last modified June, 2022 # first written May, 2004 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: sim.ril, simulateFounderSnps, convertMWril # ###################################################################### ###################################################################### # # sim.ril # # Simulate RILs by selfing or sibling mating from 2, 4, or 8 # parental strains # map = map in the usual R/qtl map format # m = interference parameter (0 is no interference) ###################################################################### sim.ril <- function(map, n.ril=1, type=c("sibmating", "selfing"), n.str=c("2","4","8"), m=0, p=0, error.prob=0, missing.prob=0, random.cross=TRUE) { type <- match.arg(type) if(type=="sibmating") selfing <- 0 else selfing <- 1 if(is.numeric(n.str)) n.str <- as.character(n.str) n.str <- as.numeric(match.arg(n.str)) n.chr <- length(map) n.mar <- sapply(map,length) tot.mar <- sum(n.mar) if(m < 0) stop("Must have m >= 0.") if(p < 0 || p > 1) stop("Must have 0 <= p <= 1.") if(p == 1) { p <- 0 m <- 0 } omap <- map map <- lapply(map, function(a) a-min(a)) if(!selfing && inherits(omap[[length(omap)]], "X")) include.x <- TRUE else { for(i in seq(along=omap)) class(omap[[i]]) <- "A" include.x <- FALSE } if(n.str==2) random.cross <- FALSE x <- .C("R_sim_ril", as.integer(n.chr), as.integer(n.mar), as.integer(n.ril), as.double(unlist(map)), as.integer(n.str), as.integer(m), as.double(p), as.integer(include.x), as.integer(random.cross), as.integer(selfing), cross=as.integer(rep(0,n.ril*n.str)), res=as.integer(rep(0,tot.mar*n.ril)), orig=as.integer(rep(0,tot.mar*n.ril)), as.double(error.prob), as.double(missing.prob), err=as.integer(rep(0,tot.mar*n.ril)), PACKAGE="qtl") cross <- t(matrix(x$cross,ncol=n.ril,nrow=n.str)) err <- t(matrix(x$err,nrow=tot.mar,ncol=n.ril)) truegeno <- t(matrix(x$orig, nrow=tot.mar, ncol=n.ril)) x <- t(matrix(x$res,nrow=tot.mar,ncol=n.ril)) x[x==0] <- NA geno <- vector("list", n.chr) names(geno) <- names(map) cur <- 0 for(i in 1:n.chr) { geno[[i]]$data <- x[,cur + 1:n.mar[i],drop=FALSE] colnames(geno[[i]]$data) <- names(map[[i]]) geno[[i]]$map <- omap[[i]] if(missing.prob > 0 || (error.prob>0 && n.str==2)) geno[[i]]$truegeno <- truegeno[,cur+1:n.mar[i],drop=FALSE] if(error.prob > 0 && n.str==2) geno[[i]]$errors <- err[,cur+1:n.mar[i],drop=FALSE] cur <- cur + n.mar[i] class(geno[[i]]) <- class(omap[[i]]) } pheno <- data.frame(line=1:n.ril, stringsAsFactors=TRUE) x <- list(geno=geno,pheno=pheno,cross=cross) # ri[n][sib/self]un: un = genotypes not yet transformed if(type=="sibmating") { if(n.str=="2") class(x) <- c("risib","cross") else class(x) <- c(paste("ri", n.str, "sibun",sep=""),"cross") } else { if(n.str=="2") class(x) <- c("riself","cross") else class(x) <- c(paste("ri", n.str, "selfun",sep=""),"cross") } x } ###################################################################### # simFounderSnps # # Simulate founder snp genotypes for a multiple-strain RIL # # map = genetic map of markers (used just to get no. markers per chr) # # n.str = number of founder strains (4 or 8) # # pat.freq = frequency of SNP genotype patterns (length n.str/2 + 1) # (monoallelic, snp unique to a founder, # snp present in 2 founder, # [for 8 founders: snp in 3/8, snp in 4/8] ) ###################################################################### simFounderSnps <- function(map, n.str=c("4","8"), pat.freq) { if(is.numeric(n.str)) n.str <- as.character(n.str) n.str <- as.numeric(match.arg(n.str)) if(missing(pat.freq)) { if(n.str==8) pat.freq <- c(0, 0.4, 0.3, 0.2, 0.1) else pat.freq <- c(0, 0.7, 0.3) } if(length(pat.freq) < n.str/2+1) pat.freq <- c(pat.freq, rep(0, n.str/2+1 - length(pat.freq))) else pat.freq <- pat.freq[1:(n.str/2+1)] pat.freq <- pat.freq/sum(pat.freq) n.mar <- sapply(map, length) output <- vector("list", length(map)) names(output) <- names(map) for(i in seq(along=map)) { thepat <- sample(seq(length(pat.freq))-1, n.mar[i], prob=pat.freq, replace=TRUE) output[[i]] <- matrix(0, ncol=n.str, nrow=n.mar[i]) for(j in seq(along=thepat)) output[[i]][j,sample(1:n.str, thepat[j])] <- 1 } output } ###################################################################### # convertMWril: Convert multiple-strain RIL genotypes using parental data # # parents = Parental genotype data, with genetic map # list with elements being chromosomes # each chromosome is a matrix n.mar x n.str, ###################################################################### convertMWril <- function(cross, parents, error.prob=0) { crosstype <- crosstype(cross) n.str.by.crosstype <- as.numeric(substr(crosstype, 3, 3)) if(!grepl("un$", crosstype)) { stop("cross appears to have already been converted.") } class(cross) <- c(sub("un$", "", crosstype), "cross") n.ril <- nind(cross) thecrosses <- cross$cross n.str <- ncol(thecrosses) if(n.str != ncol(parents[[1]])) stop("Different numbers of founders in cross and parents.") if(n.str != n.str.by.crosstype) stop("Confusion regarding no. founders within cross.") if(length(parents) != nchr(cross)) stop("Different numbers of chromosomes in cross and parents.") n.mar <- nmar(cross) n.mar2 <- sapply(parents, nrow) if(any(n.mar != n.mar2)) stop("Different numbers of markers in cross and parents.") pg <- unlist(parents) if(any(is.na(pg))) stop("Missing parental data not allowed.") # if positive error prob, check whether all parental data are snps if(error.prob > 0) { if(all(pg==0 | pg==1)) all.snps <- TRUE else { if(all(pg==1 | pg==2)) { # convert to 0/1 parents <- lapply(parents, function(a) a - 1) all.snps <- TRUE } else all.snps <- FALSE } } else all.snps <- FALSE for(i in 1:nchr(cross)) { dat <- cross$geno[[i]]$data dat[is.na(dat)] <- 0 results <- .C("R_convertMWril", as.integer(n.ril), # no. ril as.integer(n.mar[i]), # no. markers as.integer(n.str), # no. founders as.integer(parents[[i]]), # SNP data on parents (n.mar x n.str) g=as.integer(dat), # SNP data on RIL (n.ril x n.mar) as.integer(thecrosses), # the crosses (n.ril x n.str) as.integer(all.snps), as.double(error.prob), err=as.integer(rep(0,n.mar[i]*n.ril)), PACKAGE="qtl") # replace 0's with missing values newgeno <- results$g newgeno[newgeno==0] <- NA newgeno <- matrix(newgeno, n.ril, n.mar[i]) colnames(newgeno) <- colnames(cross$geno[[i]]$data) cross$geno[[i]]$data <- newgeno if(error.prob > 0) cross$geno[[i]]$errors <- matrix(results$err, n.ril, n.mar[i]) } cross } # end of sim_ril.R qtl/R/viridis.R0000644000176200001440000002547312770016226013065 0ustar liggesusers# viridis color scheme # # Code modified from https://github.com/sjmgarnier/viridis # by Simon Garnier viridis_qtl <- function(n, alpha=1, begin=0, end=1) { ## data R <- c(0.26700401, 0.26851048, 0.26994384, 0.27130489, 0.27259384, 0.27380934, 0.27495242, 0.27602238, 0.2770184, 0.27794143, 0.27879067, 0.2795655, 0.28026658, 0.28089358, 0.28144581, 0.28192358, 0.28232739, 0.28265633, 0.28291049, 0.28309095, 0.28319704, 0.28322882, 0.28318684, 0.283072, 0.28288389, 0.28262297, 0.28229037, 0.28188676, 0.28141228, 0.28086773, 0.28025468, 0.27957399, 0.27882618, 0.27801236, 0.27713437, 0.27619376, 0.27519116, 0.27412802, 0.27300596, 0.27182812, 0.27059473, 0.26930756, 0.26796846, 0.26657984, 0.2651445, 0.2636632, 0.26213801, 0.26057103, 0.25896451, 0.25732244, 0.25564519, 0.25393498, 0.25219404, 0.25042462, 0.24862899, 0.2468114, 0.24497208, 0.24311324, 0.24123708, 0.23934575, 0.23744138, 0.23552606, 0.23360277, 0.2316735, 0.22973926, 0.22780192, 0.2258633, 0.22392515, 0.22198915, 0.22005691, 0.21812995, 0.21620971, 0.21429757, 0.21239477, 0.2105031, 0.20862342, 0.20675628, 0.20490257, 0.20306309, 0.20123854, 0.1994295, 0.1976365, 0.19585993, 0.19410009, 0.19235719, 0.19063135, 0.18892259, 0.18723083, 0.18555593, 0.18389763, 0.18225561, 0.18062949, 0.17901879, 0.17742298, 0.17584148, 0.17427363, 0.17271876, 0.17117615, 0.16964573, 0.16812641, 0.1666171, 0.16511703, 0.16362543, 0.16214155, 0.16066467, 0.15919413, 0.15772933, 0.15626973, 0.15481488, 0.15336445, 0.1519182, 0.15047605, 0.14903918, 0.14760731, 0.14618026, 0.14475863, 0.14334327, 0.14193527, 0.14053599, 0.13914708, 0.13777048, 0.1364085, 0.13506561, 0.13374299, 0.13244401, 0.13117249, 0.1299327, 0.12872938, 0.12756771, 0.12645338, 0.12539383, 0.12439474, 0.12346281, 0.12260562, 0.12183122, 0.12114807, 0.12056501, 0.12009154, 0.11973756, 0.11951163, 0.11942341, 0.11948255, 0.11969858, 0.12008079, 0.12063824, 0.12137972, 0.12231244, 0.12344358, 0.12477953, 0.12632581, 0.12808703, 0.13006688, 0.13226797, 0.13469183, 0.13733921, 0.14020991, 0.14330291, 0.1466164, 0.15014782, 0.15389405, 0.15785146, 0.16201598, 0.1663832, 0.1709484, 0.17570671, 0.18065314, 0.18578266, 0.19109018, 0.19657063, 0.20221902, 0.20803045, 0.21400015, 0.22012381, 0.2263969, 0.23281498, 0.2393739, 0.24606968, 0.25289851, 0.25985676, 0.26694127, 0.27414922, 0.28147681, 0.28892102, 0.29647899, 0.30414796, 0.31192534, 0.3198086, 0.3277958, 0.33588539, 0.34407411, 0.35235985, 0.36074053, 0.3692142, 0.37777892, 0.38643282, 0.39517408, 0.40400101, 0.4129135, 0.42190813, 0.43098317, 0.44013691, 0.44936763, 0.45867362, 0.46805314, 0.47750446, 0.4870258, 0.49661536, 0.5062713, 0.51599182, 0.52577622, 0.5356211, 0.5455244, 0.55548397, 0.5654976, 0.57556297, 0.58567772, 0.59583934, 0.60604528, 0.61629283, 0.62657923, 0.63690157, 0.64725685, 0.65764197, 0.66805369, 0.67848868, 0.68894351, 0.69941463, 0.70989842, 0.72039115, 0.73088902, 0.74138803, 0.75188414, 0.76237342, 0.77285183, 0.78331535, 0.79375994, 0.80418159, 0.81457634, 0.82494028, 0.83526959, 0.84556056, 0.8558096, 0.86601325, 0.87616824, 0.88627146, 0.89632002, 0.90631121, 0.91624212, 0.92610579, 0.93590444, 0.94563626, 0.95529972, 0.96489353, 0.97441665, 0.98386829, 0.99324789) G <- c(0.00487433, 0.00960483, 0.01462494, 0.01994186, 0.02556309, 0.03149748, 0.03775181, 0.04416723, 0.05034437, 0.05632444, 0.06214536, 0.06783587, 0.07341724, 0.07890703, 0.0843197, 0.08966622, 0.09495545, 0.10019576, 0.10539345, 0.11055307, 0.11567966, 0.12077701, 0.12584799, 0.13089477, 0.13592005, 0.14092556, 0.14591233, 0.15088147, 0.15583425, 0.16077132, 0.16569272, 0.17059884, 0.1754902, 0.18036684, 0.18522836, 0.19007447, 0.1949054, 0.19972086, 0.20452049, 0.20930306, 0.21406899, 0.21881782, 0.22354911, 0.2282621, 0.23295593, 0.23763078, 0.24228619, 0.2469217, 0.25153685, 0.2561304, 0.26070284, 0.26525384, 0.26978306, 0.27429024, 0.27877509, 0.28323662, 0.28767547, 0.29209154, 0.29648471, 0.30085494, 0.30520222, 0.30952657, 0.31382773, 0.3181058, 0.32236127, 0.32659432, 0.33080515, 0.334994, 0.33916114, 0.34330688, 0.34743154, 0.35153548, 0.35561907, 0.35968273, 0.36372671, 0.36775151, 0.37175775, 0.37574589, 0.37971644, 0.38366989, 0.38760678, 0.39152762, 0.39543297, 0.39932336, 0.40319934, 0.40706148, 0.41091033, 0.41474645, 0.4185704, 0.42238275, 0.42618405, 0.42997486, 0.43375572, 0.4375272, 0.44128981, 0.4450441, 0.4487906, 0.4525298, 0.45626209, 0.45998802, 0.46370813, 0.4674229, 0.47113278, 0.47483821, 0.47853961, 0.4822374, 0.48593197, 0.4896237, 0.49331293, 0.49700003, 0.50068529, 0.50436904, 0.50805136, 0.51173263, 0.51541316, 0.51909319, 0.52277292, 0.52645254, 0.53013219, 0.53381201, 0.53749213, 0.54117264, 0.54485335, 0.54853458, 0.55221637, 0.55589872, 0.55958162, 0.56326503, 0.56694891, 0.57063316, 0.57431754, 0.57800205, 0.58168661, 0.58537105, 0.58905521, 0.59273889, 0.59642187, 0.60010387, 0.60378459, 0.60746388, 0.61114146, 0.61481702, 0.61849025, 0.62216081, 0.62582833, 0.62949242, 0.63315277, 0.63680899, 0.64046069, 0.64410744, 0.64774881, 0.65138436, 0.65501363, 0.65863619, 0.66225157, 0.66585927, 0.66945881, 0.67304968, 0.67663139, 0.68020343, 0.68376525, 0.68731632, 0.69085611, 0.69438405, 0.6978996, 0.70140222, 0.70489133, 0.70836635, 0.71182668, 0.71527175, 0.71870095, 0.72211371, 0.72550945, 0.72888753, 0.73224735, 0.73558828, 0.73890972, 0.74221104, 0.74549162, 0.74875084, 0.75198807, 0.75520266, 0.75839399, 0.76156142, 0.76470433, 0.76782207, 0.77091403, 0.77397953, 0.7770179, 0.78002855, 0.78301086, 0.78596419, 0.78888793, 0.79178146, 0.79464415, 0.79747541, 0.80027461, 0.80304099, 0.80577412, 0.80847343, 0.81113836, 0.81376835, 0.81636288, 0.81892143, 0.82144351, 0.82392862, 0.82637633, 0.82878621, 0.83115784, 0.83349064, 0.83578452, 0.83803918, 0.84025437, 0.8424299, 0.84456561, 0.84666139, 0.84871722, 0.8507331, 0.85270912, 0.85464543, 0.85654226, 0.85839991, 0.86021878, 0.86199932, 0.86374211, 0.86544779, 0.86711711, 0.86875092, 0.87035015, 0.87191584, 0.87344918, 0.87495143, 0.87642392, 0.87786808, 0.87928545, 0.88067763, 0.88204632, 0.88339329, 0.88472036, 0.88602943, 0.88732243, 0.88860134, 0.88986815, 0.89112487, 0.89237353, 0.89361614, 0.89485467, 0.89609127, 0.89732977, 0.8985704, 0.899815, 0.90106534, 0.90232311, 0.90358991, 0.90486726, 0.90615657) B <- c(0.32941519, 0.33542652, 0.34137895, 0.34726862, 0.35309303, 0.35885256, 0.36454323, 0.37016418, 0.37571452, 0.38119074, 0.38659204, 0.39191723, 0.39716349, 0.40232944, 0.40741404, 0.41241521, 0.41733086, 0.42216032, 0.42690202, 0.43155375, 0.43611482, 0.44058404, 0.44496, 0.44924127, 0.45342734, 0.45751726, 0.46150995, 0.46540474, 0.46920128, 0.47289909, 0.47649762, 0.47999675, 0.48339654, 0.48669702, 0.48989831, 0.49300074, 0.49600488, 0.49891131, 0.50172076, 0.50443413, 0.50705243, 0.50957678, 0.5120084, 0.5143487, 0.5165993, 0.51876163, 0.52083736, 0.52282822, 0.52473609, 0.52656332, 0.52831152, 0.52998273, 0.53157905, 0.53310261, 0.53455561, 0.53594093, 0.53726018, 0.53851561, 0.53970946, 0.54084398, 0.5419214, 0.54294396, 0.54391424, 0.54483444, 0.54570633, 0.546532, 0.54731353, 0.54805291, 0.54875211, 0.54941304, 0.55003755, 0.55062743, 0.5511844, 0.55171011, 0.55220646, 0.55267486, 0.55311653, 0.55353282, 0.55392505, 0.55429441, 0.55464205, 0.55496905, 0.55527637, 0.55556494, 0.55583559, 0.55608907, 0.55632606, 0.55654717, 0.55675292, 0.55694377, 0.5571201, 0.55728221, 0.55743035, 0.55756466, 0.55768526, 0.55779216, 0.55788532, 0.55796464, 0.55803034, 0.55808199, 0.55811913, 0.55814141, 0.55814842, 0.55813967, 0.55811466, 0.5580728, 0.55801347, 0.557936, 0.55783967, 0.55772371, 0.55758733, 0.55742968, 0.5572505, 0.55704861, 0.55682271, 0.55657181, 0.55629491, 0.55599097, 0.55565893, 0.55529773, 0.55490625, 0.55448339, 0.55402906, 0.55354108, 0.55301828, 0.55245948, 0.55186354, 0.55122927, 0.55055551, 0.5498411, 0.54908564, 0.5482874, 0.54744498, 0.54655722, 0.54562298, 0.54464114, 0.54361058, 0.54253043, 0.54139999, 0.54021751, 0.53898192, 0.53769219, 0.53634733, 0.53494633, 0.53348834, 0.53197275, 0.53039808, 0.52876343, 0.52706792, 0.52531069, 0.52349092, 0.52160791, 0.51966086, 0.5176488, 0.51557101, 0.5134268, 0.51121549, 0.50893644, 0.5065889, 0.50417217, 0.50168574, 0.49912906, 0.49650163, 0.49380294, 0.49103252, 0.48818938, 0.48527326, 0.48228395, 0.47922108, 0.47608431, 0.4728733, 0.46958774, 0.46622638, 0.46278934, 0.45927675, 0.45568838, 0.45202405, 0.44828355, 0.44446673, 0.44057284, 0.4366009, 0.43255207, 0.42842626, 0.42422341, 0.41994346, 0.41558638, 0.41115215, 0.40664011, 0.40204917, 0.39738103, 0.39263579, 0.38781353, 0.38291438, 0.3779385, 0.37288606, 0.36775726, 0.36255223, 0.35726893, 0.35191009, 0.34647607, 0.3409673, 0.33538426, 0.32972749, 0.32399761, 0.31819529, 0.31232133, 0.30637661, 0.30036211, 0.29427888, 0.2881265, 0.28190832, 0.27562602, 0.26928147, 0.26287683, 0.25641457, 0.24989748, 0.24332878, 0.23671214, 0.23005179, 0.22335258, 0.21662012, 0.20986086, 0.20308229, 0.19629307, 0.18950326, 0.18272455, 0.17597055, 0.16925712, 0.16260273, 0.15602894, 0.14956101, 0.14322828, 0.13706449, 0.13110864, 0.12540538, 0.12000532, 0.11496505, 0.11034678, 0.10621724, 0.1026459, 0.09970219, 0.09745186, 0.09595277, 0.09525046, 0.09537439, 0.09633538, 0.09812496, 0.1007168, 0.10407067, 0.10813094, 0.11283773, 0.11812832, 0.12394051, 0.13021494, 0.13689671, 0.1439362) if(n==256 && begin==0 && end==1) return(grDevices::rgb(R, G, B, alpha=alpha)) loc <- seq(0, 1, length.out=256) R <- stats::splinefun(x=loc, y=R) G <- stats::splinefun(x=loc, y=G) B <- stats::splinefun(x=loc, y=B) loc <- seq(begin, end, length.out=n) grDevices::rgb(R(loc), G(loc), B(loc), alpha=alpha) } qtl/R/write.cross.R0000644000176200001440000004232113576241200013662 0ustar liggesusers###################################################################### # # write.cross.R # # copyright (c) 2001-2019, Karl W Broman and Hao Wu # last modified Dec, 2019 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: write.cross, write.cross.mm, write.cross.csv, # write.cross.gary, write.cross.tidy, fixX4write # [See qtlcart_io.R for write.cross.qtlcart] # [write.cross.qtab in write.cross.qtab.R] # ###################################################################### ###################################################################### # # write.cross: Wrapper for the other write.cross functions # ###################################################################### write.cross <- function(cross, format=c("csv", "csvr", "csvs", "csvsr", "mm", "qtlcart", "gary", "qtab", "mapqtl", "tidy"), filestem="data", chr, digits=NULL, descr) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") format <- match.arg(format) if(!missing(chr)) cross <- subset(cross,chr=chr) # revise X data chr_type <- sapply(cross$geno,chrtype) crosstype <- crosstype(cross) if((crosstype=="bc" || crosstype=="f2") && any(chr_type=="X")) { sexpgm <- getsex(cross) sex <- sexpgm$sex pgm <- sexpgm$pgm for(i in which(chr_type=="X")) cross$geno[[i]]$data <- fixX4write(cross$geno[[i]]$data,sex,pgm,crosstype) } if(crosstype == "bcsft") # convert BCsFt to intercross for writing class(cross) <- c("f2", "cross") if(format=="csv") write.cross.csv(cross,filestem,digits,FALSE,FALSE) else if(format=="csvr") write.cross.csv(cross,filestem,digits,TRUE,FALSE) else if(format=="csvs") write.cross.csv(cross,filestem,digits,FALSE,TRUE) else if(format=="csvsr") write.cross.csv(cross,filestem,digits,TRUE,TRUE) else if(format=="mm") write.cross.mm(cross,filestem,digits) else if(format=="qtlcart") write.cross.qtlcart(cross, filestem) else if(format=="gary") write.cross.gary(cross, digits) else if(format=="tidy") write.cross.tidy(cross, filestem, digits) else if(format=="qtab") { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") write.cross.qtab(cross, filestem, descr, verbose=FALSE) } else if(format == "mapqtl") write.cross.mq(cross, filestem, digits) } ###################################################################### # # write.cross.mm: Write data for an experimental cross in Mapmaker # format # # creates two files: "raw" file with geno & pheno data # "prep" file with map information # ###################################################################### write.cross.mm <- function(cross, filestem="data", digits=NULL) { n.ind <- nind(cross) tot.mar <- totmar(cross) n.phe <- nphe(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) if(type=="riself" || type=="risib" || type=="dh" || type=="haploid") type <- "bc" if(type != "f2" && type != "bc") stop("write.cross.mm only works for intercross, backcross, doubled haploid and RI data.") # write genotype and phenotype data file <- paste(filestem, ".raw", sep="") # write experiment type if(type == "f2") write("data type f2 intercross", file, append=FALSE) else write("data type f2 backcross", file, append=FALSE) # write numbers of progeny, markers and phenotypes write(paste(n.ind, tot.mar, n.phe), file, append=TRUE) # max length of marker name mlmn <- max(nchar(unlist(lapply(cross$geno,function(a) colnames(a$data)))))+1 # write marker data for(i in 1:n.chr) { for(j in 1:n.mar[i]) { mn <- paste("*", colnames(cross$geno[[i]]$data)[j], sep="") if(nchar(mn) < mlmn) mn <- paste(mn,paste(rep(" ", mlmn-nchar(mn)),collapse=""),sep="") g <- cross$geno[[i]]$data[,j] x <- rep("", n.ind) x[is.na(g)] <- "-" x[!is.na(g) & g==1] <- "A" x[!is.na(g) & g==2] <- "H" if(type == "f2") { x[!is.na(g) & g==3] <- "B" x[!is.na(g) & g==4] <- "D" x[!is.na(g) & g==5] <- "C" } if(n.ind < 60) write(paste(mn, paste(x,collapse="")), file, append=TRUE) else { lo <- seq(1,n.ind-1,by=60) hi <- c(lo[-1]-1,n.ind) for(k in seq(along=lo)) { if(k==1) write(paste(mn,paste(x[lo[k]:hi[k]],collapse="")),file,append=TRUE) else write(paste(paste(rep(" ", mlmn),collapse=""), paste(x[lo[k]:hi[k]],collapse="")),file,append=TRUE) } } } } # end writing marker data # max length of phenotype name mlpn <- max(nchar(colnames(cross$pheno)))+1 # write phenotypes for(i in 1:n.phe) { pn <- paste("*",colnames(cross$pheno)[i],sep="") if(nchar(pn) < mlpn) pn <- paste(pn, paste(rep(" ", mlpn-nchar(pn)),collapse=""),sep="") if(!is.factor(cross$pheno[,i])) { if(is.null(digits)) x <- as.character(cross$pheno[,i]) else x <- as.character(round(cross$pheno[,i],digits)) } else x <- as.character(cross$pheno[,i]) x[is.na(x)] <- "-" if(n.ind < 10) write(paste(pn, paste(x,collapse="")), file, append=TRUE) else { lo <- seq(1,n.ind-1,by=10) hi <- c(lo[-1]-1,n.ind) for(k in seq(along=lo)) { if(k==1) write(paste(pn,paste(x[lo[k]:hi[k]],collapse=" ")),file,append=TRUE) else write(paste(paste(rep(" ", mlpn),collapse=""), paste(x[lo[k]:hi[k]],collapse=" ")),file,append=TRUE) } } } # make "prep" file with map information file <- paste(filestem, ".prep", sep="") for(i in 1:n.chr) { cname <- paste("chr", names(cross$geno)[i], sep="") line <- paste("make chromosome", cname) if(i==1) write(line, file, append=FALSE) else write(line, file, append=TRUE) mn <- names(cross$geno[[i]]$map) # dis <- round(diff(cross$geno[[i]]$map),2) # dis <- paste("=", dis, sep="") # write(paste(paste("sequence", mn[1]), paste(dis,mn[-1],collapse=" ")), # file, append=TRUE) write(paste(paste("sequence", mn[1]), paste(mn[-1],collapse=" ")), file, append=TRUE) write(paste("anchor", cname), file, append=TRUE) write(paste("framework", cname), file, append=TRUE) } } ###################################################################### # # write.cross.csv: Write data for an experimental cross in # comma-delimited format (the same format as is read # by read.cross.csv) # ###################################################################### write.cross.csv <- function(cross, filestem="data", digits=NULL, rotate=FALSE, split=FALSE) { type <- crosstype(cross) if(type != "f2" && type != "bc" && type != "riself" && type != "risib" && type != "dh" && type != "haploid") stop("write.cross.csv only works for intercross, backcross, RI, doubled haploid, and haploid data.") if(!split) file <- paste(filestem, ".csv", sep="") else { genfile <- paste(filestem, "_gen.csv", sep="") phefile <- paste(filestem, "_phe.csv", sep="") } if(split) { # split files; need individual IDs id <- getid(cross) if(is.null(id)) { cross$pheno$id <- 1:nind(cross) id <- getid(cross) } id.col <- which(colnames(cross$pheno)==attr(id,"phenam")) } n.ind <- nind(cross) tot.mar <- totmar(cross) n.phe <- nphe(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) geno <- matrix(ncol=tot.mar,nrow=n.ind) # allele codes to use if("alleles" %in% names(attributes(cross))) { alle <- attr(cross, "alleles") alleles <- c(paste(alle[1],alle[1],sep=""), paste(alle[1],alle[2],sep=""), paste(alle[2],alle[2],sep=""), paste("not ", alle[2],alle[2],sep=""), paste("not ", alle[1],alle[1],sep="")) } else alleles <- c("A","H","B","D","C") if(type=="dh" || type=="riself" || type=="risib") alleles[2:3] <- alleles[3:2] else if(type=="haploid") alleles <- alle firstmar <- 1 for(i in 1:n.chr) { # replace allele numbers with geno[,firstmar:(firstmar+n.mar[i]-1)] <- alleles[match(cross$geno[[i]]$data,1:5)] firstmar <- firstmar + n.mar[i] } if(any(is.na(geno))) geno[is.na(geno)] <- "-" pheno <- cross$pheno for(i in 1:nphe(cross)) { if(is.factor(pheno[,i])) pheno[,i] <- as.character(pheno[,i]) else if(is.numeric(pheno[,i])) { if(!is.null(digits)) pheno[,i] <- round(pheno[,i], digits) pheno[,i] <- as.character(pheno[,i]) } } pheno <- matrix(unlist(pheno), nrow=n.ind) if(any(is.na(pheno))) pheno[is.na(pheno)] <- "-" thedata <- cbind(pheno,geno) colnames(thedata) <- c(colnames(cross$pheno), unlist(lapply(cross$geno, function(a) colnames(a$data)))) chr <- rep(names(cross$geno),n.mar) pos <- unlist(lapply(cross$geno,function(a) a$map)) chr <- c(rep("",n.phe),chr) if(!is.null(digits)) pos <- c(rep("",n.phe),as.character(round(pos,digits))) else pos <- c(rep("",n.phe),as.character(pos)) # put it all together thenames <- colnames(thedata) thedata <- matrix(as.character(thedata), ncol=ncol(thedata)) thedata <- rbind(thenames, chr, pos, thedata) if(!split) { if(!rotate) write.table(thedata, file, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) else write.table(t(thedata), file, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) } else { # split files: one for phenotypes and one for genotypes n.phe <- nphe(cross) phe <- thedata[-(2:3),1:n.phe] gen <- cbind(thedata[,id.col], thedata[,-(1:n.phe)]) if(!rotate) { write.table(gen, genfile, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) write.table(phe, phefile, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) } else { write.table(t(gen), genfile, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) write.table(t(phe), phefile, quote=FALSE, sep=",", row.names=FALSE, col.names=FALSE) } } } ###################################################################### # # write.cross.gary: Write data for an experimental cross in # Gary's format. There will be 6 output files, they are: # chrid.dat - chromosome ids # markerpos.txt - marker position # mnames.txt - marker names # geno.data - genotypes # pheno.data - phenotypes # pnames.txt - phenotype names # ###################################################################### write.cross.gary <- function(cross, digits=NULL) { # local variables n.ind <- nind(cross) tot.mar <- totmar(cross) n.phe <- nphe(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) # chromosome ids chrid <- NULL for(i in 1:n.chr) { # the name for this chromosome chrname <- names(cross$geno[i]) # convert to number (why?) # if(chrname=="X") chrname <- 20 # else chrname <- as.numeric(chrname) chrid <- c(chrid, rep(chrname, n.mar[i])) } write.table(chrid, file="chrid.dat", quote=FALSE, row.names=FALSE, col.names=FALSE) # marker position file markpos <- NULL for(i in 1:n.chr) markpos <- c(markpos, cross$geno[[i]]$map) write.table(markpos, file="markerpos.txt", quote=FALSE, sep="\t", row.names=TRUE, col.names=FALSE) # marker names mnames <- names(markpos) write.table(mnames, file="mnames.txt", quote=FALSE, row.names=FALSE, col.names=FALSE) # genotype geno <- NULL for(i in 1:n.chr) geno <- cbind(geno, cross$geno[[i]]$data) # note that gary's format codes genotype from 0 # and 9 is for NA geno <- geno - 1 # note NA will still be NA write.table(geno, file="geno.dat", quote=FALSE, row.names=FALSE, col.names=FALSE, sep="\t", na="9") # phenotype pheno <- cross$pheno for(i in 1:nphe(cross)) { if(is.factor(pheno[,i])) pheno[,i] <- as.character(pheno[,i]) else if(is.numeric(pheno[,i])) { if(is.null(digits)) pheno[,i] <- as.character(pheno[,i]) else pheno[,i] <- as.character(round(pheno[,i], digits)) } } pheno <- matrix(unlist(pheno), nrow=nrow(pheno)) write.table(pheno, file="pheno.dat", quote=FALSE, row.names=FALSE, col.names=FALSE, sep="\t", na="-999") # phenotype names write.table(names(cross$pheno), file="pnames.txt", quote=FALSE, row.names=FALSE, col.names=FALSE, sep="\t", na="-999") } ###################################################################### # # write.cross.tidy: Write data for an experimental cross in tidy # format. There will be 3 output files, they are: # geno.csv # pheno.csv # map.csv # ###################################################################### write.cross.tidy <- function(cross, filestem="data", digits=NULL) { genfile <- paste(filestem, "_gen.csv", sep="") phefile <- paste(filestem, "_phe.csv", sep="") mapfile <- paste(filestem, "_map.csv", sep = "") type <- crosstype(cross) id <- getid(cross) if(is.null(id)) { cross$pheno$id <- 1:nind(cross) id <- getid(cross) } id.col <- which(colnames(cross$pheno) == attr(id,"phenam")) # allele codes to use if("alleles" %in% names(attributes(cross))) { alle <- attr(cross, "alleles") alleles <- c(paste(alle[1],alle[1],sep=""), paste(alle[1],alle[2],sep=""), paste(alle[2],alle[2],sep=""), paste("not ", alle[2],alle[2],sep=""), paste("not ", alle[1],alle[1],sep="")) } else alleles <- c("A","H","B","D","C") if (type %in% c("dh", "riself", "risib")) alleles[2:3] <- alleles[3:2] else if (type == "haploid") alleles <- alle geno <- pull.geno(cross) geno <- matrix(alleles[geno], ncol = nind(cross), byrow = TRUE, dimnames = list(markernames(cross), make.names(id))) if(any(is.na(geno))) geno[is.na(geno)] <- "-" pheno <- cross$pheno[-id.col] for(i in 1:ncol(pheno)) { if(is.factor(pheno[,i])) pheno[,i] <- as.character(pheno[,i]) else if(is.numeric(pheno[,i])) { if(!is.null(digits)) pheno[,i] <- round(pheno[,i], digits) pheno[,i] <- as.character(pheno[,i]) } } pheno <- matrix(unlist(pheno), nrow=nind(cross), dimnames = list(make.names(id), phenames(cross)[-id.col])) pheno <- t(pheno) if(any(is.na(pheno))) pheno[is.na(pheno)] <- "-" map <- pull.map(cross, as.table = TRUE) if(!is.null(digits)) map$pos <- as.character(round(map$pos, digits)) else map$pos <- as.character(map$pos) write.table(geno, genfile, quote = FALSE, sep = ",", col.names = NA) write.table(pheno, phefile, quote = FALSE, sep = ",", col.names = NA) write.table(map, mapfile, quote = FALSE, sep = ",", col.names = NA) } ###################################################################### # fixX4write ###################################################################### fixX4write <- function(geno,sex,pgm,crosstype) { # males if(!is.null(sex) & any(sex==1)) { temp <- geno[sex==1,,drop=FALSE] temp[temp==2] <- 3 geno[sex==1,] <- temp } if(crosstype == "f2") { # females if(!is.null(pgm)) { if(!is.null(sex)) { if(any(pgm==1 & sex==0)) { temp <- geno[sex==0 & pgm==1,,drop=FALSE] temp[temp==1] <- 3 geno[sex==0 & pgm==1,] <- temp } } else { # assume all females if(any(pgm==1)) { temp <- geno[pgm==1,,drop=FALSE] temp[temp==1] <- 3 geno[pgm==1,] <- temp } } } } geno } # end of write.cross.R qtl/R/phyloqtl_util.R0000644000176200001440000002272213576241200014314 0ustar liggesusers###################################################################### # phyloqtl_util.R # # copyright (c) 2009-2019, Karl W Broman # last modified Dec, 2019 # first written May, 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Utility functions for the phylo/qtl analyses # # Part of the R/qtl package # Contains: checkPhyloPartition, checkPhyloCrosses, qtlByPartition, # flipcross, genAllPartitions, sortPhyloPartitions # ###################################################################### # check that 'partition' is appropriate for a given set of taxa checkPhyloPartition <- function(partition, taxa) { n.taxa <- length(taxa) if(length(partition) > 1) { for(i in partition) checkPhyloPartition(i, taxa) return(TRUE) } # check that all the taxa are there and that there is just one "|" temp <- unlist(strsplit(partition, "")) if(length(temp) != n.taxa+1 || any(is.na(match(c(taxa, "|"), temp)))) stop("partition is mis-specified; should be a character string with all taxa and one vertical bar (|).") # check that "|" is not at one end or the other ss <- unlist(strsplit(partition, "\\|")) if(length(ss) != 2 || any(nchar(ss)==0)) stop("partition is mis-specified; vertical bar (|) should be somewhere in the middle.") TRUE } # check that the crosses are correct checkPhyloCrosses <- function(crosses, taxa, nostop=FALSE) { temp <- strsplit(crosses, "") if(any(is.na(match(unlist(temp), taxa)))) { temp <- unlist(temp) extras <- unique(temp[is.na(match(temp, taxa))]) if(nostop) return(FALSE) stop("Crosses mis-specified; have extra taxa, ", paste(extras, collapse=" ")) } crosses <- sapply(temp, paste, collapse="") if(length(crosses) != length(unique(crosses))) { warning("Some crosses given multiple times; these are omitted.") crosses <- unique(crosses) temp <- strsplit(crosses, "") } # all taxa included in the crosses? m <- is.na(match(taxa, unique(unlist(temp)))) if(any(m)) { temp <- paste(taxa[m], collapse=" ") if(nostop) return(FALSE) stop("Some taxa missing from the crosses: ", temp) } # check that the crosses connect all n taxa thetaxa <- as.list(taxa) for(i in seq(along=temp)) { wh1 <- which(sapply(thetaxa, function(a,b) any(a==b), temp[[i]][1])) wh2 <- which(sapply(thetaxa, function(a,b) any(a==b), temp[[i]][2])) if(wh1 != wh2) { thetaxa[[wh1]] <- c(thetaxa[[wh1]], thetaxa[[wh2]]) thetaxa <- thetaxa[-wh2] } } if(length(thetaxa) > 1) { if(nostop) return(FALSE) stop("The crosses are insufficient; they should connect all taxa.") } if(nostop) return(TRUE) crosses } ###################################################################### # qtlByPartition # # for each cross and each partition, determine which crosses have a # QTL and whether the alleles need to be swapped ###################################################################### qtlByPartition <- function(crosses, partition) { # check for multiple crosses (of the form "AB:AC:AD") if(length(grep(":", crosses)) > 0) { result <- lapply(strsplit(crosses, ":"), qtlByPartition, partition) names(result) <- crosses return(result) } # for each partition, determine which crosses have the QTL crossmat <- matrix(NA, ncol=length(partition), nrow=length(crosses)) crosssplit <- strsplit(crosses, "") partitionsplit <- lapply(strsplit(partition, "\\|"), strsplit, "") for(i in seq(along=crosses)) { for(j in seq(along=partition)) { v <- vector("list", 2) for(k in 1:2) v[[k]] <- sapply(partitionsplit[[j]], function(a,b) match(b, a), crosssplit[[i]][k]) crossmat[i,j] <- diff(sapply(v, function(a) which(!is.na(a)))) } } dimnames(crossmat) <- list(crosses, partition) crossmat } ###################################################################### # flipcross # # The goal of this function is to take a QTL cross object (for R/qtl) # and flip the alleles A <-> B. # # For the case of an intercross, the allele codes (and corresponding # QTL genotype probabilities and/or imputated genotypes) are switched # as follows: # # genotype old code new code # AA 1 3 # AB 2 2 # BB 3 1 # not BB 4 5 # not AA 5 4 ###################################################################### flipcross <- function(cross) { if(!inherits(cross, "cross")) stop("The input should have class 'cross'") allowed_crosses <- c("f2", "riself", "risib", "dh", "haploid") crosstype <- crosstype(cross) if(!(crosstype %in% allowed_crosses)) stop("The function is not working for cross type ", crosstype) chr_type <- sapply(cross$geno, chrtype) # omit X chr if(any(chr_type=="X")) { cross <- subset(cross, chr = (chr_type != "X")) warning("flipcross is not yet working for the X chromosome; X chr omitted from output.") } if(crosstype == "f2") { for(i in seq(along=cross$geno)) { nd <- d <- cross$geno[[i]]$data nd[!is.na(d) & d==1] <- 3 nd[!is.na(d) & d==3] <- 1 nd[!is.na(d) & d==4] <- 5 nd[!is.na(d) & d==5] <- 4 cross$geno[[i]]$data <- nd if("prob" %in% names(cross$geno[[i]])) { theattr <- attributes(cross$geno[[i]]$prob) cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,,3:1,drop=FALSE] attr(cross$geno[[i]]$prob,"map") <- theattr$map attr(cross$geno[[i]]$prob,"error.prob") <- theattr$error.prob attr(cross$geno[[i]]$prob,"step") <- theattr$step attr(cross$geno[[i]]$prob,"off.end") <- theattr$off.end attr(cross$geno[[i]]$prob,"map.function") <- theattr$map.function attr(cross$geno[[i]]$prob,"stepwidth") <- theattr$stepwidth } if("draws" %in% names(cross$geno[[i]])) { nd <- d <- cross$geno[[i]]$draws nd[d==3] <- 1 nd[d==1] <- 3 cross$geno[[i]]$draws <- nd } } } else { # riself/risib/dh/haploid for(i in seq(along=cross$geno)) { nd <- d <- cross$geno[[i]]$data nd[!is.na(d) & d==1] <- 2 nd[!is.na(d) & d==2] <- 1 if("prob" %in% names(cross$geno[[i]])) { theattr <- attributes(cross$geno[[i]]$prob) cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,,2:1,drop=FALSE] attr(cross$geno[[i]]$prob,"map") <- theattr$map attr(cross$geno[[i]]$prob,"error.prob") <- theattr$error.prob attr(cross$geno[[i]]$prob,"step") <- theattr$step attr(cross$geno[[i]]$prob,"off.end") <- theattr$off.end attr(cross$geno[[i]]$prob,"map.function") <- theattr$map.function attr(cross$geno[[i]]$prob,"stepwidth") <- theattr$stepwidth } if("draws" %in% names(cross$geno[[i]])) { nd <- d <- cross$geno[[i]]$draws nd[d==2] <- 1 nd[d==1] <- 2 cross$geno[[i]]$draws <- nd } } } if("alleles" %in% names(attributes(cross))) attr(cross, "alleles") <- rev(attr(cross, "alleles")) cross } # generate all possible partitions (except the null) genAllPartitions <- function(n.taxa, taxa) { # Utility function # returns binary representation of 1:(2^n) binary.v <- function(n) { x <- 1:(2^n) mx <- max(x) digits <- floor(log2(mx)) ans <- 0:(digits-1); lx <- length(x) x <- matrix(rep(x,rep(digits, lx)),ncol=lx) (x %/% 2^ans) %% 2 } if(missing(taxa)) taxa <- LETTERS[1:n.taxa] else { if(missing(n.taxa)) n.taxa <- length(taxa) else { if(n.taxa != length(taxa)) stop("n.taxa != length(taxa)") } } mat <- binary.v(n.taxa) colsum <- apply(mat, 2, sum) mat <- mat[,colsum > 0 & colsum <= floor(n.taxa/2)] result <- unique(apply(mat, 2, function(a,b) { x <- c(paste(b[a==1],collapse=""), paste(b[a==0],collapse="")) if(diff(nchar(x)) == 0) x <- sort(x) paste(x, collapse="|")}, taxa)) sortPhyloPartitions(result, taxa) } sortPhyloPartitions <- function(partitions, taxa) { if(missing(taxa)) taxa <- LETTERS[1:26] thesplit <- strsplit(partitions, "\\|") n1 <- sapply(thesplit, function(a) nchar(a[1])) c1 <- sapply(thesplit, function(a) a[1]) c1 <- strsplit(c1, "") for(i in seq(along=c1)) c1[[i]] <- as.numeric(paste(match(c1[[i]], taxa), collapse="")) c1 <- unlist(c1) partitions[order(n1, c1)] } # end of phyloqtl_util.R qtl/R/interpPositions.R0000644000176200001440000000620112770016226014611 0ustar liggesusers##################################################################### # # interpPositions.R # # copyright (c) 2011-2012, Karl W Broman # last modified Mar, 2012 # first written Nov, 2011 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Takes an "oldmap" (e.g., a physical map in bp or Mbp) # and a "newmap" (e.g., a genetic map in cM) # take additional positions in the "oldmap" scale and estimate # the corresponding positions (by interpolation or extrapolation) # in the "newmap" scale ###################################################################### # oldmap and newmap in "map" format (list of vectors of positions) # oldpositions as dataframe with $chr and $pos interpPositions <- function(oldpositions, oldmap, newmap) { orig.rownames <- rownames(oldpositions) # not sure why this is necessary, but it avoids a bug if(is.null(rownames(oldpositions))) rownames(oldpositions) <- paste("temprn", 1:nrow(oldpositions), sep="") else rownames(oldpositions) <- paste("temprn", rownames(oldpositions), sep="") oldchrnum <- match(oldpositions$chr, names(oldmap)) newchrnum <- match(oldpositions$chr, names(newmap)) missingchr <- is.na(oldchrnum) | is.na(newchrnum) if(any(missingchr)) warning("Chromosomes ", paste(sort(unique(oldpositions$chr[missingchr])), collapse=", "), " not found") newpositions <- cbind(oldpositions, newpos=rep(NA, nrow(oldpositions))) u <- unique(oldchrnum) for(i in seq(along=u)) { # loop over chromosomes chrnam <- names(oldmap)[u[i]] # name of chromosome # the positions to be interpolated wholdpositions <- !missingchr & oldchrnum==u[i] theposnames <- rownames(oldpositions)[wholdpositions] if(!any(wholdpositions)) next # data frame with oldmap positions for this chromosome tempoldmap <- oldmap[[u[i]]] tempoldmap.df <- data.frame(chr=rep(chrnam, length(tempoldmap)), pos=as.numeric(tempoldmap)) rownames(tempoldmap.df) <- names(tempoldmap) # add the positions to be interpolated tempoldmap.df <- rbind(tempoldmap.df, oldpositions[wholdpositions,,drop=FALSE]) tempoldmap.df <- tempoldmap.df[order(tempoldmap.df$pos),,drop=FALSE] tempoldmap.df$chr <- as.character(tempoldmap.df$chr) # do the interpolation result <- interpmap(tempoldmap.df, newmap[chrnam]) # paste in the interpolated positions newpositions[theposnames, "newpos"] <- result[theposnames, "pos"] } rownames(newpositions) <- orig.rownames newpositions } # end of interpPositions.R qtl/R/transformPheno.R0000644000176200001440000000355512770016226014416 0ustar liggesusers##################################################################### # # transformPheno.R # # Copyright (c) 2009, Danny Arends # # Modified by Karl Broman # # # first written Februari 2009 # last modified April 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: transformPheno # ##################################################################### transformPheno <- function(cross, pheno.col=1, transf=log, ...) { #Helperfunction to transform a specific phenotype specified by the pheno.col parameter # by default, a log transformation is used, though one may use any function if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num))>1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") for(i in pheno.col) cross$pheno[,i] <- transf(cross$pheno[,i], ...) cross } # end of transformPheno.R qtl/R/markerlrt.R0000644000176200001440000000361613576241200013407 0ustar liggesusers###################################################################### # # markerlrt.R # # copyright (c) 2010-2019, Karl W Broman # last modified Dec, 2019 # first written Jul, 2010 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: markerlrt # ###################################################################### ###################################################################### # # markerlrt: General likelihood ratio test to assess linkage between # all pairs of markers # ###################################################################### markerlrt <- function(cross) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") Geno <- pull.geno(cross) Geno[is.na(Geno)] <- 0 maxg <- max(as.numeric(Geno)) n.ind <- nrow(Geno) n.mar <- ncol(Geno) mar.names <- colnames(Geno) z <- .C("R_markerlrt", as.integer(n.ind), # number of individuals as.integer(n.mar), # number of markers as.integer(Geno), as.integer(maxg), # maximum observed genotype lod = as.double(rep(0,n.mar*n.mar)), PACKAGE="qtl") cross$rf <- matrix(z$lod,ncol=n.mar) dimnames(cross$rf) <- list(mar.names,mar.names) attr(cross$rf, "onlylod") <- TRUE cross } # end of markerlrt.R qtl/R/scanonevar.varperm.R0000644000176200001440000001056113576241200015213 0ustar liggesusers# scanonevar.varperm # single-QTL genome scan for QTL affecting variance # with code from Lars Ronnegard scanonevar.varperm <- function(cross, pheno.col=1, mean_covar = NULL, var_covar = NULL, maxit = 25 , tol=1e-6, n.var.perm = 2, seed = 27517, quiet=TRUE) { set.seed(seed) # check input crosstype <- crosstype(cross) if(!(crosstype %in% c("bc", "dh", "f2", "haploid", "risib", "riself"))) stop('scanonevar not implemented for cross type "', crosstype, '"') chr_type <- sapply(cross$geno, chrtype) if(any(chr_type=="X")) { warning("Analysis of X chromosome not implemented for scanonevar; omitted.") cross <- subset(cross, chr=(chr_type != "X")) } # grab phenotype # if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { # cross$pheno <- cbind(pheno.col, cross$pheno) # pheno.col <- 1 # } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(is.matrix(pheno) && ncol(pheno) > 1) { pheno <- pheno[,1] warning('scanonevar requires a single phenotype; all but "', phenames(cross)[pheno.col[1]], '" omitted.') } N <- length(pheno) # No. individuals n.chr <- nchr(cross) #No. chromosomes chr.names <- chrnames(cross) # need to run calc.genoprob? if(!("prob" %in% names(cross$geno[[1]]))) { warning("First running calc.genoprob") cross <- calc.genoprob(cross) } scan.logPm <- scan.logPd <- chr.names.out <- NULL # set up data and formulas X <- cbind(pheno=pheno, mean.add=rep(0, length(pheno)), var.add=rep(0, length(pheno))) mean_formula <- "pheno ~ mean.add" var_formula <- "~ var.add" if(!is.null(mean_covar)) { ncolX <- ncol(X) X <- cbind(X, mean_covar) meancovarnames <- paste0("meancov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- meancovarnames mean_formula <- paste(mean_formula, "+", paste(meancovarnames, collapse="+")) } if(!is.null(var_covar)) { ncolX <- ncol(X) X <- cbind(X, var_covar) varcovarnames <- paste0("varcov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- varcovarnames var_formula <- paste(var_formula, "+", paste(varcovarnames, collapse="+")) } X <- as.data.frame(X) mean_formula <- as.formula(mean_formula) var_formula <- as.formula(var_formula) max.var.neglog.ps <- rep(NA, n.var.perm) for(perm.num in 1:n.var.perm) { result <- NULL for(j in seq(along=cross$geno)) { # loop over chromosomes if(!quiet) message(" - Chr ", chr.names[j]) if (crosstype=="f2") { g11 <- cross$geno[[j]]$prob[,,1] g12 <- cross$geno[[j]]$prob[,,2] g13 <- cross$geno[[j]]$prob[,,3] a1 <- g11 + g12/2 d1 <- g12 - (g11+g13)/2 } else { a1 <- cross$geno[[j]]$prob[,,1] } n.loci <- dim(a1)[2] logP.m <- logP.d <- numeric(n.loci) for(i in 1:n.loci) { # loop over positions within chromosome # fill in genotype probs for this locus X$mean.add <- a1[,i] X$var.add <- sample(a1[,i]) d.fit <- DGLM_norm(m.form=mean_formula, d.form=var_formula, indata=X, maxiter=maxit, conv=tol) p.mean <- summary(d.fit$mean)$coef[2,4] p.disp<- summary(d.fit$disp)$coef[2,4] if (d.fit$iter < maxit) { logP.m[i]<- -log10(p.mean) logP.d[i]<- -log10(p.disp) } else { logP.m[i]<- -log10(p.mean) logP.d[i]<- 0 warning("dglm did not converge on chr", chr.names[j], " position ", i) } } max.var.neglog.ps[perm.num] <- max(max.var.neglog.ps[perm.num], logP.d, na.rm = TRUE) } } return(max.var.neglog.ps) } qtl/R/mqmscan.R0000644000176200001440000004640413576241200013045 0ustar liggesusers##################################################################### # # mqmscan.R # # Copyright (c) 2009-2019, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified Dec 2019 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmscan # # ##################################################################### ###################################################################### # # mqmscan: main scanning function to the mqmpackage # ###################################################################### mqmscan <- function(cross,cofactors=NULL,pheno.col=1,model=c("additive","dominance"),forceML=FALSE, cofactor.significance=0.02,em.iter=1000,window.size=25.0,step.size=5.0,logtransform = FALSE, estimate.map = FALSE,plot=FALSE,verbose=FALSE, outputmarkers=TRUE, multicore=TRUE, batchsize=10, n.clusters=1, test.normality=FALSE,off.end=0) { start <- proc.time() model <- match.arg(model) # omit X chromosome cross <- omit_x_chr(cross) #Because iirc we cannot pass booleans from R to C if(forceML){ forceML <- 1 #1 -> Maximum Likelyhood }else{ forceML <- 0 #0 -> Restricted Maximum Likelyhood } dominance <- 0 #We code :0 -> Additive model (no_dominance) if(model=="dominance"){ dominance <- 1 #and 1 -> Dominance model } if(estimate.map){ estimate.map <- 1 }else{ estimate.map <- 0 } n.run <- 0 if(is.null(cross)){ stop("No cross file. Please supply a valid cross object.") } crosstype <- crosstype(cross) if(crosstype == "f2" || crosstype == "bc" || crosstype == "riself"){ if(crosstype == "f2"){ ctype = 1 } if(crosstype == "bc" || crosstype=="dh" || crosstype=="haploid"){ ctype = 2 } if(crosstype == "riself") { ctype = 3 # check genotypes g <- as.numeric(pull.geno(cross)) g <- sort(unique(g[!is.na(g)])) if(max(g)==2) { # convert genotypes from 1/2 to 1/3 for(i in seq(along=cross$geno)) cross$geno[[i]]$data[!is.na(cross$geno[[i]]$data) & cross$geno[[i]]$data==2] <- 3 } } n.ind <- nind(cross) n.chr <- nchr(cross) if(verbose) { cat("INFO: Received a valid cross file type:",crosstype,".\n") cat("INFO: Number of individuals: ",n.ind,"\n") cat("INFO: Number of chromosomes: ",n.chr,"\n") } savecross <- cross geno <- NULL chr <- NULL dist <- NULL newcmbase <- NULL out.qtl <- NULL for(i in 1:n.chr) { #We always shift the marker positions to 0 geno <- cbind(geno,cross$geno[[i]]$data) chr <- c(chr,rep(i,dim(cross$geno[[i]]$data)[2])) newcmbase = c(newcmbase,min(cross$geno[[i]]$map)) cross$geno[[i]]$map <- cross$geno[[i]]$map-(min(cross$geno[[i]]$map)) dist <- c(dist,cross$geno[[i]]$map) } if(cofactor.significance <=0 || cofactor.significance >= 1){ stop("cofactor.significance must be between 0 and 1.\n") } if(any(is.na(geno))){ stop("Missing genotype information, please estimate unknown data, before running mqmscan.\n") } if(missing(cofactors)) cofactors <- rep(0,sum(nmar(cross))) numcofold <- sum(cofactors) cofactors <- checkdistances(cross,cofactors,1) numcofnew <- sum(cofactors) if(numcofold!=numcofnew){ cat("INFO: Removed ",numcofold-numcofnew," cofactors that were close to eachother\n") } #Convert phenotypes from character to numeric pheno.col = stringPhenoToInt(cross,pheno.col) if (length(pheno.col) > 1){ cross$pheno <- cross$pheno[,pheno.col] #Scale down the triats result <- mqmscanall( cross,cofactors=cofactors,forceML=forceML,model=model, cofactor.significance=cofactor.significance,step.size=step.size,window.size=window.size, logtransform=logtransform, estimate.map = estimate.map,plot=plot, verbose=verbose,n.clusters=n.clusters,batchsize=batchsize) return(result) } if(pheno.col != 1){ if(verbose) { cat("INFO: Selected phenotype ",pheno.col,".\n") cat("INFO: Number of phenotypes in object ",nphe(cross),".\n") } if(nphe(cross) < pheno.col || pheno.col < 1){ stop("No such phenotype in cross object.\n") } } if(test.normality && !mqmtestnormal(cross, pheno.col, 0.01, FALSE)){ warning("Trait might not be normal (Shapiro normality test)\n") } pheno <- cross$pheno[,pheno.col] phenovar = var(pheno,na.rm = TRUE) if(phenovar > 1000){ if(!logtransform){ if(verbose) cat("INFO: Before LOG transformation Mean:",mean(pheno,na.rm = TRUE),"variation:",var(pheno,na.rm = TRUE),".\n") #warning(paste("WARNING: Set needs Log-transformation? (var=",phenovar,"), use mqmscan with logtransform=TRUE")) } } if(logtransform){ #transform the cross file cross <- transformPheno(cross,pheno.col,transf=log) pheno <- cross$pheno[,pheno.col] } n.mark <- ncol(geno) if(verbose) cat("INFO: Number of markers:",n.mark,"\n") #check for missing phenotypes dropped <- NULL droppedIND <- NULL for(i in 1:length(pheno)) { if(is.na(pheno[i]) || is.infinite(pheno[i])){ if(verbose) cat("INFO: Dropped individual ",i," with missing phenotype.\n") dropped <- c(dropped,i) if(!is.null(cross$mqm)){ droppedIND <- c(droppedIND,cross$mqm$augIND[i]) } n.ind = n.ind-1 } } #Throw out missing phenotypes from phenotype vector and genotype matrix if(!is.null(dropped)){ geno <- geno[-dropped,] pheno <- pheno[-dropped] } #CHECK for previously augmented dataset if(!is.null(cross$mqm)){ augmentedNind <- cross$mqm$Nind augmentedInd <- cross$mqm$augIND if(verbose){ cat("n.ind:",n.ind,"\n") cat("augmentedNind:",augmentedNind,"\n") cat("length(augmentedInd):",length(augmentedInd),"\n") } if(!is.null(dropped)){ augmentedInd <- cross$mqm$augIND[-dropped] augmentedInd[1] <- 0 for(x in 1:(length(augmentedInd)-1)){ if(augmentedInd[x+1] - 1 > augmentedInd[x] ){ for(y in (x+1):length(augmentedInd)){ augmentedInd[y] <- augmentedInd[y] - ((augmentedInd[x+1] - augmentedInd[x])-1) } } } } augmentedNind <- length(unique(augmentedInd)) if(verbose){ cat("New augmentedNind:",augmentedNind,"\n") cat("New length(augmentedInd):",length(augmentedInd),"\n") } }else{ #No augmentation augmentedNind <- n.ind augmentedInd <- 0:n.ind } #CHECK if we have cofactors, so we can do backward elimination backward <- 0; if(missing(cofactors)){ if(verbose) cat("INFO: No cofactors, setting cofactors to 0\n") cofactors = rep(0,n.mark) }else{ if(length(cofactors) != n.mark){ if(verbose) cat("ERROR: # Cofactors != # Markers\n") }else{ if(verbose) cat("INFO:",sum(cofactors!=0),"Cofactors received to be analyzed\n") if((sum(cofactors) > n.ind-10 && dominance==0)){ stop("Cofactors don't look okay for use without dominance\n") } if((sum(cofactors)*2 > n.ind-10 && dominance==1)){ stop("Cofactors don't look okay for use with dominance\n") } if(sum(cofactors) > 0){ if(verbose) cat("INFO: Doing backward elimination of selected cofactors.\n") backward <- 1; n.run <- 0; }else{ backward <- 0; cofactors = rep(0,n.mark) } } } step.min = -off.end; step.max = max(dist)+step.size+off.end; step.max <- as.integer(ceiling((step.max+step.size)/step.size)*step.size) if((step.min+step.size) > step.max){ stop("step.max needs to be >= step.min + step.size") } # cat("Step.min:",step.min," Step.max:",step.max,"\n") if(step.size < 1){ stop("step.size needs to be >= 1") } qtlAchromo <- length(seq(step.min,step.max,step.size)) if(verbose) cat("INFO: Number of locations per chromosome: ",qtlAchromo, "\n") end.1 <- proc.time() result <- .C("R_mqmscan", as.integer(n.ind), as.integer(n.mark), as.integer(1), # 1 phenotype as.integer(geno), as.integer(chr), DIST=as.double(dist), as.double(pheno), COF=as.integer(cofactors), as.integer(backward), as.integer(forceML), as.double(cofactor.significance), as.integer(em.iter), as.double(window.size), as.double(step.size), as.double(step.min), as.double(step.max), as.integer(n.run), as.integer(augmentedNind), as.integer(augmentedInd), QTL=as.double(rep(0,2*n.chr*qtlAchromo)), as.integer(estimate.map), as.integer(ctype), as.integer(dominance), as.integer(verbose), PACKAGE="qtl") end.2 <- proc.time() # initialize output object qtl <- NULL info <- NULL names <- NULL for(i in 1:(n.chr*qtlAchromo)) { #Store the result in the qtl object qtl <- rbind(qtl,c(ceiling(i/qtlAchromo),rep(seq(step.min,step.max,step.size),n.chr)[i],result$QTL[i])) info <- rbind(info,result$QTL[(n.chr*qtlAchromo)+i]) #make names in the form: cX.locXX names <- c(names,paste("c",ceiling(i/qtlAchromo),".loc",rep(seq(step.min,step.max,step.size),n.chr)[i],sep="")) } if(estimate.map){ new.map <- pull.map(cross) chrmarkers <- nmar(cross) sum <- 1 for(i in 1:length(chrmarkers)) { for(j in 1:chrmarkers[[i]]) { new.map[[i]][j] <- result$DIST[sum] sum <- sum+1 } } } if(plot){ if(estimate.map && backward){ op <- par(mfrow = c(3,1)) }else{ if(estimate.map || backward){ op <- par(mfrow = c(2,1)) }else{ op <- par(mfrow = c(1,1)) } } if(estimate.map){ if(verbose) cat("INFO: Viewing the user supplied map versus genetic map used during analysis.\n") plotMap(pull.map(cross), new.map,main="Supplied map versus re-estimated map") } } if(backward){ if(!estimate.map){ new.map <- pull.map(cross) } chrmarkers <- nmar(cross) mapnames <- NULL for(x in 1:nchr(cross)){ mapnames <- c(mapnames,names(pull.map(cross)[[x]])) } sum <- 1 model.present <- 0 qc <- NULL qp <- NULL qn <- NULL for(i in 1:length(chrmarkers)) { for(j in 1:chrmarkers[[i]]) { #cat("INFO ",sum," ResultCOF:",result$COF[sum],"\n") if(result$COF[sum] != 48){ if(verbose) cat("MODEL: Marker",sum,"named:", strsplit(names(unlist(new.map)),".",fixed=TRUE)[[sum]][2],"from model found, CHR=",i,",POSITION=",as.double(unlist(new.map)[sum])," cM\n") qc <- c(qc, as.character(names(cross$geno)[i])) qp <- c(qp, as.double(unlist(new.map)[sum])) qn <- c(qn, mapnames[sum]) model.present <- 1 } sum <- sum+1 } } if(!is.null(qc) && model.present){ why <- sim.geno(savecross,n.draws=1) QTLmodel <- makeqtl(why, qc, qp, qn, what="draws") attr(QTLmodel,"mqm") <- 1 if(plot) plot(QTLmodel) } } rownames(qtl) <- names qtl <- cbind(qtl,1/(min(info))*(info-min(info))) qtl <- cbind(qtl,1/(min(info))*(info-min(info))*qtl[,3]) colnames(qtl) = c("chr","pos (cM)",paste("LOD",colnames(cross$pheno)[pheno.col]),"info","LOD*info") #Convert to data/frame and scanone object so we can use the standard plotting routines qtl <- as.data.frame(qtl, stringsAsFactors=TRUE) if(backward && !is.null(qc) && model.present){ attr(qtl,"mqmmodel") <- QTLmodel cimcovar <- as.data.frame(cbind(as.numeric(attr(qtl,"mqmmodel")[[4]]),as.data.frame(attr(qtl,"mqmmodel")[[5]])), stringsAsFactors=TRUE) rownames(cimcovar) <- attr(qtl,"mqmmodel")[[2]] colnames(cimcovar) <- c("chr","pos") attr(qtl, "marker.covar.pos") <- cimcovar } class(qtl) <- c("scanone",class(qtl)) if(outputmarkers){ #Remove pseudomarkers from the dataset and scale to the chromosome #Somewhat longer then off-end to be able to put back the original markers for( x in 1:nchr(cross)){ to.remove <- NULL chr.length <- max(cross$geno[[x]]$map) markers.on.chr <- which(qtl[,1]==x) to.remove <- markers.on.chr[which(qtl[markers.on.chr,2] > chr.length+off.end+(2*step.size))] to.remove <- c(to.remove,markers.on.chr[which(qtl[markers.on.chr,2] < -off.end)]) if(length(to.remove) > 0) qtl <- qtl[-to.remove,] } qtl <- addmarkerstointervalmap(cross,qtl) qtl <- as.data.frame(qtl, stringsAsFactors=TRUE) if(backward && !is.null(qc) && model.present){ attr(qtl,"mqmmodel") <- QTLmodel cimcovar <- as.data.frame(cbind(as.numeric(attr(qtl,"mqmmodel")[[4]]),as.data.frame(attr(qtl,"mqmmodel")[[5]])), stringsAsFactors=TRUE) rownames(cimcovar) <- attr(qtl,"mqmmodel")[[2]] colnames(cimcovar) <- c("chr","pos") attr(qtl, "marker.covar.pos") <- cimcovar } class(qtl) <- c("scanone",class(qtl)) } #Now we handle the off-end and any shifts comming from that (newcmbase) #We didn't thow away the old names, and could thus get duplicates qtlnew <- qtl rownames(qtlnew) <- paste0("qtlnew_X", 1:nrow(qtl)) oldnames <- rownames(qtl) for(x in 1:n.chr){ #Do per chromosome markers.on.chr <- which(qtl[,1]==x) if(newcmbase[x] !=0 && nrow(qtl[markers.on.chr,]) > 0){ qtl[markers.on.chr,2] <- qtl[markers.on.chr,2]+newcmbase[x] #We end up with 3 posibilities for(n in 1:nrow(qtl[markers.on.chr,])){ name <- rownames(qtl[markers.on.chr,])[n] id <- which(name==oldnames) if(!is.na(name) && grepl(".loc",name,fixed=TRUE)){ #a marker we need to shift rownames(qtlnew)[id] <- paste(strsplit(name,".loc",fixed=TRUE)[[1]][1],".loc",qtlnew[id,2],sep="") }else{ #a marker with a user defined name, no need to shift rownames(qtlnew)[id] <- name } } }else{ #No shift for the chromosome so we don't have to worry about shifting rownames(qtlnew)[markers.on.chr] <- rownames(qtl)[markers.on.chr] } } qtl <- qtlnew for( x in 1:nchr(cross)){ #Remove the off ends that we left hanging a step before if(chrtype(cross$geno[[x]])!="X"){ to.remove <- NULL chr.length <- max(cross$geno[[x]]$map) markers.on.chr <- which(qtl[,1]==x) to.remove <- markers.on.chr[which(qtl[markers.on.chr,2] > chr.length+off.end)] to.remove <- c(to.remove,markers.on.chr[which(qtl[markers.on.chr,2] < -off.end)]) qtl <- qtl[-to.remove,] } } qtl[,1] <- factor(names(cross$geno)[qtl[,1]], levels=names(cross$geno)) #Plot the results if the user asked for it if(plot){ info.c <- qtl #Check for errors in the information content IF err we can't do a second plot e <- 0 for(i in 1:ncol(qtl)){ if(is.na(info.c[i,5])){ e<- 1 } if(is.infinite(info.c[i,5])){ e<- 1 } if(is.null(info.c[i,5])){ e<- 1 } } #No error do plot 2 if(!e){ mqmplot.singletrait(qtl,main=paste(colnames(cross$pheno)[pheno.col],"at significance=",cofactor.significance)) }else{ plot(qtl,main=paste(colnames(cross$pheno)[pheno.col],"at significance=",cofactor.significance),lwd=1) grid(max(qtl$chr),5) labels <- paste("QTL",colnames(cross$pheno)[pheno.col]) legend("topright", labels,col=c("black"),lty=c(1)) } op <- par(mfrow = c(1,1)) } end.3 <- proc.time() if(verbose) cat("INFO: Calculation time (R->C,C,C-R): (",round((end.1-start)[3], digits=3), ",",round((end.2-end.1)[3], digits=3),",",round((end.3-end.2)[3], digits=3),") (in seconds)\n") qtl }else{ stop("Currently only F2, BC, and selfed RIL crosses can be analyzed by MQM.") } } # end of mqmscan.R qtl/R/plot.scantwo.R0000644000176200001440000003533613576241200014043 0ustar liggesusers###################################################################### # # plot.scantwo.R # # copyright (c) 2001-2019, Karl W Broman, Hao Wu and Brian Yandell # last modified Dec, 2019 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Hao Wu (The Jackson Lab) wrote the initial code # # Part of the R/qtl package # Contains: plot.scantwo # ###################################################################### plot.scantwo <- function(x, chr, incl.markers = FALSE, zlim, lodcolumn=1, lower = c("full", "add", "cond-int", "cond-add", "int"), upper = c("int", "cond-add", "cond-int", "add", "full"), nodiag = TRUE, contours = FALSE, main, zscale = TRUE, point.at.max=FALSE, col.scheme = c("viridis", "redblue","cm","gray","heat","terrain","topo"), gamma=0.6, allow.neg=FALSE, alternate.chrid=FALSE, ...) { if(!inherits(x, "scantwo")) stop("Input should have class \"scantwo\".") col.scheme <- match.arg(col.scheme) if(length(dim(x$lod)) > 2) { # results from multiple phenotypes if(length(lodcolumn) > 1) { warning("Argument lodcolumn should be of length 1.") lodcolumn <- lodcolumn[1] } if(lodcolumn < 0 || lodcolumn > dim(x$lod)[3]) stop("Argument lodcolumn misspecified.") x$lod <- x$lod[,,lodcolumn] } if(!missing(chr)) x <- subset(x, chr=chr) if(nrow(x$lod)==0) { warning("Empty scantwo object.") return(invisible(NULL)) } chr <- as.character(unique(x$map[,1])) addpair <- attr(x, "addpair") if(!is.null(addpair) && addpair) { lower <- "full" upper <- "add" if(missing(zlim)) { if(allow.neg) zlim <- rep(max(abs(x$lod), na.rm=TRUE), 2) else zlim <- rep(max(x$lod, na.rm=TRUE), 2) } addpair <- TRUE } else addpair <- FALSE if(length(lower)==1 && lower == "fv1") lower <- "cond-int" if(length(lower)==1 && lower == "av1") lower <- "cond-add" if(length(upper)==1 && upper == "fv1") upper <- "cond-int" if(length(upper)==1 && upper == "av1") upper <- "cond-add" lower <- match.arg(lower) upper <- match.arg(upper) if(!any(class(x) == "scantwo")) stop("Input variable is not an object of class scantwo!") lod <- x$lod map <- x$map # backward compatibility for previous version of R/qtl if(!("scanoneX" %in% names(x))) { warning("It would be best to re-run scantwo() with the R/qtl version 0.98 or later.\n") scanoneX <- NULL } else scanoneX <- x$scanoneX # if incl.markers is FALSE, drop positions # for which third column of map is 0 if(!incl.markers && any(map[, 3] == 0)) { o <- (map[, 3] == 1) lod <- lod[o, o] map <- map[o, ] if(!is.null(scanoneX)) scanoneX <- scanoneX[o] } if(all(diag(lod) < 1e-14) && (lower == "cond-int" || lower=="cond-add") ) stop("Need to run scantwo with run.scanone=TRUE.") oldlod <- lod lo <- lower.tri(lod) up <- upper.tri(lod) # grab the interaction LOD scores if(upper=="int") lod[up] <- t(oldlod)[up] - oldlod[up] if(lower=="int") lod[lo] <- oldlod[lo] - t(oldlod)[lo] if(lower=="add") lod[lo] <- t(oldlod)[lo] if(upper=="full") lod[up] <- t(oldlod)[up] # get conditional LOD scores if(lower=="cond-int" || lower=="cond-add") { if(lower=="cond-add") lod[lo] <- t(oldlod)[lo] thechr <- map$chr uchr <- unique(thechr) thechr <- factor(as.character(thechr), levels=as.character(uchr)) uchr <- factor(as.character(uchr), levels=levels(thechr)) xchr <- tapply(map$xchr, thechr, function(a) a[1]) maxo <- tapply(diag(lod), thechr, max, na.rm=TRUE) if(any(xchr) && !is.null(scanoneX)) { maxox <- tapply(scanoneX, thechr, max, na.rm=TRUE) maxo[xchr] <- maxox[xchr] } n.chr <- length(chr) for(i in 1:n.chr) { pi <- which(thechr==uchr[i]) for(j in i:n.chr) { pj <- which(thechr==uchr[j]) temp <- lod[pj,pi] - max(maxo[c(i,j)]) temp[!is.na(temp) & temp<0] <- 0 if(i==j) lod[pj,pi][lower.tri(temp)] <- temp[lower.tri(temp)] else lod[pj,pi] <- temp } } } if(upper=="cond-int" || upper=="cond-add") { if(upper=="cond-int") lod[up] <- t(oldlod)[up] thechr <- map$chr uchr <- unique(thechr) thechr <- factor(as.character(thechr), levels=as.character(uchr)) uchr <- factor(as.character(uchr), levels=levels(thechr)) xchr <- tapply(map$xchr, thechr, function(a) a[1]) maxo <- tapply(diag(lod), thechr, max, na.rm=TRUE) if(any(xchr) && !is.null(scanoneX)) { maxox <- tapply(scanoneX, thechr, max, na.rm=TRUE) maxo[xchr] <- maxox[xchr] } n.chr <- length(chr) for(i in 1:n.chr) { pi <- which(thechr==uchr[i]) for(j in i:n.chr) { pj <- which(thechr==uchr[j]) temp <- lod[pi,pj] - max(maxo[c(i,j)]) temp[!is.na(temp) & temp<0] <- 0 if(i==j) lod[pi,pj][upper.tri(temp)] <- temp[upper.tri(temp)] else lod[pi,pj] <- temp } } } if(nodiag) diag(lod) <- 0 # deal with bad LOD score values if(any(is.na(lod))) { u <- is.na(lod) n <- sum(u) warning(n, " LOD scores NA, set to 0") lod[u] <- 0 } if(!allow.neg && any(!is.na(lod) & lod < -1e-6)) { u <- !is.na(lod) & lod < 0 n <- sum(u) warning(n, " LOD scores <0, set to 0") lod[u] <- 0 } if(any(!is.na(lod) & lod == Inf)) { u <- !is.na(lod) & lod == Inf n <- sum(u) warning(n, " LOD scores =Inf, set to maximum observed value") lod[u] <- max(lod[!is.na(lod) & lod < Inf]) } if(missing(zlim)) { # no given zlim # calculate the zlim for interactive and full LODs if(allow.neg) { zlim.int <- max(abs(lod[row(lod) < col(lod)])) zlim.jnt <- max(abs(lod[row(lod) >= col(lod)])) } else { zlim.int <- max(lod[row(lod) < col(lod)]) zlim.jnt <- max(lod[row(lod) >= col(lod)]) } } else { zlim.jnt <- zlim[1] if(length(zlim) < 2) zlim.int <- zlim[1] else zlim.int <- zlim[2] } # rescale the data in upper triangle based on zlims.jnt lod[row(lod) < col(lod)] <- lod[row(lod) < col(lod)] * zlim.jnt/zlim.int # make sure LOD values are below (0,zlim.jnt) or update zlim.jnt # if(max(lod) > zlim.jnt) { # warning("LOD values out of range; updating zlim.") # temp <- max(lod) # zlim.int <- zlim.int * temp/zlim.jnt # zlim.jnt <- temp # } # save old par parameters, to restore them on exit if(zscale) { old.mar <- par("mar") old.mfrow <- par("mfrow") old.las <- par("las") on.exit(par(las = old.las, mar = old.mar, mfrow = old.mfrow)) } else { old.las <- par("las") on.exit(par(las = old.las)) } par(las = 1) dots <- list(...) if(zscale) { if("layout" %in% names(dots)) layout(dots[["layout"]][[1]],dots[["layout"]][[2]]) else layout(cbind(1, 2), c(6, 1)) if("mar1" %in% names(dots)) par(mar=dots[["mar1"]]) else par(mar = c(5, 4, 4, 2) + 0.1) } if( gamma < 0 && col.scheme == "redblue") stop( "gamma must be non-negative" ) cols <- switch(col.scheme, gray = if( gamma <= 0) rev(gray(seq(0,1,len=256))) else rev(gray(log(seq(1,exp(gamma),len=256))/gamma)), heat = heat.colors(256), terrain = terrain.colors(256), topo = topo.colors(256), cm = cm.colors(256), redblue = rev(rainbow(256, start = 0, end = 2/3)), viridis = viridis_qtl(256) ) if(col.scheme=="redblue") { # convert colors using gamma=0.6 (which will no longer be available in R) rgbval <- (col2rgb(cols)/255)^0.6 cols <- rgb(rgbval[1,], rgbval[2,], rgbval[3,]) } if(allow.neg) { lo <- -zlim.jnt lo.int <- -zlim.int } else lo.int <- lo <- 0 if("xlab" %in% names(dots)) { xlab <- dots$xlab if("ylab" %in% names(dots)) ylab <- dots$ylab else ylab <- xlab } else { if("ylab" %in% names(dots)) xlab <- ylab <- dots$ylab else { if(length(chr) > 1) xlab <- ylab <- "Chromosome" else xlab <- ylab <- "Location (cM)" } } if(length(chr) > 1) image(1:ncol(lod), 1:nrow(lod), lod, ylab = ylab, xlab = xlab, zlim = c(lo, zlim.jnt), col = cols, xaxt = "n", yaxt = "n") else image(map[,2], map[,2], lod, ylab = ylab, xlab = xlab, zlim = c(lo, zlim.jnt), col = cols) # plot point at maximum, if requested if(point.at.max) { temp <- lod temp[upper.tri(temp)] <- -50 temp[diag(temp)] <- -50 wh <- which(temp == max(temp), arr.ind=TRUE) if(length(chr) > 1) points(wh,rev(wh),pch=4,lwd=2) else { points(map[wh[,1],2],map[wh[,2],2],pch=4,lwd=2,col="blue") points(map[wh[,2],2],map[wh[,1],2],pch=4,lwd=2,col="blue") } } # add contours if requested if(any(contours > 0)) { if(is.logical(contours)) contours = 1.5 tmp = lod tmp[row(lod) < col(lod)] <- NA if(length(chr) > 1) thepos <- 1:ncol(lod) else thepos <- map[,2] contour(thepos, thepos, tmp, add = TRUE,drawlabels=FALSE, levels = max(tmp,na.rm=TRUE) - contours, col = "blue", lwd = 2) tmp = lod tmp[row(lod) > col(lod)] <- NA contour(thepos, thepos, tmp, add = TRUE,drawlabels=FALSE, levels = max(tmp,na.rm=TRUE) - contours * zlim.jnt/zlim.int, col = "blue", lwd = 2) } if(length(chr) > 1) { # calculate how many markers in each chromesome n.mar <- NULL for(i in 1:length(chr)) n.mar[i] <- sum(map[, 1] == chr[i]) # plot lines at the chromosome boundaries if(length(chr) > 1) wh <- c(0.5, cumsum(n.mar) + 0.5) abline(v = wh, xpd = FALSE) abline(h = wh, xpd = FALSE) # add chromesome numbers a <- par("usr") placement <- (wh[-1] + wh[-length(wh)])/2 if(!alternate.chrid || length(chr)<2) { for(i in 1:length(chr)) { axis(side=1, at=placement[i], labels=chr[i]) axis(side=2, at=placement[i], labels=chr[i]) } } else { odd <- seq(1, length(chr), by=2) even <- seq(2, length(chr), by=2) for(i in odd) { axis(side=1, at=placement[i], labels="") axis(side=2, at=placement[i], labels="") axis(side=1, at=placement[i], labels=chr[i], line=-0.4, tick=FALSE) axis(side=2, at=placement[i], labels=chr[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=1, at=placement[i], labels="") axis(side=2, at=placement[i], labels="") axis(side=1, at=placement[i], labels=chr[i], line=+0.4, tick=FALSE) axis(side=2, at=placement[i], labels=chr[i], line=+0.4, tick=FALSE) } } } else { u <- par("usr") abline(v=u[1:2], h=u[3:4]) } # add title if(!missing(main)) title(main = main) if(zscale) { # plot the colormap dots <- list(...) if("mar2" %in% names(dots)) par(mar=dots[["mar2"]]) else par(mar = c(5, 2, 4, 2) + 0.1) colorstep <- (zlim.jnt-lo)/255 image(x = 1:1, y = seq(lo, zlim.jnt, colorstep), z = matrix(1:256, 1, 256), zlim = c(1, 256), ylab = "", xlab = "", xaxt = "n", yaxt = "n", col = cols) # make sure there's a box around it u <- par("usr") abline(v = u[1:2], xpd = FALSE) abline(h = u[3:4], xpd = FALSE) if(any(contours) > 0) { for(i in seq(length(contours))) { segments(mean(u[1:2]), max(lod[row(lod) > col(lod)]) - contours[i], u[2], max(lod[row(lod) > col(lod)]) - contours[i], xpd = FALSE, col = "blue", lwd = 2) segments(u[1], max(lod[row(lod) < col(lod)]) - contours[i] * zlim.jnt/zlim.int, mean(u[1:2]), max(lod[row(lod) < col(lod)]) - contours[i] * zlim.jnt / zlim.int, xpd = FALSE, col = "blue", lwd = 2) } } # figure out how big the axis labels should be fin <- par("fin")[1] # figure width in inches pin <- par("pin")[1] # plot width in inches mai <- par("mai")[2] # margin width in inches # note: pin + 2*mai = fin xlen.mar <- mai/pin * diff(u[1:2]) # axis for full LODs yloc <- pretty(c(lo, zlim.jnt), 4) yloc <- yloc[yloc >= u[3] & yloc <= u[4]] # segments(u[2], yloc, u[2] + xlen.mar/4, yloc, xpd = TRUE) # text(u[2] + xlen.mar/3, yloc, as.character(yloc), xpd = TRUE, adj = 0) axis(side=4, at=yloc, labels=yloc) # axis for int've LODs yloc <- pretty(c(lo.int, zlim.int), 4) yloc.rev <- yloc * zlim.jnt/zlim.int yloc <- yloc[yloc.rev >= u[3] & yloc.rev <= u[4]] yloc.rev <- yloc.rev[yloc.rev >= u[3] & yloc.rev <= u[4]] # segments(u[1], yloc.rev, u[1] - xlen.mar/4, yloc.rev, xpd = TRUE) # text(u[1] - xlen.mar/3, yloc.rev, as.character(yloc), xpd = TRUE, adj = 1) if(!addpair) axis(side=2, at=yloc.rev, labels=yloc) } invisible() } # end of plot.scantwo.R qtl/R/read.cross.karl.R0000644000176200001440000001260613576241200014376 0ustar liggesusers###################################################################### # # read.cross.karl.R # # copyright (c) 2000-2019, Karl W Broman # last modified Dec, 2019 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.karl # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.karl # # read data in Karl's format # ###################################################################### read.cross.karl <- function(dir,genfile,mapfile,phefile) { # create file names if(missing(genfile)) genfile <- "gen.txt" if(missing(mapfile)) mapfile <- "map.txt" if(missing(phefile)) phefile <- "phe.txt" if(!missing(dir) && dir != "") { genfile <- file.path(dir, genfile) mapfile <- file.path(dir, mapfile) phefile <- file.path(dir, phefile) } # read data geno <- as.matrix(read.table(genfile,na.strings="0")) pheno <- as.matrix(read.table(phefile,na.strings="-",header=TRUE)) tempmap <- scan(mapfile, what=character(),quiet=TRUE) # fix up map information # number of chromosomes n.chr <- as.numeric(tempmap[1]) n.mar <- 1:n.chr g <- map <- geno.data <- vector("list", n.chr) cur <- 2 min.mar <- 1 names(g) <- as.character(1:n.chr) for(i in 1:n.chr) { # loop over chromosomes # number of markers n.mar[i] <- as.numeric(tempmap[cur]) cur <- cur+1 # pull out appropriate portion of genotype data geno.data[[i]] <- geno[,min.mar:(min.mar+n.mar[i]-1)] min.mar <- min.mar + n.mar[i] # recombination fractions r <- as.numeric(tempmap[cur:(cur+n.mar[i]-2)]) # convert to cM distances (w/ Kosambi map function) d <- 0.25*log((1+2*r)/(1-2*r))*100 # convert to locations map[[i]] <- round(c(0,cumsum(d)),2) cur <- cur+n.mar[i]-1 # marker names names(map[[i]]) <- tempmap[cur:(cur+n.mar[i]-1)] dimnames(geno.data[[i]]) <- list(NULL, names(map[[i]])) cur <- cur+n.mar[i] g[[i]] <- list(data=geno.data[[i]],map=map[[i]]) # attempt to pull out chromosome number mar.names <- names(map[[i]]) twodig <- grep("[Dd][1-9][0-9][Mm]", mar.names) onedig <- grep("[Dd][1-9][Mm]", mar.names) xchr <- grep("[Dd][Xx][Mm]", mar.names) chr.num <- NULL if(length(twodig) > 0) chr.num <- c(chr.num,substr(mar.names[twodig],2,3)) if(length(onedig) > 0) chr.num <- c(chr.num,substr(mar.names[onedig],2,2)) if(length(xchr) > 0) chr.num <- c(chr.num,rep("X",length(xchr))) # no marker names of the form above if(is.null(chr.num)) { chr.num <- length(mar.names) names(chr.num) <- "1" } else { chr.num <- table(chr.num) } m <- max(chr.num) if(m > sum(chr.num)/2 && m > 1) names(g)[i] <- names(chr.num)[chr.num==m][1] if(names(g)[i] == "X" || names(g)[i] == "x") class(g[[i]]) <- "X" else class(g[[i]]) <- "A" } # check that data dimensions match n.mar1 <- sapply(g,function(a) ncol(a$data)) n.mar2 <- sapply(g,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(g,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { print(c(n.ind1,n.ind2)) stop("Number of individuals in genotypes and phenotypes do not match."); } if(any(n.mar1 != n.mar2)) { print(c(n.mar,n.mar2)) stop("Numbers of markers in genotypes and marker names files do not match."); } # print some information about the amount of data read cat(" --Read the following data:\n"); cat("\t", n.ind1, " individuals\n"); cat("\t", sum(n.mar1), " markers\n"); cat("\t", n.phe, " phenotypes\n"); # add phenotype names, if missing if(is.null(colnames(pheno))) dimnames(pheno) <- list(NULL, paste("phenotype", 1:n.phe,sep="")) # determine map type: f2 or bc or 4way? if(max(geno[!is.na(geno)])<=2) type <- "bc" else if(max(geno[!is.na(geno)])<=5) type <- "f2" else type <- "4way" cross <- list(geno=g,pheno=pheno) class(cross) <- c(type,"cross") # check that nothing is strange in the genotype data if(type=="f2") max.gen <- 5 else if(type=="bc") max.gen <- 2 else max.gen <- 14 u <- unique(geno) if(any(!is.na(u) & (u > max.gen | u < 1))) stop("There are stange values in the genotype data : ", paste(u,collapse=":"), ".") cross$pheno <- as.data.frame(cross$pheno, stringsAsFactors=TRUE) # return cross + indicator of whether to run est.map list(cross,FALSE) } # end of read.cross.karl.R qtl/R/tryallpositions.R0000644000176200001440000004161313576241200014662 0ustar liggesusers###################################################################### # # tryallpositions.R # # copyright (c) 2007-2019, Karl W Broman # last modified Dec, 2019 # first written Oct, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: tryallpositions, markerloglik, allchrsplits # ###################################################################### ###################################################################### # tryallpositions # # Place a given marker in all possible positions on a selected set of # chromosomes, keeping the positions of all other markers fixed, and # evaluate the likelihood and estimate the chromosome length ###################################################################### tryallpositions <- function(cross, marker, chr, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), m=0, p=0, maxit=4000, tol=1e-6, sex.sp=TRUE, verbose=TRUE) { map.function <- match.arg(map.function) if(missing(chr)) chr <- names(cross$geno) else chr <- matchchr(chr, names(cross$geno)) thechr <- find.markerpos(cross, marker)[1,1] if(is.na(thechr)) stop("Marker ", marker, " not found.") markerll <- markerloglik(cross, marker, error.prob) allchr <- names(subset(cross, chr=chr)$geno) results <- NULL for(i in allchr) { if(i == thechr) { # marker already on this chromosome pos <- cross$geno[[i]]$map if(is.matrix(pos)) { pos <- pos[1,] matrixmap <- TRUE } else matrixmap <- FALSE n.mar <- ncol(cross$geno[[i]]$data) if(n.mar == 1) { # this is the only marker pos <- 0 length <- length.male <- 0 llik <- 0 if(verbose) cat(i, pos, llik/log(10), "\n") interval <- "---" } # just this marker else if(n.mar == 2) { # just two markers pos <- 0 themar <- colnames(cross$geno[[i]]$data) initialloglik <- sum(sapply(themar, function(a, b, c) markerloglik(b, a, c), cross, error.prob)) nm <- est.map(cross, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] llik <- attr(nm, "loglik") - initialloglik if(verbose) cat(i, pos, llik/log(10), "\n") if(is.matrix(nm)) { length <- diff(range(nm[1,])) length.male <- diff(range(nm[2,])) } else length <- diff(range(nm)) interval <- "---" } # just two markers else { # >2 markers temp <- drop.markers(cross, marker) pos <- temp$geno[[i]]$map if(is.matrix(pos)) { pos <- pos[1,] matrixmap <- TRUE } else matrixmap <- FALSE pos <- c(min(pos)-10, pos, max(pos)+10) pos <- (pos[-1] + pos[-length(pos)])/2 themarkers <- colnames(temp$geno[[i]]$data) int2 <- c("*", match(themarkers, colnames(cross$geno[[i]]$data)), "*") themarkers <- c("pter", themarkers, "qter") interval <- paste(themarkers[-length(themarkers)], themarkers[-1], sep="-") int2 <- paste("(", int2[-length(int2)], "-", int2[-1], ")", sep="") interval <- paste(interval, int2) initialmap <- est.map(temp, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] initialloglik <- attr(initialmap, "loglik") + markerll llik <- length <- length.male <- rep(NA, length(pos)) for(j in seq(along=pos)) { temp <- movemarker(cross, marker, i, pos[j]) nm <- est.map(temp, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] llik[j] <- attr(nm, "loglik") - initialloglik if(verbose) cat(i, pos[j], llik[j]/log(10), "\n") if(is.matrix(nm)) { length[j] <- diff(range(nm[1,])) length.male[j] <- diff(range(nm[2,])) } else length[j] <- diff(range(nm)) } } # >2 markers } else { # marker not on this chromosome pos <- cross$geno[[i]]$map if(is.matrix(pos)) { pos <- pos[1,] matrixmap <- TRUE } else matrixmap <- FALSE n.mar <- ncol(cross$geno[[i]]$data) if(n.mar > 1) { pos <- c(min(pos)-10, pos, max(pos)+10) pos <- (pos[-1] + pos[-length(pos)])/2 themarkers <- colnames(cross$geno[[i]]$data) int2 <- c("*", 1:length(themarkers), "*") themarkers <- c("pter", themarkers, "qter") interval <- paste(themarkers[-length(themarkers)], themarkers[-1], sep="-") int2 <- paste("(", int2[-length(int2)], "-", int2[-1], ")", sep="") interval <- paste(interval, int2) initialmap <- est.map(cross, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] initialloglik <- attr(initialmap, "loglik") + markerll llik <- length <- length.male <- rep(NA, length(pos)) for(j in seq(along=pos)) { temp <- movemarker(cross, marker, i, pos[j]) nm <- est.map(temp, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] llik[j] <- attr(nm, "loglik") - initialloglik if(verbose) cat(i, pos[j], llik[j]/log(10), "\n") if(is.matrix(nm)) { length[j] <- diff(range(nm[1,])) length.male[j] <- diff(range(nm[2,])) } else length[j] <- diff(range(nm)) } } # >1 marker on chromosome else { initialloglik <- markerloglik(cross, colnames(cross$geno[[i]]$data), error.prob) + markerll pos <- pos+10 interval <- "---" temp <- movemarker(cross, marker, i, pos) nm <- est.map(temp, chr=i, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp, verbose=FALSE, omit.noninformative=FALSE)[[1]] llik <- attr(nm, "loglik") - initialloglik if(verbose) cat(i, pos, llik/log(10), "\n") if(is.matrix(nm)) { length <- diff(range(nm[1,])) length.male <- diff(range(nm[2,])) } else length <- diff(range(nm)) } # one marker on chromosome } # marker not on this chr if(matrixmap && sex.sp) tempres <- data.frame(chr=rep(i, length(pos)), pos=pos, lod=llik/log(10), length.female=length, length.male=length.male, interval=interval, stringsAsFactors=FALSE) else tempres <- data.frame(chr=rep(i, length(pos)), pos=pos, lod=llik/log(10), length=length, interval=interval, stringsAsFactors=FALSE) results <- rbind(results, tempres) } # loop over chromosomes rownames(results) <- results$interval results <- results[,-ncol(results)] class(results) <- c("scanone", "data.frame") results } ###################################################################### # # markerloglik: Calculate log likelihood for a given marker # ###################################################################### markerloglik <- function(cross, marker, error.prob=0.0001) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") type <- crosstype(cross) if(length(marker) > 1) { ll <- sapply(marker, function(a,b,d) markerloglik(b, a, d), cross, error.prob) names(ll) <- marker return(ll) } # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) thechr <- find.markerpos(cross, marker)[1,1] if(is.na(thechr)) stop("Marker ", marker, " not found.") chr_type <- chrtype(cross$geno[[thechr]]) g <- pull.geno(cross, chr=thechr) m <- match(marker, colnames(g)) if(is.na(m)) stop("Marker ", marker, " not found.") g <- g[,m] g[is.na(g)] <- 0 # which type of cross is this? if(type == "f2") { if(chr_type == "A") # autosomal cfunc <- "marker_loglik_f2" else # X chromsome cfunc <- "marker_loglik_bc" } else if(type == "bc" || type=="riself" || type=="risib" || type=="dh" || type=="haploid") { cfunc <- "marker_loglik_bc" } else if(type == "4way") { cfunc <- "marker_loglik_4way" } else if(type=="ri4sib" || type=="ri4self" || type=="ri8sib" || type=="ri8self" || type=="bgmagic16") { cfunc <- paste("marker_loglik_", type, sep="") if(chr_type=="X") warning("markerloglik not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { cfunc <- "marker_loglik_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(chr_type != "A") { ## X chromosome cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 } } else stop("markerloglik not available for cross type ", type, ".") ## Hide cross scheme in genoprob to pass to routine. BY temp <- 0 if(type == "bcsft") temp[1] <- cross.scheme[1] * 1000 + cross.scheme[2] # call the C function z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(g), # genotype data as.double(error.prob), loglik=as.double(temp), # log likelihood PACKAGE="qtl") z$loglik } ###################################################################### # allchrsplits # # get LOD scores for each possible split of each chromosome into # two pieces # ###################################################################### allchrsplits <- function(cross, chr, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), m=0, p=0, maxit=4000, tol=1e-6, sex.sp=TRUE, verbose=TRUE) { map.function <- match.arg(map.function) if(!missing(chr)) cross <- subset(cross, chr=chr) biggap <- imf.h(0.5 - 1e-14) n.mar <- nmar(cross) chrnam <- names(cross$geno) result <- NULL for(i in seq(along=cross$geno)) { if(n.mar[i] == 1) { # temp <- data.frame(chr=chrnam[i], pos=pos, lod=NA, gap=0) # rownames(temp) <- themarkers # result <- cbind(result, temp) next } thischr <- subset(cross, chr=chrnam[i]) if(verbose) cat("Chr ", chrnam[i], " (", n.mar[i], " markers)\n", sep="") pos <- cross$geno[[i]]$map themarkers <- colnames(cross$geno[[i]]$data) if(is.matrix(pos)) { pos <- pos[1,] matrixmap <- TRUE } else matrixmap <- FALSE gap <- (pos[-1] - pos[-length(pos)]) pos <- (pos[-1] + pos[-length(pos)])/2 int2 <- match(themarkers, colnames(cross$geno[[i]]$data)) interval <- paste(themarkers[-length(themarkers)], themarkers[-1], sep="-") int2 <- paste("(", int2[-length(int2)], "-", int2[-1], ")", sep="") interval <- paste(interval, int2) initialmap <- est.map(thischr, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp) thischr$geno[[1]]$map <- initialmap[[1]] initialloglik <- attr(initialmap[[1]], "loglik") if(n.mar[i] == 2) { # 2 markers mmll <- markerloglik(thischr, markernames(thischr), error.prob=error.prob) temp <- data.frame(chr=chrnam[i], pos=pos, lod=(initialloglik - sum(mmll))/log(10), gap=gap, stringsAsFactors=TRUE) rownames(temp) <- interval } else { # >2 markers mn <- markernames(thischr) mmll <- markerloglik(thischr, mn[c(1,length(mn))], error.prob=error.prob) lod <- rep(NA, length(mn)-1) if(verbose) cat(" interval 1\n") # first interval lod[1] <- initialloglik - mmll[1] - attr(est.map(drop.markers(thischr, mn[1]), error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp)[[1]], "loglik") if(n.mar[i] > 3) { for(j in 2:(n.mar[i]-2)) { if(verbose) cat(" interval", j, "\n") temp1 <- est.map(pull.markers(thischr, mn[1:j]), error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp)[[1]] temp2 <- est.map(drop.markers(thischr, mn[1:j]), error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp)[[1]] # lod[j] <- initialloglik - attr(temp1, "loglik") - attr(temp2, "loglik") if(any(is.na(temp1)) || any(is.na(temp2))) stop("Missing values in estimated map on chr ", chrnam[i], " with split at interval ", j, "\n") # the likelihoods aren't adding properly, so I'll use the following kluge: temp3 <- thischr if(is.matrix(temp1)) temp3$geno[[1]]$map <- cbind(temp1, biggap+temp2) else temp3$geno[[1]]$map <- c(temp1, biggap+temp2) temp3 <- est.map(temp3, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=0, tol=tol, sex.sp=sex.sp)[[1]] lod[j] <- initialloglik - attr(temp3, "loglik") } } if(verbose) cat(" interval", n.mar[i]-1, "\n") # last interval lod[length(mn)-1] <- initialloglik - mmll[2] - attr(est.map(drop.markers(thischr, mn[length(mn)]), error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp)[[1]], "loglik") temp <- data.frame(chr=rep(chrnam[i], length(interval)), pos=pos, lod=lod/log(10), gap=gap, stringsAsFactors=TRUE) rownames(temp) <- interval } result <- rbind(result, temp) } class(result) <- c("scanone", "data.frame") result } # end of tryallpositions.R qtl/R/arithscan.R0000644000176200001440000002332713576241200013361 0ustar liggesusers##################################################################### # # arithscan.R # # copyright (c) 2005-2019, Karl W Broman # last modified Dec, 2019 # first written Mar, 2005 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: +.scanone, -.scanone, +.scanoneperm, -.scanoneperm # +.scantwo, -.scantwo, +.scantwoperm, -.scantwoperm # ###################################################################### "-.scanone" <- function(e1,e2) { if(!inherits(e1, "scanone")) stop("Input should have class \"scanone\".") if(missing(e2)) { class(e1) <- "data.frame" e1[,-(1:2)] <- -e1[,-(1:2)] class(e1) <- c("scanone","data.frame") return(e1) } if(!inherits(e2, "scanone")) stop("Input should have class \"scanone\".") class(e1) <- class(e2) <- "data.frame" if(nrow(e1) != nrow(e2)) { u1 <- levels(e1[,1]) u2 <- levels(e2[,2]) u <- unique(c(u1,u2)) if(length(u) == 0) stop("Can't subtract; no chromosomes in common.") e1 <- e1[!is.na(match(e1[,1],u)),] e2 <- e2[!is.na(match(e2[,1],u)),] if(nrow(e1) != nrow(e2) || any(e1[,1] != e2[,1]) || max(abs(e1[,2]-e2[,2])) < 0.01) stop("Can't subtract; arguments not compatible") } nc1 <- ncol(e1) nc2 <- ncol(e2) nc <- min(c(nc1,nc2)) e1 <- e1[,1:nc] e1[,3:nc] <- e1[,3:nc] - e2[,3:nc] # zero out small stuff temp <- e1[,3:nc] temp[!is.na(temp) & abs(temp) < 1e-6] <- 0 e1[,3:nc] <- temp class(e1) <- c("scanone","data.frame") e1 } "+.scanone" <- function(e1,e2) { if(!inherits(e1, "scanone")) stop("Input should have class \"scanone\".") if(missing(e2)) return(e1) if(!inherits(e2, "scanone")) stop("Input should have class \"scanone\".") class(e1) <- class(e2) <- "data.frame" if(nrow(e1) != nrow(e2)) { u1 <- levels(e1[,1]) u2 <- levels(e2[,2]) u <- unique(c(u1,u2)) if(length(u) == 0) stop("Can't add; no chromosomes in common.") e1 <- e1[!is.na(match(e1[,1],u)),] e2 <- e2[!is.na(match(e2[,1],u)),] if(nrow(e1) != nrow(e2) || any(e1[,1] != e2[,1]) || max(abs(e1[,2]-e2[,2])) < 0.01) stop("Can't add; arguments not compatible") } nc1 <- ncol(e1) nc2 <- ncol(e2) nc <- min(c(nc1,nc2)) e1 <- e1[,1:nc] e1[,3:nc] <- e1[,3:nc] + e2[,3:nc] class(e1) <- c("scanone","data.frame") e1 } "-.scanoneperm" <- function(e1, e2) { if(!inherits(e1, "scanoneperm")) stop("Input should have class \"scanoneperm\".") if(missing(e2)) { e1.x <- ("xchr" %in% names(attributes(e1))) if(e1.x) { e1$A <- -e1$A e1$X <- -e1$X } else { theclass <- class(e1) e1 <- -unclass(e1) class(e1) <- theclass } return(e1) } if(!inherits(e2, "scanoneperm")) stop("Input should have class \"scanoneperm\".") # check input e1.x <- ("xchr" %in% names(attributes(e1))) e2.x <- ("xchr" %in% names(attributes(e2))) if(e1.x != e2.x) stop("Need both or neither input to be X-chr specific.\n") if((e1.x && (any(dim(e1$A)!=dim(e2$A)) || any(dim(e1$X)!=dim(e2$X)))) || (!e1.x && any(dim(e1) != dim(e2)))) stop("Need input to concern the same phenotypes and no. permutations.\n") if(e1.x) { e1$A <- e1$A - e2$A e1$X <- e1$X - e2$X # zero out small stuff e1$A[!is.na(e1$A) & abs(e1$A) < 1e-6] <- 0 e1$X[!is.na(e1$X) & abs(e1$X) < 1e-6] <- 0 } else { theclass <- class(e1) e1 <- unclass(e1) - unclass(e2) # zero out small stuff e1[!is.na(e1) & abs(e1) < 1e-6] <- 0 class(e1) <- theclass } e1 } "+.scanoneperm" <- function(e1, e2) { if(!inherits(e1, "scanoneperm")) stop("Input should have class \"scanoneperm\".") if(missing(e2)) return(e1) if(!inherits(e2, "scanoneperm")) stop("Input should have class \"scanoneperm\".") # check input e1.x <- ("xchr" %in% names(attributes(e1))) e2.x <- ("xchr" %in% names(attributes(e2))) if(e1.x != e2.x) stop("Need both or neither input to be X-chr specific.\n") if((e1.x && (any(dim(e1$A)!=dim(e2$A)) || any(dim(e1$X)!=dim(e2$X)))) || (!e1.x && any(dim(e1) != dim(e2)))) stop("Need input to concern the same phenotypes and no. permutations.\n") if(e1.x) { e1$A <- e1$A + e2$A e1$X <- e1$X + e2$X } else { theclass <- class(e1) e1 <- unclass(e1) + unclass(e2) class(e1) <- theclass } e1 } ###################################################################### # -.scantwo: subtract LOD scores in two scantwo results ###################################################################### "-.scantwo" <- function(e1, e2) { if(!inherits(e1, "scantwo")) stop("Input should have class \"scantwo\".") if(missing(e2)) { e1$lod <- -e1$lod if("scanoneX" %in% names(e1)) e1$scanoneX <- -e1$scanoneX return(e1) } if(!inherits(e2, "scantwo")) stop("Input should have class \"scantwo\".") e1x <- "scanoneX" %in% names(e1) e2x <- "scanoneX" %in% names(e2) if(any(dim(e1$map) != dim(e2$map)) || length(dim(e1$lod)) != length(dim(e2$lod)) || any(dim(e1$lod) != dim(e2$lod)) || e1x != e2x) stop("input arguments do not conform.") e1$lod <- e1$lod - e2$lod if(e1x) { if(!is.null(e1$scanoneX) && !is.null(e2$scanoneX)) e1$scanoneX <- e1$scanoneX - e2$scanoneX } e1 } ###################################################################### # +.scantwo: add LOD scores in two scantwo results ###################################################################### "+.scantwo" <- function(e1, e2) { if(!inherits(e1, "scantwo")) stop("Input should have class \"scantwo\".") if(missing(e2)) return(e1) if(!inherits(e2, "scantwo")) stop("Input should have class \"scantwo\".") e1x <- "scanoneX" %in% names(e1) e2x <- "scanoneX" %in% names(e2) if(any(dim(e1$map) != dim(e2$map)) || length(dim(e1$lod)) != length(dim(e2$lod)) || any(dim(e1$lod) != dim(e2$lod)) || e1x != e2x) stop("input arguments do not conform.") e1$lod <- e1$lod + e2$lod if(e1x) { if(!is.null(e1$scanoneX) && !is.null(e2$scanoneX)) e1$scanoneX <- e1$scanoneX + e2$scanoneX } e1 } ###################################################################### # -.scantwoperm: subtract LOD scores in two scantwo permutation results ###################################################################### "-.scantwoperm" <- function(e1, e2) { if(!inherits(e1, "scantwoperm")) stop("Input should have class \"scantwoperm\".") if(missing(e2)) { # x-chr-specific if("AA" %in% names(e1)) { for(i in seq(along=e1)) for(j in seq(along=e1[[i]])) e1[[i]][[j]] <- -e1[[i]][[j]] return(e1) } for(i in 1:length(e1)) e1[[i]] <- -e1[[i]] return(e1) } if(!inherits(e2, "scantwoperm")) stop("Input should have class \"scantwoperm\".") # x-chr-specific if("AA" %in% names(e1) || "AA" %in% names(e2)) { if(!("AA" %in% names(e1) && "AA" %in% names(e2))) stop("Input must both be Xchr-specific, or neither") for(i in seq(along=e1)) { for(j in seq(along=e1[[i]])) { if(any(dim(e1[[i]][[j]]) != dim(e1[[i]][[j]]))) stop("dimensions do not match") e1[[i]][[j]] <- e1[[i]][[j]] - e2[[i]][[j]] } } return(e1) } dim1 <- sapply(e1, dim) dim2 <- sapply(e2, dim) if(any(dim1 != dim2)) stop("Need input to concern the same phenotypes and no. permutations.\n") for(i in 1:length(e1)) e1[[i]] <- e1[[i]] - e2[[i]] e1 } ###################################################################### # +.scantwoperm: add LOD scores in two scantwo permutation results ###################################################################### "+.scantwoperm" <- function(e1, e2) { if(!inherits(e1, "scantwoperm")) stop("Input should have class \"scantwoperm\".") if(missing(e2)) return(e1) if(!inherits(e2, "scantwoperm")) stop("Input should have class \"scantwoperm\".") # x-chr-specific if("AA" %in% names(e1) || "AA" %in% names(e2)) { if(!("AA" %in% names(e1) && "AA" %in% names(e2))) stop("Input must both be Xchr-specific, or neither") for(i in seq(along=e1)) { for(j in seq(along=e1[[i]])) { if(any(dim(e1[[i]][[j]]) != dim(e1[[i]][[j]]))) stop("dimensions do not match") e1[[i]][[j]] <- e1[[i]][[j]] + e2[[i]][[j]] } } return(e1) } dim1 <- sapply(e1, dim) dim2 <- sapply(e2, dim) if(any(dim1 != dim2)) stop("Need input to concern the same phenotypes and no. permutations.\n") for(i in 1:length(e1)) e1[[i]] <- e1[[i]] + e2[[i]] e1 } # end of arithscan.R qtl/R/pull_stuff.R0000644000176200001440000002710313762235662013600 0ustar liggesusers##################################################################### # # pull_stuff.R # # copyright (c) 2001-2020, Karl W Broman # [find.pheno, find.flanking, and a modification to create.map # from Brian Yandell] # last modified Dec, 2020 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: pull.map, pull.geno, pull.pheno # pull.genoprob, pull.argmaxgeno # ###################################################################### ###################################################################### # # pull.map # # pull out the map portion of a cross object, as a list # ###################################################################### pull.map <- function(cross, chr, as.table=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) if(!as.table) { result <- lapply(cross$geno,function(a) { b <- a$map class(b) <- chrtype(a) b }) class(result) <- "map" return(result) } else { return(map2table(pull.map(cross, as.table=FALSE))) } } map2table <- function(map, chr) { if(!missing(chr)) { chr <- matchchr(chr, names(map)) map <- map[chr] } if(is.matrix(map[[1]])) { map1 <- unlist(lapply(map, function(a) a[1,])) map2 <- unlist(lapply(map, function(a) a[2,])) result <- data.frame(chr=rep(names(map), vapply(map, ncol, 0)), pos.female=map1, pos.male=map2, stringsAsFactors=FALSE) rownames(result) <- make_unique(unlist(lapply(map, colnames)), "marker names") } else { result <- data.frame(chr=rep(names(map), vapply(map, length, 0)), pos=unlist(map), stringsAsFactors=FALSE) rownames(result) <- make_unique(unlist(lapply(map, names)), "marker names") } result[,1] <- factor(result[,1], levels=unique(result[,1])) result } # force a string of names to be unique # 'label' used if there are mismatches make_unique <- function(nam, label="names") { tab <- table(nam) if(any(tab > 1)) { warning(label, " are not all distinct; output names adjusted to make them distinct") for(marker in names(tab)[tab > 1]) { wh <- (nam==marker) nam[wh] <- paste0(marker, "_", seq_len(sum(wh))) } } nam } ###################################################################### # pull.geno ###################################################################### pull.geno <- function(cross, chr) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) X <- cross$geno[[1]]$data if(nchr(cross) > 1) for(i in 2:nchr(cross)) X <- cbind(X, cross$geno[[i]]$data) X } ###################################################################### # pull.pheno ###################################################################### pull.pheno <- function(cross, pheno.col) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") pheno <- cross$pheno if(!missing(pheno.col)) { if(is.character(pheno.col)) { m <- match(pheno.col, names(pheno)) if(any(is.na(m))) { if(sum(is.na(m)) > 1) warning("Phenotypes ", paste("\"", pheno.col[is.na(m)], "\"", sep="", collapse=" "), " not found.") else warning("Phenotype ", paste("\"", pheno.col[is.na(m)], "\"", sep="", collapse=" "), " not found.") } if(all(is.na(m))) return(NULL) m <- m[!is.na(m)] pheno <- pheno[,m] } else if(is.logical(pheno.col)) { if(length(pheno.col) != ncol(pheno)) stop("If pheno.col is logical, it should have length ", ncol(pheno)) pheno <- pheno[,pheno.col] } else if(is.numeric(pheno.col)) { if(any(pheno.col > 0) && any(pheno.col < 0)) stop("If pheno.col is numeric, values should be all > 0 or all < 0") if(any(pheno.col > 0) && (any(pheno.col < 1) || any(pheno.col > ncol(pheno)))) stop("pheno.col values should be >= 1 and <= ", ncol(pheno)) if(any(pheno.col < 0) && (any(pheno.col > -1) || any(pheno.col < -ncol(pheno)))) stop("With negative pheno.col values, they should be between -", ncol(pheno), " and -1") pheno <- pheno[,pheno.col] } } if(is.data.frame(pheno) && ncol(pheno) == 1) pheno <- pheno[,1] pheno } ###################################################################### # pull.genoprob ###################################################################### pull.genoprob <- function(cross, chr, omit.first.prob=FALSE, include.pos.info=FALSE, rotate=FALSE) { if(!missing(chr)) cross <- subset(cross, chr=chr) if(!("prob" %in% names(cross$geno[[1]]))) stop("You must first run calc.genoprob.") if(include.pos.info && !rotate) { warning("If include.pos.info=TRUE, we assume rotate=TRUE as well.") rotate <- TRUE } pr <- lapply(cross$geno, function(a) a$prob) chrnames <- names(cross$geno) for(i in seq(along=pr)) { w <- colnames(pr[[i]]) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",chrnames[i],".",w[o],sep="") colnames(pr[[i]]) <- w } if(omit.first.prob) fullncol <- sum(sapply(pr, ncol))*(dim(pr[[1]])[3]-1) else fullncol <- sum(sapply(pr, ncol))*dim(pr[[1]])[3] fullpr <- matrix(nrow=nrow(pr[[1]]), ncol=fullncol) colnames(fullpr) <- 1:fullncol curcol <- 0 thegen <- themarker <- rep(NA, fullncol) if(include.pos.info) thechr <- thepos <- rep(NA, fullncol) for(i in seq(along=pr)) { dim3 <- 1:dim(pr[[i]])[3] if(omit.first.prob) dim3 <- dim3[-1] for(j in seq(along=dim3)) { thecol <- curcol + ((1:ncol(pr[[i]]))-1)*length(dim3) + j fullpr[,thecol] <- pr[[i]][,,dim3[j]] thisgen <- dimnames(pr[[i]])[[3]][dim3[j]] thegen[thecol] <- rep(thisgen, length(thecol)) themarker[thecol] <- colnames(pr[[i]]) colnames(fullpr)[thecol] <- paste(colnames(pr[[i]]), thisgen, sep=":") if(include.pos.info) { thechr[thecol] <- rep(names(cross$geno)[i], length(thecol)) map <- attr(pr[[i]], "map") if(is.matrix(map)) map <- map[1,] # sex-specific map; take female positions thepos[thecol] <- map } } curcol <- curcol + ncol(pr[[i]])*length(dim3) } id <- getid(cross) if(is.null(id)) id <- paste("ind", 1:nrow(fullpr), sep="") rownames(fullpr) <- id if(rotate) { fullpr <- as.data.frame(t(fullpr)) if(include.pos.info) { thechr <- factor(thechr, names(cross$geno)) fullpr <- cbind(marker=themarker, gen=thegen, chr=thechr, pos=thepos, fullpr, stringsAsFactors=FALSE) } } fullpr } ###################################################################### # pull.argmaxgeno ###################################################################### pull.argmaxgeno <- function(cross, chr, include.pos.info=FALSE, rotate=FALSE) { if(!missing(chr)) cross <- subset(cross, chr=chr) if(!("argmax" %in% names(cross$geno[[1]]))) stop("You must first run argmax.geno.") if(include.pos.info && !rotate) { warning("If include.pos.info=TRUE, we assume rotate=TRUE as well.") rotate <- TRUE } am <- lapply(cross$geno, function(a) a$argmax) chrnames <- names(cross$geno) for(i in seq(along=am)) { w <- colnames(am[[i]]) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",chrnames[i],".",w[o],sep="") colnames(am[[i]]) <- w } fullncol <- sum(sapply(am, ncol)) fullam <- matrix(nrow=nrow(am[[1]]), ncol=fullncol) colnames(fullam) <- 1:fullncol curcol <- 0 if(include.pos.info) thechr <- thepos <- rep(NA, fullncol) for(i in seq(along=am)) { thecol <- curcol + 1:ncol(am[[i]]) fullam[,thecol] <- am[[i]] colnames(fullam)[thecol] <- colnames(am[[i]]) if(include.pos.info) { thechr[thecol] <- rep(names(cross$geno)[i], length(thecol)) map <- attr(am[[i]], "map") if(is.matrix(map)) map <- map[1,] # sex-specific map; take female positions thepos[thecol] <- map } curcol <- curcol + length(thecol) } id <- getid(cross) if(is.null(id)) id <- paste("ind", 1:nrow(fullam), sep="") rownames(fullam) <- id if(rotate) { fullam <- as.data.frame(t(fullam)) if(include.pos.info) { thechr <- factor(thechr, names(cross$geno)) fullam <- cbind(marker=rownames(fullam), chr=thechr, pos=thepos, fullam, stringsAsFactors=FALSE) } } fullam } ###################################################################### # pull.draws ###################################################################### pull.draws <- function(cross, chr) { if(!missing(chr)) cross <- subset(cross, chr=chr) if(!("draws" %in% names(cross$geno[[1]]))) stop("You must first run sim.geno.") dr <- lapply(cross$geno, function(a) a$draws) chrnames <- names(cross$geno) for(i in seq(along=dr)) { w <- colnames(dr[[i]]) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",chrnames[i],".",w[o],sep="") colnames(dr[[i]]) <- w } fullncol <- sum(sapply(dr, ncol)) d <- dim(dr[[1]]) fulldr <- array(dim=c(d[1], fullncol, d[3])) colnames(fulldr) <- 1:fullncol curcol <- 0 for(i in seq(along=dr)) { thecol <- curcol + 1:ncol(dr[[i]]) fulldr[,thecol,] <- dr[[i]] colnames(fulldr)[thecol] <- colnames(dr[[i]]) curcol <- curcol + length(thecol) } id <- getid(cross) if(is.null(id)) id <- paste("ind", 1:nrow(fulldr), sep="") rownames(fulldr) <- id fulldr } ############################## # table2map: create map object from a table # # rownames should be marker names # first column chromosome # second column position ############################## table2map <- function(tab) { mar <- rownames(tab) if(is.null(mar)) stop("marker names should be the row names") chr <- factor(tab[,1], levels=unique(tab[,1])) pos <- tab[,2] map <- split(pos, chr) mar <- split(mar, chr) for(i in seq(along=map)) names(map[[i]]) <- mar[[i]] if(all(names(map) %in% c(1:20,"X"))) { # names are as in mouse for(i in seq(along=map)) class(map[[i]]) <- ifelse(names(map)[i]=="X", "X", "A") } class(map) <- "map" map } # end of pull_stuff.R qtl/R/read.cross.qtx.R0000644000176200001440000001655212770016226014270 0ustar liggesusers###################################################################### # # read.cross.qtx.R # # copyright (c) 2000-2011, Karl W Broman # last modified May, 2011 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.qtx # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.qtx # # read data in Map Manager QTX format # ###################################################################### read.cross.qtx <- function(dir, file, estimate.map=TRUE) { if(!missing(dir) && dir != "") { file <- file.path(dir, file) } # This is a revised version of match which gives *all* matches # of x within the table mymatch <- function(x, table) { if(length(x) > 1) x <- x[1] # ignore any but the first element of x if(!any(x==table)) return(NA) seq(along=table)[x==table] } # read file into a big vector, each item one line cat(" --Read the following data:\n") x <- scan(file,what=character(0),sep="\n",quiet=TRUE) genoabbrev <- unlist(strsplit(x[9],"")) if(length(genoabbrev) < 8) # just in case, fill out to 8 chars genoabbrev <- c(genoabbrev,rep("H",8-length(genoabbrev))) myabbrev <- c(0,1,3,2,5,4,2,2) ugeno <- NULL # individuals ind.beg <- match("{pgy", x) # there should be just one ind.end <- match("}pgy", x) n.ind <- as.numeric(x[ind.beg+1]) ind <- x[(ind.beg+2):(ind.end-1)] if(length(ind) != n.ind) stop("Problem with individual IDs ({pgy}).") cat("\t", n.ind, " individuals\n", sep="") # determine if individuals can be viewed as numbers g <- grep("^[0-9\\.]+$", ind) if(length(g) == n.ind) ind <- as.numeric(as.character(ind)) # phenotypes phe.beg <- mymatch("{trt",x) phe.end <- mymatch("}trt",x) pheno <- NULL if(!is.na(phe.beg[1])) { # at least one phenotype pheno <- vector("list",length(phe.beg)) names(pheno) <- paste(phe.beg) for(i in 1:length(phe.beg)) { z <- x[phe.beg[i]:phe.end[i]] names(pheno)[i] <- z[2] vals.beg <- match("{tvl", z)+1 # there should be just one match vals.end <- match("}tvl", z)-1 # "X" or "x" is a missing phenotype temp <- unlist(strsplit(z[vals.beg[1]:vals.end[1]]," ")) temp[temp=="X" | temp=="x"] <- NA pheno[[i]] <- as.numeric(temp) } pheno <- cbind(as.data.frame(pheno, stringsAsFactors=TRUE),ind=ind) cat("\t", length(pheno), " phenotypes\n",sep="") } else { pheno <- data.frame(ind=ind, stringsAsFactors=TRUE) cat("\t", 0, " phenotypes\n",sep="") } # chromosomes chr.beg <- mymatch("{chx",x) chr.end <- mymatch("}chx",x) if(is.na(chr.beg[1])) # no genotype data stop("There appears to be no genotype data!") geno <- vector("list", length(chr.beg)) names(geno) <- paste(chr.beg) has.loci <- rep(TRUE,length(chr.beg)) map.offset <- rep(0,length(chr.beg)) cat("\t", length(chr.beg), " chromosomes\n",sep="") for(i in 1:length(chr.beg)) { z <- x[chr.beg[i]:chr.end[i]] names(geno)[i] <- z[2] map.offset <- as.numeric(z[5]) # loci loc.beg <- mymatch("{lox",z) loc.end <- mymatch("}lox",z) if(all(is.na(loc.beg))) { has.loci[i] <- FALSE next } data <- matrix(ncol=length(loc.beg),nrow=n.ind) loctype <- rep(NA,length(loc.beg)) #### colnames(data) <- paste(loc.beg) has.geno <- rep(TRUE,length(loc.beg)) for(j in 1:length(loc.beg)) { zz <- z[loc.beg[j]:loc.end[j]] colnames(data)[j] <- zz[2] loctype[j] <- zz[5] #### geno.beg <- match("{sdp",zz)+1 # should be just one match geno.end <- match("}sdp",zz)-1 if(all(is.na(geno.beg))) { # no genotype data has.geno[j] <- FALSE next } dat <- unlist(strsplit(paste(zz[geno.beg[1]:geno.end[1]],collapse=""),"")) data[,j] <- myabbrev[match(dat,genoabbrev)] } # end loop over loci # check that all loci have the same code if(all(loctype == loctype[1])) loctype <- loctype[1] # 0 = unknown # 1 = backcross codominant maternal unique # 2 = backcross codominant paternal unique # 3 = backcross maternal dominant # 4 = backcross paternal dominant # 5 = f2 codominant # 6 = f2 maternal dominant # 7 = f2 paternal dominant # 8 = doubled haploid # 9 = selfed RI # 10 = sib-mated RI # 11 = advanced backcross codominant maternal unique # 12 = advanced backcross codominant paternal udnique # 13 = advanced backcross maternal dominant # 14 = advanced backcross paternal dominant # 15 = AIL codominant # 16 = AIL maternal dominant # 17 = AIL paternal dominant # 18 = radiation hybrid data # 19 = radiation hybrid data # 20 = selfed RIX # 21 = sib-mated RIX # replace 0's with NA's data[!is.na(data) & data==0] <- NA # remove columns with no data data <- data[,has.geno,drop=FALSE] # temporary map map <- seq(0,length=ncol(data),by=5)+map.offset names(map) <- colnames(data) geno[[i]] <- list(data=data,map=map) if(length(grep("[Xx]", names(geno)[i]))>0) # X chromosome class(geno[[i]]) <- "X" else class(geno[[i]]) <- "A" } # end loop over chromosomes # unique genotypes for(i in 1:length(geno)) { ugeno <- unique(c(ugeno,unique(geno[[i]]$data))) ugeno <- ugeno[!is.na(ugeno)] } if(length(ugeno)==2) { # backcross # Fix if coded as A:B rather than A:H (RI lines) if(all(ugeno==1 | ugeno==3)) { for(i in 1:length(geno)) geno[[i]]$data[geno[[i]]$data == 3] <- 2 } # Fix if coded as H:B rather than A:H (other backcross) else if(all(ugeno==2 | ugeno==3)) { for(i in 1:length(geno)) geno[[i]]$data[geno[[i]]$data == 3] <- 1 } type <- "bc" for(i in 1:length(geno)) geno[[i]]$data[geno[[i]]$data > 2] <- 1 } else type <- "f2" totmar <- sum(sapply(geno,function(a) ncol(a$data))) cat("\t", totmar, " total markers\n",sep="") cross <- list(geno=geno,pheno=pheno) class(cross) <- c(type,"cross") if(estimate.map) estmap <- TRUE else estmap <- FALSE # return cross + indicator of whether to run est.map list(cross,estmap) } # end of read.cross.qtx.R qtl/R/addqtl.R0000644000176200001440000015345714407205154012670 0ustar liggesusers###################################################################### # # addqtl.R # # copyright (c) 2007-2023, Karl W. Broman # last modified Mar, 2023 # first written Nov, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: addint, print.addint, addqtl, addpair, # reviseqtlnuminformula, qtlformulasymmetric # dropfromqtlformula # addcovarint, print.addcovarint, summary.addcovarint # ###################################################################### ###################################################################### # addint # # Try adding each possible QTL:QTL interaction (that is not # already in the formula), and give results similar to the drop-one # analysis. ###################################################################### addint <- function(cross, pheno.col=1, qtl, covar=NULL, formula, method=c("imp","hk"), model=c("normal", "binary"), qtl.only=FALSE, verbose=TRUE, pvalues=TRUE, simple=FALSE, tol=1e-4, maxit=1000, require.fullrank=FALSE) { if( !inherits(cross, "cross") ) stop("The cross argument must be an object of class \"cross\".") if( !inherits(qtl, "qtl") ) stop("The qtl argument must be an object of class \"qtl\".") if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("addint can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") method <- match.arg(method) model <- match.arg(model) # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } # check phenotypes and covariates; drop ind'ls with missing values if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") pheno <- pheno[!hasmissing] qtl$n.ind <- sum(!hasmissing) if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] cross <- subset(cross, ind=!hasmissing) } } # number of covariates if( is.null(covar) ) n.covar <- 0 else n.covar <- ncol(covar) # if formula is missing, build one # all QTLs and covarariates will be additive by default n.qtl <- qtl$n.qtl if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if (n.covar) { # if covarariate is not empty tmp.C <- colnames(covar) # covarariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } formula <- as.formula(formula) } # check input formula formula <- checkformula(formula, qtl$altname, colnames(covar)) # look for interactions that haven't been added factors <- attr(terms(formula), "factors") if(sum(factors[1,])==0) factors <- factors[-1,] # replace QTL altnames (Q1 etc) with real names (chr1@20 etc) fn <- fn.alt <- rownames(factors) qan <- qtl$altname qn <- qtl$name m <- match(fn, qan) fn.alt[!is.na(m)] <- qn[m[!is.na(m)]] # all possible interactions int2test <- int2test.alt <- NULL for(i in 1:(nrow(factors)-1)) { for(j in (i+1):nrow(factors)) { temp <- rep(0, nrow(factors)) temp[c(i,j)] <- 1 if(!any(apply(factors, 2, function(a, b) all(a==b), temp))) { int2test <- c(int2test, paste(fn[i], fn[j], sep=":")) int2test.alt <- c(int2test.alt, paste(fn.alt[i], fn.alt[j], sep=":")) } } } if(qtl.only && length(int2test) > 0) { z <- matrix(unlist(strsplit(int2test, ":")), ncol=2, byrow=TRUE) wh <- apply(z, 1, function(a) length(grep("^[Qq][0-9]+$", a)) ) int2test <- int2test[wh==2] int2test.alt <- int2test.alt[wh==2] } n2test <- length(int2test) if(n2test == 0) { if(verbose) cat("No pairwise interactions to add.\n") return(NULL) } sexpgm <- getsex(cross) cross.attr <- attributes(cross) # fit base model thefit0 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit) matrix0.rank <- attr(thefit0, "matrix.rank") matrix0.ncol <- attr(thefit0, "matrix.ncol") results <- matrix(ncol=7, nrow=n2test) dimnames(results) <- list(int2test.alt, c("df", "Type III SS", "LOD", "%var", "F value", "Pvalue(Chi2)", "Pvalue(F)")) matrix1.rank <- matrix1.ncol <- rep(0, n2test) for(k in seq(along=int2test)) { thefit1 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=as.formula(paste(deparseQTLformula(formula), int2test[k], sep="+")), method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit) results[k,1] <- thefit1$result.full[1,1] - thefit0$result.full[1,1] results[k,2] <- thefit1$result.full[1,2] - thefit0$result.full[1,2] results[k,3] <- thefit1$result.full[1,4] - thefit0$result.full[1,4] results[k,4] <- 100*(1-10^(-2*thefit1$result.full[1,4]/qtl$n.ind)) - 100*(1-10^(-2*thefit0$result.full[1,4]/qtl$n.ind)) results[k,5] <- (results[k,2]/results[k,1])/thefit1$result.full[2,3] results[k,6] <- pchisq(results[k,3]*2*log(10), results[k,1], lower.tail=FALSE) results[k,7] <- pf(results[k,5], results[k,1], thefit1$result.full[3,1], lower.tail=FALSE) matrix1.rank[k] <- attr(thefit1, "matrix.rank") matrix1.ncol[k] <- attr(thefit1, "matrix.ncol") } matrix.fullrank <- (matrix1.rank - matrix0.rank == matrix1.ncol - matrix0.ncol) results <- as.data.frame(results, stringsAsFactors=TRUE) class(results) <- c("addint", "data.frame") attr(results, "method") <- method attr(results, "model") <- model attr(results, "formula") <- deparseQTLformula(formula) if(simple) pvalues <- FALSE attr(results, "pvalues") <- pvalues attr(results, "simple") <- simple attr(results, "matrix.fullrank") <- matrix.fullrank if(require.fullrank) results[!matrix.fullrank,3] <- 0 results } print.addint <- function(x, ...) { meth <- attr(x, "method") mod <- attr(x, "model") simp <- attr(x, "simple") if(is.null(mod)) mod <- "normal" if(is.null(meth)) meth <- "unknown" if(mod=="binary" || simp) attr(x, "pvalues") <- FALSE if(meth=="imp") meth <- "multiple imputation" else if(meth=="hk") meth <- "Haley-Knott regression" cat("Method:", meth, "\n") cat("Model: ", mod, "phenotype\n") cat("Model formula:") w <- options("width")[[1]] printQTLformulanicely(attr(x, "formula"), " ", w+5, w) cat("\n") cat("Add one pairwise interaction at a time table:\n") cat("--------------------------------------------\n") pval <- attr(x, "pvalues") if(!is.null(pval) && !pval) x <- x[,-ncol(x)+(0:1)] if(mod == "binary" || simp) x <- x[,c(1,3,4), drop=FALSE] printCoefmat(x, digits=4, cs.ind=1, P.values=pval, has.Pvalue=pval) cat("\n") } summary.addint <- function(object, ...) object ###################################################################### # addqtl # # scan for an additional QTL in the context of a multiple-QTL model # # If the formula includes one more QTL than in the QTL object, we # use it as given; otherwise, a main effect for the additional QTL # is added # # the output is like scanone ###################################################################### addqtl <- function(cross, chr, pheno.col=1, qtl, covar=NULL, formula, method=c("imp","hk"), model=c("normal", "binary"), incl.markers=TRUE, verbose=FALSE, tol=1e-4, maxit=1000, forceXcovar=FALSE, require.fullrank=FALSE) { method <- match.arg(method) model <- match.arg(model) if( !inherits(cross, "cross") ) stop("The cross argument must be an object of class \"cross\".") if( !inherits(qtl, "qtl") ) stop("The qtl argument must be an object of class \"qtl\".") # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(verbose > 1) { verbose <- TRUE verbose.scanqtl <- TRUE } else verbose.scanqtl <- FALSE n.qtl <- qtl$n.qtl qtlchr <- qtl$chr qtlpos <- qtl$pos if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } if(method=="imp") { if("stepwidth" %in% names(attributes(cross$geno[[1]]$draws)) && attr(cross$geno[[1]]$draws, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } else { if("stepwidth" %in% names(attributes(cross$geno[[1]]$prob)) && attr(cross$geno[[1]]$prob, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } # look for the chr if(missing(chr)) chr <- names(cross$geno) else chr <- matchchr(chr, names(cross$geno)) # if formula is missing, make one. # All QTLs and covariates will be additive by default if(is.null(covar)) n.covar <- 0 else n.covar <- ncol(covar) if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if(n.covar) { # if covariate is not empty tmp.C <- names(covar) # covariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } newformula <- as.formula(paste(formula, "+Q", n.qtl+1, sep="")) formula <- as.formula(formula) } else { # formula given newqtl <- paste("Q", n.qtl+1, sep="") # check the formula formula <- checkformula(formula, c(qtl$altname, newqtl), colnames(covar)) theterms <- rownames(attr(terms(formula), "factors")) # is new QTL in the formula? g <- grep(paste("^[Qq]", n.qtl+1, "$", sep=""), theterms) if(length(g) == 0) { # no; add to formula newformula <- as.formula(paste(deparseQTLformula(formula), "+ Q", n.qtl+1, sep="")) } else { # need a version without it newformula <- formula theterms <- colnames(attr(terms(formula), "factors")) g <- unique(c(grep(paste("^[Qq]", n.qtl+1, "$", sep=""), theterms), grep(paste("^[Qq]", n.qtl+1, " *:", sep=""), theterms), grep(paste(": +[Qq]", n.qtl+1, " *:", sep=""), theterms), grep(paste(": +[Qq]", n.qtl+1, "$", sep=""), theterms))) if(length(g) > 0) { theterms <- theterms[-g] formula <- as.formula(paste("y ~ ", paste(theterms, collapse=" + "), sep="")) } } } # drop qtl that are not in the formula thefactors <- rownames(attr(terms(formula), "factors")) todrop <- NULL for(i in 1:n.qtl) { if(length(grep(paste("^[Qq]", i, "$", sep=""), thefactors))==0) todrop <- c(todrop, i) } if(length(todrop) > 0) { newqtlnum <- n.qtl+1 notdropped <- (1:n.qtl)[-todrop] newnum <- 1:length(notdropped) qtl <- dropfromqtl(qtl, index=todrop) qtlchr <- qtlchr[-todrop] qtlpos <- qtlpos[-todrop] n.qtl <- n.qtl - length(todrop) revnewqtlnum <- n.qtl+1 formula <- reviseqtlnuminformula(formula, notdropped, newnum) newformula <- reviseqtlnuminformula(newformula, c(notdropped,newqtlnum), c(newnum, revnewqtlnum)) } # drop covariates that are not in the formula if(!is.null(covar)) { theterms <- rownames(attr(terms(formula), "factors")) m <- match(colnames(covar), theterms) if(all(is.na(m))) covar <- NULL else covar <- covar[,!is.na(m),drop=FALSE] } # phenotype column if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("addqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 || pheno.col > nphe(cross)) stop("pheno.col should be between 1 and ", nphe(cross)) pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") # check phenotypes and covariates; drop ind'ls with missing values if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") pheno <- pheno[!hasmissing] qtl$n.ind <- sum(!hasmissing) if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] cross <- subset(cross, ind=!hasmissing) } } sexpgm <- getsex(cross) cross.attr <- attributes(cross) # fit the base model fit0 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod0 <- fit0$result.full[1,4] matrix0.rank <- attr(fit0, "matrix.rank") matrix0.ncol <- attr(fit0, "matrix.ncol") results <- matrix1.rank <- matrix1.ncol <- NULL for(i in chr) { if(verbose) cat("Scanning chr", i, "\n") thechr <- c(qtlchr, i) thepos <- c(as.list(qtlpos), list(c(-Inf,Inf))) sqout <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) matrix1.rank <- c(matrix1.rank, attr(sqout, "matrix.rank")) matrix1.ncol <- c(matrix1.ncol, attr(sqout, "matrix.ncol")) # get map of positions if(method=="imp") { if("map" %in% names(attributes(cross$geno[[i]]$draws))) map <- attr(cross$geno[[i]]$draws,"map") else { stp <- attr(cross$geno[[i]]$draws, "step") oe <- attr(cross$geno[[i]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$draws))) stpw <- attr(cross$geno[[i]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } } else { if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } } # pull out the female map if there are sex-specific maps if(is.matrix(map)) map <- map[1,] if(method=="imp") step <- attr(cross$geno[[i]]$draws,"step") else step <- attr(cross$geno[[i]]$prob,"step") if(!incl.markers && step>0) { # equally spaced positions eq.sp.pos <- seq(min(map), max(map), by=step) wh.eq.pos <- match(eq.sp.pos, map) map <- map[wh.eq.pos] } w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",i,".",w[o],sep="") z <- data.frame(lod=as.numeric(sqout)-lod0, stringsAsFactors=TRUE) z <- cbind(chr=factor(rep(i,length(map)),levels=i), pos=as.numeric(map), z) rownames(z) <- w results <- rbind(results, z) } matrix.fullrank <- (matrix1.rank - matrix0.rank == matrix1.ncol - matrix0.ncol) class(results) <- c("scanone","data.frame") attr(results,"method") <- method attr(results,"formula") <- deparseQTLformula(newformula) attr(results, "matrix.fullrank") <- matrix.fullrank if(require.fullrank) results[!matrix.fullrank,3] <- 0 results } ###################################################################### # addpair # # scan for an additional pair of QTL in the context of a multiple-QTL # model # # If the formula includes one more QTL than in the QTL object, we # use it as given (perhaps adding the second, additively); # otherwise, we do as in scantwo, performing both additive and # interactive models, plus a single-QTL scan # # The output is like scantwo. If we didn't do the scantwo type format, # the results are placed where the full LODs usually are, and everything # else is NA ###################################################################### addpair <- function(cross, chr, pheno.col=1, qtl, covar=NULL, formula, method=c("imp","hk"), model=c("normal", "binary"), incl.markers=FALSE, verbose=TRUE, tol=1e-4, maxit=1000, forceXcovar=FALSE) { method <- match.arg(method) model <- match.arg(model) if( !inherits(cross, "cross") ) stop("The cross argument must be an object of class \"cross\".") if( !inherits(qtl, "qtl") ) stop("The qtl argument must be an object of class \"qtl\".") # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(verbose > 1) { verbose <- TRUE verbose.scanqtl <- TRUE } else verbose.scanqtl <- FALSE n.qtl <- qtl$n.qtl qtlchr <- qtl$chr qtlpos <- qtl$pos if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } if(method=="imp") { if("stepwidth" %in% names(attributes(cross$geno[[1]]$draws)) && attr(cross$geno[[1]]$draws, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } else { if("stepwidth" %in% names(attributes(cross$geno[[1]]$prob)) && attr(cross$geno[[1]]$prob, "stepwidth") != "fixed") { stepwidth.var <- TRUE incl.markers <- TRUE } else stepwidth.var <- FALSE } # look for the chr if(missing(chr)) chr <- names(cross$geno) else chr <- matchchr(chr, names(cross$geno)) fullmap <- pull.map(cross, chr) # if formula is missing, make one. # All QTLs and covariates will be additive by default if(is.null(covar)) n.covar <- 0 else n.covar <- ncol(covar) if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if(n.covar) { # if covariate is not empty tmp.C <- names(covar) # covariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } newformula1 <- as.formula(paste(formula, " + Q", n.qtl+1, " + Q", n.qtl+2, " + Q", n.qtl+1, ":Q", n.qtl+2, sep="")) newformula2 <- as.formula(paste(formula, " + Q", n.qtl+1, " + Q", n.qtl+2, sep="")) formula <- as.formula(formula) scanbothways <- FALSE } else { # formula given newqtl <- paste("Q", n.qtl+1:2, sep="") # check the formula formula <- checkformula(formula, c(qtl$altname, newqtl), colnames(covar)) theterms <- rownames(attr(terms(formula), "factors")) # are either of the new QTL in the formula? g <- c(grep(paste("^[Qq]", n.qtl+1, "$", sep=""), theterms), grep(paste("^[Qq]", n.qtl+2, "$", sep=""), theterms)) g1 <- grep(paste("^[Qq]", n.qtl+1, "$", sep=""), theterms) g2 <- grep(paste("^[Qq]", n.qtl+2, "$", sep=""), theterms) if(length(g) == 0) { # no; add to formula newformula1 <- as.formula(paste(deparseQTLformula(formula), "+ Q", n.qtl+1, " + Q", n.qtl+2, " + Q", n.qtl+1, ":Q", n.qtl+2, sep="")) newformula2 <- as.formula(paste(deparseQTLformula(formula), "+ Q", n.qtl+1, " + Q", n.qtl+2, sep="")) scanbothways <- FALSE } else { # need a version without them # first make sure that *both* terms are in the formula if(length(g1)==0) # add Q1 formula <- as.formula(paste(deparseQTLformula(formula), "+ Q", n.qtl+1, sep="")) if(length(g2)==0) # add Q2 formula <- as.formula(paste(deparseQTLformula(formula), "+ Q", n.qtl+2, sep="")) newformula1 <- formula newformula2 <- NULL theterms <- colnames(attr(terms(formula), "factors")) g <- unique(c(grep(paste("^[Qq]", n.qtl+1, "$", sep=""), theterms), grep(paste("^[Qq]", n.qtl+1, " *:", sep=""), theterms), grep(paste(": *[Qq]", n.qtl+1, " *:", sep=""), theterms), grep(paste(": *[Qq]", n.qtl+1, "$", sep=""), theterms), grep(paste("^[Qq]", n.qtl+2, "$", sep=""), theterms), grep(paste("^[Qq]", n.qtl+2, " *:", sep=""), theterms), grep(paste(": *[Qq]", n.qtl+2, " *:", sep=""), theterms), grep(paste(": *[Qq]", n.qtl+2, "$", sep=""), theterms))) if(length(g) > 0) { theterms <- theterms[-g] formula <- as.formula(paste("y ~ ", paste(theterms, collapse=" + "), sep="")) } # if the QTL formula is symmetric in the two new QTL, need scan only for i 0) { newqtlnum1 <- n.qtl+1 newqtlnum2 <- n.qtl+2 notdropped <- (1:n.qtl)[-todrop] newnum <- 1:length(notdropped) qtl <- dropfromqtl(qtl, index=todrop) qtlchr <- qtlchr[-todrop] qtlpos <- qtlpos[-todrop] n.qtl <- n.qtl - length(todrop) revnewqtlnum1 <- n.qtl+1 revnewqtlnum2 <- n.qtl+2 formula <- reviseqtlnuminformula(formula, notdropped, newnum) newformula1 <- reviseqtlnuminformula(newformula1, c(notdropped, newqtlnum1, newqtlnum2), c(newnum, revnewqtlnum1, revnewqtlnum2)) if(!is.null(newformula2)) newformula2 <- reviseqtlnuminformula(newformula2, c(notdropped, newqtlnum1, newqtlnum2), c(newnum, revnewqtlnum1, revnewqtlnum2)) if(scanbothways) { newformula1.minus1 <- reviseqtlnuminformula(newformula1.minus1, c(notdropped, newqtlnum1), c(newnum, revnewqtlnum1)) newformula1.minus2 <- reviseqtlnuminformula(newformula1.minus2, c(notdropped, newqtlnum1), c(newnum, revnewqtlnum1)) } } # drop covariates that are not in the formula if(!is.null(covar)) { theterms <- rownames(attr(terms(formula), "factors")) m <- match(colnames(covar), theterms) if(all(is.na(m))) covar <- NULL else covar <- covar[,!is.na(m),drop=FALSE] } # phenotype column if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("addpair can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 || pheno.col > nphe(cross)) stop("pheno.col should be between 1 and ", nphe(cross)) pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") # check phenotypes and covariates; drop ind'ls with missing values if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") pheno <- pheno[!hasmissing] qtl$n.ind <- sum(!hasmissing) if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] cross <- subset(cross, ind=!hasmissing) } } sexpgm <- getsex(cross) cross.attr <- attributes(cross) # fit the base model fit0 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod0 <- fit0$result.full[1,4] gmap <- NULL # form map for(i in 1:length(chr)) { ci <- chr[i] # get map of positions if(method=="imp") { if("map" %in% names(attributes(cross$geno[[ci]]$draws))) map <- attr(cross$geno[[ci]]$draws,"map") else { stp <- attr(cross$geno[[ci]]$draws, "step") oe <- attr(cross$geno[[ci]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[ci]]$draws))) stpw <- attr(cross$geno[[ci]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[ci]]$map,stp,oe,stpw) } } else { if("map" %in% names(attributes(cross$geno[[ci]]$prob))) map <- attr(cross$geno[[ci]]$prob,"map") else { stp <- attr(cross$geno[[ci]]$prob, "step") oe <- attr(cross$geno[[ci]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[ci]]$prob))) stpw <- attr(cross$geno[[ci]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[ci]]$map,stp,oe,stpw) } } # pull out the female map if there are sex-specific maps if(is.matrix(map)) map <- map[1,] w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",ci,".",w[o],sep="") map <- data.frame(chr=factor(rep(ci,length(map)),levels=ci), pos=as.numeric(map), stringsAsFactors=TRUE) rownames(map) <- w if(method=="imp") step <- attr(cross$geno[[ci]]$draws,"step") else step <- attr(cross$geno[[ci]]$prob,"step") if(step==0 || stepwidth.var) # just use markers eq.sp.pos <- rep(1,nrow(map)) else { eq.sp.pos <- seq(min(map[,2]),max(map[,2]),by=step) wh.eq.sp <- match(eq.sp.pos,map[,2]) if(any(is.na(wh.eq.sp))) { # this shouldn't happen warning("Possible error in determining the equally spaced positions.") wh.eq.sp <- wh.eq.sp[!is.na(wh.eq.sp)] } eq.sp.pos <- rep(0,nrow(map)) eq.sp.pos[wh.eq.sp] <- 1 } if(!incl.markers && any(eq.sp.pos==0)) { map <- map[eq.sp.pos==1,] eq.sp.pos <- eq.sp.pos[eq.sp.pos==1] } gmap <- rbind(gmap, cbind(map, eq.spacing=eq.sp.pos, xchr=inherits(cross$geno[[i]], "X"))) } lod <- matrix(ncol=nrow(gmap), nrow=nrow(gmap)) if(scanbothways) lod.m1 <- lod.m2 <- rep(NA, nrow(gmap)) for(i in 1:length(chr)) { ci <- chr[i] whi <- which(gmap[,1]==ci) for(j in i:length(chr)) { cj <- chr[j] whj <- which(gmap[,1]==cj) if(verbose) { if(is.null(newformula2)) cat("Scanning chr", ci, "and", cj, "\n") else cat("Scanning full model for chr", ci, "and", cj, "\n") } thechr <- c(qtlchr, ci, cj) thepos <- c(as.list(qtlpos), list(c(-Inf, Inf)), list(c(-Inf, Inf))) temp1 <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula1, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) - lod0 if(!is.null(newformula2)) { if(verbose) cat("Scanning add've model for chr", ci, "and", cj, "\n") temp2 <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula2, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) - lod0 } else { if(i != j && scanbothways) { if(verbose) cat("Scanning chr", cj, "and", ci, "\n") thechr <- c(qtlchr, cj, ci) temp1r <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula1, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) - lod0 } } if(i==j) { if(!is.null(newformula2)) temp1[upper.tri(temp1)] <- temp2[upper.tri(temp1)] else temp1 <- t(temp1) lod[whi,whi] <- temp1 } else { if(!is.null(newformula2)) { lod[whi,whj] <- t(temp2) lod[whj,whi] <- temp1 } else { lod[whi,whj] <- t(temp1) if(scanbothways) lod[whj,whi] <- t(temp1r) else lod[whj,whi] <- temp1 } } } if(scanbothways) { if(verbose) cat("Scanning chr", ci, "alone\n") thechr <- c(qtlchr, ci) thepos <- c(as.list(qtlpos), list(c(-Inf, Inf))) lod.m1[whi] <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula1.minus1, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) - lod0 lod.m2[whi] <- scanqtl(cross, pheno.col=pheno.col, chr=thechr, pos=thepos, covar=covar, formula=newformula1.minus2, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scanqtl, tol=tol, maxit=maxit, forceXcovar=forceXcovar) - lod0 } } result <- list(lod=lod, map=gmap, scanoneX=NULL) class(result) <- "scantwo" attr(result, "fullmap") <- fullmap attr(result,"method") <- method attr(result,"formula") <- deparseQTLformula(newformula1) if(scanbothways) { attr(result, "lod.minus1") <- lod.m1 attr(result, "lod.minus2") <- lod.m2 } if(is.null(newformula2)) attr(result, "addpair") <- TRUE result } ###################################################################### # consider, e.g., oldnum=5 and newnum = 3 # This functions replaces any instances of "Q5" or "q5" in the # formula with "Q3". ###################################################################### reviseqtlnuminformula <- function(formula, oldnum, newnum) { if(is.character(formula)) formula <- as.formula(formula) if(length(oldnum) != length(newnum)) stop("oldnum and newnum must be the same length.") newterms <- theterms <- colnames(attr(terms(formula), "factors")) for(i in seq(along=oldnum)) { g <- grep(paste("^[Qq]", oldnum[i], "$", sep=""), theterms) if(length(g) > 0) newterms[g] <- paste("Q", newnum[i], sep="") } intxn <- grep(":", theterms) if(length(intxn) > 0) { temp <- strsplit(theterms[intxn], ":") for(i in seq(along=temp)) { for(j in seq(along=oldnum)) { g <- grep(paste("^[Qq]", oldnum[j], "$", sep=""), temp[[i]]) if(length(g) > 0) temp[[i]][g] <- paste("Q", newnum[j], sep="") } } temp <- sapply(temp, paste, collapse=":") newterms[intxn] <- temp } as.formula(paste("y ~ ", paste(newterms, collapse=" + "), sep="")) } ###################################################################### # return TRUE or FALSE according to whether the formula is symmetric # in QTL qtlnum1 and qtlnum2 ###################################################################### qtlformulasymmetric <- function(formula, qtlnum1, qtlnum2) { theterms <- attr(terms(formula), "factors") rn <- rownames(theterms) wh1 <- grep(paste("^[Qq]", qtlnum1, "$", sep=""), rn) wh2 <- grep(paste("^[Qq]", qtlnum2, "$", sep=""), rn) cn <- colnames(theterms) if(length(wh1)==0 && length(wh2)==0) return(TRUE) if(length(wh1)==0 || length(wh2)==0) return(FALSE) revterms <- theterms revterms[c(wh1,wh2),] <- revterms[c(wh2, wh1),] theterms <- sort(apply(theterms, 2, paste, collapse="")) revterms <- sort(apply(revterms, 2, paste, collapse="")) all(theterms==revterms) } ###################################################################### # If qtlnum=5, drop any terms containing Q5 or q5 ###################################################################### dropfromqtlformula <- function(formula, qtlnum) { theterms <- colnames(attr(terms(formula), "factors")) todrop <- NULL for(i in seq(along=qtlnum)) { g <- grep(paste("^[Qq]", qtlnum[i], "$", sep=""), theterms) if(length(g) > 0) todrop <- c(todrop, g) } intxn <- grep(":", theterms) if(length(intxn) > 0) { temp <- strsplit(theterms[intxn], ":") for(i in seq(along=temp)) { for(j in seq(along=qtlnum)) { g <- grep(paste("^[Qq]", qtlnum[j], "$", sep=""), temp[[i]]) if(length(g) > 0) todrop <- c(todrop, intxn[i]) } } } todrop <- unique(todrop) as.formula(paste("y ~ ", paste(theterms[-todrop], collapse=" + "), sep="")) } ###################################################################### # addcovarint # # Try adding each QTL x covariate interaction (that is not # already in the formula), and give results similar to the drop-one # analysis. ###################################################################### addcovarint <- function(cross, pheno.col=1, qtl, covar=NULL, icovar, formula, method=c("imp","hk"), model=c("normal", "binary"), verbose=TRUE, pvalues=TRUE, simple=FALSE, tol=1e-4, maxit=1000, require.fullrank=FALSE) { if( !inherits(cross, "cross")) stop("The cross argument must be an object of class \"cross\".") if( !inherits(qtl, "qtl")) stop("The qtl argument must be an object of class \"qtl\".") if(missing(covar) || is.null(covar)) stop("Must include covariate data frame.") if(!is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("addcovarint can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 | pheno.col > nphe(cross)) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") if(missing(icovar)) stop("Must include icovar (the covariate to consider in interactions)") if(!is.character(icovar) || any(is.na(match(icovar, colnames(covar))))) stop("icovar must be a vector of character strings corresonding to columns in covar.") method <- match.arg(method) model <- match.arg(model) # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") } # check phenotypes and covariates; drop ind'ls with missing values phcovar <- cbind(pheno, covar) if(any(is.na(phcovar))) { if(ncol(phcovar)==1) hasmissing <- is.na(phcovar) else hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { warning("Dropping ", sum(hasmissing), " individuals with missing phenotypes.\n") pheno <- pheno[!hasmissing] qtl$n.ind <- sum(!hasmissing) if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) covar <- covar[!hasmissing,,drop=FALSE] cross <- subset(cross, ind=!hasmissing) } } # number of covariates n.covar <- ncol(covar) # if formula is missing, build one # all QTLs and covarariates will be additive by default n.qtl <- qtl$n.qtl if(missing(formula)) { tmp.Q <- paste("Q", 1:n.qtl, sep="") # QTL term names formula <- "y~Q1" if(n.qtl > 1) for (i in 2:n.qtl) formula <- paste(formula, tmp.Q[i], sep="+") if (n.covar) { # if covarariate is not empty tmp.C <- colnames(covar) # covarariate term names for(i in 1:n.covar) formula <- paste(formula, tmp.C[i], sep="+") } formula <- as.formula(formula) } # check input formula formula <- checkformula(formula, qtl$altname, colnames(covar)) # make sure icovar is in the formula m <- is.na(match(icovar, rownames(attr(terms(formula), "factors")))) if(any(m)) formula <- as.formula(paste(deparseQTLformula(formula), "+", paste(icovar[m], collapse="+"), sep="")) # look for interactions that haven't been added factors <- attr(terms(formula), "factors") if(sum(factors[1,])==0) factors <- factors[-1,] # replace QTL altnames (Q1 etc) with real names (chr1@20 etc) fn <- fn.alt <- rownames(factors) qan <- qtl$altname qn <- qtl$name m <- match(fn, qan) fn.alt[!is.na(m)] <- qn[m[!is.na(m)]] theqtl <- fn[fn != fn.alt] theqtl.alt <- fn.alt[fn != fn.alt] theint <- theint.alt <- NULL for(i in icovar) { theint <- c(theint, paste(theqtl, ":", i, sep="")) theint.alt <- c(theint.alt, paste(theqtl.alt, ":", i, sep="")) } wh <- match(theint, colnames(factors)) theint <- theint[is.na(wh)] theint.alt <- theint.alt[is.na(wh)] n2test <- length(theint) if(n2test == 0) { if(verbose) cat("No QTL x covariate interactions to add.\n") return(NULL) } sexpgm <- getsex(cross) cross.attr <- attributes(cross) # fit base model thefit0 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit) matrix0.rank <- attr(thefit0, "matrix.rank") matrix0.ncol <- attr(thefit0, "matrix.ncol") results <- matrix(ncol=7, nrow=n2test) dimnames(results) <- list(theint.alt, c("df", "Type III SS", "LOD", "%var", "F value", "Pvalue(Chi2)", "Pvalue(F)")) matrix1.rank <- matrix1.ncol <- rep(0, n2test) for(k in seq(along=theint)) { thefit1 <- fitqtlengine(pheno=pheno, qtl=qtl, covar=covar, formula=as.formula(paste(deparseQTLformula(formula), theint[k], sep="+")), method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit) results[k,1] <- thefit1$result.full[1,1] - thefit0$result.full[1,1] results[k,2] <- thefit1$result.full[1,2] - thefit0$result.full[1,2] results[k,3] <- thefit1$result.full[1,4] - thefit0$result.full[1,4] results[k,4] <- 100*(1-10^(-2*thefit1$result.full[1,4]/qtl$n.ind)) - 100*(1-10^(-2*thefit0$result.full[1,4]/qtl$n.ind)) results[k,5] <- (results[k,2]/results[k,1])/thefit1$result.full[2,3] results[k,6] <- pchisq(results[k,3]*2*log(10), results[k,1], lower.tail=FALSE) results[k,7] <- pf(results[k,5], results[k,1], thefit1$result.full[3,1], lower.tail=FALSE) matrix1.rank[k] <- attr(thefit1, "matrix.rank") matrix1.ncol[k] <- attr(thefit1, "matrix.ncol") } matrix.fullrank <- (matrix1.rank - matrix0.rank == matrix1.ncol - matrix0.ncol) results <- as.data.frame(results, stringsAsFactors=TRUE) class(results) <- c("addcovarint", "data.frame") attr(results, "model") <- model attr(results, "method") <- method attr(results, "formula") <- deparseQTLformula(formula) if(simple) pvalues <- FALSE attr(results, "pvalues") <- pvalues attr(results, "simple") <- simple attr(results, "matrix.fullrank") <- matrix.fullrank if(require.fullrank) results[!matrix.fullrank,3] <- 0 results } print.addcovarint <- function(x, ...) { meth <- attr(x, "method") mod <- attr(x, "model") simp <- attr(x, "simple") if(is.null(mod)) mod <- "normal" if(is.null(meth)) meth <- "unknown" if(mod=="binary" || simp) attr(x, "pvalues") <- FALSE if(meth=="imp") meth <- "multiple imputation" else if(meth=="hk") meth <- "Haley-Knott regression" cat("Method:", meth, "\n") cat("Model: ", mod, "phenotype\n") cat("Model formula:") w <- options("width")[[1]] printQTLformulanicely(attr(x, "formula"), " ", w+5, w) cat("\n") cat("Add one QTL x covar interaction at a time table:\n") cat("--------------------------------------------\n") pval <- attr(x, "pvalues") if(!is.null(pval) && !pval) x <- x[,-ncol(x)+(0:1)] if(mod == "binary" || simp) x <- x[,c(1,3,4), drop=FALSE] printCoefmat(x, digits=4, cs.ind=1, P.values=pval, has.Pvalue=pval) cat("\n") } summary.addcovarint <- function(object, ...) object # end of addqtl.R qtl/R/scanoneboot.R0000644000176200001440000001051412770016226013714 0ustar liggesusers##################################################################### # # scanoneboot.R # # copyright (c) 2007-2011, Karl W Broman # last modified Mar, 2011 # first written Apr, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: scanoneboot, summary.scanoneboot, print.scanoneboot # ###################################################################### ###################################################################### # scanoneboot: function to get bootstrap-based confidence interval for # QTL location ###################################################################### scanoneboot <- function(cross, chr, pheno.col=1, model=c("normal","binary","2part","np"), method=c("em","imp","hk","ehk","mr","mr-imp","mr-argmax"), addcovar=NULL, intcovar=NULL, weights=NULL, use=c("all.obs", "complete.obs"), upper=FALSE, ties.random=FALSE, start=NULL, maxit=4000, tol=1e-4, n.boot=1000, verbose=FALSE) { if(!missing(chr)) cross <- subset(cross, chr) if(nchr(cross) != 1) { # scan just one chromosome warning("Considering just the first chromosome (", names(cross$geno)[1], ").") cross <- subset(cross, names(cross$geno)[1]) } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(length(pheno.col) > 1) stop("pheno.col should indicate a single phenotype") if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 || pheno.col > nphe(cross)) stop("pheno.col should be between 1 and ", nphe(cross)) # do scan with actual data out <- scanone(cross, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol) maxlod <- max(out[,3],na.rm=TRUE) w <- which(!is.na(out[,3]) & out[,3] == maxlod) results <- rep(NA, n.boot) n.ind <- nind(cross) n.prnt <- floor(n.boot/20) for(i in 1:n.boot) { temp <- subset(cross, ind=sample(n.ind, replace=TRUE)) out <- scanone(temp, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol) mx <- max(out[,3],na.rm=TRUE) w <- out[!is.na(out[,3]) & out[,3]==mx,2] if(length(w) > 1) w <- sample(w,1) results[i] <- w if(verbose && ((i-1) %% n.prnt) == 0) cat("replicate", i, "\n") } attr(results, "results") <- out class(results) <- "scanoneboot" results } # summary function for scanoneboot output summary.scanoneboot <- function(object, prob=0.95, expandtomarkers=FALSE, ...) { lo <- (1-prob)/2 results <- attr(object, "results") o <- max(results) qu <- quantile(object, c(lo, 1-lo)) wh1 <- which(results[,2] <= qu[1]) wh1 <- wh1[length(wh1)] wh2 <- which(results[,2] >= qu[2]) wh2 <- wh2[1] if(expandtomarkers) { markerpos <- (1:nrow(results))[-grep("^c.+\\.loc-*[0-9]+(\\.[0-9]+)*$", rownames(results))] if(any(markerpos <= wh1)) wh1 <- max(markerpos[markerpos <= wh1]) if(any(markerpos >= wh2)) wh2 <- min(markerpos[markerpos >= wh2]) } rbind(results[wh1,], o, results[wh2,]) } # print function for scanoneboot output print.scanoneboot <- function(x, ...) { print(as.numeric(x)) } # end of scanoneboot.R qtl/R/countXO.R0000644000176200001440000000630614326316151013004 0ustar liggesusers###################################################################### # # countXO.R # # copyright (c) 2008-2022, Karl W Broman # last modified Oct, 2022 # first written Feb, 2008 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: countXO # ###################################################################### ###################################################################### # # countXO: Count number of obligate crossovers for each individual # on individual chromosomes or overall # # if bychr=TRUE, return matrix with no. obligate crossovers for each # individual on each chromosome # =FALSE, return vector with total no. crossovers across the # selected chromosomes ###################################################################### countXO <- function(cross, chr, bychr=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # pull out relevant chromosome if(!missing(chr)) cross <- subset(cross,chr=chr) chr.name <- names(cross$geno) type <- crosstype(cross) n.ind <- nind(cross) n.chr <- nchr(cross) nxo <- matrix(0, ncol=n.chr, nrow=n.ind) id <- getid(cross) if(is.null(id)) id <- 1:n.ind dimnames(nxo) <- list(id, chr.name) for(i in 1:n.chr) { chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") xchr <- TRUE else xchr <- FALSE # which type of cross is this? if(type == "f2" || type=="bcsft") { if(!xchr) # autosomal func <- "R_countXO_f2" else func <- "R_countXO_bc" # X chromsome } else if(type == "bc" || type=="riself" || type=="risib" || type=="dh" || type=="haploid") func <- "R_countXO_bc" else if(type == "4way") func <- "R_countXO_4way" else if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") { func <- "R_countXO_ril48" if(xchr) warning("countXO not working properly for the X chromosome for 4- or 8-way RIL.") } else stop("ripple not available for cross ", type) # data to be input genodat <- cross$geno[[i]]$data genodat[is.na(genodat)] <- 0 n.mar <- ncol(genodat) if(n.mar > 1) { z <- .C(func, as.integer(n.ind), as.integer(n.mar), as.integer(genodat), oblxo=as.integer(rep(0,n.ind)), PACKAGE="qtl") nxo[,i] <- z$oblxo } } if(!bychr) nxo <- apply(nxo, 1, sum) nxo } # end of countXO.R qtl/R/mqmutil.R0000644000176200001440000002370313576241200013073 0ustar liggesusers##################################################################### # # mqmutil.R # # Copyright (c) 2009-2018, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified Mar 2018 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: ourstop # ourline # mqmextractmarkers # estimatemarkerlod # stringPhenoToInt # addmarkerstointervalmap # mqmtestnormal # mqmgetmodel # # ##################################################################### # Returns the effective version of R/qtl and MQM. This is used for testing, # debugging, and error reporting on MQM itself. We could also R/qtl tagged # releases, but they may be faster/slower than the development version. Also # the C libraries may be used outside R. Returns a list with values for # RQTL, RMQM and MQM. mqm_version <- function() { rqtl_version = qtlversion() rmqm_version = "0.90-pre1" mqm_version = rmqm_version # fetch from C code, later list(RQTL=rqtl_version, RMQM=rmqm_version, MQM=mqm_version) } groupclusteredheatmap <- function(cross, clusteredheatmapresult, height){ items <- cut(clusteredheatmapresult$Rowv,h=height)$lower phenotypes <- names(pull.pheno(cross)) groups <- vector(length(items), mode="list") cnt <- 1 for(x in items){ nam <- labels(x) groups[[cnt]] <- which(phenotypes %in% nam) cnt <- cnt+1 } groups } ourstop <- function(...){ stop(...) } ourline <- function(){ cat("------------------------------------------------------------------\n") } simulatemissingdata <- function(cross,percentage=5){ if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } for(x in 1:length(cross$geno)){ numtoDROP <- length(cross$geno[[x]]$data)*(percentage/100) toDROP <- sample(length(cross$geno[[x]]$data))[1:numtoDROP] cross$geno[[x]]$data[toDROP] <- NA } cross } # Return the real markers in the set (remove fake ones) mqmextractmarkers <- function(mqmresult){ if(!inherits(mqmresult, "scanone")){ stop("Wrong type of result file, please supply a valid scanone (from MQM) object.") } result <- NULL for(x in 1:nrow(mqmresult)){ # for every marker... marker = mqmresult[x,] found = grep('.loc',rownames(marker)) if (length(found)==0) { result <- rbind(result,marker) } } class(result) <- class(mqmresult) result } # Return the fake markers in the set (remove real ones) mqmextractpseudomarkers <- function(mqmresult){ if(!inherits(mqmresult, "scanone")){ stop("Wrong type of result file, please supply a valid scanone (from MQM) object.") } result <- NULL for(x in 1:nrow(mqmresult)){ # for every marker... marker = mqmresult[x,] found = grep('.loc',rownames(marker)) if(length(found)!=0) { result <- rbind(result,marker) } } class(result) <- class(mqmresult) result } stepsize <- function(mqmpseudomarkers){ step <- as.numeric(strsplit(rownames(mqmpseudomarkers)[2],"loc")[[1]][2])-as.numeric(strsplit(rownames(mqmpseudomarkers)[1],"loc")[[1]][2]) step } estimatemarkerlod <- function(interresults){ #For an okay return, with all markers filled every REAL marker has to be surrounded by interval markers #It does skip markers untill we reach the next pseudomarker. When one of the assumptions fails #we return, so there could be markers without a LOD score if(all(is.na(interresults[,3]))) return (interresults) pY <- interresults[1,3] pX <- interresults[1,2] if(is.na(pY) || is.na(pX)) return (interresults) #The first marker needs to be a interval marker for(x in 2:nrow(interresults)){ if(is.na(interresults[x,3])){ y <- x while(y <= nrow(interresults) && is.na(interresults[y,3]) && interresults[y,1] == interresults[x,1]){ y <- y + 1 } nY <- interresults[y,3] nX <- interresults[y,2] if(is.na(nY) || is.na(nX)) return (interresults) #The next marker also needs to be a interval marker distp = interresults[x,2] - pX distn = nX - interresults[x,2] disttot = distn+distp interresults[x,3] <- (((nY-pY)/disttot) * distp) + pY interresults[x,4] <- 1 interresults[x,5] <- interresults[x,3] } pY <- interresults[x,3] pX <- interresults[x,2] } interresults } #Function to go from character phenotypes to numeric column numbers #Based on the code in the scanone function stringPhenoToInt <- function(cross,pheno.col){ if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1){ stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""),collapse=" ")) }else{ stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno.col } addmarkerstointervalmap <- function(cross,intervalresult,verbose=FALSE){ if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(!inherits(intervalresult, "scanone")) { stop("Wrong type of result file, please supply a valid scanone (from MQM) object.") } map <- pull.map(cross) newres <- NULL intervalmaploc <- 1 n <- NULL for(chr in 1:length(map)){ for(mar in 1:length(map[[chr]])){ if(verbose) cat(chr,"Placing marker: ",names(map[[chr]])[mar]," at ",map[[chr]][mar],"\t",intervalresult[intervalmaploc,2],"\n") if((chrtype(map[[chr]])=="A")){ while(intervalresult[intervalmaploc,2] < map[[chr]][mar] || intervalresult[intervalmaploc,1] < chr ){ newres <- rbind(newres,intervalresult[intervalmaploc,]) n <- c(n,rownames(intervalresult)[intervalmaploc]) intervalmaploc <- intervalmaploc+1 } if(intervalresult[intervalmaploc,2] == map[[chr]][mar]){ newres <- rbind(newres,c(chr,map[[chr]][mar],intervalresult[intervalmaploc,3],intervalresult[intervalmaploc,4],intervalresult[intervalmaploc,5])) while(intervalresult[intervalmaploc,2] == map[[chr]][mar]){ intervalmaploc <- intervalmaploc+1 } }else{ newres <- rbind(newres,c(chr,map[[chr]][mar],NA,NA,NA)) } n <- c(n,names(map[[chr]])[mar]) colnames(newres) <- colnames(intervalresult) } } while(intervalmaploc < nrow(intervalresult) && intervalresult[intervalmaploc,1] <= chr ){ if((chrtype(map[[chr]])=="A")){ newres <- rbind(newres,intervalresult[intervalmaploc,]) n <- c(n,rownames(intervalresult)[intervalmaploc]) } intervalmaploc <- intervalmaploc+1 } } # if(intervalmaploc <= nrow(intervalresult)){ # newres <- rbind(newres,intervalresult[intervalmaploc,]) #n <- c(n,rownames(intervalresult)[intervalmaploc]) # intervalmaploc <- intervalmaploc+1 # } rownames(newres) <- n newres <- estimatemarkerlod(newres) class(newres) <- c("scanone",class(newres)) newres } mqmtestnormal <- function(cross, pheno.col=1,significance=0.05, verbose=FALSE){ if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } # if augmented data, pull out just the unique individuals if("mqm" %in% names(cross)) { theind <- cross$mqm$augIND cross <- subset(cross, ind=match(unique(theind), theind)) } # shapiro.test works only for 3 <= n <= 5000 if(nind(cross) < 3 || nind(cross) > 5000) { warning("Can perform test of normality only if 3 <= n <= 5000") return(TRUE) # I guess this should be NA } if(significance > 1 || significance <= 0){ stop("significance should be between 0 and 1") } # if pheno.col has multiple entries if(length(pheno.col) > 1) { returnval <- rep(NA, length(pheno.col)) for(i in seq(along=pheno.col)) returnval[i] <- mqmtestnormal(cross, pheno.col=pheno.col[i], significance=significance, verbose=verbose) names(returnval) <- colnames(cross$pheno)[pheno.col] return(returnval) } returnval <- FALSE if(pheno.col <0 || pheno.col > nphe(cross)){ stop("No such phenotype (pheno.col = ",pheno.col,")") } if(!is.numeric(cross$pheno[,pheno.col])){ stop("Please supply a numeric trait (pheno.col = ",pheno.col," is not numeric)") } if((shapiro.test(cross$pheno[,pheno.col])$p.value) > significance){ if(verbose) cat("Trait distribution normal\n") returnval<- TRUE }else{ if(verbose) cat("Trait distribution not normal\n") returnval<- FALSE } returnval } mqmgetmodel <- function(scanresult){ if(!is.null(scanresult)){ model <- attr(scanresult,"mqmmodel") model }else{ stop("Please supply a scan result made by using mqm with cofactors") } } # end of mqmutil.R qtl/R/calc.genoprob.R0000644000176200001440000003774513576241200014132 0ustar liggesusers###################################################################### # # calc.genoprob.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: calc.genoprob # ###################################################################### ###################################################################### # # calc.genoprob: calculate genotype probabilities conditional on # observed marker genotypes # ###################################################################### calc.genoprob <- function(cross, step=0, off.end=0, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), stepwidth=c("fixed", "variable", "max")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # map function map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h stepwidth <- match.arg(stepwidth) # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) # calculate genotype probabilities one chromosome at a time for(i in 1:n.chr) { if(n.mar[i]==1) temp.offend <- max(c(off.end,5)) else temp.offend <- off.end chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") xchr <- TRUE else xchr <- FALSE # which type of cross is this? if(type == "f2") { one.map <- TRUE if(!xchr) { # autosomal cfunc <- "calc_genoprob_f2" n.gen <- 3 gen.names <- getgenonames("f2", "A", cross.attr=attributes(cross)) } else { # X chromsome cfunc <- "calc_genoprob_bc" n.gen <- 2 gen.names <- c("g1","g2") } } else if(type == "bc") { cfunc <- "calc_genoprob_bc" n.gen <- 2 if(!xchr) gen.names <- getgenonames("bc", "A", cross.attr=attributes(cross)) else gen.names <- c("g1","g2") one.map <- TRUE } else if(type == "riself" || type=="risib" || type=="dh" || type=="haploid") { cfunc <- "calc_genoprob_bc" n.gen <- 2 gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) one.map <- TRUE } else if(type == "4way") { cfunc <- "calc_genoprob_4way" n.gen <- 4 one.map <- FALSE gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) } else if(type=="ri8sib" || type=="ri4sib" || type=="ri8self" || type=="ri4self" || type=="bgmagic16") { cfunc <- paste("calc_genoprob_", type, sep="") if(type=="bgmagic16") n.gen <- 16 else n.gen <- as.numeric(substr(type, 3, 3)) one.map <- TRUE gen.names <- LETTERS[1:n.gen] if(xchr) warning("calc.genoprob not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE cfunc <- "calc_genoprob_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(!xchr) { # autosomal gen.names <- getgenonames("bcsft", "A", cross.attr=attributes(cross)) n.gen <- 2 + (cross.scheme[2] > 0) } else { ## X chr cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 gen.names <- c("g1","g2") n.gen <- 2 } } else if(type == "ri8selfIRIP1") { one.map <- TRUE cfunc <- "calc_genoprob_ri8selfIRIP1" n.gen <- 8 gen.names <- LETTERS[1:n.gen] } else stop("calc.genoprob not available for cross type ", type, ".") # genotype data gen <- cross$geno[[i]]$data gen[is.na(gen)] <- 0 # recombination fractions if(one.map) { # recombination fractions map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf, sub("^ri", "", type), chr_type) rf[rf < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=length(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,names(map)) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- names(map) } else { map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(map[2,])) rf2[rf2 < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=ncol(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,dimnames(map)[[2]]) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- colnames(map) } ## Cross scheme being added for Ft and BCs. ## cross_scheme = c(BC = s, F = t). ## BC has cross_scheme = c(1,0) ## F2 has cross_scheme = c(0,2) ## BCsFt has cross_scheme = c(s,t) ## Other designs such as Ft with test cross don't quite fit in (yet). ## *** Need to change all the C routines!! # call the C function if(one.map) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- as.double(rep(0,n.gen*n.ind*n.pos)) if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(error.prob), # genoprob=as.double(temp), PACKAGE="qtl") } else { z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(rf2), # recombination fractions as.double(error.prob), # genoprob=as.double(rep(0,n.gen*n.ind*n.pos)), PACKAGE="qtl") } # re-arrange marginal probabilites cross$geno[[i]]$prob <- array(z$genoprob,dim=c(n.ind,n.pos,n.gen)) dimnames(cross$geno[[i]]$prob) <- list(NULL, marnames, gen.names) # attribute set to the error.prob value used, for later # reference, especially by calc.errorlod() attr(cross$geno[[i]]$prob, "map") <- map attr(cross$geno[[i]]$prob,"error.prob") <- error.prob attr(cross$geno[[i]]$prob,"step") <- step attr(cross$geno[[i]]$prob,"off.end") <- temp.offend attr(cross$geno[[i]]$prob,"map.function") <- map.function attr(cross$geno[[i]]$prob,"stepwidth") <- stepwidth } # end loop over chromosomes # 4- and 8-way RIL: reorganize the results if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") cross <- reorgRIgenoprob(cross) cross } ###################################################################### # # calc.genoprob.special: # special version used by calc.errorlod # for each individual and marker, calculate probabilities allowing # that genotype to be in error but assuming that all other genotypes # are correct # ###################################################################### calc.genoprob.special <- function(cross, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") step <- 0 off.end <- 0 stepwidth <- "fixed" # map function map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) # calculate genotype probabilities one chromosome at a time for(i in 1:n.chr) { if(n.mar[i]==1) temp.offend <- max(c(off.end,5)) else temp.offend <- off.end chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") xchr <- TRUE else xchr <- FALSE # which type of cross is this? if(type == "f2") { one.map <- TRUE if(!xchr) { # autosomal cfunc <- "calc_genoprob_special_f2" n.gen <- 3 gen.names <- getgenonames("f2", "A", cross.attr=attributes(cross)) } else { # X chromsome cfunc <- "calc_genoprob_special_bc" n.gen <- 2 gen.names <- c("g1","g2") } } else if(type == "bc") { cfunc <- "calc_genoprob_special_bc" n.gen <- 2 if(!xchr) gen.names <- getgenonames("bc", "A", cross.attr=attributes(cross)) else gen.names <- c("g1","g2") one.map <- TRUE } else if(type == "riself" || type=="risib" || type=="dh" || type=="haploid") { cfunc <- "calc_genoprob_special_bc" n.gen <- 2 gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) one.map <- TRUE } else if(type == "4way") { cfunc <- "calc_genoprob_special_4way" n.gen <- 4 one.map <- FALSE gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) } else if(type=="ri8sib" || type=="ri4sib" || type=="ri8self" || type=="ri4self" || type=="bgmagic16") { cfunc <- paste("calc_genoprob_special_", type, sep="") if(type=="bgmagic16") n.gen <- 16 else n.gen <- as.numeric(substr(type, 3, 3)) one.map <- TRUE gen.names <- LETTERS[1:n.gen] if(xchr) warning("calc.genoprob.special not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE cfunc <- "calc_genoprob_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(!xchr) { # autosomal if(cross.scheme[2] == 0) { gen.names <- getgenonames("bc", "A", cross.attr=attributes(cross)) n.gen <- 2 } else { gen.names <- getgenonames("f2", "A", cross.attr=attributes(cross)) n.gen <- 3 } } else { ## X chr cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 gen.names <- c("g1","g2") n.gen <- 2 } } else stop("calc.genoprob.special not available for cross type ", type, ".") # genotype data gen <- cross$geno[[i]]$data gen[is.na(gen)] <- 0 # recombination fractions if(one.map) { # recombination fractions map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf,sub("^ri", "", type), chr_type) rf[rf < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=length(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,names(map)) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- names(map) } else { map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(map[2,])) rf2[rf2 < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=ncol(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,dimnames(map)[[2]]) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- colnames(map) } # call the C function if(one.map) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- as.double(rep(0,n.gen*n.ind*n.pos)) if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(error.prob), # genoprob=as.double(temp), PACKAGE="qtl") } else { z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(rf2), # recombination fractions as.double(error.prob), # genoprob=as.double(rep(0,n.gen*n.ind*n.pos)), PACKAGE="qtl") } # re-arrange marginal probabilites cross$geno[[i]]$prob <- array(z$genoprob,dim=c(n.ind,n.pos,n.gen)) dimnames(cross$geno[[i]]$prob) <- list(NULL, marnames, gen.names) # attribute set to the error.prob value used, for later # reference, especially by calc.errorlod() attr(cross$geno[[i]]$prob, "map") <- map attr(cross$geno[[i]]$prob,"error.prob") <- error.prob attr(cross$geno[[i]]$prob,"step") <- step attr(cross$geno[[i]]$prob,"off.end") <- temp.offend attr(cross$geno[[i]]$prob,"map.function") <- map.function attr(cross$geno[[i]]$prob,"stepwidth") <- stepwidth } # end loop over chromosomes cross } # end of calc.genoprob.R qtl/R/comparegeno.R0000644000176200001440000000707713576462636013732 0ustar liggesusers###################################################################### # comparegeno ###################################################################### comparegeno <- function(cross, what=c("proportion","number", "both")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") what <- match.arg(what) g <- pull.geno(cross) g[is.na(g)] <- 0 n.ind <- nrow(g) n.mar <- ncol(g) z <- .C("R_comparegeno", as.integer(g), as.integer(n.ind), as.integer(n.mar), n.match=as.integer(rep(0,n.ind^2)), n.missing=as.integer(rep(0,n.ind^2)), PACKAGE="qtl") if(what=="number") { z <- matrix(z$n.match,n.ind,n.ind) } else { if(what=="proportion") { z <- matrix(z$n.match/(n.mar-z$n.missing),n.ind,n.ind) diag(z) <- NA } else { prop <- matrix(z$n.match/(n.mar-z$n.missing),n.ind,n.ind) z <- matrix(z$n.match,n.ind,n.ind) z[lower.tri(z)] <- prop[lower.tri(z)] } } id <- getid(cross) if(is.null(id)) id <- as.character(seq_len(nind(cross))) dimnames(z) <- list(id, id) class(z) <- c("comparegeno", class(z)) attr(z, "what") <- what z } # report which pairs of individuals have nearly-matching genotypes summary.comparegeno <- function(object, thresh=0.9, ...) { what <- attr(object, "what") if(is.null(what)) what <- "proportion" if(what=="number" && thresh < 1) thresh <- thresh*max(diag(object), na.rm=TRUE) wh <- which(!is.na(object) & object >= thresh & row(object) > col(object), arr.ind=TRUE) if(length(wh)==0) { result <- data.frame(ind1=character(0), ind2=character(0), prop_match=numeric(0), stringsAsFactors=FALSE) class(result) <- c("summary.comparegeno", "data.frame") return(result) } id <- rownames(object) if(is.null(id)) id <- as.character(seq_len(nrow(object))) # create results object result <- data.frame(ind1=id[wh[,2]], ind2=id[wh[,1]], prop_match=rep(0, nrow(wh)), stringsAsFactors=FALSE) # fill in values with lower triangle for(i in seq_len(nrow(wh))) { result[i,3] <- object[wh[i,1], wh[i,2]] } # if both count and proportion is provided, determine number of markers if(what=="both") { result <- cbind(result, n_markers=rep(0, nrow(wh))) for(i in seq_len(nrow(wh))) { result[i,4] <- round(object[wh[i,2], wh[i,1]]/object[wh[i,1], wh[i,2]]) } } if(what=="number") { # change column name colnames(result)[3] <- "number_match" } # sort by decreasing percent matching result <- result[order(result[,3], decreasing=TRUE),,drop=FALSE] rownames(result) <- 1:nrow(result) class(result) <- c("summary.comparegeno", "data.frame") result } print.summary.comparegeno <- function(x, ...) { if(nrow(x)==0) { cat("No pairs above threshold.\n") } else { print.data.frame(x, digits=3) } } plot.comparegeno <- function(x, breaks=NULL, main="", xlab="Proportion matching genotypes", ...) { vals <- x[lower.tri(x)] if(is.null(breaks)) breaks <- 2*sqrt(length(vals)) if(attr(x, "what")=="number" && missing(xlab)) { xlab <- "Number matching genotypes" } hist(vals, breaks=breaks, main=main, xlab=xlab, ...) rug(vals) invisible() } qtl/R/inferFounderHap.R0000644000176200001440000001007612770016226014464 0ustar liggesusers##################################################################### # # inferFounderHap.R # # copyright (c) 2011, Karl W Broman # last modified Dec, 2011 # first written Dec, 2011 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: inferFounderHap, restoreMWrilGeno # # This is for reconstructing the founder haplotypes in inbred lines # by a crude method using groups of adjacent SNPs # ###################################################################### inferFounderHap <- function(cross, chr, max.n.markers=15) { if(!missing(chr)) cross <- subset(cross, chr=chr) if(nchr(cross) > 1) { thechr <- names(cross$geno)[1] cross <- subset(cross, chr=thechr) warning("inferFounderHap is only for one chromosome; considering ", thechr) } # pull out genotypes for RIL and founders offspringGen <- restoreMWrilGeno(cross) founderGen <- cross$founderGeno # drop markers with any missing data in the founders nomissing <- apply(founderGen, 2, function(a) !any(is.na(a))) names(nomissing) <- colnames(offspringGen) if(!any(nomissing)) stop("No markers with complete founder genotypes") offspringGen <- offspringGen[,nomissing,drop=FALSE] founderGen <- founderGen[,nomissing,drop=FALSE] longbits <- .Machine$sizeof.long*8 if(max.n.markers > longbits-1) { max.n.markers <- longbits-1 warning("We can't use max.n.markers > ", longbits-1, ", so we're taking max.n.markers = ", longbits-1) } n.mar <- ncol(offspringGen) if(max.n.markers > n.mar) max.n.markers <- n.mar max.offset <- ceiling((max.n.markers-1)/2) n.ind <- nrow(offspringGen) n.founders <- nrow(founderGen) if(n.mar != ncol(founderGen)) stop("ncol(offspringGen) != ncol(founderGen)") if(any(!is.na(offspringGen) & offspringGen != 0 & offspringGen != 1)) stop("offspringGen should be NA, 0 or 1") if(any(!is.na(founderGen) & founderGen != 0 & founderGen != 1)) stop("founderGen should be NA, 0 or 1") offspringGen[is.na(offspringGen)] <- -1 z <- .C("R_inferFounderHap", as.integer(n.mar), as.integer(n.founders), as.integer(n.ind), as.integer(founderGen), as.integer(offspringGen), as.integer(max.offset), hap=as.integer(rep(0,n.mar * n.ind)), PACKAGE="qtl") z$hap[z$hap <= 0] <- NA fullhap <- matrix(ncol=length(nomissing), nrow=n.ind) fullhap[,nomissing] <- matrix(z$hap, ncol=n.mar, nrow=n.ind) colnames(fullhap) <- names(nomissing) fullhap } restoreMWrilGeno <- function(cross) { g <- pull.geno(cross) f <- cross$founderGeno uf <- unique(as.numeric(f[!is.na(f)])) f[is.na(f)] <- missingval <- min(uf)-1 g[is.na(g)] <- 0 n.mar <- ncol(g) n.ind <- nrow(g) n.str <- nrow(f) if(n.mar != ncol(f)) stop("no. genotypes inconsistent between offspring and founders.") crosses <- cross$cross if(ncol(crosses) != n.str || nrow(crosses) != n.ind) stop("Incompatiability in cross$cross dimension.") gen <- .C("R_restoreMWrilGeno", as.integer(n.ind), as.integer(n.mar), as.integer(n.str), as.integer(f), gen=as.integer(g), as.integer(crosses), as.integer(missingval), PACKAGE="qtl")$gen gen[gen==missingval] <- NA gen <- matrix(gen, nrow=n.ind, ncol=n.mar) colnames(gen) <- colnames(g) gen } # end of inferFounderHap.R qtl/R/read.cross.gary.R0000644000176200001440000001451613576241200014411 0ustar liggesusers###################################################################### # # read.cross.gary.R # # copyright (c) 2000-2019, Karl W Broman # last modified Dec, 2019 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.gary # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.gary # # read data in Gary's format # ###################################################################### read.cross.gary <- function(dir,genfile,mnamesfile,chridfile,phefile,pnamesfile,mapfile, estimate.map,na.strings) { # create file names if(missing(genfile)) genfile <- "geno.dat" if(missing(mnamesfile)) mnamesfile <- "mnames.txt" if(missing(chridfile)) chridfile <- "chrid.dat" if(missing(phefile)) phefile <- "pheno.dat" if(missing(pnamesfile)) pnamesfile <- "pnames.txt" if(missing(mapfile)) mapfile <- "markerpos.txt" if(!missing(dir) && dir != "") { genfile <- file.path(dir, genfile) mnamesfile <- file.path(dir, mnamesfile) chridfile <- file.path(dir, chridfile) phefile <- file.path(dir, phefile) if(!is.null(pnamesfile)) pnamesfile <- file.path(dir, pnamesfile) if(!is.null(mapfile)) mapfile <- file.path(dir, mapfile) } # read data allgeno <- as.matrix(read.table(genfile,na.strings="9"))+1 pheno <- as.matrix(read.table(phefile,na.strings=na.strings,header=FALSE)) chr <- scan(chridfile,what=character(),quiet=TRUE) mnames <- scan(mnamesfile,what=character(),quiet=TRUE) if(!is.null(mapfile)) { map <- read.table(mapfile,row.names=1) map <- map[mnames,1] map.included <- TRUE } else { map <- seq(0,by=5,len=length(mnames)) map.included <- FALSE } if(!is.null(pnamesfile)) pnames <- scan(pnamesfile,what=character(),quiet=TRUE) else pnames <- paste("pheno",1:ncol(pheno),sep="") # fix up map information # number of chromosomes uchr <- unique(chr) n.chr <- length(uchr) geno <- vector("list",n.chr) names(geno) <- uchr min.mar <- 1 for(i in 1:n.chr) { # loop over chromosomes # create map temp.map <- map[chr==uchr[i]] # deal with any markers that didn't appear in the marker pos file if(any(is.na(temp.map))) { o <- (seq(along=temp.map))[is.na(temp.map)] for(j in o) { if(j==1 || all(is.na(temp.map[1:(j-1)]))) { z <- min((seq(along=temp.map))[-o]) temp.map[j] <- min(temp.map,na.rm=TRUE)-(z-j+1) } else if(j==length(temp.map) || all(is.na(temp.map[-(1:j)]))) { z <- max((seq(along=temp.map))[-o]) temp.map[j] <- max(temp.map,na.rm=TRUE)+(j-z+1) } else { temp.map[j] <- (min(temp.map[-(1:j)],na.rm=TRUE)+ max(temp.map[1:(j-1)],na.rm=TRUE))/2 } } } names(temp.map) <- mnames[chr==uchr[i]] # pull out appropriate portion of genotype data data <- allgeno[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE] min.mar <- min.mar + length(temp.map) colnames(data) <- names(temp.map) geno[[i]] <- list(data=data,map=temp.map) if(uchr[i] == "X" || uchr[i] == "x") class(geno[[i]]) <- "X" else class(geno[[i]]) <- "A" } colnames(pheno) <- pnames # fix up phenotype data: make things numeric that look numeric sw2numeric_gary <- function(x) { pattern <- "^[ \t]*-*[0-9]*[.]*[0-9]*[ \t]*$" n <- sum(!is.na(x)) if(length(grep(pattern,as.character(x[!is.na(x)])))==n) return(as.numeric(as.character(x))) else return(x) } pheno <- data.frame(lapply(as.data.frame(pheno), sw2numeric_gary), stringsAsFactors=TRUE) # check that data dimensions match n.mar1 <- sapply(geno,function(a) ncol(a$data)) n.mar2 <- sapply(geno,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(geno,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { cat(n.ind1,n.ind2,"\n") stop("Number of individuals in genotypes and phenotypes do not match."); } if(any(n.mar1 != n.mar2)) { cat(n.mar1,n.mar2,"\n") stop("Numbers of markers in genotypes and marker names files do not match."); } # print some information about the amount of data read cat(" --Read the following data:\n"); cat("\t", n.ind1, " individuals\n"); cat("\t", sum(n.mar1), " markers\n"); cat("\t", n.phe, " phenotypes\n"); # determine map type: f2 or bc or 4way? if(max(allgeno[!is.na(allgeno)])<=2) type <- "bc" else type <- "f2" cross <- list(geno=geno,pheno=pheno) class(cross) <- c(type,"cross") # check that nothing is strange in the genotype data if(type=="f2") max.gen <- 5 else max.gen <- 2 u <- unique(allgeno) if(any(!is.na(u) & (u > max.gen | u < 1))) stop("There are stange values in the genotype data : ", paste(sort(u),collapse=":"), ".") cross$pheno <- as.data.frame(cross$pheno, stringsAsFactors=TRUE) # if map wasn't included, go through each chromosome and # make first marker at 0 cM. if(!map.included) { for(i in 1:nchr(cross)) cross$geno[[i]]$map <- cross$geno[[i]]$map - min(cross$geno[[i]]$map) } # return cross + indicator of whether to run est.map # [run est.map if map not included and estimate.map == TRUE] list(cross, (!map.included && estimate.map) ) } # end of read.cross.gary.R qtl/R/bcsft.R0000644000176200001440000002564414326314611012513 0ustar liggesusersconvert2bcsft <- function(cross, BC.gen = 0, F.gen = 0, estimate.map = TRUE, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), verbose=FALSE) { cross.class <- crosstype(cross) if(cross.class=="bcsft") cross.class <- "f2" if((cross.class %in% c("bc","f2"))) { class(cross) <- c("bcsft", "cross") ## If BC.gen = 0 and F.gen = 0, then set to BC1F0 (bc) or BC0F2 (f2). if(cross.class == "bc" & F.gen > 0) { stop("input cross has only 2 genotypes--cannot have F.gen > 0") if(BC.gen == 0) BC.gen <- 1 } if(cross.class == "f2") { if(F.gen == 0) { if(BC.gen == 0) F.gen <- 2 else stop("input cross has 3 genotypes--cannot have F.gen = 0") } } if(BC.gen < 0 | F.gen < 0) stop("BC.gen and F.gen cannot be negative") attr(cross, "scheme") <- c(BC.gen, F.gen) cross } else stop("cross object has to be of class bc or f2 to be converted to bcsft") # re-estimate map? if(estimate.map) { cat(" --Estimating genetic map\n") newmap <- est.map(cross, error.prob=error.prob, map.function=map.function, verbose=verbose) cross <- replace.map(cross, newmap) } cross } read.cross.bcsft <- function(..., BC.gen = 0, F.gen = 0, cross = NULL, force.bcsft = FALSE, estimate.map=TRUE) { ## Must specify s = BC.gen and t = F.gen. ## Later: Could import in clever way from qtlcart? See qtlcart_io.R and their software. ## Make sure we only estimate map once! if(is.null(cross)) # Estimate map at end of this routine (called read.cross.bcsft directly). cross <- read.cross(..., estimate.map = FALSE) else # Estimate map in parent read.cross() call (read.cross.bcsft is pass-through from read.cross). estimate.map <- FALSE force.bcsft <- force.bcsft | (BC.gen > 0 | F.gen > 0) if((crosstype(cross) %in% c("bc","f2","bcsft")) && force.bcsft) { # deal with ... args dots <- list(...) if("verbose" %in% names(dots)) verbose <- dots$verbose else verbose <- TRUE if("error.prob" %in% names(dots)) error.prob <- dots$error.prob else error.prob <- 0.0001 if("map.function" %in% names(dots)) map.function <- dots$map.function else map.function <- "haldane" cross <- convert2bcsft(cross, BC.gen, F.gen, estimate.map = estimate.map, error.prob=error.prob, map.function=map.function, verbose=verbose) } cross } ###################################################################### sim.cross.bcsft <- function(map,model,n.ind,error.prob,missing.prob, partial.missing.prob,keep.errorind, m,p,map.function, cross.scheme) { if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h if(any(sapply(map,is.matrix))) stop("Map must not be sex-specific.") ## cross.scheme = c(s,t) for bcsft. if(missing(cross.scheme)) stop("must specify cross.scheme for bcsft") if(length(cross.scheme) != 2) stop("cross.scheme for bcsft must have 2 values") cross.scheme <- round(cross.scheme) if(min(cross.scheme) < 0) stop("cross.scheme for bcsft must have 2 non-negative integers") n.eff <- 3 + (cross.scheme[2] > 0) ## chromosome types chr.type <- sapply(map,chrtype) n.chr <- length(map) if(is.null(model)) n.qtl <- 0 else { if(!((!is.matrix(model) && length(model) == n.eff) || (is.matrix(model) && ncol(model) == n.eff))) { stop(paste("Model must be a matrix with ", n.eff, " columns (chr, pos and effect", ifelse(n.eff == 4, "s", ""), ").", sep = "")) } if(!is.matrix(model)) model <- rbind(model) n.qtl <- nrow(model) if(any(model[,1] < 0 | model[,1] > n.chr)) stop("Chromosome indicators in model matrix out of range.") model[,2] <- model[,2]+1e-14 # so QTL not on top of marker } # if any QTLs, place qtls on map if(n.qtl > 0) { for(i in 1:n.qtl) { temp <- map[[model[i,1]]] if(model[i,2] < min(temp)) { temp <- c(model[i,2],temp) names(temp)[1] <- paste("QTL",i,sep="") } else if(model[i,2] > max(temp)) { temp <- c(temp,model[i,2]) names(temp)[length(temp)] <- paste("QTL",i,sep="") } else { j <- max((seq(along=temp))[temp < model[i,2]]) temp <- c(temp[1:j],model[i,2],temp[(j+1):length(temp)]) names(temp)[j+1] <- paste("QTL",i,sep="") } map[[model[i,1]]] <- temp } } geno <- vector("list", n.chr) names(geno) <- names(map) n.mar <- sapply(map,length) mar.names <- lapply(map,names) BC.gen <- cross.scheme[1] F.gen <- cross.scheme[2] - (BC.gen == 0) for(i in 1:n.chr) { # simulate genotype data bcallele1 <- sim.bcg(n.ind, map[[i]], m, p, map.function) - 1 ## BCs: multiply independent instances of meiosis together. if(BC.gen > 0) { if(BC.gen > 1) for(j in seq(2, BC.gen)) bcallele1 <- bcallele1 * (sim.bcg(n.ind, map[[i]], m, p, map.function) - 1) } if(F.gen == 0) ## BCs only. thedata <- bcallele1 + 1 else { if(chr.type[i] == "X") { if(F.gen > 1) for(j in seq(F.gen)) bcallele1 <- bcallele1 * (sim.bcg(n.ind, map[[i]], m, p, map.function) - 1) thedata <- bcallele1 + 1 } else { ## chr.type[i] != "X" if(BC.gen > 0) { ## Two unique alleles from BC(s). bcallele2 <- bcallele1 * (sim.bcg(n.ind, map[[i]], m, p, map.function) - 1) bcallele1 <- bcallele1 * (sim.bcg(n.ind, map[[i]], m, p, map.function) - 1) } else ## Starting from F(1) with two unique alleles. bcallele2 <- sim.bcg(n.ind, map[[i]], m, p, map.function) - 1 if(F.gen > 1) for(j in seq(2, F.gen)) { ## need two instances. allelemask1 <- sim.bcg(n.ind, map[[i]], m, p, map.function) - 1 allelemask2 <- sim.bcg(n.ind, map[[i]], m, p, map.function) - 1 bcallele1 <- bcallele1 * allelemask1 + bcallele2 * (1 - allelemask1) bcallele2 <- bcallele2 * allelemask2 + bcallele1 * (1 - allelemask2) } thedata <- bcallele1 + bcallele2 + 1 } } dimnames(thedata) <- list(NULL,mar.names[[i]]) geno[[i]] <- list(data = thedata, map = map[[i]]) class(geno[[i]]) <- chr.type[i] class(geno[[i]]$map) <- NULL } # end loop over chromosomes # simulate phenotypes pheno <- rnorm(n.ind,0,1) if(n.qtl > 0) { # find QTL positions in genotype data QTL.chr <- QTL.loc <- NULL for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) { QTL.chr <- c(QTL.chr,rep(i,length(o))) QTL.loc <- c(QTL.loc,o) } } # incorporate QTL effects for(i in 1:n.qtl) { QTL.geno <- geno[[QTL.chr[i]]]$data[,QTL.loc[i]] pheno[QTL.geno==2] <- pheno[QTL.geno==2] + model[i,n.eff] if(n.eff == 4) { pheno[QTL.geno==1] <- pheno[QTL.geno==1] - model[i,3] pheno[QTL.geno==3] <- pheno[QTL.geno==3] + model[i,3] } } } # end simulate phenotype n.mar <- sapply(geno, function(a) length(a$map)) # add errors if(error.prob > 0) { for(i in 1:n.chr) { if(chr.type[i]=="X") { a <- sample(0:1,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob)) geno[[i]]$data[a == 1] <- 3 - geno[[i]]$data[a == 1] } else { a <- sample(0:2,n.mar[i]*n.ind,replace=TRUE, prob=c(1-error.prob,error.prob/2,error.prob/2)) if(any(a>0 & geno[[i]]$data==1)) geno[[i]]$data[a>0 & geno[[i]]$data==1] <- (geno[[i]]$data+a)[a>0 & geno[[i]]$data==1] if(any(a>0 & geno[[i]]$data==2)) { geno[[i]]$data[a>0 & geno[[i]]$data==2] <- (geno[[i]]$data+a)[a>0 & geno[[i]]$data==2] geno[[i]]$data[geno[[i]]$data>3] <- 1 } if(any(a>0 & geno[[i]]$data==3)) geno[[i]]$data[a>0 & geno[[i]]$data==3] <- (geno[[i]]$data-a)[a>0 & geno[[i]]$data==3] } if(keep.errorind) { errors <- matrix(0,n.ind,n.mar[i]) errors[a>0] <- 1 colnames(errors) <- colnames(geno[[i]]$data) geno[[i]]$errors <- errors } } # end loop over chromosomes } # end simulate genotyping errors ## add partial missing if(partial.missing.prob > 0) { for(i in 1:n.chr) { if(chr.type[i] != "X") { o <- sample(c(TRUE,FALSE),n.mar[i],replace=TRUE, prob=c(partial.missing.prob,1-partial.missing.prob)) if(any(o)) { o2 <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o2)>0) x <- geno[[i]]$data[,o2] m <- (1:n.mar[i])[o] for(j in m) { if(runif(1) < 0.5) geno[[i]]$data[geno[[i]]$data[,j]==1 | geno[[i]]$data[,j]==2,j] <- 4 else geno[[i]]$data[geno[[i]]$data[,j]==3 | geno[[i]]$data[,j]==2,j] <- 5 } if(length(o2)>0) geno[[i]]$data[,o2] <- x } } } # end loop over chromosomes } # end simulate partially missing data # add missing if(missing.prob > 0) { for(i in 1:n.chr) { o <- grep("^QTL[0-9]+",mar.names[[i]]) if(length(o)>0) x <- geno[[i]]$data[,o] geno[[i]]$data[sample(c(TRUE,FALSE),n.mar[i]*n.ind,replace=TRUE, prob=c(missing.prob,1-missing.prob))] <- NA if(length(o)>0) geno[[i]]$data[,o] <- x } } pheno <- data.frame(phenotype=pheno) cross <- list(geno=geno,pheno=pheno) class(cross) <- c("bcsft","cross") attr(cross, "scheme") <- cross.scheme cross } ## End bcsft.R qtl/R/plotModel.R0000644000176200001440000001161212770016226013341 0ustar liggesusers###################################################################### # plotModel.R # # copyright (c) 2008-9, Karl W Broman # last modified January, 2009 # first written Apr, 2008 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: plotModel # ###################################################################### ###################################################################### # plotModel # # plot a QTL model ###################################################################### plotModel <- function(qtl, formula, circrad.rel=0.25, circrad.abs, cex.name=1, chronly=FALSE, order, ...) { if(missing(qtl)) stop("Must provide qtl object or a vector of QTL names") if(is.character(qtl)) { # qtl names if(missing(formula)) formula <- NULL } else { if(missing(formula)) { if("formula" %in% names(attributes(qtl))) formula <- attr(qtl, "formula") else { if("formula" %in% names(qtl)) formula <- qtl$formula else formula <- NULL } } if(length(qtl)>0) { if(chronly) qtl <- qtl$chr else { if("name" %in% names(qtl)) qtl <- qtl$name else { if("pos" %in% names(qtl)) qtl <- paste(qtl$chr, roundqtlpos(qtl$pos, 1), sep="@") else qtl <- qtl$chr } } } } nqtl <- length(qtl) if(!is.null(formula)) { if(is.character(formula)) formula <- as.formula(formula) theterms <- attr(terms(formula), "factors")[-1,] rn <- rownames(theterms) g <- grep("^[Qq][0-9]+$", rn) qtlnum <- as.numeric(substr(rn[g], 2, nchar(rn[g]))) if(any(qtlnum < 1 | qtlnum > nqtl)) stop("QTL in formula must be numbered between 1 and ", nqtl) cn <- colnames(theterms) intxn <- cn[grep("^[Qq][0-9]+:[Qq][0-9]+$", cn)] } else intxn <- NULL plot(0,0,type="n", xlab="", ylab="", xaxt="n", yaxt="n", xaxs="i", yaxs="i", xlim=c(-1.5,1.5), ylim=c(-1.5,1.5), ...) if(!is.null(qtl) && length(qtl) > 0) { radloc <- rev(seq(pi/2, 2.5*pi, len=nqtl+1)[-1]) xloc <- cos(radloc) yloc <- sin(radloc) rad <- seq(0, 2*pi, length=100) if(missing(circrad.abs)) { if(length(xloc) == 1) circrad.abs <- circrad.rel*2 else circrad.abs <- circrad.rel * sqrt(diff(xloc[1:2])^2 + diff(yloc[1:2])^2) if(circrad.abs > 0.45) circrad.abs <- 0.45 } # use the smallest of the two relative lengths u <- par("usr") pin <- par("pin") pin <- pin/c(diff(u[1:2]), diff(u[3:4])) circrad.abs<- circrad.abs/(pin/min(pin)) if(!missing(order)) { if(length(order) != length(qtl)) stop("order should have length ", nqtl) if(!all(sort(order) == seq(along=qtl))) stop("order should be a permutaton of 1,2,...,", nqtl) xloc <- xloc[order(order)] yloc <- yloc[order(order)] } if(length(intxn) > 0) { for(i in intxn) { thisint <- strsplit(i, ":")[[1]] theseqtl <- as.numeric(substr(thisint, 2, nchar(thisint))) lines(xloc[theseqtl], yloc[theseqtl], lwd=2) } } for(i in seq(along=xloc)) polygon(xloc[i]+cos(rad)*circrad.abs[1], yloc[i]+sin(rad)*circrad.abs[2], col="white", border="black", lwd=2) text(xloc, yloc, qtl, cex=cex.name) } invisible() } roundqtlpos <- function (x, digits = 1) { if (digits < 1) stop("This is intended for the case digits >= 1.") y <- as.character(round(x, digits)) z <- strsplit(y, "\\.") sapply(z, function(a, digits) { if (length(a) == 1) b <- paste(a[1], ".", paste(rep("0", digits), collapse = ""), sep = "") else { if (nchar(a[2]) == digits) b <- paste(a, collapse = ".") else b <- paste(a[1], ".", a[2], paste(rep("0", digits - nchar(a[2])), collapse = "."), sep = "") } }, digits) } # end of plotModel.R qtl/R/scanonevar.R0000644000176200001440000001303613576241200013540 0ustar liggesusers# scanonevar # single-QTL genome scan for QTL affecting variance # with code from Lars Ronnegard scanonevar <- function(cross, pheno.col=1, mean_covar = NULL, var_covar = NULL, maxit = 25 , tol=1e-6, quiet=TRUE) { # check input crosstype <- crosstype(cross) if(!(crosstype %in% c("bc", "dh", "f2", "haploid", "risib", "riself"))) stop('scanonevar not implemented for cross type "', crosstype, '"') chr_type <- sapply(cross$geno, chrtype) if(any(chr_type=="X")) { warning("Analysis of X chromosome not implemented for scanonevar; omitted.") cross <- subset(cross, chr=(chr_type != "X")) } # grab phenotype if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(is.matrix(pheno) && ncol(pheno) > 1) { pheno <- pheno[,1] warning('scanonevar requires a single phenotype; all but "', phenames(cross)[pheno.col[1]], '" omitted.') } N <- length(pheno) # No. individuals n.chr <- nchr(cross) #No. chromosomes chr.names <- chrnames(cross) # need to run calc.genoprob? if(!("prob" %in% names(cross$geno[[1]]))) { warning("First running calc.genoprob") cross <- calc.genoprob(cross) } scan.logPm <- scan.logPd <- chr.names.out <- NULL # set up data and formulas X <- cbind(pheno=pheno, add=rep(0, length(pheno))) mean_formula <- var_formula <- "pheno ~ add" if(!is.null(mean_covar)) { ncolX <- ncol(X) X <- cbind(X, mean_covar) meancovarnames <- paste0("meancov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- meancovarnames mean_formula <- paste(mean_formula, "+", paste(meancovarnames, collapse="+")) } if(!is.null(var_covar)) { ncolX <- ncol(X) X <- cbind(X, var_covar) varcovarnames <- paste0("varcov", 1:(ncol(X)-ncolX)) colnames(X)[-(1:ncolX)] <- varcovarnames var_formula <- paste(var_formula, "+", paste(varcovarnames, collapse="+")) } X <- as.data.frame(X) mean_formula <- as.formula(mean_formula) var_formula <- as.formula(var_formula) result <- NULL for(j in seq(along=cross$geno)) { # loop over chromosomes if(!quiet) message(" - Chr ", chr.names[j]) if (crosstype=="f2") { g11 <- cross$geno[[j]]$prob[,,1] g12 <- cross$geno[[j]]$prob[,,2] g13 <- cross$geno[[j]]$prob[,,3] a1 <- g11 + g12/2 d1 <- g12 - (g11+g13)/2 } else { a1 <- cross$geno[[j]]$prob[,,1] } n.loci <- dim(a1)[2] logP.m <- logP.d <- numeric(n.loci) for(i in 1:n.loci) { # loop over positions within chromosome # fill in genotype probs for this locus X[,2] <- a1[,i] d.fit <- DGLM_norm(m.form=mean_formula, d.form=var_formula, indata=X, maxiter=maxit, conv=tol) p.mean <- summary(d.fit$mean)$coef[2,4] p.disp<- summary(d.fit$disp)$coef[2,4] if (d.fit$iter < maxit) { logP.m[i]<- -log10(p.mean) logP.d[i]<- -log10(p.disp) } else { logP.m[i]<- -log10(p.mean) logP.d[i]<- 0 warning("dglm did not converge on chr", chr.names[j], " position ", i) } } # set up the output map <- attr(cross$geno[[j]]$prob,"map") w <- names(map) o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",chr.names[j],".",w[o],sep="") thischr <- data.frame(chr=rep(chr.names[j], length(w)), pos=unclass(map), neglogP_mean=logP.m, neglogP_disp=logP.d, stringsAsFactors=FALSE) rownames(thischr) <- w if(is.null(result)) result <- thischr else result <- rbind(result, thischr) } class(result) <- c("scanone", "data.frame") attr(result, "method") <- "scanonevar" result } DGLM_norm <- function(m.form, d.form, indata, maxiter=20, conv=1e-6) { X.mean <- model.matrix(m.form, data = indata) X.disp <- model.matrix(d.form, data = indata) y.name <- all.vars(m.form)[1] y <- indata[,y.name] w <- rep(1, nrow(indata)) convergence <- 1 iter <- 0 while (convergence > conv & iter < maxiter) { iter <- iter +1 w.old <- w glm1 <- lm(y~.-1, weights=w, data=data.frame(X.mean)) res <- resid(glm1) q <- hatvalues(glm1) y2 <- res^2/(1-q) glm2 <- glm(y2~.-1, family=Gamma(link=log), weights=(1-q)/2, data=data.frame(X.disp)) w <- 1/fitted(glm2) convergence <- (max(abs(w.old-w)) + (summary(glm1)$sigma-1) ) } return(list(mean=glm1, disp=glm2, iter=iter)) } qtl/R/summary.cross.R0000644000176200001440000005630414326316525014242 0ustar liggesusers###################################################################### # # summary.cross.R # # copyright (c) 2001-2022, Karl W Broman # last modified Oct, 2022 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: summary.cross, print.summary.cross, nind, nchr, nmar, # totmar, nphe, nmissing, ntyped, print.cross, chrlen # ###################################################################### summary.cross <- function(object,...) { if(!inherits(object, "cross")) stop("Input should have class \"cross\".") n.ind <- nind(object) tot.mar <- totmar(object) n.phe <- nphe(object) n.chr <- nchr(object) n.mar <- nmar(object) type <- crosstype(object) if(!(type %in% c("f2", "bc", "4way", "riself", "risib", "dh", "haploid", "ri4self", "ri4sib", "ri8self", "ri8selfIRIP1", "ri8sib", "bcsft", "bgmagic16"))) stop("Cross type ", type, " is not supported.") # combine genotype data into one big matrix Geno <- pull.geno(object) # A and X-specific genotypes? chr_type <- sapply(object$geno, chrtype) if(any(chr_type=="A")) { GenoA <- pull.geno(object, chr=chrnames(object)[chr_type=="A"]) } else { GenoA <- NULL } if(any(chr_type=="X") && type %in% c("f2", "bc", "bcsft")) { GenoX <- pull.geno(object, chr=chrnames(object)[chr_type=="X"]) GenoX <- reviseXdata(type, "full", getsex(object), geno=GenoX, cross.attr=attributes(object)) } else{ GenoX <- NULL } # proportion of missing genotype data missing.gen <- mean(is.na(Geno)) # Get cross scheme for BCsFt. if(type == "bcsft") { cross.scheme <- attr(object, "scheme") is.bcs <- (cross.scheme[2] == 0) } else { cross.scheme <- rep(0,2) is.bcs <- FALSE } # table of genotype values typings <- typingsA <- typingsX <- NULL if(type %in% c("f2", "bcsft") && !is.bcs) { if(is.null(GenoX)) { typings <- table(factor(Geno[!is.na(Geno)], levels=1:5)) temp <- getgenonames("f2", "A", cross.attr=attributes(object)) names(typings) <- c(temp, paste("not", temp[c(3,1)])) } else { if(!is.null(GenoA)) { typingsA <- table(factor(GenoA[!is.na(GenoA)], levels=1:5)) temp <- getgenonames("f2", "A", cross.attr=attributes(object)) names(typingsA) <- c(temp, paste("not", temp[c(3,1)])) } if(!is.null(GenoX)) { gnames <- getgenonames("f2", "X", "full", getsex(object), cross.attr=attributes(object)) typingsX <- table(factor(GenoX[!is.na(GenoX)], levels=1:length(gnames))) names(typingsX) <- gnames } } } else if(type %in% c("bc", "riself", "risib", "dh", "haploid", "bcsft")) { if(is.null(GenoX)) { typings <- table(factor(Geno[!is.na(Geno)], levels=1:2)) temp <- getgenonames(type, "A", cross.attr=attributes(object)) names(typings) <- temp } else { if(!is.null(GenoA)) { typingsA <- table(factor(GenoA[!is.na(GenoA)], levels=1:2)) temp <- getgenonames(type, "A", cross.attr=attributes(object)) names(typingsA) <- temp } if(!is.null(GenoX)) { gnames <- getgenonames(type, "X", "full", getsex(object), cross.attr=attributes(object)) typingsX <- table(factor(GenoX[!is.na(GenoX)], levels=1:length(gnames))) names(typingsX) <- gnames } } } else if(type=="4way") { typings <- table(factor(Geno[!is.na(Geno)], levels=1:14)) temp <- getgenonames("4way", "A", cross.attr=attributes(object)) names(typings) <- c(temp, paste(temp[c(1,3)], collapse="/"), paste(temp[c(2,4)], collapse="/"), paste(temp[c(1,2)], collapse="/"), paste(temp[c(3,4)], collapse="/"), paste(temp[c(1,4)], collapse="/"), paste(temp[c(2,3)], collapse="/"), paste("not", temp[1]), paste("not", temp[2]), paste("not", temp[3]), paste("not", temp[4])) } else typings <- table(factor(Geno[!is.na(Geno)])) # turn into fractions if(!is.null(typings)) typings <- typings/sum(typings) if(!is.null(typingsA)) typingsA <- typingsA/sum(typingsA) if(!is.null(typingsX)) typingsX <- typingsX/sum(typingsX) # amount of missing phenotype data if(ncol(object$pheno) <= 30) missing.phe <- as.numeric(cbind(apply(object$pheno,2,function(a) mean(is.na(a))))) else missing.phe <- mean(as.numeric(is.na(object$pheno))) # check that, in the case of a "4way" cross, the genetic # maps are matrices with 2 rows, and that for other crosses, # the genetic maps are numeric vectors if(type=="4way") { if(any(!sapply(object$geno, function(a) (is.matrix(a$map) && nrow(a$map)==2)))) warning("The genetic maps should all be matrices with two rows.") } else { if(any(sapply(object$geno, function(a) is.matrix(a$map)))) warning("The genetic maps should all be numeric vectors rather than matrices.") } # check that object$geno[[i]]$data has colnames and that they match # the names in object$geno[[i]]$map jitterwarning <- NULL for(i in 1:n.chr) { nam1 <- colnames(object$geno[[i]]$data) map <- object$geno[[i]]$map if(is.matrix(map)) nam2 <- colnames(map) else nam2 <- names(map) chr <- names(object$geno)[[i]] if(is.null(nam1)) { warn <- paste("The data matrix for chr", chr, "lacks column names") warning(warn) } if(is.null(nam2)) { warn <- paste("The genetic map for chr", chr, "lacks column names") warning(warn) } if(any(nam1 != nam2)) stop("Marker names in the data matrix and genetic map\n", "for chr ", chr, " do not match.") if((is.matrix(map) && (any(diff(map[1,])<0) || any(diff(map[2,])<0))) || (!is.matrix(map) && any(diff(map)<0))) stop("Markers out of order on chr ", chr) # check that no two markers are on top of each other if(is.matrix(map)) { # sex-specific maps n <- ncol(map) if(n > 1) { d1 <- diff(map[1,]) d2 <- diff(map[2,]) if(any(d1 < 1e-14 & d2 < 1e-14)) { if (is.null(jitterwarning)) jitterwarning<-list() jitterwarning[[names(object$geno)[i]]]<-which(d1 < 1e-14 & d2 < 1e-14) } } } else { n <- length(map) if(n > 1) { d <- diff(map) if(any(d < 1e-14)) { if (is.null(jitterwarning)) jitterwarning<-list() jitterwarning[[names(object$geno)[i]]]<-which(d < 1e-14) } } } } if (!is.null(jitterwarning)) warning("Some markers at the same position on chr ", paste(names(jitterwarning),collapse=",",sep=""),"; use jittermap().") if(!is.data.frame(object$pheno)) warning("Phenotypes should be a data.frame.") if(is.null(colnames(object$pheno))) stop("Phenotype data needs column names") x <- table(colnames(object$pheno)) if(any(x > 1)) warning("Some phenotypes have the same name:\n", paste(names(x)[x>1], collapse=" ")) # check genotype data if(type %in% c("bc", "riself", "risib", "dh", "haploid") | (type == "bcsft" & is.bcs)) { # Invalid genotypes? if(any(!is.na(Geno) & Geno != 1 & Geno != 2)) { u <- unique(as.numeric(Geno)) u <- sort(u[!is.na(u)]) warn <- paste("Invalid genotypes.", "\n Observed genotypes:", paste(u, collapse=" ")) warning(warn) } # Missing genotype category on autosomes? if(sum(!is.na(Geno) & Geno==2) == 0 || sum(!is.na(Geno) & Geno==1) == 0) { warn <- paste("Strange genotype pattern on chr ", chr, ".", sep="") warning(warn) } } else if(type %in% c("f2","bcsft") & !is.bcs) { # invalid genotypes if(any(!is.na(Geno) & Geno!=1 & Geno!=2 & Geno!=3 & Geno!=4 & Geno!=5)) { u <- unique(as.numeric(Geno)) u <- sort(u[!is.na(u)]) warn <- paste("Invalid genotypes on chr", chr, ".", "\n Observed genotypes:", paste(u, collapse=" ")) warning(warn) } # X chromosome for(i in 1:n.chr) { if(chrtype(object$geno[[i]]) == "X") { dat <- object$geno[[i]]$data if(any(!is.na(dat) & dat!=1 & dat!=2)) { u <- unique(as.numeric(dat)) u <- sort(u[!is.na(u)]) warn <- paste("Invalid genotypes on X chromosome:", "\n Observed genotypes:", paste(u, collapse=" ")) warning(warn) } } } # Missing genotype category on autosomes? dat <- NULL; flag <- 0 for(i in 1:n.chr) { if(chrtype(object$geno[[i]]) != "X") { dat <- cbind(dat,object$geno[[i]]$data) flag <- 1 } } if(flag && (sum(!is.na(dat) & dat==2) == 0 || sum(!is.na(dat) & dat==1) == 0 || sum(!is.na(dat) & dat==3) == 0)) warning("Strange genotype pattern.") } else if(type=="4way") { # Invalid genotypes? if(any(!is.na(Geno) & (Geno != round(Geno) | Geno < 1 | Geno > 14))) { u <- unique(as.numeric(Geno)) u <- sort(u[!is.na(u)]) warn <- paste("Invalid genotypes.", "\n Observed genotypes:", paste(u, collapse=" ")) warning(warn) } } else if(type %in% c("ri4sib", "ri4self", "ri8sib", "ri8self", "ri8selfIRIP1", "bgmagic16")) { if(type=="bgmagic16") n.str <- 16 else n.str <- as.numeric(substr(type, 3, 3)) if(any(!is.na(Geno) & (Geno != round(Geno) | Geno < 1 | Geno > 2^n.str-1))) { u <- unique(as.numeric(Geno)) u <- sort(u[!is.na(u)]) warn <- paste("Invalid genotypes.", "\n Observed genotypes:", paste(u, collapse=" ")) warning(warn) } } # Look for duplicate marker names mnames <- NULL for(i in 1:nchr(object)) mnames <- c(mnames,colnames(object$geno[[i]]$data)) o <- table(mnames) if(any(o > 1)) warning("Duplicate markers [", paste(names(o)[o>1], collapse=", "), "]") # make sure the genotype data are matrices rather than data frames if(any(sapply(object$geno, function(a) is.data.frame(a$data)))) warning("The $data objects should be simple matrices, not data frames.") # make sure each chromosome has class "A" or "X" chr.class <- sapply(object$geno, chrtype) if(!all(chr.class == "A" | chr.class == "X")) warning("Each chromosome should have class \"A\" or \"X\".") chr.nam <- names(object$geno) if(is.null(chr.nam)) { warning("The chromosome names are missing.") chr.nam <- as.character(1:length(chr.class)) } if(type != "riself" && any(chr.class=="A" & (chr.nam=="X" | chr.nam=="x"))) { wh <- which(chr.nam=="X" | chr.nam=="x") warning("Chromosome \"", chr.nam[wh], "\" has class \"A\" but probably ", "should have class \"X\".") } if(length(chr.nam) > length(unique(chr.nam))) { tab <- table(chr.nam) dups <- names(tab[tab > 1]) warning("Duplicate chromosome names: ", paste(dups,sep=", ")) } g <- grep("^-", chr.nam) if(length(g) > 0) warning("Chromosome names shouldn't start with '-': ", paste(chr.nam[g], sep=", ")) # if more than one X chromosome, print a warning if(sum(chr.class=="X") > 1) warning("More than one X chromosome: [", paste(chr.nam[chr.class == "X"], collapse=", "), "]") if(any(chr.class=="A")) autosomes <- chr.nam[chr.class == "A"] else autosomes <- NULL if(any(chr.class=="X")) Xchr <- chr.nam[chr.class == "X"] else Xchr <- NULL # check individual IDs id <- getid(object) if(!is.null(id) && length(id) != length(unique(id))) warning("The individual IDs are not unique.") # check that chromosomes aren't too long mapsum <- summaryMap(object) if(ncol(mapsum)==7) # sex-specific map maxlen <- max(mapsum[1:(nrow(mapsum)-1),2:3]) else maxlen <- max(mapsum[1:(nrow(mapsum)-1),2]) if(maxlen > 1000) warning(paste("Some chromosomes > 1000 cM in length; there may", "be a problem with the genetic map.\n (Perhaps it is in basepairs?)")) cross.summary <- list(type=type, n.ind = n.ind, n.phe=n.phe, n.chr=n.chr, n.mar=n.mar, missing.gen=missing.gen, typing.freq=typings, typing.freq.A=typingsA, typing.freq.X=typingsX, missing.phe=missing.phe, autosomes=autosomes, Xchr=Xchr, cross.scheme=cross.scheme) class(cross.summary) <- "summary.cross" cross.summary } print.summary.cross <- function(x,...) { print.genotypes <- TRUE if(x$type=="f2") cat(" F2 intercross\n\n") else if(x$type=="bc") cat(" Backcross\n\n") else if(x$type=="4way") cat(" 4-way cross\n\n") else if(x$type=="riself") cat(" RI strains via selfing\n\n") else if(x$type=="risib") cat(" RI strains via sib matings\n\n") else if(x$type=="dh") cat(" Doubled haploids\n\n") else if(x$type=="haploid") cat(" Haploids\n\n") else if(x$type %in% c("ri4self", "ri4sib", "ri8self", "ri8selfIRIP1", "ri8sib")) { n.str <- substr(x$type, 3, 3) if(substr(x$type, 4, min(6, nchar(x$type)))=="sib") crosstype <- "sib-mating" else crosstype <- "selfing" print.genotypes <- FALSE cat(" ", n.str, "-way RIL by ", crosstype, "\n\n", sep="") } else if(x$type=="bcsft") cat(paste(" BC(", x$cross.scheme[1], ")F(", x$cross.scheme[2], ") cross\n\n", sep = "")) else if(x$type %in% c("bgmagic16")) { n.str <- 16 print.genotypes <- FALSE cat(" ", n.str, "-way Biogemma MAGIC lines\n\n", sep="") } else cat(" cross", x$type, "\n\n",sep=" ") cat(" No. individuals: ", x$n.ind,"\n\n") cat(" No. phenotypes: ", x$n.phe,"\n") header <- " " width <- options("width")$width cat(" Percent phenotyped:") ###################################################################### # function to print things nicely printnicely <- function(thetext, header, width, sep=" ") { nleft <- width - nchar(header) nsep <- nchar(sep) if(length(thetext) < 2) cat("", thetext, "\n", sep=sep) else { z <- paste("", thetext[1], sep=sep, collapse=sep) for(j in 2:length(thetext)) { if(nchar(z) + nsep + nchar(thetext[j]) > nleft) { cat(z, "\n") nleft <- width z <- paste(header, thetext[j], sep=sep) } else { z <- paste(z, thetext[j], sep=sep) } } cat(z, "\n") } } ###################################################################### # function to pre-pad with spaces pad_w_spaces <- function(x, width, pre=TRUE) { padding <- vapply(nchar(x), function(n) paste(rep(" ", width-n), collapse=""), "") if(pre) return(paste0(padding, x)) paste0(x, padding) } ###################################################################### printnicely(round((1-x$missing.phe)*100,1), header, width) cat("\n") cat(" No. chromosomes: ", x$n.chr,"\n") if(!is.null(x$autosomes)) { cat(" Autosomes: ") printnicely(x$autosomes, header, width) } if(!is.null(x$Xchr)) { cat(" X chr: ") printnicely(x$Xchr, header, width) } cat("\n") cat(" Total markers: ", sum(x$n.mar), "\n") cat(" No. markers: ") printnicely(x$n.mar, header, width) cat(" Percent genotyped: ", round((1-x$missing.gen)*100,1), "\n") if(print.genotypes) { cat(" Genotypes (%): ") header <- " " if(!is.null(x$typing.freq.X)) { # contortions to line things up roundedX <- sprintf("%.1f", x$typing.freq.X*100) genoX <- paste(names(x$typing.freq.X),roundedX,sep=":") if(!is.null(x$typing.freq.A)) { roundedA <- sprintf("%.1f", x$typing.freq.A*100) genoA <- paste(names(x$typing.freq.A),roundedA,sep=":") # line up values maxchar <- max(nchar(c(roundedA, roundedX))) roundedA <- pad_w_spaces(roundedA, maxchar, pre=FALSE) roundedX <- pad_w_spaces(roundedX, maxchar, pre=FALSE) genoX <- paste(names(x$typing.freq.X),roundedX,sep=":") genoA <- paste(names(x$typing.freq.A),roundedA,sep=":") # line things up again maxchar <- max(nchar(c(genoA, genoX))) genoA <- pad_w_spaces(genoA, maxchar) genoX <- pad_w_spaces(genoX, maxchar) cat("\n Autosomes: ") printnicely(genoA, header, width, " ") cat(" X chromosome: ") } printnicely(genoX, header, width, " ") } else { if(!is.null(x$typing.freq.A) && !is.null(x$typing.freq)) x$typing.freq <- x$typing.freq.A geno <- paste(names(x$typing.freq),sprintf("%.1f", x$typing.freq*100), sep=":") printnicely(geno, header, width, " ") } } } nind <- function(object) { if(!inherits(object, "cross")) stop("Input should have class \"cross\".") n.ind1 <- nrow(object$pheno) n.ind2 <- sapply(object$geno,function(x) nrow(x$data)) if(any(n.ind2 != n.ind1)) stop("Different numbers of individuals in genotypes and phenotypes.") n.ind1 } nchr <- function(object) { if(inherits(object, "map")) { return(length(object)) } else if(inherits(object, "cross")) { return(length(object$geno)) } else { # neither cross nor map object stop("Input should have class \"cross\" or \"map\".") } } nmar <- function(object) { if(inherits(object, "map")) { if(is.matrix(object[[1]])) return(sapply(object, function(x) ncol(x))) else return(sapply(object, function(x) length(x))) } else if(!inherits(object, "cross")) { stop("Input should have class \"cross\" or \"map\".") } if(length(object$geno) == 0) stop("There is no genotype data.") if(!is.matrix(object$geno[[1]]$map)) n.mar1 <- sapply(object$geno, function(x) length(x$map)) else # sex-specific maps n.mar1 <- sapply(object$geno, function(x) ncol(x$map)) n.mar2 <- sapply(object$geno, function(x) ncol(x$data)) if(any(n.mar1 != n.mar2)) stop("Different numbers of markers in genotypes and maps.") n.mar1 } totmar <- function(object) { if(inherits(object, "map")) { if(is.matrix(object[[1]])) return(sum(sapply(object, function(x) ncol(x)))) else return(sum(sapply(object, function(x) length(x)))) } else if(!inherits(object, "cross")) { stop("Input should have class \"cross\" or \"map\".") } if(length(object$geno) == 0) stop("There is no genotype data.") if(!is.matrix(object$geno[[1]]$map)) totmar1 <- sum(sapply(object$geno, function(x) length(x$map))) else # sex-specific maps totmar1 <- sum(sapply(object$geno, function(x) ncol(x$map))) totmar2 <- sum(sapply(object$geno, function(x) ncol(x$data))) if(totmar1 != totmar2) stop("Different numbers of markers in genotypes and maps.") totmar1 } nphe <- function(object) { if(!inherits(object, "cross")) stop("Input should have class \"cross\".") ncol(object$pheno) } # count number of missing genotypes for each individual or each marker nmissing <- function(cross,what=c("ind","mar")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") what <- match.arg(what) if(what=="ind") { n.missing <- rep(0,nind(cross)) for(i in 1:nchr(cross)) n.missing <- n.missing + apply(cross$geno[[i]]$data,1,function(a) sum(is.na(a))) # individual IDs id <- getid(cross) if(!is.null(id)) names(n.missing) <- id } else { n.missing <- NULL for(i in 1:nchr(cross)) n.missing <- c(n.missing, apply(cross$geno[[i]]$data,2,function(a) sum(is.na(a)))) } n.missing } # like nmissing, but for the opposite value ntyped <- function(cross, what=c("ind","mar")) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") what <- match.arg(what) if(what=="ind") n <- totmar(cross) else n <- nind(cross) n - nmissing(cross, what) } # "print" method for cross object # # to avoid ever printing the entire object, print just a little # warning message and then the summary print.cross <- function(x, ...) { cat(" This is an object of class \"cross\".\n") cat(" It is too complex to print, so we provide just this summary.\n") print(summary(x)) return(summary(x)) } # get chromosome lengths chrlen <- function(object) { if(!inherits(object, "map") && !inherits(object, "cross")) stop("Input should have class \"map\" or \"cross\".") if(!inherits(object, "map")) x <- pull.map(object) else x <- object if(is.matrix(x[[1]])) return(sapply(x, apply, 1, function(a) diff(range(a)))) sapply(x, function(a) diff(range(a))) } # end of summary.cross.R qtl/R/argmax.geno.R0000644000176200001440000001653213576241200013613 0ustar liggesusers###################################################################### # # argmax.geno.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: argmax.geno # ###################################################################### ###################################################################### # # argmax.geno: Use Viterbi algorithm to find most likely sequence of # underlying genotypes, given observed marker data # ###################################################################### argmax.geno <- function(cross, step=0, off.end=0, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), stepwidth=c("fixed", "variable", "max")) { if(!inherits(cross, "cross")) stop("cross should have class \"cross\".") # map function map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h stepwidth <- match.arg(stepwidth) # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) # loop over chromosomes for(i in 1:n.chr) { if(n.mar[i]==1) temp.offend <- max(c(off.end,5)) else temp.offend <- off.end chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") xchr <- TRUE else xchr <- FALSE # which type of cross is this? if(type=="f2") { one.map <- TRUE if(!xchr) # autosomal cfunc <- "argmax_geno_f2" else # X chromsome cfunc <- "argmax_geno_bc" } else if(type=="bc" || type=="dh" || type=="riself" || type=="risib" || type=="haploid") { cfunc <- "argmax_geno_bc" one.map <- TRUE } else if(type == "4way") { cfunc <- "argmax_geno_4way" one.map <- FALSE } else if(type == "ri8sib" || type=="ri4sib" || type=="ri8self" || type=="ri4self" || type=="bgmagic16") { cfunc <- paste("argmax_geno_", type, sep="") one.map <- TRUE if(xchr) warning("argmax.geno not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE cfunc <- "argmax_geno_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(xchr) { ## X chr cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 } } else stop("argmax.geno not available for cross type ", type, ".") # genotype data gen <- cross$geno[[i]]$data gen[is.na(gen)] <- 0 # recombination fractions if(one.map) { # recombination fractions map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf, sub("^ri", "", type), chr_type) rf[rf < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=length(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,names(map)) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) } else { map <- create.map(cross$geno[[i]]$map,step,temp.offend,stepwidth) rf <- mf(diff(map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(map[2,])) rf2[rf2 < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=ncol(map),nrow=nrow(gen)) dimnames(newgen) <- list(NULL,dimnames(map)[[2]]) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) } if(any(is.na(rf))) { # this occurs when there is only one marker rf <- rf2 <- 0 warn <- paste("Only one marker on chr ", names(cross$geno)[i], ": argmax results tenuous.", sep="") warning(warn) } # call the C function if(one.map) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- newgen if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(error.prob), argmax=as.integer(temp), # the output PACKAGE="qtl") cross$geno[[i]]$argmax <- matrix(z$argmax,ncol=n.pos) dimnames(cross$geno[[i]]$argmax) <- list(NULL, names(map)) } else { z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(rf2), # recombination fractions as.double(error.prob), argmax=as.integer(newgen), # the output PACKAGE="qtl") cross$geno[[i]]$argmax <- matrix(z$argmax,ncol=n.pos) dimnames(cross$geno[[i]]$argmax) <- list(NULL, colnames(map)) } # attribute set to the error.prob value used, for later # reference attr(cross$geno[[i]]$argmax, "map") <- map attr(cross$geno[[i]]$argmax,"error.prob") <- error.prob attr(cross$geno[[i]]$argmax,"step") <- step attr(cross$geno[[i]]$argmax,"off.end") <- temp.offend attr(cross$geno[[i]]$argmax,"map.function") <- map.function attr(cross$geno[[i]]$argmax,"stepwidth") <- stepwidth } # store argmax values as integers for(i in 1:nchr(cross)) storage.mode(cross$geno[[i]]$argmax) <- "integer" # 4- and 8-way RIL: reorganize the results if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") cross <- reorgRIargmax(cross) cross } # end of argmax.geno.R qtl/R/est.rf.R0000644000176200001440000003545714256661625012632 0ustar liggesusers###################################################################### # # est.rf.R # # copyright (c) 2001-2022, Karl W Broman # last modified Jun, 2022 # first written Apr, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: est.rf, plotRF, checkAlleles, pull.rf, plot.rfmatrix # ###################################################################### ###################################################################### # # est.rf: Estimate sex-averaged recombination fractions between # all pairs of markers # ###################################################################### est.rf <- function(cross, maxit=10000, tol=1e-6) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") n.chr <- nchr(cross) n.mar <- totmar(cross) n.ind <- nind(cross) mar.names <- unlist(lapply(cross$geno,function(a) colnames(a$data))) type <- crosstype(cross) chr_type <- sapply(cross$geno, chrtype) is.bcsft <- (type == "bcsft") if(is.bcsft) { cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) is.bcsft <- cross.scheme[2] > 0 ## used for fixX only } xchrcol <- NULL fixX <- FALSE Geno <- NULL # create full genotype matrix for(i in 1:n.chr) { temp <- cross$geno[[i]]$data # treat X chromosome specially in an intercross or BCsFt with t>0. if((type=="f2" || is.bcsft) && chr_type[i]=="X") { fixX <- TRUE if(i != 1) xchrcol <- c(xchrcol,ncol(Geno)+(1:ncol(cross$geno[[i]]$data))) else xchrcol <- 1:ncol(cross$geno[[i]]$data) xchr <- temp xchr[is.na(xchr)] <- 0 temp <- reviseXdata("f2","simple",getsex(cross),geno=temp, cross.attr=attributes(cross)) } Geno <- cbind(Geno,temp) } # which type of cross is this? if(type == "f2") cfunc <- "est_rf_f2" else if(type == "bc" || type=="risib" || type=="riself" || type=="dh" || type=="haploid") cfunc <- "est_rf_bc" else if(type == "4way") cfunc <- "est_rf_4way" else if(type=="ri8sib" || type=="ri8self" || type=="ri4sib" || type=="ri4self") { cfunc <- paste("est_rf_", type, sep="") if(any(chr_type == "X")) warning("est.rf not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") cfunc <- "est_rf_bcsft" else stop("est.rf not available for cross type ", type, ".") Geno[is.na(Geno)] <- 0 if(type=="bc" || type=="risib" || type=="riself" || type=="dh" || type=="haploid") z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.mar), # number of markers as.integer(Geno), rf = as.double(rep(0,n.mar*n.mar)), PACKAGE="qtl") else { ## Hide cross scheme in genoprob to pass to routine. BY temp <- as.double(rep(0,n.mar*n.mar)) if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.mar), # number of markers as.integer(Geno), rf = as.double(temp), as.integer(maxit), as.double(tol), PACKAGE="qtl") } cross$rf <- matrix(z$rf,ncol=n.mar) dimnames(cross$rf) <- list(mar.names,mar.names) if(fixX) { temp <- as.double(rep(0, ncol(xchr) ^ 2)) if(type == "bcsft") { temp[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) zz <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(ncol(xchr)), # number of markers on X chr. as.integer(xchr), rf = as.double(temp), as.integer(maxit), as.double(tol), PACKAGE="qtl") } else { zz <- .C("est_rf_bc", as.integer(n.ind), as.integer(ncol(xchr)), as.integer(xchr), rf=as.double(temp), PACKAGE="qtl") } zz <- matrix(zz$rf,ncol=ncol(xchr)) cross$rf[xchrcol,xchrcol] <- zz } # check for alleles switches if(type == "risib" || type=="riself" || type=="f2" || type=="bc" || type=="dh" || type=="haploid") { out <- checkAlleles(cross, 5, FALSE) if(!is.null(out)) { out <- as.character(out[,1]) warning("Alleles potentially switched at markers \n ", paste(out, collapse=" ")) } } cross } plotRF <- function(x, chr, what=c("both","lod","rf"), alternate.chrid=FALSE, zmax=12, mark.diagonal=FALSE, col.scheme=c("viridis", "redblue"), ...) { if(!inherits(x, "cross")) stop("Input should have class \"cross\".") what <- match.arg(what) if("onlylod" %in% names(attributes(x$rf)) && attr(x$rf, "onlylod")) { onlylod <- TRUE what <- "lod" } else onlylod <- FALSE if(!missing(chr)) x <- subset(x,chr=chr) if(!("rf" %in% names(x))) { warning("Running est.rf.") x <- est.rf(x) } g <- x$rf old.xpd <- par("xpd") old.las <- par("las") par(xpd=TRUE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) if(!onlylod) { # if any of the rf's are NA (ie no data), put NAs in corresponding LODs if(any(is.na(g))) g[is.na(t(g))] <- NA # convert rf to -2*(log2(rf)+1); place zmax's on the diagonal; # anything above zmax replaced by zmax; # NA's replaced by -1 g[row(g) > col(g) & g > 0.5] <- 0.5 g[row(g) > col(g)] <- -4*(log2(g[row(g) > col(g)])+1)/12*zmax } diag(g) <- zmax g[!is.na(g) & g>zmax] <- zmax g[is.na(g)] <- -1 if(what=="lod" && !onlylod) { # plot LOD scores # copy upper triangle (LODs) to lower triangle (rec fracs) g[row(g) > col(g)] <- t(g)[row(g) > col(g)] } else if(what=="rf") { # plot recombination fractions # copy lower triangle (rec fracs) to upper triangle (LODs) g[row(g) < col(g)] <- t(g)[row(g) < col(g)] } br <- c(-1, seq(-1e-6, zmax, length=257)) col.scheme <- match.arg(col.scheme) if(col.scheme=="redblue") { # convert colors using gamma=0.6 (which will no longer be available in R) thecol <- rev(rainbow(256, start=0, end=2/3)) rgbval <- (col2rgb(thecol)/255)^0.6 thecol <- rgb(rgbval[1,], rgbval[2,], rgbval[3,]) } else { thecol <- viridis_qtl(256) # the new default } image(1:ncol(g),1:nrow(g),t(g),ylab="Markers",xlab="Markers",breaks=br, col=c("lightgray",thecol)) if(mark.diagonal) { for(i in 1:ncol(g)) segments(i+c(-0.5, -0.5, -0.5, +0.5), i+c(-0.5, +0.5, -0.5, -0.5), i+c(-0.5, +0.5, +0.5, +0.5), i+c(+0.5, +0.5, -0.5, +0.5)) } # plot lines at the chromosome boundaries n.mar <- nmar(x) n.chr <- nchr(x) a <- c(0.5,cumsum(n.mar)+0.5) abline(v=a,xpd=FALSE,col="white") abline(h=a,xpd=FALSE,col="white") # this line adds a line above the image # (the image function leaves it out) abline(h=0.5+c(0,nrow(g)),xpd=FALSE) abline(v=0.5+c(0,nrow(g)),xpd=FALSE) # add chromosome numbers a <- par("usr") wh <- cumsum(c(0.5,n.mar)) chrnam <- names(x$geno) chrpos <- (wh[-1] + wh[-length(wh)])/2 if(!alternate.chrid || length(chrnam) < 2) { for(i in seq(along=chrpos)) { axis(side=3, at=chrpos[i], labels=chrnam[i], tick=FALSE, line=-0.8) axis(side=4, at=chrpos[i], labels=chrnam[i], tick=FALSE, line=-0.8) } } else { odd <- seq(1, length(chrpos), by=2) even <- seq(2, length(chrpos), by=2) for(i in odd) { axis(side=3, at=chrpos[i], labels=chrnam[i], line=-0.8, tick=FALSE) axis(side=4, at=chrpos[i], labels=chrnam[i], line=-0.8, tick=FALSE) } for(i in even) { axis(side=3, at=chrpos[i], labels=chrnam[i], line=0, tick=FALSE) axis(side=4, at=chrpos[i], labels=chrnam[i], line=0, tick=FALSE) } } dots <- list(...) if("main" %in% names(dots)) title(main=dots$main) else { if(what=="lod") title(main="Pairwise LOD scores") else if(what=="rf") title(main="Recombination fractions") else title("Pairwise recombination fractions and LOD scores") } invisible() } ###################################################################### # check for apparent errors in the recombination fractions ###################################################################### #checkrf <- #function(cross, threshold=5) #{ # rf <- cross$rf # n.mar <- nmar(cross) # map <- pull.map(cross) # n <- ncol(rf) # mnam <- colnames(rf) # whpos <- unlist(lapply(map,function(a) 1:length(a))) # whchr <- rep(names(map),sapply(map,length)) # # # first check whether a locus has "significant" pairwise recombination # # with rf > 0.5 # for(i in 1:n) { # if(i == 1) { # lod <- rf[1,-1] # r <- rf[-1,1] # } # else if(i == n) { # lod <- rf[-n,n] # r <- rf[n,-n] # } # else { # lod <- c(rf[1:(i-1),i],rf[i,(i+1):n]) # r <- c(rf[i,1:(i-1)],rf[(i+1):n,i]) # } # # # if rf > 1/2 and LOD > threshold for more than two other markers # if(sum(!is.na(lod) & !is.na(r) & lod > threshold & r > 0.5) >= 2) # warning("Genotypes potentially switched for marker ", mnam[i], # paste(" (",whpos[i],")",sep=""), " on chr ", whchr[i], "\n") # # } # #} ###################################################################### # checkAlleles() # # Function to find markers that may have alleles miscoded; # we go through each marker, one at a time, swap alleles and # then see what it does to pairwise linkage against all other # markers ###################################################################### checkAlleles <- function(cross, threshold=3, verbose=TRUE) { if(!inherits(cross, "cross")) stop("checkAlleles() only works for cross objects.") type <- crosstype(cross) if(type != "f2" && type != "bc" && type != "risib" && type != "riself" && type != "dh" && type!="haploid") stop("checkAlleles not available for cross type ", type, ".") # drop X chromosome chr_type <- sapply(cross$geno, chrtype) if(all(chr_type=="X")) { if(verbose) cat("checkAlleles() only works for autosomal data.\n") return(NULL) } cross <- subset(cross, chr = (chr_type != "X")) n.mar <- nmar(cross) mar.names <- unlist(lapply(cross$geno,function(a) colnames(a$data))) if(!("rf" %in% names(cross))) { warning("First running est.rf.") cross <- est.rf(cross) } onlylod <- attr(cross$rf, "onlylod") if(!is.null(onlylod) && onlylod) { # need to re-run est.rf() warning("First running est.rf.") cross <- est.rf(cross) } diag(cross$rf) <- 0 lod <- rf <- cross$rf lod[lower.tri(lod)] <- t(lod)[lower.tri(lod)] rf[upper.tri(rf)] <- t(rf)[upper.tri(rf)] orig.lod <- rev.lod <- lod orig.lod[rf > 0.5] <- 0 rev.lod[rf < 0.5] <- 0 dif <- apply(rev.lod, 2, max, na.rm=TRUE) - apply(orig.lod, 2, max, na.rm=TRUE) results <- data.frame(marker=mar.names, chr=rep(names(cross$geno), n.mar), index=unlist(lapply(n.mar, function(a) 1:a)), "diff in max LOD" = dif, stringsAsFactors=TRUE) rownames(results) <- 1:nrow(results) if(all(results[,4] < threshold)) { if(verbose) cat("No apparent problems.\n") return(invisible(NULL)) } results[results[,4] >= threshold,] } ###################################################################### # pull.rf # # pull out the pairwise marker recombination fraction estimates, # with class "rfmatrix" ###################################################################### pull.rf <- function(cross, what=c("rf", "lod"), chr) { if(!inherits(cross, "cross")) stop("Input must have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) if(!("rf" %in% names(cross))) { warning(" -Running est.rf") cross <- est.rf(cross) } rf <- cross$rf if(nrow(rf) != totmar(cross) || ncol(rf) != totmar(cross) || any(rownames(rf) != markernames(cross)) || any(colnames(rf) != markernames(cross))) { warning(" -Rec. frac. estimates seem corrupted; re-running est.rf") cross <- est.rf(cross) } rf <- cross$rf diag(rf) <- NA what <- match.arg(what) if(what=="rf") rf[upper.tri(rf)] <- t(rf)[upper.tri(rf)] else rf[lower.tri(rf)] <- t(rf)[lower.tri(rf)] attr(rf, "map") <- pull.map(cross, as.table=TRUE) attr(rf, "what") <- what class(rf) <- c("rfmatrix", "matrix") rf } ###################################################################### # plot.rfmatrix: # # plot a slice through the matrix (that is, for one marker) ###################################################################### plot.rfmatrix <- function(x, marker, ...) { if(!inherits(x, "rfmatrix")) stop("Input must have class \"rfmatrix\".") if(missing(marker)) stop("You must provide a marker name.") if(length(marker) > 1) { warning("Ignoring all but the first marker, ", marker[1]) marker <- marker[1] } if(!(marker %in% rownames(x))) stop("Marker ", marker, " not found.") what <- attr(x, "what") x <- cbind(attr(x, "map"), x[marker,]) x$chr <- factor(x$chr, levels=unique(x$chr)) # fill in hole wh <- which(rownames(x)==marker) if(wh > 1 && wh < nrow(x) && x[wh-1,1] == x[wh,1] && x[wh+1,1] == x[wh,1]) { xl <- x[wh-1,2] xm <- x[wh,2] xr <- x[wh+1,2] yl <- x[wh-1,3] yr <- x[wh+1,3] x[wh,3] <- yl + (xm-xl)*(yr-yl)/(xr-xl) } colnames(x)[3] <- what class(x) <- c("scanone", "data.frame") dots <- list(...) if("main" %in% names(dots)) plot(x, ...) else plot(x, main=marker, ...) invisible(x) } # end of est.rf.R qtl/R/add_threshold.R0000644000176200001440000001104513576241200014203 0ustar liggesusers###################################################################### # # add_threshold.R # # copyright (c) 2006-2019, Karl W Broman # last modified Dec, 2019 # first written Dec, 2006 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Contains: add.threshold, xaxisloc.scanone # ###################################################################### ###################################################################### # add.threshold: function to add threshold lines to a plot # created by plot.scanone() # # out: scanone output used to create the plot # chr: chromosomes that were plotted # # perms: scanone permutation results # alpha: significance level (a single number) # # gap: the gap between chromosomes, as specified in the call to plot.scanone # # ...: extra arguments passed to abline or segments to control line types/widths/colors # (e.g., specify lty=2 to give dashed lines) ###################################################################### add.threshold <- function(out, chr, perms, alpha=0.05, lodcolumn=1, gap=25, ...) { if(missing(out)) stop("You must provide scanone output, so we can get chromosome lengths.") if(!inherits(out, "scanone")) stop("out should have class \"scanone\".") if(!missing(chr)) out <- subset(out, chr=chr) if(missing(perms)) stop("You must specify permutation results, to get the thresholds") if(length(alpha) > 1 || alpha<0 || alpha>1) stop("alpha should have length 1 and be between 0 and 1.") thr <- summary(perms, alpha=alpha) if(!is.list(thr)) { if(any(lodcolumn < 1 | lodcolumn > length(thr))) stop("lodcolumn should be between 1 and ", length(thr)) abline(h=thr[lodcolumn], ...) } else { if(any(lodcolumn < 1 | lodcolumn > length(thr$A))) stop("lodcolumn should be between 1 and ", length(thr$A)) a <- thr$A[lodcolumn] x <- thr$X[lodcolumn] noX <- FALSE xchr <- attr(perms, "xchr") L <- tapply(out[,2], out[,1], function(a) diff(range(a))) L <- L[!is.na(L)] xchr <- xchr[match(names(L), names(xchr))] if(all(xchr)) abline(h=x, ...) else if(all(!xchr)) abline(h=a, ...) else { start <- c(0,cumsum(L+gap)) end <- start+ c(L,0) wh <- which(!xchr) if(length(wh)==1 || all(diff(wh)==1)) segments(start[min(wh)], a, end[max(wh)], a, ...) else segments(start[wh], a, start[wh+1], a, ...) wh <- which(xchr) if(length(wh)==1 || all(diff(wh)==1)) segments(start[min(wh)], x, end[max(wh)], x, ...) else segments(start[wh], x, start[wh+1], x, ...) } } invisible() } # xaxisloc.scanone # find x-axis locations for a plot of scanone output xaxisloc.scanone <- function(out, thechr, thepos, chr, gap=25) { if(missing(out)) stop("You must provide scanone output, so we can get chromosome lengths.") if(!inherits(out, "scanone")) stop("out should have class \"scanone\".") if(!missing(chr)) out <- subset(out, chr=chr) chr <- unique(out[,1]) if(length(thechr) != 1) { if(length(thepos)==1) thepos <- rep(thepos, length(thechr)) else if(length(thechr) != length(thepos)) stop("If thechr and thepos have length>1 they must both have the same length") } else { if(length(thepos)!=1) thechr <- rep(thechr, length(thepos)) } if(length(thechr) > 1) { res <- rep(NA, length(thechr)) for(i in seq(along=thechr)) res[i] <- xaxisloc.scanone(out, thechr[i], thepos[i], chr, gap) return(res) } L <- tapply(out[,2], out[,1], function(a) diff(range(a, na.rm=TRUE))) Lmin <- tapply(out[,2], out[,1], min, na.rm=TRUE) start <- c(0,cumsum(L+gap)) start[which(as.character(thechr)==chr)]+(thepos - Lmin[as.character(thechr)==chr]) } # end of add_threshold.R qtl/R/plotperm.R0000644000176200001440000001466412770016226013256 0ustar liggesusers##################################################################### # # plotperm.R # # copyright (c) 2007-2014, Karl W Broman # last modified Oct, 2014 # first written Dec, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: plot.scanoneperm, plot.scantwoperm, plot.scanoneboot # ###################################################################### ############################################################ # plot.scanoneboot # # plot histogram of the results from scanoneboot ############################################################ plot.scanoneboot <- function(x, ...) { results <- attr(x, "results") markerpos <- results[-grep("^c.+\\.loc-*[0-9]+(\\.[0-9]+)*$", rownames(results)),2] hideplot.scanoneboot <- function(x, breaks, xlim, main, xlab, ...) { if(missing(breaks)) breaks <- ceiling(2*sqrt(length(x))) if(missing(xlim)) xlim <- range(results[,2]) if(missing(main)) main <- "" if(missing(xlab)) xlab <- "QTL position (cM)" hist(x, xlim=xlim, xlab=xlab, main=main, breaks=breaks, ...) } hideplot.scanoneboot(x, ...) rug(markerpos) } ############################################################ # plot.scanoneperm # # plot histogram of the permutation results from scanone ############################################################ plot.scanoneperm <- function(x, lodcolumn=1, ...) { # subroutine for hiding arguments in ... hideplot.scanoneperm <- function(A, X, breaks, xlab, xlim, main, ...) { if(missing(xlab)) xlab <- "maximum LOD score" if(missing(X)) { if(missing(breaks)) breaks <- ceiling(2*sqrt(length(A))) if(missing(xlim)) xlim <- c(0, max(A)) if(missing(main)) main <- "" hist(A, breaks=breaks, xlab=xlab, xlim=xlim, main=main, ...) } else { mfrow <- par("mfrow") on.exit(par(mfrow=mfrow)) par(mfrow=c(2,1)) if(missing(breaks)) { breaks.missing <- TRUE breaks <- seq(0, max(c(A,X)), length=2*sqrt(length(A))) } else breaks.missing <- FALSE if(missing(xlim)) xlim <- c(0, max(c(A,X))) if(missing(main)) { main <- "Autosomes" main.missing <- TRUE } else { main.missing <- FALSE if(length(main)>1) { main2 <- main[2]; main <- main[1] } else main2 <- main } hist(A, xlim=xlim, breaks=breaks, xlab=xlab, main=main, ...) rug(A) if(breaks.missing) breaks <- seq(0, max(c(A,X)), length=2*sqrt(length(X))) if(main.missing) main <- "X chromosome" else main <- main2 hist(X, xlim=xlim, breaks=breaks, xlab=xlab, main=main, ...) rug(X) } } # now to the actual code if(is.list(x)) { # separate X chr results if(lodcolumn < 1 || lodcolumn > ncol(x$A)) stop("lodcolumn should be between 1 and ", ncol(x$A)) A <- as.numeric(x$A[,lodcolumn]) X <- as.numeric(x$X[,lodcolumn]) hideplot.scanoneperm(A, X, ...) } else { if(lodcolumn < 1 || lodcolumn > ncol(x)) stop("lodcolumn should be between 1 and ", ncol(x$A)) A <- as.numeric(x[,lodcolumn]) hideplot.scanoneperm(A, ...) } } ############################################################ # plot.scantwoperm # # plot histogram of the permutation results from scantwo ############################################################ plot.scantwoperm <- function(x, lodcolumn=1, include_rug=TRUE, ...) { hideplot.scantwoperm <- function(x, include_rug=TRUE, xlim, breaks, xlab, main, ...) { if(missing(xlim)) xlim <- c(0, max(unlist(x))) if(missing(xlab)) xlab <- "maximum LOD score" if(missing(main)) main.missing <- TRUE else { main.missing <- FALSE; main.input <- main } mfcol <- par("mfcol") on.exit(par(mfcol=mfcol)) if("AA" %in% names(x)) { if(missing(breaks)) breaks <- seq(0, max(unlist(x)), len=ceiling(4*sqrt(length(x[[1]][[1]]))+1)) par(mfrow=c(3,6)) for(i in seq(along=x)) { for(j in seq(along=x[[i]])) { if(main.missing) main <- paste(names(x)[i], names(x[[i]])[j]) else { if(length(main.input) >= i) main <- main.input[i] else if(length(main.input) == 1) main <- main.input else main <- "" } hist(x[[i]][[j]], xlim=xlim, breaks=breaks, xlab=xlab, main=main,...) if(include_rug) rug(x[[i]][[j]]) } } invisible(return(NULL)) } if(missing(breaks)) breaks <- seq(0, max(unlist(x)), len=ceiling(4*sqrt(length(x[[1]]))+1)) par(mfcol=c(3,2)) for(i in seq(along=x)) { if(main.missing) main <- names(x)[i] else { if(length(main.input) >= i) main <- main.input[i] else if(length(main.input) == 1) main <- main.input else main <- "" } hist(x[[i]], xlim=xlim, breaks=breaks, xlab=xlab, main=main,...) if(include_rug) rug(x[[i]]) } } if(length(lodcolumn) > 1) stop("Select just one lod column") x <- x[,lodcolumn] hideplot.scantwoperm(x, include_rug=include_rug, ...) } # end of plotperm.R qtl/R/write.cross.qtab.R0000644000176200001440000001653513576241200014620 0ustar liggesusers###################################################################### # write.cross.qtab.R # # copyright (c) 2012-2019, Karl W Broman and Danny Arends # last modified Dec, 2019 # first written Jul, 2012 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: write.cross.qtab # rqtl.to.qtab.* where * = symbols, location, genotypes, phenotypes, founder # get.qtlHD.ID, get.indID.for.qtab, getgenonames.for.qtab # get.qtab.geno.symbols, get.phenotype.type # ###################################################################### # write cross in a set of qtab-format files write.cross.qtab <- function(cross, filestem="data", descr, verbose=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") # for now, omit X chromosome chr_type <- sapply(cross$geno, chrtype) if(any(chr_type == "X")) { cross <- subset(cross, chr=names(chr_type)[chr_type != "X"]) warning("Omitting X chromosome.") } if(verbose) cat("Writing symbols\n") rqtl.to.qtab.symbols(cross, paste(filestem,"_symbols.qtab",sep=""), descr=descr) if(verbose) cat("Writing founder file\n") rqtl.to.qtab.founder(cross, paste(filestem,"_founder.qtab",sep=""), descr=descr) if(verbose) cat("Writing genetic map\n") rqtl.to.qtab.location(cross, paste(filestem,"_location.qtab",sep=""), descr=descr) if(verbose) cat("Writing genotypes\n") rqtl.to.qtab.genotypes(cross, paste(filestem,"_genotypes.qtab",sep=""), descr=descr) if(verbose) cat("Writing phenotypes\n") rqtl.to.qtab.phenotypes(cross, paste(filestem,"_phenotypes.qtab",sep=""), descr=descr) } # version number for qtlHD get.qtlHD.ID <- function(){ VER <- "0.1" ID <- paste("qtlHD-in-", VER, sep="") ID } # individual IDs for qtab files get.indID.for.qtab <- function(cross) { id <- getid(cross) if(is.null(id)) id <- 1:nind(cross) paste("ID_", id, sep="") } # genotype codes for qtab files getgenonames.for.qtab <- function(cross) { gnames <- getgenonames(crosstype(cross), "A", "full", getsex(cross), attributes(cross)) if(crosstype(cross) == "f2") { gnames <- c(gnames, paste(gnames[1], "or", gnames[2], sep=""), paste(gnames[2], "or", gnames[3], sep="")) } c("-", gnames) } # qtab genotypes symbols get.qtab.geno.symbols <- function(cross) { crtype <- crosstype(cross) if(crtype == "bc") { return(c("None", "0,0", "0,1")) } if(crtype == "riself" || crtype == "risib") { return(c("None", "0,0", "1,1")) } if(crtype == "f2") { return(c("None", "0,0", "0,1 1,0", "1,1", "0,0 0,1 1,0", "0,1 1,0 1,1")) } stop("cross type \"", crtype, "\" not yet supported for qtab.") } # write qtab symbols rqtl.to.qtab.symbols <- function(cross, filename="symbols.qtab",descr) { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") cat(file=filename, "# --- ",get.qtlHD.ID()," Symbol ",descr, "\n",sep=""); cat(file=filename, "# --- Genotype Symbol begin\n", append=TRUE) gnames <- getgenonames.for.qtab(cross) symbols <- get.qtab.geno.symbols(cross) for(i in seq(along=gnames)) { cat(file=filename, gnames[i], " as ", symbols[i], "\n", sep="", append=TRUE) } cat(file=filename, "# --- Genotype Symbol end\n", append=TRUE) } # write qtab marker map rqtl.to.qtab.location <- function(cross, filename="locations.qtab", descr) { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") cat(file=filename, "# --- ",get.qtlHD.ID()," Location ", descr, "\n", sep="") cat(file=filename, "# --- Data Location begin\n", append=TRUE) cat(file=filename, "#\tChr\tPos\n", append=TRUE) map <- pull.map(cross, as.table=TRUE) map <- cbind(rownames(map), map) write.table(map, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE) cat(file=filename, "# --- Data Location end\n", append=TRUE) } rqtl.to.qtab.genotypes <- function(cross, filename="genotypes.qtab", descr) { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") cat(file=filename, "# --- ",get.qtlHD.ID()," Genotype ", descr, "\n", sep="") cat(file=filename, "# --- Data Genotype begin\n", append=TRUE) # pull out genotypes data; convert to strings genotypes <- pull.geno(cross) genotypes[is.na(genotypes)] <- 0 gnames <- getgenonames.for.qtab(cross) gstr <- matrix(rep("", prod(dim(genotypes))), ncol=ncol(genotypes)) for(i in seq(along=gnames)) gstr[genotypes == (i-1)] <- gnames[i] # add column with individual IDs id <- get.indID.for.qtab(cross) gstr <- cbind(id, gstr) # marker names cat(file=filename, "#", paste(colnames(genotypes), collapse="\t"), "\n", sep="", append=TRUE) # genotypes write.table(gstr, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE) cat(file=filename, "# --- Data Genotype end\n", append=TRUE) } rqtl.to.qtab.phenotypes <- function(cross, filename="phenotypes.qtab", descr) { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") cat(file=filename, "# --- ",get.qtlHD.ID()," Phenotype ", descr, "\n", sep="") cat(file=filename, "# --- Type Phenotype begin\n", append=TRUE) for(phename in colnames(cross$pheno)) { cat(file=filename, phename, "\t", get.phenotype.type(cross,phename), "\n", sep="", append=TRUE) } cat(file=filename, "# --- Type Phenotype end", "\n", sep="", append=TRUE) cat(file=filename, "# --- Data Phenotype begin", "\n", sep="", append=TRUE) cat(file=filename, "#", paste(colnames(cross$pheno), collapse="\t"), "\n", sep="", append=TRUE) # add column with individual IDs id <- get.indID.for.qtab(cross) phe <- cbind(id, cross$pheno) write.table(phe, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE) cat(file=filename, "# --- Data Phenotype end", "\n", sep="", append=TRUE) } get.phenotype.type <- function(cross, phenotype) { if(is.numeric(cross$pheno[,phenotype])) return("Float") if(is.character(cross$pheno[,phenotype])) return("Char") if(is.factor(cross$pheno[,phenotype])) return("Char") return("Float") } rqtl.to.qtab.founder <- function(cross, filename="founder.qtab", descr) { if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl") cat(file=filename, "# --- ",get.qtlHD.ID()," Founder ", descr, "\n", sep="") cat(file=filename, "# --- Set Founder begin\n", append=TRUE) cat(file=filename, "Cross\t", toupper(crosstype(cross)), "\n", sep="", append=TRUE) cat(file=filename, "# --- Set Founder end\n", append=TRUE) } # end of write.cross.qtab.R qtl/R/replacemap.R0000644000176200001440000002203613576241200013512 0ustar liggesusers##################################################################### # # replacemap.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: replace.map, replacemap, replacemap.cross, # replacemap.scanone, replacemap.scantwo ###################################################################### ###################################################################### # # replace.map # # replace the map portion of a cross object with a list defining a map # ###################################################################### replace.map <- function(cross, map) replacemap.cross(cross, map) replacemap.cross <- function(object, map) { cross <- object if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") chr.names <- names(cross$geno) chr.names2 <- names(map) m <- match(chr.names2, chr.names) if(any(is.na(m))) { # some extra chr in map extra <- chr.names2[is.na(m)] map <- map[!is.na(m)] chr.names2 <- names(map) warning("Extra chr in map: ", paste(extra, collapse=" ")) } cross.sexsp <- sapply(cross$geno, function(a) is.matrix(a$map)) map.sexsp <- sapply(map, is.matrix) if(all(cross.sexsp)) cross.sexsp <- TRUE else if(all(!cross.sexsp)) cross.sexsp <- FALSE else stop("In cross, some maps sex-specific, some not.") if(all(map.sexsp)) map.sexsp <- TRUE else if(all(!map.sexsp)) map.sexsp <- FALSE else stop("In map, some chrsex-specific, some not.") m <- match(chr.names, chr.names2) if(any(is.na(m))) { for(i in chr.names2) { if(cross.sexsp) mnames <- colnames(cross$geno[[i]]$map) else mnames <- names(cross$geno[[i]]$map) if(map.sexsp) mnames2 <- colnames(map[[i]]) else mnames2 <- names(map[[i]]) if(length(mnames) != length(mnames2)) stop("Different numbers of markers on chr ", i) if(!all(mnames==mnames2)) stop("Different marker names on chr ", i) cross$geno[[i]]$map <- map[[i]] } } else { # the same chromosomes n.chr <- nchr(cross) n.mar <- nmar(cross) n.chr2 <- length(map) if(cross.sexsp) mnames <- unlist(lapply(cross$geno, function(a) colnames(a$map))) else mnames <- unlist(lapply(cross$geno, function(a) names(a$map))) if(map.sexsp) { mnames2 <- unlist(lapply(map, colnames)) n.mar2 <- sapply(map, ncol) } else { mnames2 <- unlist(lapply(map, names)) n.mar2 <- sapply(map, length) } # check that things line up properly if(n.chr != n.chr2) stop("Numbers of chromosomes don't match.") if(any(names(cross$geno) != names(map))) stop("Chromosome names don't match.") if(any(n.mar != n.mar2)) stop("Number of markers don't match.") if(any(mnames != mnames2)) stop("Marker names don't match.") # proceed if no errors for(i in 1:length(cross$geno)) cross$geno[[i]]$map <- map[[i]] } #### < BUG > #### # the next two things don't work for sex-sp maps (4-way cross) ################# # maps in geno prob if("prob" %in% names(cross$geno[[1]])) { for(i in names(cross$geno)) { if("map" %in% names(attributes(cross$geno[[i]]$prob))) { temp <- attr(cross$geno[[i]]$prob, "map") tempr <- interpmap(data.frame(chr=rep(i, length(temp)), pos=temp, stringsAsFactors=TRUE), map)[,2] names(tempr) <- names(temp) attr(cross$geno[[i]]$prob, "map") <- tempr } } } # maps in draws if("draws" %in% names(cross$geno[[1]])) { for(i in names(cross$geno)) { if("map" %in% names(attributes(cross$geno[[i]]$draws))) { temp <- attr(cross$geno[[i]]$draws, "map") tempr <- interpmap(data.frame(chr=rep(i, length(temp)), pos=temp, stringsAsFactors=TRUE), map)[,2] names(tempr) <- names(temp) attr(cross$geno[[i]]$draws, "map") <- tempr } } } # maps in argmax if("argmax" %in% names(cross$geno[[1]])) { for(i in names(cross$geno)) { if("map" %in% names(attributes(cross$geno[[i]]$argmax))) { temp <- attr(cross$geno[[i]]$argmax, "map") tempr <- interpmap(data.frame(chr=rep(i, length(temp)), pos=temp, stringsAsFactors=TRUE), map)[,2] names(tempr) <- names(temp) attr(cross$geno[[i]]$argmax, "map") <- tempr } } } cross } # generic function replacemap <- function(object, map) UseMethod("replacemap") replacemap.scanone <- function(object, map) { object[,2] <- interpmap(object[,1:2], map)[,2] object } replacemap.scantwo <- function(object, map) { object$map[,2] <- interpmap4scantwo(object, map)[,2] object } ###################################################################### # interpolate map positions from one to another ###################################################################### interpmap <- function(oldmap, newmap) { returnasmap <- TRUE if(is.data.frame(oldmap)) { origmap <- oldmap pos <- oldmap[,2] names(pos) <- rownames(oldmap) oldmap <- split(pos, oldmap[,1]) returnasmap <- FALSE } ochrnam <- names(oldmap) nchrnam <- names(newmap) m <- match(ochrnam, nchrnam) if(any(is.na(m))) { u <- ochrnam[is.na(m)] stop("Chr ", paste(u, collapse=" "), " not found in new map") } for(i in seq(along=ochrnam)) { omap <- oldmap[[i]] nmap <- newmap[[m[i]]] mm <- match(names(omap), names(nmap)) wh <- is.na(mm) if(sum(!wh) > 1 && any(diff(mm[!wh])<0)) stop("Need old and new maps to have markers in the same order.") if(sum(wh)==0) { oldmap[[i]] <- nmap next } if(sum(!wh) < 2) stop("Need at least two markers per chromosome in both old and new maps") nnmap <- omap nnmap[!wh] <- nmap[mm[!wh]] nL <- diff(range(nmap[mm[!wh]])) oL <- diff(range(omap[!wh])) onmap <- which(!wh) first <- onmap[1] last <- max(onmap) notonmap <- which(wh) for(j in notonmap) { if(!any(onmap < j)) # before first marker nnmap[j] <- nnmap[first] - (omap[first] - omap[j])*nL/oL else if(!any(onmap > j)) # after last marker nnmap[j] <- nnmap[last] + (omap[j] - omap[last])*nL/oL else { left <- max(onmap[onmap < j]) right <- min(onmap[onmap > j]) nnmap[j] <- nnmap[left] + (omap[j]-omap[left])*(nnmap[right]-nnmap[left])/ (omap[right]-omap[left]) } } oldmap[[i]] <- nnmap } if(!returnasmap) { origmap[,2] <- unlist(oldmap) return(origmap) } oldmap } # like interpmap, but special for scantwo to deal with # the case that scantwo was run without incl.markers=TRUE, # so we need to add all marker positions to the map thing interpmap4scantwo <- function(output, newmap) { themap <- output$map[,1:2] pos <- themap[,2] names(pos) <- rownames(themap) themapalt <- split(pos, themap[,1]) markermap <- attr(output, "fullmap") omapnam <- names(themapalt) nmapnam <- names(markermap) m <- match(omapnam, nmapnam) if(any(is.na(m))) { u <- omapnam[is.na(m)] stop("Chr ", paste(u, collapse=" "), " not found in new map") } flag <- FALSE for(i in seq(along=m)) { omap <- themapalt[[i]] nmap <- markermap[[m[i]]] mm <- match(names(nmap), names(omap)) if(any(is.na(mm))) { flag <- TRUE themapalt[[i]] <- sort(c(omap, nmap[is.na(mm)])) } } if(flag) { revmap <- data.frame(chr=factor(rep(names(themapalt), sapply(themapalt, length)), levels=names(themapalt)), pos=unlist(themapalt), stringsAsFactors=TRUE) rownames(revmap) <- unlist(lapply(themapalt, names)) revmap[,2] <- interpmap(revmap, newmap)[,2] themap <- revmap[rownames(themap),] } else themap[,2] <- interpmap(themap, newmap)[,2] themap } # end of replacemap.R qtl/R/summary.scantwo.R0000644000176200001440000011631413626261114014560 0ustar liggesusers###################################################################### # # summary.scantwo.R # # copyright (c) 2001-2020, Karl W Broman, Hao Wu, and Brian Yandell # last modified Feb, 2020 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: summary.scantwo, print.summary.scantwo, # max.scantwo, clean.scantwo, print.scantwo, subset.scantwo # summary.scantwoperm, print.summary.scantwoperm # condense.scantwo, summary.scantwocondensed # max.scantwocondensed, print.summary.addpair # rbind.scantwoperm, c.scantwoperm, subset.scantwoperm # [.scantwoperm # ###################################################################### # # summarize the result from scantwo # ###################################################################### summary.scantwo <- function(object, thresholds, what=c("best", "full", "add", "int"), perms, alphas, lodcolumn=1, pvalues=FALSE, allpairs=TRUE, ...) { if(!inherits(object, "scantwo") && !inherits(object, "scantwocondensed")) stop("Input should have class \"scantwo\".") addpair <- attr(object, "addpair") if(!is.null(addpair) && addpair) { # results from addpair() that need special treatment if("lod.minus1" %in% names(attributes(object))) { # asymmetric formula attr(object, "addpair") <- NULL x <- summary.scantwo(object, allpairs=allpairs) class(x) <- "data.frame" x <- x[,c(1,2,8,9,10,3,4,5),drop=FALSE] mlod.minus1 <- tapply(attr(object, "lod.minus1"), object$map$chr, max, na.rm=TRUE) mlod.minus2 <- tapply(attr(object, "lod.minus2"), object$map$chr, max, na.rm=TRUE) w <- which(x[,1] == x[,2]) for(i in seq(along=w)) if(x[w[i],5] < x[w[i],8]) x[w[i],3:5] <- x[w[i],c(7,6,8)] if(any(x[,1] != x[,2])) { w <- which(x[,1] != x[,2]) y <- x[w,,drop=FALSE] for(i in 1:nrow(y)) y[,1:5] <- y[,c(2,1,7,6,8)] neworder <- cbind(1:nrow(x), rep(NA, nrow(x))) neworder[w,2] <- nrow(x) + 1:nrow(y) neworder <- as.numeric(t(neworder)) x <- rbind(x, y)[neworder[!is.na(neworder)],,drop=FALSE] } x <- cbind(x[,1:5], lod.2v1b=rep(NA,nrow(x)), lod.2v1a=rep(NA,nrow(x))) names(x)[5] <- "lod.2v0" x[,6] <- x[,5] - mlod.minus1[as.character(x[,2])] x[,7] <- x[,5] - mlod.minus2[as.character(x[,1])] if(!missing(thresholds)) { if(length(thresholds) > 2) warning("Only the first two values in thresholds are used.") if(length(thresholds) == 1) thresholds <- c(thresholds, 0) x <- x[!is.na(x[,5]) & x[,5] >= thresholds[1] & ((!is.na(x[,6]) & x[,6] >= thresholds[2]) | (!is.na(x[,7]) & x[,7] >= thresholds[2])),,drop=FALSE] } class(x) <- c("summary.addpair", "data.frame") return(x) } else { # symmetric formula attr(object, "addpair") <- NULL if(missing(thresholds)) x <- summary.scantwo(object, allpairs=allpairs) else x <- summary.scantwo(object, thresholds=thresholds, allpairs=allpairs) x <- x[,1:6] colnames(x)[5:6] <- c("lod.2v0", "lod.2v1") if(!missing(thresholds)) { if(length(thresholds) > 2) warning("Only the first two values in thresholds are used.") if(length(thresholds) == 1) thresholds <- c(thresholds, 0) x <- x[!is.na(x[,5]) & x[,5] >= thresholds[1] & !is.na(x[,6]) & x[,6] >= thresholds[2],,drop=FALSE] } class(x) <- c("summary.addpair", "data.frame") return(x) } } what <- match.arg(what) if(!missing(thresholds)) { if(length(thresholds) != 5) stop("If thresholds are given, there must be 5 of them.") else if(!is.numeric(thresholds)) stop("thresholds should be a numeric vector") } if(!missing(alphas)) { if(length(alphas) != 5) { if(length(alphas)==1) alphas <- rep(alphas, 5) else stop("If alphas are given, there must be 5 of them.") } else if(!is.numeric(alphas)) stop("alphas should be a numeric vector") } if(!missing(perms) && !inherits(perms, "scantwoperm")) stop("perms must be in scantwoperm format.") # subset object and permutations, if necessary if(inherits(object, "scantwo")) { d <- dim(object$lod) if(length(d)==3) { if(!missing(perms)) { if("AA" %in% names(perms)) { # contains X-specific results ncp <- sapply(perms$AA, ncol) } else { ncp <- sapply(perms, ncol) } if(all(ncp==1)) onepermcol <- TRUE else onepermcol <- FALSE if(any(ncp != d[3])) { if(onepermcol) { if(lodcolumn > 1) warning("Just one column of permutation results; assuming they apply to all LOD score columns.") } else stop("perms have different numbers of columns as object input.\n") } } if(lodcolumn < 1 || lodcolumn > d[3]) stop("lodcolumn must be between 1 and ", d[3]) object$lod <- object$lod[,,lodcolumn] if(!missing(perms) && !onepermcol) { if("AA" %in% names(perms)) { for(i in seq(along=perms)) perms[[i]] <- lapply(perms[[i]], function(a, b) a[,b,drop=FALSE], lodcolumn) } else { perms <- lapply(perms, function(a, b) a[,b,drop=FALSE], lodcolumn) } } } } else { # condensed version if(is.matrix(object$pos1.jnt)) { d <- ncol(object$pos1.jnt) if(!missing(perms)) { ncp <- sapply(perms, ncol) if(all(ncp==1)) onepermcol <- TRUE else onepermcol <- FALSE if(any(ncp != d[3])) { if(onepermcol) warning("Just one column of permutation results; reusing for all LOD score columns.") else stop("perms have different numbers of columns as object input.\n") } } if(lodcolumn < 1 || lodcolumn > d) stop("lodcolumn must be between 1 and ", d) for(i in 3:length(object)) object[[i]] <- object[[i]][,lodcolumn] if(!missing(perms) && !onepermcol) perms <- lapply(perms, function(a, b) a[,b,drop=FALSE], lodcolumn) } } # check input if(missing(perms) && !missing(alphas)) stop("If alphas are to be used, permutation results must be provided.") if(!missing(thresholds) && !missing(alphas)) stop("Only one of threshold and alpha should be specified.") if(pvalues && what != "best") { pvalues <- FALSE warning("pvalues shown only with what=\"best\".") } if(pvalues && missing(perms)) { pvalues <- FALSE warning("p-values may be calculated only if perms are provided.") } if(inherits(object, "scantwo")) out <- subrousummaryscantwo(object, for.perm=FALSE) else out <- as.data.frame(object, stringsAsFactors=TRUE) if(!allpairs) # only look at self-self cases out <- out[out$chr1==out$chr2,] if(what=="best") { p1.f <- out$pos1.jnt p2.f <- out$pos2.jnt p1.a <- out$pos1.add p2.a <- out$pos2.add lf <- out$jnt.lod.full li <- out$jnt.lod.full - out$add.lod.add lfv1 <- out$jnt.lod.full - out$lod.1qtl la <- out$add.lod.add lav1 <- out$add.lod.add - out$lod.1qtl } else if(what=="full") { p1.f <- p1.a <- out$pos1.jnt p2.f <- p2.a <- out$pos2.jnt lf <- out$jnt.lod.full li <- out$jnt.lod.full - out$jnt.lod.add lfv1 <- out$jnt.lod.full - out$lod.1qtl la <- out$jnt.lod.add lav1 <- out$jnt.lod.add - out$lod.1qtl } else if(what=="add") { p1.f <- p1.a <- out$pos1.add p2.f <- p2.a <- out$pos2.add lf <- out$add.lod.full li <- out$add.lod.full - out$add.lod.add lfv1 <- out$add.lod.full - out$lod.1qtl la <- out$add.lod.add lav1 <- out$add.lod.add - out$lod.1qtl } else { # what == "int" p1.f <- p1.a <- out$pos1.int p2.f <- p2.a <- out$pos2.int lf <- out$int.lod.full li <- out$int.lod.full - out$int.lod.add lfv1 <- out$int.lod.full - out$lod.1qtl la <- out$int.lod.add lav1 <- out$int.lod.add - out$lod.1qtl } out <- data.frame(chr1=out$chr1, chr2=out$chr2, pos1f=p1.f, pos2f=p2.f, lod.full=lf, lod.fv1=lfv1, lod.int=li, pos1a=p1.a, pos2a=p2.a, lod.add=la, lod.av1=lav1, stringsAsFactors=TRUE) if(what != "best") { out <- out[,-(8:9)] names(out)[3:4] <- c("pos1", "pos2") } if(!missing(perms) && "AA" %in% names(perms)) { xchr_specific <- TRUE chr_type <- attr(perms, "chrtype") chrpair_type <- paste0(chr_type[out$chr1], chr_type[out$chr2]) if(all(chrpair_type=="AA")) { perms <- perms$AA xchr_specific <- FALSE } else if(all(chrpair_type=="XX")) { perms <- perms$XX xchr_specific <- FALSE } else if(all(chrpair_type=="AX")) { perms <- perms$AX xchr_specific <- FALSE } } else xchr_specific <- FALSE if(!missing(alphas)) { # get thresholds if(!xchr_specific) { thresholds <- rep(0,5) for(i in 1:5) thresholds[i] <- quantile(perms[[i]], 1-alphas[i]) thresholds[alphas==1] <- 0 thresholds[alphas==0] <- Inf } else { # x-chr-specific thresholds <- matrix(nrow=3, ncol=5) for(j in 1:3) { for(i in 1:5) thresholds[j,i] <- quantile(perms[[j]][[i]], 1-alphas[i]) } thresholds[alphas==1] <- 0 thresholds[alphas==0] <- Inf } } if(!missing(thresholds) || !missing(alphas)) { # apply thresholds if(!xchr_specific) { out <- out[(out$lod.full >= thresholds[1] & (out$lod.fv1 >= thresholds[2] | out$lod.int >= thresholds[3])) | (out$lod.add >= thresholds[4] & out$lod.av1 >= thresholds[5]),,drop=FALSE] } else { tokeep <- NULL for(i in 1:nrow(out)) { this_chrpair_type <- match(chrpair_type[i], c("AA", "AX", "XX")) if((out$lod.full[i] >= thresholds[this_chrpair_type, 1] & (out$lod.fv1[i] >= thresholds[this_chrpair_type, 2] | out$lod.int[i] >= thresholds[this_chrpair_type, 3])) | (out$lod.add[i] >= thresholds[this_chrpair_type, 4] & out$lod.av1[i] >= thresholds[this_chrpair_type, 5])) tokeep <- c(tokeep, i) } out <- out[tokeep, , drop=FALSE] } } if(pvalues && nrow(out) > 0) { result <- as.data.frame(matrix(ncol=11+5, nrow=nrow(out)), stringsAsFactors=TRUE) wh <- c(1,2,3,4,5,7,9,11,12,13,15) wh2 <- (1:16)[-wh] result[,wh] <- out names(result)[wh] <- names(out) colnames(result)[wh2] <- rep("pval",5) if(!xchr_specific) { for(i in 1:5) { for(j in 1:nrow(out)) result[j,wh2[i]] <- mean(perms[[i]] >= result[j,wh2[i]-1], na.rm=TRUE) } } else { # X-chr-specific L <- attr(perms, "L") sumL <- sum(L) for(j in 1:nrow(out)) { this_chrpair_type <- match(chrpair_type[j], c("AA", "AX", "XX")) pow <- sumL/L[this_chrpair_type] for(i in 1:5) { nominal_p <- mean(perms[[this_chrpair_type]][[i]] >= result[j,wh2[i]-1], na.rm=TRUE) result[j,wh2[i]] <- 1 - (1-nominal_p)^pow # adjusted P-value } } } out <- result } class(out) <- c("summary.scantwo", "data.frame") out } # subroutine for summary.scantwo; pulls out the key info # on each pair of chromosomes subrousummaryscantwo <- function(object, for.perm=FALSE) { lod <- object$lod lod[is.na(lod) | lod == Inf | lod == -Inf] <- 0 map <- object$map pos <- map[,2] chr <- as.factor(map[,1]) tchr <- as.numeric(chr) n.chr <- max(tchr) xchr <- tapply(map[,4], map[,1], function(a) a[1]) xchr <- xchr[!is.na(xchr)] n.phe <- 1 if(length(dim(lod)) == 3) n.phe <- dim(lod)[3] if(!("scanoneX" %in% names(object)) || is.null(object$scanoneX) || length(object$scanoneX)==0) { if(n.phe==1) scanoneX <- diag(lod) else { if(nrow(lod)==1) scanoneX <- lod[1,1,1] else scanoneX <- diag(lod[,,1]) for(i in 2:n.phe) { if(nrow(lod)==1) scanoneX <- cbind(scanoneX, lod[1,1,i]) else scanoneX <- cbind(scanoneX, diag(lod[,,i])) } } } else scanoneX <- object$scanoneX if((is.matrix(scanoneX) && nrow(scanoneX) != nrow(lod)) || (!is.matrix(scanoneX) && length(scanoneX) != nrow(lod))) stop("scanoneX component has length ", length(scanoneX), " but should have length ", nrow(lod)) n.chrpair <- n.chr*(n.chr+1)/2 fill <- matrix(0, nrow=n.chrpair, ncol=n.phe) out <- .C("R_summary_scantwo", as.integer(nrow(map)), as.integer(n.phe), as.double(lod), as.integer(n.chr), as.integer(tchr), as.double(pos), as.integer(xchr), as.double(scanoneX), as.integer(n.chrpair), chr1=as.integer(rep(0,n.chrpair)), chr2=as.integer(rep(0,n.chrpair)), as.integer(rep(0,n.chr*n.chr)), pos1.jnt=as.double(fill), pos2.jnt=as.double(fill), pos1.add=as.double(fill), pos2.add=as.double(fill), pos1.int=as.double(fill), pos2.int=as.double(fill), jnt.lod.full=as.double(fill), jnt.lod.add=as.double(fill), add.lod.full=as.double(fill), add.lod.add=as.double(fill), int.lod.full=as.double(fill), int.lod.add=as.double(fill), lod.1qtl=as.double(fill), PACKAGE="qtl") chr1 <- factor(levels(chr)[out$chr1+1], levels=levels(chr)) chr2 <- factor(levels(chr)[out$chr2+1], levels=levels(chr)) if(n.phe == 1) { out <- data.frame(chr1=chr1, chr2=chr2, pos1.jnt=out$pos1.jnt, pos2.jnt=out$pos2.jnt, jnt.lod.full=out$jnt.lod.full, jnt.lod.add=out$jnt.lod.add, pos1.add=out$pos1.add, pos2.add=out$pos2.add, add.lod.full=out$add.lod.full, add.lod.add=out$add.lod.add, pos1.int=out$pos1.int, pos2.int=out$pos2.int, int.lod.full=out$int.lod.full, int.lod.add=out$int.lod.add, lod.1qtl=out$lod.1qtl, stringsAsFactors=TRUE) } else out <- list(chr1=chr1, chr2=chr2, pos1.jnt=matrix(out$pos1.jnt, ncol=n.phe), pos2.jnt=matrix(out$pos2.jnt, ncol=n.phe), jnt.lod.full=matrix(out$jnt.lod.full, ncol=n.phe), jnt.lod.add=matrix(out$jnt.lod.add, ncol=n.phe), pos1.add=matrix(out$pos1.add, ncol=n.phe), pos2.add=matrix(out$pos2.add, ncol=n.phe), add.lod.full=matrix(out$add.lod.full, ncol=n.phe), add.lod.add=matrix(out$add.lod.add, ncol=n.phe), pos1.int=matrix(out$pos1.int, ncol=n.phe), pos2.int=matrix(out$pos2.int, ncol=n.phe), int.lod.full=matrix(out$int.lod.full, ncol=n.phe), int.lod.add=matrix(out$int.lod.add, ncol=n.phe), lod.1qtl=matrix(out$lod.1qtl, ncol=n.phe)) if(for.perm) { if(n.phe==1) { out <- c("full"=max(out$jnt.lod.full,na.rm=TRUE), "fv1"=max(out$jnt.lod.full - out$lod.1qtl, na.rm=TRUE), "int"=max(out$jnt.lod.full - out$add.lod.add, na.rm=TRUE), "add"=max(out$add.lod.add, na.rm=TRUE), "av1"=max(out$add.lod.add - out$lod.1qtl, na.rm=TRUE), "one"=max(out$lod.1qtl, na.rm=TRUE)) } else { out <- list("full"=apply(out$jnt.lod.full, 2, max, na.rm=TRUE), "fv1"=apply(out$jnt.lod.full - out$lod.1qtl, 2, max, na.rm=TRUE), "int"=apply(out$jnt.lod.full - out$add.lod.add, 2, max, na.rm=TRUE), "add"=apply(out$add.lod.add, 2, max, na.rm=TRUE), "av1"=apply(out$add.lod.add - out$lod.1qtl, 2, max, na.rm=TRUE), "one"=apply(out$lod.1qtl, 2, max, na.rm=TRUE)) } } out } print.summary.scantwo <- function(x, ...) { if(nrow(x)==0) { cat(" There were no pairs of loci meeting the criteria.\n") return(invisible(NULL)) } z <- as.character(unlist(x[,1])) if(max(nchar(z)) == 1) rownames(x) <- apply(x[,1:2], 1, function(a) paste("c", a, collapse=":", sep="")) else rownames(x) <- apply(x[,1:2], 1, function(a) paste(sprintf("c%-2s", a), collapse=":")) x <- x[,-(1:2)] cn <- colnames(x) if(any(cn=="pos1a")) cn[cn=="pos1a"] <- " pos1a" wh <- grep("^pval", cn) if(length(wh) > 0) cn[wh] <- "pval" colnames(x) <- cn print.data.frame(x, digits=3) } print.summary.addpair <- function(x, ...) { if(nrow(x)==0) { cat(" There were no pairs of loci meeting the criteria.\n") return(invisible(NULL)) } z <- as.character(unlist(x[,1])) if(max(nchar(z)) == 1) rownames(x) <- apply(x[,1:2], 1, function(a) paste("c", a, collapse=":", sep="")) else rownames(x) <- apply(x[,1:2], 1, function(a) paste(sprintf("c%-2s", a), collapse=":")) x <- x[,-(1:2), drop=FALSE] print.data.frame(x, digits=3) } print.scantwo <- function(x, ...) { d <- dim(x$lod) dn <- dimnames(x$lod)[[3]] if(is.null(dn)) dn <- attr(x, "phenotypes") if(nrow(x$lod) == 0) cat("Empty scantwo object.\n") else { if(length(d)==2) print(summary(x)) else { for(i in 1:d[3]) { if(is.null(dn)) cat("Phenotype", i, "\n") else cat(dn[i], "\n") print(summary(x, lod=i)) } } } } ###################################################################### # # max.scantwo: Give pair of chromosome with maximum 2-locus LOD score # ###################################################################### max.scantwo <- function(object, lodcolumn=1, what=c("best", "full", "add", "int"), na.rm=TRUE, ...) { if(!inherits(object, "scantwo") && !inherits(object, "scantwocondensed")) stop("Input must have class \"scantwo\".") addpair <- attr(object, "addpair") if(!is.null(addpair) && addpair) { # special treatment for output for addpair temp <- summary(object) mx <- max(temp[,5],na.rm=TRUE) return(temp[!is.na(temp[,5]) & temp[,5]==mx,]) } what <- match.arg(what) if(inherits(object, "scantwo")) { d <- dim(object$lod) if(length(d)==3) { if(lodcolumn < 1 || lodcolumn > d[3]) stop("lodcolumn must be between 1 and ", d[3]) object$lod <- object$lod[,,lodcolumn] } out <- subrousummaryscantwo(object, for.perm=FALSE) } else { # condensed version if(is.matrix(object$pos1.jnt)) { d <- ncol(object$pos1.jnt) if(lodcolumn < 1 || lodcolumn > d) stop("lodcolumn must be between 1 and ", d) for(i in 3:length(object)) object[[i]] <- object[[i]][,lodcolumn] } out <- as.data.frame(object, stringsAsFactors=TRUE) } if(what=="best") { wh <- which(!is.na(out$jnt.lod.full) & out$jnt.lod.full==max(out$jnt.lod.full, na.rm=TRUE)) p1.f <- out$pos1.jnt[wh] p2.f <- out$pos2.jnt[wh] p1.a <- out$pos1.add[wh] p2.a <- out$pos2.add[wh] lf <- out$jnt.lod.full[wh] li <- out$jnt.lod.full[wh] - out$add.lod.add[wh] lfv1 <- out$jnt.lod.full[wh] - out$lod.1qtl[wh] la <- out$add.lod.add[wh] lav1 <- out$add.lod.add[wh] - out$lod.1qtl[wh] } else if(what=="full") { wh <- which(!is.na(out$jnt.lod.full) & out$jnt.lod.full==max(out$jnt.lod.full, na.rm=TRUE)) p1.f <- p1.a <- out$pos1.jnt[wh] p2.f <- p2.a <- out$pos2.jnt[wh] lf <- out$jnt.lod.full[wh] li <- out$jnt.lod.full[wh] - out$jnt.lod.add[wh] lfv1 <- out$jnt.lod.full[wh] - out$lod.1qtl[wh] la <- out$jnt.lod.add[wh] lav1 <- out$jnt.lod.add[wh] - out$lod.1qtl[wh] } else if(what=="add") { wh <- which(!is.na(out$add.lod.add) & out$add.lod.add==max(out$add.lod.add, na.rm=TRUE)) p1.f <- p1.a <- out$pos1.add[wh] p2.f <- p2.a <- out$pos2.add[wh] lf <- out$add.lod.full[wh] li <- out$add.lod.full[wh] - out$add.lod.add[wh] lfv1 <- out$add.lod.full[wh] - out$lod.1qtl[wh] la <- out$add.lod.add[wh] lav1 <- out$add.lod.add[wh] - out$lod.1qtl[wh] } else { # what == "int" lod.int <- out$int.lod.full - out$int.lod.add wh <- which(!is.na(lod.int) & lod.int == max(lod.int, na.rm=TRUE)) p1.f <- p1.a <- out$pos1.int[wh] p2.f <- p2.a <- out$pos2.int[wh] lf <- out$int.lod.full[wh] li <- out$int.lod.full[wh] - out$int.lod.add[wh] lfv1 <- out$int.lod.full[wh] - out$lod.1qtl[wh] la <- out$int.lod.add[wh] lav1 <- out$int.lod.add[wh] - out$lod.1qtl[wh] } out <- data.frame(chr1=out$chr1[wh], chr2=out$chr2[wh], pos1f=p1.f, pos2f=p2.f, lod.full=lf, lod.fv1=lfv1, lod.int=li, pos1a=p1.a, pos2a=p2.a, lod.add=la, lod.av1=lav1, stringsAsFactors=TRUE) if(what != "best") { out <- out[,-(8:9)] names(out)[3:4] <- c("pos1", "pos2") } class(out) <- c("summary.scantwo", "data.frame") rownames(out) <- what out } ###################################################################### # clean.scantwo # # sets LOD scores that are missing or < 0 to 0 # If full LOD < add've LOD, set full = add've # sets LOD scores, for pairs of positions that are not separated # by n.mar markers and distance cM, to 0 ###################################################################### clean.scantwo <- function(object, n.mar=1, distance=0, ...) { if(!inherits(object, "scantwo")) stop("Input should have class \"scantwo\".") addpair <- attr(object, "addpair") if(is.null(addpair)) addpair <- FALSE lod <- object$lod map <- object$map if(!("fullmap" %in% names(attributes(object)))) stop("clean.scantwo only works on scantwo objects created with R/qtl ver >= 1.04-38.\n") fmap <- attr(object, "fullmap") lod[is.na(lod) | lod < 0] <- 0 subrou <- function(x,y,z) { out <- x for(i in seq(along=x)) out[i] <- sum((z > x[i] & z < y[i]) | (z < x[i] & z > y[i])) + (x[i] == y[i]) out } last <- 0 for(i in seq(along=fmap)) { m <- map[map[,1]==names(fmap)[i],2] idx <- 1:length(m)+last last <- last + length(m) toclean <- (outer(m, m, subrou, fmap[[i]]) < n.mar) | (abs(outer(m, m, "-")) 0) && any(lodcolumn<0)) stop("lodcolumn values can't be both >0 and <0.") if(any(lodcolumn<0) || is.logical(lodcolumn)) lodcolumn <- (1:(dim(x$lod)[3]))[lodcolumn] if(length(lodcolumn)==0) stop("You must retain at least one LOD column.") if(any(lodcolumn < 1 || lodcolumn > dim(x$lod)[3])) stop("lodcolumn values must be >=1 and <=",dim(x$lod)[3]) x$lod <- x$lod[,,lodcolumn] if("scanoneX" %in% names(x)) x$scanoneX <- x$scanoneX[,lodcolumn] } if(!missing(chr)) { chr <- matchchr(chr, unique(x$map[,1])) wh <- x$map[,1] %in% chr x$map <- x$map[wh,,drop=FALSE] x$map[,1] <- droplevels(x$map[,1]) if(length(dim(x$lod))==2) x$lod <- x$lod[wh,wh,drop=FALSE] else x$lod <- x$lod[wh,wh,,drop=FALSE] if(!is.null(x$scanoneX)) x$scanoneX <- x$scanoneX[wh] if("fullmap" %in% names(attributes(x))) { fmap <- attr(x, "fullmap") fmap <- fmap[chr] attr(x, "fullmap") <- fmap } } x } ###################################################################### # summary.scantwoperm # # Give genome-wide LOD thresholds on the basis of results of # scantwo permutation test (from scantwo with n.perm > 0) ###################################################################### summary.scantwoperm <- function(object, alpha=c(0.05, 0.10), ...) { if(!inherits(object, "scantwoperm")) stop("Input should have class \"scantwoperm\".") if("AA" %in% names(object)) { # X-chr-specific version # get region-specific (nominal) signif levels L <- attr(object, "L") LL <- attr(object, "LL") if(is.null(LL)) stop("LL attribute not found in input object") if(length(alpha)==1) { tmp <- L/sum(L); tmp <- c(tmp[1], 1, tmp[2]) one_minus_alpha_onechr <- cbind((1-alpha)^tmp) one_minus_alpha <- cbind((1-alpha)^(LL/sum(LL))) } else { tmp <- L/sum(L); tmp <- c(tmp[1], 1, tmp[2]) one_minus_alpha_onechr <- vapply(alpha, function(a,b) (1-a)^b, rep(0, length(tmp)), tmp) one_minus_alpha <- vapply(alpha, function(a,b) (1-a)^b, rep(0, length(LL)), LL/sum(LL)) } # get quantiles out <- vector("list", length(object)) names(out) <- names(object) for(i in seq(along=out)) { f <- function(a, qu) { b <- apply(a, 2, quantile, qu) if(!is.matrix(b)) { nam <- names(b) b <- matrix(b, nrow=1) colnames(b) <- nam } rownames(b) <- paste0(alpha*100, "%") b } out[[i]] <- lapply(unclass(object[[i]])[1:5], f, one_minus_alpha[i,,drop=FALSE]) qu_one <- f(object[[i]][[6]], one_minus_alpha_onechr[i,,drop=FALSE]) out[[i]] <- c(out[[i]], "one"=list(qu_one)) } attr(out, "n.perm") <- vapply(object, function(a) nrow(a[[1]]), 0) class(out) <- c("summary.scantwoperm", "list") return(out) } out <- lapply(object, apply, 2, quantile, 1-alpha) for(i in 1:length(out)) { if(!is.matrix(out[[i]])) out[[i]] <- matrix(out[[i]], nrow=length(alpha)) rownames(out[[i]]) <- paste0(alpha*100, "%") } attr(out, "n.perm") <- nrow(object[[1]]) class(out) <- c("summary.scantwoperm", "list") out } print.summary.scantwoperm <- function(x, ...) { if("AA" %in% names(x)) { # X-sp perms nperm <- attr(x, "n.perm") rn <- rownames(x[[1]][[1]]) nc <- rapply(x, ncol) if(length(unique(nc)) != 1) stop("The components shouldn't have varying numbers of columns.\n") nc <- nc[1] phe <- colnames(x[[1]][[1]]) convert2matrix <- function(a, which_col=1) { a <- lapply(a, "[", , which_col, drop=FALSE) b <- matrix(unlist(a), ncol=6) rownames(b) <- rn colnames(b) <- names(a) b } for(i in seq(along=phe)) { cat(phe[i], ":\n", sep="") y <- lapply(x, convert2matrix, i) lab <- c(AA="A:A", AX="A:X", XX="X:X") for(j in c("AA", "AX", "XX")) { cat(" ", lab[j], " (", nperm[j], " permutations)\n", sep="") print(y[[j]], digits=3) cat("\n") } if(i != length(phe)) cat("\n") } invisible(return(x)) } nam <- names(x) rn <- rownames(x[[1]]) n.perm <- attr(x, "n.perm") nc <- sapply(x, ncol) if(length(unique(nc)) != 1) stop("The components shouldn't have varying numbers of columns.\n") nc <- nc[1] if(nc==1) { phe <- colnames(x[[1]]) if(is.null(phe)) phe <- "" x <- matrix(unlist(x), nrow=length(rn)) dimnames(x) <- list(rn, nam) if(is.null(phe)) cat("(", n.perm, " permutations)\n", sep="") else cat(phe, " (", n.perm, " permutations)\n", sep="") print(x, digits=3) } else { phe <- colnames(x[[1]]) if(is.null(phe)) phe <- paste("pheno", 1:nc) for(i in 1:nc) { y <- matrix(ncol=length(x), nrow=nrow(x[[1]])) for(j in 1:length(x)) y[,j] <- x[[j]][,i] dimnames(y) <- list(rn, nam) cat(phe[i], " (", n.perm, " permutations)\n", sep="") print(y, digits=3) if(i != nc) cat("\n") } } } ###################################################################### # combine scantwo results ... paste the phenotype columns together ###################################################################### cbind.scantwo <- c.scantwo <- function(...) { dots <- list(...) if(length(dots)==1 && is.list(dots[[1]])) dots <- dots[[1]] if(length(dots)==1) return(dots[[1]]) for(i in seq(along=dots)) { if(!inherits(dots[[i]], "scantwo")) stop("Input should have class \"scantwo\".") } # check dimensions of LODs nr <- sapply(dots, function(a) nrow(a$lod)) nc <- sapply(dots, function(a) ncol(a$lod)) nd3 <- sapply(dots, function(a) dim(a$lod)[3]) if(any(nr[-1]!=nr[1]) || any(nc[-1] != nc[1])) stop("Input objects are not the same dimensions.") # check maps map1 <- dots$map[[1]] for(i in 2:length(dots)) { if(!all(dots$map[[i]] != map1)) stop("Maps are not all the same.") } output <- dots[[1]] nd3[is.na(nd3)] <- 1 output$lod <- array(dim=c(nr[1], nc[1], sum(nd3))) start <- cumsum(c(0,nd3))[-length(nd3)-1] end <- start+nd3 for(i in seq(along=dots)) output$lod[,,(start[i]+1):end[i]] <- dots[[i]]$lod attr(output, "phenotypes") <- unlist(lapply(dots, attr, "phenotypes")) dimnames(output$lod) <- list(NULL, NULL, attr(output, "phenotypes")) # check scanoneX if(is.null(dots[[1]]$scanoneX)) { for(i in 2:length(dots)) { if(!is.null(dots[[i]]$scanoneX)) stop("Some but not all input objects have null scanoneX.") } } else { nrx <- sapply(dots, function(a) nrow(a$scanoneX)) if(any(nrx[-1]!=nrx[1])) stop("Mismatch in scanoneX dimensions.") for(i in 2:length(dots)) output$scanoneX <- cbind(output$scanoneX, dots[[i]]$scanoneX) colnames(output$scanoneX) <- attr(output, "phenotypes") } methods <- sapply(dots, attr, "method") if(length(unique(methods)) != 1) attr(output, "method") <- rep(sapply(dots, attr, "method"), nd3) fm <- lapply(dots, attr, "fullmap") for(i in 2:length(fm)) { if(length(fm[[1]]) != length(fm[[i]]) || !all(names(fm[[1]]) == names(fm[[i]]))) stop("Mismatch in \"fullmap\" attributes (1).") for(j in 1:length(fm[[1]])) { if(length(fm[[1]][[j]]) != length(fm[[i]][[j]]) || !all(names(fm[[1]][[j]]) == names(fm[[i]][[j]])) || max(abs(fm[[1]][[j]] - fm[[i]][[j]])) > 0.001) stop("Mismatch in \"fullmap\" attributes (2).") } } output } ###################################################################### # combine scantwoperm results ... paste the rows together ###################################################################### rbind.scantwoperm <- c.scantwoperm <- function(...) { dots <- list(...) if(length(dots)==1 && is.list(dots[[1]])) dots <- dots[[1]] if(length(dots)==1) return(dots[[1]]) xchrsp <- vapply(dots, function(a) "AA" %in% names(a), TRUE) if(any(xchrsp)) { if(!all(xchrsp)) stop("Some but not all inputs are X-chr specific") for(i in 2:length(dots)) { for(j in seq(along=dots[[1]])) { for(k in seq(along=dots[[1]][[j]])) { if(ncol(dots[[1]][[j]][[k]]) != ncol(dots[[i]][[j]][[k]])) stop("Mismatch in no. columns") if(any(colnames(dots[[1]][[j]][[k]]) != colnames(dots[[1]][[j]][[k]]))) warning("Mismatch in column names") dots[[1]][[j]][[k]] <- rbind(dots[[1]][[j]][[k]], dots[[i]][[j]][[k]]) } } } return(dots[[1]]) } for(i in seq(along=dots)) { if(!inherits(dots[[i]], "scantwoperm")) stop("Input should have class \"scantwoperm\".") } nc <- sapply(dots, function(a) ncol(a[[1]])) if(length(unique(nc)) != 1) stop("Number of LOD columns in the input objects must be constant.\n") flag <- 0 for(j in 1:length(dots[[1]])) { for(i in 2:length(dots)) { dots[[1]][[j]] <- rbind(dots[[1]][[j]], dots[[i]][[j]]) if(any(colnames(dots[[i]][[j]]) != colnames(dots[[1]][[j]]))) flag <- 1 } } if(flag) warning("Mismatch in column names; input may not be consistent.\n") dots[[1]] } # paste columns together cbind.scantwoperm <- function(...) { dots <- list(...) if(length(dots)==1 && is.list(dots[[1]])) dots <- dots[[1]] if(length(dots)==1) return(dots) xchrsp <- vapply(dots, function(a) "AA" %in% names(a), TRUE) if(any(xchrsp)) { if(!all(xchrsp)) stop("Some but not all inputs are X-chr specific") for(i in 2:length(dots)) { for(j in seq(along=dots[[1]])) { for(k in seq(along=dots[[1]][[j]])) { if(nrow(dots[[1]][[j]][[k]]) != nrow(dots[[i]][[j]][[k]])) stop("Mismatch in no. permutations") dots[[1]][[j]][[k]] <- cbind(dots[[1]][[j]][[k]], dots[[i]][[j]][[k]]) } } } return(dots[[1]]) } for(i in 2:length(dots)) { for(j in seq(along=dots[[1]])) { if(nrow(dots[[1]][[j]]) != nrow(dots[[i]][[j]])) stop("Mismatch in no. permutations") dots[[1]][[j]] <- cbind(dots[[1]][[j]], dots[[i]][[j]]) } } dots[[1]] } ###################################################################### # condensed scantwo output condense <- function(object) UseMethod("condense") condense.scantwo <- function(object) { out <- subrousummaryscantwo(object, for.perm=FALSE) class(out) <- c("scantwocondensed", "list") out } summary.scantwocondensed <- summary.scantwo max.scantwocondensed <- max.scantwo ############################## # subset.scantwoperm: pull out a set of lodcolumns ############################## subset.scantwoperm <- function(x, repl, lodcolumn, ...) { if("AA" %in% names(x)) { # x chr specific for(j in seq(along=x)) { if(missing(lodcolumn)) lodcolumn <- 1:ncol(x[[j]][[1]]) else if(!check_colindex(lodcolumn, x[[j]][[1]])) stop("lodcolumn misspecified.") repl <- 1:nrow(x[[j]][[1]]) x[[j]] <- lapply(x[[j]], function(a,b,d) unclass(a)[b,d,drop=FALSE], repl, lodcolumn) } return(x) } att <- attributes(x) if(any(!sapply(x, is.matrix))) x <- lapply(x, as.matrix) if(missing(lodcolumn)) lodcolumn <- 1:ncol(x[[1]]) else if(!check_colindex(lodcolumn, x[[1]])) stop("lodcolumn misspecified.") if(missing(repl)) repl <- 1:nrow(x[[1]]) else if(!check_rowindex(repl, x[[1]])) stop("repl misspecified.") cl <- class(x) x <- lapply(x, function(a,b,d) unclass(a)[b,d,drop=FALSE], repl, lodcolumn) class(x) <- cl for(i in seq(along=att)) { if(names(att)[i] == "dim" || length(grep("names", names(att)[i]))>0) next attr(x, names(att)[i]) <- att[[i]] } x } # subset.scantwoperm using [,] `[.scantwoperm` <- function(x, repl, lodcolumn) subset.scantwoperm(x, repl, lodcolumn) # end of summary.scantwo.R qtl/R/read.cross.mm.R0000644000176200001440000003155213626261114014061 0ustar liggesusers###################################################################### # # read.cross.mm.R # # copyright (c) 2000-2020, Karl W Broman # last modified Feb, 2020 # first written Aug, 2000 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.mm, read.maps.mm # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.mm: read data from an experimental cross in mapmaker # format. # # We need two files: a "raw" file containing the genotype and # phenotype data and a "map" file containing the chromosomes # assignments and (optionally) map positions. # # The map file contains two or three columns, separated by white # space, with the chromosome number, marker name (with markers in # order along the chromosomes) and (optionally) the map position. # ###################################################################### read.cross.mm <- function(dir,rawfile,mapfile,estimate.map=TRUE) { # create file names if(missing(mapfile)) stop("Missing mapfile.") if(missing(rawfile)) stop("Missing rawfile.") if(!missing(dir) && dir != "") { mapfile <- file.path(dir, mapfile) rawfile <- file.path(dir, rawfile) } # count lines in rawfile n.lines <- length(scan(rawfile, what=character(), skip=0, nlines=0, blank.lines.skip=FALSE,quiet=TRUE,sep="\n")) # read map file map <- read.table(mapfile,header=FALSE,colClasses="character",blank.lines.skip=FALSE,stringsAsFactors=TRUE) fixmap <- TRUE if(ncol(map) == 1) stop("Map file should contain the markers' chromosome IDs.") if(ncol(map) > 3) { # special maps format maps <- read.maps.mm(mapfile) chr <- rep(names(maps),sapply(maps,length)) markers <- unlist(lapply(maps,names)) includes.pos <- TRUE fixmap <- FALSE } if(fixmap) { # my map format: 2 or 3 column table # remove any rows lacking a chromosome ID o <- (1:nrow(map))[map[,1]==""] if(length(o) > 0) map <- map[-o,] # remove any leading *'s from the marker names g <- grep("^\\*",map[,2]) if(length(g) > 0) map[g,2] <- substr(map[g,2],2,nchar(map[g,2])) } # begin reading/parsing the genotype data cur.mar <- 0 cur.phe <- 0 NEW.symb <- c("1","2","3","4","5","0") OLD.symb <- c("A","H","B","D","C","-") flag <- 0 # rawdata <- scan(rawfile,what=character(),sep="\n", # blank.lines.skip=TRUE,quiet=TRUE) # for(i in 1:n.lines) { a <- scan(rawfile,what=character(),skip=i-1,nlines=1, blank.lines.skip=TRUE,quiet=TRUE) if(length(a) == 0) next if(length(grep("#", a[1])) != 0) next if(flag == 0) { flag <- 1 if(!is.na(match("intercross", a))) type <- "f2" else if(!is.na(match("backcross", a)) || !is.na(match("bc", a))) type <- "bc" else stop("File indicates invalid cross type: ", a[length(a)], ".") } else if(flag == 1) { flag <- 2 n.ind <- as.numeric(a[1]) n.mar <- as.numeric(a[2]) n.phe <- as.numeric(a[3]) cat(" --Read the following data:\n") cat("\tType of cross: ", type, "\n") cat("\tNumber of individuals: ", n.ind, "\n") cat("\tNumber of markers: ", n.mar, "\n") cat("\tNumber of phenotypes: ", n.phe, "\n") # if there's a set of "symbols" for non-standard symbols in # the file, use them. if(length(a) > 3 && ("symbols" %in% a)) { o <- match("symbols",a) b <- a[-(1:o)] infile.symb <- substring(b,1,1) std.symb <- substring(b,3,3) wh <- rep(0,length(std.symb)) fixed <- rep(0,length(OLD.symb)) for(j in 1:length(std.symb)) if(std.symb[j] %in% OLD.symb) wh[j] <- match(std.symb[j],OLD.symb) for(j in 1:length(std.symb)) if(wh[j] != 0) { OLD.symb[wh[j]] <- infile.symb[j] fixed[wh[j]] <- 1 } temp <- table(OLD.symb) if(any(temp>1)) { for(j in names(temp)[temp>1]) { o <- OLD.symb==j & fixed==0 if(any(o)) OLD.symb[o] <- paste(OLD.symb[o]," ") } } } marnames <- rep("", n.mar) geno <- matrix(0,ncol=n.mar,nrow=n.ind) if(n.phe == 0) { pheno <- matrix(1:n.ind,ncol=1) phenames <- c("number") } else { pheno <- matrix(0,ncol=n.phe,nrow=n.ind) phenames <- rep("", n.phe) } } else { if(substring(a[1],1,1) == "*") { cur.mar <- cur.mar+1 cur.row <- 1 if(cur.mar > n.mar) { # now reading phenotypes cur.phe <- cur.phe+1 if(cur.phe > n.phe) next phenames[cur.phe] <- substring(a[1],2) if(length(a) > 1) { p <- a[-1] p[p=="-"] <- NA n <- length(p) oldna <- is.na(p) numerp <- suppressWarnings(as.numeric(p)) newna <- is.na(numerp) wh <- !oldna & newna if(any(wh)) { droppedasmissing <- unique(p[wh]) if(length(droppedasmissing) > 1) { themessage <- paste("The values", paste("\"", droppedasmissing, "\"", sep="", collapse=" ")) themessage <- paste(themessage, " for phenotype \"", phenames[cur.phe], "\" were", sep="") } else { themessage <- paste("The value \"", droppedasmissing, "\" ", sep="") themessage <- paste(themessage, " for phenotype \"", phenames[cur.phe], "\" was", sep="") } themessage <- paste(themessage, "interpreted as missing.") warning(themessage) } pheno[cur.row+(0:(n-1)),cur.phe] <- numerp } else n <- 0 ## ? cur.row <- cur.row + n } else { # reading genotypes marnames[cur.mar] <- substring(a[1],2) if(length(a) > 1) { g <- paste(a[-1],collapse="") h <- g <- unlist(strsplit(g,"")) for(j in seq(along=NEW.symb)) { if(any(h==OLD.symb[j])) g[h==OLD.symb[j]] <- NEW.symb[j] } n <- length(g) geno[cur.row+(0:(n-1)),cur.mar] <- as.numeric(g) } else n <- 0 cur.row <- cur.row + n } } else { # continuation lines if(cur.mar > n.mar) { # now reading phenotypes a[a=="-"] <- NA n <- length(a) pheno[cur.row+(0:(n-1)),cur.phe] <- as.numeric(a) cur.row <- cur.row + n } else { g <- paste(a,collapse="") h <- g <- unlist(strsplit(g,"")) for(j in seq(along=NEW.symb)) { if(any(h==OLD.symb[j])) g[h==OLD.symb[j]] <- NEW.symb[j] } n <- length(g) geno[cur.row+(0:(n-1)),cur.mar] <- as.numeric(g) cur.row <- cur.row + n } } # end continuation line } # end non-intro line } dimnames(pheno) <- list(NULL, phenames) # done reading the raw file if(fixmap) { # my map format: 2 or 3 column table # parse map file if(ncol(map) == 3) { includes.pos <- TRUE # make positions numeric pos <- as.numeric(map[,3]) } else includes.pos <- FALSE chr <- as.character(map[,1]) markers <- map[,2] # reorder markers? if(all(chr %in% c(1:999,"X","x"))) { # 1...19 + X tempchr <- chr tempchr[chr=="X" | chr=="x"] <- 1000 tempchr <- as.numeric(tempchr) if(includes.pos) neworder <- order(tempchr, pos) else neworder <- order(tempchr) } else { # prevent reordering of chromosomes tempchr <- factor(chr, levels=unique(chr)) if(includes.pos) neworder <- order(tempchr, pos) else neworder <- order(tempchr) } chr <- chr[neworder] if(includes.pos) pos <- pos[neworder] markers <- markers[neworder] } Geno <- vector("list",length(unique(chr))) names(Geno) <- unique(chr) for(i in unique(chr)) { mar <- markers[chr == i] if(fixmap) { # my map format: 2 or 3 column table # create map if(includes.pos) { map <- pos[chr == i] # reorder markers? if(any(diff(map)<0)) { o <- order(map) map <- map[o] mar <- mar[o] } } else map <- seq(0,by=5,length=length(mar)) names(map) <- mar } else map <- maps[[i]] # pull out genotype data o <- match(mar,marnames) if(any(is.na(o))) stop("Cannot find markers in genotype data: ", paste(mar[is.na(o)],collapse=" "), ".",sep="") if(length(o)==1) data <- matrix(geno[,o],ncol=1) else data <- geno[,o] # add marker names to data colnames(data) <- mar # changes 0's to NA's data[!is.na(data) & data==0] <- NA Geno[[i]] <- list(data=data,map=map) if(i=="X" || i=="x") class(Geno[[i]]) <- "X" else class(Geno[[i]]) <- "A" } cross <- list(geno=Geno,pheno=pheno) class(cross) <- c(type,"cross") if(estimate.map && !includes.pos) estmap <- TRUE else estmap <- FALSE cross$pheno <- as.data.frame(cross$pheno, stringsAsFactors=TRUE) # return cross + indicator of whether to run est.map list(cross,estmap) } ###################################################################### # # read.maps.mm: Read genetic map for a special Mapmaker format # Written by Brian S Yandell; modified by Karl W Broman # ###################################################################### read.maps.mm <- function( mapsfile ) { if (missing(mapsfile)) stop("Missing mapsfile.") ## find where everything is f <- scan(mapsfile, what = "", blank.lines.skip = FALSE, sep = "\n", quiet = TRUE) start <- pmatch( paste( "*", c("OrderInfo","Classes","Chromosomes", "Assignments and Placements" ), ":", sep = "" ), f ) ## marker names f <- scan( mapsfile, what = c("",rep(0,9)), skip = start[1], nlines = start[2] - start[1] - 1, blank.lines.skip = FALSE, quiet = TRUE) markers <- substring( f[ seq( 1, length( f ), by = 10 ) ], 2 ) ## distances f <- scan( mapsfile, what = "", skip = start[3], nlines = start[4] - start[3] - 1, blank.lines.skip = FALSE, quiet = TRUE) chr <- grep( "^\\*", f) chrom <- substring( f[chr], 2 ) nmark <- as.integer( f[ 1 + chr ] ) chr <- c( chr[-1], 1 + length( f )) lo <- chr - 2 * nmark + 2 hi <- chr - nmark map <- list() imark <- c( 0, cumsum( nmark )) for( i in seq( along = chrom )) { tmp <- cumsum( c(0,imf.h(as.numeric( f[ lo[i]:hi[i] ] )))) names( tmp ) <- markers[ imark[i] + seq( nmark[i] ) ] map[[ chrom[i] ]] <- tmp } map } # end of read.cross.mm.R qtl/R/stepwiseqtl.R0000644000176200001440000011535714100605652013775 0ustar liggesusers###################################################################### # stepwiseqtl.R # # copyright (c) 2007-2021, Karl W Broman # last modified Mar, 2021 # first written Nov, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: stepwiseqtl, calc.plod, countqtlterms, calc.penalties, # checkStepwiseqtlStart # ###################################################################### ###################################################################### # stepwiseqtl # # perform forward and backward selection to identify multiple QTL # # cross: cross object # chr: chromosomes to consider # pheno.col: phenotype column # qtl (Optional) If given, qtl object used at start of # forward selection. If missing, we start at the null # model. # formula If given, formula used with the qtl object for the model # at the start of forward selection # max.qtl: maximum no. QTL in forward selection # covar: data.frame with covariates (strictly additive at this point) # method: imputation or Haley-Knott regression # incl.markers: If TRUE, include marker positions in scan; if FALSE, # just use the grid # refine.locations: If TRUE, refine the QTL positions at each step # additive.only: If TRUE, don't scan for interactions # scan.pairs: If TRUE, do a pairscan at each step # penalties: Vector with 3 values: the penalties on main effects # followed by the heavy and light interaction penalties. # (if missing, we use default values derived via # simulation) # keeplodprofile If TRUE, perform one last pass of refineqtl and save # the LOD profiles. # keeptrace If TRUE, retain the QTL locations, model formula and pLOD # for the best model from each step of forward and backward # selection as an attribute in the output # verbose: If TRUE, print a bunch of tracing information ###################################################################### stepwiseqtl <- function(cross, chr, pheno.col=1, qtl, formula, max.qtl=10, covar=NULL, method=c("imp", "hk"), model=c("normal", "binary"), incl.markers=TRUE, refine.locations=TRUE, additive.only=FALSE, scan.pairs=FALSE, penalties, keeplodprofile=TRUE, keeptrace=FALSE, verbose=TRUE, tol=1e-4, maxit=1000, require.fullrank=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr) if(missing(qtl)) qtl <- NULL if(missing(formula)) formula <- NULL method <- match.arg(method) model <- match.arg(model) # force covar to be a data frame if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(!missing(penalties)) { if(is.matrix(penalties)) { penalties <- penalties[1,] warning("penalties should be a vector; only the first row will be used") } if(length(penalties)==6) { # X-chr-specific penalties chr_type <- vapply(cross$geno, chrtype, "") if(!all(chr_type=="A")) { if(scan.pairs) warning("scan.pairs=TRUE not implemented X-chr specific penalties; ignored.") return(stepwiseqtlX(cross, chrnames(cross), pheno.col=pheno.col, qtl=qtl, formula=formula, max.qtl=max.qtl, k_f=3, stop.rule=0, covar=covar, method=method, model=model, incl.markers=incl.markers, refine.locations=refine.locations, additive.only=additive.only, penalties=penalties, keeplodprofile=keeplodprofile, keeptrace=keeptrace, verbose=verbose, tol=tol, maxit=maxit, require.fullrank=require.fullrank)) } penalties <- penalties[c(1,3,4)] # just the autosomal penalties } } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } chr_type <- sapply(cross$geno, chrtype) if(any(chr_type=="X")) { Xadjustment <- scanoneXnull(crosstype(cross), getsex(cross), attributes(cross)) forceXcovar <- Xadjustment$adjustX Xcovar <- Xadjustment$sexpgmcovar } else forceXcovar <- FALSE if(!is.null(qtl)) { # start f.s. at somewhere other than the null if( !inherits(qtl, "qtl") ) stop("The qtl argument must be an object of class \"qtl\".") # check that chromosomes were retained, otherwise give error m <- is.na(match(qtl$chr, names(cross$geno))) if(any(m)) { wh <- qtl$chr[m] if(length(wh) > 1) stop("Chromosomes ", paste(wh, collapse=", "), " (in QTL object) not in cross object.") else stop("Chromosome ", wh, " (in QTL object) not in cross object.") } if(is.null(formula)) { # create a formula with all covariates and all QTL add've if(!is.null(covar)) formula <- paste("y ~ ", paste(names(covar), collapse="+"), "+") else formula <- "y ~ " formula <- paste(formula, paste(paste("Q", 1:length(qtl$chr), sep=""), collapse="+")) } else { temp <- checkStepwiseqtlStart(qtl, formula, covar) qtl <- temp$qtl formula <- temp$formula } startatnull <- FALSE } else { if(!is.null(formula)) warning("formula ignored if qtl is not provided.") startatnull <- TRUE } # revise names in qtl object if(!startatnull) qtl$name <- qtl$altname # check that we have the right stuff for the selected method if(method=="imp") { if(!("draws" %in% names(cross$geno[[1]]))) { if("prob" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("You need to first run sim.geno.") } } else { if(!("prob" %in% names(cross$geno[[1]]))) { if("draws" %in% names(cross$geno[[1]])) { warning("The cross doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("You need to first run calc.genoprob.") } } if(method=="imp") qtlmethod <- "draws" else qtlmethod <- "prob" if(!is.null(qtl) && qtl$n.ind != nind(cross)) { map <- attr(qtl, "map") # save map warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") attr(qtl, "map") <- map } if(!is.null(qtl) && method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { map <- attr(qtl, "map") # save map warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") attr(qtl, "map") <- map } # check that qtl object matches the method if(!startatnull) { if(method=="imp" && !("geno" %in% names(qtl))) stop("The qtl object doesn't contain imputations; re-run makeqtl with what=\"draws\".") else if(method=="hk" && !("prob" %in% names(qtl))) stop("The qtl object doesn't contain QTL genotype probabilities; re-run makeqtl with what=\"prob\".") } # check phenotypes and covariates; drop ind'ls with missing values if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("stepwiseqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") pheno <- cross$pheno[,pheno.col] if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) hasmissing <- rowSums(is.na(phcovar)) > 0 if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { pheno <- pheno[!hasmissing] cross <- subset(cross, ind=!hasmissing) if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] if(forceXcovar) Xcovar <- Xcovar[!hasmissing,,drop=FALSE] if(!startatnull) { if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else { for(i in seq(along=qtl$prob)) qtl$prob[[i]] <- qtl$prob[[i]][!hasmissing,,drop=FALSE] } qtl$n.ind <- sum(!hasmissing) } } if(max.qtl < 1) stop("Need max.qtl > 0 if we are to scan for qtl") if(is.null(covar)) { lod0 <- 0 if(startatnull) firstformula <- y~Q1 else firstformula <- formula } else { nullformula <- as.formula(paste("y~", paste(names(covar), collapse="+"))) tempqtl <- makeqtl(cross, chrnames(cross)[1], 0, what=ifelse(method=="imp", "draws", "prob")) fit <- fitqtl(cross, pheno.col, tempqtl, covar=covar, formula=nullformula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod0 <- fit$result.full[1,4] if(startatnull) firstformula <- as.formula(paste("y~", paste(names(covar), collapse="+"), "+", "Q1")) else firstformula <- formula } # penalties cross.type <- crosstype(cross) if(missing(penalties)) { if(cross.type=="f2") { penalties <- c(3.52, 4.28, 2.69) } else if(cross.type=="bc") { penalties <- c(2.69, 2.62, 1.19) } else stop("No default penalties available for cross type ", cross.type) } else if(length(penalties) != 3) { if(length(penalties)==1) { if(additive.only) penalties <- c(penalties,Inf,Inf) else stop("You must include a penalty for interaction terms.") } else { if(length(penalties)==2) penalties <- penalties[c(1,2,2)] else { warning("penalties should have length 3") penalties <- penalties[1:3] } } } if(verbose > 2) verbose.scan <- TRUE else verbose.scan <- FALSE curbest <- NULL curbestplod <- 0 # initial scan : either 1d or 2d if(verbose) cat(" -Initial scan\n") if(startatnull) { if(forceXcovar) { if(is.null(covar)) covar.w.X <- Xcovar else covar.w.X <- cbind(covar, Xcovar) } else covar.w.X <- covar if(additive.only || max.qtl == 1 || !scan.pairs) { suppressWarnings(out <- scanone(cross, pheno.col=pheno.col, method=method, model=model, addcovar=covar.w.X)) lod <- max(out[,3], na.rm=TRUE) if(verbose) cat("initial lod: ", lod, "\n") curplod <- calc.plod(lod, c(1,0,0), penalties=penalties) wh <- which(!is.na(out[,3]) & out[,3]==lod) if(length(wh) > 1) wh <- sample(wh, 1) qtl <- makeqtl(cross, as.character(out[wh,1]), out[wh,2], "Q1", what=qtlmethod) formula <- firstformula n.qtl <- 1 } else { suppressWarnings(out <- scantwo(cross, pheno.col=pheno.col, method=method, model=model, incl.markers=incl.markers, addcovar=covar.w.X, verbose=verbose.scan)) lod <- out$lod lod1 <- max(diag(lod), na.rm=TRUE) plod1 <- calc.plod(lod1, c(1,0,0), penalties=penalties) loda <- max(lod[upper.tri(lod)], na.rm=TRUE) ploda <- calc.plod(loda, c(2,0,0), penalties=penalties) lodf <- max(lod[lower.tri(lod)], na.rm=TRUE) plodf <- calc.plod(lodf, c(2,0,1), penalties=penalties) if(plod1 > ploda && plod1 > plodf) { wh <- which(!is.na(diag(lod)) & diag(lod) == lod1) if(length(wh) > 1) wh <- sample(wh, 1) m <- out$map[wh,] qtl <- makeqtl(cross, as.character(m[1,1]), m[1,2], "Q1", what=qtlmethod) formula <- firstformula n.qtl <- 1 lod <- lod1 curplod <- plod1 } else if(ploda > plodf) { temp <- max(out, what="add") if(nrow(temp) > 1) temp <- temp[sample(1:nrow(temp),1),] qtl <- makeqtl(cross, c(as.character(temp[1,1]), as.character(temp[1,2])), c(temp[1,3], temp[1,4]), c("Q1","Q2"), what=qtlmethod) formula <- as.formula(paste(deparseQTLformula(firstformula), "+Q2", sep="")) curplod <- ploda lod <- loda n.qtl <- 2 } else { temp <- max(out, what="full") if(nrow(temp) > 1) temp <- temp[sample(1:nrow(temp),1),] qtl <- makeqtl(cross, c(as.character(temp[1,1]), as.character(temp[1,2])), c(temp[1,3], temp[1,4]), c("Q1","Q2"), what=qtlmethod) formula <- as.formula(paste(deparseQTLformula(firstformula), "+Q2+Q1:Q2", sep="")) curplod <- plodf lod <- lodf n.qtl <- 2 } } } # start at null else { if(verbose) cat(" ---Starting at a model with", length(qtl$chr), "QTL\n") if(refine.locations) { if(verbose) cat(" ---Refining positions\n") rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") } qtl <- rqtl } fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod(lod, countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) attr(qtl, "pLOD") <- curplod n.qtl <- length(qtl$chr) } attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- curplod if(curplod > 0) { curbest <- qtl curbestplod <- curplod if(verbose) cat("** new best ** (pLOD increased by ", round(curplod, 4), ")\n", sep="") } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod class(temp) <- c("compactqtl", "list") thetrace <- list("0"=temp) } if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep="@"), "\n") # start stepwise search i <- 0 while(n.qtl < max.qtl) { i <- i+1 if(verbose) { cat(" -Step", i, "\n") cat(" ---Scanning for additive qtl\n") } out <- addqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) curlod <- max(out[,3], na.rm=TRUE) wh <- which(!is.na(out[,3]) & out[,3]==curlod) if(length(wh) > 1) wh <- sample(wh,1) curqtl <- addtoqtl(cross, qtl, as.character(out[wh,1]), out[wh,2], paste("Q", n.qtl+1, sep="")) curformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, sep="")) curlod <- curlod + lod curplod <- calc.plod(curlod, countqtlterms(curformula, ignore.covar=TRUE), penalties=penalties) if(verbose) cat(" plod =", curplod, "\n") curnqtl <- n.qtl+1 if(!additive.only) { for(j in 1:n.qtl) { if(verbose) cat(" ---Scanning for QTL interacting with Q", j, "\n", sep="") thisformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, "+Q", j, ":Q", n.qtl+1, sep="")) out <- addqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=thisformula, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar, require.fullrank=require.fullrank) thislod <- max(out[,3], na.rm=TRUE) wh <- which(!is.na(out[,3]) & out[,3]==thislod) if(length(wh) > 1) wh <- sample(wh,1) thisqtl <- addtoqtl(cross, qtl, as.character(out[wh,1]), out[wh,2], paste("Q", n.qtl+1, sep="")) thislod <- thislod + lod thisplod <- calc.plod(thislod, countqtlterms(thisformula, ignore.covar=TRUE), penalties=penalties) if(verbose) cat(" plod =", thisplod, "\n") if(thisplod > curplod) { curformula <- thisformula curplod <- thisplod curlod <- thislod curqtl <- thisqtl curnqtl <- n.qtl+1 } } if(n.qtl > 1) { if(verbose) cat(" ---Look for additional interactions\n") temp <- addint(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, qtl.only=TRUE, verbose=verbose.scan, require.fullrank=require.fullrank) if(!is.null(temp)) { thislod <- max(temp[,3], na.rm=TRUE) wh <- which(!is.na(temp[,3]) & temp[,3] == thislod) if(length(wh) > 1) wh <- sample(wh, 1) thisformula <- as.formula(paste(deparseQTLformula(formula), "+", rownames(temp)[wh])) thislod <- thislod + lod thisplod <- calc.plod(thislod, countqtlterms(thisformula, ignore.covar=TRUE), penalties=penalties) if(verbose) cat(" plod =", thisplod, "\n") if(thisplod > curplod) { curformula <- thisformula curplod <- thisplod curlod <- thislod curqtl <- qtl curnqtl <- n.qtl } } } if(scan.pairs) { if(verbose) cat(" ---Scan for an additional pair\n") out <- addpair(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, incl.markers=incl.markers, verbose=verbose.scan, forceXcovar=forceXcovar) thelod <- out$lod loda <- max(thelod[upper.tri(thelod)], na.rm=TRUE) ploda <- calc.plod(loda+lod, c(2,0,0,0)+countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) lodf <- max(thelod[lower.tri(thelod)], na.rm=TRUE) plodf <- calc.plod(lodf+lod, c(2,0,1,1)+countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) if(verbose) { cat(" ploda =", ploda, "\n") cat(" plodf =", plodf, "\n") } if(ploda > curplod && loda > plodf) { temp <- max(out, what="add") if(nrow(temp) > 1) temp <- temp[sample(1:nrow(temp),1),] curqtl <- addtoqtl(cross, qtl, c(as.character(temp[1,1]), as.character(temp[1,2])), c(temp[1,3], temp[1,4]), paste("Q", n.qtl+1:2, sep="")) curformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, "+Q", n.qtl+2, sep="")) curplod <- ploda lod <- loda+lod curnqtl <- n.qtl+2 } else if(plodf > curplod) { temp <- max(out, what="full") if(nrow(temp) > 1) temp <- temp[sample(1:nrow(temp),1),] curqtl <- addtoqtl(cross, qtl, c(as.character(temp[1,1]), as.character(temp[1,2])), c(temp[1,3], temp[1,4]), paste("Q", n.qtl+1:2, sep="")) curformula <- as.formula(paste(deparseQTLformula(formula), "+Q", n.qtl+1, "+Q", n.qtl+2, "+Q", n.qtl+1, ":Q", n.qtl+2, sep="")) curplod <- plodf lod <- lodf+lod curnqtl <- n.qtl+2 } } } qtl <- curqtl n.qtl <- curnqtl attr(qtl, "formula") <- deparseQTLformula(curformula) attr(qtl, "pLOD") <- curplod formula <- curformula lod <- curlod if(refine.locations) { if(verbose) cat(" ---Refining positions\n") rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") qtl <- rqtl fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod(lod, countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) attr(qtl, "pLOD") <- curplod } } if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep="@"), "\n") if(curplod > curbestplod) { if(verbose) cat("** new best ** (pLOD increased by ", round(curplod - curbestplod, 4), ")\n", sep="") curbest <- qtl curbestplod <- curplod } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod class(temp) <- c("compactqtl", "list") temp <- list(temp) names(temp) <- i thetrace <- c(thetrace, temp) } if(n.qtl >= max.qtl) break } if(verbose) cat(" -Starting backward deletion\n") while(n.qtl > 1) { i <- i+1 out <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=TRUE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar)$result.drop formulas <- attr(out, "formulas") lods <- attr(out, "lods") rn <- rownames(out) # ignore things with covariates wh <- c(grep("^[Qq][0-9]+$", rn), grep("^[Qq][0-9]+:[Qq][0-9]+$", rn)) out <- out[wh,,drop=FALSE] formulas <- formulas[wh] lods <- lods[wh] # need to calculate penalized LOD scores here plod <- rep(NA, length(lods)) for(modi in seq(along=plod)) plod[modi] <- calc.plod(lods[modi], countqtlterms(formulas[modi], ignore.covar=TRUE), penalties=penalties) maxplod <- max(plod, na.rm=TRUE) wh <- which(!is.na(plod) & plod==maxplod) if(length(wh) > 1) wh <- sample(wh, 1) todrop <- rownames(out)[wh] if(verbose) cat(" ---Dropping", todrop, "\n") if(length(grep(":", todrop)) > 0) { # dropping an interaction theterms <- attr(terms(formula), "factors") wh <- colnames(theterms)==todrop if(!any(wh)) stop("Confusion about what interation to drop!") theterms <- colnames(theterms)[!wh] formula <- as.formula(paste("y~", paste(theterms, collapse="+"))) } else { numtodrop <- as.numeric(substr(todrop, 2, nchar(todrop))) theterms <- attr(terms(formula), "factors") cn <- colnames(theterms) g <- c(grep(paste("^[Qq]", numtodrop, "$", sep=""), cn), grep(paste("^[Qq]", numtodrop, ":", sep=""), cn), grep(paste(":[Qq]", numtodrop, "$", sep=""), cn)) cn <- cn[-g] formula <- as.formula(paste("y~", paste(cn, collapse="+"))) if(n.qtl > numtodrop) { for(j in (numtodrop+1):n.qtl) formula <- reviseqtlnuminformula(formula, j, j-1) } qtl <- dropfromqtl(qtl, index=numtodrop) qtl$name <- qtl$altname <- paste("Q", 1:qtl$n.qtl, sep="") n.qtl <- n.qtl - 1 } # call fitqtl again, just in case fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod(lod, countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) if(verbose) cat(" no.qtl = ", n.qtl, " pLOD =", curplod, " formula:", deparseQTLformula(formula), "\n") if(verbose > 1) cat(" qtl:", paste(qtl$chr, round(qtl$pos,1), sep=":"), "\n") attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- curplod if(refine.locations) { if(verbose) cat(" ---Refining positions\n") if(!is.null(qtl)) { rqtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=FALSE, forceXcovar=forceXcovar) if(any(rqtl$pos != qtl$pos)) { # updated positions if(verbose) cat(" --- Moved a bit\n") qtl <- rqtl fit <- fitqtl(cross, pheno.col, qtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, tol=tol, maxit=maxit, forceXcovar=forceXcovar) lod <- fit$result.full[1,4] - lod0 if(require.fullrank && attr(fit, "matrix.rank") < attr(fit, "matrix.ncol")) lod <- 0 curplod <- calc.plod(lod, countqtlterms(formula, ignore.covar=TRUE), penalties=penalties) attr(qtl, "pLOD") <- curplod } } } if(curplod > curbestplod) { if(verbose) cat("** new best ** (pLOD increased by ", round(curplod - curbestplod, 4), ")\n", sep="") curbestplod <- curplod curbest <- qtl } if(keeptrace) { temp <- list(chr=qtl$chr, pos=qtl$pos) attr(temp, "formula") <- deparseQTLformula(formula) attr(temp, "pLOD") <- curplod class(temp) <- c("compactqtl", "list") temp <- list(temp) names(temp) <- i thetrace <- c(thetrace, temp) } } # re-form the qtl if(!is.null(curbest)) { chr <- curbest$chr pos <- curbest$pos o <- order(factor(chr, levels=names(cross$geno)), pos) qtl <- makeqtl(cross, chr[o], pos[o], what=qtlmethod) # need to redo numbering in formula formula <- as.formula(attr(curbest, "formula")) if(length(chr) > 1) { n.qtl <- length(chr) for(i in 1:n.qtl) formula <- reviseqtlnuminformula(formula, i, n.qtl+i) for(i in 1:n.qtl) formula <- reviseqtlnuminformula(formula, n.qtl+o[i], i) } if(keeplodprofile) { if(verbose) cat(" ---One last pass through refineqtl\n") qtl <- refineqtl(cross, pheno.col=pheno.col, qtl=qtl, covar=covar, formula=formula, method=method, model=model, verbose=verbose.scan, incl.markers=incl.markers, keeplodprofile=TRUE, forceXcovar=forceXcovar) } attr(qtl, "formula") <- deparseQTLformula(formula) attr(qtl, "pLOD") <- attr(curbest, "pLOD") curbest <- qtl } else { curbest <- numeric(0) class(curbest) <- "qtl" attr(curbest,"pLOD") <- 0 } if(keeptrace) attr(curbest, "trace") <- thetrace attr(curbest, "formula") <- deparseQTLformula(attr(curbest, "formula"), TRUE) attr(curbest, "penalties") <- penalties curbest } ###################################################################### # check initial qtl model for appropriateness ###################################################################### checkStepwiseqtlStart <- function(qtl, formula, covar=NULL) { if(is.character(formula)) formula <- as.formula(formula) formula <- checkformula(formula, qtl$altname, colnames(covar)) theterms <- attr(terms(formula), "factors")[-1,,drop=FALSE] rn <- rownames(theterms) # make sure that all covariates in covar exist in the formula if(!is.null(covar)) { covarnam <- colnames(covar) m <- is.na(match(covarnam, rn)) if(any(m)) { toadd <- covarnam[m] warning("Adding ", paste(toadd, collapse="+"), " to formula") formula <- as.formula(paste(deparseQTLformula(formula), "+", paste(toadd, collapse="+"), sep="")) theterms <- attr(terms(formula), "factors")[-1,,drop=FALSE] rn <- rownames(theterms) } # make sure there are no QTL:covariate interactions theqtl <- grep("^Q[0-9]+$", rn) thecovar <- seq(along=rn)[-theqtl] if(any(apply(theterms[thecovar,,drop=FALSE], 1, sum)>1)) stop("We can't yet handle QTL:covariate or covariate:covariate interactions") } # make sure that any QTL in formula exist in object theqtl <- grep("^Q[0-9]+$", rn) thecovar <- seq(along=rn)[-theqtl] qtlindex <- as.numeric(substr(rn[theqtl], 2, nchar(rn[theqtl]))) wh <- qtlindex < 0 | qtlindex > length(qtl$chr) if(any(wh)) stop("QTL ", paste(rn[theqtl][wh], collapse=" "), " not in qtl object") # make sure that there are not any extraneous terms if(length(thecovar) > 0) { if(is.null(covar)) stop("Extraneous terms in formula: ", paste(rn[thecovar], collapse=" ")) else { wh <- is.na(match(rn[thecovar], colnames(covar))) if(any(wh)) stop("Extraneous terms in formula: ", paste(rn[thecovar][wh], collapse=" ")) } } # if any QTL not referred to in formula, drop them from the QTL object todrop <- seq(along=qtl$chr)[-qtlindex] if(length(todrop) > 0) { oldnum <- seq(along=qtl$chr)[-todrop] newnum <- order(oldnum) formula <- reviseqtlnuminformula(formula, oldnum, newnum) qtl <- dropfromqtl(qtl, todrop) } return(list(qtl=qtl, formula=as.formula(formula))) } ###################################################################### # penalized LOD score ###################################################################### calc.plod <- function(lod, nterms, type=c("f2","bc"), penalties) { nterms <- nterms[1:3] if(any(penalties==Inf & nterms > 0)) return(-Inf) as.numeric(lod - sum((nterms*penalties)[nterms > 0])) } ###################################################################### # count terms in a model, for use by plod ###################################################################### countqtlterms <- function(formula, ignore.covar=TRUE) { if(is.character(formula)) formula <- as.formula(formula) factors <- attr(terms(formula), "factors")[-1,,drop=FALSE] if(any(factors > 1)) { warning("some formula terms > 1; may be a problem with the formula:\n ", deparseQTLformula(formula)) factors[factors > 1] <- 1 } nterm <- apply(factors, 2, sum) if(any(nterm>2)) stop("Can't deal with higher-order interactions\n") # need to check for QTL x covariate interactions in here! if(ignore.covar) { cn <- colnames(factors) wh <- c(grep("^[Qq][0-9]+$", cn), grep("^[Qq][0-9]+:[Qq][0-9]+$", cn)) rn <- rownames(factors) wh2 <- c(grep("^[Qq][0-9]+$", rn), grep("^[Qq][0-9]+:[Qq][0-9]+$", rn)) factors <- factors[wh2,wh, drop=FALSE] } nterm <- apply(factors, 2, sum) nmain <- sum(nterm==1) if(all(nterm==1)) return(c(main=nmain, intH=0, intL=0, inttot=0)) n.int <- sum(nterm==2) if(n.int <=1) # 0 or 1 interactions, so no need to figure them out return(c(main=nmain, intH=0, intL=n.int, inttot=n.int)) factors <- factors[,nterm==2, drop=FALSE] wh <- apply(factors, 2, function(a) which(a==1)) u <- sort(unique(as.numeric(wh))) grp <- rep(NA, length(u)) names(grp) <- u ngrp <- 0 nint <- NULL for(i in 1:ncol(wh)) { thegrp <- grp[as.character(wh[,i])] if(all(!is.na(thegrp))) { nint[as.character(thegrp[1])] <- sum(nint[unique(as.character(thegrp))]) + 1 grp[grp==thegrp[1] | grp==thegrp[2]] <- thegrp[1] } else if(any(!is.na(thegrp))) { grp[as.character(wh[,i])] <- thegrp[!is.na(thegrp)] nint[as.character(thegrp[!is.na(thegrp)])] <- nint[as.character(thegrp[!is.na(thegrp)])] + 1 } else { ngrp <- ngrp+1 grp[as.character(wh[,i])] <- ngrp nint[as.character(ngrp)] <- 1 } } nint <- nint[as.character(unique(grp))] nL <- sum(nint>0) nH <- sum(nint)-nL c(main=nmain, intH=nH, intL=nL, inttot=n.int) } ###################################################################### # calculate penalties for pLOD using scantwo permutation results. ###################################################################### calc.penalties <- function(perms, alpha=0.05, lodcolumn) { if(missing(perms) || !inherits(perms, "scantwoperm")) stop("You must include permutation results from scantwo.") if("AA" %in% names(perms)) { # X-chr-specific penalties if(missing(lodcolumn)) lodcolumn <- NULL return(calc.penalties.X(perms, alpha, lodcolumn)) } if(missing(lodcolumn) || is.null(lodcolumn)) { if(is.matrix(perms[[1]]) && ncol(perms[[1]]) > 1) lodcolumn <- 1:ncol(perms[[1]]) else lodcolumn <- 1 } if(length(lodcolumn)>1) { result <- NULL for(i in seq(along=lodcolumn)) { temp <- calc.penalties(perms, alpha, lodcolumn[i]) result <- rbind(result, temp) } dimnames(result) <- list(colnames(perms[[1]])[lodcolumn], names(temp)) return(result) } if(is.matrix(perms[[1]]) && ncol(perms[[1]]) >1) { if(lodcolumn < 1 || lodcolumn > ncol(perms[[1]])) stop("lodcolumn misspecified") for(i in seq(along=perms)) perms[[i]] <- perms[[i]][,lodcolumn,drop=FALSE] } qu <- summary(perms, alpha=alpha) if(!("one" %in% names(qu))) stop("You need to re-run scantwo permutations with R/qtl version >= 1.09.") if(length(alpha)>1) { penalties <- cbind(qu[["one"]], qu[["int"]], qu[["fv1"]]-qu[["one"]]) colnames(penalties) <- c("main","heavy", "light") } else { penalties <- c(qu[["one"]], qu[["int"]], qu[["fv1"]]-qu[["one"]]) names(penalties) <- c("main","heavy", "light") } penalties } # end of stepwiseqtl.R qtl/R/scanone.R0000644000176200001440000012757014121105012013023 0ustar liggesusers##################################################################### # # scanone.R # # copyright (c) 2001-2020, Karl W Broman # last modified Feb, 2020 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Hao Wu (The Jackson Lab) wrote the imputation method # # Part of the R/qtl package # Contains: scanone, scanone.perm, scanone.perm.engine # ###################################################################### ###################################################################### # # scanone: scan genome, calculating LOD scores with single QTL model # (covariates are not allowed for models other than "normal" # and "binary") # ###################################################################### scanone <- function(cross, chr, pheno.col=1, model=c("normal","binary","2part","np"), method=c("em","imp","hk","ehk","mr","mr-imp","mr-argmax"), addcovar=NULL, intcovar=NULL, weights=NULL, use=c("all.obs", "complete.obs"), upper=FALSE, ties.random=FALSE, start=NULL, maxit=4000, tol=1e-4, n.perm, perm.Xsp=FALSE, perm.strata=NULL, verbose, batchsize=250, n.cluster=1, ind.noqtl) { if(batchsize < 1) stop("batchsize must be >= 1.") model <- match.arg(model) method <- match.arg(method) use <- match.arg(use) # in RIL, treat X chromomse like an autosome chr_type <- sapply(cross$geno, chrtype) crosstype <- crosstype(cross) if(any(chr_type=="X") && (crosstype == "risib" || crosstype == "riself")) for(i in which(chr_type=="X")) class(cross$geno[[i]]) <- "A" if(!missing(n.perm) && n.perm > 0 && n.cluster > 1) { cat(" -Running permutations via a cluster of", n.cluster, "nodes.\n") updateParallelRNG(n.cluster) scanonePermInParallel <- function(n.perm, cross, chr, pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, perm.Xsp, perm.strata, batchsize) scanone(cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol, n.perm=n.perm, perm.Xsp=perm.Xsp, perm.strata=perm.strata, batchsize=batchsize, n.cluster=0, verbose=FALSE) n.perm <- ceiling(n.perm/n.cluster) if(missing(chr)) chr <- names(cross$geno) if(Sys.info()[1] == "Windows") { # Windows doesn't support mclapply, but it's faster if available cl <- makeCluster(n.cluster) on.exit(stopCluster(cl)) operm <- clusterApply(cl, rep(n.perm, n.cluster), scanonePermInParallel, cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol, perm.Xsp=perm.Xsp, perm.strata=perm.strata, batchsize=batchsize) } else { operm <- mclapply(rep(n.perm, n.cluster), scanonePermInParallel, cross=cross, chr=chr, pheno.col=pheno.col, model=model, method=method, addcovar=addcovar, intcovar=intcovar, weights=weights, use=use, upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol, perm.Xsp=perm.Xsp, perm.strata=perm.strata, batchsize=batchsize, mc.cores=n.cluster) } for(j in 2:length(operm)) operm[[1]] <- c(operm[[1]], operm[[j]]) return(operm[[1]]) } # check perm.strat if(!missing(perm.strata) && !is.null(perm.strata)) { if(length(perm.strata) != nind(cross)) stop("perm.strata, if given, must have length = nind(cross) [", nind(cross), "]") } # individuals with no QTL effect if(missing(ind.noqtl)) ind.noqtl <- rep(FALSE, nind(cross)) else { if(method %in% c("mr", "mr-imp", "mr-argmax","ehk") || model %in% c("2part", "np")) { ind.noqtl <- rep(FALSE, nind(cross)) warning("ind.noqtl ignored for model=", model, ", method=", method) } else if(is.null(addcovar) && (!is.logical(ind.noqtl) || any(ind.noqtl))) { ind.noqtl <- rep(FALSE, nind(cross)) warning("ind.noqtl ignored when no additive covariates") } else if(!is.logical(ind.noqtl) || length(ind.noqtl) != nind(cross)) stop("ind.noqtl be a logical vector of length n.ind (", nind(cross), ")") } if(!missing(chr)) cross <- subset(cross, chr) if(missing(n.perm)) n.perm <- 0 if(missing(verbose)) { if(!missing(n.perm) && n.perm > 0) verbose <- TRUE else verbose <- FALSE } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") if(length(pheno.col)==1 && n.perm>=0) use <- "complete.obs" if(n.perm >= 0) { # not in the midst of a permutation test # If use="all.obs", check whether there are individuals missing some # phenotypes but not others. If not, act like "complete.obs". if(use=="all.obs" && length(pheno.col) > 1) { n.phe <- length(pheno.col) temp <- apply(cross$pheno[,pheno.col], 1, function(a) sum(is.na(a))) if(all(temp==0 | temp==n.phe)) use <- "complete.obs" } # If use="complete.obs", drop individuals with any missing phenotypes if(use=="complete.obs") { temp <- checkcovar(cross, pheno.col, addcovar, intcovar, perm.strata, ind.noqtl, weights, TRUE) cross <- temp[[1]] pheno <- temp[[2]] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] ind.noqtl <- temp[[8]] weights <- temp[[9]] } } # use all observations; not in a permutation test; different phenotypes have different sets of missing values # -> want to do in batches, but need to define batches by the pattern of missing data if(n.perm <= 0 && use=="all.obs" && length(pheno.col) > 1 && (method=="hk" || method=="imp") && model == "normal") { # drop individuals with missing covariates cross$pheno <- cbind(cross$pheno, rep(1, nind(cross))) temp <- checkcovar(cross, nphe(cross), addcovar, intcovar, perm.strata, ind.noqtl, weights, TRUE) cross <- temp[[1]] pheno <- cross$pheno[,pheno.col, drop=FALSE] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] ind.noqtl <- temp[[8]] weights <- temp[[9]] # determine the batches (defined by the pattern of missing data) patterns <- apply(pheno, 2, function(a) paste(!is.na(a), collapse=":")) upat <- unique(patterns) m <- match(patterns, upat) batches <- vector("list", length(upat)) upat <- lapply(strsplit(upat, ":"), function(a) as.logical(a)) for(i in seq(along=batches)) batches[[i]] <- pheno.col[m==i] # run scanone for one batch at a time out <- NULL for(i in seq(along=batches)) { if(!is.null(addcovar)) { if(!is.matrix(addcovar)) addcovar <- as.matrix(addcovar) tempac <- addcovar[upat[[i]],,drop=FALSE] } else tempac <- addcovar if(!is.null(intcovar)) { if(!is.matrix(intcovar)) intcovar <- as.matrix(intcovar) tempic <- intcovar[upat[[i]],,drop=FALSE] } else tempic <- intcovar temp <- scanone(subset(cross, ind=upat[[i]]), chr=chr, pheno.col=batches[[i]], model=model, method=method, addcovar=tempac, intcovar=tempic, weights=weights[upat[[i]]], use="complete.obs", upper=upper, ties.random=ties.random, start=start, maxit=maxit, tol=tol, n.perm=n.perm, perm.Xsp=perm.Xsp, perm.strata=perm.strata[upat[[i]]], verbose=verbose, batchsize=batchsize, n.cluster=n.cluster) if(is.null(out)) out <- temp else out <- cbind(out, temp) } # reorder LOD score columns and make sure that the names are correct colnames(out)[-(1:2)] <- colnames(cross$pheno)[unlist(batches)] out[,-(1:2)] <- out[,colnames(cross$pheno)[pheno.col]] colnames(out)[-(1:2)] <- colnames(cross$pheno)[pheno.col] return(out) } # multiple phenotype for methods except imp or hk with normal model if(length(pheno.col)>1 && n.perm <= 0 && (model != "normal" || (method!="imp" && method != "hk"))) { out <- scanone(cross, chr, pheno.col[1], model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, n.perm, perm.Xsp, perm.strata, verbose, batchsize, n.cluster=0) nc <- ncol(out)-2 cn <- colnames(out)[-(1:2)] for(i in 2:length(pheno.col)) out[,ncol(out)+1:nc] <- scanone(cross, chr, pheno.col[i], model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, n.perm, perm.Xsp, perm.strata, verbose, batchsize, n.cluster=0)[,-(1:2)] if(length(cn) > 1) colnames(out)[-(1:2)] <- paste(rep(cn,length(pheno.col)), rep(colnames(cross$pheno)[pheno.col], rep(nc,length(pheno.col))), sep=".") else colnames(out)[-(1:2)] <- colnames(cross$pheno)[pheno.col] return(out) } if(n.perm>0) { return(scanone.perm(cross, pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, n.perm, perm.Xsp, perm.strata, verbose, batchsize)) } if(n.perm < 0) { # in the midst of permutations if(use=="all.obs") { temp <- checkcovar(cross, pheno.col, addcovar, intcovar, perm.strata, ind.noqtl, weights, n.perm==-1) cross <- temp[[1]] pheno <- temp[[2]] addcovar <- temp[[3]] intcovar <- temp[[4]] n.addcovar <- temp[[5]] n.intcovar <- temp[[6]] perm.strata <- temp[[7]] ind.noqtl <- temp[[8]] weights <- temp[[9]] } else { pheno <- as.matrix(cross$pheno[,pheno.col]) if(is.null(addcovar)) n.addcovar <- 0 else n.addcovar <- ncol(addcovar) if(is.null(intcovar)) n.intcovar <- 0 else n.intcovar <- ncol(intcovar) } } n.chr <- nchr(cross) n.ind <- nind(cross) n.phe <- ncol(pheno) type <- crosstype(cross) is.bcs <- FALSE if(type == "bcsft") { cross.scheme <- attr(cross, "scheme") is.bcs <- (cross.scheme[2] == 0) } # fill in missing genotypes with imputed values if(n.perm==0) { # not in the midst of permutations if(method=="mr-argmax") cross <- fill.geno(cross,method="argmax") if(method=="mr-imp") cross <- fill.geno(cross,method="imp") } # weights for model="normal" if(model != "normal") { if(!is.null(weights) && !all(weights==1) && n.perm > -2) warning("weights used only for normal model.") } else { if(is.null(weights)) weights <- rep(1, nind(cross)) else if(length(weights) != nind(cross)) stop("weights should either be NULL or a vector of length n.ind") if(any(weights <= 0)) stop("weights should be entirely positive") weights <- sqrt(weights) } if(model=="binary") { if(method=="imp") { if(n.perm > -2) warning("Method imp not available for binary model; using em") method <- "em" } return(discan(cross, pheno, method, addcovar, intcovar, maxit, tol, verbose, n.perm > -2, ind.noqtl)) } else if(model=="2part") { if((n.addcovar > 0 || n.intcovar > 0) && n.perm > -2) warning("Covariates ignored for the two-part model.") if(method!="em") { if(n.perm > -2) warning("Only em method is available for the two-part model") method <- "em" } return(vbscan(cross, pheno.col, upper, method, maxit, tol)) } else if(model=="np") { if((n.addcovar > 0 || n.intcovar > 0) && n.perm > -2) warning("Covariates ignored for non-parametric interval mapping.") if(method!="em") { if(n.perm > -2) warning("Method argument ignored for non-parametric interval mapping.") method <- "em" } } # if non-parametric, convert phenotypes to ranks if(model=="np") { if(ties.random) { y <- pheno[!is.na(pheno)] y <- rank(y+runif(length(y))/(sd(y)*10^8)) pheno[!is.na(pheno)] <- y correct <- 1 } else { ties <- table(pheno) if(any(ties > 1)) { ties <- ties[ties>1] correct <- 1-sum(ties^3-ties)/(n.ind^3-n.ind) } else correct <- 1 pheno <- rank(pheno) } } results <- NULL # starting points for interval mapping if(method=="em" && model=="normal") { if(is.null(start)) std.start <- 1 else if(length(start)==1) std.start <- -1 else std.start <- 0 } # scan genome one chromosome at a time for(i in 1:n.chr) { chr_type <- chrtype(cross$geno[[i]]) if(chr_type=="X") { sexpgm <- getsex(cross) ac <- revisecovar(sexpgm,addcovar) if(!is.null(addcovar) && (nd <- attr(ac, "n.dropped")) > 0 && n.perm > -2) warning("Dropped ", nd, " additive covariates on X chromosome.") if(length(ac)==0) { n.ac <- 0 ac <- NULL } else n.ac <- ncol(ac) ic <- revisecovar(sexpgm,intcovar) if(!is.null(intcovar) && (nd <- attr(ic, "n.dropped")) > 0 && n.perm > -2) warning("Dropped ", nd, " interactive covariates on X chromosome.") if(length(ic)==0) { n.ic <- 0 ic <- NULL } else n.ic <- ncol(ic) } else { sexpgm <- NULL ac <- addcovar n.ac <- n.addcovar ic <- intcovar n.ic <- n.intcovar } # get genotype names gen.names <- getgenonames(type,chr_type,"full",sexpgm,attributes(cross)) n.gen <- length(gen.names) # starting values for interval mapping if(method=="em" && model=="normal") { this.start <- rep(0,n.gen+1) if(std.start == 0) { if(length(start) < n.gen+1) stop("Length of start argument should be 0, 1 or ", n.gen+1) this.start <- c(start[1:n.gen],start[length(start)]) } } # pull out reconstructed genotypes (mr) # or imputations (imp) # or genotype probabilities (em or hk) if(method=="mr" || method=="mr-imp" || method=="mr-argmax") { newgeno <- cross$geno[[i]]$data newgeno[is.na(newgeno)] <- 0 # discard partially informative genotypes if(type=="f2" || (type=="bcsft" && !is.bcs)) newgeno[newgeno>3] <- 0 if(type=="4way") newgeno[newgeno>4] <- 0 # revise X chromosome genotypes if(chr_type=="X" && (type %in% c("bc","f2","bcsft"))) newgeno <- reviseXdata(type, "full", sexpgm, geno=newgeno, cross.attr=attributes(cross)) n.pos <- ncol(newgeno) map <- cross$geno[[i]]$map if(is.matrix(map)) { marnam <- colnames(map) map <- map[1,] } else marnam <- names(map) } else if(method == "imp") { if(!("draws" %in% names(cross$geno[[i]]))) { # need to run sim.geno if(n.perm > -2) warning("First running sim.geno.") cross <- sim.geno(cross) } draws <- cross$geno[[i]]$draws n.pos <- ncol(draws) n.draws <- dim(draws)[3] # revise X chromosome genotypes if(chr_type=="X" && (type %in% c("bc","f2","bcsft"))) draws <- reviseXdata(type, "full", sexpgm, draws=draws, cross.attr=attributes(cross)) if("map" %in% names(attributes(cross$geno[[i]]$draws))) map <- attr(cross$geno[[i]]$draws,"map") else { stp <- attr(cross$geno[[i]]$draws, "step") oe <- attr(cross$geno[[i]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$draws))) stpw <- attr(cross$geno[[i]]$draws, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) { marnam <- colnames(map) map <- map[1,] } else marnam <- names(map) } else { if(!("prob" %in% names(cross$geno[[i]]))) { # need to run calc.genoprob if(n.perm > -2) warning("First running calc.genoprob.") cross <- calc.genoprob(cross) } genoprob <- cross$geno[[i]]$prob n.pos <- ncol(genoprob) # revise X chromosome genotypes if(chr_type=="X" && (type %in% c("bc","f2","bcsft"))) genoprob <- reviseXdata(type, "full", sexpgm, prob=genoprob, cross.attr=attributes(cross)) if("map" %in% names(attributes(cross$geno[[i]]$prob))) map <- attr(cross$geno[[i]]$prob,"map") else { stp <- attr(cross$geno[[i]]$prob, "step") oe <- attr(cross$geno[[i]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[i]]$prob))) stpw <- attr(cross$geno[[i]]$prob, "stepwidth") else stpw <- "fixed" map <- create.map(cross$geno[[i]]$map,stp,oe,stpw) } if(is.matrix(map)) { marnam <- colnames(map) map <- map[1,] } else marnam <- names(map) } # call the C function if(method == "mr" || method=="mr-imp" || method=="mr-argmax") z <- .C("R_scanone_mr", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.integer(newgeno), # genotype data as.double(ac), # additive covariates as.integer(n.ac), as.double(ic), # interactive covariates as.integer(n.ic), as.double(pheno), # phenotype data as.double(weights), # weights result=as.double(rep(0,n.pos)), PACKAGE="qtl") else if(method=="imp") { if(n.phe > batchsize) { firstcol <- 1 z <- NULL while(firstcol <= n.phe) { if(verbose > 2) cat("chr", names(cross$geno)[i], "phe", firstcol, "...\n") thiscol <- firstcol + 0:(batchsize-1) thiscol <- thiscol[thiscol <= n.phe] thisz <- .C("R_scanone_imp", as.integer(n.ind), as.integer(n.pos), as.integer(n.gen), as.integer(n.draws), as.integer(draws), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno[,thiscol]), as.integer(length(thiscol)), # number of phenotypes as.double(weights), result=as.double(rep(0,length(thiscol)*n.pos)), as.integer(ind.noqtl), # indicators of ind'l w/o QTL effects PACKAGE="qtl") firstcol <- firstcol + batchsize if(is.null(z)) { z <- thisz z$result <- matrix(ncol=n.phe, nrow=n.pos) } z$result[,thiscol] <- matrix(thisz$result, nrow=n.pos) } } else { z <- .C("R_scanone_imp", as.integer(n.ind), as.integer(n.pos), as.integer(n.gen), as.integer(n.draws), as.integer(draws), as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), as.integer(n.phe), # number of phenotypes as.double(weights), result=as.double(rep(0,n.phe*n.pos)), as.integer(ind.noqtl), # indicators of ind'l w/o QTL effects PACKAGE="qtl") } } else if(method=="hk") { # Haley-Knott regression if(n.phe > batchsize) { firstcol <- 1 z <- NULL while(firstcol <= n.phe) { if(verbose > 2) cat("chr", names(cross$geno)[i], "phe", firstcol, "...\n") thiscol <- firstcol + 0:(batchsize-1) thiscol <- thiscol[thiscol <= n.phe] thisz <- .C("R_scanone_hk", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), # additive covariates as.integer(n.ac), as.double(ic), # interactive covariates as.integer(n.ic), as.double(pheno[,thiscol]), # phenotype data as.integer(length(thiscol)), # number of phenotypes as.double(weights), result=as.double(rep(0,length(thiscol)*n.pos)), as.integer(ind.noqtl), # indicators of ind'l w/o QTL effects PACKAGE="qtl") firstcol <- firstcol + batchsize if(is.null(z)) { z <- thisz z$result <- matrix(ncol=n.phe, nrow=n.pos) } z$result[,thiscol] <- matrix(thisz$result, nrow=n.pos) } } else { z <- .C("R_scanone_hk", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), # additive covariates as.integer(n.ac), as.double(ic), # interactive covariates as.integer(n.ic), as.double(pheno), # phenotype data as.integer(n.phe), # number of phenotypes as.double(weights), result=as.double(rep(0,n.phe*n.pos)), as.integer(ind.noqtl), # indicators of ind'l w/o QTL effects PACKAGE="qtl") } } else if(method=="ehk") { # extended Haley-Knott method z <- .C("R_scanone_ehk", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), # additive covariates as.integer(n.ac), as.double(ic), # interactive covariates as.integer(n.ic), as.double(pheno), # phenotype data as.double(weights), result=as.double(rep(0,n.pos)), as.integer(maxit), as.double(tol), PACKAGE="qtl") } else if(method=="em" && model=="normal") # interval mapping z <- .C("R_scanone_em", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(ac), as.integer(n.ac), as.double(ic), as.integer(n.ic), as.double(pheno), # phenotype data as.double(weights), result=as.double(rep(0,n.pos)), as.integer(std.start), as.double(this.start), as.integer(maxit), as.double(tol), as.integer(0), # debugging verbose off as.integer(ind.noqtl), # indicators of ind'l w/o QTL effects PACKAGE="qtl") else if(model=="np") # non-parametric interval mapping z <- .C("R_scanone_np", as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(n.gen), # number of possible genotypes as.double(genoprob), # genotype probabilities as.double(pheno) , # phenotype data result=as.double(rep(0,n.pos)), PACKAGE="qtl") else stop("Model ", model, " with method ", method, " not available") z <- matrix(z$result,nrow=n.pos) # interval mapping without covariates: # rescale log likelihood if(model == "np" && !ties.random) z <- z/correct # correct for ties # setup column names for z if(length(pheno.col)==1) colnames(z) <- "lod" else { if(is.null(colnames(pheno))) colnames(z) <- paste("lod", pheno.col, sep="") else colnames(z) <- colnames(pheno) } # get null log10 likelihood if(i==1 & model != "np") { if(n.ac > 0) resid0 <- lm(pheno ~ ac, weights=weights^2)$resid else resid0 <- lm(pheno ~ 1, weights=weights^2)$resid if(method=="hk") { if(n.phe > 1) { nllik0 <- apply(resid0, 2, function(x) (n.ind/2)*log10(sum((x*weights)^2))) } else nllik0 <- (n.ind/2)*log10(sum((resid0*weights)^2)) } else { sig0 <- sqrt(sum((resid0*weights)^2)/n.ind) nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10) } } # re-scale with null log10 likel for methods em and ehk if(method=="em" && model=="normal") z <- nllik0 - z else if(method=="ehk") z <- z/log(10) + nllik0 else if(method == "hk") { if(n.phe > 1) { z <- t(nllik0 - t(z)) } else z <- nllik0 - z } # get null log10 likelihood for the X chromosome if(chr_type=="X") { # determine which covariates belong in null hypothesis temp <- scanoneXnull(type, sexpgm, cross.attr=attributes(cross)) adjustX <- temp$adjustX parX0 <- temp$parX0+n.ac sexpgmcovar <- temp$sexpgmcovar if(adjustX) { if(model == "np") { sexpgmcovar <- factor(apply(sexpgmcovar,1,paste,collapse=":")) nllikX <- kruskal.test(pheno ~ sexpgmcovar)$stat/(2*log(10)) z <- z - nllikX } else if(method=="mr") { for(s in 1:ncol(newgeno)) { wh <- newgeno[,s] != 0 if(n.ac > 0) { residX <- lm(pheno ~ ac+sexpgmcovar, weights=weights^2,subset=wh)$resid resid0 <- lm(pheno ~ ac, weights=weights^2,subset=wh)$resid } else { residX <- lm(pheno ~ sexpgmcovar, weights=weights^2,subset=wh)$resid resid0 <- lm(pheno ~ 1, weights=weights^2,subset=wh)$resid } nllikX <- (sum(wh)/2)*log10(sum((residX*weights[wh])^2)) nllik0 <- (sum(wh)/2)*log10(sum((resid0*weights[wh])^2)) # rescale LOD score z[s,] <- z[s,] + nllikX - nllik0 } } else { if(n.ac > 0) { outX <- lm(pheno ~ ac+sexpgmcovar, weights=weights^2) residX <- outX$resid # revise the parX0, if some columns got dropped parX0 <- outX$rank } else residX <- lm(pheno ~ sexpgmcovar, weights=weights^2)$resid if(method=="hk") { if(n.phe==1) nllikX <- (n.ind/2)*log10(sum((residX*weights)^2)) else nllikX <- (n.ind/2)*apply(residX, 2, function(a,b) log10(sum((a*b)^2)), weights) } else { if(method=="imp") { if(n.ac > 0) { out0 <- lm(pheno ~ ac, weights=weights^2) resid0 <- out0$resid } else { out0 <- lm(pheno ~ 1, weights=weights^2) resid0 <- out0$resid } if(n.phe > 1) { sig0 <- sqrt(apply(resid0, 2, function(a,b) sum((a*b)^2),weights)/n.ind) nllik0 <- sig0 for(j in seq(along=nllik0)) nllik0[j] <- -sum(dnorm(resid0[,j],0,sig0[j]/weights,log=TRUE))/log(10) } else { sig0 <- sqrt(sum((resid0*weights)^2)/n.ind) nllik0 <- -sum(dnorm(resid0,0,sig0/weights,log=TRUE))/log(10) } } if(n.phe > 1) { sigX <- sqrt(apply(residX, 2, function(a,b) sum((a*b)^2),weights)/n.ind) nllikX <- sigX for(j in seq(along=nllikX)) nllikX[j] <- -sum(dnorm(residX[,j],0,sigX[j]/weights,log=TRUE))/log(10) } else { sigX <- sqrt(sum((residX*weights)^2)/n.ind) nllikX <- -sum(dnorm(residX,0,sigX/weights,log=TRUE))/log(10) } } } if(method != "mr" && model != "np") { # rescale LOD score z <- t(t(z) + nllikX - nllik0) } } } # replace missing or negative LODs with 0 z[is.na(z) | z<0] <- 0 w <- marnam o <- grep("^loc-*[0-9]+",w) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" w[o] <- paste("c",names(cross$geno)[i],".",w[o],sep="") z <- as.data.frame(z, stringsAsFactors=TRUE) z <- cbind(chr=factor(rep(names(cross$geno)[i],length(map)),levels=names(cross$geno)), pos=as.numeric(map), z) rownames(z) <- w results <- rbind(results, z) } class(results) <- c("scanone","data.frame") attr(results,"method") <- method attr(results,"type") <- type attr(results,"model") <- model results } ###################################################################### # # scanone.perm: Permutation test of scanone # ###################################################################### scanone.perm <- function(cross, pheno.col=1, model=c("normal","binary","2part","np"), method=c("em","imp","hk","ehk","mr","mr-imp","mr-argmax"), addcovar=NULL, intcovar=NULL, weights=NULL, use=c("all.obs", "complete.obs"), upper=FALSE, ties.random=FALSE, start=NULL, maxit=4000, tol=1e-4, n.perm=1000, perm.Xsp=FALSE, perm.strata=NULL, verbose=TRUE, batchsize=250) { method <- match.arg(method) model <- match.arg(model) use <- match.arg(use) if((model=="2part" || model=="np") && (!is.null(addcovar) || !is.null(intcovar))) { warning("Use of covariates not available for model ", model) addcovar <- intcovar <- NULL } chr.type <- sapply(cross$geno, chrtype) if((all(chr.type=="X") || all(chr.type=="X")) && perm.Xsp==TRUE) warning("All chromosomes of the same type, so X-chr specific permutations not needed.\n") if(any(chr.type=="X") && any(chr.type=="A") && perm.Xsp) { # autosome and X-specific perms # X chr versus autosomes xchr <- chr.type=="X" names(xchr) <- names(cross$geno) # chromosome lengths L <- summary(pull.map(cross))[,2] L <- L[-length(L)] La <- sum(L[!xchr]) Lx <- sum(L[xchr]) n.perm.X <- ceiling(La/Lx*n.perm) if(verbose) cat("--Autosome permutations\n") resA <- scanone.perm.engine(n.perm, subset(cross, chr=!xchr), pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, verbose, perm.strata, batchsize) if(verbose) cat("--X chromosome permutations\n") resX <- scanone.perm.engine(n.perm.X, subset(cross, chr=xchr), pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, verbose, perm.strata, batchsize) res <- list("A"=resA, "X"=resX) attr(res, "xchr") <- xchr attr(res, "L") <- c("A"=La, "X"=Lx) } else { res <- scanone.perm.engine(n.perm, cross, pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, verbose, perm.strata, batchsize) } attr(res,"method") <- method attr(res,"model") <- model attr(res,"type") <- crosstype(cross) if(any(chr.type=="X") && any(chr.type=="A") && perm.Xsp) class(res) <- c("scanoneperm", "list") else class(res) <- c("scanoneperm", "matrix") res } ################################################################## # engine function to permform permutation test ################################################################## scanone.perm.engine <- function(n.perm, cross, pheno.col, model, method, addcovar, intcovar, weights, use, upper, ties.random, start, maxit, tol, verbose, perm.strata, batchsize=250) { ## local variables n.phe <- length(pheno.col) n.addcov <- ncol(addcovar) n.intcovar <- ncol(intcovar) n.ind <- dim(cross$pheno)[1] if(method=="mr-imp") # save version with missing genotypes tempcross <- cross if(method=="mr-argmax") # impute genotypes cross <- fill.geno(cross,method="argmax") ## if there's only one phenotype, no covariate, and method is imp or hk, ## generate permuted phenotype as a matrix ## we also need one sex and one direction, or that the ## stratification is within those groups batch.mode <- FALSE if( (n.phe==1) && ((method=="imp") || (method=="hk")) && model == "normal" && is.null(addcovar) && is.null(intcovar) ) { chr_type <- sapply(cross$geno, chrtype) sexpgm <- getsex(cross) sex <- sexpgm$sex pgm <- sexpgm$pgm if(all(chr_type=="A")) batch.mode <- TRUE else if((is.null(sex) || length(unique(sex))==1) && (is.null(pgm) || length(unique(pgm))==1)) batch.mode <- TRUE else if(!is.null(perm.strata)) { sp <- paste(sex, pgm, sep=":") tab <- table(sp, perm.strata) if(all(apply(tab, 2, function(a) sum(a != 0))==1)) batch.mode <- TRUE } } if(batch.mode) { if(verbose) cat("Doing permutation in batch mode ...\n") ## if there's only one phenotype, no covariate, and method is imp or hk, ## generate permuted phenotype as a matrix and do permutation ## as multiple phenotypes ord <- matrix(0, n.ind, n.perm) if(!is.null(perm.strata)) { # stratified permutation test if(length(perm.strata) != n.ind) stop("perm.strata must be NULL or have length nind(cross).") u <- unique(perm.strata) theindex <- 1:n.ind if(length(u)==n.ind) stop("All elements of perm.strata are unique, so there will be no real permutation.") if(length(u)==1) warning("Just one unique element in perm.strata, so the perms are not stratified.") for(iperm in 1:n.perm) { for(j in u) { wh <- perm.strata==j if(sum(wh)==1) ord[wh,iperm] <- theindex[wh] else ord[wh,iperm] <- sample(theindex[wh]) } } } else { for(iperm in 1:n.perm) ord[,iperm] <- sample(n.ind) } cross$pheno <- cbind(matrix(cross$pheno[,pheno.col][ord], nrow=n.ind), cross$pheno) pheno.col <- 1:n.perm tem <- scanone(cross,,pheno.col,model,method,addcovar, intcovar, weights, use, upper,ties.random,start, maxit,tol,n.perm= -1, perm.Xsp=FALSE, perm.strata, verbose=FALSE, batchsize, n.cluster=0) res <- matrix(apply(tem[,-(1:2),drop=FALSE], 2, max, na.rm=TRUE), ncol=1) colnames(res) <- "lod" } else { ## all other cases, do one permutation at a time ## rnd: how often to print tracing information if(verbose > 1) rnd <- 1 else { if(n.perm >= 1000) rnd <- 20 else if(n.perm >= 100) rnd <- 5 else rnd <- 1 } addcovarp <- addcovar intcovarp <- intcovar if(!is.null(addcovar)) addcovarp <- as.matrix(addcovarp) if(!is.null(intcovar)) intcovarp <- as.matrix(intcovarp) if(model=="2part") res <- matrix(ncol=3*n.phe,nrow=n.perm) else res <- matrix(0, n.perm, n.phe) for(i in 1:n.perm) { if(verbose && i/rnd == floor(i/rnd)) cat("Permutation", i, "\n") # impute genotypes for method "mr-imp" if(method=="mr-imp") cross <- fill.geno(tempcross) if(!is.null(perm.strata)) { # stratified permutation test if(length(perm.strata) != n.ind) stop("perm.strata must be NULL or have length nind(cross).") u <- unique(perm.strata) theindex <- 1:n.ind if(length(u)==n.ind) stop("All elements of perm.strata are unique, so no real permutations.") if(length(u)==1 && i==1) warning("Just one unique element in perm.strata, so the perms are not stratified.") o <- 1:n.ind for(j in u) { wh <- perm.strata==j if(sum(wh)>1) o[wh] <- sample(o[wh]) } } else o <- sample(1:n.ind) cross$pheno <- cross$pheno[o,,drop=FALSE] if(!is.null(addcovar)) addcovarp <- addcovarp[o,,drop=FALSE] if(!is.null(intcovar)) intcovarp <- intcovarp[o,,drop=FALSE] if(!is.null(weights)) weights <- weights[o] tem <- scanone(cross,,pheno.col,model,method,addcovarp, intcovarp,weights,use,upper,ties.random,start, maxit,tol,n.perm= -i, perm.Xsp=FALSE, perm.strata, verbose=FALSE, batchsize, n.cluster=0) res[i,] <- apply(tem[,-(1:2),drop=FALSE], 2, max, na.rm=TRUE) } # finish permutation colnames(res) <- colnames(tem)[-(1:2)] } ## set row and column names when n.phe>1 rownames(res) <- 1:n.perm ## return res } # end of scanone.R qtl/R/xchr.R0000644000176200001440000010530413576241200012345 0ustar liggesusers##################################################################### # # xchr.R # # copyright (c) 2004-2018, Karl W Broman # last modified Mar, 2018 # first written Apr, 2004 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: Utilities for dealing with the X chromosome. # getsex, getgenonames, reviseXdata, scanoneXnull # revisecovar, dropXcol # [See also fixXgeno.bc & fixXgeno.f2 in read.cross.R] # ###################################################################### # get sex and pgm columns from phenotype data getsex <- function(cross) { type <- crosstype(cross) if(type != "bc" && type != "f2" && type != "4way") return(list(sex=NULL, pgm=NULL)) phe.names <- names(cross$pheno) sex.column <- grep("^[Ss][Ee][Xx]$", phe.names) pgm.column <- grep("^[Pp][Gg][Mm]$", phe.names) if(length(sex.column)==0) { # no sex included sex <- NULL } else { if(length(sex.column)>1) warning("'sex' included multiple times. Using the first one.") temp <- cross$pheno[,sex.column[1]] if(is.numeric(temp)) { if(any(!is.na(temp) & temp != 0 & temp != 1)) { warning("Sex column should be coded as 0=female 1=male; sex ignored.") sex <- NULL } else sex <- temp } else { if(!is.factor(temp)) temp <- as.factor(temp) if(length(levels(temp)) == 1) { if(levels(temp) == "F" || levels(temp)=="f" || toupper(levels(temp)) == "FEMALE") sex <- rep(0,nind(cross)) else if(levels(temp) == "M" || levels(temp)=="m" || toupper(levels(temp)) == "MALE") sex <- rep(1,nind(cross)) else warning("Sex column should be coded as 0=female 1=male; sex ignored.") } else if(length(levels(temp)) > 2) { warning("Sex column should be coded as a two-level factor; sex ignored.") sex <- NULL } else { # is a factor with two levels lev <- levels(temp) if(length(grep("^[Ff]",lev))>0 && length(males <- grep("^[Mm]",lev))>0) { temp <- as.character(temp) sex <- rep(0,length(temp)) sex[is.na(temp)] <- NA sex[!is.na(temp) & temp==lev[males]] <- 1 } else warning("Don't understand levels in sex column; sex ignored.") } } } if(length(pgm.column)==0 || type=="4way") { # no pgm included pgm <- NULL } else { if(length(pgm.column)>1) warning("'pgm' included multiple times. Using the first one.") temp <- cross$pheno[,pgm.column[1]] if(!is.numeric(temp)) temp <- as.numeric(temp)-1 if(any(!is.na(temp) & temp != 0 & temp != 1)) { warning("pgm column should be coded as 0/1; pgm ignored.") pgm <- NULL } else pgm <- temp } if(!is.null(sex) && any(is.na(sex))) { if(all(sex[!is.na(sex)]==1)) { warning(sum(is.na(sex)), " individuals with missing sex; assuming they're male like the others") sex[is.na(sex)] <- 1 } else if(all(sex[!is.na(sex)]==0)) { warning(sum(is.na(sex)), " individuals with missing sex; assuming they're female like the others") sex[is.na(sex)] <- 0 } else { warning(sum(is.na(sex)), " individuals with missing sex; assuming they're female") sex[is.na(sex)] <- 0 } } if(!is.null(pgm) && any(is.na(pgm))) { if(all(pgm[!is.na(pgm)]==1)) { warning(sum(is.na(pgm)), " individuals with missing pgm; assuming pgm==1 like the others") pgm[is.na(pgm)] <- 1 } else if(all(pgm[!is.na(pgm)]==0)) { warning(sum(is.na(pgm)), " individuals with missing pgm; assuming pgm==0 like the others") pgm[is.na(pgm)] <- 0 } else { warning(sum(is.na(pgm)), " individuals with missing pgm; assuming pgm==0") pgm[is.na(pgm)] <- 0 } } list(sex=sex,pgm=pgm) } # get names of genotypes # used in discan, effectplot, plotPXG, scanone, scantwo, vbscan, reviseXdata # cross.attr gives the cross attributes getgenonames <- function(type=c("f2","bc","riself","risib","4way","dh","haploid","special","bcsft"), chrtype=c("A","X"), expandX=c("simple","standard","full"), sexpgm, cross.attr) { type <- match.arg(type) chrtype <- match.arg(chrtype) expandX <- match.arg(expandX) ## Treat bcsft as bc if no intercross generations; otherwise as f2. if(type == "bcsft") { if(cross.attr$scheme[2] == 0) type <- "bc" else type <- "f2" } if(chrtype=="X") { sex <- sexpgm$sex pgm <- sexpgm$pgm } if(type=="special") return(cross.attr$genotypes) if(missing(cross.attr) || !("alleles" %in% names(cross.attr))) { if(type == "4way") alleles <- LETTERS[1:4] else alleles <- LETTERS[1:2] } else { alleles <- cross.attr$alleles } if(type=="4way") { # ensure that we have enough allele codes if(length(alleles) < 4) alleles <- LETTERS[1:4] } else { if(length(alleles) < 2) alleles <- LETTERS[1:2] } tempgn <- c(paste(rep(alleles[1],2),collapse=""), paste(alleles,collapse=""), paste(rep(alleles[2],2),collapse=""), paste(alleles[1],"Y",sep=""), paste(alleles[2],"Y",sep="")) # get rid of missing sex and pgm values, if there are any if(chrtype=="X") { if(length(sex)>0) sex <- sex[!is.na(sex)] if(length(pgm)>0) pgm <- pgm[!is.na(pgm)] } if(type=="riself" || type=="risib" || type=="dh") gen.names <- tempgn[c(1,3)] else if(type=="haploid") gen.names <- alleles else if(type == "4way") { if(chrtype=="A") gen.names <- c(paste(alleles[1],alleles[3],sep=""), paste(alleles[2],alleles[3],sep=""), paste(alleles[1],alleles[4],sep=""), paste(alleles[2],alleles[4],sep="")) else gen.names <- c(paste(alleles[1],alleles[3],sep=""), paste(alleles[2],alleles[3],sep=""), paste(alleles[1],"Y",sep=""), paste(alleles[2],"Y",sep="")) } else if(type == "bc") { if(chrtype=="A") # autosome gen.names <- tempgn[1:2] # AA AB else { # X chromosome # simple standard full # -both sexes A-/AB/BY AA/AB/AY/BY same as std # -all females AA/AB same same # -all males AY/BY same same if(length(sex)==0 || all(sex==0)) # all females gen.names <- tempgn[1:2] # AA AB else if(all(sex==1)) # all males gen.names <- tempgn[4:5] # AY BY else { # some of each if(expandX == "simple") gen.names <- c(paste(alleles[1], "-", sep=""), tempgn[c(2,5)]) # A-, AB, BY else gen.names <- tempgn[c(1,2,4,5)] # AA,AB,AY,BY } } } else { # intercross if(chrtype == "A") # autosomal gen.names <- tempgn[1:3] else { # X chromsome # both crosses simple standard full # -both sexes A-/AB/B- AA/AB/BB/AY/BY AA/AB1/AB2/BB/AY/BY # -all females AA/AB/BB same as simple AA/AB1/AB2/BB # -all males AY/BY same same # forw cross # -both sexes A-/AB/BY AA/AB/AY/BY same as std # -all females AA/AB same same # -all males AY/BY same same # backw cross # -both sexes B-/AB/AY BB/AB/AY/BY same as std # -all females BB/AB same same # -all males AY/BY same same if(length(sex)==0 || all(sex==0)) { # all females if(length(pgm)==0 || all(pgm==0)) # all forw dir gen.names <- tempgn[1:2] # AA AB else if(all(pgm==1)) # all backw dir gen.names <- tempgn[3:2] # BB AB else { # some of each direction if(expandX=="full") gen.names <- c(tempgn[1], paste(tempgn[2],c("f","r"), sep=""), tempgn[3]) else gen.names <- tempgn[1:3] } } else if(all(sex==1)) # all males gen.names <- tempgn[4:5] else { # some of each sex if(length(pgm)==0 || all(pgm==0)) { # all forw if(expandX=="simple") gen.names <- c(paste(alleles[1],"-", sep=""), tempgn[c(2,5)]) else gen.names <- tempgn[c(1,2,4,5)] } else if (all(pgm==1)) { # all backw if(expandX=="simple") gen.names <- c(paste(alleles[2], "-",sep=""), tempgn[c(2,4)]) else gen.names <- tempgn[c(3,2,4,5)] } else { # some of each dir if(expandX=="simple") gen.names <- c(paste(alleles[1],"-",sep=""), tempgn[2], paste(alleles[2],"-",sep="")) else if(expandX=="standard") gen.names <- tempgn else gen.names <- c(tempgn[1], paste(tempgn[2],c("f","r"),sep=""), tempgn[3:5]) } } } } gen.names } # revise genotype data, probabilities or imputations for the X chromosome reviseXdata <- function(type=c("f2","bc","bcsft"), expandX=c("simple","standard","full"), sexpgm, geno, prob, draws, pairprob, cross.attr, force=FALSE) { type <- match.arg(type) expandX <- match.arg(expandX) ## Treat bcsft as bc if no intercross generations; otherwise as f2. if(type == "bcsft") { if(cross.attr$scheme[2] == 0) type <- "bc" else type <- "f2" } sex <- sexpgm$sex pgm <- sexpgm$pgm notmissing <- (!missing(geno)) + (!missing(prob)) + (!missing(draws)) + (!missing(pairprob)) if(notmissing == 0) stop("Provide one of geno, prob, draws, pairprob.") if(notmissing > 1) stop("Provide just one of geno, prob, draws, pairprob.") # get genonames genonames <- getgenonames(type, "X", expandX, sexpgm, cross.attr) if(type == "bc") { # backcross if(length(sex)==0 || ((all(sex==0) || all(sex==1)) && !force)) { # all one sex # no changes necessary if(!missing(geno)) return(geno) else if(!missing(prob)) { dimnames(prob)[[3]] <- genonames return(prob) } else if(!missing(draws)) return(draws) else # pairprob return(pairprob) } else { # both sexes if(!missing(geno)) { gmale <- geno[sex==1,] if(expandX=="simple") gmale[!is.na(gmale) & gmale==2] <- 3 else { gmale[!is.na(gmale) & gmale==1] <- 3 gmale[!is.na(gmale) & gmale==2] <- 4 } geno[sex==1,] <- gmale return(geno) } else if(!missing(draws)) { gmale <- draws[sex==1,,] if(expandX=="simple") gmale[gmale==2] <- 3 else { gmale[gmale==1] <- 3 gmale[gmale==2] <- 4 } draws[sex==1,,] <- gmale return(draws) } else if(!missing(prob)) { dimprob <- dim(prob) dimprob[3] <- length(genonames) newprob <- array(0,dim=dimprob) dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames)) newprob[sex==0,,1:2] <- prob[sex==0,,1:2] if(expandX=="simple") { newprob[sex==1,,1] <- prob[sex==1,,1] newprob[sex==1,,3] <- prob[sex==1,,2] } else { newprob[sex==1,,3] <- prob[sex==1,,1] newprob[sex==1,,4] <- prob[sex==1,,2] } return(newprob) } else { # pairprob dimpairprob <- dim(pairprob) dimpairprob[3] <- dimpairprob[4] <- length(genonames) newpairprob <- array(0,dim=dimpairprob) newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,] if(expandX=="simple") { newpairprob[sex==1,,1,1] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,1,3] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,3,1] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,3,3] <- pairprob[sex==1,,2,2] } else { newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2] } return(newpairprob) } } # end of "both sexes" / backcross } # end of backcross else { # intercross if(length(sex)==0 || all(sex==0)) { # all females if(length(pgm)==0 || ((all(pgm==0) || all(pgm==1)) && !force)) { # one dir, females if(!missing(geno)) return(geno) else if(!missing(draws)) return(draws) else if(!missing(pairprob)) return(pairprob) else { dimnames(prob)[[3]] <- genonames return(prob) } } else { # both dir, females if(!missing(geno)) { gback <- geno[pgm==1,] if(expandX!="full") { gback[!is.na(gback) & gback==1] <- 3 geno[pgm==1,] <- gback } else { gback[!is.na(gback) & gback==1] <- 4 gback[!is.na(gback) & gback==2] <- 3 geno[pgm==1,] <- gback } return(geno) } else if(!missing(draws)) { gback <- draws[pgm==1,,] if(expandX!="full") { gback[!is.na(gback) & gback==1] <- 3 } else { gback[!is.na(gback) & gback==1] <- 4 gback[!is.na(gback) & gback==2] <- 3 } draws[pgm==1,,] <- gback return(draws) } else if(!missing(prob)) { dimprob <- dim(prob) dimprob[3] <- length(genonames) newprob <- array(0,dim=dimprob) dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames)) newprob[pgm==0,,1:2] <- prob[pgm==0,,1:2] if(expandX!="full") { # simple/standard newprob[pgm==1,,3] <- prob[pgm==1,,1] newprob[pgm==1,,2] <- prob[pgm==1,,2] } else { newprob[pgm==1,,4] <- prob[pgm==1,,1] newprob[pgm==1,,3] <- prob[pgm==1,,2] } return(newprob) } else { # pairprob dimpairprob <- dim(pairprob) dimpairprob[3] <- dimpairprob[4] <- length(genonames) newpairprob <- array(0,dim=dimpairprob) newpairprob[pgm==0,,1:2,1:2] <- pairprob[pgm==0,,,] if(expandX!="full") { # simple/standard newpairprob[pgm==1,,3,3] <- pairprob[pgm==1,,1,1] newpairprob[pgm==1,,3,2] <- pairprob[pgm==1,,1,2] newpairprob[pgm==1,,2,3] <- pairprob[pgm==1,,2,1] newpairprob[pgm==1,,2,2] <- pairprob[pgm==1,,2,2] } else { newpairprob[pgm==1,,4,4] <- pairprob[pgm==1,,1,1] newpairprob[pgm==1,,4,3] <- pairprob[pgm==1,,1,2] newpairprob[pgm==1,,3,4] <- pairprob[pgm==1,,2,1] newpairprob[pgm==1,,3,3] <- pairprob[pgm==1,,2,2] } return(newpairprob) } } } else if(all(sex==1) && !force) { # all males if(!missing(geno)) return(geno) else if(!missing(draws)) return(draws) else if(!missing(pairprob)) return(pairprob) else { dimnames(prob)[[3]] <- genonames return(prob) } } else { # both sexes if(length(pgm)==0 || all(pgm==0)) { # both sexes, forw dir if(!missing(geno)) { gmale <- geno[sex==1,] if(expandX=="simple") gmale[!is.na(gmale) & gmale==2] <- 3 else { gmale[!is.na(gmale) & gmale==1] <- 3 gmale[!is.na(gmale) & gmale==2] <- 4 } geno[sex==1,] <- gmale return(geno) } else if(!missing(draws)) { gmale <- draws[sex==1,,] if(expandX=="simple") gmale[gmale==2] <- 3 else { gmale[gmale==1] <- 3 gmale[gmale==2] <- 4 } draws[sex==1,,] <- gmale return(draws) } else if(!missing(prob)) { dimprob <- dim(prob) dimprob[3] <- length(genonames) newprob <- array(0,dim=dimprob) dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames)) newprob[sex==0,,1:2] <- prob[sex==0,,1:2] if(expandX=="simple") { newprob[sex==1,,1] <- prob[sex==1,,1] newprob[sex==1,,3] <- prob[sex==1,,2] } else { newprob[sex==1,,3] <- prob[sex==1,,1] newprob[sex==1,,4] <- prob[sex==1,,2] } return(newprob) } else { # pairprob dimpairprob <- dim(pairprob) dimpairprob[3] <- dimpairprob[4] <- length(genonames) newpairprob <- array(0,dim=dimpairprob) newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,] if(expandX=="simple") { newpairprob[sex==1,,1,1] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,1,3] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,3,1] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,3,3] <- pairprob[sex==1,,2,2] } else { newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2] } return(newpairprob) } } # both sexes, forw dir if(all(pgm==1) && !force) { # both sexes, backw dir if(!missing(geno)) { gmale <- geno[sex==1,] if(expandX=="simple") { gmale[!is.na(gmale) & gmale==1] <- 3 gmale[!is.na(gmale) & gmale==2] <- 1 } else { gmale[!is.na(gmale) & gmale==1] <- 3 gmale[!is.na(gmale) & gmale==2] <- 4 } geno[sex==1,] <- gmale return(geno) } else if(!missing(draws)) { gmale <- draws[sex==1,,] if(expandX=="simple") { gmale[gmale==1] <- 3 gmale[gmale==2] <- 1 } else { gmale[gmale==1] <- 3 gmale[gmale==2] <- 4 } draws[sex==1,,] <- gmale return(draws) } else if(!missing(prob)) { dimprob <- dim(prob) dimprob[3] <- length(genonames) newprob <- array(0,dim=dimprob) dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames)) newprob[sex==0,,1:2] <- prob[sex==0,,1:2] if(expandX=="simple") { newprob[sex==1,,3] <- prob[sex==1,,1] newprob[sex==1,,1] <- prob[sex==1,,2] } else { newprob[sex==1,,3] <- prob[sex==1,,1] newprob[sex==1,,4] <- prob[sex==1,,2] } return(newprob) } else { # pairprob dimpairprob <- dim(pairprob) dimpairprob[3] <- dimpairprob[4] <- length(genonames) newpairprob <- array(0,dim=dimpairprob) newpairprob[sex==0,,1:2,1:2] <- pairprob[sex==0,,,] if(expandX=="simple") { newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,1,3] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,3,1] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,1,1] <- pairprob[sex==1,,2,2] } else { newpairprob[sex==1,,3,3] <- pairprob[sex==1,,1,1] newpairprob[sex==1,,3,4] <- pairprob[sex==1,,1,2] newpairprob[sex==1,,4,3] <- pairprob[sex==1,,2,1] newpairprob[sex==1,,4,4] <- pairprob[sex==1,,2,2] } return(newpairprob) } } # both sexes, backw dir else { # both dir, both sexes if(!missing(geno)) { gmale <- geno[sex==1,] gfemaler <- geno[sex==0 & pgm==1,] if(expandX=="simple") { gmale[!is.na(gmale) & gmale==2] <- 3 gfemaler[!is.na(gfemaler) & gfemaler==1] <- 3 } else if(expandX=="standard") { gmale[!is.na(gmale) & gmale==1] <- 4 gmale[!is.na(gmale) & gmale==2] <- 5 gfemaler[!is.na(gfemaler) & gfemaler==1] <- 3 } else { gmale[!is.na(gmale) & gmale==1] <- 5 gmale[!is.na(gmale) & gmale==2] <- 6 gfemaler[!is.na(gfemaler) & gfemaler==1] <- 4 gfemaler[!is.na(gfemaler) & gfemaler==2] <- 3 } geno[sex==1,] <- gmale geno[sex==0 & pgm==1,] <- gfemaler return(geno) } else if(!missing(draws)) { gmale <- draws[sex==1,,] gfemaler <- draws[sex==0 & pgm==1,,] if(expandX=="simple") { gmale[gmale==2] <- 3 gfemaler[gfemaler==1] <- 3 } else if(expandX=="standard") { gmale[gmale==1] <- 4 gmale[gmale==2] <- 5 gfemaler[gfemaler==1] <- 3 } else { gmale[gmale==1] <- 5 gmale[gmale==2] <- 6 gfemaler[gfemaler==1] <- 4 gfemaler[gfemaler==2] <- 3 } draws[sex==1,,] <- gmale draws[sex==0 & pgm==1,,] <- gfemaler return(draws) } else if(!missing(prob)) { dimprob <- dim(prob) dimprob[3] <- length(genonames) newprob <- array(0,dim=dimprob) dimnames(newprob) <- c(dimnames(prob)[1:2],list(genonames)) newprob[sex==0 & pgm==0,,1:2] <- prob[sex==0 & pgm==0,,1:2] if(expandX=="simple") { newprob[sex==1,,1] <- prob[sex==1,,1] newprob[sex==1,,3] <- prob[sex==1,,2] newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,1] newprob[sex==0 & pgm==1,,2] <- prob[sex==0 & pgm==1,,2] } else if(expandX=="standard") { newprob[sex==1,,4] <- prob[sex==1,,1] newprob[sex==1,,5] <- prob[sex==1,,2] newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,1] newprob[sex==0 & pgm==1,,2] <- prob[sex==0 & pgm==1,,2] } else { newprob[sex==1,,5] <- prob[sex==1,,1] newprob[sex==1,,6] <- prob[sex==1,,2] newprob[sex==0 & pgm==1,,4] <- prob[sex==0 & pgm==1,,1] newprob[sex==0 & pgm==1,,3] <- prob[sex==0 & pgm==1,,2] } return(newprob) } else { # pairprob dimpairprob <- dim(pairprob) dimpairprob[3] <- dimpairprob[4] <- length(genonames) newpairprob <- array(0,dim=dimpairprob) newpairprob[sex==0 & pgm==0,,1:2,1:2] <- pairprob[sex==0 & pgm==0,,,] male <- (sex==1) femaler <- (sex==0) & (pgm==1) if(expandX=="simple") { newpairprob[male,,1,1] <- pairprob[male,,1,1] newpairprob[male,,1,3] <- pairprob[male,,1,2] newpairprob[male,,3,1] <- pairprob[male,,2,1] newpairprob[male,,3,3] <- pairprob[male,,2,2] newpairprob[femaler,,3,3] <- pairprob[femaler,,1,1] newpairprob[femaler,,3,2] <- pairprob[femaler,,1,2] newpairprob[femaler,,2,3] <- pairprob[femaler,,2,1] newpairprob[femaler,,2,2] <- pairprob[femaler,,2,2] } else if(expandX=="standard") { newpairprob[male,,4,4] <- pairprob[male,,1,1] newpairprob[male,,4,5] <- pairprob[male,,1,2] newpairprob[male,,5,4] <- pairprob[male,,2,1] newpairprob[male,,5,5] <- pairprob[male,,2,2] newpairprob[femaler,,3,3] <- pairprob[femaler,,1,1] newpairprob[femaler,,3,2] <- pairprob[femaler,,1,2] newpairprob[femaler,,2,3] <- pairprob[femaler,,2,1] newpairprob[femaler,,2,2] <- pairprob[femaler,,2,2] } else { newpairprob[male,,5,5] <- pairprob[male,,1,1] newpairprob[male,,5,6] <- pairprob[male,,1,2] newpairprob[male,,6,5] <- pairprob[male,,2,1] newpairprob[male,,6,6] <- pairprob[male,,2,2] newpairprob[femaler,,4,4] <- pairprob[femaler,,1,1] newpairprob[femaler,,4,3] <- pairprob[femaler,,1,2] newpairprob[femaler,,3,4] <- pairprob[femaler,,2,1] newpairprob[femaler,,3,3] <- pairprob[femaler,,2,2] } return(newpairprob) } } } } # end of intercross } ###################################################################### # scanoneXnull # # figure out null hypothesis business for scanone on X chromosome ###################################################################### scanoneXnull <- function(type, sexpgm, cross.attr) { sex <- sexpgm$sex pgm <- sexpgm$pgm if(type == "risib" || type=="riself" || type=="dh" || type=="haploid") type <- "bc" if(type == "bcsft") { if(cross.attr$scheme[2] == 0) type <- "bc" else type <- "f2" } ### first figure out sex/pgm pattern # sex if(length(sex)==0 || all(sex==0)) { # all female onesex <- allfemale <- TRUE } else if(all(sex==1)) { # all male onesex <- TRUE allfemale <- FALSE } else { # both sexes onesex <- allfemale <- FALSE } # pgm if(length(pgm)==0 || all(pgm==0) || all(pgm==1)) # one direction onedir <- TRUE else onedir <- FALSE allmale <- onesex && !allfemale bothsex <- !onesex bothdir <- !onedir ### now figure out the null hypothesis and pull out appropriate ### covariates for the null # backcross, one sex # OR intercross, one dir and one sex # OR intercross, both dir and all male if((type=="bc" && onesex) || (type=="f2" && ((onedir && onesex) || (bothdir && allmale)))) { adjustX <- FALSE parX0 <- 1 sexpgmcovar <- sexpgmcovar.alt <- NULL } # backcross, both sexes # OR intercross, one direction and both sexes else if((type=="bc" && bothsex) || (type=="f2" && onedir && bothsex)) { adjustX <- TRUE parX0 <- 2 sexpgmcovar <- cbind(sex) sexpgmcovar.alt <- sex+1 } # intercross, both dir and all female else if(type=="f2" && bothdir && allfemale) { adjustX <- TRUE parX0 <- 2 sexpgmcovar <- cbind(pgm) sexpgmcovar.alt <- pgm+1 } # intercross, both dir and both sexes else { adjustX <- TRUE parX0 <- 3 sexpgmcovar <- cbind(sex,as.numeric(sex==0 & pgm==1)) sexpgmcovar.alt <- rep(3,length(sex)) sexpgmcovar.alt[sex==0 & pgm==0] <- 1 sexpgmcovar.alt[sex==0 & pgm==1] <- 2 } list(adjustX=adjustX, parX0=parX0, sexpgmcovar=sexpgmcovar, sexpgmcovar.alt=sexpgmcovar.alt) } ###################################################################### # revisecovar # # Drop sex and pgm and their interxn as covariates for the X chr. ###################################################################### revisecovar <- function(sexpgm, covar) { if(is.null(covar) || (is.null(sexpgm$sex) && is.null(sexpgm$pgm))) { if(!is.null(covar)) attr(covar, "n.dropped") <- 0 return(covar) } covar <- as.matrix(covar) sex <- sexpgm$sex pgm <- sexpgm$pgm if(!is.null(pgm) && length(unique(pgm))==1) pgm <- NULL allfemale <- FALSE if(is.null(sex)) allfemale <- TRUE else { if(all(sex==0)) { allfemale <- TRUE sex <- NULL } else if(all(sex==1)) { allfemale <- FALSE sex <- NULL } } if(!is.null(pgm)) { # some of each direction if(!is.null(sex)) { # some of each sex femf <- as.numeric(pgm==0 & sex==0) femr <- as.numeric(pgm==1 & sex==0) mal <- sex X <- cbind(femf, femr, mal) } else { # all of one sex if(allfemale) X <- cbind(1-pgm, pgm) else X <- cbind(rep(1, nrow(covar))) } } else { # all of one direction if(!is.null(sex)) # some of each sex X <- cbind(sex, 1-sex) else X <- cbind(rep(1, nrow(covar))) } nc <- ncol(X) keep <- rep(TRUE,ncol(covar)) for(i in 1:ncol(covar)) { if(qr(cbind(X,covar[,i]))$rank <= nc) keep[i] <- FALSE } if(!any(keep)) covar <- numeric(0) else covar <- covar[,keep,drop=FALSE] attr(covar, "n.dropped") <- sum(!keep) covar } ###################################################################### # dropXcol: for use with scantwo() for the X chromosome: # figure out what columns to drop...both for the full model # and for the additive model. ###################################################################### dropXcol <- function(type=c("f2","bc", "riself", "risib", "4way", "dh", "haploid", "special","bcsft"), sexpgm, cross.attr) { type <- match.arg(type) ## Treat bcsft as bc if no intercross generations; otherwise as f2. if(type == "bcsft") { if(cross.attr$scheme[2] == 0) type <- "bc" else type <- "f2" } gn <- getgenonames(type, "X", "full", sexpgm, cross.attr) if(length(gn)==2) return(rep(0,4)) if(length(gn)==4) return( c(0,0,0,0,0,1,0, 0,1,1,1,1,1,1,1,0) ) if(length(gn)==6) { todrop <- c(rep(0,11), rep(1,25)) todrop[c(8,10)] <- 1 todrop[11+c(1,13,25)] <- 0 return(todrop) } return(rep(0,length(gn)^2)) } # end of xchr.R qtl/R/mqmprepare.R0000644000176200001440000000272713355127045013564 0ustar liggesusers##################################################################### # # mqmprepare.R # # Copyright (c) 2009-2010, Danny Arends # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified April 2010 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmfind.marker # # ##################################################################### mqmfind.marker <- function(cross,mqmscan=NULL,perm=NULL,alpha=0.05,verbose=FALSE){ thesum <- summary(mqmscan[,1:3],alpha=alpha,perms=perm,pvalues=FALSE) chr <- thesum$'chr' pos <- thesum$'pos' if(verbose) cat("INFO: Found",length(chr),"markers with alpha <",alpha,".\n") ret <- NULL for(i in 1:length(chr)){ ret <- rbind(ret,cbind(find.marker(cross,chr=chr[i],pos=pos[i]),as.integer(chr[i]),as.double(pos[i]))) } colnames(ret) <- c("marker","chr","pos (cM)") ret } # end of mqmprepare.R qtl/R/calc.pairprob.R0000644000176200001440000001776113576241200014131 0ustar liggesusers###################################################################### # # calc.pairprob.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Nov, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: calc.pairprob # ###################################################################### ###################################################################### # # calc.pairprob: calculate joint genotype probabilities for all pairs # of putative QTLs, conditional on the observed marker # data # # This is an *internal* function, not to be called by the user. # # The input argument cross is assumed to have just one chromosome. # ###################################################################### calc.pairprob <- function(cross, step=0, off.end=0, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), map, assumeCondIndep=FALSE) { # which type of cross is this? type <- crosstype(cross) if(assumeCondIndep) { # assume conditional independence of QTL given markers if(!("prob" %in% names(cross$geno[[1]]))) { cross <- calc.genoprob(subset(cross, chr=1), step=step, off.end=off.end, error.prob=error.prob, map.function=map.function) } prob <- cross$geno[[1]]$prob n.ind <- dim(prob)[1] n.pos <- dim(prob)[2] n.gen <- dim(prob)[3] if(n.pos < 2) return(NULL) z <- .C("R_calc_pairprob_condindep", as.integer(n.ind), as.integer(n.pos), as.integer(n.gen), as.double(prob), pairprob=as.double(rep(0,n.ind*choose(n.pos, 2)*n.gen*n.gen)), PACKAGE="qtl") pairprob <- array(z$pairprob, dim=c(n.ind,n.pos*(n.pos-1)/2,n.gen,n.gen)) return(pairprob) } if(step==0 && off.end > 0) step <- off.end*2 # map function map.function <- match.arg(map.function) if(map.function=="kosambi") mf <- mf.k else if(map.function=="c-f") mf <- mf.cf else if(map.function=="morgan") mf <- mf.m else mf <- mf.h # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } n.ind <- nind(cross) n.chr <- nchr(cross) # type of chromosome? chrtype <- chrtype(cross$geno[[1]]) if(chrtype=="X") xchr <- TRUE else xchr <- FALSE if(type == "f2") { one.map <- TRUE if(!xchr) { # autosome cfunc <- "calc_pairprob_f2" n.gen <- 3 gen.names <- getgenonames("f2", "A", cross.attr=attributes(cross)) } else { # X chromsome cfunc <- "calc_pairprob_bc" n.gen <- 2 gen.names <- c("g1","g2") } } else if(type == "bc") { cfunc <- "calc_pairprob_bc" n.gen <- 2 if(!xchr) # autosome gen.names <- getgenonames("bc", "A", cross.attr=attributes(cross)) else gen.names <- c("g1","g2") one.map <- TRUE } else if(type == "riself" || type=="risib" || type=="dh" || type=="haploid") { cfunc <- "calc_pairprob_bc" n.gen <- 2 gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) one.map <- TRUE } else if(type == "4way") { cfunc <- "calc_pairprob_4way" n.gen <- 4 one.map <- FALSE gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) } else if(type == "ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="magic16") { cfunc <- paste("calc_pairprob_", type, sep="") if(type=="magic16") n.gen <- 16 else n.gen <- as.numeric(substr(type, 3, 3)) one.map <- TRUE gen.names <- LETTERS[1:n.gen] if(xchr) warning("calc.pairprob not working properly for the X chromosome for 4- or 8-way RIL.") } else if(type == "bcsft") { one.map <- TRUE cfunc <- "calc_pairprob_bcsft" cross.scheme <- attr(cross, "scheme") ## c(s,t) for BC(s)F(t) if(!xchr) { # autosome gen.names <- getgenonames("bcsft", "A", cross.attr=attributes(cross)) n.gen <- 2 + (cross.scheme[2] > 0) } else { ## X chromsome cross.scheme[1] <- cross.scheme[1] + cross.scheme[2] - (cross.scheme[1] == 0) cross.scheme[2] <- 0 gen.names <- c("g1","g2") n.gen <- 2 } } else stop("calc.pairprob not available for cross type ", type, ".") # genotype data gen <- cross$geno[[1]]$data gen[is.na(gen)] <- 0 # get recombination fractions if(one.map) { # map <- create.map(cross$geno[[1]]$map,step,off.end) rf <- mf(diff(map)) if(type=="risib" || type=="riself") rf <- adjust.rf.ri(rf,substr(type,3,nchar(type)),chrtype(cross$geno[[1]])) rf[rf < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=length(map),nrow=nrow(gen)) colnames(newgen) <- names(map) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- names(map) } else { # map <- create.map(cross$geno[[1]]$map,step,off.end) rf <- mf(diff(map[1,])) rf[rf < 1e-14] <- 1e-14 rf2 <- mf(diff(map[2,])) rf2[rf2 < 1e-14] <- 1e-14 # new genotype matrix with pseudomarkers filled in newgen <- matrix(ncol=ncol(map),nrow=nrow(gen)) colnames(newgen) <- colnames(map) newgen[,colnames(gen)] <- gen newgen[is.na(newgen)] <- 0 n.pos <- ncol(newgen) marnames <- colnames(map) } if(n.pos < 2) return(NULL) # below: at least two positions # call the C function if(one.map) { ## Hide cross scheme in genoprob to pass to routine. BY temp <- as.double(rep(0,n.gen*n.ind*n.pos)) if(type == "bcsft") temp[1:2] <- cross.scheme z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(error.prob), # as.double(temp), pairprob=as.double(rep(0,n.ind*n.pos*(n.pos-1)/2*n.gen^2)), PACKAGE="qtl") } else { z <- .C(cfunc, as.integer(n.ind), # number of individuals as.integer(n.pos), # number of markers as.integer(newgen), # genotype data as.double(rf), # recombination fractions as.double(rf2), # recombination fractions as.double(error.prob), # as.double(rep(0,n.gen*n.ind*n.pos)), pairprob=as.double(rep(0,n.ind*n.pos*(n.pos-1)/2*n.gen^2)), PACKAGE="qtl") } pairprob <- array(z$pairprob, dim=c(n.ind,n.pos*(n.pos-1)/2,n.gen,n.gen)) # 4- and 8-way RIL: reorganize the results if(type=="ri4self" || type=="ri4sib" || type=="ri8self" || type=="ri8sib" || type=="bgmagic16") pairprob <- reorgRIpairprob(cross, pairprob) pairprob } # end of calc.pairprob.R qtl/R/plot.scanone.R0000644000176200001440000002365113576241200014010 0ustar liggesusers##################################################################### # # plot.scanone.R # # copyright (c) 2001-2019, Karl W Broman # last modified Dec, 2019 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: plot.scanone, # ###################################################################### ###################################################################### # # plot.scanone: plot output from scanone # ###################################################################### plot.scanone <- function(x,x2,x3,chr,lodcolumn=1,incl.markers=TRUE,xlim, ylim, lty=1,col=c("black","blue","red"),lwd=2,add=FALSE,gap=25, mtick=c("line", "triangle"), show.marker.names=FALSE, alternate.chrid=FALSE, bandcol=NULL, type="l", cex=1, pch=1, bg="transparent", bgrect=NULL, ...) { if(!inherits(x, "scanone") || (!missing(x2) && !inherits(x2, "scanone")) || (!missing(x3) && !inherits(x3, "scanone"))) stop("Input should have class \"scanone\".") if(!is.factor(x$chr)) x$chr <- factor(x$chr, levels=unique(x$chr)) dots <- list(...) # handle special arguments to be used in lines() if(length(type)==1) type <- rep(type, 3) if(length(cex)==1) cex <- rep(cex, 3) if(length(pch)==1) pch <- rep(pch, 3) if(length(bg)==1) bg <- rep(bg, 3) mtick <- match.arg(mtick) if(length(dim(x))!=2) stop("Argument x must be a matrix or data.frame.") if(!missing(x2) && length(dim(x2))!=2) stop("Argument x2 must be a matrix or data.frame.") if(!missing(x3) && length(dim(x3))!=2) stop("Argument x3 must be a matrix or data.frame.") if(length(lodcolumn)==1) lodcolumn <- rep(lodcolumn,3)[1:3] else if(length(lodcolumn)==2) { if(missing(x2)) x2 <- x lodcolumn <- lodcolumn[c(1,2,3)] } else { if(missing(x2)) x2 <- x if(missing(x3)) x3 <- x } lodcolumn <- lodcolumn+2 second <- third <- TRUE if(missing(x2) && missing(x3)) second <- third <- FALSE if(missing(x3)) third <- FALSE if(missing(x2)) second <- FALSE # rename things and turn into data frames if(lodcolumn[1] > ncol(x) || (second && lodcolumn[2] > ncol(x2)) || (third && lodcolumn[3] > ncol(x3))) stop("Argument lodcolumn misspecified.") out <- x[,c(1:2,lodcolumn[1])] if(second) out2 <- x2[,c(1:2,lodcolumn[2])] if(third) out3 <- x3[,c(1:2,lodcolumn[3])] if(length(lty)==1) lty <- rep(lty,3) if(length(lwd)==1) lwd <- rep(lwd,3) if(length(col)==1) col <- rep(col,3) # pull out desired chromosomes if(missing(chr) || length(chr)==0) chr <- unique(as.character(out[,1])) else chr <- matchchr(chr, unique(out[,1])) out <- out[!is.na(match(out[,1],chr)),] if(second) out2 <- out2[!is.na(match(out2[,1],chr)),] if(third) out3 <- out3[!is.na(match(out3[,1],chr)),] onechr <- FALSE if(length(chr) == 1) { gap <- 0 onechr <- TRUE } # beginning and end of chromosomes temp <- out begend <- matrix(unlist(tapply(temp[,2],temp[,1],range)),ncol=2,byrow=TRUE) rownames(begend) <- unique(out[,1]) begend <- begend[as.character(chr),,drop=FALSE] len <- begend[,2]-begend[,1] # locations to plot start of each chromosome if(!onechr) start <- c(0,cumsum(len+gap))-c(begend[,1],0) else start <- 0 maxx <- sum(len+gap)-gap # replace +/- Inf with NA out[!is.finite(out[,3]),3] <- NA if(second) out2[!is.finite(out2[,3]),3] <- NA if(third) out3[!is.finite(out3[,3]),3] <- NA # get max y-axis value if(all(is.na(out[,3]))) maxy <- 1 else maxy <- max(out[,3],na.rm=TRUE) if(second) maxy <- max(c(maxy,out2[,3]),na.rm=TRUE) if(third) maxy <- max(c(maxy,out3[,3]),na.rm=TRUE) # graphics parameters old.xpd <- par("xpd") old.las <- par("las") par(xpd=FALSE,las=1) on.exit(par(xpd=old.xpd,las=old.las)) # make frame of plot if(missing(ylim)) ylim <- c(0,maxy) if(missing(xlim)) { if(onechr) xlim <- c(0,max(out[,2])) else xlim <- c(-gap/2,maxx+gap/2) } if(!add) { if(onechr) { if("ylab" %in% names(dots)) { if("xlab" %in% names(dots)) { plot(0,0,ylim=ylim,xlim=xlim,type="n",...) } else { plot(0,0,ylim=ylim,xlim=xlim,type="n", xlab="Map position (cM)",...) } } else { if("xlab" %in% names(dots)) { plot(0,0,ylim=ylim,xlim=xlim,type="n", ylab=dimnames(out)[[2]][3], ...) } else { plot(0,0,ylim=ylim,xlim=xlim,type="n", xlab="Map position (cM)",ylab=dimnames(out)[[2]][3], ...) } } } else { if("ylab" %in% names(dots)) { if("xlab" %in% names(dots)) { plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n", xaxs="i", ...) } else { plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n", xlab="Chromosome", xaxs="i", ...) } } else { if("xlab" %in% names(dots)) { plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n", ylab=dimnames(out)[[2]][3], xaxs="i", ...) } else { plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n", xlab="Chromosome",ylab=dimnames(out)[[2]][3], xaxs="i", ...) } } } } if(!add && !is.null(bgrect)) { u <- par("usr") rect(u[1], u[3], u[2], u[4], col=bgrect) } if(!add && !onechr && !is.null(bandcol)) { u <- par("usr") for(i in seq(2, by=2, length(chr))) { rect(min(out[out[,1]==chr[i],2]) + start[i]-gap/2, u[3], max(out[out[,1]==chr[i],2]) + start[i]+gap/2, u[4], border=bandcol, col=bandcol) } abline(h=u[3:4]) } # initialize xtick and xtickmark xtick <- NULL xticklabel <- NULL for(i in 1:length(chr)) { # plot first out x <- out[out[,1]==chr[i],2]+start[i] y <- out[out[,1]==chr[i],3] if(length(x)==1) { g <- max(gap/10,2) x <- c(x-g,x,x+g) y <- rep(y,3) } lines(x,y,lwd=lwd[1],lty=lty[1],col=col[1], type=type[1], cex=cex[1], pch=pch[1], bg=bg[1]) # plot chromosome number if(!add && !onechr) { tloc <- mean(c(min(x),max(x))) xtick <- c(xtick, tloc) xticklabel <- c(xticklabel, as.character(chr[i])) } # plot second out if(second) { x <- out2[out2[,1]==chr[i],2]+start[i] y <- out2[out2[,1]==chr[i],3] if(length(x)==1) { g <- max(gap/10,2) x <- c(x-g,x,x+g) y <- rep(y,3) } lines(x,y,lty=lty[2],col=col[2],lwd=lwd[2], type=type[2], cex=cex[2], pch=pch[2], bg=bg[2]) } if(third) { x <- out3[out3[,1]==chr[i],2]+start[i] y <- out3[out3[,1]==chr[i],3] if(length(x)==1) { g <- max(gap/10,2) x <- c(x-g,x,x+g) y <- rep(y,3) } lines(x,y,lty=lty[3],col=col[3],lwd=lwd[3], type=type[3], cex=cex[3], pch=pch[3], bg=bg[3]) } # plot lines or triangles at marker positions if(!add) { nam <- dimnames(out)[[1]][out[,1]==chr[i]] wh.genoprob <- grep("^c.+\\.loc-*[0-9]+", nam) if(length(wh.genoprob)==0) wh.genoprob <- seq(along=nam) else wh.genoprob <- (seq(along=nam))[-wh.genoprob] pos <- out[out[,1]==chr[i],2][wh.genoprob]+start[i] if(incl.markers) { if(mtick=="line") rug(pos, 0.02, quiet=TRUE) else { a <- par("usr") points(pos, rep(a[3]+diff(a[3:4])*0.01, length(pos)), pch=17, cex=1.5) } } if(show.marker.names) { a <- par("usr") text(pos, rep(a[3]+diff(a[3:4])*0.03, length(pos)), nam[wh.genoprob], srt=90, adj=c(0,0.5)) } } } # draw the axis if(!add && !onechr) { if(!alternate.chrid || length(xtick) < 2) { for(i in seq(along=xtick)) axis(side=1, at=xtick[i], labels=xticklabel[i]) } else { odd <- seq(1, length(xtick), by=2) even <- seq(2, length(xtick), by=2) for(i in odd) { axis(side=1, at=xtick[i], labels="") axis(side=1, at=xtick[i], labels=xticklabel[i], line=-0.4, tick=FALSE) } for(i in even) { axis(side=1, at=xtick[i], labels="") axis(side=1, at=xtick[i], labels=xticklabel[i], line=+0.4, tick=FALSE) } } } if(!add && !is.null(bgrect)) { u <- par("usr") rect(u[1], u[3], u[2], u[4]) } invisible() } # end of plot.scanone.R qtl/R/find_large_intervals.R0000644000176200001440000000235213656774127015603 0ustar liggesusers# find large intervals in a map # # # input: map = list of chromosomes that are vectors of marker positions # [can also be a cross object, in which case pull.map() is used] # min_length = minimum distance between markers to be flagged # # example use: # library(qtl) # data(hyper) # find_large_intervals(hyper, 20) find_large_intervals <- function(map, min_length=35) { output <- NULL # if input is a cross, pull out the map if("cross" %in% class(map)) { map <- pull.map(map) } # make sure there are names if(is.null(names(map))) { names(map) <- seq_along(map) } for(i in names(map)) { d <- diff(map[[i]]) big <- which(d > min_length) n_big <- length(big) mar <- names(map[[i]]) if(n_big > 0) { this <- data.frame(chr=rep(i, n_big), left=mar[big], right=mar[big+1], interval_size=d[big], stringsAsFactors=FALSE) if(is.null(output)) output <- this else output <- rbind(output, this) } } if(!is.null(output)) rownames(output) <- 1:nrow(output) output } qtl/R/read.cross.mq.R0000644000176200001440000007315314525760136014077 0ustar liggesusers###################################################################### # # read.cross.mq.R # # copyright (c) 2014, INRA (author: Timothee Flutre) # (Some revisions by Karl Broman) # last modified Dec, 2018 # first written May, 2014 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.mq, read.cross.mq.loc, read.cross.mq.map, # read.cross.mq.qua, mq.rmv.comment # [See read.cross.R for the main read.cross function.] # ###################################################################### ###################################################################### # # read.cross.mq: read data from an experimental cross in MapQTL (and # JoinMap) format. # # We need three files: a "loc" file containing the genotype data, a # "map" file containing the linkage group assignments and map # positions, and a "qua" file containing the phenotypes. # # File formats are described in the MapQTL manual available online at # http://www.kyazma.nl/docs/MQ7Manual.pdf # For the loc-file, each marker should be on a single line. # Only 4-way crosses are supported ("CP" type in MapQTL/JoinMap). # ###################################################################### read.cross.mq <- function(dir, locfile, mapfile, quafile) { if(! missing(dir) && dir != "") { if(length(grep("/$", dir)) > 0) # strip off ending / dir <- substr(dir, 1, nchar(dir)-1) locfile <- file.path(dir, locfile) mapfile <- file.path(dir, mapfile) quafile <- file.path(dir, quafile) } loc <- read.cross.mq.loc(locfile) map <- read.cross.mq.map(mapfile) pheno <- read.cross.mq.qua(quafile) type <- loc$pop.type # only "4way" for the moment n.ind <- nrow(loc$genotypes) n.mar <- ncol(loc$genotypes) n.phe <- ncol(pheno) if(nrow(pheno) < n.ind){ msg <- paste("qua-file should have at least the same number of", " individuals than loc-file") stop(msg, call.=FALSE) } if(nrow(pheno) > n.ind){ pheno <- pheno[-((n.ind+1):nrow(pheno)),] } cat(" --Read the following data:\n") cat("\tNumber of individuals: ", n.ind, "\n") cat("\tNumber of markers: ", n.mar, "\n") cat("\tNumber of phenotypes: ", n.phe, "\n") geno <- list() for(chr in levels(map$chr)){ geno[[chr]] <- list(data=loc$genotypes[,map$marker[map$chr == chr]], map=map$pos[map$chr == chr]) names(geno[[chr]]$map) <- map$marker[map$chr == chr] if(type == "4way") geno[[chr]]$map <- rbind(geno[[chr]]$map, map$pos[map$chr == chr]) if(chr %in% c("x", "X")){ class(geno[[chr]]) <- "X" } else class(geno[[chr]]) <- "A" } cross <- list(geno=geno, pheno=pheno) class(cross) <- c(type, "cross") list(cross, FALSE) # FALSE for "don't estimate map" } mq_grab_param <- function(lines, param, longname, filetype) { # stuff for error message if(missing(filetype)) filetype <- "" else filetype <- paste(" in", filetype, "file") if(missing(longname)) longname <- param g <- grep(param, lines) if(length(g) == 0) stop("Cannot find ", longname, " in ", filetype) # remove white space line <- gsub("\\s+", "", lines[g]) result <- strsplit(line, "=")[[1]][2] return(list(result, g)) # g is the line number } ## each marker should be on a single line ## only 4-way crosses (CP type) are handled read.cross.mq.loc <- function(locfile){ pop.name <- NULL pop.type <- NULL nb.loci <- NULL nb.inds <- NULL seg <- NULL phase <- NULL classif <- NULL genotypes <- NULL lines <- readLines(locfile, warn=FALSE) # drop comments lines <- vapply(strsplit(lines, ";"), "[", "", 1) # drop empty lines lines <- lines[!is.na(lines)] blank <- grep("^\\s*$", lines) if(length(blank) > 0) lines <- lines[-blank] ## extract the population name res <- mq_grab_param(lines, "name", "population name", "loc") pop.name <- res[[1]] todrop <- res[[2]] ## extract the population type res <- mq_grab_param(lines, "popt", "population type", "loc") pop.type <- res[[1]] todrop <- c(todrop, res[[2]]) pop.types <- c("BC1","F2","RIx","DH","DH1","DH2","HAP","HAP1","CP","BCpxFy", "IMxFy") if(! pop.type %in% pop.types){ msg <- paste("unknown population type", pop.type) stop(msg, call.=FALSE) } if(pop.type == "CP"){ pop.type <- "4way" } else{ msg <- paste("population type", pop.type, "is not supported (yet)") stop(msg, call.=FALSE) } ## extract the number of loci res <- mq_grab_param(lines, "nloc", "Number of loci", "loc") nb.loci <- as.numeric(res[[1]]) todrop <- c(todrop, res[[2]]) seg <- rep(NA, nb.loci) phase <- rep(NA, nb.loci) classif <- rep(NA, nb.loci) res <- mq_grab_param(lines, "nind", "Number of individuals", "loc") nb.inds <- as.numeric(res[[1]]) todrop <- c(todrop, res[[2]]) genotypes <- matrix(NA, nrow=nb.loci, ncol=nb.inds) rownames(genotypes) <- paste("loc", 1:nb.loci, sep=".") ## colnames(genotypes) <- paste("ind", 1:nb.inds, sep=".") lines <- lines[-todrop] spl <- strsplit(lines, "\\s+") if(length(spl) != nb.loci) stop("nloc=", nb.loci, " but genotypes are found at ", length(spl), " markers") spl.lengths <- vapply(spl, length, 1) if(any(spl.lengths > nb.inds+4)) stop("lines should have no more than ", nb.inds+4, " columns\n", "Problems in lines", seq(along=spl.lengths)[spl.lengths > nb.inds+4]) rn <- vapply(spl, "[", "", 1) if(nrow(genotypes) != length(rn)) stop(paste0("nloc = ", nrow(genotypes), ", but .loc file contains ", length(rn), " genotype rows")) rownames(genotypes) <- rn if(length(spl) > nb.loci + 1){ msg <- paste("there seems to be more loci (", locus.id-1, ") than indicated in the header (", nb.loci, ")") stop(msg, call.=FALSE) } nb.fields <- rep(NA, length(lines)) for(line.id in 1:length(lines)){ tokens <- spl[[line.id]] nb.fields[line.id] <- length(tokens) if(length(tokens) > nb.inds + 1){ for(i in 2:(length(tokens)-nb.inds)){ if(length(grep(pattern="\\{", x=tokens[i])) > 0){ phase[line.id] <- tokens[i] } else if(length(grep(pattern="\\(", x=tokens[i])) > 0){ classif[line.id] <- tokens[i] } else seg[line.id] <- tokens[i] # only for "4way" type } } genotypes[line.id,] <- tokens[(length(tokens)-nb.inds+1):length(tokens)] } if(length(unique(nb.fields)) > 1) stop("some markers have more fields than others") genotypes <- t(genotypes) # individuals in rows, markers in columns ## convert all missing data to NA for(i in 1:length(genotypes)){ if(grepl(pattern="\\.", x=genotypes[i])) genotypes[i] <- gsub(pattern="\\.", replacement="-", x=genotypes[i]) if(grepl(pattern="u", x=genotypes[i])) genotypes[i] <- gsub(pattern="u", replacement="-", x=genotypes[i]) } genotypes[genotypes == "--"] <- NA ## convert segregation types and genotypes to new MapQtl format convert.seg <- FALSE new.seg.types <- c("", "", "", "", "") for(seg.type in unique(seg)) if(! seg.type %in% new.seg.types){ # e.g. convert.seg <- TRUE break } if(convert.seg){ if(pop.type != "4way"){ msg <- paste("can't convert genotypes from old to new format", "for 4way cross (yet)") stop(msg, call.=FALSE) } for(locus.id in 1:nb.loci){ if(seg[locus.id] %in% new.seg.types){ next } else if(seg[locus.id] == ""){ seg[locus.id] <- "" tmp <- which(genotypes[,locus.id] == "aa") genotypes[tmp, locus.id] <- "ee" tmp <- which(genotypes[,locus.id] == "ab") genotypes[tmp, locus.id] <- "ef" tmp <- which(genotypes[,locus.id] == "ac") genotypes[tmp, locus.id] <- "eg" tmp <- which(genotypes[,locus.id] == "bc") genotypes[tmp, locus.id] <- "fg" } else if(seg[locus.id] == ""){ seg[locus.id] <- "" tmp <- which(genotypes[,locus.id] == "aa") genotypes[tmp, locus.id] <- "hh" tmp <- which(genotypes[,locus.id] == "ab") genotypes[tmp, locus.id] <- "hk" tmp <- which(genotypes[,locus.id] == "bb") genotypes[tmp, locus.id] <- "kk" tmp <- which(genotypes[,locus.id] == "a-") genotypes[tmp, locus.id] <- "h-" tmp <- which(genotypes[,locus.id] == "b-") genotypes[tmp, locus.id] <- "k-" } else if(seg[locus.id] == ""){ seg[locus.id] <- "" tmp <- which(genotypes[,locus.id] == "aa") genotypes[tmp, locus.id] <- "ll" tmp <- which(genotypes[,locus.id] == "ab") genotypes[tmp, locus.id] <- "lm" } else if(seg[locus.id] == ""){ seg[locus.id] <- "" tmp <- which(genotypes[,locus.id] == "aa") genotypes[tmp, locus.id] <- "nn" tmp <- which(genotypes[,locus.id] == "ab") genotypes[tmp, locus.id] <- "np" } else{ msg <- paste("unrecognized segregation type", seg[locus.id], "at locus", locus.id) stop(msg, call.=FALSE) } } } ## check genotypes proper.genotypes <- c(NA, "ac", "ca", "ad", "da", "bc", "cb", "bd", "db", "ee", "ef", "fe", "eg", "ge", "fg", "gf", "hh", "hk", "kh", "kk", "h-", "k-", "ll", "lm", "ml", "nn", "np", "pn") for(genotype in unique(genotypes)) if(! genotype %in% proper.genotypes){ msg <- paste("unrecognized genotype", genotype) stop(msg, call.=FALSE) } ## replace all "ca" by "ac", etc -> speed-up next step? ## TODO ## convert genotypes to R/qtl code (mother=AB x father=CD) for(locus.id in 1:nb.loci){ if(phase[locus.id] == "{0-}"){ if(seg[locus.id] == ""){ # AB=lm ; CD=ll for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] == "ll"){ # AC or AD genotypes[ind.id,locus.id] <- 5 } else if(genotypes[ind.id,locus.id] %in% c("lm","ml")){ # BC or BD genotypes[ind.id,locus.id] <- 6 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id], "(should be )") stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{1-}"){ if(seg[locus.id] == ""){ # AB=ml ; CD=ll for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] == "ll"){ # BC or BD genotypes[ind.id,locus.id] <- 6 } else if(genotypes[ind.id,locus.id] %in% c("lm","ml")){ # AC or AD genotypes[ind.id,locus.id] <- 5 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id], "(should be )") stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{-0}"){ if(seg[locus.id] == ""){ # AB=nn ; CD=np for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] == "nn"){ # AC or BC genotypes[ind.id,locus.id] <- 7 } else if(genotypes[ind.id,locus.id] %in% c("np","pn")){ # AD or BD genotypes[ind.id,locus.id] <- 8 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id], "(should be )") stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{-1}"){ if(seg[locus.id] == ""){ # AB=nn ; CD=pn for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] == "nn"){ # AD or BD genotypes[ind.id,locus.id] <- 8 } else if(genotypes[ind.id,locus.id] %in% c("np","pn")){ # AC or BC genotypes[ind.id,locus.id] <- 7 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id], "(should be )") stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{00}"){ if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("ac","ca")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("ad","da")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("bc","cb")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("bd","db")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("ee")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("eg","ge")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("fe","ef")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("fg","gf")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("hh")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("hk","kh")){ # AD or BC genotypes[ind.id,locus.id] <- 10 } else if(genotypes[ind.id,locus.id] %in% c("kk")){ # BD genotypes[ind.id,locus.id] <- 4 } else if(genotypes[ind.id,locus.id] %in% c("h-","-h")){ # not BD genotypes[ind.id,locus.id] <- 14 } else if(genotypes[ind.id,locus.id] %in% c("k-","-k")){ # not AC genotypes[ind.id,locus.id] <- 11 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id]) stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{01}"){ if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("ad","da")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("ac","ca")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("bd","db")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("bc","cb")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("eg","ge")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("ee")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("fg","gf")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("fe","ef")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("hk","kh")){ # AC or BD genotypes[ind.id,locus.id] <- 9 } else if(genotypes[ind.id,locus.id] %in% c("hh")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("kk")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("h-","-h")){ # not BC genotypes[ind.id,locus.id] <- 12 } else if(genotypes[ind.id,locus.id] %in% c("k-","-k")){ # not AD genotypes[ind.id,locus.id] <- 13 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id]) stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{10}"){ if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("bc","cb")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("bd","db")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("ac","ca")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("ad","da")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("fe","ef")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("fg","gf")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("ee")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("eg","ge")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("kh","hk")){ # AC or BD genotypes[ind.id,locus.id] <- 9 } else if(genotypes[ind.id,locus.id] %in% c("kk")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("hh")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("h-","-h")){ # not AD genotypes[ind.id,locus.id] <- 13 } else if(genotypes[ind.id,locus.id] %in% c("k-","-k")){ # not BC genotypes[ind.id,locus.id] <- 12 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id]) stop(msg, call.=FALSE) } } else if(phase[locus.id] == "{11}"){ if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("bd","db")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("bc","cb")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("ad","da")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("ac","ca")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("fg","gf")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("fe","ef")){ # AD genotypes[ind.id,locus.id] <- 3 } else if(genotypes[ind.id,locus.id] %in% c("eg","ge")){ # BC genotypes[ind.id,locus.id] <- 2 } else if(genotypes[ind.id,locus.id] %in% c("ee")){ # BD genotypes[ind.id,locus.id] <- 4 } } } else if(seg[locus.id] == ""){ for(ind.id in 1:nb.inds){ if(is.na(genotypes[ind.id,locus.id])){ next } else if(genotypes[ind.id,locus.id] %in% c("kk")){ # AC genotypes[ind.id,locus.id] <- 1 } else if(genotypes[ind.id,locus.id] %in% c("kh","hk")){ # AD or BC genotypes[ind.id,locus.id] <- 10 } else if(genotypes[ind.id,locus.id] %in% c("hh")){ # BD genotypes[ind.id,locus.id] <- 4 } else if(genotypes[ind.id,locus.id] %in% c("h-","-h")){ # not AC genotypes[ind.id,locus.id] <- 11 } else if(genotypes[ind.id,locus.id] %in% c("k-","-k")){ # not BD genotypes[ind.id,locus.id] <- 14 } } } else{ msg <- paste("unrecognized segregation ", seg[locus.id], "at locus", locus.id, "with phase", phase[locus.id]) stop(msg, call.=FALSE) } } else{ msg <- paste("unrecognized phase", phase[locus.id], "at locus", locus.id) stop(msg, call.=FALSE) } } storage.mode(genotypes) <- "numeric" list(pop.name=pop.name, pop.type=pop.type, genotypes=genotypes, seg=seg, phase=phase, classif=classif) } ## returns a data.frame with 3 columns: chr (factor), marker (char), pos (num) read.cross.mq.map <- function(mapfile){ # read all lines lines <- readLines(mapfile, warn=FALSE) # remove comments lines <- vapply(strsplit(lines, ";"), "[", "", 1) # drop empty lines lines <- lines[!is.na(lines)] blank <- grep("^\\s*$", lines) if(length(blank) > 0) lines <- lines[-blank] # find groups grouplines <- grep("group", lines) # add lg name to end of each line for(i in seq(along=grouplines)) { # linkage group name groupname <- strsplit(lines[grouplines[i]], "\\s+")[[1]] groupname <- groupname[length(groupname)] first <- grouplines[i]+1 if(i==length(grouplines)) last <- length(lines) else last <- grouplines[i+1]-1 lines[first:last] <- paste(lines[first:last], groupname) } # drop initial lines if(grouplines[1] > 1) todrop <- 1:(grouplines[1]-1) else todrop <- NULL # also drop the group lines todrop <- c(todrop, grouplines) # now the actual dropping lines <- lines[-todrop] # split at white space spl <- strsplit(lines, "\\s+") # combine into a data frame genmap <- data.frame(chr=vapply(spl, "[", "", 3), marker=vapply(spl, "[", "", 1), pos=as.numeric(vapply(spl, "[", "", 2)), stringsAsFactors=FALSE) # make chr as factor genmap[,1] <- factor(genmap[,1], levels=unique(genmap[,1])) genmap } read.cross.mq.qua <- function(quafile){ nb.traits <- NULL nb.inds <- NULL miss <- NULL phenotypes <- NULL lines <- readLines(quafile, warn=FALSE) # remove comments lines <- vapply(strsplit(lines, ";"), "[", "", 1) # drop empty lines lines <- lines[!is.na(lines)] blank <- grep("^\\s*$", lines) if(length(blank) > 0) lines <- lines[-blank] ## extract the number of traits res <- mq_grab_param(lines, "ntrt", "Number of traits", "qua") nb.traits <- as.numeric(res[[1]]) todrop <- res[[2]] ## extract the number of individuals res <- mq_grab_param(lines, "nind", "Number of individuals", "qua") nb.inds <- as.numeric(res[[1]]) todrop <- c(todrop, res[[2]]) ## extract the symbol for missing values res <- mq_grab_param(lines, "miss", "Missing value code", "qua") miss <- res[[1]] todrop <- c(todrop, res[[2]]) lines <- lines[-todrop] spl <- strsplit(lines, "\\s+") ind.id <- 1 trait.id <- 1 trait.names <- c() for(line.id in 1:length(lines)){ tokens <- spl[[line.id]] if(trait.id <= nb.traits){ if(length(tokens) == 1){ # one trait name per line trait.names <- c(trait.names, tokens[1]) trait.id <- trait.id + 1 } else{ # all trait names on the same line trait.names <- tokens trait.id <- nb.traits + 1 } next } else if(trait.id > nb.traits && is.null(phenotypes)){ if(length(trait.names) != nb.traits){ msg <- paste("there seems to be fewer trait names (", length(trait.names), ") than indicated in the header (", nb.traits, ")", sep="") stop(msg, call.=FALSE) } phenotypes <- matrix(NA, nrow=nb.inds, ncol=nb.traits) } if(length(tokens) != nb.traits){ msg <- paste0("line ", line.id, " should have ", nb.traits, " column", ifelse(nb.traits > 1, "s", ""), " separated by spaces or tabs") stop(msg, call.=FALSE) } phenotypes[ind.id,] <- tokens ind.id <- ind.id + 1 } phenotypes[which(phenotypes == miss)] <- NA phenotypes <- as.data.frame(phenotypes) for(j in 1:ncol(phenotypes)) phenotypes[,j] <- tryCatch(expr=as.numeric(as.character(phenotypes[,j])), warning=function(w) as.factor(phenotypes[,j])) colnames(phenotypes) <- trait.names phenotypes } # end of read.cross.mq.R qtl/R/mqmplots.R0000644000176200001440000004772413626261114013272 0ustar liggesusers##################################################################### # # mqmplots.R # # Copyright (c) 2009-2020, Danny Arends # Copyright polyplot routine (c) 2009, Rutger Brouwer # # Modified by Pjotr Prins and Karl Broman # # # first written Februari 2009 # last modified Feb 2020 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: mqmplot.directedqtl # mqmplot.cistrans # addloctocross # polyplot # getThird # getChr # mqmplot.multitrait # mqmplot.permutations # mqmplot.singletrait # # # ##################################################################### mqmplot.directedqtl <- function(cross, mqmresult, pheno.col=1, draw = TRUE) { if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(!is.null(cross$mqm$Nind)){ stop("Augmented crossobject. Please supply the original unaugmented dataset.") } if(is.null(mqmresult)){ stop("No mqmresult object. Please supply a valid scanone object.") } if(!inherits(mqmresult, "scanone")){ stop("No mqmresult object. Please supply a valid scanone object.") } onlymarkers <- mqmextractmarkers(mqmresult) eff <- effectscan(sim.geno(cross),pheno.col=pheno.col,draw=FALSE) if(any(eff[,1]=="X")){ eff <- eff[-which(eff[,1]=="X"),] } onlymarkers[,3] <- onlymarkers[,3]*(eff[,3]/abs(eff[,3])) if(draw) plot(ylim=c((min(onlymarkers[,3])*1.1),(max(onlymarkers[,3])*1.1)),onlymarkers) class(onlymarkers) <- c("scanone",class(onlymarkers)) if(!is.null(attr(mqmresult,"mqmmodel"))) attr(onlymarkers,"mqmmodel") <- attr(mqmresult,"mqmmodel") invisible(onlymarkers) } mqmplot.heatmap <- function(cross, result, directed=TRUE, legend=FALSE, breaks = c(-100,-10,-3,0,3,10,100), col = c("darkblue","blue","lightblue","yellow","orange","red"), ...) { if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(directed && !is.null(cross$mqm$Nind)){ stop("Augmented crossobject. Please supply the original unaugmented dataset.") } if(is.null(result)){ stop("No result object. Please supply a valid scanone object.") } if(!inherits(result,"mqmmulti")){ stop("Not a mqmmulti object. Please supply a valid scanone object.") } cross <- sim.geno(cross) names <- NULL for(x in 1:nphe(cross)){ result[[x]] <- mqmextractpseudomarkers(result[[x]]) if(directed){ effect <- effectscan(sim.geno(cross,step=stepsize(result[[x]])), pheno.col=x, draw=FALSE) for(y in 1:nrow(result[[x]])){ effectid <- which(rownames(effect)==rownames(result[[x]])[y]) if(!is.na(effectid&&1)){ result[[x]][y,3] <- result[[x]][y,3] *(effect[effectid,3]/abs(effect[effectid,3])) } } } names <- c(names,substring(colnames(result[[x]])[3],5)) } chrs <- unique(lapply(result,getChr)) data <- NULL for(x in 1:length(result)){ data <- rbind(data,result[[x]][,3]) } rownames(data) <- names if(nphe(cross) < 100){ image(seq(0,nrow(result[[1]])),seq(0,nphe(cross)),t(data),xlab="Markers",ylab="Traits",breaks=breaks,col=col,yaxt="n",...) axis(2,at=seq(1,nphe(cross)),labels=colnames(pull.pheno(cross)),las=1) }else{ image(seq(0,nrow(result[[1]])),seq(0,nphe(cross)),t(data),xlab="Markers",ylab="Traits",breaks=breaks,col=col,...) } abline(v=0) for(x in unique(chrs[[1]])){ abline(v=sum(as.numeric(chrs[[1]])<=x)) } for(x in 1:nphe(cross)){ abline(h=x) } if(legend){ leg <- NULL for(x in 2:length(breaks)){ leg <- c(leg,paste("LOD",breaks[x-1],"to",breaks[x])) } legend("bottom",leg,col=col,lty=1,bg="white") } invisible(data) } mqmplot.clusteredheatmap <- function(cross, mqmresult, directed=TRUE, legend=FALSE, Colv=NA, scale="none", verbose=FALSE, breaks = c(-100,-10,-3,0,3,10,100), col = c("darkblue","blue","lightblue","yellow","orange","red"), ...) { if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(directed && !is.null(cross$mqm$Nind)){ stop("Augmented crossobject. Please supply the original unaugmented dataset.") } if(is.null(mqmresult)){ stop("No mqmresult object. Please supply a valid mqmmulti object.") } if(!inherits(mqmresult,"mqmmulti")){ stop("Not a mqmmulti object. Please supply a valid mqmmulti object.") } cross <- sim.geno(cross) names <- NULL for(x in 1:nphe(cross)){ mqmresult[[x]] <- mqmextractpseudomarkers(mqmresult[[x]]) if(directed){ effect <- effectscan(sim.geno(cross,step=stepsize(mqmresult[[x]])), pheno.col=x, draw=FALSE) if(verbose) cat(".") for(y in 1:nrow(mqmresult[[x]])){ effectid <- which(rownames(effect)==rownames(mqmresult[[x]])[y]) if(!is.na(effectid&&1)){ mqmresult[[x]][y,3] <- mqmresult[[x]][y,3] *(effect[effectid,3]/abs(effect[effectid,3])) } } } names <- c(names,substring(colnames(mqmresult[[x]])[3],5)) } if(verbose && directed) cat("\n") chrs <- unique(lapply(mqmresult,getChr)) data <- NULL for(x in 1:length(mqmresult)){ data <- rbind(data,mqmresult[[x]][,3]) } colnames(data) <- rownames(mqmresult[[1]]) rownames(data) <- names if(length(names) < 100){ retresults <- heatmap(data,Colv=Colv,scale=scale, xlab="Markers",main="Clustered heatmap",breaks=breaks,col=col,keep.dendro = TRUE, ...) }else{ retresults <- heatmap(data,Colv=Colv,scale=scale, xlab="Markers",main="Clustered heatmap",breaks=breaks,col=col,keep.dendro = TRUE,labRow=1:length(names), ...) } if(legend){ leg <- NULL for(x in 2:length(breaks)){ leg <- c(leg,paste("LOD",breaks[x-1],"to",breaks[x])) } legend("bottom",leg,col=col,lty=1,bg="white") } invisible(retresults) } mqmplot.cistrans <- function(result,cross,threshold=5,onlyPEAK=TRUE,highPEAK=FALSE,cisarea=10,pch=22,cex=0.5, verbose=FALSE, ...) { if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(is.null(cross$locations)){ stop("Please add trait locations to the cross file\n") } if(inherits(result, "mqmmulti")){ sum.map <- 0 chr.breaks <- NULL for(j in 1:nchr(cross)){ l.chr <- max(result[[1]][result[[1]][,1]==j,2]) chr.breaks <- c(chr.breaks,sum.map) sum.map <- sum.map+l.chr } sum.map <- ceiling(sum.map) if(verbose) cat("Total maplength:",sum.map," cM in ",nchr(cross),"Chromosomes\nThe lengths are:",chr.breaks,"\n") locations <- do.call(rbind,cross$locations) QTLs <- do.call(rbind,lapply(FUN=getThird,result)) colnames(QTLs) <- rownames(result[[1]]) bmatrix <- QTLs>threshold pmatrix <- NULL for(j in 1:nrow(QTLs)){ if(verbose && (j%%1000 == 0)) cat("QTL row:",j,"\n") temp <- as.vector(bmatrix[j,]) tempv <- QTLs[j,] value = 0 index = -1 for(l in 1:length(temp)){ if(temp[l]){ if( tempv[l] > value){ #New highest marker set the old index to false if(index != -1){ temp[index] <- FALSE } #and store the new one value = tempv[l] index <- l }else{ #Lower marker temp[l] <- FALSE } }else{ index = -1 value = 0 } } if(onlyPEAK){ bmatrix[j,] <- temp } if(highPEAK){ pmatrix <- rbind(pmatrix,temp) } } locz <- NULL for(marker in 1:ncol(QTLs)){ if(verbose && (j%%1000 == 0)) cat("QTL col:",marker,"\n") pos <- find.markerpos(cross, colnames(QTLs)[marker]) if(!is.na(pos[1,1])){ locz <- c(locz,round(chr.breaks[as.numeric(pos[[1]])] + as.numeric(pos[[2]]))) }else{ mark <- colnames(QTLs)[marker] mchr <- substr(mark,sum(regexpr("c",mark)+attr(regexpr("c",mark),"match.length")),regexpr(".loc",mark)-1) mpos <- as.numeric(substr(mark,sum(regexpr("loc",mark)+attr(regexpr("loc",mark),"match.length")),nchar(mark))) locz <- c(locz,round(chr.breaks[as.numeric(mchr)] + as.numeric(mpos))) } } axi <- 1:sum.map plot(x=axi,y=axi,type="n",main=paste("Cis/Trans QTL plot at LOD",threshold),xlab="Markers (in cM)",ylab="Location of traits (in cM)",xaxt="n",yaxt="n") trait.locz <- NULL for(j in 1:nrow(QTLs)){ if(verbose && (j%%10 == 0)) cat("QTL row:",j,"\n") values <- rep(NA,sum.map) aa <- locz[bmatrix[j,]] trait.locz <- c(trait.locz,chr.breaks[locations[j,1]] + locations[j,2]) values[aa] = chr.breaks[locations[j,1]] + locations[j,2] if(!highPEAK){ points(values,pch=pch,cex=cex) }else{ points(values,pch=24,cex=1.25*cex,col="black",bg="red") } } points(axi,type="l") points(axi+(cisarea/2),type="l",col="green") points(axi-(cisarea/2),type="l",col="green") chr.breaks <- c(chr.breaks,sum.map) axis(1,at=chr.breaks,labels=FALSE) axis(2,at=chr.breaks,labels=FALSE) axis(1,at=locz,line=1,pch=24) axis(2,at=seq(0,sum.map,25),line=1) }else{ stop("invalid object supplied\n") } } addloctocross <- function(cross,locations=NULL,locfile="locations.txt", verbose=FALSE) { if(is.null(cross)){ stop("No cross object. Please supply a valid cross object.") } if(is.null(locations)){ locations <- read.table(locfile,row.names=1,header=TRUE, stringsAsFactors=TRUE) } if(verbose) { cat("Phenotypes in cross:",nphe(cross),"\n") cat("Phenotypes in file:",nrow(locations),"\n") } if(max(as.numeric(rownames(locations))) != nphe(cross)){ stop("ID's of traits in file are larger than # of traits in crossfile.") } if(nphe(cross)==nrow(locations)){ locs <- vector(mode = "list", length = nphe(cross)) for(x in as.numeric(rownames(locations))){ if(names(cross$pheno)[x] == locations[x,1]){ locs[[x]] <- locations[x,2:3] rownames(locs[[x]]) <- locations[x,1] }else{ warning("Mismatch between name of trait in cross & file.\n") } } }else{ stop("Number of traits in cross & file don't match.") } cross$locations <- locs cross } polyplot <- function( x, type='b', legend=TRUE,legendloc=0, labels=NULL, cex = par("cex"), pch = 19, gpch = 21, bg = par("bg"), color = par("fg"), col=NULL, ylim=range(x[is.finite(x)]), xlim = NULL, main = NULL, xlab = NULL, ylab = NULL, add=FALSE, ... ) { #Addition by Danny Arends if(legend){ if(legendloc){ op <- par(mfrow = c(1,2)) }else{ op <- par(mfrow = c(1,1)) } }else{ op <- par(mfrow = c(1,1)) } #End of addition if ( is.vector(x) ) { x <- t( as.matrix(x) ) if (is.null(labels) ) { rownames(x) <- c("unspecified gene") } else { rownames(x) <- labels } } else { x <- as.matrix(x) } if (is.null(labels) ) labels = rownames( x ) if (is.null(col) ) col = rainbow( nrow(x),alpha=0.35 ) if (is.null(xlab) ) xlab="Markers" if (is.null(ylab) ) ylab="QTL (LOD)" timepoints <- as.numeric( colnames(x) ) tps <- sort( unique( timepoints ) ) if(is.null(xlim)) xlim = c(min(tps),max(tps)) plot.new() # make a new plot plot.window(xlim=xlim, ylim=ylim, log="") # add the plot windows size #grid() for( k in 1:nrow( x ) ) { max.p <- NULL # the expression of the maximum min.p <- NULL # med.p <- NULL # for( i in 1:length(tps)) { # idx <- ( 1:length( timepoints ) )[timepoints==tps[i] ] # get the indeces of the work <- x[k, idx] pmax <- max(work[is.finite(work)], na.rm=TRUE) pmin <- min(work[is.finite(work)], na.rm=TRUE) pmed <- median(work[is.finite(work)], na.rm=TRUE) max.p <- append(max.p, pmax) # min.p <- append(min.p, pmin) # med.p <- append(med.p, pmed) # } lines( x=tps, y=max.p, type='l', col=col[k] ) # add the lines if requested lines( x=tps, y=min.p, type='l', col=col[k] ) # add the lines if requested xp <- append(tps, rev(tps)) yp <- append(max.p, rev(min.p) ) polygon(xp, y=yp, col=col[k], border=FALSE) lines( x=tps, y=med.p, type='l', col=col[k] ) # add the lines if requested } axis(1) # add the x axis axis(2) # add the y axis title(main=main, xlab=xlab, ylab=ylab, ...) # add the title and axis labels #Addition by Danny Arends if (legend){ if(legendloc){ plot.new() } legend("topright", labels, col=col, pch=pch) # add a legend if requested } #End of addition op <- par(mfrow = c(1,1)) invisible() # return the plot } getThird <- function(x){ x[,3] } getChr <- function(x){ x[,1] } mqmplot.multitrait <- function(result, type=c("lines","image","contour","3Dplot"), group=NULL, meanprofile=c("none","mean","median"), theta=30, phi=15, ...) { #Helperfunction to plot mqmmulti objects made by doing multiple mqmscan runs (in a LIST) type <- match.arg(type) meanprofile <- match.arg(meanprofile) if(!inherits(result, "mqmmulti")){ stop("Wrong type of result file, please supply a valid mqmmulti object.") } n.pheno <- length(result) temp <- lapply(result,getThird) chrs <- unique(lapply(result,getChr)) qtldata <- do.call("rbind",temp) if(!is.null(group)){ qtldata <- qtldata[group,] colors <- rep("blue",n.pheno) }else{ group <- 1:n.pheno colors <- rainbow(n.pheno) } qtldata <- t(qtldata) if(type=="contour"){ #Countour plot contour(x=seq(1,dim(qtldata)[1]), y=seq(1,dim(qtldata)[2]), qtldata, xlab="Markers",ylab="Trait", ...) for(x in unique(chrs[[1]])){ abline(v=sum(as.numeric(chrs[[1]])<=x)) } } if(type=="image"){ #Image plot image(x=1:dim(qtldata)[1],y=1:dim(qtldata)[2],qtldata,xlab="Markers",ylab="Trait",...) for(x in unique(chrs[[1]])){ abline(v=sum(as.numeric(chrs[[1]])<=x)) } } if(type=="3Dplot"){ #3D perspective plot persp(x=1:dim(qtldata)[1],y=1:dim(qtldata)[2],qtldata, theta = theta, phi = phi, expand = 1, col="gray", xlab = "Markers", ylab = "Traits", zlab = "LOD score") } if(type=="lines"){ #Standard plotting option, Lineplot first <- TRUE for(i in group) { if(first){ plot(result[[i]],ylim=c(0,max(qtldata)),col=colors[i],lwd=1,ylab="LOD score",xlab="Markers",main="Multiple profiles", ...) first <- FALSE }else{ plot(result[[i]],add=TRUE,col=colors[i],lwd=1,...) } } if(meanprofile != "none"){ temp <- result[[1]] if(meanprofile=="median"){ temp[,3] <- apply(qtldata,1,median) legend("topright",c("QTL profiles","Median profile"),col=c("blue","black"),lwd=c(1,3)) } if(meanprofile=="mean"){ temp[,3] <- rowMeans(qtldata) legend("topright",c("QTL profiles","Mean profile"),col=c("blue","black"),lwd=c(1,3)) } plot(temp,add=TRUE,col="black",lwd=3,...) } } } mqmplot.permutations <- function(permutationresult, ...) { #Helperfunction to show mqmmulti objects made by doing multiple mqmscan runs (in a LIST) #This function should only be used for bootstrapped data matrix <- NULL row1 <- NULL row2 <- NULL i <- 1 if(!inherits(permutationresult, "mqmmulti")) ourstop("Wrong type of result file, please supply a valid mqmmulti object.") for( j in 1:length( permutationresult[[i]][,3] ) ) { row1 <- NULL row2 <- NULL for(i in 1:length( permutationresult ) ) { if(i==1){ row1 <- c(row1,rep(permutationresult[[i]][,3][j],(length( permutationresult )-1))) names(row1) <- rep(j,(length( permutationresult )-1)) }else{ row2 <- c(row2,permutationresult[[i]][,3][j]) } } names(row2) <- rep(j,(length( permutationresult )-1)) matrix <- cbind(matrix,rbind(row1,row2)) } rownames(matrix) <- c("QTL trait",paste("# of bootstraps:",length(permutationresult)-1)) #Because bootstrap only has 2 rows of data we can use black n blue polyplot(matrix,col=c(rgb(0,0,0,1),rgb(0,0,1,0.35)),...) #PLot some lines so we know what is significant perm.temp <- mqmprocesspermutation(permutationresult) #Create a permutation object numresults <- dim(permutationresult[[1]])[1] lines(x=1:numresults,y=rep(summary(perm.temp)[1,1],numresults),col="green",lwd=2,lty=2) lines(x=1:numresults,y=rep(summary(perm.temp)[2,1],numresults),col="blue",lwd=2,lty=2) chrs <- unique(lapply(permutationresult,getChr)) for(x in unique(chrs[[1]])){ abline(v=sum(as.numeric(chrs[[1]])<=x),lty="dashed",col="gray",lwd=1) } } mqmplot.singletrait <- function(result, extended=0,...) { #Helperfunction to show scanone objects made by doing mqmscan runs if(!inherits(result, "scanone")){ stop("Wrong type of result file, please supply a valid scanone (from MQM) object.") } if(is.null(result$"info")){ stop("Wrong type of result file, please supply a valid scanone (from MQM) object.") } if(is.null(attr(result,"mqmmodel"))){ op <- par(mfrow = c(1,1)) }else{ op <- par(mfrow = c(2,1)) } info.l <- result info.l[,3] <- result[,4] if(extended){ if(!is.null(attr(result,"mqmmodel"))){ plot(attr(result,"mqmmodel")) } plot(result,lwd=1,col=c("black"),ylab="QTL (LOD)",...) par(new=TRUE) plot(info.l,lwd=1,col=c("red"),ylab="QTL (LOD)",yaxt="n",lty=1,...) grid(length(result$chr),5) labels <- c(colnames(result)[3],"Information Content") mtext("Information Content",side=4,col="red",line=4) axis(4, ylim=c(0,1), col="red",col.axis="red",las=1) legend("right", labels,col=c("black","red"),lty=c(1,1,1)) }else{ if(!is.null(attr(result,"mqmmodel"))){ plot(attr(result,"mqmmodel")) } plot(result,lwd=1,ylab="QTL (LOD)",...) grid(length(result$chr),5) labels <- c(colnames(result)[3]) legend("right", labels,col=c("black","blue"),lty=c(1,1)) } op <- par(mfrow = c(1,1)) } # end of mqmplots.R qtl/R/util.R0000644000176200001440000045735314326316571012404 0ustar liggesusers##################################################################### # # util.R # # copyright (c) 2001-2022, Karl W Broman # [find.pheno, find.flanking, and a modification to create.map # from Brian Yandell] # last modified Oct, 2022 # first written Feb, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: markernames, c.cross, create.map, reduce2grid, # clean, clean.cross, drop.nullmarkers, nullmarkers # drop.markers, pull.markers, drop.dupmarkers # geno.table, genotab.em # mf.k, mf.h, imf.k, imf.h, mf.cf, imf.cf, mf.m, imf.m, # mf.stahl, imf.stahl # switch.order, flip.order, makeSSmap, # subset.cross, fill.geno, checkcovar, find.marker, # find.pseudomarker, # adjust.rf.ri, lodint, bayesint, # comparecrosses, movemarker, summary.map (aka summaryMap), # print.summary.map, find.pheno, # convert, convert.scanone, convert.scantwo # find.flanking, strip.partials, # qtlversion, locateXO, jittermap, getid, # find.markerpos, geno.crosstab, LikePheVector, # matchchr, convert2sa, charround, testchr, # scantwoperm2scanoneperm, subset.map, [.map, [.cross, # findDupMarkers, convert2riself, convert2risib, # switchAlleles, nqrank, cleanGeno, typingGap, # calcPermPval, phenames, updateParallelRNG # ###################################################################### ###################################################################### # # markernames # # pull out the marker names for selected chromosomes as one big vector # ###################################################################### markernames <- function(cross, chr) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) temp <- unlist(lapply(cross$geno, function(a) colnames(a$data))) names(temp) <- NULL temp } ###################################################################### # # chrnames # # pull out the chrnames for a cross # ###################################################################### chrnames <- function(cross) { names(cross$geno) } ###################################################################### # # create.map # # create a new map with inserted inter-marker locations # # Note: map is a vector or a matrix with 2 rows # # stepwidth = "fixed" is the original R/qtl version; # stepwidth="variable" is for Brian Yandell and the qtlbim package # stepwidth="max" creates the minimal number of inserted pseudomarkers # to have the maximum stepwidth = step ###################################################################### create.map <- function(map, step, off.end, stepwidth = c("fixed", "variable", "max")) { stepwidth <- match.arg(stepwidth) if(step<0 || off.end<0) stop("step and off.end must be > 0.") if(!is.matrix(map)) { # sex-ave map if(stepwidth == "variable") { if(off.end > 0) { tmp <- names(map) ## Append and prepend by off.end value (exact here, no roundoff). map <- c(map[1] - off.end, map, map[length(map)] + off.end) names(map) <- c("loc000", tmp, "loc999") } if(step == 0) return(unclass(map)) ## Determine differences and expansion vector. dif <- diff(map) expand <- pmax(1, floor(dif / step)) ## Create pseudomarker map. a <- min(map) + cumsum(c(0, rep(dif / expand, expand))) ## Names are marker names or locNNN. namesa <- paste("loc", seq(length(a)), sep = "") namesa[cumsum(c(1, expand))] <- names(map) names(a) <- namesa return(unclass(a)) } if(stepwidth == "max") { if(off.end > 0) { toadd <- c(map[1] - off.end, map[length(map)]+off.end) if(step==0) { names(toadd) <- paste("loc", 1:2, sep="") map <- sort(c(map, toadd)) return(unclass(map)) } nmap <- c(map[1] - off.end, map, map[length(map)]+off.end) } else { nmap <- map toadd <- NULL } if(step==0 || (length(map)==1 && off.end==0)) return(unclass(map)) d <- diff(nmap) nadd <- ceiling(d/step)-1 if(sum(nadd) > 0) { for(j in 1:(length(nmap)-1)) { if(nadd[j]>0) toadd <- c(toadd, seq(nmap[j], nmap[j+1], len=nadd[j]+2)[-c(1,nadd[j]+2)]) } } if(length(toadd) > 0) { names(toadd) <- paste("loc", 1:length(toadd), sep="") map <- sort(c(map, toadd)) } return(unclass(map)) } if(length(map) == 1) { # just one marker! if(off.end==0) { if(step == 0) step <- 1 nam <- names(map) map <- c(map,map+step) names(map) <- c(nam,paste("loc",step,sep="")) } else { if(step==0) m <- c(-off.end,off.end) else m <- seq(-off.end,off.end,by=step) m <- m[m!=0] names(m) <- paste("loc",m,sep="") map <- sort(c(m+map,map)) } return(map) } minloc <- min(map) map <- map-minloc if(step==0 && off.end==0) return(map+minloc) else if(step==0 && off.end > 0) { a <- c(floor(min(map)-off.end),ceiling(max(map)+off.end)) names(a) <- paste("loc", a, sep="") return(sort(c(a,map))+minloc) } else if(step>0 && off.end == 0) { a <- seq(floor(min(map)),max(map), by = step) if(any(is.na(match(a, map)))) { a <- a[is.na(match(a,map))] names(a) <- paste("loc",a,sep="") return(sort(c(a,map))+minloc) } else return(map+minloc) } else { a <- seq(floor(min(map)-off.end),ceiling(max(map)+off.end+step), by = step) a <- a[is.na(match(a,map))] # no more than one point above max(map)+off.end z <- (seq(along=a))[a >= max(map)+off.end] if(length(z) > 1) a <- a[-z[-1]] names(a) <- paste("loc",a,sep="") return(sort(c(a,map))+minloc) } } # end sex-ave map else { # sex-specific map if(stepwidth == "variable") { if(off.end > 0) { tmp <- colnames(map) map <- cbind(map[, 1] - off.end, map, map[, ncol(map)] + off.end) dimnames(map) <- list(NULL, c("loc000", tmp, "loc999")) } if(step == 0) return(unclass(map)) ## Determine differences and expansion vector. dif <- diff(map[1, ]) expand <- pmax(1, floor(dif / step)) ## Create pseudomarker map. a <- min(map[1, ]) + cumsum(c(0, rep(dif / expand, expand))) b <- min(map[2, ]) + cumsum(c(0, rep(diff(map[2, ]) / expand, expand))) namesa <- paste("loc", seq(length(a)), sep = "") namesa[cumsum(c(1, expand))] <- dimnames(map)[[2]] map <- rbind(a,b) dimnames(map) <- list(NULL, namesa) return(unclass(map)) } if(stepwidth == "max") { if(step==0 && off.end==0) return(unclass(map)) if(step==0 && off.end>0) { if(ncol(map)==1) { # only one marker; assume equal recomb in sexes L1 <- L2 <- 1 } else { L1 <- diff(range(map[1,])) L2 <- diff(range(map[2,])) } nam <- colnames(map) nmap1 <- c(map[1,1]-off.end, map[1,], map[1,ncol(map)]+off.end) nmap2 <- c(map[2,1]-off.end*L2/L1, map[2,], map[2,ncol(map)]+off.end*L2/L1) map <- rbind(nmap1, nmap2) colnames(map) <- c("loc1", nam, "loc2") return(unclass(map)) } if(ncol(map)==1) L1 <- L2 <- 1 else { L1 <- diff(range(map[1,])) L2 <- diff(range(map[2,])) } nam <- colnames(map) if(off.end > 0) { toadd1 <- c(map[1,1] - off.end, map[1,ncol(map)]+off.end) toadd2 <- c(map[2,1] + off.end*L2/L1, map[2,ncol(map)]+off.end*L2/L1) neword <- order(c(map[1,], toadd1)) nmap1 <- c(map[1,], toadd1)[neword] nmap2 <- c(map[2,], toadd2)[neword] } else { nmap1 <- map[1,] nmap2 <- map[2,] toadd1 <- toadd2 <- NULL } d <- diff(nmap1) nadd <- ceiling(d/step)-1 if(sum(nadd) > 0) { for(j in 1:(length(nmap1)-1)) { if(nadd[j]>0) { toadd1 <- c(toadd1, seq(nmap1[j], nmap1[j+1], len=nadd[j]+2)[-c(1,nadd[j]+2)]) toadd2 <- c(toadd2, seq(nmap2[j], nmap2[j+1], len=nadd[j]+2)[-c(1,nadd[j]+2)]) } } } newnam <- paste("loc", 1:length(toadd1), sep="") toadd1 <- sort(toadd1) toadd2 <- sort(toadd2) neword <- order(c(map[1,], toadd1)) nmap1 <- c(map[1,], toadd1)[neword] nmap2 <- c(map[2,], toadd2)[neword] map <- rbind(nmap1, nmap2) colnames(map) <- c(nam, newnam)[neword] return(unclass(map)) } minloc <- c(min(map[1,]),min(map[2,])) map <- unclass(map-minloc) markernames <- colnames(map) if(step==0 && off.end==0) return(map+minloc) else if(step==0 && off.end > 0) { map <- map+minloc if(ncol(map)==1) { # only one marker; assume equal recomb in sexes L1 <- L2 <- 1 } else { L1 <- diff(range(map[1,])) L2 <- diff(range(map[2,])) } nam <- colnames(map) nmap1 <- c(map[1,1]-off.end, map[1,], map[1,ncol(map)]+off.end) nmap2 <- c(map[2,1]-off.end*L2/L1, map[2,], map[2,ncol(map)]+off.end*L2/L1) map <- rbind(nmap1, nmap2) colnames(map) <- c("loc1", nam, "loc2") return(map) } else if(step>0 && off.end == 0) { if(ncol(map)==1) return(map+minloc) a <- seq(floor(min(map[1,])),max(map[1,]), by = step) a <- a[is.na(match(a,map[1,]))] if(length(a)==0) return(map+minloc) b <- sapply(a,function(x,y,z) { ZZ <- min((seq(along=y))[y > x]) (x-y[ZZ-1])/(y[ZZ]-y[ZZ-1])*(z[ZZ]-z[ZZ-1])+z[ZZ-1] }, map[1,],map[2,]) m1 <- c(a,map[1,]) m2 <- c(b,map[2,]) names(m1) <- names(m2) <- c(paste("loc",a,sep=""),markernames) return(rbind(sort(m1),sort(m2))+minloc) } else { a <- seq(floor(min(map[1,])-off.end),ceiling(max(map[1,])+off.end+step), by = step) a <- a[is.na(match(a,map[1,]))] # no more than one point above max(map)+off.end z <- (seq(along=a))[a >= max(map[1,])+off.end] if(length(z) > 1) a <- a[-z[-1]] b <- sapply(a,function(x,y,z,ml) { if(x < min(y)) { return(min(z) - (min(y)-x)/diff(range(y))*diff(range(z)) - ml) } else if(x > max(y)) { return(max(z) + (x - max(y))/diff(range(y))*diff(range(z)) - ml) } else { ZZ <- min((seq(along=y))[y > x]) (x-y[ZZ-1])/(y[ZZ]-y[ZZ-1])*(z[ZZ]-z[ZZ-1])+z[ZZ-1] } }, map[1,],map[2,], minloc[2]) m1 <- c(a,map[1,]) m2 <- c(b,map[2,]) names(m1) <- names(m2) <- c(paste("loc",a,sep=""),markernames) return(rbind(sort(m1),sort(m2))+minloc) } } } ###################################################################### # reduce2grid # # for high-density marker data, rather than run scanone at both the # markers and at a set of pseudomarkers, we could reduce to just # a set of evenly-spaced pseudomarkers # # first run calc.genoprob (or sim.geno) and then use this. ###################################################################### reduce2grid <- function(cross) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # sample one element from a vector sampleone <- function(x) ifelse(length(x)==1, x, sample(x, 1)) # for a map containing a grid with a given step size, # find the grid min(map), min(map)+step, min(map)+2step, ... gridindex <- function(map, step) { if(is.matrix(map)) stop("reduce2grid isn't working for sex-specific maps") grid <- seq(min(map), max(map), by=step) index <- match(grid, map) if(any(is.na(index))) index <- sapply(grid, function(a,b) { d <- abs(a-b); sampleone(which(d == min(d))) }, map) index } attr2fix <- c("error.prob", "step", "off.end", "map.function", "stepwidth") reduced <- FALSE if("prob" %in% names(cross$geno[[1]])) { stepwidth <- attr(cross$geno[[1]]$prob, "stepwidth") if(stepwidth != "fixed") { warning("You need to have run calc.genoprob with stepwidth=\"fixed\".") } else { step <- attr(cross$geno[[1]]$prob, "step") for(i in 1:nchr(cross)) { pr <- cross$geno[[i]]$prob map <- attr(pr, "map") butes <- attributes(pr) reduced <- gridindex(map, step) pr <- pr[,reduced,,drop=FALSE] attr(pr, "map") <- map[reduced] for(a in attr2fix) attr(pr, a) <- butes[[a]] attr(pr, "reduced2grid") <- TRUE cross$geno[[i]]$prob <- pr } reduced <- TRUE } } if("draws" %in% names(cross$geno[[1]])) { stepwidth <- attr(cross$geno[[1]]$draws, "stepwidth") if(stepwidth != "fixed") { warning("You need to have run sim.geno with stepwidth=\"fixed\".") } else { step <- attr(cross$geno[[1]]$draws, "step") for(i in 1:nchr(cross)) { dr <- cross$geno[[i]]$draws map <- attr(dr, "map") butes <- attributes(dr) reduced <- gridindex(map, step) dr <- dr[,reduced,,drop=FALSE] attr(dr, "map") <- map[reduced] for(a in attr2fix) attr(dr, a) <- butes[[a]] attr(dr, "reduced2grid") <- TRUE cross$geno[[i]]$draws <- dr } reduced <- TRUE } } if(!reduced) warning("You first need to run calc.genoprob or sim.geno with stepwidth=\"fixed\".") cross } ###################################################################### # clean functions ###################################################################### clean <- function(object, ...) UseMethod("clean") ###################################################################### # # clean.cross # # remove all of the extraneous stuff from a cross object, to get back # to just the data # ###################################################################### clean.cross <- function(object, ...) { if(!inherits(object, "cross")) stop("Input should have class \"cross\".") cross2 <- list(geno=object$geno,pheno=object$pheno) if("cross" %in% names(object)) cross2$cross <- object$cross if("founderGeno" %in% names(object)) cross2$founderGeno <- object$founderGeno if(!is.null(attr(object, "alleles"))) attr(cross2, "alleles") <- attr(object, "alleles") if(!is.null(attr(object, "scheme"))) attr(cross2, "scheme") <- attr(object, "scheme") for(i in 1:length(object$geno)) { cross2$geno[[i]] <- list(data=object$geno[[i]]$data, map=object$geno[[i]]$map) class(cross2$geno[[i]]) <- class(object$geno[[i]]) } class(cross2) <- class(object) cross2 } ###################################################################### # # drop.qtlgeno # # remove any QTLs from the genotype data and the genetic maps # from data simulated via sim.cross. (They all have names "QTL*") # ###################################################################### #drop.qtlgeno <- #function(cross) #{ # n.chr <- nchr(cross) # mar.names <- lapply(cross$geno, function(a) { # m <- a$map # if(is.matrix(m)) return(colnames(m)) # else return(names(m)) } ) # # for(i in 1:n.chr) { # o <- grep("^QTL[0-9]+",mar.names[[i]]) # if(length(o) != 0) { # cross$geno[[i]]$data <- cross$geno[[i]]$data[,-o,drop=FALSE] # if(is.matrix(cross$geno[[i]]$map)) # cross$geno[[i]]$map <- cross$geno[[i]]$map[,-o,drop=FALSE] # else # cross$geno[[i]]$map <- cross$geno[[i]]$map[-o] # } # } # cross #} ###################################################################### # # drop.nullmarkers # # remove markers that have no genotype data from the data matrix and # genetic maps # ###################################################################### drop.nullmarkers <- function(cross) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") n.chr <- nchr(cross) keep.chr <- rep(TRUE,n.chr) for(i in 1:n.chr) { o <- !apply(cross$geno[[i]]$data,2,function(a) sum(!is.na(a))) if(any(o)) { # remove from genotype data and map mn.drop <- colnames(cross$geno[[i]]$data)[o] if(length(mn.drop) == ncol(cross$geno[[i]]$data)) keep.chr[i] <- FALSE # removing all markers from this chromosome cross$geno[[i]]$data <- cross$geno[[i]]$data[,!o,drop=FALSE] if(is.matrix(cross$geno[[i]]$map)) cross$geno[[i]]$map <- cross$geno[[i]]$map[,!o,drop=FALSE] else cross$geno[[i]]$map <- cross$geno[[i]]$map[!o] # results of calc.genoprob if("prob" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$prob)) cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,-o,,drop=FALSE] } # results of argmax.geno if("argmax" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$argmax)) cross$geno[[i]]$argmax <- cross$geno[[i]]$argmax[,-o,drop=FALSE] } # results of sim.geno if("draws" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$draws)) cross$geno[[i]]$draws <- cross$geno[[i]]$draws[,-o,,drop=FALSE] } # results of est.rf if("rf" %in% names(cross)) { attrib <- attributes(cross$rf) o <- match(mn.drop,colnames(cross$rf)) cross$rf <- cross$rf[-o,-o] if("onlylod" %in% names(attrib)) # save the onlylod attribute if its there attr(cross$rf, "onlylod") <- attrib$onlylod } } } cross$geno <- cross$geno[keep.chr] if("founderGeno" %in% names(cross)) cross$founderGeno <- cross$founderGeno[,markernames(cross)] cross } ###################################################################### # # nullmarkers # # identify markers that have no genotype data from the data matrix and # genetic maps # ###################################################################### nullmarkers <- function(cross) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") n.chr <- nchr(cross) keep.chr <- rep(TRUE,n.chr) all2drop <- NULL for(i in 1:n.chr) { o <- !apply(cross$geno[[i]]$data,2,function(a) sum(!is.na(a))) if(any(o)) { # remove from genotype data and map mn.drop <- colnames(cross$geno[[i]]$data)[o] all2drop <- c(all2drop, mn.drop) } } all2drop } ###################################################################### # # drop.markers # # remove a vector of markers from the data matrix and genetic maps # ###################################################################### drop.markers <- function(cross, markers) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") n.chr <- nchr(cross) keep.chr <- rep(TRUE,n.chr) found <- rep(FALSE, length(markers)) for(i in 1:n.chr) { # find markers on this chromosome o <- match(markers,colnames(cross$geno[[i]]$data)) found[!is.na(o)] <- TRUE o <- o[!is.na(o)] a <- rep(FALSE,ncol(cross$geno[[i]]$data)) a[o] <- TRUE o <- a if(any(o)) { # remove from genotype data and map mn.drop <- colnames(cross$geno[[i]]$data)[o] if(length(mn.drop) == ncol(cross$geno[[i]]$data)) keep.chr[i] <- FALSE # removing all markers from this chromosome cross$geno[[i]]$data <- cross$geno[[i]]$data[,!o,drop=FALSE] if(is.matrix(cross$geno[[i]]$map)) cross$geno[[i]]$map <- cross$geno[[i]]$map[,!o,drop=FALSE] else cross$geno[[i]]$map <- cross$geno[[i]]$map[!o] # results of calc.genoprob if("prob" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$prob)) cross$geno[[i]]$prob <- cross$geno[[i]]$prob[,-o,,drop=FALSE] } # results of argmax.geno if("argmax" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$argmax)) cross$geno[[i]]$argmax <- cross$geno[[i]]$argmax[,-o,drop=FALSE] } # results of sim.geno if("draws" %in% names(cross$geno[[i]])) { o <- match(mn.drop,colnames(cross$geno[[i]]$draws)) cross$geno[[i]]$draws <- cross$geno[[i]]$draws[,-o,,drop=FALSE] } # results of est.rf if("rf" %in% names(cross)) { attrib <- attributes(cross$rf) o <- match(mn.drop,colnames(cross$rf)) cross$rf <- cross$rf[-o,-o] if("onlylod" %in% names(attrib)) attr(cross$rf, "onlylod") <- attrib$onlylod } } } if(sum(keep.chr) == 0) stop("You're attempting to drop *all* of the markers, which isn't allowed.") if(any(!found)) warning("Markers not found: ", paste(markers[!found],collapse=" ")) cross$geno <- cross$geno[keep.chr] if("founderGeno" %in% names(cross)) cross$founderGeno <- cross$founderGeno[,markernames(cross)] cross } ###################################################################### # pull.markers # # like drop.markers, but retain just those indicated ###################################################################### pull.markers <- function(cross, markers) { mn <- markernames(cross) m <- match(markers, mn) if(any(is.na(m))) warning("Some markers couldn't be found: ", paste(markers[is.na(m)], collapse=" ")) drop.markers(cross, mn[is.na(match(mn, markers))]) } ###################################################################### # drop.dupmarkers # # drop duplicate markers, retaining the consensus genotypes ###################################################################### drop.dupmarkers <- function(cross, verbose=TRUE) { mn <- markernames(cross) tab <- table(mn) if(all(tab==1)) { if(verbose) cat("No duplicate markers.\n") return(cross) } dup <- names(tab[tab > 1]) if(verbose) cat(" ", length(dup), "duplicate markers\n") # get consensus genotypes g <- pull.geno(cross)[,!is.na(match(mn, dup))] ng.omitted <- rep(NA, length(dup)) tot.omitted <- 0 nmar.omitted <- 0 for(i in seq(along=dup)) { gg <- g[,colnames(g)==dup[i],drop=FALSE] res <- apply(gg, 1, function(a) { if(all(is.na(a))) return(c(NA, 0)) a <- unique(a[!is.na(a)]) if(length(a)==1) return(c(a, 0)) return(c(NA, 1)) } ) if(verbose>1) { cat(" ", dup[i], ":\t", sum(res[2,]), " genotypes omitted\n", sep="") if(sum(res[2,]) > 1) cat(" ", paste(which(res[2,]>0), collapse=" "), "\n") } tot.omitted <- tot.omitted + sum(res[2,]) flag <- FALSE for(j in seq(along=cross$geno)) { mn <- colnames(cross$geno[[j]]$data) wh <- mn==dup[i] if(!any(wh)) next wh <- which(wh) if(!flag) { flag <- TRUE cross$geno[[j]]$data[,wh[1]] <- res[1,] if(length(wh)==1) next else wh <- wh[-1] } if(length(wh) > 0) { nmar.omitted <- nmar.omitted + length(wh) cross$geno[[j]]$data <- cross$geno[[j]]$data[,-wh,drop=FALSE] if(is.matrix(cross$geno[[j]]$map)) cross$geno[[j]]$map <- cross$geno[[j]]$map[,-wh,drop=FALSE] else cross$geno[[j]]$map <- cross$geno[[j]]$map[-wh] } } } if(verbose) { cat(" Total genotypes omitted:", tot.omitted, "\n") cat(" Total markers omitted: ", nmar.omitted, "\n") } if("founderGeno" %in% names(cross)) cross$founderGeno <- cross$founderGeno[,markernames(cross)] clean(cross) } ###################################################################### # # geno.table # # create table showing observed numbers of individuals with each # genotype at each marker # ###################################################################### geno.table <- function(cross, chr, scanone.output=FALSE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) n.chr <- nchr(cross) type <- crosstype(cross) is.bcs <- type == "bcsft" cross.scheme <- attr(cross, "scheme") if(is.bcs) is.bcs <- (cross.scheme[2] == 0) chr_type <- sapply(cross$geno, chrtype) allchrtype <- rep(chr_type, nmar(cross)) chrname <- names(cross$geno) allchrname <- rep(chrname, nmar(cross)) ## Actually plan to have our own geno.table.bcsft routine. if(type == "f2" || (type == "bcsft" && !is.bcs)) { n.gen <- 5 temp <- getgenonames("f2", "A", cross.attr=attributes(cross)) gen.names <- c(temp, paste("not", temp[c(3,1)])) } else if(type %in% c("bc", "riself", "risib", "dh", "haploid", "bcsft")) { n.gen <- 2 gen.names <- getgenonames(type, "A", cross.attr=attributes(cross)) } else if(type == "4way") { n.gen <- 14 temp <- getgenonames("4way", "A", cross.attr=attributes(cross)) gen.names <- c(temp, paste(temp[c(1,3)], collapse="/"), paste(temp[c(2,4)], collapse="/"), paste(temp[c(1,2)], collapse="/"), paste(temp[c(3,4)], collapse="/"), paste(temp[c(1,4)], collapse="/"), paste(temp[c(2,3)], collapse="/"), paste("not", temp[1]), paste("not", temp[2]), paste("not", temp[3]), paste("not", temp[4])) gen.names[5:8] <- substr(temp[c(1,2,1,3)], c(1,1,2,2), c(1,1,2,2)) } else stop("Unknown cross type: ",type) res <- lapply(cross$geno, function(a,ngen) { a <- a$data; a[is.na(a)] <- 0 apply(a,2,function(b,ngen) table(factor(b,levels=0:ngen)),ngen) },n.gen) results <- NULL for(i in 1:length(res)) results <- rbind(results,t(res[[i]])) colnames(results) <- c("missing",gen.names) rownames(results) <- unlist(lapply(cross$geno,function(a) colnames(a$data))) pval <- rep(NA,nrow(results)) if(type %in% c("bc","risib","riself","dh","haploid") || (type=="bcsft" & is.bcs)) { sexpgm <- getsex(cross) if((type == "bc" || type=="bcsft") && any(chr_type == "X") && !is.null(sexpgm$sex) && any(sexpgm$sex==1)) { for(i in which(allchrtype=="A")) { x <- results[i,2:3] if(sum(x) > 0) pval[i] <- chisq.test(x,p=c(0.5,0.5))$p.value else pval[i] <- 1 } gn <- getgenonames("bc","X", "full", sexpgm, attributes(cross)) wh <- which(is.na(match(gn, colnames(results)))) temp <- matrix(0, nrow=nrow(results), ncol=length(wh)) colnames(temp) <- gn[wh] results <- cbind(results, temp) for(i in which(chr_type=="X")) { dat <- reviseXdata("bc", "full", sexpgm, geno=cross$geno[[i]]$data, cross.attr=attributes(cross)) dat[is.na(dat)] <- 0 tab <- t(apply(dat, 2, function(x) table(factor(x, levels=0:length(gn))))) colnames(tab) <- c("missing", gn) results[allchrname==chrname[i],] <- 0 results[allchrname==chrname[i],colnames(tab)] <- tab for(j in 1:ncol(dat)) { stat <- apply(table(sexpgm$sex, cross$geno[[i]]$data[,j]),1, function(a) if(length(a) > 1 && sum(a)>0) return(chisq.test(a,p=c(0.5,0.5))$stat) else return(0)) pval[allchrname==chrname[i]][j] <- 1-pchisq(sum(stat),length(stat)) } } results <- cbind(results, P.value=pval) } else { for(i in 1:length(pval)) { x <- results[i,2:3] if(sum(x) > 0) pval[i] <- chisq.test(x,p=c(0.5,0.5))$p.value else pval[i] <- 1 } results <- cbind(results, P.value=pval) } } else if(type == "f2" || (type == "bcsft" && !is.bcs)) { sexpgm <- getsex(cross) ## F2 with set initial genotype probabilities. init.geno <- c(0.25,0.5,0.25,0.75,0.75) ## BCsFt initial genotype probabilities need to be computed. if(type == "bcsft") { ret <- .C("genotab_em_bcsft", as.integer(cross.scheme), init.geno = as.double(init.geno)) init.geno <- ret$init.geno } for(i in which(allchrtype=="A")) { dat <- results[i,2:6] if(sum(dat)==0) pval[i] <- 1 else if(dat[4]==0 && dat[5]==0) pval[i] <- chisq.test(dat[1:3], p=init.geno[1:3] )$p.value else if(all(dat[2:4]==0)) pval[i] <- chisq.test(dat[c(1,5)],p=init.geno[c(1,5)])$p.value else if(all(dat[c(1,2,5)]==0)) pval[i] <- chisq.test(dat[3:4], p=init.geno[3:4] )$p.value else { # this is harder: some dominant and some not pval[i] <- genotab.em(dat, init.geno) } } for(i in which(chr_type=="X")) { gn <- getgenonames("f2","X","full", getsex(cross), attributes(cross)) wh <- which(is.na(match(gn, colnames(results)))) temp <- matrix(0, nrow=nrow(results), ncol=length(wh)) colnames(temp) <- gn[wh] results <- cbind(results, temp) dat <- reviseXdata("f2", "full", sexpgm, geno=cross$geno[[i]]$data, cross.attr=attributes(cross)) dat[is.na(dat)] <- 0 tab <- t(apply(dat, 2, function(x) table(factor(x, levels=0:length(gn))))) colnames(tab) <- c("missing", gn) results[allchrname==chrname[i],] <- 0 results[allchrname==chrname[i],colnames(tab)] <- tab cn <- colnames(results) f <- grep("f$", cn) r <- grep("r$", cn) if(length(f)>0 && length(r)>0) { results <- results[,c(1:2,f,3,r,(1:ncol(results))[-c(1:3,f,r)])] colnames(results) <- cn[c(1:2,f,3,r,(1:ncol(results))[-c(1:3,f,r)])] } sex <- sexpgm$sex pgm <- sexpgm$pgm for(j in 1:ncol(dat)) { g <- cross$geno[[i]]$data[,j] if(!is.null(sex)) { if(!is.null(pgm)) g <- matrix(as.numeric(table(g,sex,pgm)),ncol=2,byrow=TRUE) else g <- matrix(as.numeric(table(g,sex)),ncol=2,byrow=TRUE) } else { if(!is.null(pgm)) { g <- matrix(as.numeric(table(g,pgm)),ncol=2,byrow=TRUE) } else g <- matrix(table(g),ncol=2,byrow=TRUE) } stat <- apply(g, 1, function(a) if(sum(a)>0) return(chisq.test(a,p=c(0.5,0.5))$stat) else return(0)) pval[allchrname==chrname[i]][j] <- 1-pchisq(sum(stat),length(stat)) } } results <- cbind(results, P.value=pval) } else if(type == "4way") { for(i in 1:length(pval)) { x <- results[i,2:5] y <- results[i,-(1:5)] if(sum(x) > 0 && sum(y)==0) pval[i] <- chisq.test(x,p=c(0.25,0.25,0.25,0.25))$p.value else { if(allchrtype[i] == "A") { res <- results[i,-1] if(all(res==0)) pval[i] <- 1 # entirely missing else if(all(res[-c(1,11)]==0)) # AC/not AC pval[i] <- chisq.test(res[c(1,11)], p=c(0.25, 0.75))$p.value else if(all(res[-c(2,12)]==0)) # BC/not BC pval[i] <- chisq.test(res[c(2,12)], p=c(0.25, 0.75))$p.value else if(all(res[-c(3,13)]==0)) # AD/not AD pval[i] <- chisq.test(res[c(3,13)], p=c(0.25, 0.75))$p.value else if(all(res[-c(4,14)]==0)) # BD/not BD pval[i] <- chisq.test(res[c(4,14)], p=c(0.25, 0.75))$p.value else if(all(res[-c(5,6)]==0)) # A/B pval[i] <- chisq.test(res[c(5,6)], p=c(0.5, 0.5))$p.value else if(all(res[-c(7,8)]==0)) # C/D pval[i] <- chisq.test(res[c(7,8)], p=c(0.5, 0.5))$p.value else if(all(res[-c(9,10)]==0)) # AC/BD or AD/BC pval[i] <- chisq.test(res[c(9,10)], p=c(0.5, 0.5))$p.value else if(all(res[-c(2,4,5)]==0)) # BC/BD/A pval[i] <- chisq.test(res[c(2,4,5)], p=c(0.25, 0.25, 0.5))$p.value else if(all(res[-c(1,3,6)]==0)) # AC/AD/B pval[i] <- chisq.test(res[c(1,3,6)], p=c(0.25, 0.25, 0.5))$p.value else if(all(res[-c(3,4,7)]==0)) # AD/BD/C pval[i] <- chisq.test(res[c(3,4,7)], p=c(0.25, 0.25, 0.5))$p.value else if(all(res[-c(1,2,8)]==0)) # AC/BC/D pval[i] <- chisq.test(res[c(1,2,8)], p=c(0.25, 0.25, 0.5))$p.value else if(all(res[-c(2,3,9)]==0)) # AC/BD or AD or BC pval[i] <- chisq.test(res[c(2,3,9)], p=c(0.25, 0.25, 0.5))$p.value else if(all(res[-c(1,4,10)]==0)) # AD/BC or AC or BD pval[i] <- chisq.test(res[c(1,4,10)], p=c(0.25, 0.25, 0.5))$p.value } } } results <- cbind(results, P.value=pval) } if(!scanone.output) return(data.frame(chr=rep(names(cross$geno),nmar(cross)),results, stringsAsFactors=TRUE)) themap <- pull.map(cross) if(is.matrix(themap[[1]])) thepos <- unlist(lapply(themap, function(a) a[1,])) else thepos <- unlist(themap) temp <- results[,1:(ncol(results)-1),drop=FALSE] res <- data.frame(chr=rep(names(cross$geno),nmar(cross)), pos=thepos, neglog10P=-log10(results[,ncol(results)]), missing=temp[,1]/apply(temp, 1, sum), temp[,-1]/apply(temp[,-1], 1, sum), stringsAsFactors=TRUE) class(res) <- c("scanone", "data.frame") rownames(res) <- rownames(results) res[,1] <- factor(as.character(res[,1]), levels=unique(as.character(res[,1]))) res } genotab.em <- function(dat, init.geno, tol=1e-6, maxit=10000, verbose=FALSE) { genotab.ll <- function(dat, gam, init.geno) { p <- c(init.geno[1]*(1-gam[2]), init.geno[2]*gam[1], init.geno[3]*(1-gam[3]), gam[2]*init.geno[4], gam[3]*init.geno[5]) if(any(p==0 & dat > 0)) return(-Inf) return( sum((dat*log(p))[dat>0 & p>0]) ) } n <- sum(dat) gam <- c(sum(dat[1:3]), dat[4], dat[5])/n curll <- genotab.ll(dat, gam, init.geno) flag <- 0 if(verbose) cat(0, gam, curll, "\n") for(i in 1:maxit) { # estep zAA <- dat[1]*gam[3]/(gam[1]+gam[3]) zBB <- dat[3]*gam[2]/(gam[1]+gam[2]) # mstep gamnew <- c(sum(dat[1:3])-zAA-zBB, dat[4]+zBB, dat[5]+zAA)/n newll <- genotab.ll(dat, gamnew, init.geno) if(verbose) cat(i, gamnew, newll, "\n") if(abs(curll-newll) < tol) { flag <- 1 break } gam <- gamnew curll <- newll } if(!flag) warning("Didn't converge.") gam <- gamnew p <- c(init.geno[1]*(1-gam[2]), init.geno[2]*gam[1], init.geno[3]*(1-gam[3]), gam[2]*init.geno[4], gam[3]*init.geno[5]) ex <- p*n 1-pchisq(sum(((dat-ex)^2/ex)[ex>0]), 2) } ###################################################################### # geno.crosstab # # Get a cross-tabulation of the genotypes at two markers, # with the markers specified by name ###################################################################### geno.crosstab <- function(cross, mname1, mname2, eliminate.zeros=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(missing(mname2) && length(mname1)>1) { mname2 <- mname1[2] mname1 <- mname1[1] } if(length(mname1) > 1 || length(mname2) > 1) stop("mname1 and mname2 should both have lenght 1, or mname1 should have length 2 and mname1 should be missing.") if(mname1==mname2) stop("You must give two distinct marker names.") pos <- find.markerpos(cross, c(mname1, mname2)) if(any(is.na(pos$chr))) { if(all(is.na(pos$chr))) stop("Markers ", mname1, " and ", mname2, " not found.") else stop("Marker ", rownames(pos)[is.na(pos$chr)], " not found.") } chr_type <- sapply(cross$geno[pos$chr], chrtype) crosstype <- crosstype(cross) g1 <- pull.geno(cross, pos$chr[1])[,mname1, drop=FALSE] g2 <- pull.geno(cross, pos$chr[2])[,mname2, drop=FALSE] if(chr_type[1] == "X") g1 <- reviseXdata(crosstype, "full", getsex(cross), geno=g1, cross.attr=attributes(cross)) if(chr_type[2] == "X") g2 <- reviseXdata(crosstype, "full", getsex(cross), geno=g2, cross.attr=attributes(cross)) g1[is.na(g1)] <- 0 g2[is.na(g2)] <- 0 g1names <- getgenonames(crosstype, chr_type[1], "full", getsex(cross), attributes(cross)) g2names <- getgenonames(crosstype, chr_type[2], "full", getsex(cross), attributes(cross)) if(chr_type[1] != "X") { if(crosstype == "f2") g1names <- c(g1names, paste("not", g1names[c(3,1)])) else if(crosstype == "bc" || crosstype == "risib" || crosstype=="riself" || crosstype=="dh" || crosstype=="haploid") { } else if(crosstype == "4way") { temp <- g1names g1names <- c(temp, paste(temp[c(1,3)], collapse="/"), paste(temp[c(2,4)], collapse="/"), paste(temp[c(1,2)], collapse="/"), paste(temp[c(3,4)], collapse="/"), paste(temp[c(1,4)], collapse="/"), paste(temp[c(2,3)], collapse="/"), paste("not", temp[1]), paste("not", temp[2]), paste("not", temp[3]), paste("not", temp[4])) g1names[5:8] <- substr(temp[c(1,2,1,3)], c(1,1,2,2), c(1,1,2,2)) } else stop("Unknown cross type: ",crosstype) } if(chr_type[2] != "X") { if(crosstype == "f2") g2names <- c(g2names, paste("not", g2names[c(3,1)])) else if(crosstype == "bc" || crosstype == "risib" || crosstype=="riself" || crosstype=="dh" || crosstype=="haploid") { } else if(crosstype == "4way") { temp <- g2names g2names <- c(temp, paste(temp[c(1,3)], collapse="/"), paste(temp[c(2,4)], collapse="/"), paste(temp[c(1,2)], collapse="/"), paste(temp[c(3,4)], collapse="/"), paste(temp[c(1,4)], collapse="/"), paste(temp[c(2,3)], collapse="/"), paste("not", temp[1]), paste("not", temp[2]), paste("not", temp[3]), paste("not", temp[4])) g2names[5:8] <- substr(temp[c(1,2,1,3)], c(1,1,2,2), c(1,1,2,2)) } else stop("Unknown cross type: ",crosstype) } g1names <- c("-", g1names) g2names <- c("-", g2names) g1 <- as.character(g1) g2 <- as.character(g2) for(i in 1:length(g1names)) { j <- as.character(i-1) g1[g1==j] <- g1names[i] } g1 <- factor(g1, levels=g1names) for(i in 1:length(g2names)) { j <- as.character(i-1) g2[g2==j] <- g2names[i] } g2 <- factor(g2, levels=g2names) tab <- table(g1, g2) names(attributes(tab)$dimnames) <- c(mname1, mname2) if(eliminate.zeros) { # eliminate rows and columns with no data (but always include missing data row and column) rs <- apply(tab, 1, sum); rs[1] <- 1 tab <- tab[rs>0,,drop=FALSE] cs <- apply(tab, 2, sum); cs[1] <- 1 tab <- tab[,cs>0,drop=FALSE] } tab } # map functions mf.k <- function(d) 0.5*tanh(d/50) mf.h <- function(d) 0.5*(1-exp(-d/50)) imf.k <- function(r) { r[r >= 0.5] <- 0.5-1e-14; 50*atanh(2*r) } imf.h <- function(r) { r[r >= 0.5] <- 0.5-1e-14; -50*log(1-2*r) } mf.m <- function(d) sapply(d,function(a) min(a/100,0.5)) imf.m <- function(r) sapply(r,function(a) min(a*100,50)) # carter-falconer: mf.cf, imf.cf imf.cf <- function(r) { r[r >= 0.5] <- 0.5-1e-14; 12.5*(log(1+2*r)-log(1-2*r))+25*atan(2*r) } mf.cf <- function(d) { d[d >= 300] <- 300 icf <- function(r,d) imf.cf(r)-d sapply(d,function(a) { if(a==0) return(0) uniroot(icf, c(0,0.5-1e-14),d=a,tol=1e-12)$root }) } ###################################################################### # # switch.order: change the marker order on a given chromosome to some # specified order # ###################################################################### switch.order <- function(cross, chr, order, error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), maxit=4000, tol=1e-6, sex.sp=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") map.function <- match.arg(map.function) # check chromosome argument if(missing(chr)) { chr <- names(cross$geno)[1] warning("Assuming you mean chromosome ", chr) } else { if(length(chr) > 1) { chr <- chr[1] warning("switch.order can deal with just one chromosome at a time; assuming you want chr ", chr) } if(!testchr(chr, names(cross$geno))) stop("Chr ", chr, " not found.") } chr <- matchchr(chr, names(cross$geno)) # check order argument n.mar <- nmar(cross) if(n.mar[chr] == length(order)-2 || n.mar[chr]==length(order)-1) order <- order[1:n.mar[chr]] # useful for output from ripple() if(n.mar[chr] != length(order)) stop("Incorrect number of markers.") # save recombination fractions flag <- 0 if("rf" %in% names(cross)) { attrib <- attributes(cross$rf) rf <- cross$rf # determine column within rec fracs whchr <- which(names(cross$geno)==chr) oldcols <- cumsum(c(0,n.mar))[whchr]+seq(along=order) newcols <- cumsum(c(0,n.mar))[whchr]+order rf[oldcols,] <- rf[newcols,] rf[,oldcols] <- rf[,newcols] colnames(rf)[oldcols] <- colnames(rf)[newcols] rownames(rf)[oldcols] <- rownames(rf)[newcols] flag <- 1 } # remove any intermediate calculations (except rec fracs), # as they will no longer be meaningful cross <- clean(cross) if(!is.matrix(cross$geno[[chr]]$map)) first <- min(cross$geno[[chr]]$map) else first <- apply(cross$geno[[chr]]$map,1,min) # re-order markers cross$geno[[chr]]$data <- cross$geno[[chr]]$data[,order,drop=FALSE] m <- seq(0,by=5,length=ncol(cross$geno[[chr]]$data)) names(m) <- colnames(cross$geno[[chr]]$data) if(is.matrix(cross$geno[[chr]]$map)) cross$geno[[chr]]$map <- rbind(m,m) else cross$geno[[chr]]$map <- m # re-estimate rec fracs for re-ordered chromosome if(flag==1) { temp <- est.rf(subset(cross, chr=chr))$rf rf[oldcols,oldcols] <- temp cross$rf <- rf if("onlylod" %in% names(attrib)) attr(cross$rf, "onlylod") <- attrib$onlylod } # re-estimate map newmap <- est.map(cross, chr=chr, error.prob=error.prob, map.function=map.function, maxit=maxit, tol=tol, sex.sp=sex.sp) if(!is.matrix(newmap[[1]])) cross$geno[[chr]]$map <- newmap[[1]] + first else { cross$geno[[chr]]$map[1,] <- newmap[[1]][1,] + first[1] cross$geno[[chr]]$map[2,] <- newmap[[1]][2,] + first[2] rownames(cross$geno[[chr]]$map) <- NULL } cross } ###################################################################### # flip.order: flip the order of markers on a set of chromosomes ###################################################################### flip.order <- function(cross, chr) { # utility function to flip a map flipChrOnMap <- function(map) { if(is.matrix(map)) { map <- map[,ncol(map):1,drop=FALSE] for(j in 1:nrow(map)) map[j,] <- max(map[j,]) - map[j,] } else { map <- max(map) - map[length(map):1] } map } # utility function to flip intermediate calc flipChrInterCalc <- function(object, attr2consider=c("error.prob", "step", "off.end", "map.function", "stepwidth")) { the_attr <- attributes(object) ndim <- length(dim(object)) if(ndim == 3) object <- object[,ncol(object):1,,drop=FALSE] else object <- object[,ncol(object):1,drop=FALSE] for(a in attr2consider) { if(a %in% names(the_attr)) attr(object, a) <- the_attr[[a]] } if("map" %in% names(the_attr)) attr(object, "map") <- flipChrOnMap(the_attr$map) object } chr <- matchchr(chr, names(cross$geno)) for(i in chr) { nc <- ncol(cross$geno[[i]]$data) cross$geno[[i]]$data <- cross$geno[[i]]$data[,nc:1,drop=FALSE] cross$geno[[i]]$map <- flipChrOnMap(cross$geno[[i]]$map) if("prob" %in% names(cross$geno[[i]])) cross$geno[[i]]$prob <- flipChrInterCalc(cross$geno[[i]]$prob) if("argmax" %in% names(cross$geno[[i]])) cross$geno[[i]]$argmax <- flipChrInterCalc(cross$geno[[i]]$argmax) if("draws" %in% names(cross$geno[[i]])) cross$geno[[i]]$draws <- flipChrInterCalc(cross$geno[[i]]$draws) if("errorlod" %in% names(cross$geno[[i]])) cross$geno[[i]]$errorlod <- flipChrInterCalc(cross$geno[[i]]$errorlod, c("error.prob", "map.function")) } cross$rf <- NULL cross } ###################################################################### # # subset.cross: General subsetting function for a cross object # ###################################################################### subset.cross <- function(x, chr, ind, ...) { if(!inherits(x, "cross")) stop("Input should have class \"cross\".") if(missing(chr) && missing(ind)) stop("You must specify either chr or ind.") n.chr <- nchr(x) n.ind <- nind(x) # pull out relevant chromosomes if(!missing(chr)) { chr <- matchchr(chr, names(x$geno)) if("rf" %in% names(x)) { # pull out part of rec fracs if(totmar(x) != ncol(x$rf)) x <- clean(x) else { attrib <- attributes(x$rf) n.mar <- nmar(x) n.chr <- n.chr wh <- rbind(c(0,cumsum(n.mar)[-n.chr])+1,cumsum(n.mar)) dimnames(wh) <- list(NULL, names(n.mar)) wh <- wh[,chr,drop=FALSE] wh <- unlist(apply(wh,2,function(a) a[1]:a[2])) x$rf <- x$rf[wh,wh] if("onlylod" %in% names(attrib)) # save the onlylod attribute if its there attr(x$rf, "onlylod") <- attrib$onlylod } } x$geno <- x$geno[chr] if("founderGeno" %in% names(x)) x$founderGeno <- x$founderGeno[,unlist(lapply(x$geno, function(a) colnames(a$data)))] } if(!missing(ind)) { theid <- getid(x) if(is.logical(ind)) { ind[is.na(ind)] <- FALSE if(length(ind) != n.ind) stop("ind argument has wrong length (", length(ind), "; should be ", n.ind, ")") ind <- (1:n.ind)[ind] } else if(is.numeric(ind)) { # treat as numeric indices; don't match against individual identifiers if(all(ind < 0)) { # drop all but these ind <- -ind if(any(ind > nind(x))) { a <- -ind[ind > nind(x)] if(length(a) > 1) a <- sample(a, 1) stop("Invalid ind values (e.g., ", a, ")") } ind <- (1:n.ind)[-ind] } else if(all(ind > 0)) { # keep these if(any(ind > nind(x))) { a <- ind[ind > nind(x)] if(length(a) > 1) a <- sample(a, 1) stop("Invalid ind values (e.g., ", a, ")") } } else { stop("Need ind to be all > 0 or all < 0.") } } else if(!is.null(theid)) { # cross has individual IDs ind <- as.character(ind) if(all(substr(ind, 1,1) == "-")) { ind <- substr(ind, 2, nchar(ind)) m <- match(ind, theid) if(all(is.na(m))) stop("No matching individuals.") if(any(is.na(m))) warning("Individuals not found: ", paste(ind[is.na(m)])) ind <- (1:n.ind)[-m[!is.na(m)]] } else { m <- match(ind, theid) if(any(is.na(m))) warning("Individuals not found: ", paste(ind[is.na(m)], collapse=" ")) ind <- m[!is.na(m)] } ind <- ind[!is.na(ind)] } else { # no individual IDs stop("In the absense of individual IDs, ind should be logical or numeric.") } # Note: ind should now be a numeric vector if(length(ind) == 0) stop("Must retain at least one individual.") if(length(ind) == 1) warning("Retained only one individual!") x$pheno <- x$pheno[ind,,drop=FALSE] if("cross" %in% names(x)) x$cross <- x$cross[ind,,drop=FALSE] for(i in 1:nchr(x)) { x$geno[[i]]$data <- x$geno[[i]]$data[ind,,drop=FALSE] if("prob" %in% names(x$geno[[i]])) { temp <- attributes(x$geno[[i]]$prob) # all attributes but dim and dimnames x$geno[[i]]$prob <- x$geno[[i]]$prob[ind,,,drop=FALSE] # put attributes back in for(k in seq(along=temp)) { if(names(temp)[k] != "dim" && names(temp)[k] != "dimnames") attr(x$geno[[i]]$prob, names(temp)[k]) <- temp[[k]] } } if("errorlod" %in% names(x$geno[[i]])) { temp <- attributes(x$geno[[i]]$prob) # all attributes but dim and dimnames x$geno[[i]]$errorlod <- x$geno[[i]]$errorlod[ind,,drop=FALSE] # put attributes back in for(k in seq(along=temp)) { if(names(temp)[k] != "dim" && names(temp)[k] != "dimnames") attr(x$geno[[i]]$errorlod, names(temp)[k]) <- temp[[k]] } } if("argmax" %in% names(x$geno[[i]])) { temp <- attributes(x$geno[[i]]$argmax) # all attributes but dim and dimnames x$geno[[i]]$argmax <- x$geno[[i]]$argmax[ind,,drop=FALSE] # put attributes back in for(k in seq(along=temp)) { if(names(temp)[k] != "dim" && names(temp)[k] != "dimnames") attr(x$geno[[i]]$argmax, names(temp)[k]) <- temp[[k]] } } if("draws" %in% names(x$geno[[i]])) { temp <- attributes(x$geno[[i]]$draws) # all attributes but dim and dimnames x$geno[[i]]$draws <- x$geno[[i]]$draws[ind,,,drop=FALSE] # put attributes back in for(k in seq(along=temp)) { if(names(temp)[k] != "dim" && names(temp)[k] != "dimnames") attr(x$geno[[i]]$draws, names(temp)[k]) <- temp[[k]] } } } if("qtlgeno" %in% names(x)) x$qtlgeno <- x$qtlgeno[ind,,drop=FALSE] } x } #pull.chr <- #function(cross, chr) { # warning("pull.chr is deprecated; use subset.cross.") # subset.cross(cross, chr) #} ###################################################################### # # c.cross: Combine crosses # ###################################################################### c.cross <- function(...) { args <- list(...) n.args <- length(args) for(i in seq(along=args)) { if(!inherits(args[[i]], "cross")) stop("Input should have class \"cross\".") } # if only one cross, just return it if(n.args==1) return(args[[1]]) if(any(sapply(args, function(a) !inherits(a, "cross")))) stop("All arguments must be cross objects.") # crosses must be all the same, or must be combination of F2 and BC classes <- sapply(args, crosstype) if(length(unique(classes))==1) { allsame <- TRUE type <- classes[1] } else { if(any(classes != "bc" & classes != "f2")) stop("Experiments must be either the same type or be bc/f2.") allsame <- FALSE type <- "f2" } if(length(unique(sapply(args, nchr))) > 1) stop("All arguments must have the same number of chromosomes.") x <- args[[1]] chr <- names(x$geno) n.mar <- nmar(x) marnam <- unlist(lapply(x$geno,function(b) colnames(b$data))) marpos <- unlist(lapply(x$geno,function(b) b$map)) map.mismatch <- 0 for(i in 2:n.args) { y <- args[[i]] y.marnam <- unlist(lapply(y$geno, function(b) colnames(b$data))) y.marpos <- unlist(lapply(y$geno, function(b) b$map)) if(any(chr != names(y$geno)) || any(n.mar != nmar(y)) || any(marnam != y.marnam) || any(marpos != y.marpos)) { map.mismatch <- 1 break } } if(map.mismatch) { # get the maps to line up for(i in 1:nchr(args[[1]])) { themap <- NULL themaps <- vector("list", n.args) for(j in 1:n.args) { if(is.matrix(args[[j]]$map)) stop("c.cross() won't work with sex-specific maps.") themaps[[j]] <- args[[j]]$geno[[i]]$map themap <- c(themap, themaps[[j]]) } themap <- sort(themap) mn <- unique(names(themap)) newmap <- rep(0,length(mn)) names(newmap) <- mn for(j in 1:length(newmap)) newmap[j] <- mean(themap[names(themap) == mn[j]]) for(j in 1:n.args) { m <- match(names(themaps[[j]]), mn) m <- m[!is.na(m)] if(any(diff(m)) < 0) stop(" Markers must all be in the same order.") if(!all(mn %in% names(themaps[[j]]))) { temp <- matrix(ncol=length(mn), nrow=nind(args[[j]])) colnames(temp) <- mn temp[,names(themaps[[j]])] <- args[[j]]$geno[[i]]$data args[[j]]$geno[[i]]$data <- temp } args[[j]]$geno[[i]]$map <- newmap } } } # end of map mismatch fix x <- args[[1]] chr <- names(x$geno) n.mar <- nmar(x) marnam <- unlist(lapply(x$geno,function(b) colnames(b$data))) # create genotype information geno <- x$geno for(j in 1:nchr(x)) { # drop extraneous stuff geno[[j]] <- list(data=geno[[j]]$data, map=geno[[j]]$map) class(geno[[j]]) <- class(x$geno[[j]]) } for(i in 2:n.args) for(j in 1:nchr(x)) geno[[j]]$data <- rbind(geno[[j]]$data,args[[i]]$geno[[j]]$data) # get all phenotype names phenam <- names(x$pheno) for(i in 2:n.args) phenam <- c(phenam, names(args[[i]]$pheno)) phenam <- unique(phenam) # form big phenotype matrix n.ind <- sapply(args,nind) pheno <- matrix(nrow=sum(n.ind),ncol=length(phenam)) colnames(pheno) <- phenam pheno <- as.data.frame(pheno, stringsAsFactors=TRUE) if(!allsame) { crosstype <- factor(rep(c("bc","f2")[match(classes,c("bc","f2"))],n.ind), levels=c("bc","f2")) pheno <- cbind(pheno,crosstype=crosstype) } for(i in 1:length(phenam)) { phe <- vector("list",n.args) for(j in 1:n.args) { o <- match(phenam[i],names(args[[j]]$pheno)) if(is.na(o)) phe[[j]] <- rep(NA,n.ind[j]) else phe[[j]] <- args[[j]]$pheno[,o] } pheno[,i] <- unlist(phe) } # indicator of which cross whichcross <- matrix(0,ncol=n.args,nrow=sum(n.ind)) colnames(whichcross) <- paste("cross",1:n.args,sep="") thecross <- rep(NA, sum(n.ind)) prev <- 0 for(i in 1:n.args) { wh <- prev + 1:n.ind[i] prev <- prev + n.ind[i] whichcross[wh,i] <- 1 thecross[wh] <- i } pheno <- cbind(pheno,cross=thecross,whichcross) x$pheno <- pheno if(!map.mismatch) { # keep probs and draws only if we've not re-aligned the maps # if probs exist in each and all have the same # set up values, keep them wh <- sapply(args, function(a) match("prob",names(a$geno[[1]]))) step <- sapply(args,function(a) attr(a$geno[[1]]$prob,"step")) error.prob <- sapply(args,function(a) attr(a$geno[[1]]$prob,"error.prob")) off.end <- sapply(args,function(a) attr(a$geno[[1]]$prob,"off.end")) map.function <- sapply(args,function(a) attr(a$geno[[1]]$prob,"map.function")) map <- lapply(args,function(a) attr(a$geno[[1]]$prob,"map")) if(!any(is.na(wh)) && length(unique(step))==1 && length(unique(error.prob))==1 && length(unique(off.end))==1 && length(unique(map.function))==1) { if(allsame) { # all same cross type for(j in 1:nchr(x)) { geno[[j]]$prob <- array(dim=c(sum(n.ind),dim(x$geno[[j]]$prob)[-1])) dimnames(geno[[j]]$prob) <- dimnames(x$geno[[j]]$prob) prev <- 0 for(i in 1:n.args) { wh <- prev + 1:n.ind[i] prev <- prev + n.ind[i] geno[[j]]$prob[wh,,] <- args[[i]]$geno[[j]]$prob } } } else { # mixed F2 and BC for(j in 1:nchr(x)) { wh <- match("f2",classes) geno[[j]]$prob <- array(0,dim=c(sum(n.ind),dim(args[[wh]]$geno[[j]]$prob)[-1])) dimnames(geno[[j]]$prob) <- dimnames(args[[wh]]$geno[[j]]$prob) prev <- 0 for(i in 1:n.args) { wh <- prev + 1:n.ind[i] prev <- prev + n.ind[i] if(classes[i]=="f2") geno[[j]]$prob[wh,,] <- args[[i]]$geno[[j]]$prob else # backcross geno[[j]]$prob[wh,,1:2] <- args[[i]]$geno[[j]]$prob } } } for(j in 1:nchr(x)) { wh <- sapply(args, function(a) match("prob",names(a$geno[[j]]))) step <- sapply(args,function(a) attr(a$geno[[j]]$prob,"step")) error.prob <- sapply(args,function(a) attr(a$geno[[j]]$prob,"error.prob")) off.end <- sapply(args,function(a) attr(a$geno[[j]]$prob,"off.end")) map.function <- sapply(args,function(a) attr(a$geno[[j]]$prob,"map.function")) map <- lapply(args,function(a) attr(a$geno[[j]]$prob,"map")) attr(geno[[j]]$prob,"step") <- step[1] attr(geno[[j]]$prob,"error.prob") <- error.prob[1] attr(geno[[j]]$prob,"off.end") <- off.end[1] attr(geno[[j]]$prob,"map.function") <- map.function[1] attr(geno[[j]]$prob,"map") <- map[[1]] } } # if draws exist in each and all have the same # set up values, keep them wh <- sapply(args, function(a) match("draws",names(a$geno[[1]]))) step <- sapply(args,function(a) attr(a$geno[[1]]$draws,"step")) error.prob <- sapply(args,function(a) attr(a$geno[[1]]$draws,"error.prob")) off.end <- sapply(args,function(a) attr(a$geno[[1]]$draws,"off.end")) map.function <- sapply(args,function(a) attr(a$geno[[1]]$draws,"map.function")) map <- lapply(args,function(a) attr(a$geno[[1]]$draws,"map")) ndraws <- sapply(args,function(a) dim(a$geno[[1]]$draws)[3]) if(!any(is.na(wh)) && length(unique(step))==1 && length(unique(error.prob))==1 && length(unique(off.end))==1 && length(unique(map.function))==1 && length(unique(ndraws))==1) { for(j in 1:nchr(x)) { geno[[j]]$draws <- array(0,dim=c(sum(n.ind),dim(x$geno[[j]]$draws)[-1])) dimnames(geno[[j]]$draws) <- dimnames(x$geno[[j]]$draws) prev <- 0 for(i in 1:n.args) { wh <- prev + 1:n.ind[i] prev <- prev + n.ind[i] geno[[j]]$draws[wh,,] <- args[[i]]$geno[[j]]$draws } wh <- sapply(args, function(a) match("draws",names(a$geno[[j]]))) step <- sapply(args,function(a) attr(a$geno[[j]]$draws,"step")) error.prob <- sapply(args,function(a) attr(a$geno[[j]]$draws,"error.prob")) off.end <- sapply(args,function(a) attr(a$geno[[j]]$draws,"off.end")) map.function <- sapply(args,function(a) attr(a$geno[[j]]$draws,"map.function")) map <- lapply(args,function(a) attr(a$geno[[j]]$draws,"map")) attr(geno[[j]]$draws,"step") <- step[1] attr(geno[[j]]$draws,"error.prob") <- error.prob[1] attr(geno[[j]]$draws,"off.end") <- off.end[1] attr(geno[[j]]$draws,"map.function") <- map.function[1] attr(geno[[j]]$draws,"map") <- map[[1]] } } } x <- list(geno=geno, pheno=pheno) class(x) <- c(type,"cross") x } ###################################################################### # # fill.geno: Run argmax.geno or sim.geno and then fill in the # genotype data with the results. This will allow # rough genome scans by marker regression without # holes. WE WOULD NOT PLACE ANY TRUST IN THE RESULTS! # # the newer method, "no_dbl_XO", fills in missing genotypes between # markers with matching genotypes # ###################################################################### fill.geno <- function(cross, method=c("imp","argmax", "no_dbl_XO", "maxmarginal"), error.prob=0.0001, map.function=c("haldane","kosambi","c-f","morgan"), min.prob=0.95) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") method <- match.arg(method) # don't let error.prob be exactly zero (or >1) if(error.prob < 1e-50) error.prob <- 1e-50 if(error.prob > 1) { error.prob <- 1-1e-50 warning("error.prob shouldn't be > 1!") } # remove any extraneous material cross <- clean(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) if(method=="imp") { # do one imputation temp <- sim.geno(cross,n.draws=1,step=0,off.end=0, error.prob=error.prob,map.function=map.function) # replace the genotype data with the results, # stripping off any attributes for(i in 1:n.chr) { nam <- colnames(cross$geno[[i]]$data) if(n.mar[i] == 1) cross$geno[[i]]$data <- matrix(as.numeric(temp$geno[[i]]$draws[,2,1]),ncol=n.mar[i]) else cross$geno[[i]]$data <- matrix(as.numeric(temp$geno[[i]]$draws[,,1]),ncol=n.mar[i]) colnames(cross$geno[[i]]$data) <- nam } } else if(method=="argmax") { # run the Viterbi algorithm temp <- argmax.geno(cross,step=0,off.end=0,error.prob=error.prob, map.function=map.function) # replace the genotype data with the results, # stripping off any attributes for(i in 1:n.chr) { nam <- colnames(cross$geno[[i]]$data) if(n.mar[i] == 1) cross$geno[[i]]$data <- matrix(as.numeric(temp$geno[[i]]$argmax[,2]),ncol=n.mar[i]) else cross$geno[[i]]$data <- matrix(as.numeric(temp$geno[[i]]$argmax),ncol=n.mar[i]) colnames(cross$geno[[i]]$data) <- nam } } else if(method=="maxmarginal") { temp <- calc.genoprob(cross, step=0, off.end=0, error.prob=error.prob, map.function=map.function) for(i in 1:n.chr) { p <- temp$geno[[i]]$prob whmax <- apply(p, 1:2, which.max) maxpr <- apply(p, 1:2, max) g <- cross$geno[[i]]$data g[maxpr >= min.prob] <- whmax[maxpr > min.prob] g[maxpr < min.prob] <- NA cross$geno[[i]]$data <- g } } else { for(i in 1:n.chr) { dat <- cross$geno[[i]]$data dat[is.na(dat)] <- 0 nr <- nrow(dat) nc <- ncol(dat) dn <- dimnames(dat) dat <- .C("R_fill_geno_nodblXO", as.integer(nr), as.integer(nc), dat=as.integer(dat), PACKAGE="qtl")$dat dat[dat==0] <- NA dat <- matrix(dat, ncol=nc, nrow=nr) dimnames(dat) <- dn cross$geno[[i]]$data <- dat } } cross } ###################################################################### # # checkcovar # # This is a utility function for scanone and scantwo. We remove # individuals with missing phenotypes or covariates and check # that the covariates are of the appropriate form. # ###################################################################### checkcovar <- function(cross, pheno.col, addcovar, intcovar, perm.strata, ind.noqtl=NULL, weights=NULL, verbose=TRUE) { chr_type <- sapply(cross$geno, chrtype) # drop individuals whose sex or pgm is missing if X chr is included if(any(chr_type=="X")) { sexpgm <- getsex(cross) keep <- rep(TRUE,nind(cross)) flag <- 0 if(!is.null(sexpgm$sex)) { if(any(is.na(sexpgm$sex))) { keep[is.na(sexpgm$sex)] <- FALSE flag <- 1 } } if(!is.null(sexpgm$pgm)) { if(any(is.na(sexpgm$pgm))) { keep[is.na(sexpgm$pgm)] <- FALSE flag <- 1 } } if(flag) { if(verbose) warning("Dropping ", sum(!keep), " individuals with missing sex or pgm.\n") cross <- subset(cross, ind=keep) if(!is.null(addcovar)) { if(!is.matrix(addcovar)) addcovar <- addcovar[keep] else addcovar <- addcovar[keep,] } if(!is.null(intcovar)) { if(!is.matrix(intcovar)) intcovar <- intcovar[keep] else intcovar <- intcovar[keep,] } } } # check phenotypes - we allow multiple phenotypes here if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("Specified phenotype column is invalid.") # check if all phenotypes are numeric pheno <- cross$pheno[,pheno.col,drop=FALSE] idx.nonnum <- which(!apply(pheno,2, is.numeric)) if(length(idx.nonnum) > 0) stop("Following phenotypes are not numeric: ", paste(colnames(pheno)[idx.nonnum], collapse=", ")) orig.n.ind <- nind(cross) # drop individuals with missing phenotypes if(any(!is.finite(unlist(pheno)))) { keep.ind <- as.numeric(which(apply(pheno, 1, function(x) !any(!is.finite(x))))) # keep.ind <- (1:length(pheno))[!is.na(pheno)] n.drop <- nind(cross) - length(keep.ind) keep.ind.boolean <- rep(FALSE, nind(cross)) keep.ind.boolean[keep.ind] <- TRUE cross <- subset.cross(cross,ind=keep.ind.boolean) pheno <- pheno[keep.ind,,drop=FALSE] if(verbose) warning("Dropping ", n.drop, " individuals with missing phenotypes.\n") } else keep.ind <- 1:nind(cross) n.ind <- nind(cross) n.chr <- nchr(cross) # number of chromosomes type <- crosstype(cross) # type of cross n.addcovar <- n.intcovar <- 0 if(!is.null(addcovar)) { # for additive covariates if(!is.matrix(addcovar)) { if(!is.numeric(as.matrix(addcovar))) stop("addcovar should be numeric") if(is.vector(addcovar) || is.data.frame(addcovar)) addcovar <- as.matrix(addcovar) else stop("addcovar should be a matrix") } if(!all(apply(addcovar,2,is.numeric))) stop("All columns of addcovar must be numeric") if( nrow(addcovar) != orig.n.ind ) { # the length of additive covariates is incorrect stop("Number of rows in additive covariates is incorrect") } addcovar <- addcovar[keep.ind,,drop=FALSE] n.addcovar <- ncol(addcovar) } if(!is.null(intcovar)) { # interacting covariates if(!is.matrix(intcovar)) { if(!is.numeric(as.matrix(intcovar))) stop("intcovar should be a numeric") if(is.vector(intcovar) || is.data.frame(intcovar)) intcovar <- as.matrix(intcovar) else stop("intcovar should be a matrix") } if(!all(apply(intcovar,2,is.numeric))) stop("All columns of intcovar must be numeric") if(nrow(intcovar)[1] != orig.n.ind) { # the length of interacting covariates is incorrect stop("The length of interacting covariates is incorrect!") } intcovar <- intcovar[keep.ind,,drop=FALSE] n.intcovar <- ncol(intcovar) } if(!is.null(perm.strata)) perm.strata <- perm.strata[keep.ind] if(!is.null(ind.noqtl)) ind.noqtl <- ind.noqtl[keep.ind] if(!is.null(weights)) weights <- weights[keep.ind] # drop individuals missing any covariates if(!is.null(addcovar)) { # note that intcovar is contained in addcovar wh <- apply(cbind(addcovar,intcovar),1,function(a) any(!is.finite(a))) if(any(wh)) { cross <- subset.cross(cross,ind=(!wh)) pheno <- pheno[!wh,,drop=FALSE] addcovar <- addcovar[!wh,,drop=FALSE] if(!is.null(intcovar)) intcovar <- intcovar[!wh,,drop=FALSE] n.ind <- nind(cross) if(!is.null(perm.strata)) perm.strata <- perm.strata[!wh] if(!is.null(ind.noqtl)) ind.noqtl <- ind.noqtl[!wh] if(!is.null(weights)) weights <- weights[!wh] if(verbose) warning("Dropping ", sum(wh), " individuals with missing covariates.\n") } } # make sure columns of intcovar are contained in addcovar if(!is.null(intcovar)) { if(is.null(addcovar)) { addcovar <- intcovar n.addcovar <- n.intcovar if(verbose) warning("addcovar forced to contain all columns of intcovar\n") } else { wh <- 1:n.intcovar for(i in 1:n.intcovar) { o <- (apply(addcovar,2,function(a,b) max(abs(a-b)),intcovar[,i])<1e-14) if(any(o)) wh[i] <- (1:n.addcovar)[o] else wh[i] <- NA } if(any(!is.finite(wh))) { addcovar <- cbind(addcovar,intcovar[,!is.finite(wh)]) n.addcovar <- ncol(addcovar) if(verbose) warning("addcovar forced to contain all columns of intcovar") } } } if(n.addcovar > 0) { # check rank if(qr(cbind(1,addcovar))$rank < n.addcovar+1) if(verbose) warning("addcovar appears to be over-specified; consider dropping columns.\n") } if(n.intcovar > 0) { # check rank if(qr(cbind(1,intcovar))$rank < n.intcovar+1) if(verbose) warning("intcovar appears to be over-specified; consider dropping columns.\n") } pheno <- as.matrix(pheno) list(cross=cross, pheno=pheno, addcovar=addcovar, intcovar=intcovar, n.addcovar=n.addcovar, n.intcovar=n.intcovar, perm.strata=perm.strata, ind.noqtl=ind.noqtl, weights=weights) } # Find the nearest marker to a particular position find.marker <- function(cross, chr, pos, index) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") if(missing(pos) && missing(index)) stop("Give either pos or index.") if(!missing(pos) && !missing(index)) stop("Give just one of pos or index.") # if chr has length 1, expand if necessary if(length(chr) == 1) { if(!missing(pos)) chr <- rep(chr,length(pos)) else chr <- rep(chr, length(index)) } # otherwise, chr and pos should have same length else { if(!missing(pos) && length(chr) != length(pos)) stop("chr and pos must be the same length.") if(!missing(index) && length(chr) != length(index)) stop("chr and index must be the same length.") } markers <- rep("",length(chr)) chrnotfound <- NULL for(i in 1:length(chr)) { # find chromosome o <- match(chr[i], names(cross$geno)) if(is.na(o)) { markers[i] <- NA # chr not matched chrnotfound <- c(chrnotfound, chr[i]) } else { thismap <- cross$geno[[o]]$map # genetic map # sex-specific map; look at female positions if(is.matrix(thismap)) thismap <- thismap[1,] if(!missing(pos)) { # find closest marker d <- abs(thismap-pos[i]) o2 <- (1:length(d))[d==min(d)] if(length(o2)==1) markers[i] <- names(thismap)[o2] # if multiple markers are equidistant, # choose the one with the most data # or choose among them at random else { x <- names(thismap)[o2] n.geno <- apply(cross$geno[[o]]$data[,o2],2,function(a) sum(!is.na(a))) o2 <- o2[n.geno==max(n.geno)] if(length(o2) == 1) markers[i] <- names(thismap)[o2] else markers[i] <- names(thismap)[sample(o2,1)] } } else { # by index if(index[i] < 1 || index[i] > length(thismap)) stop("Misspecified index ", index[i], " on chr ", chr[i]) markers[i] <- names(thismap)[index[i]] } } } if(length(chrnotfound) > 0) { chrnotfound <- sort(unique(chrnotfound)) if(length(chrnotfound) == 1) warning("Chromosome ", paste("\"", chrnotfound, "\"", sep=""), " not found") else warning("Chromosomes ", paste("\"", chrnotfound, "\"", sep="", collapse=", "), " not found") } markers } ### Find the nearest pseudomarker to a particular position find.pseudomarker <- function(cross, chr, pos, where=c("draws","prob"), addchr=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") # if chr has length 1, expand if necessary if(length(chr) == 1) chr <- rep(chr,length(pos)) # otherwise, chr and pos should have same length else if(length(chr) != length(pos)) stop("chr and pos must be the same length.") markers <- rep("",length(chr)) where <- match.arg(where) if(where=="draws" && !("draws" %in% names(cross$geno[[1]]))) stop("You'll need to first run sim.geno") if(where=="prob" && !("prob" %in% names(cross$geno[[1]]))) stop("You'll need to first run calc.genoprob") for(i in 1:length(chr)) { # find chromosome o <- match(chr[i], names(cross$geno)) if(is.na(o)) markers[i] <- NA # chr not matched else { if(where=="draws") { if("map" %in% names(attributes(cross$geno[[o]]$draws))) thismap <- attr(cross$geno[[o]]$draws, "map") else { stp <- attr(cross$geno[[o]]$draws, "step") oe <- attr(cross$geno[[o]]$draws, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[o]]$draws))) stpw <- attr(cross$geno[[o]]$draws, "stepwidth") else stpw <- "fixed" thismap <- create.map(cross$geno[[o]]$map,stp,oe,stpw) attr(cross$geno[[o]]$draws, "map") <- thismap } } else { # prob if("map" %in% names(attributes(cross$geno[[o]]$prob))) thismap <- attr(cross$geno[[o]]$prob, "map") else { stp <- attr(cross$geno[[o]]$prob, "step") oe <- attr(cross$geno[[o]]$prob, "off.end") if("stepwidth" %in% names(attributes(cross$geno[[o]]$prob))) stpw <- attr(cross$geno[[o]]$prob, "stepwidth") else stpw <- "fixed" thismap <- create.map(cross$geno[[o]]$map,stp,oe,stpw) attr(cross$geno[[o]]$prob, "map") <- thismap } } # sex-specific map; look at female positions if(is.matrix(thismap)) thismap <- thismap[1,] # find closest marker d <- abs(thismap-pos[i]) o2 <- (1:length(d))[d==min(d)] if(length(o2)==1) themarker <- names(thismap)[o2] else themarker <- names(thismap)[sample(o2, 1)] if(addchr && length(grep("^loc[0-9]+\\.*[0-9]*(\\.[0-9]+)*$", themarker)) > 0) themarker <- paste("c", chr[i], ".", themarker, sep="") markers[i] <- themarker } } markers } # expand recombination fractions for RI lines adjust.rf.ri <- function(r, type=c("self","sib"), chrtype=c("A","X"), expand=TRUE) { # type of RI lines type <- match.arg(type) chrtype <- match.arg(chrtype) if(type=="self") { if(expand) return(r*2/(1+2*r)) else return(r/2/(1-r)) } else { if(chrtype=="A") { # autosome / sib mating if(expand) return(r*4/(1+6*r)) else return(r/(4-6*r)) } else { # X chromosome/ sib mating if(expand) return(8/3*r/(1+4*r)) else return(3/8*r/(1-1.5*r)) } } } ###################################################################### # lodint: function to get lod support interval ###################################################################### lodint <- function(results, chr, qtl.index, drop=1.5, lodcolumn=1, expandtomarkers=FALSE) { if(!inherits(results, "scanone")) { if(!inherits(results, "qtl")) stop("Input must have class \"scanone\" or \"qtl\".") else { if(!("lodprofile" %in% names(attributes(results)))) stop("qtl object needs to be produced by refineqtl with keeplodprofile=TRUE.") else { # qtl object if(lodcolumn != 1) { warning("lod column ignored if input is a qtl object.") lodcolumn <- 1 } results <- attr(results, "lodprofile") if(missing(qtl.index)) { if(length(results)==1) results <- results[[1]] else stop("You must specify qtl.index.") } else { if(length(qtl.index)>1) stop("qtl.index should have length 1") if(qtl.index < 1 || qtl.index > length(results)) { stop("qtl.index should be between 1 and ", length(results)) } results <- results[[qtl.index]] } chr <- results[1,1] } } } else { if(lodcolumn < 1 || lodcolumn +2 > ncol(results)) stop("Argument lodcolumn should be between 1 and ", ncol(results)-2) if(missing(chr)) { if(length(unique(results[,1]))>1) stop("Give a chromosome ID.") } else { if(length(chr) > 1) stop("chr should have length 1") if(is.na(match(chr, results[,1]))) stop("Chromosome ", chr, " not found.") results <- results[results[,1]==chr,] } } if(all(is.na(results[,lodcolumn+2]))) return(NULL) maxlod <- max(results[,lodcolumn+2],na.rm=TRUE) w <- which(!is.na(results[,lodcolumn+2]) & results[,lodcolumn+2] == maxlod) o <- range(which(!is.na(results[,lodcolumn+2]) & results[,lodcolumn+2] > maxlod-drop)) if(length(o)==0) o <- c(1,nrow(results)) else { if(o[1] > 1) o[1] <- o[1]-1 if(o[2] < nrow(results)) o[2] <- o[2]+1 } if(expandtomarkers) { markerpos <- (1:nrow(results))[-grep("^c.+\\.loc-*[0-9]+(\\.[0-9]+)*$", rownames(results))] if(any(markerpos <= o[1])) o[1] <- max(markerpos[markerpos <= o[1]]) if(any(markerpos >= o[2])) o[2] <- min(markerpos[markerpos >= o[2]]) } rn <- rownames(results)[c(o[1],w,o[2])] # look for duplicate rows if(length(w)>1 && rn[length(rn)]==rn[length(rn)-1]) w <- w[-length(w)] else if(length(w)>1 && rn[2]==rn[1]) w <- w[-1] rn <- rownames(results)[c(o[1],w,o[2])] # look for more duplicate rows if(any(table(rn)> 1)) { tab <- table(rn) temp <- which(tab>1) for(j in temp) { z <- which(rn==names(tab)[j]) for(k in 2:length(z)) rn[z[k:length(z)]] <- paste(rn[z[k:length(z)]], " ", sep="") } } results <- results[c(o[1],w,o[2]),] rownames(results) <- rn class(results) <- c("scanone","data.frame") results } ###################################################################### # bayesint: function to get Bayesian probability interval ###################################################################### bayesint <- function(results, chr, qtl.index, prob=0.95, lodcolumn=1, expandtomarkers=FALSE) { if(!inherits(results, "scanone")) { if(!inherits(results, "qtl")) stop("Input must have class \"scanone\" or \"qtl\".") else { if(!("lodprofile" %in% names(attributes(results)))) stop("qtl object needs to be produced by refineqtl with keeplodprofile=TRUE.") else { # qtl object if(lodcolumn != 1) { warning("lod column ignored if input is a qtl object.") lodcolumn <- 1 } results <- attr(results, "lodprofile") if(missing(qtl.index)) { if(length(results)==1) results <- results[[1]] else stop("You must specify qtl.index.") } else { if(length(qtl.index)>1) stop("qtl.index should have length 1") if(qtl.index < 1 || qtl.index > length(results)) stop("qtl.index should be between 1 and ", length(results)) results <- results[[qtl.index]] } chr <- results[1,1] } } } else { if(lodcolumn < 1 || lodcolumn +2 > ncol(results)) stop("Argument lodcolumn should be between 1 and ", ncol(results)-2) if(missing(chr)) { if(length(unique(results[,1]))>1) stop("Give a chromosome ID.") } else { if(length(chr) > 1) stop("chr should have length 1") if(is.na(match(chr, results[,1]))) stop("Chromosome ", chr, " not found.") results <- results[results[,1]==chr,] } } if(all(is.na(results[,lodcolumn+2]))) return(NULL) loc <- results[,2] width <- (c(loc[-1], loc[length(loc)]) - c(loc[1], loc[-length(loc)]))/2 width[c(1, length(width))] <- width[c(1, length(width))]*2 # adjust widths at ends area <- 10^results[,lodcolumn+2]*width area <- area/sum(area) o <- order(results[,lodcolumn+2], decreasing=TRUE) cs <- cumsum(area[o]) wh <- min(which(cs >= prob)) int <- range(o[1:wh]) if(expandtomarkers) { markerpos <- (1:nrow(results))[-grep("^c.+\\.loc-*[0-9]+(\\.[0-9]+)*$", rownames(results))] if(any(markerpos <= int[1])) int[1] <- max(markerpos[markerpos <= int[1]]) if(any(markerpos >= int[2])) int[2] <- min(markerpos[markerpos >= int[2]]) } rn <- rownames(results)[c(int[1],o[1],int[2])] # look for duplicate rows if(any(table(rn)> 1)) { rn[2] <- paste(rn[2], "") if(rn[1] == rn[3]) rn[3] <- paste(rn[3], " ") } results <- results[c(int[1],o[1],int[2]),] rownames(results) <- rn class(results) <- c("scanone", "data.frame") results } ###################################################################### # makeSSmap: convert a genetic map, or the genetic maps in a cross # object, to be sex-specific (i.e., 2-row matrices) ###################################################################### makeSSmap <- function(cross) { if(!inherits(cross, "map")) { # input object is a genetic map for(i in 1:length(cross)) { if(!is.matrix(cross[[i]])) cross[[i]] <- rbind(cross[[i]], cross[[i]]) } } else { # input object is assumed to be a "cross" object n.chr <- nchr(cross) for(i in 1:n.chr) { if(!is.matrix(cross$geno[[i]]$map)) cross$geno[[i]]$map <- rbind(cross$geno[[i]]$map, cross$geno[[i]]$map) } } cross } ###################################################################### # comparecrosses: verify that two cross objects have identical # classes, chromosomes, markers, genotypes, maps, # and phenotypes ###################################################################### comparecrosses <- function(cross1, cross2, tol=1e-5) { if(missing(cross1) || missing(cross2)) stop("Two crosses must be input.") # both are of class "cross" if(!inherits(cross1, "cross") || !inherits(cross2, "cross")) stop("Input should have class \"cross\".") # classes are the same if(crosstype(cross1) != crosstype(cross2)) stop("crosses are not the same type.") if(nchr(cross1) != nchr(cross2)) stop("crosses do not have the same number of chromosomes.") if(any(names(cross1$geno) != names(cross2$geno))) stop("Chromosome names do not match.") if(any(nmar(cross1) != nmar(cross2))) stop("Number of markers per chromosome do not match.") mnames1 <- unlist(lapply(cross1$geno, function(a) colnames(a$data))) mnames2 <- unlist(lapply(cross2$geno, function(a) colnames(a$data))) if(any(mnames1 != mnames2)) { # stop("Markers names do not match.") for(i in 1:nchr(cross1)) if(any(colnames(cross1$geno[[i]]$data) != colnames(cross2$geno[[i]]$data))) stop("Marker names on chr ", names(cross1$geno)[i], " don't match.") } chr_type1 <- sapply(cross1$geno, chrtype) chr_type2 <- sapply(cross2$geno, chrtype) if(any(chr_type1 != chr_type2)) stop("Chromosome types (autosomal vs X) do not match.") for(i in 1:nchr(cross1)) { if(any(abs(diff(cross1$geno[[i]]$map) - diff(cross2$geno[[i]]$map)) > tol)) stop("Genetic maps for chromosome ", names(cross1$geno)[i], " do not match.") if(abs(cross1$geno[[i]]$map[1] - cross2$geno[[i]]$map[1]) > tol) warning("Initial marker positions for chromosome ", names(cross1$geno)[i], " do not match.") } if(nind(cross1) != nind(cross2)) stop("Number of individuals do not match.") for(i in 1:nchr(cross1)) { g1 <- cross1$geno[[i]]$data g2 <- cross2$geno[[i]]$data if(any((is.na(g1) & !is.na(g2)) | (!is.na(g1) & is.na(g2)) | (!is.na(g1) & !is.na(g2) & g1!=g2))) stop("Genotype data for chromosome ", names(cross1$geno)[i], " do not match.") } if(nphe(cross1) != nphe(cross2)) stop("Number of phenotypes do not match.") if(any(names(cross1$pheno) != names(cross2$pheno))) stop("Phenotype names do not match.") for(i in 1:nphe(cross1)) { phe1 <- cross1$pheno[,i] phe2 <- cross2$pheno[,i] if(is.numeric(phe1) & is.numeric(phe2)) { phe1[phe1 == Inf] <- max(phe1[phe1 < Inf], na.rm=TRUE)+5 phe2[phe2 == Inf] <- max(phe2[phe2 < Inf], na.rm=TRUE)+5 phe1[phe1 == -Inf] <- min(phe1[phe1 > -Inf], na.rm=TRUE)-5 phe2[phe2 == -Inf] <- min(phe2[phe2 > -Inf], na.rm=TRUE)-5 if(any((is.na(phe1) & !is.na(phe2)) | (!is.na(phe1) & is.na(phe2)) | (!is.na(phe1) & !is.na(phe2) & abs(phe1-phe2) > tol))) { stop("Data for phenotype ", names(cross1$pheno)[i], " do not match.") } } else { if(any((is.na(phe1) & !is.na(phe2)) | (!is.na(phe1) & is.na(phe2)) | (!is.na(phe1) & !is.na(phe2) & as.character(phe1) != as.character(phe2)))) { stop("Data for phenotype ", names(cross1$pheno)[i], " do not match.") } } } message("\tCrosses are identical.") } ###################################################################### # move marker # Move a marker to a new chromosome...placed at the end ###################################################################### movemarker <- function(cross, marker, newchr, newpos) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") mnames <- unlist(lapply(cross$geno,function(a) colnames(a$data))) chr <- rep(names(cross$geno),nmar(cross)) pos <- unlist(lapply(cross$geno,function(a) 1:ncol(a$data))) oldindex <- match(marker, mnames) # Marker found precisely once? if(is.na(oldindex)) stop(marker, " not found.\n") if(length(oldindex) > 1) stop(marker, " found multiple times.\n") chr <- chr[oldindex] pos <- pos[oldindex] # pull out genotype data g <- cross$geno[[chr]]$data[,pos] chr_type <- chrtype(cross$geno[[chr]]) mapmatrix <- is.matrix(cross$geno[[chr]]$map) # delete marker if(nmar(cross)[chr] == 1) { # only marker on that chromosome, so drop the chromosome cross$geno <- cross$geno[-match(chr,names(cross$geno))] delchr <- TRUE } else { delchr <- FALSE cross$geno[[chr]]$data <- cross$geno[[chr]]$data[,-pos,drop=FALSE] if(is.matrix(cross$geno[[chr]]$map)) cross$geno[[chr]]$map <- cross$geno[[chr]]$map[,-pos,drop=FALSE] else cross$geno[[chr]]$map <- cross$geno[[chr]]$map[-pos] } if(is.numeric(newchr)) newchr <- as.character(newchr) if(!(newchr %in% names(cross$geno))) { # create a new chromosome n <- length(cross$geno) cross$geno[[n+1]] <- list("data"=as.matrix(g), "map"=as.numeric(0)) names(cross$geno)[n+1] <- newchr class(cross$geno[[n+1]]) <- chr_type colnames(cross$geno[[n+1]]$data) <- marker if(mapmatrix) { if(missing(newpos)) newpos <- 0 cross$geno[[n+1]]$map <- matrix(newpos, ncol=1, nrow=2) colnames(cross$geno[[n+1]]$map) <- marker } else { if(missing(newpos)) newpos <- 0 cross$geno[[n+1]]$map <- newpos names(cross$geno[[n+1]]$map) <- marker } return(cross) } if(missing(newpos)) { # add marker to end of new chromosome n.mar <- nmar(cross)[newchr] cross$geno[[newchr]]$data <- cbind(cross$geno[[newchr]]$data,g) colnames(cross$geno[[newchr]]$data)[n.mar+1] <- marker if(is.matrix(cross$geno[[newchr]]$map)) { cross$geno[[newchr]]$map <- cbind(cross$geno[[newchr]]$map, cross$geno[[newchr]]$map[,n.mar]+10) colnames(cross$geno[[newchr]]$map)[n.mar+1] <- marker } else { cross$geno[[newchr]]$map <- c(cross$geno[[newchr]]$map, cross$geno[[newchr]]$map[n.mar]+10) names(cross$geno[[newchr]]$map)[n.mar+1] <- marker } } else { # add marker to the specified position dat <- cross$geno[[newchr]]$data map <- cross$geno[[newchr]]$map if(length(newpos) != 1) stop("newpos should be a single number.") if(is.matrix(map)) { # sex-specific maps wh <- which(map[1,] < newpos) if(length(wh) == 0) { # place in first spot map <- cbind(c(newpos,map[2,1]-(map[1,1]-newpos)),map) colnames(map)[1] <- marker } else { wh <- max(wh) if(wh == ncol(map)) { # place at end of chromosome map <- cbind(map,c(newpos,map[2,ncol(map)]+(newpos-map[1,ncol(map)]))) colnames(map)[ncol(map)] <- marker } else { left <- map[,1:wh,drop=FALSE] right <- map[,-(1:wh),drop=FALSE] marleft <- colnames(left) marright <- colnames(right) left <- left[,ncol(left)] right <- right[,1] newpos2 <- (newpos-left[1])/(right[1]-left[1])*(right[2]-left[2])+left[2] map <- cbind(map[,1:wh], c(newpos,newpos2), map[,-(1:wh)]) colnames(map) <- c(marleft, marker, marright) } } } else { wh <- which(map < newpos) if(length(wh) == 0) { # place in first position map <- c(newpos,map) names(map)[1] <- marker } else { wh <- max(wh) if(wh == length(map)) { # place in last position map <- c(map,newpos) names(map)[length(map)] <- marker } else { map <- c(map[1:wh],newpos,map[-(1:wh)]) names(map)[wh+1] <- marker } } } cross$geno[[newchr]]$map <- map if(length(wh)==0) { # place marker in first position dat <- cbind(g, dat) colnames(dat)[1] <- marker } else if(wh == ncol(dat)) { # place marker in last position dat <- cbind(dat, g) colnames(dat)[ncol(dat)] <- marker } else { # place marker in the middle dat <- cbind(dat[,1:wh],g,dat[,-(1:wh)]) colnames(dat)[wh+1] <- marker } cross$geno[[newchr]]$data <- dat # make sure the marker names for the data and the genetic map match if(is.matrix(cross$geno[[newchr]]$map)) colnames(cross$geno[[newchr]]$data) <- colnames(cross$geno[[newchr]]$map) else colnames(cross$geno[[newchr]]$data) <- names(cross$geno[[newchr]]$map) } # update genoprob, errorlod, argmax, draws, rf if("rf" %in% names(cross)) { # reorder the recombination fractions # -- a bit of pain, 'cause we need LODs in upper triangle # and rec fracs in lower triangle newmar <- unlist(lapply(cross$geno,function(a) colnames(a$data))) attrib <- attributes(cross$rf) rf <- cross$rf lods <- rf;lods[lower.tri(rf)] <- t(rf)[lower.tri(rf)] rf[upper.tri(rf)] <- t(rf)[upper.tri(rf)] lods <- lods[newmar,newmar] rf <- rf[newmar,newmar] rf[upper.tri(rf)] <- lods[upper.tri(rf)] cross$rf <- rf if("onlylod" %in% names(attrib)) # save the onlylod attribute if its there attr(cross$rf, "onlylod") <- attrib$onlylod } if(!delchr) thechr <- c(chr,newchr) else thechr <- newchr for(i in thechr) { tempg <- cross$geno[[i]] tempx <- subset(cross, chr=i) if("prob" %in% names(tempg)) atp <- attributes(tempg$prob) if("draws" %in% names(tempg)) { at <- attributes(cross$geno[[1]]$draws) tempg$draws <- sim.geno(tempx, n.draws=at$dim[3], step=at$step, off.end=at$off.end, map.function=at$map.function, error.prob=at$error.prob)$geno[[1]]$draws } if("argmax" %in% names(tempg)) { at <- attributes(cross$geno[[1]]$argmax) tempg$argmax <- argmax.geno(tempx, step=at$step, off.end=at$off.end, map.function=at$map.function, error.prob=at$error.prob)$geno[[1]]$argmax } if("errorlod" %in% names(tempg)) { at <- attributes(cross$geno[[1]]$errorlod) tempg$errorlod <- argmax.geno(tempx, map.function=at$map.function, error.prob=at$error.prob)$geno[[1]]$errorlod } if("prob" %in% names(tempg)) tempg$prob <- calc.genoprob(tempx, step=atp$step, off.end=atp$off.end, map.function=atp$map.function, error.prob=atp$error.prob)$geno[[1]]$prob cross$geno[[i]] <- tempg } cross } ###################################################################### # # summary.map # # Give a short summary of a genetic map object. # ###################################################################### summaryMap <- summary.map <- function(object, ...) { map <- object if(inherits(map, "cross")) # a cross object map <- pull.map(map) if(!inherits(map, "map") && !is.list(map)) warning("Input should have class \"cross\" or \"map\".") n.chr <- length(map) chrnames <- names(map) if(is.null(chrnames)) chrnames <- 1:length(map) if(is.matrix(map[[1]])) { # sex-specific map sexsp <- TRUE n.mar <- sapply(map,ncol) tot.mar <- sum(n.mar) fmap <- lapply(map,function(a) a[1,]) mmap <- lapply(map,function(a) a[2,]) len.f <- sapply(fmap,function(a) diff(range(a))) len.m <- sapply(mmap,function(a) diff(range(a))) avesp.f <- sapply(fmap,function(a) {if(length(a)<2) return(NA); mean(diff(a))}) avesp.m <- sapply(mmap,function(a) {if(length(a)<2) return(NA); mean(diff(a))}) maxsp.f <- sapply(fmap,function(a) {if(length(a)<2) return(NA); max(diff(a))}) maxsp.m <- sapply(mmap,function(a) {if(length(a)<2) return(NA); max(diff(a))}) totlen.f <- sum(len.f) totlen.m <- sum(len.m) tot.avesp.f <- mean(unlist(lapply(fmap,diff)), na.rm=TRUE) tot.avesp.m <- mean(unlist(lapply(mmap,diff)), na.rm=TRUE) tot.maxsp.f <- max(maxsp.f,na.rm=TRUE) tot.maxsp.m <- max(maxsp.m,na.rm=TRUE) output <- rbind(cbind(n.mar,len.f,len.m,avesp.f,avesp.m, maxsp.f, maxsp.m), c(tot.mar,totlen.f,totlen.m,tot.avesp.f,tot.avesp.m, tot.maxsp.f, tot.maxsp.m)) dimnames(output) <- list(c(chrnames,"overall"), c("n.mar","length.female","length.male", "ave.spacing.female","ave.spacing.male", "max.spacing.female", "max.spacing.male")) } else { sexsp=FALSE n.mar <- sapply(map,length) len <- sapply(map,function(a) diff(range(a))) tot.mar <- sum(n.mar) len <- sapply(map,function(a) diff(range(a))) avesp <- sapply(map,function(a) {if(length(a)<2) return(NA); mean(diff(a))}) maxsp <- sapply(map,function(a) {if(length(a)<2) return(NA); max(diff(a))}) totlen <- sum(len) tot.avesp <- mean(unlist(lapply(map,diff)), na.rm=TRUE) tot.maxsp <- max(maxsp, na.rm=TRUE) output <- rbind(cbind(n.mar,len,avesp, maxsp), c(tot.mar,totlen,tot.avesp, tot.maxsp)) dimnames(output) <- list(c(chrnames,"overall"), c("n.mar","length","ave.spacing", "max.spacing")) } output <- as.data.frame(output) attr(output, "sexsp") <- sexsp class(output) <- c("summary.map", "data.frame") output } ###################################################################### # # print.summary.map # # Print out the result of summary.map() # ###################################################################### print.summary.map <- function(x, ...) { sexsp <- attr(x, "sexsp") if(sexsp) cat("Sex-specific map\n\n") x <- apply(x,2,round,1) print(x) } ###################################################################### # convert functions ###################################################################### convert <- function(object, ...) UseMethod("convert") ###################################################################### # # convert.scanone # # Convert scanone output from the format for R/qtl ver 0.97 to # that for R/qtl ver 0.98 # (previously, inter-maker locations named loc*.c*; now c*.loc*) # ###################################################################### convert.scanone <- function(object, ...) { if(!inherits(object, "scanone")) stop("Input should have class \"scanone\".") rn <- rownames(object) o <- grep("^loc-*[0-9]+(\\.[0-9]+)*\\.c[0-9A-Za-z]+$", rn) if(length(o) > 0) { temp <- rn[o] temp <- strsplit(temp,"\\.") temp <- sapply(temp, function(a) paste(a[c(length(a),1:(length(a)-1))],collapse=".")) rownames(object)[o] <- temp } object } ###################################################################### # convert.scantwo # # convert scantwo output from the format used in R/qtl version 1.03 # and earlier to that used in R/qtl version 1.04 and later. # # 1.03 and earlier: contained joint and interactive LOD scores # 1.04 and later: contains joint LOD scores and LOD scores from the # additive QTL model ###################################################################### convert.scantwo <- function(object, ...) { if(!inherits(object, "scantwo")) stop("Input should have class \"scantwo\".") lod <- object$lod if(length(dim(lod)) == 2) { u <- upper.tri(lod) lod[u] <- t(lod)[u] - lod[u] } else { # multiple phenotypes u <- upper.tri(lod[,,1]) for(i in 1:dim(lod)[3]) lod[,,i][u] <- t(lod[,,i])[u] - lod[,,i][u] } object$lod <- lod object } ###################################################################### # convert.map # # convert a genetic map from one map function to another ###################################################################### convert.map <- function(object, old.map.function=c("haldane", "kosambi", "c-f", "morgan"), new.map.function=c("haldane", "kosambi", "c-f", "morgan"), ...) { old.map.function <- match.arg(old.map.function) new.map.function <- match.arg(new.map.function) if(!inherits(object, "map")) stop("Input should have class \"map\".") if(old.map.function==new.map.function) { warning("old and new map functions are the same; no change.") return(object) } mf <- switch(old.map.function, "haldane"=mf.h, "kosambi"=mf.k, "c-f"=mf.cf, "morgan"=mf.m) imf <- switch(new.map.function, "haldane"=imf.h, "kosambi"=imf.k, "c-f"=imf.cf, "morgan"=imf.m) if(is.matrix(object[[1]])) { # sex-specific map for(i in seq(along=object)) { theclass <- class(object[[i]]) thenames <- colnames(object[[i]]) for(j in 1:2) object[[i]][j,] <- cumsum(c(object[[i]][j,1], imf(mf(diff(object[[i]][j,]))))) class(object[[i]]) <- theclass colnames(object[[i]]) <- thenames } } else { for(i in seq(along=object)) { theclass <- class(object[[i]]) thenames <- names(object[[i]]) object[[i]] <- cumsum(c(object[[i]][1], imf(mf(diff(object[[i]]))))) class(object[[i]]) <- theclass names(object[[i]]) <- thenames } } object } ###################################################################### # find.pheno # # utility to get pheno number given pheno name ###################################################################### find.pheno <- function( cross, pheno ) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") seq( ncol( cross$pheno ))[match(pheno,names(cross$pheno))] } ###################################################################### # find.flanking # # utility to get flanking and/or closest marker to chr and pos ###################################################################### find.flanking <- function( cross, chr, pos) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") map = pull.map(cross) if(is.matrix(map[[1]]) && nrow(map[[1]]) > 1) stop("This function works only for crosses with sex-averaged maps.") if(length(chr) == 1 && length(pos) > 1) { chr <- rep(chr,length(pos)) } wh <- match(chr, names(cross$geno)) if(any(is.na(wh))) { stop("Chr ", paste(chr[is.na(wh)], collapse=", "), " not found.") wh <- wh[!is.na(wh)] } chr <- names(cross$geno)[wh] marker = NULL for (i in seq(length(chr))) { tmp = map[[chr[i]]]-pos[i] m = names(map[[chr[i]]]) left = sum(tmp < 0) at = sum(tmp == 0) right = sum(tmp > 0) f <- if (at > 0) left+at[c(1,length(at))] else { if (right > 0) c(left,left+at+1) else c(left,left+at) } marker = rbind(marker,m[f[c(1:2,order(abs(tmp[f]))[1])]]) } dimnames(marker) <- list(paste(chr,":",pos,sep=""), c("left","right","close")) as.data.frame(marker, stringsAsFactors=TRUE) } ###################################################################### # strip.partials # # Removes partially informative genotypes in an intercross. # # Input: a cross object; if verbose=TRUE, a statement regarding the # number of genotypes removed is printed. ###################################################################### strip.partials <- function(cross, verbose=TRUE) { if(!inherits(cross, "cross")) stop("Input should have class \"cross\".") type <- crosstype(cross) if(type != "f2") stop("This is for intercrosses only") n.removed <- 0 for(i in 1:nchr(cross)) { g <- cross$geno[[i]]$data wh <- !is.na(g) & g>3 if(any(wh)) { g[wh] <- NA cross$geno[[i]]$data <- g n.removed <- n.removed + sum(wh) } } if(verbose) { if(n.removed == 0) cat(" --Didn't remove any genotypes.\n") else cat("Removed", n.removed, "genotypes.\n") } cross } ###################################################################### # print the installed version of R/qtl ###################################################################### qtlversion <- function() { version <- unlist(packageVersion("qtl")) if(length(version) == 3) { # make it like #.#-# return( paste(c(version, ".", "-")[c(1,4,2,5,3)], collapse="") ) } paste(version, collapse=".") } ###################################################################### # # locateXO # # Locate crossovers on a single chromosome in each individual # Look at just the first chromosome # ###################################################################### locateXO <- function(cross, chr, full.info=FALSE) { if(!missing(chr)) { cross <- subset(cross, chr=chr) if(nchr(cross) != 1) warning("locateXO works on just one chr; considering chr ", names(cross$geno)[1]) } # individual IDs id <- getid(cross) if(is.null(id)) id <- as.character(1:nind(cross)) if(nmar(cross)[1] == 1) { # just one marker; don't need to do anything warning("Just one marker.") res <- vector("list", nind(cross)) names(res) <- id for(i in seq(along=res)) res[[i]] <- numeric(0) return(res) } geno <- cross$geno[[1]]$data geno[is.na(geno)] <- 0 type <- crosstype(cross) if(!(type %in% c("bc", "f2", "riself", "risib", "dh", "haploid", "bcsft"))) stop("locateXO only working for backcross, intercross, RI strains, or BCsFt.") map <- cross$geno[[1]]$map if(is.matrix(map)) map <- map[1,] # map <- map - map[1] # shift first marker to 0 # bc or intercross? thetype==0 for BC and ==1 for intercross if(type=="f2" || type=="bcsft") { if(chrtype(geno) == "X") thetype <- 0 else thetype <- 1 } else thetype <- 0 n.ind <- nrow(geno) n.mar <- ncol(geno) z <- .C("R_locate_xo", as.integer(n.ind), as.integer(n.mar), as.integer(thetype), as.integer(geno), as.double(map), location=as.double(rep(0,n.ind*2*(n.mar-1))), nseen=as.integer(rep(0,n.ind)), ileft=as.integer(rep(0,n.ind*2*(n.mar-1))), iright=as.integer(rep(0,n.ind*2*(n.mar-1))), left=as.double(rep(0,n.ind*2*(n.mar-1))), right=as.double(rep(0,n.ind*2*(n.mar-1))), gleft=as.integer(rep(0, n.ind*2*(n.mar-1))), gright=as.integer(rep(0, n.ind*2*(n.mar-1))), ntype=as.integer(rep(0,n.ind*2*(n.mar-1))), as.integer(full.info), PACKAGE="qtl") location <- t(matrix(z$location, nrow=n.ind)) nseen <- z$nseen if(full.info) { ileft <- t(matrix(z$ileft, nrow=n.ind)) iright <- t(matrix(z$iright, nrow=n.ind)) left <- t(matrix(z$left, nrow=n.ind)) right <- t(matrix(z$right, nrow=n.ind)) gleft <- t(matrix(z$gleft, nrow=n.ind)) gright <- t(matrix(z$gright, nrow=n.ind)) ntype <- t(matrix(z$ntype, nrow=n.ind)) } if(!full.info) res <- lapply(as.data.frame(rbind(nseen, location), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) else { location <- lapply(as.data.frame(rbind(nseen, location), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) ileft <- lapply(as.data.frame(rbind(nseen, ileft), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) iright <- lapply(as.data.frame(rbind(nseen, iright), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) left <- lapply(as.data.frame(rbind(nseen, left), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) right <- lapply(as.data.frame(rbind(nseen, right), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) gleft <- lapply(as.data.frame(rbind(nseen, gleft), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) gright <- lapply(as.data.frame(rbind(nseen, gright), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) ntype <- lapply(as.data.frame(rbind(nseen, ntype), stringsAsFactors=TRUE), function(a) { if(a[1]==0) return(numeric(0)); a[(1:a[1])+1] }) res <- location for(i in seq(along=res)) { if(length(res[[i]])>0) { ntype[[i]][length(ntype[[i]])] <- NA res[[i]] <- cbind(location=location[[i]], left=left[[i]], right=right[[i]], ileft=ileft[[i]], iright=iright[[i]], gleft=gleft[[i]], gright=gright[[i]], nTypedBetween=ntype[[i]]) } } } names(res) <- id res } # jittermap: make sure no two markers are at precisely the same position jittermap <- function(object, amount=1e-6) # x is either a cross object or a map { if(inherits(object, "cross")) { themap <- pull.map(object) return.cross <- TRUE } else { if(!inherits(object, "map") && !is.list(object)) stop("Input must be a cross or a map") return.cross <- FALSE themap <- object } for(i in 1:length(themap)) { if(is.matrix(themap[[i]])) { # sex-specific maps n <- ncol(themap[[i]]) if(n > 1) { for(j in 1:2) themap[[i]][j,] <- themap[[i]][j,] + c(0,cumsum(rep(amount, n-1))) } } else { n <- length(themap[[i]]) if(n > 1) themap[[i]] <- themap[[i]] + c(0,cumsum(rep(amount, n-1))) } } if(return.cross) return(clean(replace.map(object, themap))) themap } print.map <- function(x, ...) { for(i in seq(along=x)) attr(x[[i]], "loglik") <- NULL if(length(x) == 1) print(unclass(x[[1]])) else print(unclass(lapply(x, unclass))) } # map function for Stahl model mf.stahl <- function(d, m=0, p=0) { if(any(d < 0)) stop("d must be >= 0\n") if(m < 0) stop("Must have m >= 0\n") if(p < 0 || p > 1) stop("Must have 0 <= p <= 1\n") # handle missing values if(any(!is.finite(d))) { which.finite <- is.finite(d) dsub <- d[which.finite] dropped.some <- TRUE } else { dsub <- d dropped.some <- FALSE } result <- .C("R_mf_stahl", as.integer(length(dsub)), as.double(dsub/100), # convert to Morgans as.integer(m), as.double(p), result=as.double(rep(0,length(dsub))), PACKAGE="qtl")$result if(dropped.some) { d[!which.finite] <- NA d[which.finite] <- result result <- d } result } # inverse map function for Stahl model imf.stahl <- function(r, m=0, p=0, tol=1e-12, maxit=1000) { if(any(r < 0 | r > 0.5)) stop("r must be >= 0 or <= 0.5\n") if(m < 0) stop("Must have m >= 0\n") if(p < 0 || p > 1) stop("Must have 0 <= p <= 1\n") # handle missing values if(any(!is.finite(r))) { which.finite <- is.finite(r) rsub <- r[which.finite] dropped.some <- TRUE } else { rsub <- r dropped.some <- FALSE } result <- .C("R_imf_stahl", as.integer(length(rsub)), as.double(rsub), as.integer(m), as.double(p), result=as.double(rep(0,length(rsub))), as.double(tol), as.integer(maxit), PACKAGE="qtl")$result*100 # convert to cM if(dropped.some) { r[!which.finite] <- NA r[which.finite] <- result result <- r } result } ###################################################################### # getid: internal function to pull out the "ID" column from the # phenotype data, if there is one ###################################################################### getid <- function(cross) { phe <- cross$pheno nam <- names(phe) if("id" %in% nam) { id <- phe$id phenam <- "id" } else if("ID" %in% nam) { id <- phe$ID phenam <- "ID" } else if("Id" %in% nam) { id <- phe$Id phenam <- "Id" } else if("iD" %in% nam) { id <- phe$iD phenam <- "iD" } else { id <- NULL phenam <- NULL } if(is.factor(id)) id <- as.character(id) attr(id, "phenam") <- phenam id } ###################################################################### # find the chromosome and position of a vector of markers ###################################################################### find.markerpos <- function(cross, marker) { if(length(marker) != length(unique(marker))) { warning("Dropping duplicate marker names.") marker <- unique(marker) } output <- data.frame(chr=rep("", length(marker)), pos=rep(NA, length(marker)), stringsAsFactors=TRUE) output$chr <- as.character(output$chr) rownames(output) <- marker map <- pull.map(cross) n.mar <- nmar(cross) chr <- rep(names(map), n.mar) if(!is.matrix(map[[1]])) { pos <- unlist(map) onemap <- TRUE } else { pos <- unlist(lapply(map, function(a) a[1,])) pos2 <- unlist(lapply(map, function(a) a[2,])) onemap <- FALSE output <- cbind(output, pos2=rep(NA, length(marker))) colnames(output)[2:3] <- c("pos.female","pos.male") } mnam <- markernames(cross) for(i in seq(along=marker)) { wh <- match(marker[i], mnam) if(is.na(wh)) { output[i,1] <- NA output[i,2] <- NA } else { if(length(wh) > 1) { warning("Marker ", marker[i], " found multiple times.") wh <- sample(wh, 1) } output[i,1] <- chr[wh] output[i,2] <- pos[wh] if(!onemap) output[i,3] <- pos2[wh] } } output } ###################################################################### # find the chromosome and position of a vector of pseudomarkers ###################################################################### find.pseudomarkerpos <- function(cross, marker, where=c("draws","prob")) { if(length(marker) != length(unique(marker))) { warning("Dropping duplicate pseudomarker names.") marker <- unique(marker) } output <- data.frame(chr=rep("", length(marker)), pos=rep(NA, length(marker)), stringsAsFactors=TRUE) output$chr <- as.character(output$chr) rownames(output) <- marker where <- match.arg(where) if(where=="draws" && !("draws" %in% names(cross$geno[[1]]))) stop("You'll need to first run sim.geno") if(where=="prob" && !("prob" %in% names(cross$geno[[1]]))) stop("You'll need to first run calc.genoprob") themap <- vector("list", nchr(cross)) names(themap) <- names(cross$geno) for(i in 1:nchr(cross)) { if(where=="draws") themap[[i]] <- attr(cross$geno[[i]]$draws, "map") else themap[[i]] <- attr(cross$geno[[i]]$prob, "map") } if(!is.matrix(themap[[1]])) { pmar <- unlist(lapply(themap, names)) pos <- unlist(themap) onemap <- TRUE chr <- rep(names(themap), sapply(themap, length)) } else { pos <- unlist(lapply(themap, function(a) a[1,])) pos2 <- unlist(lapply(themap, function(a) a[2,])) onemap <- FALSE pmar <- unlist(lapply(themap, colnames)) output <- cbind(output, pos2=rep(NA, length(marker))) colnames(output)[2:3] <- c("pos.female","pos.male") chr <- rep(names(themap), sapply(themap, ncol)) } whnotmarker <- grep("^loc-*[0-9]*", pmar) pmar[whnotmarker] <- paste("c", chr[whnotmarker], ".", pmar[whnotmarker], sep="") for(i in seq(along=marker)) { wh <- match(marker[i], pmar) if(is.na(wh)) { output[i,1] <- NA output[i,2] <- NA } else { if(length(wh) > 1) { warning("Pseudomarker ", marker[i], " found multiple times.") wh <- sample(wh, 1) } output[i,1] <- chr[wh] output[i,2] <- pos[wh] if(!onemap) output[i,3] <- pos2[wh] } } output } ###################################################################### # utility function for determining whether pheno.col (as argument # to scanone etc) can be interpreted as a vector of phenotypes, # versus a vector of phenotype columns ###################################################################### LikePheVector <- function(pheno, n.ind, n.phe) { if(is.numeric(pheno) && length(pheno)==n.ind && any(pheno < 1 | pheno > n.phe | pheno!=round(pheno))) return(TRUE) FALSE } ###################################################################### # for matching chromosome names ###################################################################### matchchr <- function(selection, thechr) { if(is.factor(thechr)) thechr <- as.character(thechr) if(length(thechr) > length(unique(thechr))) stop("Duplicate chromosome names.") if(is.logical(selection)) { if(length(selection) != length(thechr)) stop("Logical vector to select chromosomes is the wrong length") return(thechr[selection]) } if(is.numeric(selection)) selection <- as.character(selection) if(length(selection) > length(unique(selection))) { warning("Dropping duplicate chromosomes") selection <- unique(selection) } g <- grep("^-", selection) if(length(g) > 0 && length(g) < length(selection)) stop("In selecting chromosomes, all must start with '-' or none should.") if(length(g) > 0) { selectomit <- TRUE selection <- substr(selection, 2, nchar(selection)) } else selectomit <- FALSE wh <- match(selection, thechr) if(any(is.na(wh))) { warning("Chr ", paste(selection[is.na(wh)], collapse=", "), " not found") wh <- wh[!is.na(wh)] if(length(wh) == 0) return(thechr) } if(selectomit) return(thechr[-wh]) thechr[sort(wh)] } ###################################################################### # check that chromosomes match appropriately # TRUE = chr okay # FALSE = problem ###################################################################### testchr <- function(selection, thechr) { if(is.factor(thechr)) thechr <- as.character(thechr) if(length(thechr) > length(unique(thechr))) { # warning("Duplicate chromosome names.") return(FALSE) } if(is.logical(selection)) { if(length(selection) != length(thechr)) { # warning("Logical vector to select chromosomes is the wrong length") return(FALSE) } return(TRUE) } if(is.numeric(selection)) selection <- as.character(selection) if(length(selection) > length(unique(selection))) { # warning("Dropping duplicate chromosomes") selection <- unique(selection) } g <- grep("^-", selection) if(length(g) > 0 && length(g) < length(selection)) { # stop("In selecting chromosomes, all must start with '-' or none should.") return(FALSE) } if(length(g) > 0) { selectomit <- TRUE selection <- substr(selection, 2, nchar(selection)) } else selectomit <- FALSE wh <- match(selection, thechr) if(any(is.na(wh))) return(FALSE) TRUE } ###################################################################### # convert2sa # # convert a sex-specific maps to a sex-averaged one. # We pull out just the female map, and give a warning if the male and # female maps are too different ###################################################################### convert2sa <- function(map, tol=1e-4) { if(!inherits(map, "map")) stop("Input should have class \"map\".") if(!is.matrix(map[[1]])) stop("Input map doesn't seem to be a sex-specific map.") theclass <- sapply(map, chrtype) fem <- lapply(map, function(a) a[1,]) dif <- sapply(map, function(a) { if(ncol(a)==1) return(diff(a)) a <- apply(a, 1, diff); if(is.matrix(a)) return(max(abs(apply(a, 1, diff)))) abs(diff(a)) }) if(max(dif) > tol) warning("Female and male inter-marker distances differ by as much as ", max(dif), ".") for(i in seq(along=theclass)) class(fem[[i]]) <- theclass[i] class(fem) <- "map" fem } # round as character string, ensuring ending 0's are kept. charround <- function(x, digits=1) { if(digits < 1) stop("This is intended for the case digits >= 1.") y <- as.character(round(x, digits)) z <- strsplit(y, "\\.") sapply(z, function(a, digits) { if(length(a) == 1) b <- paste(a[1], ".", paste(rep("0", digits),collapse=""), sep="") else { if(nchar(a[2]) == digits) b <- paste(a, collapse=".") else b <- paste(a[1], ".", a[2], paste(rep("0", digits - nchar(a[2])), collapse=""), sep="") } }, digits) } ###################################################################### # scantwoperm2scanoneperm # # pull out the scanone permutations from scantwo permutation results, # so that one may use the scantwo perms in calls to summary.scanone ###################################################################### scantwoperm2scanoneperm <- function(scantwoperms) { if(!inherits(scantwoperms, "scantwoperm")) stop("Input must have class \"scantwoperm\".") if(!("one" %in% names(scantwoperms))) stop("Input doesn't contain scanone permutation results.") scanoneperms <- scantwoperms$one class(scanoneperms) <- "scanoneperm" scanoneperms } ###################################################################### # subset.map ###################################################################### subset.map <- function(x, ...) { cl <- class(x) x <- x[...] class(x) <- cl x } `[.map` <- function(x, ...) { x <- unclass(x)[...] class(x) <- "map" x } ###################################################################### # subset.cross with [ ] ###################################################################### `[.cross` <- function(x, chr, ind) subset(x, chr, ind) ###################################################################### # findDupMarkers # # find markers whose genotype data is identical to another marker # (which thus might be dropped, as extraneous) # # chr (Optional) set of chromosomes to consider # # exact.only If TRUE, look for markers with the same genotypes # and the same pattern of missing data # If FALSE, also identify markers whose observed # genotypes match another marker, with no # observed genotypes for which the other is # missing # # adjacent.only If TRUE, only consider adjacent markers ###################################################################### findDupMarkers <- function(cross, chr, exact.only=TRUE, adjacent.only=FALSE) { if(!missing(chr)) cross <- subset(cross, chr=chr) g <- pull.geno(cross) markers <- colnames(g) markerloc <- lapply(nmar(cross), function(a) 1:a) if(length(markerloc) > 1) { for(j in 2:length(markerloc)) markerloc[[j]] <- markerloc[[j]] + max(markerloc[[j-1]]) + 10 } markerloc <- unlist(markerloc) if(exact.only) { g[is.na(g)] <- 0 # genotype data patterns pat <- apply(g, 2, paste, collapse="") # table of unique values tab <- table(pat) # no duplicates; return if(all(tab == 1)) return(NULL) wh <- which(tab > 1) theloc <- themar <- vector("list", length(wh)) for(i in seq(along=wh)) { themar[[i]] <- names(pat)[pat==names(tab)[wh[i]]] theloc[[i]] <- markerloc[pat==names(tab)[wh[i]]] } if(adjacent.only) { extraloc <- list() extramar <- list() for(i in seq(along=theloc)) { d <- diff(theloc[[i]]) # look for adjacency if(any(d>1)) { # split into adjacent groups temp <- which(d>1) first <- c(1, temp+1) last <- c(temp, length(theloc[[i]])) for(j in 2:length(first)) { extraloc[[length(extraloc)+1]] <- theloc[[i]][first[j]:last[j]] extramar[[length(extramar)+1]] <- themar[[i]][first[j]:last[j]] } themar[[i]] <- themar[[i]][first[1]:last[1]] theloc[[i]] <- theloc[[i]][first[1]:last[1]] } } themar <- c(themar, extramar) theloc <- c(theloc, extraloc) nm <- sapply(themar, length) if(all(nm==1)) return(NULL) # nothing left themar <- themar[nm>1] theloc <- theloc[nm>1] } # order by first locus o <- order(sapply(theloc, min)) themar <- themar[o] randompics <- sapply(themar, function(a) sample(length(a), 1)) for(i in seq(along=themar)) { names(themar)[i] <- themar[[i]][randompics[i]] themar[[i]] <- themar[[i]][-randompics[i]] } } else { themar <- NULL ntyp <- ntyped(cross, "mar") o <- order(ntyp, decreasing=TRUE) g[is.na(g)] <- 0 z <- .C("R_findDupMarkers_notexact", as.integer(nrow(g)), as.integer(ncol(g)), as.integer(g), as.integer(o), as.integer(markerloc), as.integer(adjacent.only), result=as.integer(rep(0,length(o))), PACKAGE="qtl") if(all(z$result==0)) return(NULL) u <- unique(z$result[z$result != 0]) themar <- vector("list", length(u)) names(themar) <- colnames(g)[u] for(i in seq(along=themar)) themar[[i]] <- colnames(g)[z$result==u[i]] } themar } ###################################################################### # convert2riself ###################################################################### convert2riself <- function(cross) { if(!inherits(cross, "cross")) stop("input must be a cross object.") curtype <- crosstype(cross) chr_type <- sapply(cross$geno, chrtype) whX <- NULL if(any(chr_type != "A")) { # there's an X chromosome whX <- names(cross$geno)[chr_type != "A"] if(length(whX) > 1) warning("Converting chromosomes ", paste(whX, collapse=" "), " to autosomal.") else warning("Converting chromosome ", whX, " to autosomal.") for(i in whX) class(cross$geno[[i]]) <- "A" } gtab <- table(pull.geno(cross)) usethree <- FALSE if(!is.na(gtab["3"])) { if(!is.na(gtab["2"]) && gtab["3"] < gtab["2"]) usethree <- FALSE else usethree <- TRUE } g2omit <- g3omit <- g4omit <- 0 for(i in 1:nchr(cross)) { dat <- cross$geno[[i]]$data g1 <- sum(!is.na(dat) & dat==1) g2 <- sum(!is.na(dat) & dat==2) g3 <- sum(!is.na(dat) & dat==3) g4 <- sum(!is.na(dat) & dat>3) if(usethree && chr_type[i] == "A") { dat[!is.na(dat) & dat!=1 & dat!=3] <- NA dat[!is.na(dat) & dat==3] <- 2 g2omit <- g2omit + g2 g4omit <- g4omit + g4 } else { dat[!is.na(dat) & dat!=1 & dat!=2] <- NA g3omit <- g3omit + g3 g4omit <- g4omit + g4 } cross$geno[[i]]$data <- dat } if(g2omit > 0) warning("Omitting ", g2omit, " genotypes with code==2.") if(g3omit > 0) warning("Omitting ", g3omit, " genotypes with code==3.") if(g4omit > 0) warning("Omitting ", g4omit, " genotypes with code>3.") class(cross) <- c("riself", "cross") cross } ###################################################################### # convert2risib ###################################################################### convert2risib <- function(cross) { if(!inherits(cross, "cross")) stop("input must be a cross object.") curtype <- crosstype(cross) chr_type <- sapply(cross$geno, chrtype) gtab <- table(pull.geno(cross)) usethree <- FALSE if(!is.na(gtab["3"])) { if(!is.na(gtab["2"]) && gtab["3"] < gtab["2"]) usethree <- FALSE else usethree <- TRUE } g2omit <- g3omit <- g4omit <- 0 for(i in 1:nchr(cross)) { dat <- cross$geno[[i]]$data g1 <- sum(!is.na(dat) & dat==1) g2 <- sum(!is.na(dat) & dat==2) g3 <- sum(!is.na(dat) & dat==3) g4 <- sum(!is.na(dat) & dat>3) if(usethree) { if(chr_type[i] == "A") { dat[!is.na(dat) & dat!=1 & dat!=3] <- NA dat[!is.na(dat) & dat==3] <- 2 g2omit <- g2omit + g2 g4omit <- g4omit + g4 } else { # X chromosome if(g2 >= g3) { dat[!is.na(dat) & dat!=1 & dat!=2] <- NA g3omit <- g3omit + g3 g4omit <- g4omit + g4 } else { dat[!is.na(dat) & dat!=1 & dat!=3] <- NA dat[!is.na(dat) & dat==3] <- 2 g2omit <- g2omit + g2 g4omit <- g4omit + g4 } } } else { dat[!is.na(dat) & dat!=1 & dat!=2] <- NA g3omit <- g3omit + g3 g4omit <- g4omit + g4 } cross$geno[[i]]$data <- dat } if(g2omit > 0) warning("Omitting ", g2omit, " genotypes with code==2.") if(g3omit > 0) warning("Omitting ", g3omit, " genotypes with code==3.") if(g4omit > 0) warning("Omitting ", g4omit, " genotypes with code>3.") class(cross) <- c("risib", "cross") cross } rescalemap <- function(object, scale=1e-6) { if(inherits(object, "cross")) { for(i in 1:nchr(object)) { object$geno[[i]]$map <- object$geno[[i]]$map * scale } if(abs(scale - 1) > 1e-6) object <- clean(object) # strip off intermediate calculations } else if(inherits(object, "map") || is.list(object)) { for(i in seq(along=object)) { object[[i]] <- object[[i]] * scale } } else { stop("rescalemap works only for objects of class \"cross\" or \"map\".") } object } shiftmap <- function(object, offset=0) { if(inherits(object, "cross")) { if(length(offset) == 1) offset <- rep(offset, nchr(object)) else if(length(offset) != nchr(object)) stop("offset must have length 1 or n.chr (", nchr(object), ")") for(i in 1:nchr(object)) { if(is.matrix(object$geno[[i]]$map)) { for(j in 1:2) object$geno[[i]]$map[j,] <- object$geno[[i]]$map[j,] - object$geno[[i]]$map[j,1] + offset[i] } else { object$geno[[i]]$map <- object$geno[[i]]$map - object$geno[[i]]$map[1] + offset[i] } } } else if(inherits(object, "map") || is.list(object)) { if(length(offset) == 1) offset <- rep(offset, length(object)) else if(length(offset) != length(object)) stop("offset must have length 1 or n.chr (", length(object), ")") for(i in seq(along=object)) { if(is.matrix(object[[i]])) { for(j in 1:2) object[[i]][j,] <- object[[i]][j,] - object[[i]][j,1] + offset[i] } else { object[[i]] <- object[[i]] - object[[i]][1] + offset[i] } } } else stop("shiftmap works only for objects of class \"cross\" or \"map\".") object } ###################################################################### # switch alleles in a cross ###################################################################### switchAlleles <- function(cross, markers, switch=c("AB","CD","ABCD", "parents")) { type <- crosstype(cross) switch <- match.arg(switch) if(type %in% c("bc", "risib", "riself", "dh", "haploid")) { if(switch != "AB") warning("Using switch = \"AB\".") found <- rep(FALSE, length(markers)) for(i in 1:nchr(cross)) { cn <- colnames(cross$geno[[i]]$data) m <- match(markers, cn) if(any(!is.na(m))) { found[!is.na(m)] <- TRUE for(j in m[!is.na(m)]) { g <- cross$geno[[i]]$data[,j] cross$geno[[i]]$data[!is.na(g) & g==1,j] <- 2 cross$geno[[i]]$data[!is.na(g) & g==2,j] <- 1 } } } } else if(type=="f2" || type=="bcsft") { if(switch != "AB") warning("Using switch = \"AB\".") found <- rep(FALSE, length(markers)) for(i in 1:nchr(cross)) { cn <- colnames(cross$geno[[i]]$data) m <- match(markers, cn) if(any(!is.na(m))) { found[!is.na(m)] <- TRUE for(j in m[!is.na(m)]) { g <- cross$geno[[i]]$data[,j] cross$geno[[i]]$data[!is.na(g) & g==1,j] <- 3 cross$geno[[i]]$data[!is.na(g) & g==3,j] <- 1 cross$geno[[i]]$data[!is.na(g) & g==4,j] <- 5 cross$geno[[i]]$data[!is.na(g) & g==5,j] <- 4 } } } } else if(type=="4way") { if(switch=="AB") newg <- c(2,1,4,3,6,5,7,8,10,9,12,11,14,13) else if(switch=="CD") newg <- c(3,4,1,2,5,6,8,7,10,9,13,14,11,12) else if(switch=="ABCD") newg <- c(4,3,2,1,6,5,8,7,9,10,14,13,12,11) else # switch parents newg <- c(1,3,2,4,7,8,5,6,9,10,11,13,12,14) found <- rep(FALSE, length(markers)) for(i in 1:nchr(cross)) { cn <- colnames(cross$geno[[i]]$data) m <- match(markers, cn) if(any(!is.na(m))) { found[!is.na(m)] <- TRUE for(j in m[!is.na(m)]) { g <- cross$geno[[i]]$data[,j] for(k in 1:14) cross$geno[[i]]$data[!is.na(g) & g==k,j] <- newg[k] } } } } else { stop("Cross type ", type, " not supported by switchAlleles()") } if(any(!found)) warning("Some markers not found: ", paste(markers[!found], collapse=" ")) clean(cross) } ###################################################################### # # nqrank: Convert a set of quantitative values to the corresponding # normal quantiles (preserving mean and SD) # ###################################################################### nqrank <- function(x, jitter=FALSE) { y <- x[!is.na(x)] themean <- mean(y, na.rm=TRUE) thesd <- sd(y, na.rm=TRUE) y[y == Inf] <- max(y[y -Inf]) - 10 if(jitter) y <- rank(y+runif(length(y))/(sd(y)*10^8)) else y <- rank(y) x[!is.na(x)] <- qnorm((y-0.5)/length(y)) x*thesd/sd(x, na.rm=TRUE)-mean(x,na.rm=TRUE)+themean } ###################################################################### # # cleanGeno: omit genotypes that are possibly in error, as indicated # by apparent double-crossovers separated by a distance of # no more than maxdist and having no more than maxmark # interior typed markers # ###################################################################### cleanGeno <- function(cross, chr, maxdist=2.5, maxmark=2, verbose=TRUE) { if(!(crosstype(cross) %in% c("bc", "riself", "risib", "dh", "haploid"))) stop("This function currently only works for crosses with two genotypes") if(!missing(chr)) cleaned <- subset(cross, chr=chr) else cleaned <- cross thechr <- names(cleaned$geno) totdrop <- 0 maxmaxdist <- max(maxdist) for(i in thechr) { xoloc <- locateXO(cleaned, chr=i, full.info=TRUE) nxo <- sapply(xoloc, function(a) if(is.matrix(a)) return(nrow(a)) else return(0)) g <- pull.geno(cleaned, chr=i) ndrop <- 0 for(j in which(nxo > 1)) { maxd <- xoloc[[j]][-1,"right"] - xoloc[[j]][-nrow(xoloc[[j]]),"left"] wh <- maxd <= maxmaxdist if(any(wh)) { for(k in which(wh)) { nt <- sum(!is.na(g[j,(xoloc[[j]][k,"ileft"]+1):(xoloc[[j]][k+1,"iright"]-1)])) if(nt > 0 && any(nt <= maxmark & maxd[k] < maxdist)) { cleaned$geno[[i]]$data[j,(xoloc[[j]][k,"ileft"]+1):(xoloc[[j]][k+1,"iright"]-1)] <- NA ndrop <- ndrop + nt totdrop <- totdrop + nt } } } } if(verbose && ndrop > 0) { totgen <- sum(ntyped(subset(cross, chr=i))) cat(" ---Dropping ", ndrop, " genotypes (out of ", totgen, ") on chr ", i, "\n", sep="") } } if(verbose && nchr(cleaned)>1 && totdrop > 0) { totgen <- sum(ntyped(subset(cross, chr=thechr))) cat(" ---Dropped ", totdrop, " genotypes (out of ", totgen, ") in total\n", sep="") } for(i in names(cleaned$geno)) cross$geno[[i]] <- cleaned$geno[[i]] cross } ###################################################################### # typingGap: calculate gaps between typed markers ###################################################################### typingGap <- function(cross, chr, terminal=FALSE) { if(!missing(chr)) cross <- subset(cross, chr) n.ind <- nind(cross) n.chr <- nchr(cross) gaps <- matrix(nrow=n.ind, ncol=n.chr) colnames(gaps) <- names(cross$geno) for(i in 1:n.chr) { map <- cross$geno[[i]]$map map <- c(map[1], map, map[length(map)]) if(is.matrix(map)) stop("This function can't currently handle sex-specific maps.") if(terminal) # just look at terminal gaps gaps[,i] <- apply(cbind(1,cross$geno[[i]]$data,1), 1, function(a,b) {d <- diff(b[!is.na(a)]); max(d[c(1,length(d))]) }, map) else gaps[,i] <- apply(cbind(1,cross$geno[[i]]$data,1), 1, function(a,b) max(diff(b[!is.na(a)])), map) } if(n.chr==1) gaps <- as.numeric(gaps) gaps } ###################################################################### # calcPermPval # # calculate permutation pvalues for summary.scanone() ###################################################################### calcPermPval <- function(peaks, perms) { if(!is.matrix(peaks)) peaks <- as.matrix(peaks) if(!is.matrix(perms)) perms <- as.matrix(perms) ncol.peaks <- ncol(peaks) nrow.peaks <- nrow(peaks) n.perms <- nrow(perms) if(ncol.peaks != ncol(perms)) stop("ncol(peaks) != ncol(perms)") pval <- .C("R_calcPermPval", as.double(peaks), as.integer(ncol.peaks), as.integer(nrow.peaks), as.double(perms), as.integer(n.perms), pval=as.double(rep(0,ncol.peaks*nrow.peaks)), PACKAGE="qtl")$pval matrix(pval, ncol=ncol.peaks, nrow=nrow.peaks) } ###################################################################### # phenames: pull out phenotype names ###################################################################### phenames <- function(cross) colnames(cross$pheno) ###################################################################### # updateParallelRNG # # set RNGkind # advance RNGstream by no. clusters ###################################################################### updateParallelRNG <- function(n.cluster=1) { kind <- RNGkind()[1] if(kind != "L'Ecuyer-CMRG") RNGkind("L'Ecuyer-CMRG") s <- .Random.seed if(n.cluster < 1) n.cluster <- 1 for(i in 1:n.cluster) s <- nextRNGStream(s) .GlobalEnv$.Random.seed <- s ## global assign new .Random.seed } ###################################################################### # formMarkerCovar # # cross: cross object # # markers: marker names or pseudomarker names (like "c5loc25.1" or "5@25.1") # # method: use genotype probabilities or imputated genotypes (imputed with imp or argmax) # # ...: passed to fill.geno, if necessary # ###################################################################### formMarkerCovar <- function(cross, markers, method=c("prob", "imp", "argmax"), ...) { method <- match.arg(method) if(!is.character(markers)) markers <- as.character(markers) # check if the marker names are all like "5@25.1" grepresult <- grepl("@\\d", markers) if(all(grepresult)) { spl <- strsplit(markers, "@") chr <- sapply(spl, "[", 1) pos <- as.numeric(sapply(spl, "[", 2)) m <- match(chr, chrnames(cross)) if(any(is.na(m))) stop("Some chr not found: ", paste(unique(chr[m]), collapse=" ")) if(method=="prob") markers <- find.pseudomarker(cross, chr, pos, where="prob") else markers <- find.marker(cross, chr, pos) chr <- unique(chr) } else { if(method=="prob") z <- find.pseudomarkerpos(cross, markers, where="prob") else z <- find.markerpos(cross, markers) if(any(is.na(z[,1]))) stop("Some markers not found: ", paste(markers[is.na(z[,1])], collapse=", ")) chr <- unique(z$chr) } cross <- subset(cross, chr=chr) isXchr <- (sapply(cross$geno, chrtype) == "X") crosstype <- crosstype(cross) sexpgm <- getsex(cross) crossattr <- attributes(cross) if(method=="prob") { if(any(isXchr) && crosstype %in% c("f2", "bc", "bcsft")) { for(i in which(isXchr)) cross$geno[[i]]$prob <- reviseXdata(crosstype, "full", sexpgm=sexpgm, prob=cross$geno[[i]]$prob, cross.attr=crossattr) } if(any(isXchr) && any(!isXchr)) # some X, some not prob <- cbind(pull.genoprob(cross[!isXchr,], omit.first.prob=TRUE), pull.genoprob(cross[isXchr,], omit.first.prob=TRUE)) else # all X or all not X prob <- pull.genoprob(cross, omit.first.prob=TRUE) markercols <- sapply(strsplit(colnames(prob), ":"), "[", 1) m <- match(markers, markercols) if(any(is.na(m))) warning("Some markers/pseudomarkers not found: ", paste(unique(markers[is.na(m)]), collapse=" ")) return(prob[,!is.na(match(markercols, markers)), drop=FALSE]) } else { cross <- fill.geno(cross, method=method, ...) if(any(isXchr) && crosstype %in% c("f2", "bc", "bcsft")) { for(i in which(isXchr)) cross$geno[[i]]$data <- reviseXdata(crosstype, "full", sexpgm=sexpgm, geno=cross$geno[[i]]$data, cross.attr=crossattr) } geno <- pull.geno(cross) markercols <- colnames(geno) m <- match(markers, markercols) if(any(is.na(m))) warning("Some markers not found: ", paste(unique(markers[is.na(m)]), collapse=" ")) geno <- geno[,!is.na(match(markercols, markers)), drop=FALSE] # expand each column nalle <- apply(geno, 2, function(a) length(unique(a))) g <- matrix(ncol=sum(nalle-1), nrow=nrow(geno)) colnames(g) <- as.character(1:ncol(g)) cur <- 0 for(i in 1:ncol(geno)) { if(nalle[i] <= 1) next for(j in 2:nalle[i]) g[,cur+j-1] <- as.numeric(geno[,i] == j) colnames(g)[cur - 1 + (2:nalle[i])] <- paste(colnames(geno)[i], 2:nalle[i], sep=".") cur <- cur + nalle[i] - 1 } return(g) } } # omit the X chromosome from a cross omit_x_chr <- function(cross, warn=TRUE) { is_x <- vapply(cross$geno, function(chr) { chr_type <- chrtype(chr) !is.null(chr_type) && chr_type=="X" }, FALSE) if(any(is_x)) { if(all(is_x)) stop("Omitting X chromosome, but there are no other chromosomes.") if(warn) warning("Omitting X chromosome", ifelse(sum(is_x)>1, "s", ""), " (", paste0(names(cross$geno)[is_x], collapse=", "), ")") cross <- cross[!is_x, ] } cross } # determine cross type crosstype <- function(cross) { type <- class(cross) type <- type[type != "cross" & type != "list"] if(length(type) > 1) { warning("cross has multiple classes") } type[1] } # determine chromosome type chrtype <- function(object) { if(inherits(object, "X")) return("X") "A" } # end of util.R qtl/R/qtlcart_io.R0000644000176200001440000003463613576241200013553 0ustar liggesusers##################################################################### # # qtlcart_io.R # # copyright (c) 2002-2019, Brian S. Yandell # [with some modifications by Karl W. Broman and Hao Wu] # last modified Dec, 2019 # first written Jun, 2002 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: read.cross.qtlcart, read.cro.qtlcart, read.map.qtlcart, # write.cross.qtlcart # [See read.cross.R for the main read.cross function, and # write.cross.R for the main write.cross function.] # ############################################################################## ###################################################################### # read.cross.qtlcart # # read QTL cross object in QTL cartographer format ###################################################################### read.cross.qtlcart <- function (dir, crofile, mapfile) { if (missing(mapfile)) stop("Missing mapfile.") if (missing(crofile)) stop("Missing crofile.") if(!missing(dir) && dir != "") { mapfile <- file.path(dir, mapfile) crofile <- file.path(dir, crofile) } map <- read.map.qtlcart( mapfile ) cro <- read.cro.qtlcart( crofile ) cat(" --Read the following data:\n") cat(" Type of cross: ", cro$cross.class, "\n") cat(" Number of individuals: ", nrow( cro$markers ), "\n") cat(" Number of markers: ", ncol( cro$markers ), "\n") cat(" Number of phenotypes: ", ncol( cro$traits ), "\n") maplen <- unlist(lapply(map,length)) markers <- split( as.data.frame( t( cro$markers ), stringsAsFactors=TRUE), ordered( rep(names( maplen ), maplen ))) Geno <- list() for( i in names( map )) { name.markers <- names( map[[i]] ) markers[[i]] <- t( markers[[i]] ) colnames( markers[[i]] ) <- name.markers tmp <- list( data = markers[[i]], map = map[[i]] ) # determine whether autosomal chromosome or X chromosome # using the chromosome name class(tmp) <- ifelse(length(grep("[Xx]", i)), "X", "A") Geno[[i]] <- tmp } cross <- list(geno = Geno, pheno = cro$traits ) cross$pheno <- as.data.frame(cross$pheno, stringsAsFactors=TRUE) class(cross) <- c( cro$cross.class, "cross") if(cro$cross.class == "bcsft") attr(cross, "scheme") <- cro$cross.scheme list(cross,FALSE) } ###################################################################### # read.map.qtlcart # # read QTL Cartographer map file ###################################################################### read.map.qtlcart <- function (file) { # only interested in chromosomes, marker IDs and positions f <- scan(file, what = "", blank.lines.skip = FALSE, sep = "\n", quiet = TRUE) ctrl <- seq(f)[substring(f, 1, 1) == "-"] getvalue <- function(s, f, ctrl) { tmp <- unlist(strsplit(f[ctrl[substring(f[ctrl], 2, 3) == s]], " ")) as.numeric(tmp["" != tmp][2]) } nchrom <- getvalue("c ", f, ctrl) nmarkers <- getvalue("i ", f, ctrl) # marker positions tmp <- range(seq(f)[substring(f, 1, 3) == "-l "]) s <- strsplit(f[tmp[1]], "")[[1]] b <- grep("\\|", s) s <- grep("0", s) s <- ceiling((s[length(s)] - b - 1)/nchrom) position <- scan(file, what=character(), sep="\n", skip = tmp[1] - 1, n = tmp[2], quiet=TRUE) tmp <- grep("-b", f) if(length(tmp) < 1) stop("Marker names not found in map file\n") markers <- scan(file, list(1, 2, ""), skip = tmp[1], nlines = nmarkers, blank.lines.skip = FALSE, quiet = TRUE) if(length(tmp) < 2) { warning("Chromosome names not found in map file\n") chroms <- as.character(1:nchrom) } else chroms <- scan(file, list(1, ""), skip = tmp[2], nlines = nchrom, blank.lines.skip = FALSE, quiet = TRUE)[[2]] map <- list() n.markers <- table(markers[[1]]) # make sense of "position" position <- strsplit(position, "\\s+") pos <- matrix(ncol=nchrom,nrow=max(n.markers)) for(i in 1:max(n.markers)) { z <- position[[i]][-(1:3)] pos[i,which(n.markers >= i-1)] <- as.numeric(z) } for (i in seq(nchrom)) { tmp <- cumsum(pos[1:n.markers[i],i]) names(tmp) <- markers[[3]][i == markers[[1]]] map[[chroms[i]]] <- tmp } map } ###################################################################### # read.cro.qtlcart # # read QTL cartographer CRO file ###################################################################### read.cro.qtlcart <- function (file) { # translation from cro to R/qtl (see read.cross) # -1 NA missing data # 0 1 AA # 1 2 AB # 2 3 BB # 10 4 AA or AB # 12 5 AB or BB # f <- scan(file, what = "", blank.lines.skip = FALSE, sep = "\n", quiet = TRUE) ctrl <- seq(f)[substring(f, 1, 1) == "-"] s <- strsplit(f[ctrl], " ") ns <- character(length(ctrl)) for (i in seq(ctrl)) { ns[i] <- substring(s[[i]][1], 2) s[[i]] <- s[[i]]["" != s[[i]]][-1] } names(s) <- ns size <- as.numeric(s$n[1]) nmarkers <- as.numeric(s$p[1]) - 1 ntraits <- as.numeric(s$traits[1]) # cross.scheme (used for bcsft only) cross.scheme <- c(0,0) # cross type fix.bc1 <- fix.ridh <- FALSE # indicator of whether to fix genotypes cross <- tolower(s$cross[1]) if (cross == "ri1" || cross=="riself") { cross <- "riself" fix.ridh <- TRUE } else if (cross == "ri2" || cross=="risib") { cross <- "risib" fix.ridh <- TRUE } else if (cross == "ri0" || cross=="dh") { cross <- "dh" # doubled haploid fix.ridh <- TRUE } else if (cross == "b1" || cross == "b2") { fix.bc1 <- cross == "b1" cross <- "bc" } else if (cross == "sf2" || cross == "rf2") cross <- "f2" else if (cross == "sf3") { cross <- "bcsft" cross.scheme <- c(0,3) } if(!cross %in% c("f2","bc","risib","riself","bcsft", "dh")) stop("Cross type ", cross, " not supported.") notraits <- as.numeric(s$otraits[1]) skip <- ctrl["s" == ns] nlines <- ctrl["e" == ns] - skip - 1 trait.names <- f[ctrl["Names" == ns][1] + 1:ntraits] if(notraits) trait.names <- c(trait.names, f[ctrl["Names" == ns][2] + 1:notraits] ) ns <- strsplit(trait.names, " ") for (i in seq(ns)) ns[[i]] <- ns[[i]][length(ns[[i]])] trait.names <- unlist(ns) # kludge to handle factor phenos f <- matrix(scan(file, "", skip = skip, nlines = nlines, na.strings = ".", blank.lines.skip = FALSE, quiet = TRUE), ncol = size) traits <- t(f[-(1:(2 + nmarkers)), ]) traits = as.data.frame(traits, stringsAsFactors=TRUE) if (nrow(traits) == 1) traits <- as.data.frame(t(traits), stringsAsFactors=TRUE) colnames(traits) <- trait.names tmp = options(warn=-1) for(i in names(traits)){ tmp1 = as.numeric(as.character(traits[[i]])) if(!all(is.na(tmp1))) traits[[i]] = tmp1 } options(tmp) f <- t(f[3:(2 + nmarkers), ]) # here is the translation f = array(as.numeric(f),dim(f)) # omit negative genotypes (treat as missing) f[f<0] <- NA f[!is.na(f)] <- c(NA, 1:3, rep(NA, 7), 4, NA, 5)[2 + f[!is.na(f)]] if (fix.ridh && all(is.na(f) | f == 1 | f == 3)) f[!is.na(f) & f == 3] <- 2 if (fix.bc1) { f[!is.na(f) & f == 5] <- NA f[!is.na(f) & f == 2] <- 1 f[!is.na(f) & f == 3] <- 2 } list(traits = traits, markers = f, cross.class = cross, cross.scheme = cross.scheme) } ###################################################################### # write.cross.qtlcart # # write a QTL cross object to files in QTL Cartographer format ###################################################################### write.cross.qtlcart <- function( cross, filestem="data") { n.ind <- nind(cross) tot.mar <- totmar(cross) n.phe <- nphe(cross) n.chr <- nchr(cross) n.mar <- nmar(cross) type <- crosstype(cross) if(type=="bc") { type <- paste("B", 1 + match(1, names(table(c(pull.geno(cross)))), nomatch = 0), sep = "") } else if(type=="f2") type <- "RF2" else if(type=="riself") type <- "RI1" else if(type=="risib") type <- "RI2" else { warn <- paste("Cross type", type, "may not work with QTL Cartographer.") warning(warn) } # RIL data: convert genotypes to 1/3; later will be converted to 0/2 if(type=="RI1" || type=="RI2") { for(i in 1:n.chr) { g <- cross$geno[[i]]$data g[!is.na(g) & g==2] <- 3 cross$geno[[i]]$data <- g } } # write genotype and phenotype data file <- paste(filestem, ".cro", sep="") if( file.exists( file )) { warning( paste( "previous file", file, "moved to *.bak" )) file.rename( file, paste( file, "bak", sep = "." )) } write("# 123456789 -filetype Rcross.out", file, append=FALSE) # write numbers of progeny, markers and phenotypes write( paste( "-n ", n.ind ), file, append=TRUE) write( paste( "-p ", 1 + tot.mar ), file, append=TRUE) # write experiment type write( paste( "-cross", type ), file, append=TRUE) # write numbers of progeny, markers and phenotypes write( paste( "-traits ", n.phe ), file, append=TRUE) write( "-Names of the traits...", file, append=TRUE) phe <- names( cross$pheno ) for( i in seq( phe )) write( paste( i, phe[i] ), file, append=TRUE) write( paste( "-otraits ", 0 ), file, append=TRUE) # write genotype and phenotype data by individual write( "-s", file, append=TRUE) for( ind in 1:n.ind ) { write( paste( ind, 1 ), file, append=TRUE) for(i in 1:n.chr) { g <- unlist( cross$geno[[i]]$data[ind,] ) g[ is.na( g ) ] <- 0 g <- c(-1,0,1,2,10,12)[ 1 + g ] # if( length( g ) <= 40) write(paste( " ", paste( g, collapse = " " )), file, append=TRUE) # else { # lo <- seq( 1, length(g), by=40) # hi <- c( lo[-1]-1, length( g )) # for(k in seq(along=lo)) { # write( paste( " ", paste( g[lo[k]:hi[k]], collapse = " " )), # file, append=TRUE) # } # } } # end writing marker data p <- c( cross$pheno[ind,]) tmp <- format( p ) tmp[ is.na( p ) ] <- "." write( paste( " ", tmp ), file, append = TRUE ) # end of writing phenotype data } write( "-e", file, append = TRUE ) write( "-q", file, append = TRUE ) # make "prep" file with map information file <- paste(filestem, ".map", sep="") if( file.exists( file )) { warning( paste( "previous file", file, "moved to *.bak" )) file.rename( file, paste( file, "bak", sep = "." )) } write("# 123456789 -filetype Rmap.out", file, append=FALSE) # write numbers of progeny, markers and phenotypes write( "-s", file, append=TRUE) write( "-f 1", file, append=TRUE) write( "-p 0.0000", file, append=TRUE) write( "-u c", file, append=TRUE) write( "#", file, append=TRUE) write( paste( "-c", n.chr ), file, append=TRUE) write( paste( "-i", tot.mar ), file, append=TRUE) map <- lapply( cross$geno, function( x ) x$map ) maplen <- unlist( lapply( map, length )) # mean and SD of number of markers write( paste( "-m", round( mean( maplen ), 3 )), file, append=TRUE) write( paste( "-vm", round( sqrt( var( maplen )), 3 )), file, append=TRUE) mapdif <- lapply( map, diff ) # mean and SD of intermarker distances write( paste( "-d", round( mean( unlist( mapdif )), 3 )), file, append=TRUE) write( paste( "-vd", round( sqrt( var( unlist( mapdif ))), 3 )), file, append=TRUE) write( "-t 0.0000", file, append=TRUE) write( "#", file, append=TRUE) write( " | Chromosome----> ", file, append=TRUE) write( "--------------------------------------", file, append=TRUE) mapmat <- matrix( NA, 1 + max( maplen ), n.chr ) mapmat[ 1, ] <- 0 for( i in seq( along = maplen )) { tmp <- c( mapdif[[i]],0) mapmat[1 + seq( along = tmp ), i ] <- tmp } mapmat <- format(round(mapmat, 6)) ncmap <- nchar( mapmat[1] ) mapmat[ grep( "NA", mapmat ) ] <- paste( rep( " ", ncmap ), collapse = "" ) tmp <- format( seq( n.chr )) write( paste( "Marker | ", paste( paste(" ", tmp, sep=""), collapse = paste( rep( " ", max( 1, ncmap - nchar( tmp ))), collapse = "" ))), file, append=TRUE) write( "--------------------------------------", file, append=TRUE) for( i in seq( nrow( mapmat ))) { j <- 5-nchar(i-1) if(j < 1) j <- 1 write( paste( "-l", paste(rep(" ", j), collapse=""), i - 1, "|", paste( mapmat[i,], collapse = " " )), file, append=TRUE) } write( "---------------------------------------", file, append=TRUE) write( paste( "-Number |", paste( maplen, collapse = " " )), file, append=TRUE) write( "Names and positions of the markers", file, append=TRUE) write( "Chrom Mark Name", file, append=TRUE) write( "-b MarkerNames", file, append=TRUE) for( i in 1:n.chr ) for( j in seq( along = map[[i]] )) write( paste( i, j, names( map[[i]] )[j] ), file, append=TRUE) write( "-e MarkerNames", file, append=TRUE) write( "Names of the Chromosomes", file, append=TRUE) write( "-b ChromosomeNames", file, append=TRUE) for( i in 1:n.chr ) write( paste( i, names( map )[i] ), file, append=TRUE) write( "-e ChromosomeNames", file, append=TRUE) } # end of qtlcart_io.R qtl/R/refineqtl.R0000644000176200001440000005041413576241200013373 0ustar liggesusers###################################################################### # # refineqtl.R # # copyright (c) 2006-2019, Karl W. Broman # last modified Dec, 2019 # first written Jun, 2006 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: refineqtl, plotLodProfile # ###################################################################### ###################################################################### # this is like scanqtl, though the positions are all fixed loci; # it calls scanqtl iteratively, trying to find the best positions for # each QTL. # # the method is like that of that described by Zeng and colleagues # regarding MIM; each QTL is slid from one end of the chromosome to # the other, or to the next flanking QTLs, if there are linked ones # # maxit is the maximum number of iterations (going through all QTLs # in each iteration) to perform ###################################################################### refineqtl <- function(cross, pheno.col=1, qtl, chr, pos, qtl.name, covar=NULL, formula, method=c("imp", "hk"), model=c("normal", "binary"), verbose=TRUE, maxit=10, incl.markers=TRUE, keeplodprofile=TRUE, tol=1e-4, maxit.fitqtl=1000, forceXcovar=FALSE) { method <- match.arg(method) model <- match.arg(model) if( !inherits(cross, "cross") ) stop("The cross argument must be an object of class \"cross\".") # allow formula to be a character string if(!missing(formula) && is.character(formula)) formula <- as.formula(formula) if(!is.null(covar) && !is.data.frame(covar)) { if(is.matrix(covar) && is.numeric(covar)) covar <- as.data.frame(covar, stringsAsFactors=TRUE) else stop("covar should be a data.frame") } if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(!missing(qtl) && (!missing(chr) || !missing(pos) || !missing(qtl.name))) warning("qtl argument is provided, and so chr, pos and qtl.name are ignored.") if(missing(qtl) && (missing(chr) || missing(pos))) stop("Provide either qtl or both chr and pos.") if(!missing(qtl)) { chr <- qtl$chr pos <- qtl$pos } else { # chr and pos provided if(missing(qtl.name)) { if(method=="imp") qtl <- makeqtl(cross, chr=chr, pos=pos, what="draws") else qtl <- makeqtl(cross, chr=chr, pos=pos, what="prob") } else { if(method=="imp") qtl <- makeqtl(cross, chr=chr, pos=pos, qtl.name=qtl.name, what="draws") else qtl <- makeqtl(cross, chr=chr, pos=pos, qtl.name=qtl.name, what="prob") } } if(method=="imp") { if(!("geno" %in% names(qtl))) { if("prob" %in% names(qtl)) { warning("The qtl object doesn't contain imputations; using method=\"hk\".") method <- "hk" } else stop("The qtl object needs to be created with makeqtl with what=\"draws\".") } } else { if(!("prob" %in% names(qtl))) { if("geno" %in% names(qtl)) { warning("The qtl object doesn't contain QTL genotype probabilities; using method=\"imp\".") method <- "imp" } else stop("The qtl object needs to be created with makeqtl with what=\"prob\".") } } if(!all(chr %in% names(cross$geno))) stop("Chr ", paste(unique(chr[!(chr %in% cross$geno)]), sep=" "), " not found in cross.") if(verbose > 1) scanqtl.verbose <- TRUE else scanqtl.verbose <- FALSE cross <- subset(cross, chr=as.character(unique(chr))) # pull out just those chromosomes # save map in the object map <- attr(qtl, "map") if(qtl$n.ind != nind(cross)) { warning("No. individuals in qtl object doesn't match that in the input cross; re-creating qtl object.") if(method=="imp") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") else qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="prob") attr(qtl, "map") <- map } if(method=="imp" && dim(qtl$geno)[3] != dim(cross$geno[[1]]$draws)[3]) { warning("No. imputations in qtl object doesn't match that in the input cross; re-creating qtl object.") qtl <- makeqtl(cross, qtl$chr, qtl$pos, qtl$name, what="draws") attr(qtl, "map") <- map } # minimum distance between pseudomarkers if(is.null(map)) stop("Input qtl object should contain the genetic map.") mind <- min(unlist(lapply(map, function(a) { if(is.matrix(a)) a <- a[1,]; if(length(a) <= 1) return(NULL) # deal with case of a single marker min(diff(a)) })))/2 if(mind <= 0) mind <- 1e-6 # check phenotypes and covariates; drop ind'ls with missing values if(length(pheno.col) > 1) { pheno.col <- pheno.col[1] warning("refineqtl can take just one phenotype; only the first will be used") } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(is.na(num)) stop("Couldn't identify phenotype \"", pheno.col, "\"") pheno.col <- num } if(pheno.col < 1 || pheno.col > nphe(cross)) stop("pheno.col should be between 1 and ", nphe(cross)) pheno <- cross$pheno[,pheno.col] if(!is.null(covar) && nrow(covar) != length(pheno)) stop("nrow(covar) != no. individuals in cross.") if(!is.null(covar)) phcovar <- cbind(pheno, covar) else phcovar <- as.data.frame(pheno, stringsAsFactors=TRUE) hasmissing <- apply(phcovar, 1, function(a) any(is.na(a))) if(all(hasmissing)) stop("All individuals are missing phenotypes or covariates.") if(any(hasmissing)) { origcross <- cross origqtl <- qtl cross <- subset(cross, ind=!hasmissing) pheno <- pheno[!hasmissing] if(!is.null(covar)) covar <- covar[!hasmissing,,drop=FALSE] if(method=="imp") qtl$geno <- qtl$geno[!hasmissing,,,drop=FALSE] else qtl$prob <- lapply(qtl$prob, function(a) a[!hasmissing,,drop=FALSE]) qtl$n.ind <- sum(!hasmissing) } # if missing formula, include the additive QTL plus all covariates if(missing(formula)) { formula <- paste("y ~", paste(qtl$altname, collapse="+")) if(!is.null(covar)) formula <- paste(formula, "+", paste(colnames(covar), collapse="+")) formula <- as.formula(formula) } # drop covariates that are not in the formula if(!is.null(covar)) { theterms <- rownames(attr(terms(formula), "factors")) m <- match(colnames(covar), theterms) if(all(is.na(m))) covar <- NULL else covar <- covar[,!is.na(m),drop=FALSE] } formula <- checkformula(formula, qtl$altname, colnames(covar)) # identify which QTL are in the model formula tovary <- sort(parseformula(formula, qtl$altname, colnames(covar))$idx.qtl) if(length(tovary) != qtl$n.qtl) reducedqtl <- dropfromqtl(qtl, index=(1:qtl$n.qtl)[-tovary]) else reducedqtl <- qtl # if a QTL is missing from the formula, we need to revise the formula, moving # everything over, for use in scanqtl if(any(1:length(tovary) != tovary)) { tempform <- strsplit(deparseQTLformula(formula), " *~ *")[[1]][2] terms <- strsplit(tempform, " *\\+ *")[[1]] for(j in seq(along=terms)) { if(length(grep(":", terms[j])) > 0) { # interaction temp <- strsplit(terms[j], " *: *")[[1]] for(k in seq(along=temp)) { g <- grep("^[Qq][0-9]+$", temp[k]) if(length(g) > 0) { num <- as.numeric(substr(temp[k], 2, nchar(temp[k]))) temp[k] <- paste("Q", which(tovary == num), sep="") } } terms[j] <- paste(temp, collapse=":") } else { g <- grep("^[Qq][0-9]+$", terms[j]) if(length(g) > 0) { num <- as.numeric(substr(terms[j], 2, nchar(terms[j]))) terms[j] <- paste("Q", which(tovary == num), sep="") } } } formula <- as.formula(paste("y ~", paste(terms, collapse=" + "))) } curpos <- pos[tovary] chrnam <- chr[tovary] if(verbose) cat("pos:", curpos, "\n") converged <- FALSE oldo <- NULL lc <- length(chrnam) lastout <- vector("list", length(curpos)) names(lastout) <- qtl$name[tovary] sexpgm <- getsex(cross) cross.attr <- attributes(cross) for(i in 1:maxit) { if(keeplodprofile) # do drop-one analysis basefit <- fitqtlengine(pheno=pheno, qtl=reducedqtl, covar=covar, formula=formula, method=method, model=model, dropone=TRUE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit.fitqtl, forceXcovar=forceXcovar) else basefit <- fitqtlengine(pheno=pheno, qtl=reducedqtl, covar=covar, formula=formula, method=method, model=model, dropone=FALSE, get.ests=FALSE, run.checks=FALSE, cross.attr=cross.attr, crosstype=crosstype(cross), sexpgm=sexpgm, tol=tol, maxit=maxit.fitqtl, forceXcovar=forceXcovar) if(i==1) { origlod <- curlod <- thisitlod <- basefit$result.full[1,4] origpos <- curpos } if(verbose) cat("Iteration", i, "\n") o <- sample(lc) # make sure the first here was not the last before if(!is.null(oldo)) while(o[1] != oldo[lc]) o <- sample(lc) oldo <- o newpos <- curpos for(j in o) { otherchr <- chrnam[-j] otherpos <- newpos[-j] thispos <- as.list(newpos) if(any(otherchr == chrnam[j])) { # linked QTLs linkedpos <- otherpos[otherchr==chr[j]] if(any(linkedpos < newpos[j])) low <- max(linkedpos[linkedpos < newpos[j]]) else low <- -Inf if(any(linkedpos > newpos[j])) high <- min(linkedpos[linkedpos > newpos[j]]) else high <- Inf thispos[[j]] <- c(low, high) } else thispos[[j]] <- c(-Inf, Inf) out <- scanqtl(cross=cross, pheno.col=pheno.col, chr=chrnam, pos=thispos, covar=covar, formula=formula, method=method, model=model, incl.markers=incl.markers, verbose=scanqtl.verbose, tol=tol, maxit=maxit.fitqtl, forceXcovar=forceXcovar) lastout[[j]] <- out newpos[j] <- as.numeric(strsplit(names(out)[!is.na(out) & out==max(out,na.rm=TRUE)],"@")[[1]][2]) if(verbose) { cat(" Q", j, " pos: ", curpos[j], " -> ", newpos[j], "\n", sep="") cat(" LOD increase: ", round(max(out, na.rm=TRUE) - curlod, 3), "\n") } curlod <- max(out, na.rm=TRUE) } if(verbose) { cat("all pos:", curpos, "->", newpos, "\n") cat("LOD increase at this iteration: ", round(curlod - thisitlod, 3), "\n") } thisitlod <- curlod if(max(abs(curpos - newpos)) < mind) { converged <- TRUE break } curpos <- newpos reducedqtl <- replaceqtl(cross, reducedqtl, seq(length(curpos)), reducedqtl$chr, curpos, reducedqtl$name) } if(verbose) { cat("overall pos:", origpos, "->", newpos, "\n") cat("LOD increase overall: ", round(curlod - origlod, 3), "\n") } if(!converged) warning("Didn't converge.") # do the qtl have custom names? g <- grep("^.+@[0-9\\.]+$", qtl$name) if(length(g) == length(qtl$name)) thenames <- NULL else thenames <- qtl$name if(any(hasmissing)) { qtl <- origqtl cross <- origcross } for(j in seq(along=tovary)) qtl <- replaceqtl(cross, qtl, tovary[j], chrnam[j], newpos[j]) if(!is.null(thenames)) qtl$name <- thenames if(keeplodprofile) { # subtract off the results from the drop-one analysis from the LOD profiles dropresult <- basefit$result.drop if(is.null(dropresult)) { if(length(lastout)==1) { dropresult <- rbind(c(NA,NA, basefit$result.full[1,4])) rownames(dropresult) <- names(lastout) } else stop("There's a problem: need dropresult, but didn't obtain one.") } rn <- rownames(dropresult) qn <- names(lastout) for(i in seq(along=lastout)) { if(sum(rn==qn[i])>1) # ack! multiple QTL at same position warning("Multiple QTL at the same location.") lastout[[i]] <- lastout[[i]] - (max(lastout[[i]], na.rm=TRUE) - max(dropresult[rn==qn[i],3])) pos <- as.numeric(matrix(unlist(strsplit(names(lastout[[i]]), "@")),byrow=TRUE,ncol=2)[,2]) chr <- rep(qtl$chr[tovary][i], length(pos)) lastout[[i]] <- data.frame(chr=chr, pos=pos, lod=as.numeric(lastout[[i]]), stringsAsFactors=TRUE) } names(lastout) <- qtl$name[tovary] # make the profiles scanone objects for(i in seq(along=lastout)) { class(lastout[[i]]) <- c("scanone", "data.frame") thechr <- qtl$chr[i] if(method=="imp") detailedmap <- attr(cross$geno[[thechr]]$draws,"map") else detailedmap <- attr(cross$geno[[thechr]]$prob,"map") if(is.matrix(detailedmap)) detailedmap <- detailedmap[1,] r <- range(lastout[[i]][,2])+c(-1e-5, 1e-5) rn <- names(detailedmap)[detailedmap>=r[1] & detailedmap<=r[2]] o <- grep("^loc-*[0-9]+",rn) if(length(o) > 0) # inter-marker locations cited as "c*.loc*" rn[o] <- paste("c",thechr,".",rn[o],sep="") # if(length(rn) != nrow(lastout[[i]])) return(list(lastout[[i]], rn, detailedmap)) if(length(rn) == nrow(lastout[[i]])) rownames(lastout[[i]]) <- rn } attr(qtl, "lodprofile") <- lastout } # if there's a pLOD attribute, revise it if("pLOD" %in% names(attributes(qtl)) && curlod > origlod) attr(qtl,"pLOD") <- attr(qtl,"pLOD") + curlod - origlod qtl } ###################################################################### # plotLodProfile # # This is for creating a plot of 1-d LOD profiles calculated within # refineqtl. ###################################################################### plotLodProfile <- function(qtl, chr, incl.markers=TRUE, gap=25, lwd=2, lty=1, col="black", qtl.labels=TRUE, mtick=c("line", "triangle"), show.marker.names=FALSE, alternate.chrid=FALSE, add=FALSE, showallchr=FALSE, labelsep=5, ...) { if(!inherits(qtl, "qtl")) stop("Input qtl is not a qtl object") if(nqtl(qtl) == 0) stop("Null QTL model; there are no profiles to plot") lodprof <- attr(qtl, "lodprofile") if(is.null(lodprof)) stop("You must first run refineqtl, using keeplodprofile=TRUE") m <- match(qtl$name, names(lodprof)) if(any(is.na(m))) qtl <- dropfromqtl(qtl, index=which(is.na(m)), drop.lod.profile=FALSE) # reorder qtl by position if(qtl$n.qtl > 1) { chrindex <- match(qtl$chr, names(attr(qtl, "map"))) if(any(is.na(chrindex))) stop("Cannot find chr ", qtl$chr[is.na(chrindex)]) neworder <- order(chrindex, qtl$pos) if(any(neworder != seq(qtl$n.qtl))) { qtl <- reorderqtl(qtl, neworder) lodprof <- attr(qtl, "lodprofile") } } n.qtl <- length(lodprof) if(length(lwd) == 1) lwd <- rep(lwd, n.qtl) else { if(length(lwd) != n.qtl) { warning("lwd should have length 1 or ", n.qtl) lwd <- rep(lwd[1], n.qtl) } else lwd <- lwd[neworder] } if(length(lty) == 1) lty <- rep(lty, n.qtl) else { if(length(lty) != n.qtl) { warning("lty should have length 1 or ", n.qtl) lty <- rep(lty[1], n.qtl) } else lty <- lty[neworder] } if(length(col) == 1) col <- rep(col, n.qtl) else { if(length(col) != n.qtl) { warning("col should have length 1 or ", n.qtl) if(length(col) < n.qtl) col <- rep(col, n.qtl)[1:n.qtl] else col <- col[1:n.qtl] } else col <- col[neworder] } map <- attr(qtl, "map") if(is.null(map)) stop("Input qtl object should contain the genetic map.") thechr <- unique(qtl$chr) orderedchr <- names(map) if(showallchr) chr2keep <- seq(along=orderedchr) else chr2keep <- which(!is.na(match(orderedchr, thechr))) tempscan <- NULL for(i in chr2keep) { temp <- data.frame(chr=orderedchr[i], pos=as.numeric(map[[i]]), lod=NA, stringsAsFactors=TRUE) rownames(temp) <- names(map[[i]]) tempscan <- rbind(tempscan, temp) } class(tempscan) <- c("scanone", "data.frame") if(missing(chr)) { if(showallchr) chr <- orderedchr else chr <- thechr } dontskip <- which(!is.na(match(qtl$chr, chr))) if(length(dontskip)==0) stop("Nothing to plot.") ymax <- max(sapply(lodprof[dontskip], function(a) max(a[,3], na.rm=TRUE))) begend <- matrix(unlist(tapply(tempscan[,2],tempscan[,1],range)),ncol=2,byrow=TRUE) rownames(begend) <- unique(tempscan[,1]) begend <- begend[as.character(chr),,drop=FALSE] len <- begend[,2]-begend[,1] if(length(chr)==1) start <- 0 else start <- c(0,cumsum(len+gap))-c(begend[,1],0) names(start) <- chr dots <- list(...) if(!add) { if("ylim" %in% names(dots)) { plot.scanone(tempscan, chr=chr, incl.markers=incl.markers, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, type="n", ...) } else { if(qtl.labels) ylim <- c(0, ymax+1) else ylim <- c(0, ymax) plot.scanone(tempscan, chr=chr, incl.markers=incl.markers, gap=gap, mtick=mtick, show.marker.names=show.marker.names, alternate.chrid=alternate.chrid, type="n", ylim=ylim, ...) } } for(i in dontskip) { temp <- rbind(tempscan[tempscan[,1] != qtl$chr[i] | (tempscan[,1] == qtl$chr[i] & (tempscan[,2] < min(lodprof[[i]][,2]) | tempscan[,2] > max(lodprof[[i]][,2], na.rm=TRUE))),], lodprof[[i]]) temp <- temp[order(match(temp[,1], orderedchr), temp[,2]),] class(temp) <- c("scanone", "data.frame") plot.scanone(temp, chr=chr, incl.markers=FALSE, gap=gap, add=TRUE, col=col[i], lwd=lwd[i], lty=lty[i], ...) if(qtl.labels) { maxlod <- max(temp[,3], na.rm=TRUE) maxpos <- median(temp[!is.na(temp[,3]) & temp[,3]==maxlod,2] + start[qtl$chr[i]]) d <- diff(par("usr")[3:4]*labelsep/100) text(maxpos, maxlod + d, names(lodprof)[i], col=col[i], font=(lwd[i]>1)+1, ...) } } invisible() } # end of refineqtl.R qtl/R/readMWril.R0000644000176200001440000002647313626261114013302 0ustar liggesusers###################################################################### # # readMWril.R # # copyright (c) 2009-2020, Karl W Broman # last modified Feb, 2020 # first written Apr, 2009 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: readMWril # ###################################################################### ###################################################################### # # readMWril # # read multi-way RIL data in comma-delimited format, # with a separate file for the founder genotypes, and possible a # separate file for the phenotype data. # ###################################################################### readMWril <- function(dir, rilfile, founderfile, type=c("ri4self", "ri4sib", "ri8self", "ri8selfIRIP1", "ri8sib", "bgmagic16"), na.strings=c("-","NA"), rotate=FALSE, ...) { # create file names if(missing(rilfile) || missing(founderfile)) stop("Need to specify rilfile and founderfile.") if(!missing(dir) && dir != "") { rilfile <- file.path(dir, rilfile) founderfile <- file.path(dir, founderfile) } type <- match.arg(type) args <- list(...) # if user wants to use comma for decimal point, we need if(length(args) > 0 && "dec" %in% names(args)) { dec <- args[["dec"]] } else dec <- "." # read the data file if(length(args) < 1 || !("sep" %in% names(args))) { # "sep" not in the "..." argument and so take sep="," if(length(args) < 1 || !("comment.char" %in% names(args))) { gen <- read.table(rilfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) founder <- read.table(founderfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) } else { gen <- read.table(rilfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) founder <- read.table(founderfile, sep=",", na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } } else { if(length(args) < 1 || !("comment.char" %in% names(args))) { gen <- read.table(rilfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) founder <- read.table(founderfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, comment.char="", ...) } else { gen <- read.table(rilfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) founder <- read.table(founderfile, na.strings=na.strings, colClasses="character", fill=TRUE, stringsAsFactors=TRUE, blank.lines.skip=TRUE, ...) } } if(rotate) { gen <- as.data.frame(t(gen), stringsAsFactors=FALSE) founder <- as.data.frame(t(founder), stringsAsFactors=FALSE) } rn <- founder[-1,1] cn <- founder[1,-1] founder <- founder[-1,-1, drop=FALSE] founder <- matrix(as.numeric(unlist(founder)), ncol=length(cn)) dimnames(founder) <- list(rn, cn) # determine number of phenotypes based on initial blanks in row 2 n <- ncol(gen) temp <- rep(FALSE,n) for(i in 1:n) { temp[i] <- all(gen[2,1:i]=="") if(!temp[i]) break } if(!any(temp)) # no phenotypes! stop("You must include at least one phenotype (e.g., an index).") n.phe <- max((1:n)[temp]) # Is map included? yes if first n.phe columns in row 3 are all blank if(all(!is.na(gen[3,1:n.phe]) & gen[3,1:n.phe]=="")) { map.included <- TRUE map <- asnumericwithdec(unlist(gen[3,-(1:n.phe)]), dec=dec) if(any(is.na(map))) stop("There are missing marker positions.") nondatrow <- 3 } else { map.included <- FALSE map <- rep(0,ncol(gen)-n.phe) nondatrow <- 2 # last non-data row } pheno <- as.data.frame(gen[-(1:nondatrow),1:n.phe,drop=FALSE], stringsAsFactors=FALSE) colnames(pheno) <- as.character(gen[1,1:n.phe]) # replace empty cells with NA gen <- sapply(gen,function(a) { a[!is.na(a) & a==""] <- NA; a }) # pull apart phenotypes, genotypes and map mnames <- gen[1,-(1:n.phe)] if(any(is.na(mnames))) stop("There are missing marker names.") chr <- gen[2,-(1:n.phe)] if(any(is.na(chr))) stop("There are missing chromosome IDs.") gen <- matrix(as.numeric(gen[-(1:nondatrow),-(1:n.phe)]), ncol=ncol(gen)-n.phe) pheno <- data.frame(lapply(pheno, sw2numeric, dec=dec), stringsAsFactors=TRUE) n.str <- nrow(founder) if(type == "ri8selfIRIP1"){ } else if(!("cross" %in% names(pheno))) { warning("Need a phenotype named \"cross\"; assuming all come from the cross ", paste(LETTERS[1:n.str], collapse="x")) crosses <- matrix(1:n.str, ncol=n.str, nrow=nrow(gen), byrow=TRUE) } else { pheno$cross <- as.character(pheno$cross) if(any(nchar(pheno$cross) != n.str)) stop("Mismatches in length of \"cross\" phenotype.") thecross <- matrix(unlist(strsplit(pheno$cross, "")), byrow=TRUE, ncol=n.str) crosses <- matrix(NA, ncol=n.str, nrow=nrow(gen)) for(i in 1:nrow(thecross)) crosses[i,] <- match(thecross[i,], LETTERS[1:n.str]) if(any(is.na(crosses))) stop("Problems in the \"cross \" phenotype.") } # check founder data matches in dimension if(ncol(founder) != ncol(gen)) stop("Different numbers of markers in RIL and founder files.") if(any(colnames(founder) != mnames)) { cnf <- colnames(founder) if(any(is.na(match(cnf, mnames))) || any(is.na(match(mnames, cnf)))) stop("Mismatch in markers in RIL and founder files.") founder <- founder[,match(mnames, cnf),drop=FALSE] } wh <- which(is.na(gen)) missingval <- min(as.numeric(c(gen, founder)), na.rm=TRUE)-1 gen[wh] <- missingval founder[is.na(founder)] <- missingval d <- dim(gen) if(type == "ri8selfIRIP1") { gen <- .C("R_reviseMWrilNoCross", as.integer(d[1]), as.integer(d[2]), as.integer(n.str), as.integer(founder), gen=as.integer(gen), as.integer(missingval), PACKAGE="qtl")$gen } else { gen <- .C("R_reviseMWril", as.integer(d[1]), as.integer(d[2]), as.integer(n.str), as.integer(founder), gen=as.integer(gen), as.integer(crosses), as.integer(missingval), PACKAGE="qtl")$gen } gen[wh] <- NA gen <- matrix(gen, nrow=d[1]) gen[gen==0 | gen==(2^n.str-1)] <- NA # re-order the markers by chr and position # try to figure out the chr labels if(all(chr %in% c(1:999,"X","x"))) { # 1...19 + X tempchr <- chr tempchr[chr=="X" | chr=="x"] <- 1000 tempchr <- as.numeric(tempchr) if(map.included) neworder <- order(tempchr, map) else neworder <- order(tempchr) chr <- chr[neworder] map <- map[neworder] gen <- gen[,neworder,drop=FALSE] mnames <- mnames[neworder] } # fix up dummy map if(!map.included) { map <- split(rep(0,length(chr)),chr)[unique(chr)] map <- unlist(lapply(map,function(a) seq(0,length=length(a),by=5))) names(map) <- NULL } # fix up map information # number of chromosomes uchr <- unique(chr) n.chr <- length(uchr) geno <- vector("list",n.chr) names(geno) <- uchr min.mar <- 1 for(i in 1:n.chr) { # loop over chromosomes # create map temp.map <- map[chr==uchr[i]] names(temp.map) <- mnames[chr==uchr[i]] # pull out appropriate portion of genotype data data <- gen[,min.mar:(length(temp.map)+min.mar-1),drop=FALSE] min.mar <- min.mar + length(temp.map) colnames(data) <- names(temp.map) geno[[i]] <- list(data=data,map=temp.map) if(uchr[i] == "X" || uchr[i] == "x") class(geno[[i]]) <- "X" else class(geno[[i]]) <- "A" } cross <- list(geno=geno,pheno=pheno) # check that data dimensions match n.mar1 <- sapply(geno,function(a) ncol(a$data)) n.mar2 <- sapply(geno,function(a) length(a$map)) n.phe <- ncol(pheno) n.ind1 <- nrow(pheno) n.ind2 <- sapply(geno,function(a) nrow(a$data)) if(any(n.ind1 != n.ind2)) { cat(n.ind1,n.ind2,"\n") stop("Number of individuals in genotypes and phenotypes do not match."); } if(any(n.mar1 != n.mar2)) { cat(n.mar1,n.mar2,"\n") stop("Numbers of markers in genotypes and marker names files do not match."); } # print some information about the amount of data read cat(" --Read the following data:\n"); cat("\t", n.ind1, " individuals\n"); cat("\t", sum(n.mar1), " markers\n"); cat("\t", n.phe, " phenotypes\n"); if(all(is.na(gen))) warning("There is no genotype data!\n") if(type != "ri8selfIRIP1") { cross$cross <- crosses } # save founder genotypes in data founder[founder==missingval] <- NA ua <- apply(founder, 2, function(a) unique(a[!is.na(a)])) nua <- sapply(ua, length) if(all(nua <= 2)) { # re-code as 0/1 for(i in 1:ncol(founder)) { if(nua[i]==1) founder[!is.na(founder[,i]),i] <- 0 else if(nua[i]==2) { founder[!is.na(founder[,i]) & founder[,i]==ua[[i]][1],i] <- 0 founder[!is.na(founder[,i]) & founder[,i]==ua[[i]][2],i] <- 1 } } } cross$founderGeno <- founder class(cross) <- c(type, "cross") # check data summary(cross) cross } # end of readMWril.R qtl/R/mqmsnow.R0000644000176200001440000000643212770016226013107 0ustar liggesusers##################################################################### # # mqmsnow.R # # Copyright (c) 2009-2010, Danny Arends # # Modified by Karl Broman and Pjotr Prins # # # first written Februari 2009 # last modified April 2010 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: snowCoreALL # snowCoreBOOT # # ##################################################################### snowCoreALL <- function(x,all.data,scanfunction,cofactors,verbose=FALSE,...){ b <- proc.time() result <- NULL num.traits <- nphe(all.data) if(verbose) { cat("------------------------------------------------------------------\n") cat("INFO: Starting analysis of trait (",x,"/",num.traits,")\n") cat("------------------------------------------------------------------\n") } if(!is.null(cofactors)) { result <- scanfunction(cross=all.data,cofactors=cofactors,pheno.col=x,verbose=verbose,...) } else{ result <- scanfunction(cross=all.data,pheno.col=x,...) } colnames(result)[3] <- paste("LOD",names(all.data$pheno)[x]) e <- proc.time() if(verbose) { cat("------------------------------------------------------------------\n") cat("INFO: Done with the analysis of trait (",x,"/",num.traits,")\n") cat("INFO: Calculation of trait",x,"took:",round((e-b)[3], digits=3)," seconds\n") cat("------------------------------------------------------------------\n") } result } snowCoreBOOT <- function(x,all.data,scanfunction,bootmethod,cofactors,verbose=FALSE,...){ b <- proc.time() result <- NULL if(!bootmethod){ #random permutation neworder <- sample(nind(all.data)) all.data$pheno[[1]] <- all.data$pheno[[1]][neworder] }else{ #parametric permutation all.data$pheno[[1]] <- rnorm(nind(all.data)) } if("cofactors" %in% names(formals(scanfunction))){ if(!is.null(cofactors)){ result <- scanfunction(cross=all.data,cofactors=cofactors,pheno.col=1,verbose=FALSE,...) }else{ result <- scanfunction(cross=all.data,pheno.col=1,verbose=FALSE,...) } }else{ if("plot" %in% names(formals(scanfunction))){ result <- scanfunction(cross=all.data,pheno.col=1,...) }else{ result <- scanfunction(cross=all.data,pheno.col=1,...) } } e <- proc.time() if(verbose) { cat("------------------------------------------------------------------\n") cat("INFO: Done with bootstrap\n") cat("INFO: Calculation took:",round((e-b)[3], digits=3)," seconds\n") cat("------------------------------------------------------------------\n") } result } # end of mqmsnow.R qtl/R/cim.R0000644000176200001440000002140714067054720012157 0ustar liggesusers###################################################################### # # cim.R # # copyright (c) 2007-2021, Karl W Broman # last modified Jun, 2021 # first written Jan, 2007 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: cim, markerforwsel, markerforwself2, expandf2covar # ###################################################################### ###################################################################### # CIM by first doing forward selection at the markers (with filled-in # data) to a fixed number of markers, followed by interval mapping with # the selected markers as covariates, dropping marker covariates if # they are within some fixed window of the location under test. ###################################################################### cim <- function(cross, pheno.col=1, n.marcovar=3, window=10, method=c("em", "imp", "hk", "ehk"), imp.method=c("imp", "argmax"), error.prob=0.0001, map.function=c("haldane", "kosambi", "c-v", "morgan"), addcovar=NULL, n.perm) { method <- match.arg(method) imp.method <- match.arg(imp.method) map.function <- match.arg(map.function) if(!is.null(addcovar)) { if(!is.matrix(addcovar)) addcovar <- as.matrix(addcovar) if(nrow(addcovar) != nind(cross)) { stop("nrow(addcovar) != no. individuals in cross") } } type <- crosstype(cross) if(type=="4way") stop("cim() has not been implemented for 4-way crosses") if(LikePheVector(pheno.col, nind(cross), nphe(cross))) { cross$pheno <- cbind(pheno.col, cross$pheno) pheno.col <- 1 } if(is.character(pheno.col)) { num <- find.pheno(cross, pheno.col) if(any(is.na(num))) { if(sum(is.na(num)) > 1) stop("Couldn't identify phenotypes ", paste(paste("\"", pheno.col[is.na(num)], "\"", sep=""), collapse=" ")) else stop("Couldn't identify phenotype \"", pheno.col[is.na(num)], "\"") } pheno.col <- num } if(any(pheno.col < 1 | pheno.col > nphe(cross))) stop("pheno.col values should be between 1 and the no. phenotypes") y <- cross$pheno[,pheno.col] if(any(is.na(y))) { cross <- subset(cross, ind=(!is.na(y))) y <- y[!is.na(y)] } if(!missing(n.perm) && n.perm > 0) { results <- matrix(ncol=1, nrow=n.perm) for(i in 1:n.perm) { o <- sample(length(y)) y <- y[o] cross$pheno[,pheno.col] <- y temp <- cim(cross, pheno.col=pheno.col, n.marcovar=n.marcovar, window=window, method=method, imp.method=imp.method, error.prob=error.prob, map.function=map.function, addcovar=addcovar) results[i,1] <- max(temp[,3], na.rm=TRUE) } class(results) <- c("scanoneperm", "matrix") return(results) } window <- window/2 # window specifies twice the distance between marker and test position g <- pull.geno(cross) if(any(is.na(g))) g <- pull.geno(fill.geno(cross, method=imp.method, error.prob=error.prob, map.function=map.function)) if(type=="f2") out.forw <- markerforwself2(g, y, n.marcovar) else out.forw <- markerforwsel(g, y, n.marcovar) mar <- colnames(g)[out.forw] chrpos <- find.markerpos(cross, mar) ac <- g[,mar,drop=FALSE] if(type=="f2") useac <- expandf2covar(ac) else useac <- ac firstscan <- scanone(cross, pheno.col=pheno.col, addcovar=cbind(useac,addcovar), method=method) # scan again, dropping one marker covariate at a time for(i in seq(along=mar)) { if(type=="f2") useac <- expandf2covar(ac[,-i]) else useac <- ac[,-i] temp <- scanone(cross, pheno.col=pheno.col, addcovar=cbind(useac,addcovar), method=method, chr=chrpos[i,1]) wh1 <- (firstscan[,1]==chrpos[i,1] & firstscan[,2] >= chrpos[i,2]-window & firstscan[,2] <= chrpos[i,2]+window) wh2 <- (temp[,2] >= chrpos[i,2]-window & temp[,2] <= chrpos[i,2] + window) firstscan[wh1,3] <- temp[wh2,3] } attr(firstscan, "marker.covar") <- mar attr(firstscan, "marker.covar.pos") <- chrpos u <- table(chrpos[,1]) if(any(u>1)) { # chromosomes with multiple marker covariates u <- names(u)[u>1] for(j in u) { wh <- which(chrpos[,1]==j) pos <- chrpos[wh,2] # positions of the covariates on this chromosome scanpos <- firstscan[firstscan[,1]==j,2] # positions at which the genome scan is performed # matrix indicating, for each position, whether marker covariates need to be dropped need2drop <- t(sapply(scanpos, function(a,b,d) as.numeric(abs(a-b) <= d), pos, window)) n2drop <- apply(need2drop, 1, sum) if(any(n2drop > 1)) { pat2drop <- apply(need2drop, 1, paste, collapse="") thepat <- unique(pat2drop[n2drop > 1]) for(k in thepat) { whpos <- which(pat2drop==k) whpos2 <- (firstscan[,1]==j & !is.na(match(firstscan[,2], scanpos[whpos]))) tempac <- ac[,-wh[as.logical(need2drop[whpos[1],])]] if(type=="f2") useac <- expandf2covar(tempac) else useac <- tempac temp <- scanone(cross, pheno.col=pheno.col, addcovar=cbind(useac,addcovar), method=method, chr=j) firstscan[whpos2,3] <- temp[whpos,3] } } } } firstscan } ###################################################################### # Simple forward selection to a fixed number of covariates # # x = matrix of covariates # y = outcome # maxsize = maximum size of model # # output: indices of chosen covariates [1, 2, ..., ncol(x)] ###################################################################### markerforwsel <- function(x, y, maxsize=7) { if(length(y) != nrow(x)) stop("Need length(y) == nrow(x).") if(maxsize < 0 || maxsize > ncol(x)) stop("Need maxsize between 1 and ncol(x).") out <- .C("R_markerforwsel", as.integer(nrow(x)), as.integer(ncol(x)), as.double(x), as.double(y), as.integer(maxsize), chosen=as.integer(rep(0,maxsize)), rss=as.double(rep(0,maxsize)), PACKAGE="qtl") # out$chosen+1 temp <- out$chosen+1 attr(temp, "rss") <- out$rss temp } ###################################################################### # The same as markerforwsel, but for an intercross, in which # we need to expand each marker to two columns and do selection # with those pairs of columns ###################################################################### markerforwself2 <- function(x, y, maxsize=7) { if(length(y) != nrow(x)) stop("Need length(y) == nrow(x).") if(maxsize < 0 || maxsize > ncol(x)) stop("Need maxsize between 1 and ncol(x).") out <- .C("R_markerforwself2", as.integer(nrow(x)), as.integer(ncol(x)), as.integer(x), as.double(y), as.integer(maxsize), chosen=as.integer(rep(0,maxsize)), rss=as.double(rep(0,maxsize)), PACKAGE="qtl") # out$chosen+1 temp <- out$chosen+1 attr(temp, "rss") <- out$rss temp } ###################################################################### # expand covariates for F2 ###################################################################### expandf2covar <- function(thecovar) { if(is.null(thecovar) || (is.matrix(thecovar) && ncol(thecovar)==0)) return(NULL) if(!is.matrix(thecovar)) return(cbind((thecovar==3) - (thecovar==1), as.numeric(thecovar==2))) revcovar <- matrix(ncol=ncol(thecovar)*2, nrow=nrow(thecovar)) for(i in 1:ncol(thecovar)) { revcovar[,i*2-1] <- (thecovar[,i]==3) - (thecovar[,i]==1) revcovar[,i*2] <- as.numeric(thecovar[,i]==2) } revcovar } # end of cim.R qtl/R/droponemarker.R0000644000176200001440000001006213576241200014245 0ustar liggesusers###################################################################### # # droponemarker.R # # copyright (c) 2019, Karl W Broman # last modified Dec, 2019 # first written Oct, 2001 # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License, # version 3, as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but without any warranty; without even the implied warranty of # merchantability or fitness for a particular purpose. See the GNU # General Public License, version 3, for more details. # # A copy of the GNU General Public License, version 3, is available # at http://www.r-project.org/Licenses/GPL-3 # # Part of the R/qtl package # Contains: droponemarker # ###################################################################### ###################################################################### # # droponemarker: Drop one marker at a time from a genetic map, to # evaluate the change in log likelihood and in map # length, in order to identify problematic markers # ###################################################################### droponemarker <- function(cross, chr, error.prob=0.0001, map.function=c("haldane", "kosambi", "c-f", "morgan"), m=0, p=0, maxit=4000, tol=1e-6, sex.sp=TRUE, verbose=TRUE) { if(!inherits(cross, "cross")) stop("Input must have class \"cross\".") if(!missing(chr)) cross <- subset(cross, chr=chr) if(any(nmar(cross) < 3)) { if(all(nmar(cross) < 3)) stop("No chromosomes with at least three markers\n") todrop <- names(cross$geno)[nmar(cross) < 3] tokeep <- names(cross$geno)[nmar(cross) > 2] warning("Dropping chr with <3 markers: ", paste(todrop, collapse=", ")) cross <- subset(cross, chr=tokeep) } map.function <- match.arg(map.function) if(verbose) cat(" -Re-estimating map\n") origmap <- est.map(cross, error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp) cross <- replace.map(cross, origmap) origmaptab <- pull.map(cross, as.table=TRUE) origmaptab <- cbind(origmaptab, LOD=rep(NA, nrow(origmaptab))) if(is.matrix(origmap[[1]])) { origmaptab <- cbind(origmaptab, Ldiff.female=rep(NA, nrow(origmaptab)), Ldiff.male=rep(NA, nrow(origmaptab))) sexsp <- TRUE } else { origmaptab <- cbind(origmaptab, Ldiff=rep(NA, nrow(origmaptab))) sexsp <- FALSE } for(i in names(cross$geno)) { if(sexsp) { Lf <- diff(range(origmap[[i]][1,])) Lm <- diff(range(origmap[[i]][2,])) } else L <- diff(range(origmap[[i]])) if(verbose) cat(" -Chromosome", i, "\n") mnames <- markernames(cross, chr=i) temp <- subset(cross, chr=i) for(j in seq(along=mnames)){ if(verbose > 1) cat(" ---Marker", j, "of", length(mnames), "\n") markerll <- markerloglik(cross, mnames[j], error.prob) newmap <- est.map(drop.markers(temp, mnames[j]), error.prob=error.prob, map.function=map.function, m=m, p=p, maxit=maxit, tol=tol, sex.sp=sex.sp) if(sexsp) { origmaptab[mnames[j],4] <- -(attr(origmap[[i]], "loglik") - markerll - attr(newmap[[1]], "loglik"))/log(10) origmaptab[mnames[j],5] <- Lf - diff(range(newmap[[1]][1,])) origmaptab[mnames[j],6] <- Lm - diff(range(newmap[[1]][2,])) } else { origmaptab[mnames[j],3] <- -(attr(origmap[[i]], "loglik") - markerll - attr(newmap[[1]], "loglik"))/log(10) origmaptab[mnames[j],4] <- L - diff(range(newmap[[1]])) } } } class(origmaptab) <- c("scanone", "data.frame") origmaptab$chr <- factor(origmaptab$chr, levels=unique(origmaptab$chr)) origmaptab } # end of droponemarker.R qtl/vignettes/0000755000176200001440000000000014661346501013070 5ustar liggesusersqtl/vignettes/goldensectionsearch.pdf0000644000176200001440000071556312770016226017624 0ustar liggesusers%PDF-1.5 %âãÏÓ 1 0 obj <>/OCGs[6 0 R]>>/Pages 3 0 R/Type/Catalog>> endobj 2 0 obj <>stream application/pdf golden section search 2012-06-27T12:18:14-05:00 2012-06-27T12:18:14-05:00 2012-06-27T12:18:14-05:00 Adobe Illustrator CS5.1 256 116 JPEG /9j/4AAQSkZJRgABAgEASABIAAD/7QAsUGhvdG9zaG9wIDMuMAA4QklNA+0AAAAAABAASAAAAAEA AQBIAAAAAQAB/+4ADkFkb2JlAGTAAAAAAf/bAIQABgQEBAUEBgUFBgkGBQYJCwgGBggLDAoKCwoK DBAMDAwMDAwQDA4PEA8ODBMTFBQTExwbGxscHx8fHx8fHx8fHwEHBwcNDA0YEBAYGhURFRofHx8f Hx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8fHx8f/8AAEQgAdAEAAwER AAIRAQMRAf/EAaIAAAAHAQEBAQEAAAAAAAAAAAQFAwIGAQAHCAkKCwEAAgIDAQEBAQEAAAAAAAAA AQACAwQFBgcICQoLEAACAQMDAgQCBgcDBAIGAnMBAgMRBAAFIRIxQVEGE2EicYEUMpGhBxWxQiPB UtHhMxZi8CRygvElQzRTkqKyY3PCNUQnk6OzNhdUZHTD0uIIJoMJChgZhJRFRqS0VtNVKBry4/PE 1OT0ZXWFlaW1xdXl9WZ2hpamtsbW5vY3R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo+Ck5SVlpeYmZ qbnJ2en5KjpKWmp6ipqqusra6voRAAICAQIDBQUEBQYECAMDbQEAAhEDBCESMUEFURNhIgZxgZEy obHwFMHR4SNCFVJicvEzJDRDghaSUyWiY7LCB3PSNeJEgxdUkwgJChgZJjZFGidkdFU38qOzwygp 0+PzhJSktMTU5PRldYWVpbXF1eX1RlZmdoaWprbG1ub2R1dnd4eXp7fH1+f3OEhYaHiImKi4yNjo +DlJWWl5iZmpucnZ6fkqOkpaanqKmqq6ytrq+v/aAAwDAQACEQMRAD8A9U4qhtP/ALh/+M0//J58 VROKqb3CBiigySDqib0+ZNAPpOLIQK2t23QJEOoLVc/IgcQPvOKfSPN3ozndrhgfBFUL9zBz+OK8 Q7nehL/y0yfdH/zRivEO4fb+t3oS/wDLTJ90f/NGK8Q7h9v62KafrOoaX5ln0PVr8XVzqc093p9x 9UWCGK2QW8UcLyeooeQvMEWlSx602xQCOoZXzu16xowHUqxBPyUin0cvpxTUe931mn95FInh8POv /Ivn+OK8HcR+PevjuIJDSORWYblQQSPmMUGJHMKN3/f2X/GY/wDJmTFiicVdirsVdirsVdiqGu/7 +y/4zH/kzJiqJxV2KuxV2KuxV2KuxV2KuxV2KuxV2Ksa8peerHzLealZQWVzZXWkssd5Dcvauyuz yRlD9VnueLK0LbPTajCqkHFU8sCBbuTsBNPU/wDPZ8VX/HP3KQ9qEhm+kbgYs/p96qiIihUUKo6K BQYsSbbxQ7FXYq7FUE+m2Vzdm4u7eC4mhcG1kdFd4hSN6KxFV/eIG29jiqNxV2KrZIopABIiuBuA wB/XikSI5JFrmkp+ktJ1IX95axafJM72sDlopQ1vJ/eRFZC3AD4QuKTK+ar5Z8xR+YNDtNZsAHtb yMSLG/GOaOorwkVWmXnvuvIUxT6T5Jp9aRf71Wh93Hw/Swqo+/FeA9N1VWVlDKQyncEbg4sCKbxV 2KuxVDXf9/Zf8Zj/AMmZMVROKuxV2KuxV2KuxV2KuxV2KuxV2KuxV5v+Vy3X+K/O8kkF0lvJfn0J 5oBFBJxnuFb0JlAFzxoOUjHku0dOKKSqzmy/eo0X+61mmaX3PrPRf4n+3FmNhaPxYOxV2KuxV2Ku xVRg9L1bnhXl6g9WvTl6adPbjTFVbFXYq7FUNeANNZgioMzAg9KejJirdhp2n6fbi2sLWK0tlJIh gRYkBPU8UAGKojFVJrWEsWA4OdyyEqSfelK/TizEy1xuk+y6yjwccT/wSin/AAuK3E+X4/HV31pV /vkaL/Kbdf8AghUD6aYrwd26qrKyhlIZTuCNwcWBFIe7/v7L/jMf+TMmKonFXYq7FXYq7FXYq7FX Yq7FXYq7FXYq8j/I/wAvwaHrvmyzt7DTLaKOWGIXWmSyv6xiluYz6kUt7qBh4lfsngQaihpXFWTa P5FuotXtNak1u4urqzl1BK3KI9Y7q7R2RQvBE+CDhUJXfrQBcVtm2KuxV2KuxV2KuxVZGZecvNQq hx6ZHdeK7n/ZVGKr8VdirsVQ13/f2X/GY/8AJmTFUTirsVdirsVdiqk1tCWLKPTc7l0+Ek+Jp9r6 cWQmUl8wjzKs+lR6V6EqS3RS7mnYxyxRGCWskfFJEd1O4UrTse5CpIK/ydp3mHTdFh0/W7mO9mtY 4Yo7wSSyyylYE9Z5nlAJYz+pxp+zx71xYp5irsVdirsVdirsVdirsVdirsVdiryT8qIPKegeZ9W0 zT9KttDuL704TBay6tdpNNavch6XF9a2sAA4uFERPLi38uKvUtP/ALh/+M0//J58VROKuxV2KuxV 2KuxVSh4+pcUcufUHJf5D6a/D92/04qq4q7FXYqhrv8Av7L/AIzH/kzJiqJxV2KuxV2KuxV2Koa7 /v7L/jMf+TMmKonFXYq7FXYq7FXYq7FXYq7FXYq7FXYq88/L3SNMTzP5j1GCCd/r9xHqCz3ek3em lZna4Q0e8CmSRYpOBaJUXj1HJmLKs60/+4f/AIzT/wDJ58VROKuxV2KuxV2KuxVShIMlxSPhSQAt /P8Au1+L+H0Yqq4q7FXYqhrv+/sv+Mx/5MyYqicVdirsVdirsVdiqGu/7+y/4zH/AJMyYqicVdir sVdirsVdirsVdirsVdirsVdirsVQ2n/3D/8AGaf/AJPPiqJxV2KuxV2KuoPv64q7FVOIPzm5OGBc cAP2RwXY/TU4qqYq7FXYqhrv+/sv+Mx/5MyYqicVdirsVdirsVdiqGu/7+y/4zH/AJMyYqicVdir sVdirsVdirsVdirsVdirsVdirsVQ2n/3D/8AGaf/AJPPiqJxV2KuxV2KuxV2KqMHperccK8vUHq1 /m9NOn+xpiqtirsVdiqGu/7+y/4zH/kzJiqJxV2KuxV2KuxV2Koa7/v7L/jMf+TMmKonFXYq7FXY q7FXYq7FXYq7FXYq7FXYq7FUNp/9w/8Axmn/AOTz4qicVdirsVdirsVdiqyMy85eahVDj0yO68V3 P+yqMVX4q7FXYqhrv+/sv+Mx/wCTMmKonFXYq7FXYq7FXYqhrv8Av7L/AIzH/kzJiqJxV2KuxV2K uxV2KuxV2KuxV2KuxV2KuxVinknzA3mSzv7iL1LFbW9ktzCkkcwqVSY1LQqVdTNxdN+LAipxVkX1 Sf8A5bZvuh/6p4q76pP/AMts33Q/9U8Vd9Un/wCW2b7of+qeKu+qT/8ALbN90P8A1TxV31Sf/ltm +6H/AKp4q76pP/y2zfdD/wBU8VSTy9rtlrM97Da3d3Fc28j+tDMkAYrHPLaLKvFXXg8lpJxFQ21S oriqd/VJ/wDltm+6H/qnirvqk/8Ay2zfdD/1TxV31Sf/AJbZvuh/6p4qk2qata2Wu6ZpVzcXhnvF kmt50SAxIUZIKSHjyq7XIC0Ujxpiqc/VJ/8Altm+6H/qnirvqk//AC2zfdD/ANU8Vd9Un/5bZvuh /wCqeKu+qT/8ts33Q/8AVPFXfVJ/+W2b7of+qeKu+qT/APLbN90P/VPFUm83as3l3RJNakZrz6nJ EFinkjt4QZ5Bb85ZViYoiCUsxodsVUfJ/niLzLqGp20VvHFFYJaukiXCTuxuIyZEmSMUgkhljeJo 2YtVakAEVVZRirsVdirsVdirsVdirsVdirsVdirsVQMOrwyTXMTQXMZtpfRLNBIVf4FfnGVDAr8d K+IOKqv6Qg/km/5ETf8ANGKu/SEH8k3/ACIm/wCaMVcdStlBJWYAbkmCalP+AxVZBq9jcQR3Fu0k 0EyiSKWOKVkdGFVZWC0II3BGKr/0hB/JN/yIm/5oxV36Qg/km/5ETf8ANGKoHTPMtvfmcfUr61MD 8P8ASbWVOYqRzSgaqmmxxVHfpCD+Sb/kRN/zRirv0hB/JN/yIm/5oxV36Qg/km/5ETf80Yqpx6rF JqCWSwXFXieb6w0LpCODKvBnYCjtzqo7gHwxVG4q7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7 FXYq7FXYq7FUDDrVnNNdQosxe0l9CU+hKRz4K/wkKaijjfFVX9IQfyTf8iJv+aMVd+kIP5Jv+RE3 /NGKpX5l07S/MOjT6Te/WUtp2jZ2jt2Y/upFlUFZoZY2BKAEMhBGKonSFsNK0my0y2Fw1vYQRW0L SQylykKBFLERgVou+2Kov9IQfyTf8iJv+aMVd+kIP5Jv+RE3/NGKu/SEH8k3/Iib/mjFXfpCD+Sb /kRN/wA0Yqllhp+mWWs6nq0RuWuNVMRuFe2NFMMYjUI4hEvGi/ZZyoNSoFTVVM/0hB/JN/yIm/5o xVA3nmnS7S+trGVbn6xd/wByFtZ2XZgp5ME4puwpypXtU4qjv0hB/JN/yIm/5oxV36Qg/km/5ETf 80Yq79IQfyTf8iJv+aMVd+kIP5Jv+RE3/NGKu/SEH8k3/Iib/mjFXfpCD+Sb/kRN/wA0Yqpfpmz+ vW9kVmE10JGiLQyqn7oAtVioC7NtX9dMVR2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2KuxV2K pHfaDq1x5t0zWodZlttNsYJobrRVUmK5aUfBI7cwoMZoR8BPviqeYq7FXYq7FXYq7FXYq7FXYqxz zz5TuvMum2ttaak+lXNpc/WoruIS8wwhlh2MMtu4I9bl9um1CCCRirIx08ffFXYq7FXYq7FXYq7F XYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXYq7FXnHmj86dP8s+ZNR0zVNKuW06wRaX9qHleSVx bMIxE0ccdKXfVZmYcfiUck5KrLv8+/KVtaG5+o38y+ik4jh+pvIVdwg+AXPIU5fET8KmqEiQFMVQ 8X5+aM+qXunvo17FJYyXaTKz2pl42Ns0837tJX+IsvBN+DVrzqGUKr9Q/P8A8sW80EMFjdzM8umx 3Bb0U9L9KQtcRCgeR3kVENUVevQ0NcVRMX526Fd22pNYafdS3Nhpc+qqsjQGCVYGKmJZ7aS6BYnu qsB0+0CuKqUn58eXLWZrXUNM1C2u44jK5KRpAQlx9UciW4ktzGomDCtwsRopLBdqqqMv/ORPkdDA i2mpSyzwyTiKOGJmQRq78ZP3tEZkQMtT9llPQ1CqcWf5u6BdXsdktjfLcvfRaW0ZFszJdSEhldUn dgsao7NJTgQjcCxFMVZzirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdirsVdi rsVdirsVdirsVdiq2X0/Sf1P7viefypv0xVB6D+i/wBB6d+iP+OV9Vh/R9OX+8/pr6X2/j+xT7W/ jiq68/RX1+w+t+n9c5yfo71Ptep6Tep6df2vS5dN+Ne1cVRmKuxV2KuxV2KuxV2KuxV2KuxV2Kux V2KuxV2KuxV2Kv8A/9k= uuid:22f90bb7-2a58-8a4a-a22a-60a0ab2e3a75 xmp.did:F77F1174072068118A6DFB8E8855593C uuid:5D20892493BFDB11914A8590D31508C8 proof:pdf uuid:7e89c963-a12b-7448-894a-d72161589059 xmp.did:F77F1174072068118A6DED1BCC1F2C73 uuid:5D20892493BFDB11914A8590D31508C8 proof:pdf saved xmp.iid:F77F1174072068118A6DED1BCC1F2C73 2012-04-03T13:04:30-05:00 Adobe Illustrator CS5.1 / saved xmp.iid:F77F1174072068118A6DFB8E8855593C 2012-06-27T12:17:45-05:00 Adobe Illustrator CS5.1 / Print False False 1 792.000000 612.000000 Points MyriadPro-Regular Myriad Pro Regular Open Type Version 2.062;PS 2.000;hotconv 1.0.57;makeotf.lib2.0.21895 False MyriadPro-Regular.otf Magenta Yellow Black Default Swatch Group 0 White CMYK PROCESS 0.000000 0.000000 0.000000 0.000000 Black CMYK PROCESS 0.000000 0.000000 0.000000 100.000000 CMYK Red CMYK PROCESS 0.000000 100.000000 100.000000 0.000000 CMYK Yellow CMYK PROCESS 0.000000 0.000000 100.000000 0.000000 CMYK Green CMYK PROCESS 100.000000 0.000000 100.000000 0.000000 CMYK Cyan CMYK PROCESS 100.000000 0.000000 0.000000 0.000000 CMYK Blue CMYK PROCESS 100.000000 100.000000 0.000000 0.000000 CMYK Magenta CMYK PROCESS 0.000000 100.000000 0.000000 0.000000 C=15 M=100 Y=90 K=10 CMYK PROCESS 14.999998 100.000000 90.000000 10.000002 C=0 M=90 Y=85 K=0 CMYK PROCESS 0.000000 90.000000 85.000000 0.000000 C=0 M=80 Y=95 K=0 CMYK PROCESS 0.000000 80.000000 95.000000 0.000000 C=0 M=50 Y=100 K=0 CMYK PROCESS 0.000000 50.000000 100.000000 0.000000 C=0 M=35 Y=85 K=0 CMYK PROCESS 0.000000 35.000004 85.000000 0.000000 C=5 M=0 Y=90 K=0 CMYK PROCESS 5.000001 0.000000 90.000000 0.000000 C=20 M=0 Y=100 K=0 CMYK PROCESS 19.999998 0.000000 100.000000 0.000000 C=50 M=0 Y=100 K=0 CMYK PROCESS 50.000000 0.000000 100.000000 0.000000 C=75 M=0 Y=100 K=0 CMYK PROCESS 75.000000 0.000000 100.000000 0.000000 C=85 M=10 Y=100 K=10 CMYK PROCESS 85.000000 10.000002 100.000000 10.000002 C=90 M=30 Y=95 K=30 CMYK PROCESS 90.000000 30.000002 95.000000 30.000002 C=75 M=0 Y=75 K=0 CMYK PROCESS 75.000000 0.000000 75.000000 0.000000 C=80 M=10 Y=45 K=0 CMYK PROCESS 80.000000 10.000002 45.000000 0.000000 C=70 M=15 Y=0 K=0 CMYK PROCESS 70.000000 14.999998 0.000000 0.000000 C=85 M=50 Y=0 K=0 CMYK PROCESS 85.000000 50.000000 0.000000 0.000000 C=100 M=95 Y=5 K=0 CMYK PROCESS 100.000000 95.000000 5.000001 0.000000 C=100 M=100 Y=25 K=25 CMYK PROCESS 100.000000 100.000000 25.000000 25.000000 C=75 M=100 Y=0 K=0 CMYK PROCESS 75.000000 100.000000 0.000000 0.000000 C=50 M=100 Y=0 K=0 CMYK PROCESS 50.000000 100.000000 0.000000 0.000000 C=35 M=100 Y=35 K=10 CMYK PROCESS 35.000004 100.000000 35.000004 10.000002 C=10 M=100 Y=50 K=0 CMYK PROCESS 10.000002 100.000000 50.000000 0.000000 C=0 M=95 Y=20 K=0 CMYK PROCESS 0.000000 95.000000 19.999998 0.000000 C=25 M=25 Y=40 K=0 CMYK PROCESS 25.000000 25.000000 39.999996 0.000000 C=40 M=45 Y=50 K=5 CMYK PROCESS 39.999996 45.000000 50.000000 5.000001 C=50 M=50 Y=60 K=25 CMYK PROCESS 50.000000 50.000000 60.000004 25.000000 C=55 M=60 Y=65 K=40 CMYK PROCESS 55.000000 60.000004 65.000000 39.999996 C=25 M=40 Y=65 K=0 CMYK PROCESS 25.000000 39.999996 65.000000 0.000000 C=30 M=50 Y=75 K=10 CMYK PROCESS 30.000002 50.000000 75.000000 10.000002 C=35 M=60 Y=80 K=25 CMYK PROCESS 35.000004 60.000004 80.000000 25.000000 C=40 M=65 Y=90 K=35 CMYK PROCESS 39.999996 65.000000 90.000000 35.000004 C=40 M=70 Y=100 K=50 CMYK PROCESS 39.999996 70.000000 100.000000 50.000000 C=50 M=70 Y=80 K=70 CMYK PROCESS 50.000000 70.000000 80.000000 70.000000 Grays 1 C=0 M=0 Y=0 K=100 CMYK PROCESS 0.000000 0.000000 0.000000 100.000000 C=0 M=0 Y=0 K=90 CMYK PROCESS 0.000000 0.000000 0.000000 89.999405 C=0 M=0 Y=0 K=80 CMYK PROCESS 0.000000 0.000000 0.000000 79.998795 C=0 M=0 Y=0 K=70 CMYK PROCESS 0.000000 0.000000 0.000000 69.999702 C=0 M=0 Y=0 K=60 CMYK PROCESS 0.000000 0.000000 0.000000 59.999104 C=0 M=0 Y=0 K=50 CMYK PROCESS 0.000000 0.000000 0.000000 50.000000 C=0 M=0 Y=0 K=40 CMYK PROCESS 0.000000 0.000000 0.000000 39.999401 C=0 M=0 Y=0 K=30 CMYK PROCESS 0.000000 0.000000 0.000000 29.998802 C=0 M=0 Y=0 K=20 CMYK PROCESS 0.000000 0.000000 0.000000 19.999701 C=0 M=0 Y=0 K=10 CMYK PROCESS 0.000000 0.000000 0.000000 9.999103 C=0 M=0 Y=0 K=5 CMYK PROCESS 0.000000 0.000000 0.000000 4.998803 Brights 1 C=0 M=100 Y=100 K=0 CMYK PROCESS 0.000000 100.000000 100.000000 0.000000 C=0 M=75 Y=100 K=0 CMYK PROCESS 0.000000 75.000000 100.000000 0.000000 C=0 M=10 Y=95 K=0 CMYK PROCESS 0.000000 10.000002 95.000000 0.000000 C=85 M=10 Y=100 K=0 CMYK PROCESS 85.000000 10.000002 100.000000 0.000000 C=100 M=90 Y=0 K=0 CMYK PROCESS 100.000000 90.000000 0.000000 0.000000 C=60 M=90 Y=0 K=0 CMYK PROCESS 60.000004 90.000000 0.003099 0.003099 Adobe PDF library 9.90 endstream endobj 3 0 obj <> endobj 8 0 obj <>/Resources<>/Font<>/ProcSet[/PDF/Text]/Properties<>>>/Thumb 12 0 R/TrimBox[0.0 0.0 792.0 612.0]/Type/Page>> endobj 9 0 obj <>stream H‰ÔWMoÜ6½ëWð(HÏïkÜ´@“ H³@AP$ëuê&öÂn{è¿ïI»+yµ[8€sÑ5óøôæƒäÙOçæìÕ9™gß›æ¶!“Ø›\½±úp·i~17%W#.ÞyÑœýð†ÌÇ?š[Ãx'\3GW«°ªNb1ëku2×õ)ºƒ©Á‘Tcc&Í5ºLó;_‹ç°nÞ4¯{_Å}1#¿=r½îí§L’‰abFÆl'™èüÀtD3‡%ûü0X½+%y`è_Å:õ86„£B¼Ä"Öoñ 3÷×wd.Ì¢€ªÞ‡)€/ÕE¿C9é}:5õëæÙj‹Oû¸Ÿ­øWY]6^ú¯¸AÏB —â„HÌêºi©[ýÞ¿ŠûhVvQ?<_̸ÏÂŽ 4… hRœ…À»õêK0V\Az9žÖÍ®rÇY“w´ç!‘aÑ? ƒƒñc„ õ…;ê/wâL¤èU°½ 1BÞè¼Ê Þ¶/;–vûѼ¼ú´ù|õÛv{ѽ[ý8QÏ—4˜Kv\Ëèösg¥Ý¬»Ôn¯?\ݼï¤ýój{c¾ï|jï:¦vsû׿fÝY.íß=äƒ4ÍHNª5—ëƒ4MM¹Ö‰ªú¶ÓUŸʦÿ¢ì´J“CÀ]ŸUòt™j¼9×l"ò4ÔZŸlž’N’hDo)ñP³wZšì‡ÿÒ„DãÁŸÍ¸/ì=R`qháŒ,>…ƒîäŠGù9N‘¡‰”÷eÐ^Ϊ6šÂs›{|òP}Љj”E  •87 s$Á°Äꡨ@M•¹Ñ½ß >ã›6±*.já- …¡gFò…F¹¸R¢ïƒ @ÃÐTö©PF!.-›ÕÕäë‚ :…j¼F &8fÖçy0‚–Ü Š"kæ»ÌºaÀjn`ØÃ:ŒE ’~¥4”#äì ërê=I'¡’‘%-7ˆ”]Tù‰Û)s;¥nçÜ턼’Ü‘?pFGîvFÞÞco§ôí—ùçè(pXàïCF”…`©“„-Z§ÂõøñÊºÏ H„o4^ûÒJt®ät¿÷/µuäó´k+p›ìˆÿïX-†ê«D* ÁpDHK² Îyq;.ø£ðÍEêÐ/R_¿ªNoL<ö§ýŠá®«àû~©—ƒRÑ#ı<œ!¤‡“Å…c‹”±Ï ×ãúü¸ÿ0dßÊ endstream endobj 12 0 obj <>stream 8;Z\7;6kfs%*W/XbABD'T#9k.XRp3>(/h-^=1;\;K-nbS2V;`TET>&q5ntXD*#ik9 81C0ek_FUl>tdW#G>;)Gc9KI!bk#NCTH(Li1.(/bTQL4Qj&_@tXSh\gF\Lk)b`S_u /"U/8.*as`.7QIlNEE4@UrY>/TVo(8MkGm6,g9Yq8C]CsjN:AZJ/Sd_%c5$Cl8\3A =?R+m95"pOLl1a%W9[:aB/6W4D3'"JLtf6Cg^tNsG*lDX75QY:?"NUuET@Wr$gTG, m`i7k&C[Mo/A=C%HX8gMiJB6Ycj[M-m-c(6*)S_E&URNrZ_0SB1qsW)l:k~> endstream endobj 13 0 obj [/Indexed/DeviceRGB 255 14 0 R] endobj 14 0 obj <>stream 8;X]O>EqN@%''O_@%e@?J;%+8(9e>X=MR6S?i^YgA3=].HDXF.R$lIL@"pJ+EP(%0 b]6ajmNZn*!='OQZeQ^Y*,=]?C.B+\Ulg9dhD*"iC[;*=3`oP1[!S^)?1)IZ4dup` E1r!/,*0[*9.aFIR2&b-C#soRZ7Dl%MLY\.?d>Mn 6%Q2oYfNRF$$+ON<+]RUJmC0InDZ4OTs0S!saG>GGKUlQ*Q?45:CI&4J'_2j$XKrcYp0n+Xl_nU*O( l[$6Nn+Z_Nq0]s7hs]`XX1nZ8&94a\~> endstream endobj 6 0 obj <> endobj 15 0 obj [/View/Design] endobj 16 0 obj <>>> endobj 5 0 obj <> endobj 17 0 obj <> endobj 18 0 obj <>stream H‰|”yPWÇ»™éXÍX2iJ§Ýé Ç ˆ ¢¹D–#êl<€a¸.…!ŒIé20 .‰ˆ %/T§ +¨«ÜN0A00 ¢`b6›ý5>¶v{°¬Ú¿¶ºëWï÷^ý~¿ïû¼÷{8Æ7Ãp_¶fÇ•2R¢Jv UĤ'DªL‹ Kãì2>»b1…Ö!ýÛ·oƒ¸·¦—ÞYñ›KÌ Ç‡_lMNábcbÓ¤ëÖ¯wq0Y·ëá uqvv^°nÒÍòä(…4ìHjš"1U꟬JIVE¦)äNÒÍ Ò…©R•"U¡Ê0M¾S$U¦JÊ´X…JÉ-Æ(¹x•B.MSEʉ‘ªxi²iå܃ÿ§”T™$årI#’”&/,›L•F&É×rY’ªD'§'¥©”ŠT§µ¾aáGRRO©\qÃpîÖ`ØR³Å0G sŰ-æX ű“aÃ!Åv`!X vÅWâyx·™™¯Ù§f7yμ Þ(?ˆ_Í'‰oˆçäJÒ¼BþKà)¨¼4_kže>^ÐÁÎvàœ]ÝÁ+à³ys!óy$èQ…|àK¦I$E·)09óÅ‚yrßÂ|ç“ì-Ê4B&Oˆf„è,ñ[°ˆfª¾æë«õ©µ±±ª”˜˜š”ËŒPÓÇÖõáW'¡b’åsöZ怡dÅÑ"ѰêáDo!ZÁÛN½h´FnÈ뀵ˆ]3à Ûî¾|«3ØîÑ‚LKÐŒ‰êAc56'ÙDŠú‘õÇ~@< Ia=eÀ౬ ¨µPpó¿…eÆYX,ž™AÒÍI÷KÎí Î^h¿pž½ìoÿ±òB.Œ¯!já«Z‚qÒJ4Ý\Ge\z”f aíèÔ/LþTàý eæ…Ñ›áóM}âá?>AnóW©b%5DÕ¹Ž3·è‘º½»|¼â™;)š•;ë˜p]ÌŸÞz¶LeÚ øöÁã1¼l”Ïxìj+ðêsfí¨eÞ•…¿!_RB>U(W8Ty¡ü\UÃr=©Uæ+•b”¸ µ¾<¿Åan’Çn›“P艺 }Íy} Tgˆã¦Û±žÞùIUy “îGd^º—9HÃÊ7¯@4Ù¹ûs6Zvr7š“¯U3ga:R¸“×õÒ øÐoÈjº ø1*†48g@ÿ!…žé×™ïÙÅÔľv%…Y\T[ü¥b„cFÞ+#´’Ãyõ±UN•e¡%™æÏÉœÚìîô—Ù 7vWšë5wïMˆog^‹» © ®t¢C}±Ÿ1SEeçõÍô‹‡ 7ŸÝNŒ )Ü¢éŽË€‚ðA·å• ˆµ³ë ƒš‰yƒì‚C²TÑ’ªâÌåë¥×èu%[ä⣴S·*Yˆ·uø¾î¿u¹ák‰ž©‹ƒ‰aòx¶©Yüû딨ý‹ü£yG%Q9QÑô~Em×KÀ+f´Œð´f@‘Áz÷CB¦¥ÁW'EíXJ‰Ô´2mœdˆµŸæî^PýÝ”00‡Í`ãñúÀ;L‘Àh¡Ó4Îo¡NžÒ—Hz*ï6ߣ_uxþñ"69îj~ÍäÌ/) ¥šAÀ¸Ã´}FiTq¹{è5[ûÿÓýgÀ»Q—«©fªz‰ÒÔ½¥»häò‘=²{e6Ý7+JÎ0¯4ƒò÷b&ἑÃc;'£P³VÐ.»²‰F6öÈ]Ç Û);°îjºS»€£ÈƒøžÔÖiÛ[Äì¨Àm¾ˆÊÉÏÍË•ˆÚ²#¢ChGÙÈë_ï<ê¹±7¼”ÑktjX¡é‡Áú!Þð”ŒñØ(È  OêJ+Å“Q A®h¥;"‘ ²™´ûïîTœ¾(É~HäÄË5A´Ë¦vX¤et©Å #ÏékÜÂó!*çúܽ¼ñQ#¼­Xw°èEµ‚¡¿vÕV?V*9ÕGg*ާ£öÇD˳wl§ùùõλ „EHÑÖ½0×wtÂÙ Ñ,› ÿ¤D#]ºFýe‰7)šÍÛBhÉÆô}-4âK×"O$ÿݾÚVË~B¢%þŸ®Û¹§²:^’¾8ôÍ£œ.úA_YË æZË™^à‹]¦ÔÚ¬ãjIØ™2œã3ü ø÷ènŽÜUÎitŸ©ÅÂn/ë Üià† ÐLð \'µ‘åºÒ¥’ë­ô³óÞ º8MðZÕ—ð¹ú$Ež–£2×Â]®«Ð·\–Ù?nùwÀí'DÓànÅv?̽A­sT\º*1±:õÒ•êš Ókâ¡ûBäsu9†nÜ pû·Ìd[x!5ɽ,  "¬I´ mÈÉÊÎÈÍZ®åÊ=®Î˜“™›äÎÉ8p‰Ëçõ˜ãi‡DÓÿá шÁjZɲÂò§$­§›Zïн—Ã}Ô2·åú²¢RIsyCýMzàJ¸#ƒjÇ¡^šö&ä¦'I2Õ™™êds-Ù™±§1€öÚw`o “ǵӟ‡ ²0º0z÷;€ï ›ø‰¾34Õ,+*‘´—·5½xé=@¿ aûö¥J´¤¨íøS›ÔGëLyŽizX‹¼á9\{΃‹ìçZ.u@îÈñç5`æ°ô{ضŽoÃhý©_šV¯GxÐF÷Oj›ù#ümË€,>pô}oͲ¶HFÙÿj'›ð½½Ûz7ËYÀ’ÖÎâÈ Òª¿9m~{ýV®õõæ»–É÷²}çg©ë¨j¯“ó/Ê’ÖŠ½÷æ;áÏÎîŒ ÊXuõR|¿+€þÖ¿ö·ð§§±Íì™Õ;]îìôí;OJOŸÒÝ9Eþ{OsKO“t@h’W)(è6´¿]_\OTÐŒ’†+Ée?LÎ ½x(\ðâÇ%QCk¿ç° ošš°¸@®dÁšÚ-Òk—Mœ8G¾ýk{]mg±tTÕÚãòßg~:÷[è;;_{Õ$PZºøø{Ícá?Š~TˆÿÞÃVÕQÝV/—\” m“wê¹ü÷ùƿ׳ÿ¶}–pýáþ}›Êõ² WL°+»¶ï“â3ÿ-Tö“»œqÊhæ)@S¾»ý bÐÐÛÒÝÖÝÖÑÒÄ£Z——Y\QXšW[Ú²ÐIbaÿÖYÛ7?°íþ©ïVß%¾¿•ÐcÓþ½¡>£1­)˜T›WÔo¬_­ô}“_ôŸfÓÇMû®?mÏ´?%“Ø~xMüí3ñOþ´WLd—[àÚ4ó?ç9®ÇÜûyxL6d õ- endstream endobj 11 0 obj <> endobj 10 0 obj <> endobj 19 0 obj <> endobj 20 0 obj <>stream %!PS-Adobe-3.0 %%Creator: Adobe Illustrator(R) 15.0 %%AI8_CreatorVersion: 15.1.0 %%For: (Doebley Lab) () %%Title: (golden section search.ai) %%CreationDate: 6/27/12 12:18 PM %%Canvassize: 16383 %%BoundingBox: 34 -571 1141 -79 %%HiResBoundingBox: 34.9121 -570.8018 1140.4209 -79.998 %%DocumentProcessColors: Magenta Yellow Black %AI5_FileFormat 11.0 %AI12_BuildNumber: 39 %AI3_ColorUsage: Color %AI7_ImageSettings: 0 %%CMYKProcessColor: 1 1 1 1 ([Registration]) %AI3_Cropmarks: 0 -612 792 0 %AI3_TemplateBox: 396.5 -306.5 396.5 -306.5 %AI3_TileBox: 0 -612 792 0 %AI3_DocumentPreview: None %AI5_ArtSize: 14400 14400 %AI5_RulerUnits: 2 %AI9_ColorModel: 2 %AI5_ArtFlags: 0 0 0 1 0 0 1 0 0 %AI5_TargetResolution: 800 %AI5_NumLayers: 1 %AI9_OpenToView: -85.8013 325.2051 1.25 1595 755 18 0 0 43 135 0 0 0 1 1 0 1 1 0 1 %AI5_OpenViewLayers: 7 %%PageOrigin:90 -702 %AI7_GridSettings: 72 8 72 8 1 0 0.8 0.8 0.8 0.9 0.9 0.9 %AI9_Flatten: 1 %AI12_CMSettings: 00.MS %%EndComments endstream endobj 21 0 obj <>stream %%BoundingBox: 34 -571 1141 -79 %%HiResBoundingBox: 34.9121 -570.8018 1140.4209 -79.998 %AI7_Thumbnail: 128 60 8 %%BeginData: 3920 Hex Bytes %0000330000660000990000CC0033000033330033660033990033CC0033FF %0066000066330066660066990066CC0066FF009900009933009966009999 %0099CC0099FF00CC0000CC3300CC6600CC9900CCCC00CCFF00FF3300FF66 %00FF9900FFCC3300003300333300663300993300CC3300FF333300333333 %3333663333993333CC3333FF3366003366333366663366993366CC3366FF %3399003399333399663399993399CC3399FF33CC0033CC3333CC6633CC99 %33CCCC33CCFF33FF0033FF3333FF6633FF9933FFCC33FFFF660000660033 %6600666600996600CC6600FF6633006633336633666633996633CC6633FF %6666006666336666666666996666CC6666FF669900669933669966669999 %6699CC6699FF66CC0066CC3366CC6666CC9966CCCC66CCFF66FF0066FF33 %66FF6666FF9966FFCC66FFFF9900009900339900669900999900CC9900FF %9933009933339933669933999933CC9933FF996600996633996666996699 %9966CC9966FF9999009999339999669999999999CC9999FF99CC0099CC33 %99CC6699CC9999CCCC99CCFF99FF0099FF3399FF6699FF9999FFCC99FFFF %CC0000CC0033CC0066CC0099CC00CCCC00FFCC3300CC3333CC3366CC3399 %CC33CCCC33FFCC6600CC6633CC6666CC6699CC66CCCC66FFCC9900CC9933 %CC9966CC9999CC99CCCC99FFCCCC00CCCC33CCCC66CCCC99CCCCCCCCCCFF %CCFF00CCFF33CCFF66CCFF99CCFFCCCCFFFFFF0033FF0066FF0099FF00CC %FF3300FF3333FF3366FF3399FF33CCFF33FFFF6600FF6633FF6666FF6699 %FF66CCFF66FFFF9900FF9933FF9966FF9999FF99CCFF99FFFFCC00FFCC33 %FFCC66FFCC99FFCCCCFFCCFFFFFF33FFFF66FFFF99FFFFCC110000001100 %000011111111220000002200000022222222440000004400000044444444 %550000005500000055555555770000007700000077777777880000008800 %000088888888AA000000AA000000AAAAAAAABB000000BB000000BBBBBBBB %DD000000DD000000DDDDDDDDEE000000EE000000EEEEEEEE0000000000FF %00FF0000FFFFFF0000FF00FFFFFF00FFFFFF %524C45FD21FFA8FD62FFA8FD0DFFCAFFCAFFCAFFCAFFCAFFCAFFCAFF7D7D %CAFFCAFD0DFFA8FD1BFFA8FD40FFCBFFCAFD0FFF7DA8FFFFCAFFCBFFCAFD %5AFFA8FD09FFA8FD12FFA852FD05FFCAFFA8FFCAFFA8FFFFFFA8FD1BFFA8 %FD52FFA8A8A8FD0BFFCBFFCBA8FD51FFA8FD05FFCAFD27FF52CACAFD19FF %A8FD31FFA8A8FD07FFCBFD29FFA8CBFFFFCAFD48FF5252A8FFA8FFFFFFA8 %FD29FFA8A852FFFFFFA8FFCAFFA8FD11FFA8FD31FFA852FD05FFCAFD19FF %A8FD11FFA87DA8FD07FFCBFD42FF7D52FFFFA8FFCAFD19FFA8FD11FFA8FD %0BFFCAFFCAFD0DFFA8FD31FFA852FFFFFFCAFD3BFFCBFFCBFD3CFF7D52A8 %FFA8FFA8FD19FFA8FD11FFA8FD11FFCAFFA8FD07FFA8FD31FF5252FFFFFF %A8A8FD42FFCAFD36FF527DA8FF527D52FD2BFFA8FD17FFCAFFCAFFA8A852 %FD2FFF7D28FFFFFD04A8FD19FFA8FD2BFFCB7D7D7D7EFD2EFFA87DA8FFA8 %FD1BFFA8FD11FFA8FD1BFF7EA8FD30FF5252FD7EFF7D7DA8FFA8FD1BFFA8 %FD11FFA8FD1BFFA8FD31FFA87DFD7EFF7D7D7DFFA8FD2DFFA8FD1BFFA8FD %31FFA8527DFD1EFFA8FD5EFF7D52A8FFA8FD2DFFA8FD1BFFA8FD31FFA87D %FD7EFF7D7DA8FFA8FD1BFFA8FD11FFA8FD1BFFA8FD31FFA87EFD82FFA8FD %2DFFA8FD1BFFA8FD52FFA8FD62FFA8FD2DFFA8FD1BFFA8FDB5FFA8FD2DFF %A8FD1BFFA8FDB5FFA8FD1BFFA8FD11FFA8FD1BFFA8FD52FFA8FD62FFA8FD %2DFFA8FD1BFFA8FDB5FFA8FD1BFFA8A8FD10FFA8FD1BFFA8FDB5FFA8FD2D %FFA8FD1BFFA8FD36FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8 %FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8 %FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FD36FF7DA8FFFFA8 %FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFF %FFA8FFFFFFA8FD05FFA8FFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFFFFA8FFFF %FFA8FFFFFFA8FFA87DA87DFD32FF7D7DFD1AFF7D7DFD0FFFA859A8FD1BFF %527E52FD32FF84A8FD1AFFA8A8A8FD0FFFA8FD1CFFA87DA8FDCEFFA8FD11 %FFA8FD52FF7DFFA8FFA8FFA8FFA8FFA8FFA8FFFFFFA8FFA8FFA8FFA8FFA8 %FFFF7D7DFFA8FFA8FFA8FFFFFFA8FFA8FFA8FFA8A8FD53FFA8FFFFFFA8FF %FFFFA8FFFFFFA87D7DFFA8FFFFFFA8FFFFFFA8FFA8FFA8FFFFFFA8FFA87E %A8FFFFFFA8FFFFFFA8FD60FF52A8FD14FF52FD6AFFA8FD70FFA8FFA8FFA9 %FFA8FFA9FFA8FFA9FFFFFFA9FFA8FFA9FFA8FFA9FFA8FFA9FFA8FFA9FFA8 %FFFFFFA8FFA9FFA8FFA87EA8FFA9FFA8FFA9FFA8FFA8FFAFFFA9FFA8FFA9 %FFA8FFA9FFA8FFA8A8FD35FFA8A8FFFFA8FFA8FFA8FFA8FFA8FFA8FFA8FF %FFFFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FF7DA8 %A8FFA8FFA8FFA8FFA8FFA8A8A8FFA8FFA8FFA8FFA8FFA8FFA8FFA8FD46FF %A87DFD27FF7D52FD55FFA852FD27FF7D7DA8FDFCFFFDE0FFA8A8FD10FFA8 %A8FD0BFFA8FD60FF527D7DA87D7E537D527D7DA87D7D52A87DA8FD057DA8 %FD057DA8A8FD60FFA87D5227527DFD05527DFD06527DA852595252285227 %7D527D527DFD77FFA8A8FD05FFA8FDC4FFFF %%EndData endstream endobj 22 0 obj <>stream H‰ìWmSÛºþù:gæÌ„™6‘lË/ípgHh{¸´‡ ¡˜ÞNÇÄ"¸;c;pè‡ûÛïJ~“‚$Ðô:™€-=Zí®ví²½iµû®¢az0ôÞRo! ßnö‚^µêû‰€W­n?ºšDÓÐ˧AÂ0uG—Ðs$/£K¶øzMLq¾$îú£ÔB7¾EoP÷¯(=d£(ö˜Ç'3X&þ ˆ=laô~Dl‚ÑÉ-Èÿ7<|G¤cQÍB7È@ŸÐ—¯y€;9lqè‰û°sôµP[’¹õ ü^˜¢vo¸ã]g +ø1‹xÚÊìÊqû^z1Œ¦ñ(“¾Ç.]º‡Ì `w Œ-éÕÑ Z¾’òé-wìÆ¾ ¾bŽÝ`Ê!RÞ¡¦²H[×¥W¢}Þ}ÂA1OìPɆ¹Ë½s§©> 2Û“»W wÁ>ËaÂèm ua2­‰‘~zS?]$<î‘ÂÃæqzoTqYULI±„‹X‚0"X#<G¥îФEjNØ»kxÞ÷Ücc/`¡·*#…°G[Y™W­ŸkH«ûî6šrÄ„XÛêî‡ÑM˜ïÜjï„0kÙöhè^ ½w@íë"«ëX©áµŠ×´&¶¾¼¦Ù¶#“uœeyÍp¨Ìk¶EeæÔ°n4¼ÖðÚ òšÓðÚSë5ÇÁ¦³ÄFLÝTˆÍ6—.ذ&Wh–nÊpS°ãsè"fc?£ö®ŸL÷6{ÍXð÷!?µ%É.›@$‚Ý»ξÂFo"ö¡cɽ ‹OȪ̭U­YmX?*ø?Í/™rzׇ3ƒ³Vfé쬲d'LÁ;êœì1 x ˜)d×NŠe‡ \Y}-xA¬“öàb´×À|smyz¨ƒ©w?$‰í˜„?˜ŽFLCd•eXÖjÓªî@×Ävçç KÑÀM/îg¸ Îoš$Ý4Š;ã‘%¹Ýës£È’«À¿âx E•‰‹«'©\~ÓÉ‚‘ÿK:| e:©yhX}V×VŸaul†³VV_9¡­¯}9¨Ï®ú†ðÜêAPµ?‡!œ¹‡ À=z@¤™™N¯ŽËD{cXÜë-ßýÚyK»à…š£uD{«ûî6šrÄ„XÛêî‡ÑM˜ïÜj„BAáðúé ª¼ZíîŒxQàVÀ°w% SwtùtŽ~îoáH||×6cY? ½©Ÿ.bÔ‹dïS=±úœÌÚƒ£Ø “ó(¾ZUo* \¬3-I‹•Ðׂa¢˜g‰vº•é–5ÉÈ ØŸßÞ»#PIi)â(uSöí®7Lê¦vÙ8f,Éå)›œ¨;»¡]ù?„ë Æ3›X<‚[†Oêy¯1ñÃAägc³ ŽååÔUtÍgÒä®yǪy™Nb棲䎘?%1B›pzÕ&~}ÑêäÉZ4­¨Å!‹¾ß$]'c׿š¢ÃªòmFèb9Gªd€™ÎŒæâi.ž¦\„_†®Ý4Eà&çâÊi­M`îÍhôêo·Ý8š " î»Û80Ãu\¿þRSd-XFv,Z\jÑÄåõX6pÅ?”Boâú¢ 2 ÄY0å¢é,…ùsüN–ò{2 bE¿k‹z–÷²çÆ—²>£$=Lµÿo¬{ä'É”¡;áæ4ÜÛpïópoÇA¸£ÃÏ¡âá' áÁpÇs'ðòm"èôÛ LƒU5¢›=ýlQ>îöübbgØßÛ³é.Lz|Ý¿Áçwó4úÏÞ¾¿­·ùë;ëø2ÝÍÞ׿ýÞùï¿ÀlàÁÔTiæDȆBÄ8Äìz7f‰BòãèÅ;^ ÂÃZ;njâ qM“Ÿ£nÙô”iÿ’)ã4)£¦Ì㲤wÅBûCÌXø ² ˆn^¡ƒØ Çl Å+Éÿg{cXÜë5 6›`g¿l‚ëL°êBÄÕòBÈu§AúUêB†þÕ$(»ªwÌî¾Ã²“Ü_<ÇI~€®RI›?vöœoïBo'NÅ~ ¡|äÛ_Q8ˆy¦„ãׯ³áƒT¸KS&´œ ÉüÛþr³"÷Àà¯ütN’Öìhk0’Œiÿ}á§L$|°@‡”’üÊo÷?î£Cæ•`yLCÉŠGÕÐæjJ*p[5%èha­Q†ßXãHCFùyur' ¬Á¥´Ø›Va*~¦äEZ¦‰eÒhfZd`®ƒ)ÀÜvCQ×ÈÁ’ºF -=š«`É.-U°ê… ¶¤¯^ª`+ú»gy!ûÁ¤EJë2ØÊÏ«ZU–Q)³E´Ûâå1«ÔÀÊ YõøÞ…š(PFáT3è\Jq;ô.¸Àát—û0:O3:öÇ!¿~>e¥î“ŠÝ9«jÕLc¸ÉÑ¡ëùnð `Ͷ?ºãièn)ë²ïIÈW4)¡[€’îmÂ+æÁX¾[³„+ò[¾‘;¶ã.ÎQa lû.ÌVa&—fÝ…Y*ŒrXræ ì.‚ª}Žö† Óæh¯«02G{M…á9Ú“˜Q¿)-Ϋûã‹´:±ªðÙ®˜tö–·fJ‹Ö€Š+F6STH÷ný­+]VÕ¥‘_T³—†™“†Nª±Æ¬Yò?ꫵ·m‹î˜ÿ@`0‹hm˱ã¸ýä$M›Ù4ñÚ™ÎÛEAI´Í5- $å&ýõ{I½(Y¯tf[ï—±Éû<÷ÜùE&:Sm™«M[†þtÆ‚Õ|I%ë-ÈK[GCëo°¯åàÉ‚G°4\r!ø*øõ–î¡ÉÈŠPìÀziÜÁ‚§HÒÔ~| RFÍ1ÐÈ‹lm•ÊÆ;ƒøÓòiçr¦¯ùÄ%r@ géNÿ͸ zÙ| [ (bãÍEäÂrcÜÚá=$©ØJô –Ì%£ùôâEò˜e?QojÍ+îE;P·W°‘þôËç~ú7, ú/k›ÒÿñáöŽûÄüqò³Ÿ`a…›áftò¸c^éXkô’ôËçêï{¬·LQÿÞ,|VOaòµ?ÀjìˆÂ>þç p¾Í€=Cr–D·ð7â‡Ûð=£ð&ÇxÊ| _Œ)•­Ä w#¥ }i>½<ôåµÄ;Ⱥ%¾sb;»T´XŸi7óäïüìERñÝ›°eóðû¦!õá0æÃë}7÷ å±:§}xÙ¥¿± ÷¶ÄoSÀr|!J­¯èG,  ïŒm¾¹4ðá»s|þÙ^ü/«à\pÌÍÒ1HEßåêË›€Rë°£œÏ ¢vdÉ#á‘ ­£Ò§¢É_¨¯6­f:Î`Ü`ë/fGSï‰õ‡™Ø½¶ú5šÂ"78™[©õ‡~¹\¹%+u/(ì í™Cý ÎǵC|jõêÕx¢ç[=>Uª°VwNG½©3tŽÌ™Ç£™¶0œþχí_7qþ"ãö¹íH°ÌÙx|š„oN„ \µ'ïõ?ë^]¤òrXzÈâ|:œœMjP׌sq‘'ìlèŒ^}'HêÜø|vGòí£Ê\×"Íó÷!ö¨JÕ×a/ c—0ÓK‡õ·¾ç‚~åÁ{‹³Ï©ƒ&ÓQÒÑsN¥‡}¥ís†òÀCƒJ½ž; ÉCØí,s \hËíûÏGíö/Ö%g™>¨1f1"bÊ¿ |ò¸$üg†ËZ¯ÉÄ{õ-âýTn€H¬ FõÁùHÉ_Q©pàu»1Ò*ÝÎÁÌŠáÂÌÈoê52?ÏýÙ3@+@"£AŠ<¦Á›ŽÁ¾S笳}º7¾©\òü¸8ªíDsè{d¬Yÿó³I·„›ÃUÏž{Ǹ‹Ù‚„“PÊÍ7-eøH%u)&Ñ=@še‘{Ö©ÂÅ;øÚì`(ˆ$bOßÂUJ¦Ú'›‡Y¹œµ0y,[$nAe. {˜}Ëáº;µÒ|¯R¤bGÄÍ•´??`—ýj•q1­ZöÙ¡qÐ< Ȱ?zëS…cZ)&Î`Ó`£%QQˆnq°Žðš 9£0¹üìôü4;“¸ÄÁËœ ,7ËÑ:™ år,|ä@¶¡>[”"x#Sk¯È GLÙÆA‘2üô‹m*L¦c49?—ËÍšÜ%qŸ>b¥?½þRðp&ž™2=˜óSâÊ^Ò]ÄŒ.Ki;+ ºT)´0ÔB¿ ZÉY”Ÿq,vÁi’<θ(îú»8!†EÄ{Bkh°àkÞm(R6vÆ+?¹i±qP¨ítŸAP0$´IàC%5‚·÷¶@„`7OËúä_ˆO£õà¿˳ªI®3ê1¦P^"åÒOƒqVšÌo~H{%«Ôe©eÈËZo‡eRx§gi0Cìû‹ÌnÐ,R< l×,­ó1ÜŠu3òGÃózè0O~+Ò2 ›P$ÇXügßè>ñ3„úw\>C+[ü8D¿r݇ú€Déó, µËrœ˜ÓGÂ`$­ˆ×2Tc.0s¸¢ÐÝH»•*¨)"ûÿánÏŒGÌXMY|¶ ‡X³[ Ð Bý¸xÑøºÜÒжͰÔÈ•ëƒDHi ŠÃî-ŸHݶN½É†&<ªÓ}¬8Ê'oV÷v¾D·ZOƒ#øñ­'ÖäÈ}Y›Œ¯}'°Ou]èkcf,]k ÈøLÜâý±t¼°¥c‘ ‰|ȶB§³´åâ!ìR‹ÜËDä.l‘[ëBÕ74°¨cw Y9xÅœH‡”Œ=/àæHÇxÇf7†»©¶Aý™`› ºN¬C"©jzo×K57W›¦¦·Þîi[% ¤—d;èÉo½eýN\pÈGŸN–¿ßÏ?½@ûas››'ùŠ2ÒhÖŽ7ñ p„ìy‘݉] Ï3×Ú(]\d÷ÆÀ(ðZ $Ðk‚ÿAcßñö‚u[ðÐZ²í×ç”w3€À*Þ`ßJ*ï¸q ¤F±ÕsaVBŠ22#…е٠²Â8ýÍÉ´hg1^ºÁ0wIó}Ìñ€=°jAìâk0;ÝÐÒVçU¸€¬qa{©¹T³Nâ`á -Xý%«@õdäÊÇ4Äg¡Xñ|öÖÂrV8« ÷z·íí`í“|µê¹\eìÐ[àFuF+ÞÐêj±«¡‘$ (ö•ïg ’Kê¹þÛÓpËÓèÌÓØ‚ÕÕa1ë‹ESChœ€1 „‚Us)k¨Ö™TaÛËÂò¤!g ¦7×:ì“•–_¨¯6ÍâÛ¥j‡Ã2Cµ +óœVT±nâ9vÐŒÃ|´Öº)ÕS+¦0º*Sï ¿ÇÍ{ûޏ†hi˜¢Öuƒ0Œô¼ ‰PbLȼ„¹œjjŽa˜‘ÔöVܦÍG±n`’{ª†”†„\Òæ¢×(¨¿pÃÅ×dâ ëp\hÝÒE&CFÃÃèm›±é¼¹jhcÌ »Ãö׬uòÍSÆMÕaIµtf•ªÍp.¿Á ô‰¤ë -’a(zÀZl* Ú_‚Œhƒ}éÛN/Ëùê䊬€Á|ä>¡+J@´ Ïó3™+¹@tl\œ½N ¸ueÈ–Y”áò9Ô`©³­ UÎz€À8Àkš|zƲ"Kàaè×?­aÉÓ®ÃÍ€ÕmÉòtv9¤Û„ˆüL›A1>Ý|®â_[öÐŒ˜m÷.{ç :™Ý8šë Ñ,£+êå«ÜçLã¦(à(c2D¤±&Ôä¶¾>÷ƒ®E¯QÿŽ«ñ¸ð¡jËJ??¿ºþlÜCZgþ§Èw?]æJü4hÈbvvN;äaíÜSÖ †áÌHŸIue}år¨‘‡aã8/¸y›5S¹v¥à%ˆ{¢®A»/43Öï ÿ%½ÚûRÕšð'ð;Ð6Ô¼kŠ¥¢ÜÄKZy)»Z¨¤‚!ì}:ŸþµPP·Y÷Èš5—gfžÖxü£ aÐ[ߌ?úRš/fªä¡Po–*.–ÞËÄvÀš~`è­EEøè³T½‡~!™ª¾^2BõÙÌÆûªaÿ½Ú?1ž$FŽeÕ$ ÛB»'a©ÿ`oX·9wÝNg¿ª[@Míjÿªß‘ÇÊ·/ºeè†<1¹º/¥©ì—qx×:; õ¡«×0êîçÁ!¯ÖÌñ½ÂÜhñ¶-}YÐû’cLÕ›ÇÚ^ÏÔæ-ôqxЮÿk¯=u]†Šß®™æÖéá’\«¸²­…mØWê¼=Ý¿(#öuîi ܯý‹—%b7W8Ñûï·Ôåä‹ÛÔ!îºÂË’%ÆšÖÜr{ÈáÛfš=V—æOèCܵ$]‘ÌÃ’›%#ÃÆÇÙLý‡0Õ1X:\ NñƒSªù[eeÓJVSúP].Hïûù¤áêh¯b‡0[Ë™oõù^T~–Awàvw;}»ÞBh7}[­zl©ŠfÏ7Êð VßpŽS`yýó³ø;Þ’ú£æå ]Áß‘ušXiî2Ö›€?L/š¨Äj_#Àª*—ÄŸ‰ªKé7Ò/éÄæ\C<@HKôšUŒ¡J€9B1d{&â ^¤~·•}6±˜Á%hg9š‘iGÝX‚5MÛ2%À˜{U‡ñLXR!«„†×:‰˜Ipf°Õ»9T±´å r¯® ø[ÍSãXÓt¼3FžymIØúT‡Ê‰]P-›Ú£†ÌAZA½ðãº\¤pdÿÁ;@€æÇåÁ…ý“fÿƒ}2$6=8–/4Ôz‹o²jT†ôîXË}B ›üiâ±û +”ÅP‚‚”7'ÚÖ–¿fÚ7(x£À+NðÒB›°¶^~Æ Þ–þõF¿5 ¿XЂ‰ÿ‡u¾Î?TèÆBóuD˜Œ£Yð¹üzYê«w­õP}ux«©~óF‹n}°Â™Cú¼»âovaÅ›DWµì±tu溺þ íJ¿Õг5°1,w¤®¡ÈÊoµjjÊKwbü©iÊÊÇÔŽOñ7ch`þE‰ux($¢a ‰+çˆðJA2?ˆ<‘¸4¬Ž*¦¬ü°ð15[ZqÙ°×»t›H7O‰&0”º |ˆ.­f‚ÓÖæÙ._¯Ÿe%fÊWÇH±O Ò]´q¸ŠqŒYOòcý¨!ECA^“âËcê¦V¡üyæ¦ZjeÊùæS°Å˜¶œ+éÖ™ÊdüÉäRxÆÑä1SÄÃL1ºX2Ë‹tÂG2…摹jXܸÖn2ÅŒÚå5º$ ñxpü—©¦rör‚HæsUKx{æ2±(;7šKH­5‰”(¿- ™ã>÷6 ö}¤0J6†{•çÎG¹ÛöãÛãã·ŸÝ”Ë?3Å©øÌä—ñyDˆ’¶ª*#‰Á_¡e…Ñs?Ç͘Ù]~ÄM,~’{HmÁñäTó)–ƒ}G¸¼äãOw¡®Ô¸ØÙÛ1ÛùuLJ;I±}äù[("Wäl;ÄO2/…"Kž"Üeô5ÂðÁ‘Wípé¶áŸdYš¢'-R5'ŽåT2!åLíø5¯  7#ËÁ˜y²Ùf7ðŽü?a É©¤ ·Ï «ËÁy„n¹ù­år‰åè”5åz*2ͧ\²ÐXÞl¹ šëŸ&•¼Æ'$ÈoªE‡bQ•›å®çN÷M’áëE¿=Ï.!/õGÊ_ÊñÆ R¼Uóé¡ÿ«-é$T¢Â~”’GªOµu„S‰›žP±UiÞ*ÍdêÙßR1 ELd…B¬‹øÈäðW=ƒŸ#%±¸z*ö+Ž8­¼:ÊÒ÷é:”î]2R*U¢i¡<¦Wzút± ¼]p&]‡Aß—]Y!®á:ðì9 Ñ$¤fð»ì'¼`¨æÊêz“ÙžðF‰‹÷Š$9jxÓ.Ö„—Û›È{},·Ø^ú²ÏæžïýpGy¨Ü½–m"§j·Êt0õ”Íâfm°{Cu+ ÆÔJ'‘’¿Ðw2„4ûÈÊK*rËeî"cš“›L¾Õ/ã e5“‚ä…£Î8ìB¹ø&îkœœÄ"U>²¡í(ÌR\²‘ÍÃO5©9zJÔÐ` =ëÛkXößPîdr÷uâïÌ#ô®<öר]œìι*†‹~Bu*Ãd1,¨¦Mª×tÁuÄãYe_)\mÅØ«ˆ:õ".Ôßr’ÓûNBϺïó öjÀµD~Ô8K¦.†ŠÈ+ó{Lž{rPåfÝ÷tSV“~àj=?½ãƒ/Ô+¡:%U0Õ."†9MŽò}ãoowådxŠZÕůáùy¤¹ÜA¤P_#^[jbËØãuúÄ_¯yQÔ|`Ü9AåՊЇÆÚèø xìNÉf¸j½(s¶ûÚ£`b{-cÌÜöê’X9kßùÈb$YyráXT¢ÆeZ Pù;ȹ}^‘§ïµÜ 3É!æÀc° ôHÙÎlÞ”kK5 ¿`&×™„ãìÅ}W÷‘¾>az¹Àß|略FF8 ŒØà`ktDñåäh‚ÃÎÕUh©ìpçt•}t>Ýš4·Ã0D«F%Ú“i@±Ý‡Æ¾;Ž”hꟲÝ(£óšÖVPhGH¤'\\Ôbb±’=Á§(–qXwÄ{-†äfdåêÑëÏÜYY g˜Ûa"w]kuRÃÁ {8:®¤OŽ|ªÊ7ôT‚OÑIu˜/§¢!¾ì¾+ùÈí;Ž$~‡þrˆy|ÿ¥ºÍtÒø¶k€Gï8G[Œ‰¹lLè¤_$RNFâè…àšâÐ¥§Ç±‚ìm«`\çKîAÞ\c—° èaWP˜NÀÈ)„N½+`ež¬b"äò>£øï 1¤±» &¾S@§8Œ²¥#ŒœsPÔÇ…¶ AãéZ)nÄâ%¯t0µßNÄN|äN"œ;,O7ã´ £òþbU®åªçƒÜÎei_ÉL‰ã2~r£rŒzÛ[ß( $Üt£òJe·fX>‹v"ų†ƒöbFÂWû@ÝéTéBHï„éb’ßVQÞö†ÿ÷U¶ª¶D¿ ¡ûİÁ^ÔØÅ°‹úÿ· `LrÎã>݇=FvX©Z«æ¬ª9Ϳվ~Kjàbö…1O¨fMÖj‡Q%˜Z%õ¸aã1àùA>Í ¼a‰c9Lò¿ãÄÜ9fÍÂNVLëÐî0íkiÏû*!÷óWU )ìt7-i¾ô¥¡tfêy¶4Œ¡®öO…ŠTØóK-bƒL-:-†•[\ùË;ý)/ŽKŒØk‚N6nÖÁ”Â¥¾ú2¤_…`am‚ïüÛ;üíº¸{Œ$;ã•ÈÉÍK;´m A6óç¼®·£¸}ø·úÕ ½aV3d2=íÊíÆ (™ºÀíz“üvG„Rò[ƒ¾õF &Ù)I¶–Gt¹€© ÛVÇf(`²ìÿÉY^:­cÍOqë€'§'hF³SjuW~ãëçCÛl&i`õ\§'/¢íƒBŸ;ôç³bÐ(j凤Qˆn¤„ç rZ.ò›©pfuž› Ð(ªà,Lýÿ¬þ-¥”•˜‡-}Ât’¥¸BŸ”YÅÃãa¼«~Û´yFßLŠÎ1þžvÚä䎯sZàpÏ’×;PsªhPúàúL;•ßúŠ>Ç^‡ÀnS£ö ý´ÿ=4L‹J™m6hxK_ÓiƒßúÓ¬µ»çYÞ?˜d?:är›7Âq~zL,<’ÄruçЈ2P—üfdKú²…Éäάq ЬRõ´oÈfÏ&Áå>YÏØÌqËMÐ×pr¹WÃh‰ÔPµDh´Ìàø~Èý¿Î¬+¥šµuOÁ¦/×ï $’N‰};ØÇí9vi–;À%ó…Ó¥a !qß𢜬}€9–Û\nÈT†*dùœAéÂON‘9긂W:x\µ§ä[cÇHY$Õ°0¢£p›bà1³Œ„Ï<¾¬#ÕÓ"¿a”*åßyœ”îÝk ö/»7ŠöË}þÝ¿aœ`œÜ<¶jÿc÷Z.‚ºw L< 5%pñîËöÇÞ׈«:WP°Õ£Ñð“ÿ 0Í)Ê—ŠÕžÃV,ÝËV&­ž€K–(߸`k “µòXQay¦Òvž5òNçã– }¤è{=]«Ðfõ9Eõ¼—+pc‚ö2q´æqv_ÏÂ{µ[¿EPêÖ…÷y Ù²±LÞ!*ïŽs‚NöÎÛ”\œ¯éä‡` ¥OlÂëäd†š¿aÚÆNûûDQ‹mÙÝÆÉ°›_į ÀoâV§zE“„£s ßáœ(Uífz²«V$Xt¹w~>Œ9Yâä7Œ÷«7&N3C~ÑP=ßä’Þ©‘5¦À@¥ìä%Të2R…FmH^/ŸvÓ_êÆ4Z¡qrû™ñžp±È}eBÀ˜Šʨ#LR›Ð÷¤xö¼×6úœ[¬Ì«“˜ŸÖÁH±ë7~ƒ“ÞÏÁ}¤<ß>Eæ•n†xìWtåZ€U÷aø¢ ˆl²Þ§S'*òú4ãÂN’‰æÑûë!íHr¹œŸ_ \˜¸„üŠP‰›EX5áH„qÿyK'ëMUÌ2a^XäHÒBfñ1„¦áªLK¢Ï¯Üp\òÛLõB'lFäˆB¾–ïæê0ö ™Þ.†\iÑj°±~}þÓaƒån îr®BGÂÕÁˆA šH¤ÄwFæÖŽqŒLž‚yC[¯JS}(˜¼:"Ò Óžwl‚Øæç¡ÁéYyë7KHÎ÷¶0q8Ûð>߈ÿÜ]@Ýrⵞ…+?g½î7,YõE‡Œ$9mOdÉ•aáx†ˆ>hQчðý¿£_Rtyf ‘.}ÀãüRÜ—)L95¤†—’j­©Ø”ÝÃ#Ùð¯GÐ"˜!«ä üÒCž “º9…NgO=Ø•ê!ìü!ÄŠU\×2ëÛ;ÅÌ(æúW/5dÞSwp„²(¥Øþhí;‚>¢mXædWž:À" (3D2’°ÕO¿qeÄ~diIškKn¹§üf<„~Ï S¾®¬Íù«áãt·tª.ØrÄy_í¸ãdª¬rsï£*Ó¯´À¨;$m¾ñÐ_låd-q¢˜éR o¶‘ÝB’iÙï€öÜ0ù¥‘˜,K`§8Wš©ØËüQ¨Í¸…fiKöý®IسM7ÒÉ]å‚õMÚÂÚ,á? ^ŸÃÀJÐ*sX¸ö©µèÒ_·0%ëK©©“YÂѓÅ”ß®‹<Ø½Ô Ç¬kû´”·X ¬ k\mŽèƒÊ´ç'Yw‹8a_³{{bgQJtñt¾w¥¹_´,½hzF¦šõÓ¾uð×…ÿâJûíÖ»‡ª„0­bÔï  žL· bÕeÅñ3ÜwM‘ Ž¡??ÿpNröÆülZ²³{ŸÓ² ï³¨\íÞ’¦ÿÌÒw//E EžˆEï$w©vßÈÚøÜ}¹>çí´bc7œNÜ—ËÞZ&ìÞ€ äUv·kÐ\iÙ¼re·[H¹I‰îJ¥̱Ù^“FüÕY²Ý3—o Æ_Åkå'kÈØ/Çò?Œ—×’²À…ŸÀwTÌ(AŠ€yTt~#& c­:WçÙOƒ˜¨:7S úë½»{íÝú¾‹°­ *ä‽ÛqåvEËC±œ3Р,$º1™ßøé?è{Œx$&7xßJ¥ðfÿú9¿çFwCPþ¸•ïì!¯Õk†—÷ÑØe;‰¬Ájh¡$= wÀ¡j…­ëBhâ36î÷ŸRØO5ÆR‚v- Ô/hèʳy-øÏÍU+ã §0÷kÁŒž%zuö1Š‘ô¼éû¿Ö¿MË•(òòuŒðy¿"±íý9ôvõƒrw˜ÇÅà”æ<²¡/"J•æûí¾­Å½žÆõð¬g•¾û”¹$%c-\00©õ¨¸2žýΟéºv;½÷Î?’¼`©6·(Îv\h[$¢¤”«rɬæ+pâ;¼^›f,…DÝÜ  †mû$¥©ã¹[Ò±:?ÂñG¶ê§,ìÒ b6(–×Àà:7ii˜bq—Ów74m¹ ‰ >¶¤¹õ›[šºä1³læ®Ë¶Oµ)™½w¯mqÏqÁÏÔJ‘qßâ‡gÉ¿' ÔÞÑd,{ U¸ù?¥ N[Vúòyjxäóø8dþ¹8÷¶ Šï!Õ–˜­OXtõR0¦ä‚ÍIµW}?1d÷{'µáa,°&o­v„«@+ô=‚ûËgŒì]V¬Qx¸–¤-c?_{Œ÷ ÖGnu‡©}TŸEáíBö°úÅ6‹I¸E϶:R¯Õ/ÍQÆ_ZÜܪ)RŠˆTÒ¼éÑ–XžãH¥“¥lŽ3-®7¼”‘õ1åçgR`O-Æ~{Mn¼íƒžÿmµž@Wf½ú+þ·â‘%[ ÿ­ó~æÅÃóZ.H?Þ(W {ïäýÕ[ZÌ#KÐÁ‚[KÎ|zpûô…—õ~y³õ,9NæÓäÆJŤ nK·Š!3öÄ*ükr÷Qˆ›Î§ÇÝBòX–0n¼ã.˜íìó±Ç`À/¾—àümðG+Zâ}BíütPò¥z$YÙ®I éð„b›ãræM­T0W1PØ+¬¸…†~p^¡ŅC½ÈÑ(ï ¨ÂÀààí~w.À;á cij.XNØ2†UNó¯æùº=µ/nv¿"†kœ®meqR—ÊòþQNÉ¥ã’;-nåxÕ_×b˜\PÖÛ£¤üçúÐ\1ýùû“/ú+ÆvŠå2•àÀ¸Kå˰‘Ä4 n§ó ×#À(¯„þ 3-šx ­ç/CH9éZ½°=íÌ ,W?ûTñp¦Mn  !f $æ-8ü; 6)(²ÙiºŠBáÝ"õ„ ueú’lÅ5\«ƒÉq;Èi–(P<î0`)º|©¨(+ ±WÕlfÎFÎJ¾šÒ²”ÈüDùÓ Þ+©£Ê ø¾ÄgØÌ ±É£I!¼­p µ¯F:…{(JÔR^½é²¾TÓT5­I)£±xçÆkfÅ_{øä´ó¡Kf›¯aÕ1ª1`lêÎ ÏÜXni”§.é_ð¯°_÷¹OèH×G-{¨œ$èò$j x ìZ°/(¹­ °=”ª†Áª=ôÅÝ8zA]ð «ù#uÄšØfþ~ÉŽÂ ¾¶ÔÍOâ.ØÓ=ïkv±¢|¡šw€’ïQ f ý ʯÄò† ƇUdÉ*ˆ¸ä˜^|•¦ìÅyésMÀNݲ5ü»ª>1ÜcAŸþl¥Z0¡ß~¿šHäó úÚÉw¬¬Ž7GÉšŸ‘IÞ‹ÙB'¹iÛ *‚¦‹¤Gö±2ÐXól”¶=´U f/ÞCÍNïéì Öås+…rƒ|Óï÷Q>…6l¡n~ô¶xÓê‚Q~<æb%=ðîX/:Ag¨™öì¡Êú•@²o@]°5ÁWO$gBûHÀ’à\#ž1Ó[íøè€AkIÓ¡! ÔknQ9‘í‚lòlÝ¿µá`æ%=ÉÝ’Ÿ8A9´§ ¨qEýŒµ|¡ó¿j£m í¤ý„#´ªtÔª;|ˆ 9è¶‹UsWE¥1¶Ðžÿ¸v„v6­éÜ€ºà¿±´W=3öÐwù<“±‡ž+n;(ðdÛ“÷Õ!ÁÃ&ú“«röÐz¶$OZã±-tÜÜ• ¨^_þÆúÛO,yèˆBÇÚ±‡6~χfŠ",P@1°r9:&X…;aÈÚí¡b ¥ˆÊàcK_¬‡æ&'e:'‚–CÔf!Šû³ñ3Ò: Ѭ¼ €¢cÁ°¿—‡égT+T;ù2&ôš ["…F³að-ô±ò§FT­›…`£]©Œ±hñúÇ E7y‡æ°*b1ÂÈ9Þ¸WÂK«T§˜X¯ªÎæGŠZ ªÊ*§Çþ­@¨–ø¥ÍJ“£[QKzÝ'e*¹ÌþA™Éäç¤Ä®or¢Õ~ ;ôœÔ *NáÛKýãüÀz9ŸÃ×` |áâc^¿JÒ¢’&K¦ªí¨?§’üCE†ö˜wر};‘c&ƒ¾ê%°ýäXî¾Q| †üîÝ’xA=5.}A±!ýIÔYn_y^d»³¬»çäÌsyssK:ùÕÌWÛF7œwIL–WzrA陚^é© ¥GŠj]óîrÇHCö¨ÚÒÃçnj"CÄS4‹öA¸«¬ùÜORBÙMe_Ó©å䩱¯N®ÖúöµEµu¥¢¸‚@Ú_Vì+ÆdõÐ?UIõ2jÊ·M¢„x ½ë܈ᖎ!Û糜 ÁÚ‚2·•yFëà ——S¿ÒËM¡étÓÉ÷µœè²JÜËxWaÞ‘O&iäƒs7¿ˆ;wáSoå\Ck™®o*EtLìõi¡ŽÛœ¶eÌšW¼rclAÑEP9Á$C~Tƒ½qý…†ÄÄ…s9XÜÈtë~/Jò}ùápS ¸°`IܯW–daE¹°¸Òót¶—áÃÃ3ºƒ›™„Ï’¤$©¯…8é$wO¼Ù_X^æÕÛ¸oHH‡VWøV^Hoù2N"Æž 1VOÔ¿ò¯§fþ`JZ™ endstream endobj 23 0 obj <>stream H‰¬WëZÚL½‚\‡s@[x,g¡TAA©UO,…ª@àþ¿™!™Ì 3É„ôÏ<>û¼×Z»5i—ã¥ÓÚ²Thn2­IDÍ´Æ»“x5yRͼFŠëÓ@5Ö˹p~ÖϺÑUTôýɘ¦â•OãGþ¼WÔá_WñR3PÿmþÍ—¯'%`ÑÙAþ“pPNÓ™t¼ þŠÖÀ‹ù¥ÛKd´øÒ¯dÚ§ªŠžôŸ‹é=ò—=ù6­ÇËómZ¼&CšæZÂÕKP!çÒBÅzJ«èë,FY¹ÀÈì¯ëO[UÝÉr ã+éù¬¦â§ï’_9Ûù޾¢¨~‹®I”\‘+zóæÝ=¿®•3W™tþ6†­ôÈ,®23cyÿ/†ª¶ÍÖŸŒ&ô—CÑÀ¾àÿ—JuÕ|ÝO³ƒ7šfÚaúgÌs²ó‰rq.Öxã§XȽ¢î‹õVM=[,¼âè¹pa™¦¼ s¡Wç/pðeÅïF¶¤ ˆTT»„™ÙM*RZÅÎWœÚµã¥eáÊ!šñNÓµ‹n×.j×ì Î|ý½­?í*<9þlÀÇeвb‘Ìîó¦Ã%µr±×u+ô$FjŠ*¥½Cÿw˪ى˜Ý?v0k%úÂé–|¯š£9çÖÒsQLØã 9jSæ-ÉFXEÅ3áT ¦¹˜¨:gR“LàæKpÛÄù­H‹“Ë ©OF[ì„LLfÔ-œtâ¥Q²ydí€+Õ9!²µ+¾hÌD€­<Š;6úØ—b/朚ûœwlòÃü"˜t§9_uXÞ%5ŒpÒÁìФw ”ê©âÒs¹ÂÐDwX…¡º¸¸: ѹñ©e÷¹T—™½ŒµÌ«öX%²ŸÉ ƒpëˆI®‚xRŸØç4·<¶³•’߱ƀà븎WD5÷E(Ý´¢òÔEBÃOVX´&í²ÕøëÆš_£äýýVš«oVУÏ^µ—ºõˆföÅh†·Ñ&W¦çŸñ `§žØ?nZ`¼qh YÊ}öp’™üÉ…|ÝnçÝF˜ ŒùÝn".ÎnۻtŤä®ÕIèEt^¦¤öèPÏ!¡úPžšþ‘Ê„$œ˜‹ûz±ÄTM%h©šJKÝ•ĤW^w"õt™™méôŸP1;{ÌÈLþÕ”.WJ‰åš‹ úËË~éO»JGÔ{XàcË åÂÿu¾ËÑcžx“/ÁmSÐÉqÊa’Yc‚e¡Çy"Õœ © $'â`¹LFÞ¯®Íg¥Óî÷²0{ðÝØltãw ùÑÃçz ù-÷H¶ õØ*ükHÌwðƒŸ6‰Z¿ ŸûTî{!ŒaB6ÿo‚`…o’ñ‹þÙ|cdÕ Éb¡œ~Ö~O¥¯­|P/`÷­*§»_?´Lúâa·Ùœ#ÀßÛ9ö‚Ec'Xßì&©$9/”Óø¹þ»Ç8E˜ŒÜž…BƒÕßG¾Óüè§Ð©l,²B§™ÆÛ[úz%r= E²íñÿDN_I§ùÛ0áôëÊ-áô5 ÁÝ·Ü¡ùÌ– 9¦À¥uøgÚüK9„NAy/tJõA·d®…ÌÓ³P¸ÿ®? œŽž§ŠJØÈ‹6“¡Ð©6‹~™óžÀ$‹ l|ׄN7Æ : \>%ïHuÜÎ Vè/³±êÏ×wªû‚ï=ïÞ?œ¿r¾×Ïõ‡kW‹§ssîL1Y9ÿú†~q°¸“è»-0ñeÑØmÄ …éäÀf b㹩.ÌmŠ"¥B+¼°õØcV°ú!•u?Ýùº/Ýh žÚF^¸ºîDõ5û.‘ ÉÜ—ƒ ¦¹–àØëÖ qºÖ0,Õg…¢c/€-fµ¾'ö'—PHŒúeCR$õïcf{o­Û_|VPÅ^÷_Ôé¿j\a÷¢‡ñD±z@f¶˜ ëdWi¿83–÷¾óST˜a’ÉðØüÀ½;rÜù¢§½‡´çÊ઩Ç#ëDcM Y¹XhL<×i¬áÈf¬©CÏM;LÐ}þ ‹ éà‹åQbë,Ih…†W¢õ_ÀH™"xPñÓß§vòmZç¥æð¦õšZ2䜚u‹ÍnRÑ ªÜ¼ywÏ*²ÏŠ3çh’AÏ™å;ªW+š„WR³!$ùA›jâûÔ>Cxe!Ðf¼‘:MÝÎ:ºÙlS{ódlE&9É®laÖnª¯™œÄä—†§£m¥èìæ‚2€‰57š&Àä—`7+wÉ™‘ïׂ¸ôµ^ùYh3Ib=–¨€:]tæc–#NVÌÔzÖ²üº ÷XµC¿Pãc‰ 0É^åDS(»@îûœX£„R¢ûûÚt•]LEÝ]~Ý/.œä¤[©bM¼b¡R)àÅÐM»U Cr–ÒÔ-f5‰‚ºÄ­“êF{¼•œ«1ö/WÞuû§¨’Ü`ùyÄ0:Ù4ævcHOÖ&{RY4) “ýsŸxùŠe_ÂZë_UŒÆZ_IÚˆvTÅötj š^y%áèþÀCÜ‚«R§ôØqØ~Ý —^õ>È…ob.Æ Æ„ÀÀ2H32ÇÄDÎÂgâ¸Ý-‰c_|.ÇÞï–ô±'2 ¨®áf"3{œE5;Í—•pXn?|vhœqçKÒð×b[2\w¿û©¨.åqc/.Æx£¨’åpR. !Z¹° )畃Ž,¬Ž,Gk[‰’+*.Ñ$/®$*O„É9•öJé êÈ–ü¹*ú“±å²ùzìJvãí}ê±Å•ôÆ;” ¤b¯ »ï¿Nó´ó(Ì)!ö(ôy¿À tY(p ‰^fws¨S^6¤ýÅçT5õxdLÔÁ,–BvJ…Vxa™xoÓÊŒsÓQ3Vÿµlpf¬ )½IÍNüX >€;…Hœ+ªÄÙ Sr§ñY­â§Ï[K)¡ä°F÷‘Z”—â}êâÝÀ¸ùlªÜ¼ywÏ*²Ï TJÄPž3ËwLBíâ9ZÁ¢ÙAO³Ry.\Xç{Δ…@Kº0ã{aBâ‚…µ ç>ÉpïxŒL‹å\ùn›¡ÅrÇËޱäÄr®<ˆ‡$†AQ™q ^uèCƒR‡ìK±§Éô>Î R+Fy©ŒÌt&5Zî¦&˜O’_@(jÖÓ„ræö|øÉ$D ŒtB™7mýàiqñ•d¯n± /UéÂÐe9³ËB« ª0"½IWgjHl/¡-©ýÍ'ú„Eˆ‘¬xEŸI™‹ˆêª À)¶—^;ùp ½, W½ï4(ü8ç¨Ð+:±)pYˆd§ƒ1¯lw8c°ÞG.1CàÖŒá€Í}9ÖNö¤²hHD³¿+ìФwd4Šê{‘gìVT{´MÀæbbcÔù(éДÉȶ؄¿ÑÀØ$¢4óA¨¸pféÿ³^¥k‰+[ô xAsж` lPl”ƒ^Ž´‚ ï«2VU© áO}~ÝaÏkïµØ2+&a8‹Ô¶~f*›Ö—àc·‹YÊ·¸{)í¾À‡O" [‹íõTC½l ÷³Dj±8 ñ¼H eq«¸ã0 ÃÔó®ÚæsK¤€ù%ÓXîô¢Ýñ‹ýÍ"ç—ÔÀ^Äá£ØIòº/h'å'ƒévÒGÉJvQIò|™(YSÄßh 8 ³hã“Õ¨y]K]ÙÁ¾ ÷Š“0ÿÆiBD¿0|ðCkØG+ÝD¥c8 ö†£•( ]Ø8¬·7½H4u\'—'æÅƒoð¡ªWÝÎà¬ÈbWŒk'#M@€ÚëÆpùT_xQ VÅÌ߼ĒúGåBóôÃFø¡v¢ºRé8º2F©(±2Ì “yW‚Ô ä­€¯ÁᎣ^ÙDgߨ$è‰ænÉ":ÀØ4äWºü† ²‹)¾C6Õø’λ•€˜Íâ·Ÿh`.ÐX.CÿY h1¾bô‘ÍÍ­=>ާÚÉs¼¸œúxs#4 Tf_hçÁÁoFnL’4f&oµõº|3×þ>¼Nê¡ÙNmN/ÿ4úåžz)o%°ùýÊÏQý±1ê×Õõå?ͳ~«VMÿ[«Uåv»_Yç(üùÚø«ÊIà»ÖgZÞœ7CƒÕß''¹{þ%A•TîÖë_'Oé\çý—]åÌ5xTPÝœß{èxMÖA°z©Déîlž¸ø÷¦‹Ì êôÇ<þu²xÁÝšNó£!Ûi°1“™N3~õ–pª÷Ew{ ßü×}e9}qqª¥ ˆÓY$rœ®7ÅÄÆ¸b7ÆÊÄ œÎ;–Sí/êôW0Š:Íߟ:N×»%M8Õ/²Uà_Ÿw §g¡Ð÷ÙnLwš=1‚ò~f1eçši,û}¦ÓHçm>c9}#œÆ¥ëÛ!Û©zý¤1Ë{ú•»˜°œ»×UX3ký/s΋‚ß]оƒx!¾Ì;Bó±žñy:;g"zm©¤rc÷—<¨³HiÍ\RξcI*œÁ&¾Œ\îнڋ,Ý•ªØ½~ª+ñêGaY:åéï犾ê{‘o ^øAa$x?$@œ[¨Ž âêµNòßæK«"Ài!eŸwÕ6ì »Nù%£NÒ‰§Ö™Ø§…SßêdV œù@˜%¹ªæG&{– ¯*3¤€§yZ:Ãé)?dóÛŽVÇÉdã>Š>Y „©S¶úXh/ÚÛV°Nw—5É”ù‹˜î¥\hž~X“úGÕÇÂØc e%T6ÕM^˜º1eh,¢+9zÅFÉ­o½€ÏA L…âPdý¹3R‹ÿ3U©©U”v‡É“Í丩¥BR"óÖKG LâE$þ#+úv=lj?¨¥[ü^­õy£¹LŽþhíˆ>•Áîk,Цºì½0ûe11 w2W~¸*5U×FîJ&v5†ÓeµG¦ÙoÞœ‹]ä׆ý ½jÒxLÊÑNûVNsA‘FÀÇ_O’¨=} vÂè¾ýÿò|™(íGVü¦(¾F±$“Õ¨ÉÀƒT SªùäÒäòâ|ECðëgé;ÄÐT¯85tHƒ…i0ÈÍÍ­;¹w¿ Í4c” Âë¯ùñâ|G#7æ¶]®V±¦'޶òeì1JP… “q9ш…4±™’µGûGì{œœÂŠ ÓÓ™Æe‚ôþÙÛíàZ_ÇG†5y÷}s§ƒÆ›xzŸ‚E<.½ÙǪ˜;1äVÌ yÖ e«ÃQ Žîµ=ÄMÕUaŹ3‘5JE©Èªg;ïÌÓ1vru8ÝTÀÀ"ènxyÉþQàóâŠîf¢UÛ.…1¨|L¬ÅlÃCÐý¿fîô¢Ýá÷ôõ PÖ®^¹&2o¯“{§Í>cìÉRIæ°ÜùìÐ$ÿ/€Ôè(¢Ãb[Þp±O/†ÃÆA9Þ•àÈ{9°bР¡Å(ŽÅ\@BÞ d‘ÁRƒò/SŽt*öq¥Ÿá*銀°î¸Jr*ïÆ³Ï›oرâç— vpb² o„çy³Ù…'5y%Â.Äê´MHžêäTÉVIFê[.±íaé„dì1á ˆDWÉÆÝ‚X'Ç)¬ W[>ê„+Lî†q©SöyWm{Z™ðŠáЍ¢´6„"ÊVØÝ·Ð#ü¹bèJ0îBºò­—ްvr J…+ä·6¢u•d,AJþÙÂ+–Û«˜ýp7ŒÒ–ü§V)Þvõß‚¾àÉaŒ$ÑAʤµÃ!ÌÈJkGaæ=ÿΡWÚh…o˽ÙÑeÄØ–¬6‘‡œR–€HapÌ2 ã¬Ûi.FÔÆä0°:gÕ!î¹ß ­öËå†t‡o˜â퉻‡BÁ_ǵ[µñå™Ã¼àãÀ†Ê@qobHI”$|žÊmàÅ™‰6Iºé#N'ÝDjå6,{ÒÝR+ÅDçácd($ó>¸ ãJ¼úÑ@tåa …ó£p‡n{ïVÜUxy/Fy…4Ç@Ãêàš9É üâüWžCÌåÚΪþ-úÉÌ98uf¯´Þ'wî´6¿Þ-0T)Þã­Ð”ì˜2™u£ÃÇoBcÿ3VÓwŸÏÞÃ\@½}Û!(+µû‚vF«£qT’nÇ7u+¸„µ·%a'dß’„›1œ­ÒC2L{ 3†SͲvÿE\>ýßxW:©&N ð2‹(_ cžƒóëÑŠ,3ôv1KÙ§•’ÚTHºˆX\ÿ¤\hž~Ø^p¨DÀÎŒdS˜£T”ŽøÍ‚³‰:ˆÜJñ@5܈Í$öMuv"Ü- C†Ac½ÿØ8 Þ; °T\Cþé„ae³øíÚ}A;ïÒ÷ÐS4PWÒìpi¼P4í[ùÒªXvnníJò7Ú`†‰nÖnüeæm;}1¬—%(0| Áa ,CЈ´U¼è㮎o¶G‚¡:~ ‘ÃÝcLªãQÐ7õöCkÐF+„S:ÔÎ> ½ªWÝŽgÒ®´ã†Ð ~ m‚ì‰ÚÆjé'š1¦)CWšÆ mÌ/‘™IO59JK¥KÓ¨½2âˆz%Æë7ħ泀ão‡æ°Ô+FtÜh0Ƨ9¢£Ë^´;ŠP8Éf½øÙTÆ>x v“4+–vØ›F÷ ;òQ²Êˆi1®‹¦¾p¬Èóe¢dÍPwi1¥ò4£Ÿlõ±ÐB¶.Òød5 •o>2ÑpàÝw`XŒ&÷`XŒrAƒ!B}à ‡n0Di€sÅðË”dõ‡T¢È3ˆ€IÀÃ+e1šå%i™²û¢DXÆò"#ÓTO’X¨,FEPÉâ:xžHò}¨®ÔzŸâº’±¸&k·Këõ[9þf…M„1LSˆáH÷£†Bİ–V˜…úYÎAa^äéFy=•šô€®¤”l>ÈÆ¢p嚤„‹2MA/QµÍ½¾ð׋±ãª(íÍ”w3Ýä*ý.ïj:ËÃVI{½”íà¹ÆÇ![NŒ#°O™ â<ð6É}"aóßä“wV#:?éþ,ê—–7?š¥~}¡Ôªrëw=ôÖº„ë•Ä}¿´|Iœ¿´Þ¥¼•já¸1ËJå`Ý8<Í—„„gý‚HñT7çו;Ôéd¡÷R‰ÒÝÙ<Þ„F=¤¢åPN¶[Ÿ ¨óf¹X{9£$wÏ¿þÏz•®%®Ñ'ÈC@ ‹!¬¨ `»ˆ‚ *Ë€rÅðþ·»³‡î$ˆò!†ZNU:Å ±«þ^–S¡>Ÿl¼_âœÊûq.nåd‹[¡,„›§:pÞ ½œ^ˆNA.þò:IÌUèç.Ñ)[òšSéËìôÒ2œ‚\@cÌ·Ó “ÓY0HN·ìyPÖ&-NÓ‹W~áœR øÕœ«Õ©¿<á‰N…rý²Mpš¡™TëvŒœªzÌ ðÈÁ©ÈJ÷ô3Î)Å VbîþkNð§²Ó?­zìT»eäTÛÈÀmþ?ªRÞ”÷᫘µú„÷’%øš}Í÷8œ»ñ`1’[íDcM‚œ)»èÔ>±ÈÉæåY2¨CBÒñ|²žŒÔtòfˤaní»Ù~•zÛÍÀöÕÚ¬#"ÍV)¡GGQâ˲Œ¡õ[»æu v29¨’l Êm¡òó5~﵃[Š!Þ 6­ë¬tAH=1$ŠÁâ¾™ŠXœl›ÝcéT c êÁÿ+8­Œ•®Uß¾ÔA<&1InéáÛ1$%Ê[?I½Õ)ùAæ×2Œ‹¯[ >—ŸUwcæÅ3èVŽp ‰bœ‚šn§[¾î‹u|Pj<Š›LWâK>ŒèJA´‘•¡úŽ¥+ñ¥*»ßbAÔ\DÍÿ&:°³‚¼;›^œùl ƒ¿YÑCM­Í²„Ô~bj&†Q’#¦æIéKõ Z5K Põ)¡ÜF¼d5oóA’ȦWK †©1!áÝô]OªPQ˜Q&X}S¡¢k‡ÁÁ ˜ýŸ]-ÐXœˆ±ÍÅàŒ©È«i„‘ ‹ ™”…;úÜÔ#ùe¶êPƒÑžU/,u®8B9'e;à *:©~ø¦‰ qŽ¡º‡Ÿ~ö‘Eˆ‘ÁCrHHòî>íÆ£úc¨!6ñï$ÝâÚr*¦6Ð_Çòò|¼=†i UŸHú׸hÓÁ-¦ºÒmêeAR$ë;“¬cf_jÔäºÌúÜÀÒ–‘-$ˆ˜%¨Dñ9[#,5W5n ‰6BBˆ™ƒ2ŠçAQ<—ç¥êzÌC ¹ûæ)õSsA` óɨû;Í Ì?ç=ËÞ?ÉØvùä!.xñ¹³m•Ó{û¿„Ø{Ž{þ5ÄlŒv"bÔ ÁØ]ÇÆ´8u¨"–(ögV}XùcXžíµ]骄±;˜Xø<PTÉÄÒí*'Þâð1vë Ô0œXwF?ð¡Þo!Bý>*ÉÀE½ã@б«¢ ‹¶t8X0@]  wrÑ*—•ç SÑÉîE ^W n@Ävù­ç“’„§3oÀÙ÷ÇH>âöËml /JÈ !‡5y(­ÒÇÒ|g ld]›(ñfeUO¹­]=¸ÛsÕ(›$ ÃgÕséP¦á›©hdjÊ¥ %yÅ;qn¿ÄëvG“3©w-P=Š2`õp"’†œŒ ¹ 8-bÄ Œ*$§æ.'°!Á\‚J#TBÒù@¿+ŒSÊCH¦½ï”›ˆp ò˜T†” Ñ!m[¯\þðÊýWCW®ÒÉ^î\Ò•[CwÕ †é±PÍöD(ÄëK’:lN'±d ÇÍ´ ¡F Œþè8N` ÆÕ°¥f(Xƒ\RãœSSó6ŒZcvŠ9@YjÿsÏ*¨d…ïJPsëôÄ0ÕrM¨¶·.‚ÃÎA©D] ïÊÃiK²›ÔñÀ¢.rÈ0ÀÐúÌFÈèØf–ÐÉptqº@—ìè7ÉÂãN° öº]°Ûh¤ ©q’dOºúÄfX×M °ƒ¢”~LÆÃà¢ÕØ’¬z!:Ó­;:„éME;m 9Ò®ÑwpÕºèJh‹ñÇÕò°’ý‡H~™­+©0 —zTÏš#³éV|[œº¸ƒÆ÷Ýq=Ñ6FïÇ=ïݲ˃s´?˧P²B1G-=r4úâ¬Pží¸q·ÖØ*ÝN“!Ô…Ç1Ë {œ1«ÔdAÓD9´÷L·¤Š+Ùqr¼^jÐTig˜2)Øã4–à=eÙ]–üÍP~ÎÞ „Œ„Ð;Y›J¨×B€½†%³—í2â&–Í—SØF†‚íw=ˆw׉ï­p½ër´’@Æ^÷źW‘‚M­ˆÆ’‹zã´™Ý.“sªP-¼;[¡¼Ú‰ž ÈE³sö+YaÇG½Åޱ#_¹‹UäJë!3 á/ 4 Ö1L˜ -rêv½jÆ<(y Ð^aû‚ï\ á<†úöЪJéçc8X{óãm ±cÆÐ6„ú-¦;} Úökñj¼ÄÝ­ yÚ¬À\ðv~a|€Þ౓ìļm1W;q mÒž(ì5†Æâ'[›[`Š¢WòÙJàSJ8;à‡’Ot˜œÑ>l&Á‡o¯¸ à±<6ñ÷÷ÇËBMü#¿ûµáEæSSšbN=]žà Ùtæ)Ê©^6PtvOá;ÈcÈÎvùt"o+€\ú8+¨Çޱ÷ŽÆÆ–ÐNŽ{6ñ¸VÐìÜÝë dœ‡rÁòÒt‹Ênò’Ð -ÌwÝXì?:õ8†g¶1„^úÆjœüÓ1Ìq‘Ç `Ûb–Ým†r$;\[f€…ª 3˜ Íe¶êÈ5¬ÕGªK?Ràĺ#bJ³Àhh,ä`,^o¸O%¬;bÉBï±ùw%¨%¯ïjŒ@¨Ïž˜Í^ˆÒÔ^¼ÇŽˆQØ Í~Ÿ½—ø³aXâ]–±! •ë•( N÷™™ Œ…â°‘ÅþÂGÚ*7(K|ÒM“|A’±´1¥hÕX›eIÆ2ŒyÒ0‰âÀtßš´;ƒJJí6S1’1Â|N·N+¿LêÔËÆSG¸.eïÇ0ëáÙI£ÝuÑà*La¦¢ä¥Å×±íJð팈„qVÌrv<•V@Dç¶nÒz €ÐR¸Z›¶mº+β!ù•Œ»›gt<[–K´±¥YNl>°Vj¾È°býå¹òÒU'³ðšù*/pß¾Øßá:•”µrþë5{ß sgÿBlqS*­z³/f|/“Y|_3é?•`ónÓIo–ƒ!Åœ§ùÔß?ÍrŸ¯ó²/ÝRãbgÙ-Ìš™§Å㼕Þô¸ù{àé&”ºýô?vêËÜ×e5/pß›Ñù†‘¯¿3-ßS«À’œ”aÞ‡Õjh¿ ‡©ÕË<§Î>Û¦+ùîãCÏÇGÞ®}‰M/r™d¯…r±^Êïk‚” vdyœåäퟧê–~ËL·éé°-Ä®ú{YN…#W±³'>ÙÈú‚(~ÆäíËê~G#Õ‡áM¡.ž£ìÍßû5x9ý°V_ÍKò~gÂ7×,Hw„uI|Ä\¡—7açmº÷ü˜|˱r0‘úØÓ_3ß,Ÿ+ k@ˆûEàÏ·®S­1øYóü,CûnÊŒ˜Ï`.éöÊ*Ù×¶ñ©µKz£±è=eWšR´†Ã!ŸaJ{й}.Ïû·ôl/–^¥N?Ó*Íü×±Ýeí:¶]”³ô²->]'ßlßyé«×¹©d|S`§·ÑÌ2_HÍÄ#ËsÔjðv}ÑðÉ(«›+ØÉ7õ§§QDìõ+ðH¸ý–ÿ˜kYªÁ›]NBlÇñàÏÑNaâXšgµOqÌU”ˆœƒ?ÏÃÐ §º^EÃÐ,ØbC|Qâµ–ceñÖ«|/]§ _A‰‚ 0ƒæ¾¡(–[¦åÒâVfj‹æý¿g†5³ìûóý‡0p–çšœˆœK¦ÐâMô}4ÅNúdƪW¤ÚÕBÓ¶HO1–˜ZJÛ!K‹Ì{c2^^±šçòµ—Ñ"ðJ«·Igô£òΨÉ$­A¬d0þ«P{¬XÙ%I§›”ÐI®Ï2p=½›r$ÿT‹ùþcÒ¦7À6†Š7•–øÁæ·Ó…Âè„õ4a÷Mȫد ÒÒ½¸8iDÌ»e¦ ó~;¸§£ ÖøÑƒy‡g""bˆxèçˆÄ>\Æø ?,«²ñïöeÊò]›w}ìæ&§/öQØÎϱ˗á S ='©dÛŸ-ušòÍÉSµxQa®œ’BS“ÎDD©Ï¾°†/-»„© »­ÿ¬$¨s]eÌÍZyù| ¬^îdÀäN8Ö®íÙ«°kダ–£Q‘Œ*¾u»¦¨q_þ[,iüNS§_¡d~þ8*¡2êÀ£|t<õ°û|tõÕðô‚käêmóoîRÞ­ÀÝÆ-«äçDßÕùöÌÉ gÕGb0QãP±}©™n•4°UEÿ@uZ4ª€S(È£Tk yÈJëܼ)V:@ãY'E0æA©Z7Zǯú<¦Æº˜ˆ‘Ðò$A2¤³¨_ƒíUˆ€M„D.ÙNÈDÏ·Ñ!Ó|’¤ç·œŽ&% uå%v´ƒN¾Œ1¯¿kT ¬*ÍË…$ÝSÿ’/$ä¦u¥$ˆ¸ÊÅåJ5F6ÈùâcRç¦ëêKé°RR% q‘µ›ì–Ýß•zXªVɳË×TÍ$1$Úa¥~l.EX+È…QÔ‡¹Jù²[‹°}©E³,0ý6ø°Ò7+ŸwÇ>øw”–ŸÎ +éß?Ö†ÿX꿲I&ùB™àóqXK©%ù|Ñ­ü¿3ÕÃîä*š ´2©¿%Å”ä'TMa~¥F¿BíÜ©`áUîË ½;Ö­¸ÐùÉ«ÝG`o}®×xs Ñ“Ý5«ò.ïb[ãcß$váj2ôóÉmlMGÝ_ˆˆp  ëù•Ø‘× Ù"ôðg¨“r‰ß³îfGÞµb<„H°á¹(õ¥Zþ‰‰7<®Z¢I0:Ð_ûÐ䬰›àûæäßx9ÉV²îG½‘s?^vòtU¥â°ÚC:zØL\÷¾®UŠ.Ù.F¾q˜® æÁ¨¥în[ú°Y rÀÂEÉ\q5aOž—Ζdmª®½+\œËRw!ЕÄ=õEBÒócQqN˜<¯¸}«§cð†¹ó“±?Ýú¥ÑGŒ¨J–o8ÃF÷æ~s¶I€#äwOúéÞR›,>âä“KâKd¯/~Ûá]l©E)±Ä´ŸíÙ†Ü˼7&£Š?IÚ;ÿfx·XìCh\miD@òj–_L¿-Oý#Ú »›]‰xøVÆj_ÑõIµu 1oúV;q½·-ÀtŸÈç6­üöj]K”‹ÂW0a&‚`ÂFÅ"(*™£•š3£9F¦¦ôþ¿µ6 Ö8‡ïOO=´ë]ë=l&%ËXK®"3=æå¯ip(^e2ßî 3Ý ?z´M›y™x-?*Ò 6žZÙo*Õû:åOò»JŇîA6Ee½a‘ÓBDŽú:½a Ã¨cëü™¸¤ÃÊ8D©¢ŠmöL‡­ÖÝÁè÷é I›ÜA8Êrõ|õ‘bŒqý€–çð;¼*± 0”Y cã:êN"súù(+¶ËǨ ê\àá¢CsGÛæk·(zÝÐfgQù¸ÖËnìÙ‡–!+$ziõóì~]6&‹RD\†Wà“g|Ö oÊ̇D”TYÉ–Æ-‚kqWf&+Øöá €g‘ƒF¨.ü‹®’Éw·ø¢³yl’ÚpUoWz%Ô—:>â¨Âf¹HZ ~ôO»8˜ø~0‘¼0®Ä‚q¯ôòßb\ªFbüºØÇß„˜`öì˜p:tc§wb·E+vT7ްŠ·l3¯|9eÓMò°í€T@·Mr.`<ðÜxërèPz]#oß[›Éœ*£~x»G£à"AR¢Fð”TÔÊ!®.•$™æÃ̼{ÓQj»‡z8ÌØo»øï{øV-[.Î¥©Ráxñ¼)$Ö Öi½þEhß ‚ s~Ñ…öÌ„®t'ÝÔÅRp'›õ)>\^Þ?×rbÝÌK}(h¢È®^ÈÔ\¨ø'Ä.’Xáÿå`ƒD =gì­(p¹²B,µÖ¦¾?†„G¸¬l¤RM±]zÉüß/øE‘=¹Š4çë%|u5Ù0‡E™¶­hp”¢ËƸ_+25:êlû¼í_;õßÛÊU©p¢ß]XM3~oÔ¦xGϬj.üÆœ™UöæJiëNÆpòŸOçÚê£Yå3Žý½_bÞ÷B@,pCÁå˯7«ÁÀ·¶ìhñþ¤à€þìgû$Ø&çÇfOaö€• +z}|…È^yÄÆ»÷†~RØp*#ƒÛù¾ï]%2œ–ᆲù\5y ¯Î §ˆÙ®uÁ ÑM%å릖õŠ{˜ jù‰ñ·³#+)Æœ]ÍNd·xü¶åyj/m”¯ü_hHG:42C¯×=—ð{<—; ßb÷ßK¸(£…€Ö^_¸¿6^2qnT2ít”×C‡¸…Ék OY±#4B šÛ³P%Œí·¦}Ñ«H_ÉÖž·æùÚMãaý] €öŒE†¡ªãOIØû?¶åE•|^ðæû '$QÝÑ#Ô‚%½DÄÛn©D¦–“ߎڭÙÒÁ8ßDE+Q;,.±t=3Ï):™|m("a(&³§±F¦²Õ݇I¸¾×¿až&8ÐרÚÝÂÔi¹ð¶[4hõ¨cÿkÜßå>û¼¶(.RÝdò‰¢éâOD €žY‡&y¬e_–·û?ÞÌ ¿H ¸6T8’†¦ñÇ6†É!Î’êÆFÒÜýµ®ªµ„uåsïê  Ú—?ô·Ë’J¬Ôyß»1d”MÌõ8ëé¸lµ ÃXç~ò†ü@¬˜håe¿@“LÕ ”«¶ €¸-`àù©ŸÐ¹²³ñ¥)×2i]l³÷†d»Ã °ÉA z¦lXE†0 ¡^÷ºñOŒ~‹M¿4ú—ôáô±cÌ>úo±=þìvª—ÝØ3ý€z/ìuû(‘|¯ÜG¥7ˆäßö· Y‰:Ú— c•+Ð+×öºzWZhÕ*à{¹¤‰Úr­wyе€®n}*:£uê38l|’à‚Ðg­dK:‹E-4 ÖÆÕDæÛ_Û‚ ‡Ý„ÅpAxJ~T¤[lúÂ> ,EÞxxt_<wÈ¥;ï?øpe  endstream endobj 24 0 obj <>stream H‰´WÙZâJ~!hÒö%@€ˆˆËEÁ÷?ÕPÑ™¹™'IW×ò/u¶ „¥l­[‘–ÑÉ€S^Vu±üvUÅ7WO]NÆl«GÁ:f;… üßí ?kOZb(‡28Ì¢’y;á*‡±Š(_¶š¯ [y¥Ã·©ã@˜“Ù|ëÁŠpw±Ä"˶øÙxÙÆìa¢ÏII=Êi—]½Ü¼ºúÅÊ|Dh$ÃY4¾~ÄŸLÇP •¢/%¢‚~Ó® Ä*ï$ƒvÉÉkrY²…å®Gä×I¢pšÃœ|9æž3Voox‚LB‰F6d?8>u~aó ©¸ 'VØHrRï0;g+Xéq\^KY=ôH%ä“ îØéŸGü*ù ¿Î–ð¿âÖÙ‰3:KN9M¬ÄÐ)¼R{&LO¥¯ž x®œPgßsðúå«jÂ`Ž˜ª¢yI— ¿ÌŠ@y#NV1ø³±¨jø8CúbUGsÎJ¹8¥® ˜2Qi<蹘ÉMúrGŠW½^™g l(# z$/LGè[ ÈEu‘ Æ4~7¢|‘+ÍèI {o[ ÃF–“ÚÌ+}QwCå•Îe‹Œf‹#/ÊçëSZO˜’ä‘û &š$W¨Î/™áîÒšpy w¹¨HJ&‘A…LV˜?þ}šùŽ´ÿÊd¨2\³«n&„gï:9 K{“zñgˆ~&•òFðÍ*úF%:‡…â]òB£V­BÉËq+hw~ 9XS$BÈ«!4zõ<ÒKú`‘Ïaõð±,ÜJy¨B)‹2¾Á×y4¾ýsˆ7Ò/ ÖOŠÁ?gGdI¦á'Š˜d»¢UïèB¯ðPŸðM«•¦—·§¨ölqÑôá[ØÅ'Ü뺌مœ¢ %tÉý+b(»|'¨´ÈWé7uH½&ŠÌ•¢ Óù…ù1‚®j¨öI‰Œ&Wù™Ô5°ªy¸†È‹>ªFQh¢eu£"Ð}&(ñªªè¶?(l×ä(âægƒ4ºø“iœ Õ‰8ÕqÒ¨†û~’Š’"ÌD‘’ÜgÀ}NR{PAåIUÏGß"©=(Š òIjŠ‚ûS’ú‚¢îÐAÎâd/öμÐmôÜ«ØßÐ¥ŽÓ‰ _snÌ‹@=YK+ÔÝ1´Ø’œx¸}âef‹9n^jÀ‘ÝÕÖƒX³L"³(-¦EfvEi Æp=ãÃxÆxfŒ`‘ÎTÏOŠó»€,- i'Ç©ñð{5ª×»d@rô³ ìïŽç²€”»nAjíà"˜’ŽFȺŒôt¶ ’~¯<Ú€JT»èÑm8Ò€7qqóªã èõc¿ØI=yf<¨”HQÓ6ÙêÄ1ã`?æÃ¾íf¼ìlÕÁús8­¬‚¿#ªc;2äd‘à¥}ËYÃâ¡ ô¼íú¼W6 U*¾ÌmŽnƒv˜“í—òâÅX¢¿áäèKœ¢’ xՔטêÔbÝv$â².q@ ‹˜ÇøÅ*ƒ~uÈú.n§Ë=¶ô4>ri÷<ì샽fò&™ ?6ÆÀ^)Õá1°oÇòÉÿ˜Âh~t³ø—æq}ŸQX=¢Ã^,šù“*–ÿmÂ5”×ðtvæøÒ<)[æ ^ ;K ðY,Rw!&ˆ-ÑìstvËeF^u™(y0•͵±éLj^ôÊwô%nëZÞ5X›Ì¿—Å’/ÂAÏö¦dfu°e+Ýuf#1< • '_Ox_.Ô]ÁÄ”[¢—ÊSw´>© 828È>¤ð³_GEøö( Þê:o1è¶ŠÌØ7ŒÕm•—=•ßV÷Ýýß3V?´UTÅö7V~[B£P¥X™xD^Áæ²ø$h±–;„PއùÞ ´d^ݵÂ_/ˆÜæÊáƒaAh¬ë¹Ï7Ã@xßÝðO6Cª•{톲Bg7hžž™DJj‹#r¬&2ùÁ2øoµÅí…V‹Ÿ»e¢û‚M+ Š?ÏÀr•K›&aºšGû>ºŽÙtÝŒÚ ÄêØVƒä¡g ¹ð³Þ@‡æ}nµÀ)}l¶jï^³e3,¢fv+—,sôw]&Æ)éæB]D¹¹zê+¥Ìö;9ðY¢*–µ¬J–KŒZ1wU¨ÏKwÄP‹õ-ƒxù™Åú–Á „÷±X §\ï¿úü%+ª/‹® %cÍÁgÒ=fltP‹[ŒÞ~9„#:£dyBi-s?\Ü ûJ·÷V¿ˆŒ¯ïe öÏé´™EØidˆÃñó a•c: $ŠïQVï½W ?˜i¯Dã–D%Î@N%-ì§JÑœ-¶ õ²D+á×’rDi#,Jª¸õ!Áçîxq€T)/ÜU¢»¸™n¼‚¯î׎ah^=ô’~A%^_g<"²Äèü¬mHè6”Nä n=!zÔßµûAÅÜMçV^)¨ö;Þµé“h§GÆÝW*<"Ý-lûØÎåg Kh¥¹K‚7˜èþ– ÛÜ?BåÒfÿ %!á²}ÃÂzêŽ&eg•عc¨†=ÇmP&\t*PŸHÎVH±¼AGÜÄ-Tæ/† ‘TÓ–Àcæb‘ ‰º"‹}ŸK.íŽW;eˆ¾ˆ…cëf®€½ã°_Àr`É«9¡Ñ#¡QCI<œ„êÐ+5Èi˜M-T ײ)*üáÔµÜÔw‹ðaš%.[¦Ëj5;¯bv¢´ É(â×#ÕêÆwáØÐáSŽ/˜»ácé‹  Ÿ¿ê`Aí ã§mÃç¦ ý›Ø C ›ˆ~s{=ÝFÉÞðiˆ¡ìœÿ>¤/>ýøø½e­Ïb¶3 À‰„>IÆŸ(ÈuÀ¢DŠ•ý "ðÁšX¨¢Ú«`˜ðÖƒ heãä¿ @˜Õ—…O‰ŸI¥"Š ÏHT˜'0t×7M¡øý½juãKøŸëÏOÕ§™šM\øÍâ3ýù;ð¡{å'úó'ð!(HÑó]G¾ŽxÝ8i§t»…†%F¶ïNþ¶‡û¾ƒsðò ÷}G¢üÏz•n¥Î,Ñ'à  Ld&2Ȭ ÊŒzA¦µ¾_÷ÙoUwgÅëñ»²’TR]½{WÕ®o5\An桽44f[ñXÁ•@QMopêb–„à·\Löæø¤Ôè1yöÝ8¶í"é4ø÷ãÿú;2-He…+¢!ȸiìqwHS÷÷÷@RÑ…Yi3ìf`&ƒ.J糩ò…Þ!5<ù%¢«€„ ;ÛAúªÂmá£êŠ|?ÔƒÁÁ/ýtˆIÊø®·% V?)df¥4dw² §@Q}áÙ)©@–Ò9_òsG 9¿öc^¤©ÀHÕËò®b©${¯ÚŒ˜ z˜O24¨ü¤®‚)á1™Æö\B3ä|†HÜIi†’¾^Ù¼žÏ^zÕ`¹HGuQ±Žõ·Óç…ª|fÃG …á­ÈXº•H"ÉÅËŠ‚ ñ O=“¾ßðÐ&2¶­†O¯&vh-®"¾óÓO¦—9ôÓ<)—º•§Åydn§}™U/®µ€µíÅU°' —±™wÛo®Ëí À éÎ~4àbB’4#d »2.øŽÒª p+þ¿Ý¢SÉp ù"‹¶]ÜÓ¹Ú^&;ÁÛLøiæ¢MVxhqŒ6½¾¢S`°Çã#Ò±á0[hÜ{£SÔbÙ}ïg§¯¨%k–]Q§µ»[vvwè¨ ¸ÆCv§¼„ÐEˆ¢=|H£Ç¸L”µ2\V$úïðФžQ' ]yŠ)žÑÕìM7õüœ˜ö2ºçrú(ÑÌ.ý/0zLŸ+j¹ÄµŒæ@º˜×EFX\Ö¡_xZ“õ>ॹ¶è“H¶p( ‰6à¸ê‡Ø:þ£`ˆwï™Óxj¹öS^]Z§™fûÑy=ñ¥ïµS­®Ž‹”“ø† ÁÎf´ª¯Yµ€†há)„ÙîZÙÂêÿXërï{Irùwìô¡4Á'=l<¸†Ç €ÊL€y)½&"P†V’Īã5Ê1üq‡Ù[ô“¬4¸Ý`)˜ñhuÑÆ›$Õë3¼M&‚öÉ Êª‘†XÙ­Uèý­—&±·##mÊø®˜-2³£V‘¤Ð¤ŒG[–Í¥'»¹ð_jXf`ÞšTqÔäÇ S.…©Ä+Ì…ýÁzË.­«¼\ôåQœßš}SÍcIæ?IK8 ]„#‘Ð…Ø<,çÛÚöÏËŸÕ…×re3%Yî¬fëüv>oÏÿÙ«ëéá}¾Ú_Ä.ÄL+W*EBê|ºžÍ/¼tâ ëÅÎËbdÚ,pN´zeÕçhaQ´5cõYê%M’.Ѽ|åœí ç}}+ZxÎ3õóœw8ës^%ßâ\Å{þ@%Ê1ª‰»#EIŠÛ¦Î·Ùõ§Z¹?É,¢L££v!aá¯ï³ófZܽÄÅb桬>äïZiq/­I;¦­ÜhÑt§ÝE˜†¬M5GzTÙ;8!~ä|¢óâ\¨°»9¯NãÛÎÓ°ÞâþnÑâ|™ÀŒóV»Eν±mQëE¨Ûdþ°„dP<,Ç 2>å‡Cõ5iŽä\`ÞÕŸ$‹µÌ6’ýZ¶‰ä¥¨‹Ý½ÍQÿi%Ò=ì1æÂöVô1öKÏ• sñ܉íµÔ-IFï‘¿jÄÿ$~ ,üY!`ö«—Œf¨ÉºaÀJS!á6Þ™W†l"X…˜LkcfAÕuCf=zhŽ=íÞ`hÊä¦;ëiÃ÷•«zž$©ÊÕ¢z™‚tDFûIW’'•’w ®h'š ”d´¤ÀYMÆ ¯ÝÏ‚Ä;ÚE“xÄ&ÛÀcWd/ú’v70Ø6Qœ©J’E³˜L†Â^hÓ¯nx¶—Åû¥ij›„çÜëe¾–]FlS=¤¹ïìç膌 Æ@G à¾ë7åË”‘e?`´I»àn,kw3C]Ma®lÂþöoÁOÑ„öwy·¼ ßù¬Õü¨ÊGÉ™ZLç©¶©Òr̦š¬’íy®ÙˆK§?]Bç¹í6vÆk%ÕwsåÖ­z¢¡`îâ7ÊñG LÕõ0®×À”Hå£öæ,÷tc+&7ö÷ŠÆ,uA&Ms@Ŧ' Ó’9¶Þ$‡´O .B‚£V½Šëãí¢!(à1¼%ÓUîLâãh6jYù‹¹6ZùKû0Ù,Ž 8¼wtø‚|™×Ãq¢3±ZöO535 ÒLQë4à<%¢`Ì3VtÕ¹llP‘T&F^¢z_KPó~sÉŒ.–T0œÌN˜Ýäèp|ò³a¶öà©U1™Ã° Õa…¼VFJ BEÔ” ŽM¸<ŒM†oå¤UËœ­–¡cé ÷תƒ•T¤•{­ë™4ãWêv›˜:Ì‚€°-^¾'¿‘•\{$«ìª† ÛæòPÕ\ŒøS‡I}²#r *Åñ Ü`´5“rá=Ⱥ`s `ןãÀ1“.öêf¡uþÔE Ô7\´ˆ 6O!"YZåòC§"¼gÃ’X›»pâ¼H(Köv¼q³w «Ø$¤³{v„<´w²çÃ(&“ôA0^Ýé{÷Û“ƒßG$†…'&Á•ê/ ìè„‚Á{âWïMILt°Sá 5š•®–[ ÔŠ†Ý•vœ.ã\ºÜZ¼&ª×z½Ýf{}2jE]{óò.X€x@e›Ÿ­!và¨0$Pw}âÄá¢]4ØŒh,¼ yò4Ò|œi E‚Í€² îe¨»–Á# fáЯé tAðž€ðtÃåbŒS5 6ÞØŽË °#9‚ ‚”|³cÜÏ e‚â“ßúÖ!Xxƒ _ñ¥½ÄH®-ÊA6C0­UÏñÀI*-ä [yi|M¥o]\?&Ý?à"j˜s.ÆÖ‚çßÄ`öòK0Óù~šRp._¸À*/þ‹Ó }Ïà4"¦±ú‡œv™OÜçq ùbva€y~©Øb¥¹pŸ:0p0b ˆý¸>Ä–Šjk¢m£·:þN *„|—ogb½§“Ã1¾ü%AŒšû{ŽAKðÿ4†3û—ï2ãðKŽ™»ÏQé=ëàÇÌ–¦f§Û0§«åû‰¿: á.€~?Aâ›sÆÅpÜžuq&ãrœt®ŒÓø©s3þ ¥Ö_¾wa:пÝq`áýå6¾*\'1À^¾âùÉ9ÕÇs ìÇè°£wäß á6Xù} zGþÅI'úû Vþ¶ZºÂJ½‘Ü?íDîïyù_Ú«t©$ ?A¿Cû‘ *Õ}pÈæÈ€Á`¼0ì È —8FÄŒÿì³ofõQ% {6EwvV_f}•õóüõ°wÑkø–íK?²áíµõpóÉìž ·Å™ÅónƒáÀ×)._[7­e¾aáiç.…gMxúv篦x7 ~-tÛõ€Ò*id×Ú^·SõOx{½è½‡5«µì²ð}â/Ÿ«“ùëtgÂÕzþº.spÕ,Ÿ\Þ9ÚPmîŸtµ;py˜MSó’ŠÿgМ› kX÷íâ\ña±>ð…ßv?Úø–;s6_|Ød‘—CèêÊÜYçޗꇱç•Å©èCäy¥M°ß=ü{÷F vùÅ|ØfþU|Ø}õ€¼õ1ØîÀ 7”­Ö*a7öüÄÜ8Ÿ;¶x±³Ð^›÷ ²ÙÀfŸwoáu×›}Ÿ§±u ;—x?ù:‰Õ3û¿O‚—ÆýõÌQáå ¯«/5º³ï¦Ïú»­ÙeyÎpïhº•½/`ê]%þéî-e·¤/£ƒû‹ÿ·Å`O4_/y{˜‹®}²_œ]i}œè}]jŸÎ½ÊÛ}ýû•O.MUZÕÕv›×®:oòöÚïÊ2ñnÜ^Ç›uh @5}¬Ëñn#oüã=ÊŽ×Û5x:`ô“ªà×CÞtm¸ 6Ž»¢x:•Þ„/-ì—mo±OßÁë^#_{y@ýz¹ ”ærÅsxÉ”ºwH$û÷†Äxª^;ƒ¢ú«ÐYƒæÒÑdNG[ï®c:Ú¿!þÄâ_ýî‘¥ßÉ”'^<‘fÛó½g¼wó©éÉæmõô+PÅò§,†ò'ûðáÛçµxñÃ.x1÷½rîÊ{l„¸^·o=gad~Ì»\¸zÝo±©CÓ+(zN6Í·ÕÅ£ËùSpz»PÎt ÁßðÈBé,Ë9™­ìV-tÂÙ&¬þ<å©—­œIDì3É^Wß~l,}š½¡`g“fü‘âÊ.ÙÖ"tÉŸÿi&3@ŽmÆ:ËýÓ¯½¿K7'×½þ ©T@²Ó<Ü¢‚ê,ôÎÎûëݽû„¥Ù…?ü5.eܦ\)xQ(]?Nª^7eµtÐé4æïKç'ƒó›~÷þG:¢½õÝöR:fºÐI« í€6|ª¥P¾DØIh:ÿ{ÁÏ6üSâÀáàk-¡y,ðý¼|‚‡ ý•2šn¤¿Óô×n'†)âœdiSN”äéu"%R2™ÖuD:nR&Ñ–ë´®‰JªÔH¢ ã,”Úô$ÙIhŽÀZb@WR æ Ë×AÁ¿Ø1±4ŒHCMZÎA@Ã(e&ùõåòh5WœX«9$á(1Ò¹~Lˆºð'8%ÔR{‹eÂË®@û€q"xšýzÔ"=ˈ6Æ -vœ0ey¶xdUc¾òÌP{7qiµ–îý ž|áN *Ç"Ž¥%B•ÎghÆê|ÿ¦ï—6°“±‹¡¿hÚhÝ÷z»ýÓè"ÿÖ½îµû§½¿á±´±3¸¹ÿQxÚÀ…óýÁy÷ê¼ûçyÿ ¤3ÉhtOpñL,¿ÙfÙ^— `Ï(fÎ|µ õ¯c™&Z:—K,Ó.kRãœH±mÊ—“Ĭ`±%ìÅF‚$wë‚ Æ^éX,YG˜s&sU¼À’2–BÅ›Ïê$ùþ€ùÿ ð£ìSeDÁ~sº†fîQ¹º°0ô·}3è¢êý<³ Ä3»`¸ g„:§câŠe 0æ25ÌÃ.QddfSO<å†ùÒé!`SJå¡ ÊüáÊBõ„†ÃÁs†Éyæ¯|ÃUEHA¥ <Ë[A5BÚå‚(§<_GBM¸T:•@ÏÜì$ô Ø´œ$R[¢•‘–ÖDÆbS‘(w‰+ƒ0Ò¦‘1†{IÉØg!‚¥!´ (¬'Šù å0°wê°A4n•ëX!+ªRÁúV Á´`ŸFKNÁ áx=h1I€Eƒâ=÷…kr † .ƒ E¥oD÷¹V•ñ­2æÂÒXfOÛúp°¿4}»÷ _܃yqöÅ=¼|¥å3=àpE³Ãz;žQöS]ZÊúéNâå‘ðÊg#4ƒænh)œ’”‹2àO%ž›°_½ΩVy‰Ô^tƒ:'‰¥„1$(iu¶×àL†1Qf–¬²ÒÚ¥+h fHÆS0Ba?ƒmiaJ®`ç )ñ°™äÂfZ–cÐ`8³ä$LÎã©áŽcàƒÇHå™FÀi"óuyúRÃd©¥ò÷¢,‚ÚJËœpfmA`í(°X/G­IaUEä5`Ó  Ÿg.Bã‘\‡áøå|xÅx¼Ç“|Bç>R;ìßá$ÆZ—ý¤uÓ*V¬,]!ü5Ó†¥ieZiG™Všq¦•n”iÁR`ÚÂUÌ´Š2­’£L«ô8Ó‚ÖÓ‚¥¦ þ†1bÌðà€ Qú8ÿ)Ù£ü½H>.…ÏFà¨hy–uA˜£Àb½ ŒŽJã"("¯ j¥E†Ï!ã²Gr}*ÓŒ*G’kWú“v0ÛkI‡MF“Á¯úUp  ˆáŠÁMmTQ1î 4îXiOŒQÁÀsC-‹S; ¬þ±`‘^Q0´Æ¸ˆ V:ê…±Qáâzá5€[×k,Ñ_Ì 1ŒåœP`Í щÀˆæ„Œèü/Àˆ˜+ëñ±9¡#òЈæ„hN(Ðx$×'tï#™~ÚÃâ‰3´zñ)=wL‚ ñò.ø3]ŒÒAQY8¿5…‡ë¤UÐ ÙðÃAu-Q8@Gq8_” ôvइ†ô§ÄÜKI Õì«€]½N_ (à[8ør¶G&—p>*P®a³»Bßq¬Q(ÏEŒÃb8øZñ\þ_™›!F`ç›èõ>N¼ªŽž¦ñ®y)>‰•©Eºº¼ªª‰é©!E‰™9©E¼éʼne© ‰yyù%‰%©@…ô¢Ôb`°¦*gä—ƒD€Z`ÊUU]ýÝx –Ù½‰ endstream endobj 25 0 obj <>stream H‰ÌWënܸ~½ƒú#@ ¬‡ÝH£( kê6ŽØÞ" Š=¢Çj4ÒD'Þ§ïGqF3{“í¿Ø°%žóûá!õê/W×§qÙÞéSoA]çÕ«´Ójh»3w¢ºçu=öCgH¯ßŸ¸,XP€âs±ÜÕ]_µÍ™a±‰Yé×Y«ïjýä¾Uw'îëÐoª¡Öà¬ÛºÔÛëÕAžŠÀôçz‘•‚œs“OS4øÇò¦Çr89¼å4¦òfÕš#ÿÌ]>;d_8v?’ç0ò\ÐŽò›[C˜{3öÆtó´ÕÎG²ÝwYääJUEHªæ{ex:Ú&? $ß,&˜ÙˆC¥ê²º¿'t3ÑdÛµå¸Â˜¨ q0ê…$—½V®Ãd@0̦r™ŒˆÚBàëÎ )H¦kÜa8ówŒø›nÖÚå>5ཽ¼~Úܵõ’Øç6ÇKäü 3ljónëLWëzëM׎Ûóæ¾u^Û»ä ¶ƒÉÓåÝ1ép+Üo×c5h\·'ßU„­Ó®eBxZîŸ?–Îô=îUqKÍ›G]·Û#µ3ûÊý—ê¶?V}U«-2ÑgÍo+‰W 9:è>Ðþ„R\ ¶æhxÜ;÷ïŽXÂpÅ\ìgÝvù{Ç-íÇú®WæâѹI7öîMÛÖ³Úß³fí;òD5øŸÃÆÕ$Ð\66AÏ-íßZÂõó§³ô[ógÖž*îÓ¨Z½dàþlÉòþŸÆšF^ÕoýtD¹2#yUëë'ÜÅ6ßÓf²y_¢§évð¶ÝlÍ7©{ý ¶zÒ9<òzV˜æxÆžž~gø2ê&Íÿ9p¢ža6â‚è­ýZ=q¾Ycªs7)q¥§u_-“μ}µ„n€W:ñð¹°|‘—ôG2 tn>}žIÌà“lŽrïìËþ¿ÁQÚüâ~Àý®ýò‹{Ù)œUˆãe:”G6ž¿:”RF9õ¨OÒˆ *iLšÒŒæ´`”1Æ™Ç|àØŽpèJ³„¥,c9+8åŒsîqŸ<ä‘×<æ OyÆs^xÔc÷<Ï÷/ô"OxÒ‹½ÄK½Ì˽§>ó¹ïù¾ø¡ù—~ì'~êg~îN€ïÇ€^àAQ ðIYEHCòÐ ý0Ã0 E(Ã8LÂ4ÌÂ<,"±ˆG^äGAF‘‰HFq”Di”EyT*˜à¾D("!„±HD*2‘‹BRÉ$—žôe CI!¥Œe"S™É\NLcóØ‹ý8ˆÃ8ŠE,ã8Nâ4Îâ<.š°„'^â'A&Q"™ÄI’¤I–äI‘Ò”¥<õR? Ò0œT¤2Ó$MÓ,ÍÓ"£Ëxæe~dae"“ÎßP½¤€|-ib~bè…ß°ÂR{ìrX§qOrø“¯ÞIx)àkŸxî!æ * D•#¶1&ˆT"b¸CÄâ a’ŠùÉ‘¥ÔX…>‰Ü!½Èb€lúÂsX´Œ QTçHxŠÄ'H¿Îü„¨ ªŽúpÔ‰E4,PµµKQC¸‡j T5BmƒÐwPfåF/†ôìWÍŽã¸|‚ï|`÷bˆ”(ЋŢ~{ 2H.9 ™Î`Ig1™}ÿÔW¤dÉ–_\ßž¯m×Ö™—ñÎØË›ö÷nxþðó—÷>==M'âÓÇOÏÓ©ßýá·/¿~~:ü'Þþ^Îþǘö?à¡ÿ¨f®.o¹YTÜPjn9 w¤–{•î\=w´‘›‚áö§[aÅí±æ†©›gî§1÷‰žÛîÈÝÆä^Qr«vܺ=ûEj-7ù.÷ŒÉsî¹–1¡bépŒ>WÀxY@:ÆŽAk‹HÁ]Û²”L+:ÂðâYL†š–õ$2êô,)3xÁªbXW,RÅÒâ›j¶=æ¨ÀÓ²Åhé·´Í 9³l5&æ΂ã¤ÃMj;šèZvžÈÞÓ±ûôì?CŽû)¤°Â…ô\ÚŠ±Ñ¥1½¶Ý†DKÄŒŽè‰!cê)älÔØiæb+ö¬„:ÃϘŽ0£Íˆ3ÔE± Mf,vİKÁ,`W)$”3ª3¸ ÔðkÈü²¹7²úç§I‹6ë°Îl©¿>kÏPw5WSsrë(µ‘2³”+TXRW̺JªJ‚ª(¥IH-%”åCéL²qÔ ´"Kœe2R IU–…J"d-tYãÌþ2³>ñ½‘™ç]f÷˜Yø\e'ú&âÆLV’4“SII6J&¡Ï¤›ˆÖeNM2™'êùÉêÑ¢ÖE”».ô¦‡Ç¬®æfÕoØõ[êôUK šbhõÐÞˆþ‰Ù£Iš™øÕñ´h–ê6‘fA…«ušú±|Ô5]µGcU žæ¡íE}’†×UÛ¢ç$› –“šø :NFÇêÒÑÁ€<·vo¥SzZi_e$CËÔg«˜Å2ÚŒ8ƒŸ%øu:†æ0? ˜ì@OʪM¸Û!‹êI‹ÿÑã1àcÀÇ€wøÐâcÀÇ€ÿB‹FKêGô["õÓ²8ÔåÑ8æ»w-¶8Öè·?:jiN/ÒÝo+Šy¤ÛîÆ¸±—7í/îÝðüáç/hºOÏ_Ó‰øôñÓótê‡ÃwoûõéËáí?ÿöõ?¿ÿëßþôñùéë×§ïåÊ5|ZyˆôËíüc¦5Ù<É{ÓN¸Ð)×ÇÂÛppþˆt]ž¾é·oåòÝv¬±•Óu6Ǧ.ʃGïÍþÀûïØ?¸§rí¦{ÆŸžŸßÿãéÃác>u0x 'ñ!6-ÿÝEézMBG’ó’tQ‘ÖéTåhnFèE’‹ÑT‹¦R”*ÑTˆRJe¨aJ=(µ 37 ôaýIå§ÏÅÇäÒãrß ì:]ê9¹ã”ì75»Mê5è4Zh„mƲÉ8v˜†ý%²¹ ì,ÚWJ•š%°˜t¬$#‹ˆ–ŠÍà GËš¡õbd¡°ìŽ¡aCˆ,#¿aœ×¤^£Í5hZ-ªN‡f0 £ŒxZWGôÌK¢ÝMË”V–qGfƒE/*ýh‚]¡\¡ZÀME“ªjB³BX¡] NEõêVlYĆe!›0³S9$µ´ÊªÜ õS‰ó²êrëF·luçÝnîwó!=oÑôκ޵¶7<Ùhy#XÑcÝ"XÀÖ8°§‹ÌX #hÕc•#h@7Ú9 Uâ³ÌP`næÝákµøÚ®KE«°¨K^à™ ø¢žg‹ÇÝ€5ÈRK\+ÀÅ‹ÒA$-ÄÒ@45ÄSADb*¤¡¬ôˆPZ€â<”ç ÀJ4mFH³•"¤ Yé:H¸„”M(šÒîA¼©‡¦辆þ+ø€…~„7ôài„Wx†‡y8˜H 31¾¨G˜KNG˜M€éx˜ƒ •0#SâF¬g D¸U€ky¸—ƒ‹•p3ãŠjÄÚ÷PL„ÝØž‡ý9Ýš`‡¦*ÊOª‡º"ì2”À;kxh/µðÔÂŽx²=Äá·¾ëaÀF\Â-Ìôn„a·‡;y C7‰zÀjÃñ±$pÿ»>;‚aJ)V9åè7Ó9.‹²q›—I‰cy~±÷í\}Õ¦g«­]gñ)vJ¥§XQr—ûòÙynè%çzöå×g_7ûzsöµÎ¾\lÚé0 ØÊ3TgpKÿÔð;hvdzqöÄKÈÖɺ{!߸¡¿rÿ[þ—ä^7'àe>¥àœƒç$œ²pJÃ)§Dœ21R±0§h¬áXã±ä‘5$#& ³²¦eÍË1G«ž¹ÉY¡³Fh Ñ–Aºd˜®¨CuÍ`Ð!£ÍˆLkÂìpJã £0 ØÊ„ηz~ 9;ÑܰÙ>}Ú%dýïëñ?à$& ÚÔP é ujˆ¤…8T,vdK¶¤vE +a•›Ê@e˜rCמupî‚Sœ{à­-P¦ˆãÔOM0uÁ© ¦>˜aê„‘mE{!š¡vCa=Ô‚˜*bÅš¨EQ«¢–E­‹•QKcdqìr#ˆQ‘w?#ê%­ÍHúÖØeÔ3üŒfFX‡´§#®Ð] ß݆¬þoÇÞî-×7÷ûñ»h^ùÆåŸ–1ïöÃ\ƒ\¿|?^; =‡\žz>´Sn±fYû g«Ô6{^ÔÁšºÂ‹¢À.áµÍqá²þ›ùjÛ‘ã6¢_Ðÿб5x¿<ÎìÌ<+Ù0 Ca‚e9¶¡¡Hü÷9E²H6{z³›•LA«aM³ê°«NUñÑ;q%”å2)õl,›Z+ù©Ö7ÌQý¤+¦×®˜Ð¶ªWÌÿåhŸª_š«ãz¶N£õ%Ö¦q [³Ç‡àTj˜(½ïImÒÚkmZ.#§@~ÜÁÌA£äSIñÏñ” Ý1bŒ!zˆ‹6š¨iÚCáÎÊâ1 1„à!n 6ê3h§þâÏþ¹Až ‘žóÞ;o!Ækj1^zá…»¸3ä”êïÑüN.8<뜳C%õ#„K8a/ö 9¥²}´8ŠPÈ2=n­÷,Šþ%!‚•s†œ Ä3" 5OjŸÔ@©…æ&Jm”)µR4ÓÔN©¡RK=¥¶AÓãaJ½•»«O3orYº¬N=3uZ’Òms¿=¥Tz.„^p˜V7÷Þ±ûª{»oßyÕ©ëµ¹‡ú$®Hz5ÒÑEJ‡—ü)A\Äe¢?â\…ëèM•c•C'±J衟èO·;ˆÙˆ¾"÷ÜOZø†Ï4*îÿäå’Jv¾~Ärñ°¥FSpÄár8N˜%އÃ!‚I¾#¤Ztœb,Œ¼ÆÇSSŽ= U&c¢â¹§â”˜˜¹h )3z& C"¢KDdRö /‰„ áD]h`¡M,ÌT™ƒ+ fV´LÀ©2ð:ÿ;ä©'™zSå3ïØ˜·yÿí@¹iu•t[ÊÙåÖ„“Ó–o+º6t»F¶ŽjÓšk"Ú½$›˜eO¢ØÉÕ•oΟ¾ˆsçLjÅ\•B'V)užRVå¼Ê•=gWί–a9ǸÄçL˹–³­æÛT«=Wü¾æ¯³/ç_ËÁœ…ÜJ.Nªà/ É)Éw1YßÿeÕ¶w²›v'ÛÞÆÚMËWqC¯èûEK`=Õ¦Ñ7Ž.™»t¾ =会ÈKjO› ß6•>×·ÍeHûi'û¯7›½–Ó±bºÚîçǽ\yèÈþp¶<š\m˜Ÿ³ä1xׯýFã1Ñ<ýÑåwå–(„›ûí÷>vßð Åß^üãî›÷¿Ü}øåîçgϺ™¸ÿazñ;ý¢ó/ß¼þðá§÷w–o_ÿüñî5æãòîô‚Ì7s0‹´NÓÿ>JÀü˜ ÊrÖW¤åWøú+”Ÿf3?Ÿ¿ÿAÌo’þÕ·é¿bë]ZdKó-kã+UÙrÛï§Å]R|]@Œßð]Šù9þ3j>ÈYãýE¼4r(. µ µÇ9âÒ› –F5‡G<®;ÆàÚ‹Hg/ûÿJûáÜ9+±X¸HTTºiâ<ú¼Áž·ë ®°‘+Xt\œˆ¦Çb䢽¤ãñþ‹ñ jP¨X,°i¼ÀÑ爥¼çŠƒCï5Cq70Ü»:(.,ÖÓÝŒ·÷H¼YP+`F¨ypÈ8àHí˜nw¸îÉöå·>ô]ô¬Y´¡FÏÊEæ`Ö虸hgU ß‚kí‚&¡j½Äé«A]3`Ö÷AdHÄ©"Câ(Žqé!q,Çrt=BêbɈ8–QKFÄÁÔ*!e<ÒÁo i rÕ¨¨ä"¿Ö‹E„R®ÅŒ«¨¤_0‘à)XTº­ËËÿ‘¶ ‹S›P8¢öÂkÚ£#ôê3':¶ÁëÞOÕ,l£@óc94«Ý¢1¬ÎXTŒïÒ"½ës!ëO(šÕŠêS¬%*ü²¡"o&YUœòÖi½9 OPë€±Ž±ZdÆ®¶.¹ÙŸip«¢äŒàûáu¸úL9Û¨ëÎOÕ,õ”ëxžñœÁ/1(³:'ëø Á-¸¡ù¶Î9ß3èE¨ ë1ƒD­º)ëþ˜õ™r¶Q×ÍMU$ÕDA:ž†OéÒ«ž}ENVá½EeCÍøºîXÁ:f›`f±—ž}ΠBËøä™ Ë6ʺ÷Su Û(P‡ÃŒgìØÇ‹Šñ"Ô#6ª°ª‰÷‹êS¬%*|ÞÀÈ›IV§¼µ@@oÎÒ±¯¦è+g|]w¬¨ºÂ¶ÁÌb?=ûa}¦ Úàuç§ê –zÊ‚u<ÏxΞ}Œ‘u|Îùºn´¨ªÂœj¢0«ºéØÇë3åÕ¯››ª*Hª‰‚t< Ÿòþùf5cb V[šH¼0©ÃE ½Ûëš¶&DTaŒì†ˆb„Z6¸…¯¨µØìŒ¥±(*ê)"·òê±vëÕpÅ0‚D¡uÅ`ÆÓA0nqR˜«£cÀ8¤œqƒö‹1ÚtÓtÑS ÂÛE m+¬­·ªCáõ¤°W§)FÈ8* DÎíº9º¡h3Ëðj ÆŸ¨¥«ñIð¨vññ°\nu)BÃÝ…py¤C¤Z"n acÐàyØûh1"Ž#ê¢Å€8^ãXÛ#âx1"Ž×cî3 ‰cÇúØ1&ŽÞ8×ö˜8zŒ‰£·w¯y9óuö|÷¦\fóÅëþÚûìYV§[oÿÃôâwú%ä_Žï?þóïlç//~ú4—Å,¿˜Ä|À¿WŸ¦“H‰Còê,¾Â—_¡ú4›ùùüýb~CO~;=Ã/# ¿« åß–.³ÐxdND³ÜUcëmoçvºƒí¯§ìžêŠóóú„†dçNS(ŒjvÝ5vÕeÿíÆâíô¶ê,nMA‡Î‹ÅxÍí©ËþÛEö‚³{$·ß jĈfG]ŒÜ^·½q F9­Â蔈'‘íƒõ=u1r{ÝöÖ©CÌ­Ü8µ¨-Fn¬ï¨‹‘ÑiUNA<7o—J2ÚÝø¯«‹Ñ%kG-ÓšÍ1Õ¢µÙdÊžº}VõÛéË“œOu[(é(µ£oVÖ¬\\à¸Bí, ô¾ZÀ‹Ù@ÚW %ûse€»êfj¼ÜûÔи‘u=ü[•ôÂ"Zœ²¶Û“_ÜÉGSzuÖfdG]¼-?Ì\ÝóÙ©Z¬vrc¦©WXš‘u5’œ†¸xiÌxR¨…ˆ›—Ö©{,‘õú¤eGµqJ½-l°wê•õfdG=8EŽÚmœºER[6õÊz3²£œ¢H½}½˜æ¼ß¾Þ¦^YoFvÔƒSƒYA†SMÅ^mœ6õÊz3²£œªÅ9¹}½˜0mœ6õÊz3²£œÊEY¹ái‹5Ölœ6õÊz3²£xŠk0¾ÅAcž~ü¦^Ñ·ÙQwN¿|9½ÌC¦ºÕˆöÉM=mrûÝÕŽ¤gnOà;è* @2žÔñVm¬T:ÀÞÞ  Á‘=²¢©|$î`ì¯òºI©ÙþÚ¿þ÷—x!㸡þ¬æü´\ ºÜ´®cz½@þ (bº—¸€½ ýs9!ã`Rƒøgø$oÉ n¥ù1€W®$Í`âµ"PÃÍP;ÛHÈàýVà’,ÄÐ M }Ù³îê{\w¸Åמu‹oÊ®Eë]_rðãsIá}Óæ­èi2Ad[ÝíÔSÐ…²f‚±X¼ÞàIûª¡n‡K.t¼d|žxïm}?Gº9•È`¿7•ÃTλò!;Nø¥ Ž_Õ.OÎú-Þ‹‡dãqUwk]ȿ۷?¾üGMIQ±iæ_|P8ƒ,÷Í žŠRül8²¢¸4Rþ“4q—Qî݃/ÿüsàŸÅÈÃ]#CC«M®m¤qЦ–ß·x U|pdE/›ÂLê<«À¼\·dö©@Ø ì³ Z˜õ±;Ÿ]¨J}MâöúàUÂK?Z蜶Ù!>N¼BÎ÷#S Ž;µ@Ÿð³là~›þþ6|zä ¼u=Ø®ž ‚'ïËHb¬ßctóˆ¯ãj 0tG‚`zV°æ¿Ùÿ ï¸/Cè[5¾oÅ5Ù<¹öš„\:æýâ(VÎ<Šÿ›ßå^ºI™ƒßŠþ\nˆݽW¶[¤ØE{ÄEY¢±Ö"ˆd«;ÄÏ5÷½Æ¶ý¢.O6ÑX“Y©™95ìÍ‹˜³ÕÂ)’S1©ìU] Z’"ÿG˜ €`‘u]®9œö1fÁs¿L` 4_‡ —0¨cdæÑ®ãHMµU]jŽx³ÝZ7ƒÀ“'Ûàï]«ƒM§—¿w´pƒËû¤©2àkœÙ¥Ûø1wãe] ®uŽf*äñn¦ì\7¦Låu¯ŽIb?;‡Evýõhr¤ì’X^Û{a”æˆBdÌ J¼.•ÁäÏOLG9<ÀtîEœOpÙè†>MÞ€=üHË’åÚ<“ 6û`áo vÁñ±Å…‡æX—å½›k” ºwö °]‡°\óvÇ|aÓOÏàžË,5R[2YyeÀxý~–ÌJ`CÌZ7À°A¤0ó›ãnŒañá §~mXr vŽÄls1T„«HMž»2íÓë‘r˜.OC ú#ëß6-· Ö«à•áåfc~Ðùˆ #üp\)á\PÏ"%‚äª=´‚©¶ë·Ü(AkЃß?èL²¦+z¦>NÏM];ço°=X¨íÛÏCãQx_©^¸¨ÃBio²:62ت-€ÎÖîØ›n„íø}Ÿzš ×ðœI;3h£Êqu 圗H¸K¢Lêûಿ#Ù3mtæ‡Z‡˜OØb4G<$ù5áalæßºasœBiqG\$ü®Ìù6{õwI’ÁÙWg g$¥á°œÝ½‰M›ðF'¼–=[m-X7Á‘ ä†4è÷µ©ç^ÙÅÇë ̸‘àóHRM‚Ó_€2]HÞ­Ãiʘ‚ zyBIý gP¯c÷ùª³ ³¼ª‘ü±(RSLÿ §"«Åtža]†Oi®¾Y†;kTÐ ·¹6au»¶U”ÌKšË!€&[ ëÐmu°¯\¶ .E“`î¾ú5éL«äÂiQè7½Ä]O ñJúl:‹ˆ…®úÝÿé$[»ÏŒ„qhûýöÈÖµ¤=&áÚ 'BFÜ÷¢!37Þ°©“m³(ŽÇ;aªÁ‚T4ydÁLFÄ”sÁD€YkŸHùW ™[ êk¿ÑVX¡§R$,{2ý¦×˜ulŸÌä×|Tr îîÂɼtþº_!z ÔZÓˆji6ƒ›¢¤ØjrŠ;=QsßYX¨ÍHƒQaÞu ÊȺ)›÷£¬ôS€¬?¶æ¤Ç9³øòçÜËø¸,ârFÜA fÍMz*?5òSkÆÚ”Ï'üwjè‘Rv §%7ó/ e5¨÷xì“—C±à#ÚòÕId×ýp0‹ &ýHé € Â!‚ýt€ZyxƘ½èãRg“Ñ«”œ D…l;ñð«9:,„^>al•o|î?o°Ürk"o+†åá{î®'[ˆ¼‘î›A”¿Zõ¸ó¾Ÿmmqù*è®`Ì6HWGƒ‹MrJ¿WÀ:w©¹@úì2‘éP Ì.0Æ@­xK«z+ü–mò¡›ƒuj¡ >/õ×Ô°wðd£˵Nå‹ùTâÓ„¨ŒFÌ_$.ÓE¸ù«O4w<@íœÙ£DDÅ&bz¬]@Ä«ô¬~ª¶çnÐcwhh¾ÿjŠ‘Y0tÏd1}¿) 7ðÏŸÜ™Ðý $•Ù™—P)ÁP ;ƒÜ­PZ^´,P¹Hq´ õoO©gÜëxóü’ìQ„ÍÙÒ!gÞn#{CUE T-Y6ªÝ¯M=øƒ’-·àlÈ?¾ôo æÉœARÄý"ì6VuõÔQ49ûjè¾eÌ9F ÿC޳ÁÅâa|¼g­6˜ÓI¨)å 4PQEM_f«oœ½á**hrˆù<¡Wƒ»-é,Òï³½*Æè³ƒâ…@õÊÁžƒø55l›ž"«#¹Ó~Ñ€éÉzÀ·ÆfLò]àÙT[à»–‹[ZªcH6J /rÆFåÌã0¾ºÇd€1“$ž^7;–L½gQ¼¿µëhX‰Û¿ŸÕ#ø #v?T}°3@ºN¿:JÛzˆ”j…¯)à2Çé3Ê@„èÉfnNŒö¡-ð[FöDå ŒÒó'–·jýÔŒ˜á«T¸³Ï¢µäRvo %A…6.ð¼¹|kÜâbûôÇdL‚>©ÅÃs–c‚ìŽñï #.ü\ž ×Vö ŸÕÒÍ;pgGÇ]cDü95?_Î0¦Täg(ûé„·+Ï­\þê 0«'v\‰od—z'oœüÁ¤ƒ§NÁüõ:Ìÿ¨ôU1‘+œ¶ïs öá¼A/%õQ3‹L8ϺSø*æfgÝf—ՉඨkïÚã_ßû!±ëq7$õ/ž§ Ÿf>;ȸvOÇÄŠ’9±9¸ÌãRõ¼ugžÕê½óÌ ¢ú-î?•¾ñIÿxòì Ó6+ª`É5(“ŸZO~µgO‡väÙ/ÏýûÙMB=¿7ôLi%À9¦ÕX+9Æ÷y“àN¿ÿ¡»ÚuíÚmàÜp™ ŠzÖNé6Hz·I™ûý’3ÚÇyÀ€±AèpQ9Åe›í<èȧµuy%¸öÀaÂ8ÔbREq¶ÜF„[P§ÃȬxïý‚“‹‘Níço ŸÅÑ_Bº×½0ÓHôÀ- Úï§‘ÿÑš˜á_$zÏû¶åŸ ÷P¬–Úˆ³Ô£^Æ)‚è·MC8ÕµO GêztûÁ¼÷& Dø–Žº¸.¬-?†fÐV`6%m"ÁvúJ¿¥ œA*%˜ù Wh‡’­Ób!koN©<üTŸuØ[ÖA]6ÿ}}×L†ã!çŇî¥Ô ž#€HOëô]åÃ3UøÍã-R-ë"½‚T4i?ö|ðaFÈÞôj›9ïWA¨q£†‹¦¨‚1Tº¿zû˜LéÛ!xl¨±ï%²½ž¨‚}”Žô×Â+zyrºí7°ºYAðiçß“ÕF`¡%ÝÆƒÙ¡*iGbôÀnéì~¶ ^ o¦Ùô e¯¿ëϽ>?k2+¸N™½UÚ¹‚£•«[EŸú>~Ÿ gߩݶξ¬Kz,‚á¾SÐa³0T-ŽI2#î·ôX+£D -HÀö¯ {sA‚O³ vÈ}!³"xÌŸ<á8ÃÁ˜ÅÕç8ÏZŸ“ÁO¥ š@ÿŒjwTÛ¥oæ6^¡Ë¬ÚÈ —Þ‡¼Üi²âh/(É } þ.*r…ð˜,\ÏH»Ø. d¿<™rE"äçÙE;¡…Ä î”ªÎŸL}-Þ!Á™`\½8 #*SY±” ¶`µÇ"–$áí" ÀÚfPÔ4õ~í¾~“º3LtäT1^¨ì÷qãàçkx»É"1б•ÿ`oþL1Æ}³iÀgŸCª¯kCàÛì3I{ê¬ñfó 8¦ú–oB¿Î=üTš]må ©V¹¸…³±£F¦‰\“û<Â$Òô¯gתÖô·Û0-ƒÜüÚYM'¡ùàF¾BÎézƒy {â¾oE5‹°¬À€S«ÜøUô¹ØV]U·çšìàíSg¡¡_’FÝ7Ž÷2±`­0­×UU ^ËæðµÉ2Ù‚$Dö¥„mèe…èaÖVŒ/Ôö¡@zöCв‡]‹v(žË<4Ñ´×ïyóý>“sjÌÑÛöŸZç~úÝÇXU-Ò6Acc: ^±¥KCÃ[ð•Þ‡¶Y—Aûü6kÏÉ¡uÐ>þ\Ï®~A[~¸mL¶fî+툙Ëœz]vöe2ࣉÉm¡žçGçt ÖPF¾¨ÍWí—ú góÐ>XU«RøVΡÐN=ùúM¡-rß¡<»ä(eöÆs IĽüÓmóMéyo‹šŸ®ýÀ©ÛR8½`¥ºk™<é94bªÛë¶ÍÌ‹Ë~Qê½_9•x™?ïÿaÌ~µýõ·ûíüö÷¿Ñ½á¼—±¢®2¼k^“‚gKM#˜sËàÿso–Žì÷–Ê4à ¿ÞSíUN¯}üiàS>‚ûƒüÝÙ”`=ÍÔü°Úç‚«7ƒ`Ra ,oÊë„àò(ÖBn<ˆ/qä4JRIÆ™×äa{)¥ê×hU:Ú;OÞûÜ vWnÄ'z2%Î~Ç™ ÍbUƲªý<p®öTÃſ­ Ž5¤oHD¯ã”n @·­+ÄèV0uüg<~R ’)‘Ë-ñ=Ça_öh´Wÿ"gCÛXzȨ64Ù£VëgK1µ½6³®WVñUwÈ·ÔløØhä™ùÚ Õ`ïLм¶ÞŸvÞ pkL =Ú£zŸÁ‰ñb”9>»Ï"k¯{º"ÜC*\Q_g¨Ñ­¹» nÇmì%pA°J€±4Ä«5¸L+ÁU/d^N#‚3ÕŠ¸^‚’¨­_]³z[ ï\ëUVÁéJpïZÄÓ[ ‹{±‚Pk+ˆµ¥bòÚëÁ¶NòÙѯ0|î½E? ôì×®;~vЧ]…}$ÂdP]5ªõ˜žÞ ºQò† { naÝxò?*¸••z˜¯kYk¼ÂlçÝì¬Ã–¯¾¯ÎºpÚîåŠÕúþ\ẴiCg;ÛwL ­el_>ߟ‡Õä‚jäç#/¯µ¯àèÚ( {«Œþ2|À{<Ûa8ò’Kð6e¿œžL`Òz§™ߨöΣfÏ«¾1NàS» ih¨"8år> 5ŒI) ¥ÛRÍï¯j%àlœ!a´¾@_íb8Óך4Ñ¿BNßÅt^XôSb|8¡÷4BN•Ú ¶ž‚n;Æ¿G+ýÝC²â‹u[ÕdÇ%N€OàÇ_ý.ŒÜ^ëæk¥ÃÙÞNU•`®VË;bà#½‚ö5¨VqCcKïÕ„­ݵ—„\å†Äsø0¢÷ñÜ]ÄíÕ®Ø3÷¹hʶò¼³¸”Ï¢Ç$ÊŽÿIÕÂ!/—ù ¤m±UrºgKÙ-SVŸ›µúÄÃ=ªžÎ›{$d¡îiÆøI—>vŽQÚ¢ïN ¢×{@ô6“\ hÛ_5Ô±¸]™Ú¸ðU>þ¼zH\׈šÐ;àI›È*tÉŸ¨`œC\õr3„ep%X¸Íb­ëÛù±y„\Ã(ïàwfÆußüœ]7{ŠóeÂuK`îðªƒÃŒ$20V^÷ 8t þ·ÄKË9Т‚cCŽjLU»¶¨'µÑO^&H¨ZW¾.Z£ù:Ä‹j"DxE)D™B`Á?”o7jo{ê?=åw&Á5ãÑåªà#npt0ÿÊáÀ ú»h‚% $÷q9Á·¡p!ýN9 «ÖÂS¨áw6º²Ó×ä'´UKÌøEÇ{³®ó¨Úƒ©²¾ ¨?I×»lÉiD¬Í¥Ùùö«UûüúÓ¿~³o‰ì±L}ñ£©ÓÒ¹¡ÖùkøÃÚÌcŸ Tä bhg*‚¶7ñ±¹¤^„ƒ-*ÜK}Œ»u),úRA-övb)ÂùE²4¬àéJNDîXØE½¯ëé7ýÀ#Íe;{_xÖ#†óðÙv‰R¢cKMcfRèô•pMžºN˽§SëÇ] “©xº»åŽô^·OVÚ=O4÷I©¤•D÷ã‚ÈÎŽéøHúÚ×õáObª´½®!MXmã*ªrûB¶D?ßP·É1ÈsNÌ QT`s±–¾Êú&Õ1õžª'Óm7uïA~‹ÂG®ïç¶¹ÏO´q3€(”ødï‘1ìVe7z¯õ=†„ßcˆJòÁ½¬@/ð±\ZÍÆÕëÀS(·!F)ãÁHïQ~"w.ùÔlÉpY‚±‡¥¢ÉoÁ{sfŸ¬ç<öOQ~uÆøÞGÃ2ý€‘çÓƒíÀNÅw@uÅècõ"¨/Gy;n‹â ýüBžVéàˆ?À°7(ûC~ÃTXÂ^aš»ï°/o!K€­_µkõ$è*Aðì³^HŠß#Òùí\< Ö™GHÀÆr€—½1 >¤­'ÕdÂê‚‘_® 8µvî”ÊŸ¾î¶Ö…û­¶Ž ºAðl:2€{E®ð¯Vº ùC÷ Jç‚Y&áX¾F6ÎK2Ï«:iŽ÷s—{¾Ñî¹è¬MÍ6ó\*$Ö¿YÙ ~,…ƒ2V÷\ÂØà;2='µì÷ðOFø!®‚ŸCV%µüƈÇ^ØZ8_Àu‘}–/Š¡IXÊ>&°S”±sb¢Ô|/°qå¹°µö?À Hß#là‚'Æ…†J,›ïÑp4VĹBå{Ðï· Ô§ÿö3ìdhòj]÷5 98Vl2ÙVd¾,…qòWÈž¾€ß.CwŸñ3†®ìoÂî‚é›fàXMß®N0à ð&â}½m×4¿ƒ«óq¿pV£qŒÿ޽W™ßÇ–íXô"ƒxào·¹í??c{`ÓjÆ: ¸‰*ÖT¹ž9X çž¿¥X.÷‹Ã·Ü/ýç åÂì ™Q 0"ì¨ ú/_$30œvª¨­u3a›Déµ Ͻɨ³Ý]||jVï¯)<,¦¸š Ü+ˆWj,±% ´oÍæî•Ãö$ÂÝ`³Zz³]ÿ™„sÕ˜tw·%0æ Pñ첨_À×!;-ì, ±ž)ZÎÍg?ðj¥‘c%sÐghV‚XɪÀ6w%e·TÜÖi›€öÓæ ¢×yÏZ2=ÈëˆdŽIÖ:‚@§uµëÛÃ, !ËMƒÙ3oè-~ Um7Š~iuÂév»۠Ã$Åå¾ÊòÕ©^ØIGFf›ÇzKŸ—¡¯|º 5¸\rÎÉn9 ÇãJZ]ëÉDëU8ö½/È8ÀS';-¾¢Mœ0ao ÌÁoW·óÔã˜àsz»Õ×>è:Ö—ÆG/ª3[ÓQ ŽÒrdN#‡Ã4ô>_:“uƃj·;½vëX޲íðú ãÞm<ÔcåPZ_],c»&M5nSÁ×ìë¯/€©—hLlú6Ô˜Ü%‹å }pøõKµ9$}ÍÏñ>®Â¸ÖIñ€Íä<Üpêd1,ÒO? ÕÈ€õšj€]A‘¯¬×˜“3±Ý–/ömlf †M®kûÒ¨rh|pÀò—é~‹Ýâa0ú÷aÓXOÇPˆ'v€ªÖpbŽË¦¾ÞXéeÔÔ.󺋪‡÷9›b€ÕŽmÏ×°TÖuB8€¡$Oƒ¯º;aø‡~³X-äË×7wŽ êÔx×ÄÌ+ gÿC\èùIûëBÖRmOÙ…z`Ó;)^#ɼ‚v?ä$bóˆ„#€¸ËûÙ†J“ĶœÖc!p7;ê—xaª¯âa  ©WÇ™Kv³Ã®|Ií±aÊô%õù^g1ÏYŠž)mß÷¸^NFtãOu@ —Æå›Ù6 ý@‰¾ä@›3zÄUëà·0$'æÑ*êJQ¬¥_™ylP- Äõïðâßú=ªBäX¶’À¸Sá"ÃôK>—µÊ¤š„æ]z*OCf_¯ƒË´§¹“)–ϪeˆNê|)‚VÛI½)MV­ZÙM‹Î kËÊ÷Üì¸7,ô*ëÕf€hØ‚æWe4híØªÒý6ÂáÑÒæ"òøº_-u°™Àë©7ù`#õ逾«Ç;*Ÿ ºkÔ×dŒ†—©JÂQGq‡Ïõ¼Žš ÷oËèäe³qS^à2%¦i›@° ubûå×u3‡¾v‘8½}{Sü«©ÞÃcè/]/•AÐ[¡úªFpΘ¹á†v$ף̛ ÇkÎ!¸%¨Å8•ŽÓ•TDËû¿¾TZëSOÀ­9 ¶BhQï6´¨L4LY÷¸O£÷P¾¦5*Ÿ¯l£ëÛ_Iov˜Û/mº»É†™¥ÅÁþ¿+e7N-"X$i0ÈîÒÓé.6šË0Kƒ‚ì¾|Æ„Ľ: 0,CNì<`f s-:¡ÓnåÛÂ(Gb £8L¢–˜4舖K'ô )€-› Åk!VɽÊAg{nIQÇWD@(¢ÑÅOW¡X0ð]ñÖÈûÅ&€ë"!OïY>@®˜_"ñ•A•ÛÈï°K¡éÛÊÞ27á%3°èךW±p¼®5[k¬ŠÁ®=ßEãj•)üP¨òÊlÝh!Šv´Óõ®eM±N·¨|8ªDzi*YÒ—¸Ð\Èz¶Ñè[ån¾‡|¨ dx’›åd–fa¸¬/=w—Åñq'Í¢»ÊYR`g±ÑÔtæ>ËAô:Æîðp9“=ë ~o® ±=3>uÏÅâºóAþó‹p]¬#*ÚÙIþ3Š@4‡ ”¹ò›ŠÕ|‰ËùÔgÍA¤ŽÊì&ȼƒÅÊ‚/ÿ³†°ì™ùöUxRHŠð¹5šˆH\WUh(«ÐqÅ^âévv$ ˜i3‚`‚Ÿ¡gÕìs¾ùlßúA»™®¥}ÔGm……PE'Þj=~´ë2-V>7²lÍÎÖè¾æºWéóq¥ÜâŸZ1;ØyÕ£° é"hãh}„ZT0ÐP¬Þ×öä}"æBŽ­ŠÐð¸*ÍBlDÙrg匳 }¹Y伿¹ÁõMšpЕ Û ÆcS«ãS÷Ôî\DéoB¹Â¢.Éýó.$±ôdD¯G¿¼L#àºB\qDÓ®áü=Nœ‹?ƒ_߃™70´GgÊûÝ7‡[㢗ÁDɸc7E;Ü 15`ø~ú ü©)—:ú󦼞 @v ‰%µ&x.ƒ9ÄD¼´2ÞäåîkMÛê„à ö[`5kÓÞ{]ý@Ÿ¿þû«üõoIgí±º¹J:mÿïŸ>êœ/0ß&â2ã¤Õ)p°~ÃÁÿŸïj[±ìº_0ÿp^I ú_í& 'lL¦gœ ô<8vLþ>%©´öíœa0t—wKZkI¥*»e· /K9¨`tøN8Mo„Á8Ű$ëÜ>—z_pßìÖ.Òûë Ð!ÉYjný‘‡Á-N;¼X°inrÁ…à  hfUü %¥öƒ´¨='!\t DÊÉ’)_<¬—mµ ´ŸŸCåDÇFi}|>$½Äö¤àŽñàz7ø=û"}’^b{RhµYÚ%颃8Çø|Hz‰Í¤êÉôò1o ;VÿXvwQõxv[¼g\>±[wcEcqÓæU!+_è„e]—ÐVÜ”„Œš‰ €u¨808h¿C€r’c<U^GÊŒ6¢ŠZ€1Öt;Ÿ™Ü+ŽÍ4þG†Läå‹”žeßO°Ì{á2Ûy¯ ?Ã`gƒà}»À©9«mažÃäþ8ö5)vzñ’´›]:G3È9é‚ÏIÅŒrIŠ-UÒ¼D3È9é‚ÏI+„\Â9)Ö>dç%úSXƒœ“.øœ´˜18'Í&;ÎÑŸÀ rNºàsRÄ8ê%iÂŒ¦ºÂÔž†ÁÖáfàˆFKi›»àRÅã¾>W·²ªëãî!ƒNÃ÷uÕ=œŠ‰€È3 ,ãÁ¸ÓÀ—SݧSøþ¸Škyðs!mkÉïCK¼¥:Õ|KqúÕµ^³Y¾<—Aø\³me`"|äò&`ÚT›T•¡©¢0Jµ‘UÖ'Øõ±{敲*´NY5A?Þ¢5&J°LFŒÕì¾zYÏ åzÈM–ÛzÃ… ‹[vqí Q)´Ý\(pnv®„µêC?Õ ÀܬñQAl±Ùµ$L¥«xÐEE± b.Ö++àkIC†±]aˆ[Æ3§h…É`òBg ÇŽÃÔDkZTX¢‡í5ì¢êí©ê+ª3øJ‘ª¡mÂMšºqµŸ‘ÁëÅæÈ“¶ËN”×[EæqfÞÍþ3Þ£¶ú”$qH&õlg?´àü.Í¥Êsg÷£r*&ìÁR,i¼aüÉX¾Nwn|ç‘‚v¹Ä ðœSÞo/Ä jí¢ªåïdéÝÏôž8£‰ö:r±©ø4ÌìZÛß ÙàŸ6¼q^ ö¢ç˜Ýǯ÷UtŸ*ï…¬rYëbÑÀ>VCzd,öÄe1îýqºí-¹ P`í¯‰ëÃ-¢“`Hü¶BÝl¯‰Ãõ8w¯)Ñšïd]dyŸ„ÑZ_ [ã\ÍËe @Í¡åó@`?eÀTFĵ¶š^Ê•¿8áÇ©½àQ_'»¯*b¯Ü‘ ý»ªHÁ«3$ß’¹cÁ2Î’Í#Òºv»¨ðýƒ£¢A‡i`šÌAÍ$Äl‘¶°x>‚& %Œ•.¦Ã1îOçdžKºGþ±Šð™4a&í#ù‘ž)¼ïbæ†LK©†õ…Æývò±;xïK¯Ulå qlF¸yU'4·Pº¾x“$sÊÉ@ˆN¯¹OÝ0ƒ™?‡µÁ%@¶I¼TðW«¬àQZÊ»¾nEŸåpnÀ=û-uÑy¢¦ZÉFÀé’SJW¤µàíâvU[kE{NVWæäm¨P1°VH!ÂøÚ—Î …½|:³Ç¬ÍÇÒ¿<,Ê‹m(F÷Ü¡7K6KiE{`™*ÊšÔjg¯…œ=ÛÞ]Ù%™W=“#çâ;ðÍ«HC›àl™/Z›©·’1’‡æ~¹ÄÝÕqI·ÕQÐrŸh&ÙU´þ4ØR†©š§¦Ë€%Øû0´A ¸¤B8QaH. |;Šs|9C˜ìឨÄKO¬ÃoÞDEÁâè‰íhÑ`ÂTÌTS÷êÍÓlì æ†Ùé¾®Œ¿ªuDŸÅaµ˜ŠÎ¿dë4œ»&›Ûit 0ÚövÄ¢N§¼”#˜!l6QKÖ†@س“/0î;FÞ7Ôsä·Ív¸2#êþ¯~‹="{jÐeU4ZÕwÔ·Æ9«Æ]z·™¸¯«´¨úÚ§UBqOážýÅÜeÕévB‡pðSX]>ȱ„“$¿Ôá‹RŠ:,Ù–¶¶æ”l™@° ‚P {«Ò‚Ñ– oØü¶„V’Ò‹ù\g½–9$°‘å¯Zå­‚ñý²Ñhi4¿×PØ11Ÿji‚epJ{ì43R`›Õ7ug.ÈE®ˆI0ÄÎL]l¦÷q•ëq„á}ÜÇàRŠ38 Ž9s£¹Úfj¯=‰ Í«?Li>^Ty¾P}–!Xm¬Ó8i‰~‰*=ÿLè‘äë0ù8#ç\É]}[ý2X#2rËÕ)0ÄÕ² Ýïlçðí¶tO`VAÌX/sò6BƒåAÕÅÂ5(ÄbXîëÓjO_¤ãVïÄá\¼‡·2ÙžÀZ„W'ãšö‡|#àT/a6x/vAžÀÇý”¥¯r¹$UB—¤|ˆŽñª£=‚§—èÆI–Äoë¨åv¬"ØÌ¾<.Nªþí‡wÞýê«?Œ¿ÿþóǯüù?ÿüó÷?ýôéÇÏ~ýéÿú|€ýáóçïß>}¼åß¼ ·¯ðß7¿¼ûÿÂ-Þ‚þûæøåøá߀~¹•ÛŸnßý-Ü>Ê·y÷»<ÜÕ ª]Lgü?Ûåv CÑ ÜÁxØ&ì`â &îÿééƒÈ‡¿'Ð(í½ît0¬ø¥Î>|®¸£øˆîö2ÀZ7?yªk‹SÕýö€J àR¸«ìH/¼)ºÄ±ˆÍ(‡tâ—ÒªÍS õ¡îŠÕq«:ã6bBëÔ±VdBZZ¦zùÐhd endstream endobj 26 0 obj <>stream H‰„W9’e¹ <ÁÜ¡lE艀=cö9ä•©û $|µuËû•Å‚X &“·¿ÿú7;ÉËUôMƯ0ç·Uˆ68_b})Àe÷óÁ“ Ìúö °²FÁ3â9\ê2º‹_‹BaÁ‡T «ƒ¶„ïmâL/f¹f…Þ à×4לnÙfè‰Ð‘ ûCÁx_‚1gWÑðÆØµ°“‘ã™gR[ÂéOåaÃn°`£Ø5ÁÇ&–„= ›»÷۬΢ÍXOÁÙðþ~juCú5Tñ€äÝǯ qœ‚úÈÓ,îjnbFFu—Åìç2æ“&Ë3ªyÃ^ÏÝpÖH™Í¹!|œÈŽÍ ^xÒ˜ƒ%Hs!ŠýžJ[z“-n ÎY&å°qÁš|+Pƒá³ŽCmu²|H‰ª6¼†4œWàìòz†vþàAW¿|òª×ö«Š’œUÐ3Eã¤È_9=»n¯QDõÁ¯üŠ¨Í™± #ký>̘범.g)–Üì'ì•yP#<7(P¼ßÓó«%›Òt@ZpåíÀ Æ„f Ž– ¥[ËÄlÕ·Noý`÷ïçÂaø‡Ìf°ß_¨Ñ:Uéè S´‰ˆ·í>¼d>@ÆÃ2Õï ÇlŽmZ!ëJÄŸè$Ÿq (ó}Wê¸à«yí‹_ÃøøÌàÍ?Κ§£Sÿoñu'[ö[ÁÙ‚rÇ aŒò(õöýº&ÈìÓë1‡\²Á(œã5šÆ~ ­@)žaÀSÞ7¿&lR÷œàÕd ®U‘ŽF¿c86ðÜ#ÌVz3Ý:]V±gͽRż¤ŽßfþzÎzIyUVO¼šê[fÀp•¬Ú¨öçvf×Ü+]P¿Ê14 æ˜5NHLi°:¬ dÎøl_Û9;Cb«¤y:+RÉ›øA)í]f%ú,:"Á^ŒRn;*,íÀ^`åœÝ³‡©/£óݹµlW©v‡ö`¬ª¢„)gg1I‚sX[µ$î«.QÆnŸr¬V¬_0;«Ó…–û(‚8kÕ)PJk쇥·×l'œõV!äï©«­Êj³’Êóm©¶„Í'†JžÍâÇõYؤÇèÒÒ%`gÛvåÚ¥–-™£½¢j˜ v S ŠfÃé­w,®û]ïª}V¦£`ëï±W»þ6ßL}O`aËÌ „ /F‹½çù ¨¬%fàÂÄ=ȸë¥k.Ùì´¬Æm‡tgåÿ´&óf Vó»Û¶À€{ÎÕ$Ó Ê·ýû¨ >:°eì7ÑŸ©'†aeÝŽrÒP©þµFï?'±íÀ@ó&,X‹´v@ü> ¯î¡&ë~ uªö g-Ž®¶±sÑ Í‡cØWO+Å´ÚÁb8ÐËÁ«* ÌõaZ‰‡ö°½ÓÊpYöBNÉž!a˜ÀG%ÝqáÚáfÈàÔ_%BΊÓcËD¨<øVæZM€6¡#y/ˆú90$ðìÞÍú·8ué"ΖkmùLÁüñì2_:î×e`GãÚé¹÷Fí¢¤­…b«$üh\)p±ÀV¥YFXMsÂv™bÃAº½Œ›û‡³·Œ§TîáØlN4!!Cg{0{¥„ÅUR#µElÀ±³›¨Ãzé%âdÈ£lÍzc8"Vkøï³c>àDdi¦ œµ¶àÉWFûDd{:n ¬’Òã×*ºµÙºzôÅc€{¹ØàúáÕŽíJŽÃVÐ{¸ñsôÿķÛvoàÅgÿŠËvùug>°Š¢$óŽKì«ÒŠnÍ'-šÍ¼«®£•ùÉ0ÇÕÇÏõIèIî y›è¦ÊLÇõÒcÚøíÅ¡—½ÝIž× @ZhigµÁç ³YÂó›«=ʰr¸0ãµù}ŠËnr…`—6AâûxãÊæÂ°VÖVØÖ¢çF’j7 SFxòÆe²Õ¯•`ÌkFLaQ›+Ï éZ:}Fصͪ¨9>OÓe ° ¦Üj¶ª\i÷ÐS»ñºŽh)ü,K>·­ßióûèi°²¢dƒ7jR{ëQ%vÇŒb\Ô’Æ)ã‚È`tµÇzb³<´ºL7¸¨ãÊ„¯‹§‘rNyé’W‚ö žXsÙ˜½dÎÈJÍ®¦ ÍN~‡’[ŒzkøÂÓÆã‰$nåªOœð <ÚÖ±ËfAM»ðÜ_) ´. lqì׸G<þ²(µÀL…H¤§‡`áî…0u¿'€Ë«ÕÀâ¾Íe0ç€+wQ€Qß2 ýÝ»½îÍéó¤6 „fÙ¶¹ë‡ð6³ëpr÷b!,"Áþõ1¬öK®øczÕýúv·x¸aýáêdµæpñÐxã·!±îa¹_m(¶#é|·xõ-fƒÁË?‚é/Sô¯­rmᆎ•Å×÷çíèm:Új¡ñÎ…$dúZ=mýèç±B8` (—LhÉÊ\Дþù×çC1Ý8Üv¿^£Úüé×ÖÀ—Áy îºöšÑëĦ03ÙŽ ± =†1£Æ÷e}_|üôlÓâ-økë¼óG³²|Ž0}°æ,c-wÀ^¤ó 2î©o®-6îyj×=]¥Õíæ[¬–Xhm8<ü9Z¾bhŽÏ[¦°Åïay֤ϳæÚløƒðhþÒËŒ;éoNÎÞ°! µë$Ô[Øï¸úeu†]ýL••ydˆ ‹­øHÁÁZ§[Ð-¸Îø®ïòm{5¸›kvAKf–pµÒlå &˜]Ê $_ØËø­Å³ vþù¼Ÿ£@(ö±° Î\ìiœ“`ºÕbúá§™gQ€µn}²ÅmmõÙ2ÇÀiQé-€;À{¼¡60³&ò׉üÌ;Øæ`.â1K¨‰Fb 6 àäÚx,×Fg–ú —¯{zÀÃéÂöêg‡’}+û« Ù'2ЈSý°(-‡G\ÄJ3V±ú\K *o;!8XÆuoÛ=yR=…Ù)¼BÝžZš=¼Bõù˦:³^S]é.d÷¸—(·áU]ø·õKT1¦lÁœX ¬ã¾Æå†CU‰gÒ*7<ðhÊÚ»æ€>5Y+Ñ÷¯iwfœµ3ß×^àsÔ— ”šUO£cìYÃßWØÓS]ÛýÕÇNz:NÑõ4‘ŸáN? 4asåyOàùÒœÀö³…|†KŽÃ%˜¶àÓ‰oŸ?­íSwÎÁñ¾¿¼fF£7Jß™k‚·t6'×ÎaÝ]h ’‘Âß\[P5„I /k¡3 ð¶™²¨¡0Ãeëñþ 6'<]ä „Âì>ŒØ›Ú†”^øC\ù·µöpBÇŸ—Û[ãÉ6û`à´2¦§?·á`†! X»ü›]L§Õ‡feZµ#Ëçþú˜ÁS½vMTÐv–ƒ˜Œ;˜‹Úî° ÁUØ p;íë×Z{1S"¤Áµ¨õwm{2ëðˆË#`Ìit"ÝÜà,DÇ9œa”¥¦F4 2îXOsù\'ƒöìry¾÷úi>RÌY`\ù-+>q6L0‡ã{„—cÛŒ‘ì}3©°îFä›_Ë–"hòâëÓ/¼Ç£,½æ\â°ÖŒoÆ;Ù¢öÁ“Av;A ‚Ö"Å­áñp©¸¢U8ÜÞæé¹VØbY»—ø|V­dŸ5û5 ^G­¥Æmë­3ó<&˜Û,ê?ÀQ¦äǤͿ†;›nʱÖdðGA³Äjí<~Y¢£ -[°šNÐ`Ÿ–ÁŠ«»÷¸ \·Û¢•Þu¿U›õ­Sä4JÄ}ËWÂQþ[ª,T#§¸ÕªV¨ŽUF0¬4‚ JMã Upml ùùQE»ÀžÇ¸äÍ®îÓíKV=¹½|ÏÿªiàŠÔKÔt o8fš"¦œ« £[µß³U1÷åkgQM—´ +è[ßqá2(Æ£«Æ•gê†õI'N©žær۲όNï×gC-‚õδ·G°shÁVm·0kbb‡¾¸Y$'Õîý:"GˆÓ€%ƒrpÀ½ÎI kë|êZÏÀRûÏÿþÈ_²ö–\kô¾ÅEWB¢h¸Ö– :×Ìæ¯œm[; ÷Ýä{[{m–Ùµ%&'Ððœ z`Ø=ƒweSŠ^wtôÄA™VA(@_iÝÖvZjÛì)êfUa”x °3›sh-Ì2`N’Ø,Ìj¶§ï÷”ˆäåM¿Ð%Í•¨£‘×"¸‡Ài=æZØqpw®_Ö"òÑgxspÕÂ×ø_ßã]è˜SË•K+f Í Šù„/ j¨²ÀµMk{Œ*M ­À£V×W‡kŸS’€ÛöÚ0Ò‘Á/+JfX}sõÚÞ*±8!twÜ.5jf›E2Œ°C°²_ÍŒa×±œ¶\ ç`Sebp ЛˆÈíIJ1AvÄIŸ†R¹.3\jUú¬ 5Y”Ì™pIUçÚY aºÀ‘¤Í-åTÞ¦•›žlm³La³†ÂvRsi®NB;Ù¹U]áË7¤™‡À‹U¿€m©jÕâû*H2‹€k‘mÓ›q¿ôÝdTX‘9x_è_žl×pŸ±îm¹UŸ}\¸fPÔ€ }¹éWÖ!ÃÑIr¶QVÓ5X‹8À,~X;×fªÿg»ZŽ‹q\“J—¨%çê,&ÿÚݵ7,ñQü€à=®®k]X§öÜà-Ý¿íò>ìçÙ‰Є8NF'c¯I³Æw¶ø‡¨d1âz‡ÓÂ¥.˜¹ô¸~„#h\a‰^znŒÙá~»êk¤X¸¯[ÛÙ™D€[òl„O»h»öÍsë‘Qͽ–Ò'½Ä«Ùአx-yÐv.b’’cV¹ ,–Fì|êFÀ÷h®8Ùóžjj¼{Á}·ë±C%w#Ñ߹Ɠ5«®§\覊õ.Ù‰ë³ö^ŠÆÛZµG…%Àï÷kÞfˆ§të yþ!,·VXšøŽ¥'öi·KÀ, ¦²« /]gïª)|_ƒ<Ø Ñ‹_¿ú£Í{Z×&×ßTx69UF°ø®û{7êH. y¿)‰ív‚»9Å壖[Bôî• 8º|åÖøÀešÖ§+½6Z4[«È>MsÜߨÀ6Uª7ÄÁº}‰P±€Ê.øôÉòÌÙ SC0™ ddhƒz>Ö÷ߌô>64E· »MË–Œï}Ô´$ËØ0C¿*¯¨£‡Õ‡¤‡(Ñ oÝ2Šzþlu(‹ë¤zHW»Ëƒ‹&ÑÓ=¸pf‰  4N»ŠöY4`íÏØsü¤,AD™ázJ#@¨þ¢®ÚŸ|5ÛÇ}, ö’%ÙµAmZ¿I°^¬Œ³;ïǨ’ÆTiX¬b.6BñþoÂ_§%دâ}Ìd ï¥ò´º®}7D²9Oz¥ Í5 ^“@óÈL•%Éô5Ïî¡tµSNÓ¾ŠÊÅK,äâ…Ï$S†e J O΃”ÿý'áq«^•Áó[ðuá¿?/ý/ï·ÇeÂ(ºßlxøôtr ø¼«9^Z_F3=&êµÝ¶î/¯núÕÁ±Û9½8þPh:•¬Ý¤ÒŽZa ¢ÛuWRTŒ–oêA°ÚQ¬­N_¢^)Ouq9 §’ lŽ#.d<âͧ#ÿËû³uƒD r·»)ð™êöÚ¹Mt©ë½-h.P8¾âôÙN³­ uv;°Îø¤=ãþŽW]°„Ñ¡wOÕ ç”íEûòýÈE%°{ò;Îâ<;©«zñ;À¶Oz̵4°c ®„_ÃåÙNh| Û¯wís¦"À Çnéi`×ýÆB(ýÞºßfʧ^“ß ©|ð­mÒâ¢W.±­=v·àèÝ ªq¯Œ ˜¥†´n ú·Ì@q³5g­˜Ø—¢,NS«1½–úËB‰õâêµ(¬³w=‹:"•Â{~ cÀ‡}ïs¨½94èÿ¤8• ”0R_½Ðví ù­O ¾ÉkÓÅáÝÆìsý÷›Ôü ¡ÉX¬YÂÆ…$ÂM% žK£ ûѬè)³˜TAo‹pÊù½.Å=> wÆÅÆ…Y ÆC©Eç>m3´q©|#Ö¶¾<ù2“Ç´L»ƒÛ@+¦ƒNµ©Ý êGnÚ³Zª„üX/$ ­6˵?Me°·2p@·üXÛ:+)14¹!ÉÀÚ^µD‰¨Ãû¢SÛ(%†oŽõ]aÏ1|×Ý;^p.ï«gáILNÝ¢æÝómq« óµÆJ0º£1OFS§Àt’ßÊU3@çR‡u†`û°^zÄ#s4ùy°#à®ÜÚ‘G±6B-T–l¢e¾æ2rnìS“x¢:Á×RùÔ»õª—‹Ž´nž½SüÐÎ{¯þöò­8UÖ<=pœ5ñF[ǺjC«ë·ˆ· Ö•ÿQ»îný—Üßë“éøC_?óþÃǞؓK¼å»  ­ð`æçzí¹ÑòUÅ1®3ú΂³–/²sfaÆ=жU ¡¥* ܧι)ÅL)'¥¯~Ú0ή#â;ýÈ€Ä,jc=&y`ßí’"Ÿa|HIz‘†rЛJ«dLÀc_¶ ´Ú‹á9ÙÝ æê ‡bçc©Æ$u=—;¹eüÕqÒ6+®vŸ€ûXÕ^o(øÖŒôà>† Ð"‹™÷YZß&»3 ì*ðÃwaNÍŠ©æºîèlßÜ †Vòò!ᩃ²:rxø4fÆÀŽ[ÁLò·÷4°B ²ˆŠÎ°ú[>l1cp62Ĩ@¿ÎÁç¿E+ ô¬¢üX«³3¤èßaÅ<¬lï;VÀ 6UÑ̳Ðc[¬ ^v‚u²ò»&V& ‘ Þé³þñá/¹¬&h÷ÿ±;¶¦²¯Å£àaž¶Ã¼Î˜y¿åb˜)<=9ã“¡¥Ñh¿,¬ó˜_×mec,ä^÷®soYàC|éI$ÿßHÍOE‰*.O>»Á¢‰6wÝ~^oW·¯YFÞ÷uäÂ8Ù;÷E€ûEs%8bx×ÃÐ; °a,ÕþEÁ¡ÚÏ“U0±Æ,KôÆŽ¡wA^Â1+/&;é÷4&7}sòQÔrãÓ&‡=@ï)!žÖ­ªµ«·±NTÚ>¤m³Úæš_N¡…F’‹Yí¬w/¨H¦6†>VƒÁ=¸O‚rí%؃ìµvÉ;\‘“õÎù} ðÜ3¾B߃àÄÝy[–A×Û[F x1ZµFìgÏ¢/„385ü;lUO«‡pÁéA{îâ/óAŒÀQ¬RĦ‹vWìrvG’áMH?±”ÃÙÒfµ”½˜nƒHàj2ýšI™ §„BZ§féYÄ»8ªí-ÖlI’ÏÝóZïcøt–©å?M£„æÿ,/µ ê‘UHÑWî4JÉÁƒrX¥gXí>·½Ek)_C)ã$˜B÷å{á&yã"SzªôXï] ¨ÏOÎ}AÅváíHïR¶ˆ«Å…³nª÷åzô›n?#Aqc£Ýs’ˆ`_ÁRª1X‰tóÄóx£Ø²rB!(Å‘È).ße@’tˆñ9‘`5!Ä«18÷Ðt˜ tº´©|ÙµlžS¾›ï“g:qÊ^NwUòÍ…ÞíìÄ礯èûDŠ‘0>ƒß<ØÓ  UÝE¸-NÛƒðµ91ù%ˆÁ‡*à¿Ê €q‡7S^TM^roâb½T&Ø#$ÙtÓ(¹ý–lŽÏ–Ϋ3¿ ‰ñQКÆc£'8Mö)MS{¤­QDô‘YçšF›LËeùHa$ ìE @_£2M+Xë­22|G0ÎJ˜B|œØGŸva_±¨Q0[â2O«¤Cõ&—NzØßÒÎíòÎ6Xn4¦™ø… ‡ñ`s^‚Þ“àò²w¹cÉTZ Uš†ÑÅ»×1M¬êÃMÀÞZðÈt·¥'\ ¥ª¡Óû·sš™2à˜]¥A\F‹£¼OÙÁ=4^l'çÔ]€¡Ì(Û^A˜[þ\òÜeQaæ–Ìiߟ«ã®‡ #jAp,e]cëd—ŒöÂ\žA¸g$ú0Á‹;ÉX»áVúác·ƒí ®Ysä s"tÕ™Ã!~ª·˜ä†«¼Þ7u²|ÆsI-`h® H€â†r$JtãmîR~žìôÐâÓpãm#d‘þ6‡Ó„–÷Z‡ÑsDpGxcÓå /àÓµq‰§ß?-Þv€ù·€”-y~ÞŽ@ŒÆ)æÝ#m½"7hêNÉŒ tµ `å*Ã3i 8ºDpaxq Á¾†7çœø˜"°v½zû"XMfàY2ÏÅÒVaxň«½§h n]ÒÆI'ÐHéPB!/¥šŸu¢Š}r’à:Æul#»Ð>ĽKÕe!H{Ϫ»é­g ºß†¯M÷ŠoÝ쨸ÂÓ*‡n¨6ÃÅvöq‰ ¯òŒ“í¼žCAñ¥rhÐóÒ17H¾Ø²#—Œ5Ó%þ«pŠàˆ™vª8¶³ çtaÕ§ŒËTÛž'»‚«ç ³_}ïMXGPY4³¶Ôæ&ŽWåËùùõ-¾º  ?OŽïESíOT_;jµüK DY€{µtÝk]' M™í=ð­Ha\¦ÿ‡¿/Uºa8?#hçC,…ÜhŽñJpûzx˜C»‚¾ï½Ì;*•ƒÏqºpºLiÓIÞG°/Qñˆ.©è& êA*È©Õ$RÀ2ƒF~ šân—åâ2î轪<˜:ÛV^K-7½?wV~ꡞû¤O9£½*¤X¼8¡°=‚ÝA†ÆEŽm˜±xþ9›|ÄÙudzœmkü”q08ô©éT Ì6ÏB…èm± ÞR "†E<¾j+.Q†Ÿ7„Õ‡é0×Úšñš"¡,Ë/¢‹[Zµaœ.z¤#»Ã(üÜ%†írX[& a<–픥VJ~7>±ò„Þ›/ìÀÙÔŠ›ªÒ ’Z¥ë˜;VA˜CNb™2Yv¬Ä›ÃØÃ%å}g ´ ŽRa08ëN”l8¤Àl2‹j®²å$¨©nN¼†ä—»‹›ƒð:-‰¹Œ¡MS·š®Kºº˜&|'Úû–\ÇéM  ¯dE|¾U±rÒ`¬9bÖ8öù\H­Õ‰ 묓=«&¼ã¬QQ¡ŒÈò¿8ùzvIH &½'8ö6g%Páâi:¶·I vÏÒàOž½‚&Tø†`Oi~IJ 4ÛèÔs»àç2¾Ë§5Øi}Џ“‰†ã"Ÿ»Õ[ð cƒÅrÊÒâùŠäŽÉúŽ”-õ·^]ʤRìýS‚Ë´!ˆ¬äe»”"öX·‚Ÿ¤<èøÿ|ÁIÒÞÖµdÝo@prd>O0÷·,×tdÿcXæ §Ùî%aQ”c!L@'ËPªäŒh{#•„>´žYÁ>SÌ©x¦î;˜4Ü`,ýè™¶¼>Æs;Ö¦3ç%RžëwÁôó~ çsöC^› ôÔÒlÔÇ+# #Qb¬D H/í(d6øÚSîÿ®vŽØ¸NÝx6é/_Þ8ÙL,ÿ¤ÂìÊšº…«5½îÞÙƒÆQ p„þYzÆ´l¼‰¤b|s³°½J°5¤%×G—š~`gy1*Ë+]ŠàvÝ¿ŸIOÐ{mqûdèì£0kkÄ:|*3þTZо&êÔ21l Ná×>2dÞ$–2\:{Rœ—N¤ŒŸºVÏE45FŠ”&-&¼5^d¨6^‚sXÙÓ쿿߀^¯ê¾+ÿppžM&ÅdL£œÖU–±Ic$д\±óú~qâÜ9•Í YR³ìª8îÿ1\Rhm±yMù†áOö¬X¹?ÓU%~öbi² 3Æ«WÆ4q'˜ëþ~œ’°yCKêáÓêGj),À_-¤‚@·µ1^¶ß"ŽóuN‰Jz@÷xQÛ&—³2ë¦sÃxõ€Jÿ~—о&I_;](8|Ö“Z5ÉðçãQ¥oìxí?c'i9çH´' q™ˆw8‹Š¦m+à…yÛªù9k~s~ÌÒbÌ®‚·÷gG†«ç*ÌU Äd.>‚!‡ç’Á¸/¸;jR{ÜÇ<2#®Ï"XGjß½L0EÇÒr€£Ûàxà[5X[¶œ‘O€hR-&×okñºfWÐ…g$èûõ¬f l²éÎËšÚ¶C’xÓ»úõΠhÍšæãÿlWÉ•%7 ‹À9LÚ¨åìkŸ€óÏÁ P5ó|ûVQD>Û©Ueq¹fÓ?/8ØÍø=©`÷&#ý03g1†à.ŠáÙ’JV³ó(ö/|•eÂÞЫ(€ú’y˜†™\,NfÛSc@ùôˆ£Ôpâ¥4U?Yˆƒxn×ÀÀÙåuyÏ‚7e s¾žÜ4G÷êØŠ~ÉÀHªè–0šôÀ2òDBR *¼ãû&¥‚h0³ãŠ—ýáP¥£'W=?éÿORŠïzThïwÕ(v>³ ÕÐ=#()™}E ­° 0óíî¶JÕ|n Lw 0èìygáÕù]&áäL®´ìQ‡GvÈYCFoê»P{Ýÿß$ï·fqß¹êbÏ1ðEƒ^Fr_šˆrK 6’wÕP¶%M9¬Cz*õP‰hÜUW£¯Ã4˜ú]zéÕÊÍÍá!—»ïb5¡£¯§øe¼Ç·&ݦ…'ååã…¿¯%ÒË߬¨Þ]ìÑè?í[£‡¹:?}^dô]ÖÄ&åÓ'ÒU&Ò:¡NpòêèW°ñ30 ܬð]‘z9•,Xí…ÎœŠƒNËMj£õ <Ógž÷ù"‘Ö í—îÙ¥9Û¹õ†£XO Ïè›kc¬¾^S;E¸ ¢¼ ¡Å!ëÕ¯sž$f/¡çqvÖ© —R úc|Ú* `á#e®§¶¼þ)ISáìÒλZÑ£n'‰ùîä¬pOS«µ löÞÄIðhð»+ˆÏRåÀ^‹)8$F€wŒ›NYi ¹¨Œt‘„Vð ³UG‚9ËÖP—}j1Ãi–O@„Áq4dÁp# ˜«¸ð`kFvß(–Ê«˜ì–“ ÃñÐ{D9 LÍÞÞcU‹J6Vrw ÇGtë¶nU [’°Êèø‚¸xVC „WªÜ2 ÑãZªæËæ´?©`ÕE–ÁSs%šûÅVbøD"”Ú‘,ÉÐ\oãû¼"ÿIú[ÌÎ ø[x¥Ñ=‘Sƒ«õ|AÑ {×9«usÇÀ,š–XÜßêmä2^¸>ùÜiñ‚ædÏ·&G·¬¯\üòظ»ì`c´ï¤ \ZÞÌ8.«IhzVÈ#·ç‘â”ZK”ˆÕ²mé: ÉŠŒZÿ£ñðý%ïÜx÷6äwH­ˆÕ5¦Ñš^”T·S‘q'×Ñ a«Ëzi@õB‰ú‹ÎmIt8±y¦Žôâªüz‹pPŸ7¯¨cqr-yàp[dúIQÒn°Çm×JÐN§k“š0Çšƒœ5ÉÇÁ2šVeàêª ×ìR £(X¶î-Co3Vb²ß“Ÿªs&Šúh!L~Û:Upd.¥tóQ"+=­¤¤:0Ô¯â=ySwåÒÞô‚Õ™E_?£cL½`ÔCS- pŽàꟌkb»Î>-Ÿu%+_PT¶4zT‡5 ®[¼zuñ®]©W–EkmµÇÞòj®• :šÝøXNQƒ"’•žîGô¸€'ŸââzlÖ€3=·©1 êê|ÂÈU×ç-¸ÑA‹¦Ë1ìªþÂ^bÔ˃½c‡× • ¡N2Á¯µFUb(¡ MÐf“¼ØQþäE}®ÈŸä–˜ƒ$·£ïñóØT­þU l€¾ãÉ¯Ó Ï–'zÚ ¯®|‘d蘀áÕ*õ=¬ÌØhý†¡h§òYÑW'x›H£f­B»£¶?µK¥ùSZä ÉÈÍÍG E Îúµ,™¾Y\Gº«§hÁcÞÞãecj­0^(£m<[Ö¨Up¯'´|ÂÚ)DÊQ­ž•ØÏ€û1y06Kæ˜mí`ž’x®§)×Þ©ê\.x5ÝûŠAŒô|‡¾•­ W“YmTEakæbp_'^¦©_zcö!‰‚Jì'FK€cGÕ¸b>–4FpÖ¥üᕽ}º8èETi¢¸ pr :þéÞÆ³ÙæbÔ1•ÏÀŠé+R¨ÃÁ¶ˆ´í,¦wÃT¥å Âíò–•—úu»`c¼oþáÙ×}[Ýç?ƒ(ð‚ÅbÄ,¼ö-b;u1v\—aÎ¥à ÙÆòS™›}˜&…–§ÔŽË*× óHáF™WM§Ê0Ç6½å1(…ª´çNlª)J˜A½ªí\TxV;*¢û¢á”¾i•ÀŒzê¿Ë€h)w­zˆÍÙåTvíhŸºº% 4sS½ó'‡ \qPºâì©GuAÉâVGQouKÆTÇ­ÚOÝG­µõ*ÑÀVóþ«Uâûô?\‰Öš!ÿ5jQßM„êw%Ï^Æý!\fåÛAæ–NKÛíÁÝØH˜UQ°Ã–ûÄV¡á¼þ›TŰëêÍÁ‘‚Ôg㈷¹¸mø]£ ð¡ÔöB¨á^D­¾ïºâúð¨‘ïï_Ïog+•À•êÕÇV[Àu×)§‚ ýöe]x]#hŒ”Ï:“û+U2(çË̇NV"Ù›ÒÒ ¥Ñí%ñ4mfükY2!8¤îÖÉ<Ñ·Z†jçcªqœ`Á¬VB¢–.*-¦z9Ÿò,.oÛÒ'5ÆÄðÆx˜.ƒÊí“Sæî¦÷:ÀOŸ\‰øC¸¯Â,6‹Šx8~`bØ Ža]  Ýî‹ì¢s¦FU1–·}zÿÿ6c]Õp”)ÑÖ¥Z­çÄ5/›¼ iø¹BÐT̲ó‘ aº zÚ)èÍrvº>«Ú¬ØÂ÷³LùÎ:0 F*®JoÅ&òR3Yœ€µi8s- [NŽGÔÒÛ|tIŒ6/¡Û[€î“Ý›æä?9±½pî¬ÜW§/ Ñ]î`¿þý+àÅ‘p%ÃÁ¬¡w£é,¢ð çâɽúB!»P¥g%VftX€ @S×J¹Ýflû«’eOJÃÏ£ °Á˜Ö\º-¦X›26€OËeßêö^Œ‹ y­È·×"ÿ„*ä<T0À¶ØûÕ4+wohFL®uH¬mYý,"%Ú~ÜG׋(Ÿüg•€×“OõÌŠåM]#Ég¿´ÎêxUÆY𗮟¨«¬é`MÙ+è^ÚbÖü°´V»ô”B¸Ù±A˜í®„ø¿·Jóê‹Nȸ;LaÌfÆEñŠkêcþ±G÷Ûã¨Iðõ­;(ªé,îe Òìh„_ °Ü¥¦ÖÖÇîš’ª"6o)€‡È ÜË*˜k‘ìSÔÖâÖû‚Únî'€kùüY1o±?˜vÕs3MÄ«×nî2|êÊ0xN–Šf7âl_å©âSÇøf üRÜ9HÙ@óc½”ÒÉÒ¶mjÑGÿe€‚@îö`ㆢ="XæäÙj ÐŽìIã@\ã(€'/Üýö¨ àŒºš¶¹ƒ„·ó,Ø8ÃþÈÕ™kì}£Œ³f?vÀ§tù -@°µº«K{~E<¶D~ÌlhÁQÙGiaw­ 0·4œ†®0C¥ærɘ1Î"”ó¶`»’#ÔT#úî¦8yËQù+Êb7-€‰á°<3)0ÇÌtáï•Áf®'n¨Ëª,·Òê¯RóT€YêkÄûû‡?ÀÙæZ HaN5 Da¯×óÂSvruœV~FOc´(Xcª™‹â8V±.¶¨÷›ŠÈÁóxxÕÅ( Š?÷Å|çyßàpÂ6yzmÊŒµ)׃ßËsà÷6ë Š!ª7ñYRÉ•ÐõÏ úh™/ÂvœOÐV®*}Ìñœ¹VýÄ«if ‡‡)™íUŸ÷ñœE {øz„Hå&!â±¹;Ïö°)s©lwûŸàe;©¿-ûö‹qÔ ØHþ÷C¼ŠÎNÇ'²‹1‘Z÷@!µTsÒM\g%€DÓ“Y¹i3-LÉÎT%zA ícúùm—?h‚«æ !çmÅœž-“`}(ý¹X«ÎE½~-1<ƒš=tKcTMÅ-;ÃõŒJ+—GkO‡®IÙ9CHl‚9!áknа,ùÖQ¿ÊÉhÀâMÆf€µN½‰4þÌ7}ŠŠì,À‘²„kó‡©ز®M£oà‹_“ÅÇ´¤zXˆÒQ0DîñM »ô:*-ÀKg‡¸Ç¢ŽÿEˆÛcj&ß÷¯~ ¦(Çó'ÈF&Øl ìwP쯿ê,[ô1|T­ô´ôÿý~$ÖþþWz’ͯJù›:u[.AÈ­3‡D^O“Ê® ‰Wh¥wÒC’ÛÇ뽕¡Ezƒd… $ÞîîYjj¬Ég‚Ö¦Úaˆâe$¶7¼æRŸH‰õýп¸ÙpÂklIxéđ˛ ä ¯û9yvj°ÑÖ–K g¯Õuïamíœ]~”üëi”ÇHìmº~ùM×r¹7í%؇VYž3:MË-‹*èsZŒõme9 L<âVUPGîýa9æõjWgç\ªnwUìÇ¢ÓzvZdw­‹d«ÓÂRM*ýæGѱÔd©z3²ïpÉî?ã~}´wh’Ë?¶`ÎoÁĤnN3²Í½w t[¾:9–÷ÖYçcŸò¬óíA,õSÔ=ãG}f(ÜÃuÛ%g裥ÍÜ“#B¹¨ÿiwç-+¨·óÒ€7ôÎÇâIðD¬$.>€wIŠÜ%‹gGqÆ> cœíŸjËfrȶ±ŸFnF^¡wI\[U­ß+û±Ãªºwí ƒñMX“5“ î„Æ@˜ÿ<'-ªô¯çt¯pS»<0|êû®ˆy˜s×§ÂíL‚0+ÄòÙ3Χ[ë·Q}e÷ž¿M!uèöžêžK½ª%7 VØrÀxê´^ßÞdnü±õ¼=Jb¿m¹€í.Ùç>ÞÜEU+ÊôE°7 šYv'ŒôZq–[/ÒdEàÙÜÈ‹¸bêo­í+PÏøM{ÿÉv׆Îź‚`j(^pò]ðóÖ›<#H©þÚå`pv¦X3“á€Waà|IR;ç(fXm1Ž3¸½\î¢éy% }WaW{Ç9]΂æÙ.ëðñ)ßZ#³Í ðº0*ï<›*ïÉn ÆÎèÞèÌ£W§^Ì•@Ç”°‹4.pPœyòZSazdc?¿Õ(+w<2no×¾Ya.ö™:g[,€$ìsRè~>¾_ãúˆd‚Üb–b‡Y Q/þ7+TÄçË|že?6Ùà*±Kry+€“K”l–‚Í¥p4íòÇ€ðº.ÊêaO18—‰áe\U˜sKnõAðð½ P°7ŽÝLqžàé““p¬2€Fa,å·4ïR@wo–†ˆ„]ôwZ0±«Úk4ùzÛe„ žd¿Nr6.ÕÈ%ø{¯œú|q,m‚1‹4áÌ®dèc2ÄáÄ2i¢†¢nÃØìA÷·cB¾ qÄONÈFe^á¹Ø6,C;ýãÅSÔ¿Þ+Ç&ûöè*®´ì%;å§fùó˜7°(úgQ #©•äÂF^ŠäðÜCþ=µ²#@S”¢ç -}8’+å"ÀVÄ|È•HLªÃ²—Wnu§gPÜJOx²ŠUB­Ý#ÐÅ)¯4ŒÆCæÙû1ÿÆ a£:ózôê?¬¸„tìÛ¡^ð‘3yržKWJàÞͳF™öð'ǽSz=54j€3í#[Á“„y­™] éÑÞ´Fv‡ÿ^Z$î ïØUÚ™š7NoUA ĪޛBê„úŸ½Ä³+–=Ÿ÷6žõ1ëÍ©0Èj“*ÞÙ èÀPÕ_„µ Oj½×<¼ðîÉù¶K¬ú‡#zàÆênº=ÛÙ︰®ÿÖ§úÿ(¯rlÉv·‚¿‡´ÛÈ£šì,3Ü2Ú.ûíßmPxã ¿ª:­¨µàr!ߘô‡Ö>•=æ¨ß?N©KDb¶ÀŸmO‚ë9ùÅ¢yàÿlõÿõûÿåÙc“Í߇dNaˆ 4Ò²ëwK‡0ìí¶ç]Ë¿þÒ‚kò=s€Êll'ïseP×Ûëæ%V6©ô9@vÍ¥'þœsÖBXèç§«sÁ.º—ñ²Þ_Ã6²Z U©½_\±D®zRkT´F—ï0J*4s𘵰=Û<’ÜZÅ ¯)@=ʵt½¢ÓÒ>ñ-K½FN‚xý £ƒ~Z0|€mÕµ·ô …SÞB›EÔS6+PÅj0tgAï·v¼©,“{ÄÑEC·w˜{ CíràE›Y¹ð›„×ôôÖ•Ið‹M•Å í¤:ïÂûˆn;þÝ ¥²;m"À^ÕÇ·"aW5]>ð/Â5¯%4Oó¨•zû¼9ƒF9î°I žT ð1U}¥µIPÏ~ c4v#˜O‰áŽ7_t?Ι®Áƒ>'áCh(jO\´=M§åõÇ2Œ6ô­g1èS+ðúصŽ/ÎÂ:‚W€FlüØŠ-áÃDA=ß;ƒ—MwèU.EÔ“Ù®dƒtE©s'=օךb+½ëfâ²Z+é`û3ü!É?,QG| t[³ N‚9³È©øPé÷}I¯-щÿWO^©–¦ËÍÂ]´ €¾IœI¡î!¦¸ãnÁcoñ -€ï/p²E~îËRómWýÃìcßá~o—R‚.C8^î‚8A0Ö ƒ¼`®–{œÏ³Am,ö„-yÿüœØ YÿÏ?ÿ*‘xCŸIaröAxsð\ð#6W+’[sÇÓci;)‡-ÝCpO/¿ñžÒ{,ë÷("}:gp6À‡Û¦+? Ð(^gÈþÏØ<‹‹èvµiúÎÐÞl®iƒnVZZJ¥ì/±UŠØªŒ|#ß±Úò³ÆÖhÏ*ñ]˜à—”­PfÝ7>üTÓÏ¿|]mbi Æ“sg_ÿ h¿Ÿ°î.}{:wàê}KEì‚‚Ê^¬ Zƒï(µŠ•²7s.òM€E'(Oï”0€Õ?±,á/A^ù ÕÅÆÂ>Ï÷(.ânciÁ È­Aì>%àwß5³2“si¦龿)êÖ!ô`@wrov'4–òÊç7+'ÀÓrB?ßà)Ü—À*\9 ÜœÆyµ©Àõ1Mk‡éV_ú´k+¢¦ù)Nþ‹Ä@|ÜÞã·MQÒÿñ]íØuì0l+YÁ;¢~k·^Çë¼ÿ6üšû&-FCQ €Nq[a¾f©ÿ†^ÖÉ[ð–<žlôÎæ Ž\0V nž’cÊÎøž/Îá´±[¦é«òñ"ï(ã¦4McÞæðÇA\aÖÈ(þ®— «…–âvm A¯^<ÏÖöø–/ªZ[ù£¢/å8ç°,²>ü=VÛYåJx˜Î×°| ‘˜èÝ&5 ýÜîãæñHh.ùú÷†+lVïÁ )wJ‘Åϸ|A7é/_VÖ„w8P0FÖ½®_tðÈøŒmo u÷Mj±6 Mðô³½Í€wáþ=ŒVÞœövTg¦c»àíÃî¢Wr/ëüg¾ø ú¡xNMð†Ïäá°‡¢(Gkv/†w<1”~¾ÍMÅ©~rìŠÆà‘Rjtk=KX¥n£êZ”  .ŠÝ·ÃÄtA]Ÿ;ÅvÚwŒê­£×km `ŽPµÙ ýÌ9>²ÆüXNMQ5Žê¸ì>ª”I8»]°•óÑ2Ñ !…%tVòéàšJÉ ÊÁÑ)ŸýÚ¬Çg· ÷ uË`qX/¶ÎêÎÍöÐj Åa\ÓÓZušƒº Sª‹WØ‚T꼜¯˜ïé\;âdZ܉dFçô}¬~'kù”ÇÄQ¯ò[àXÿ/Ùüß»bóÆËD;äþØfU‰¯%-²îïýºå»2;ÿÕ†{rLìþ,×çn“»4¤¶¼ƒƒÍ6½e¡`­ëCï³,è³¥¼Ù콉ù.²G{lè½Ù$ìuå§B X¢€Œçйÿ;Cp¶‘ÁÒNiÏ¥]ËÁ9ø0º³¤Ãn€äå>Ù]v½Ú…õê˾Ko¸_Û‹×Ý9vÆÂƼR´W»L¯ƒsMÞöOs’™÷ÁÎñì£"`X^í ܲ掠:¥Âº‹½[Í‚O™¼eŸ—'Èl·«9xó„xfJ,˜…“ØÁÑôÒûSò¦/¬#Ó˜Wè9NO)wnl·&ÁÓÙ‡'Þ‹¼‘I\—àíyù~ :õ €Ê¾84zýéæFÜ]‚s> š>HÝ 竼00kS¹™Ž*P[5C£W‡ñd§œcfÂÑeÊHÚr¦²þØ]¹6j©ÞÆõt.Äí»èÐ×69£²u1­¸³J¥Žëþqg¬uÅì7®DeÖvpˆ6êG€Èw¸1îŠÙ¤â:Ü D¿£ ?Y£ƒTßæ­Ñô„¢ã®Ðv…évztÉâ\çýr{gމSÈ0Fnpb‚¬¤5cX–þËS´ÿ ¼w³'óÒ²*áÇÃ@9T‰%—jæ`K°öƒ­vƒ)¦±Nîí§~‘2—R37™ÂL ª? @½:k'ÿßm’²—¼îõ!þt1½]©[þl_ÿb‘œä(}²R£³6C´µ½Ë«Xa`Jz¬®«Ø/J•ž«ÖªPh’T ô¹‡ªØI'º[®*Ò ŸdQdì^)B0ùá¢pýZùã}¾t}/¬c ‹»ã{:òPW›ˆÍ"ÜeCþ!ï?ˆMJ›Ú=ÈÕü1Ûùõ6±›qòWN¢-’dÆrœ°Q{ü„ à$÷Ï÷A<¤fWKÛ –Þ¤`§–£®‚’ ÚÎ}ü½?&؆bmþž=’`;‹®âÛþOóeW—o&½‰Å€šðCÆïf§ |¾RǶæSœ›gÕ=«/ÂÇHqAQê"÷:3o€çš÷³¡¹vÈ…çÀÚ­r|Ëàé톒‰]ìm¿RïHJÞ˜ÐÌ ÖpRƒBª ½üƒ£c̃ø’²iÊ7¥>F‹àܱ.¬{!öJÎHÛW 7A›½,ÈõVœ ¹ñqd3Ú]_¹ÛB¾91ÕýºÙópôá'àiÝç=+^§‘žB? ¤cÿ$ƒàd¾Òà®­[qkh2k®ÜÒ‘ÜŽYµÖ¦ó«#ŸU¯<]½T^ô•q,)…=ìÎÖ[AP&mì«+ÅM&8¬TÌb  *Çy\úoTxwœO¡ž‚´ÍƒùbŒŽþ> ÉÅ[”åÐW6o1 I`¿, 6ŸíybïJXv`_vÃ-Jyž:˜èÍvéõ-§¯ÝcpÎí*k+$+F'pøVì[>)‹ßº¯ÚÒßã^M¸@eÂkнÌVºMMî— Ô5BÔ)~ÆÅ†Ad‹~ÍÛŽåL§æ{õ»_;ô¨Òl?i¼Ï®i?ß ÅJñëæ»-€»Ó×L¯—÷©‘VÃß’¶5rŽŸòM%ˆ©/B÷ p»÷GŠŠðU¬F– ÐHÖé{jeo‡š>ìpŠpóÀÍÖ kKpMva¶ÀÇû“ñÈ+F?œÍ†oøX&â¥p‰ãÈàÌ0Øu?B<±ÿ ÂÐl¼×·x²ºÉo«S\ endstream endobj 27 0 obj <>stream H‰|WÙª]Çý‚ûç%`?èÐÕ]C×£-ò 0˜Œ‡LXŽÉßgÕÐûÜ«!IWKµ«W×°ªzÝ^-rç9ü¶Ü÷u¯—ZƒâsÝ^?L|lÉäöæé‡Äõ¾È4p»ûr¹ýØ0‹PÁÛEnê°Ù ÎÕ ù< ëìó>ð{”»³®"2¶kXìÀ4 öŸpS0mÞ oÑf2T¬],™·÷úâÁ*ÚÏxíUžÕõÄTöèhLóÇÞÔ–_þèE>8®â±îf8ÇØ÷m¼’Çö‰|¹ì°GBߘ7lt`8YÞN|™<à—¾Ï¡ëîQ9ù¸„ö¡\ŒÝÖ÷l'ÊY Rü˜ ÍEyù´å½ÛÖö¼õaÁ´À¸úG¼nj‘€ˆûÍM-š§q÷ë8'¢M½¨ $[¸‰tZ“71ä„&U0Õý€ð¾ Dõr0”¤L?Æ<^§¤»ôÍWiÛamË÷MÞXÕQi9ò Á€–\xSW¼¸ÙŽMôÿ“£ârWÖ-î, ª[¡ç|îSzÝуuŸo*ÇVwZTm^ x¥P G}Àu¶«`€!Á'‚ï•À© „kjž6ïÓÆºÊVg0ä‚;¢SŽ­Ó®Ý ˆ= mUh0‹>i¯º¨œŒÀàPóã>œgSs\eHÁsv…"­¦³Àåv@s(]‚8w75¿ãjmËÚ}휵\]Í`@Þ–Óæ¾¤uñíã·ÉEõ£'ўܠ!ý v”U‘yîðYP|7O”Íu#Ç.ÓC´«;:MùSìV¦c+—ml{•ëú/ñ·Êmj· âÀ"-þŒ?oz4y‚âj BÛ£jLDżnŽRyozàˆ½¼Û==>`ÐÔH£7©…-ªBr²JDõ 'opByУ¬Ë¼¸“ì™øÄdt8]ý`V"ªâ,Íè˜Fb \Ko=þÛ¯Ž-™4 órìWñ콋,AíXÒ!tj£D»Ç3ࣣ±qð¼à£¤ð±³Ò’B[ØNµO„ᇧ¯žüöÙç··ùÄO¿ùâwûo¿}÷Ý—?ýòŸü雟þþ§w~ùýßÿùîüÙWïÞ}óã÷ßݽÆYŸ?Ûøýö×§_ðÝFþzû_üã÷øá_€~½ñí·¯ÿ:n߅域^6ô-ØÚÞ«jÁ5pGÑ‚û~ó†ŠÆh*øáäð3'ïpòŸŠÝþýDŃC/0*`;Q1)Šªš0ƒð+ŒÌŸH2@4ŸC _™Ž‰Ž¥`ê7ày7¢†y‡D@lµÌ¡c&™8½Æ}ÚbMñ‚‡b†´ƒô¹p¾ï†ˆÔ dgêÏcf ·*¦+6y€à¼¦ô¶U°­Èõ9`7/ë̱ŖGQ,&{Pæ*á]}4‰äUiÇ’¦Ç6¦U‚òW ä(Ž‚néÄô> Ág‡Ç³$Á1åÜ ?¦¥†«þžjMT²n[ ƒF¶å8ßg ´°¬&L¼ÏY²²2 å"U„MŠj y}0Øb ÇaŽ€È!Œu-,##“@\=5DT ¢Þ”ÛãÑ\]„ce+p\ МµIÜC5 †CþF5‘tvmL®å€£&´aû¬ÖuQ{ÌÇ,=–[½ë(ö¥Š×ÄÄèŠGK7¸£ÿ \ÎR Eš¢µa¼.뺘`¤Ç[E59²eÁ@×ì îQ­’1X’gíÈâØ•™zÈ&Èðܵe<û{ŠG‚vÍb ¹•SÕb…­)ž{EÁØÕ3¹Ô 66ûÁ[®€qŸþÊ>¯»Î•µ‘ãsŸ¢~ÙÛv1Î÷uØšÇk¼’³Å,`¯ë†Hª[×nfÊÇOEÛª vÈÚƒKJ/àKÌâI5Ûvò>Y¤¹4’}ÕÖx­ÃÖ.l‘}L m#ÖŽ)”†6Tªª`åqlE¸mû¡Õ—q=U„íIK']—=ŸÏ‡#®– PxÉ•ÄákìÒ9ˆ5!¤—*{\“£ÇßU†=PsŸ2Ú¾Û¶·.ñ‡6[~`£éFXˆ`ÝuÛ5†zòwÈ5S_JbEÍϦÃ룷m×E‚̼¢"st¶Gm¶-×HFý¡Ñr_ˆ°J™ûrv7@<“N¬š²23×nÛ|ߨSbGÏ3§ˆ;‡™ñÝ0D¼lr1 xÝZƒ»çt¼?׺È2*˜£% Ä:Ù `YªàÞ …×o;Xƒ¬ VFM,9ÛŒ»´ãÙ[ i5ŒA`¬×ÀÎ¥[ïÈ: ²¤Ü#eK :0ª·œ»0–LëéáB‡m/PòxÝÖ@ÁÔ烌P”‰±~«ÌŠŸ‘†Ù& ¢µ§o ”×]¨âÊË䨶>™v@¥vð¢(£žêP®FÌŠY½B ©A¥1¤5G‰×u…ÌhÂ"z*ÆØ[u¤×‚¸¬V¡Oºìƒí³×¡§‘†Z_óe’¥Í¦ ²–"ÀìÚÁƤ¶ í8áê„sÙØ—] CŸÏ‰¾Â^öráB É£r ôb40QÝ4û„`f¼¢=º{.‡Äée^§“®³‚"58Ñ·—šðC¢¿m5™±yTÓPÉy€®W'Ñ‘#È}KtÊÖq›^µbÇà^Ò$Þ`†ÚY|6OßË®Œ4[—mí§xŽÝIËrÉ_Þ0¶ki[<&úºê¼4¡uÀå`s½QÏamë6ç{ ¶¤qôÌâÝQ’Œ¶¥³yç’`Ì马½m¸Çó–»Q&ÉÀḞ\,bcê÷L8àLãxô‡‡tŽY–9“Š6sÕ^ºQЈ’õa¹~†%?kš‰wÖÕ Q)é0©]×…ç°Å»‘ìÖ\%ó5°(ŠU!Å„Èi‹'ŸSÚbϪI‘›û>´XÏr•¯¤ÊÂ:7›Á Õ7vÑlÆ©‡Al6ríˆ[?³ ”k§x®~0tÀ'÷ó‘G6“Ã}Ôá×ÐTl“X€ _™ÛWžÍd¹Û{xE42œå …±ñ˜Cv¶sF%Ÿ°åš–­*޹5‚Þ´=–%n5àµJ+]`ÆÅˆ Wñ®J¡ÈšYXµjàô¼Ïü/"v‰¤¿—–«›M܀¤2o@帄bt?>þ™éø¡`ÙŠ¸ARW°N´ò€I¦“¡µVªCã*îXði•¤®poÖËÌGyž'@˜:³?Ð&–ØÿÒn¢Äb5(H‹L"@`ôIJ>hP$ãx¢cÑ錑ràÅŽÎ Þê T]’kQ%>[$¢éLt¨ ÏZbθ3YôqøŸ˜ŒXNаƒ`Mrñ€$¢j TúN´qáróÐ\«€‰˜ëR.´6ï‡à%IiŸHMC = æôPz ¤O’¹¬ö˜³PÄG³Ëåiµœ|ØB¦¤ŽýIa=A2×ð $'iIe&}r¡¥«t•ž{‚Ü¢¸TâF¬vꉄ )¡Š€t0«Ð‡! Çàuet}dׇ& ÑŠ!8$Öšèí"1_ÓP¥*†…¶ˆz4/ˤ‰'ž“„Ž6ä§¶üÔ£7¥.ø2rQ³èCŽ È$ޱˆÑEè—°½^€}Eo‚Ö,ŒÑî·¬|½ÀX^>GøMð±|‡sX6S¨ÀVS¨dV­ŠQu¦,r²®W±—Ì ˆ>_ð¬",ë™ì"ö“5B)$–æ‘Ä[õ ö É&“Oú,‘ /gÁ\ë_Ê~Î})`(y]Ìoêë euùÇ69>‡tÒ}|” ÍZŒNF/ ó>Œ À-Â0„•|‹œ(??ÈVÀ*ˆåÄŒæRÿÉpeU |ʬ´±‰³Ouݘ?),VÚWú~AFŒA5+rÒêIOô—%5¦¸R±å“!ðb$]àbL‹2\0æ²R8‹9€UÒ b`LaiÁä °ƒ£^L¡z´ð&ßJC& •ÅB ×-NZªAKцèU¿3Gsº¦ Q…º³¹àŒ@66ðNz«ºb­L¥<2HŠ7S€Ä+BqéŒA@÷Tê èü±@›©rêK"4¡€žvóL} øƒÏ¢Li|/l'g5"-x6•1¥Ë*”BÚ€ãx ¼±¹‚`õKQ©Ë|Á`þRSj­*Z+•€êKødôúÎvŒÀVH€!J2óšÀ%'©U²¹£îrú©ŠêÆNd¹Æ°O”®uÖj1•¹•Mô.¿AYŒæ.EU É&¦2ØNÔ]Ü\X N2f¢Ó' ¸ÌGMÁZˆ@LU¾ÀK¨VIR"1ú–)B6Æ%Qn¬ùŃÁm)H’P/KˆÝÁ7Þ‹œdgU h¡–ô"{HÇg1B°¶Œ'i[zV÷@8š|«êA€ðv¼@ÞÒ5‹_¯Š`Ü,}YâX™Âë%ñ+ŸÕç$Ÿ(xB¥4"@xÊJªÅ®UÄEä•ÊLÊô1ȧ-x¡Ðk…ªR¡Rª"å§ÅöW4ŨGáõïÁ^+Í_XY]H °‘=tÀDTh¢ƒ%“]OmÌéT†3w•& z‚ ia}[a욨”J‘yjMù›š ”©ÎDSj ±ª¬ ;ôÚ\ò´€ ù[)XâuÄ\k ÎŽðw£P I¿ÈÌ06zÑ®ÑAòDX»¨·Ú‘²Jò}WT¹0VÌ)µ‹Ï]W$~#?çjŒŠ ÃaóÇ)”;“÷ŒÎ¦Ö2Yjhd#aРùó‘:/NgÞz«‡‡’7E¥J~S2¾Èc’öº&4^ÏBõe0˜ ”Q˜X©Ý ÖævKç0ó[IKÂ맘kùôk%TÄfGÀyƒL> ¶v,m²ì“ 4F†ƒ)òÙ‚žµ•´›-“Ù”e¾À˜BÏb`øÁ¡¿Ko9‚"»5‹(¤ÐY(E*¤K.å‚QÚ“€Ø>)ï?¦`EfnP7œY(rºF›£ Ýâ”äÁšÚÅ> ÛƘD9kH"¤j5’N,Œ=1žmKH½ôm¤& $E(ø(Š”À(û¤ð>Doë, +ylÈíX¥-,_ÈŒ°£Z¤òpãV…6"Èàìàìà·ƒï?/ßü´8=î׫ó×õ04ý‚ÀHà›—Ýâuß.†vñîÑ#›wíâê/—ô‹5òÓÉ?ŸýÜÎqÍÁÑøÏÃŽþõË‹—Ýiƒ>8cðûã“w¼;|ðáb¾Àoè?‹ú¢ùþðáÁ§}_Ï×ü³=.ù·£Ç}_Üþhó뺻ž7‹Ys Ÿþñò÷Ùy;?í›ÿþ´ m·¨ûíøä†£ßí ÈçÂ{0\Mä30Fì¾YÄW¡WúöízhVt ?Œ7^ɪoVëùpƒ¼&•QŽ~3§Õгó_Û9Û+±EwÂ3©ä6ÒØÌðm½j~î›ÿ®Ñc÷Ì‘„Ô¤òÛJb3ÃÅúâÕl¨ßï]B7©Ü®†ÿðs'nqà“îbÙ­Úa’Ø.v¼òt™‚C¸•͞ɜtë~Ö<ëëåy;›XVÛIu˦¯‡®ß3µ]opËù\F¿chnܺ¿·§ÃzÅóݤžEƒß¬ôyÓ¾;ßwsO.¥ýfN{ï²i%sm{}¸›y|¸F‘§;ÖЃÇÏß<ž/Ïë7vR™Pà?áiá°¯¢èÞþ»™ ÇÝzqŠCÇÝŽ¢Þr†ù|–-ž6g‡?Þ»½¿Êíõ5¤Þüe×®îý޽ߛŽß›%[»&•۽ݛQÜÛ½{»wo÷¦“ҽݛ`_c÷¦µïíÞäíÞ³z½Zµõâx¾¾ßxcÜȽ•$¦ÓŸ6F7”<<Ù“JëºàY §O›÷mM'­Âf72 ¯ÎÎVÍp燧ã4Žÿf#49J¸>;§ûê­iMÌé5½uº¯àšX"n8ð'Ëf¶ž×ý ψþÖ—öë®] /ÔxLŽuömçG°CÆLª¾ØB<ŠSKåš‹øcßTÜäÊòÇÎýkWã ÿj½ãôý^üÖšRiöI·X õbßbÙI¥u=‰­$×ýY=kNfõ¼Ù3Á8­7øtú°ìÍþœû\ÏbÛû|Ü»vs• fݼëøý¼vüé­û RÇè¡'ÝŲ[I&“S#[¢w{ætÒ­ûYóx¾<¯'•gð…ÛkŠuº¾ÀºeÓ×C·cÏŽIíÊþ–ó¹Œþÿ” æíðºnwm­;ÆÓœœ/ga·g}½Žò¸^Ç”?ƒÚË¡óŠºdl¥w"M)¢‘JM‚wøpÉL£QfçR)f±Ì ÑŸ šÜs!Ñ»™¶šÉs …² ÛA ­\q§ ¡Ü[BAí*h¾Ÿ.SUô.ÒÙAmÌ[a¸s^¨±iëþg}PQP£—L(,óYîÂdÎÇŸd¯™@JF$\BÏT{—lF öZæaÞ.t—'H¹îì‹&¼"{å5yÌ,ªÄcZI±}(_¦ak½˜´sKX³¼«[óÜV^ên‰ß] ÃÍheˆžæó„,¢)iÕû>VBºö>L‡ÖKK½õƒ “äã¿ H¶q·ê󯩙¥Š¢ÜÂõzqV"æFøV¨G-,3øzÇ£5ìŠçm K¬´~øU*jX´_±"=Í¿ç`T¼“HèÞÐiÖ,\uð~ñ°–œ „K¥Ë§¬‡Vì=(¸Ãøœ°hƒ©ÃˆÅRbĶLc™ÄJø´¤ÈNDŒ8Ú©ø'¨|¼·‰6T lym?÷“ ËJ¸­`BfA=´þOݾE~‹‚öQ¹?ù,ÌÎYÈ‚8µ$t}ó‡‡ù"rÌÐû êHwÁ»Õ’\„Üýlx†TFï2m˜8Ñp6U’5—ä dýæªù]„ÛÏÏwZ«‘!ú“ `êëæ\*K&‹Ðr-©žýN¾é4 ²‹Fº!±=:<ßUÝ‹1Í7.¦ßîó/UÃüÃþ·QmâP+½ØœôžêÔøô`DJªBêæQÇd„Õ†‰H%,V_ï \2#™rûRúØœZË÷8Oñ3Ö‰â}V´³¢ÇõO($EÃ:‘³¢í£hd²wPHçíÇ Ú¿·>ohg=;ëÙéêÖ: gXrªzö Ò$‘"©´‡·.ˆÄcZI±ý+³S®  ÃøKúå0ÇÏX§sn˜¶ùª0ÐÚëtN³mD$—Âb¿d硘}bh©WX f½»\æ!p—Ëá`xsé †×ÙÿÞ ûw“½Î~ßd@¡–X.¬ieSVR+ácåpPAóýt™ª¢o8p‘ŽÀÈ*ˆ+Œe‚ õ"6 Ý· *\._(¢›\è+X+ –³=K6£…ä.V®v¡»>stream H‰ì—ínÛ8…¯ ÷? t¶±Ó¸[Ô¿’xch’âußbÿ´DYl)RK‘ùèÕ/%ùC”\kdwµ£DX`‘&’=gxΙñÑˇˆ éÓ×^ȸ¯¨øýèÕ‹ã ó4“‚¨Ç£/Æ›‡ˆÖŠÍ¦Iú˜ýÃú×$¢Ù«]}º¶Ú÷^*S¢'Fý~tüÁ<ûë™}\,6˜þO,_}É„O&˜¦»_¸#ÜdoœÚý£~ŒóBΔ"¥ò÷c,`¼Úõ  Ð)1Iˆ8çÙ ìBßþ×5çð—qºíI ×ÀÞÌy][ïJ^½{êLyfÒ(žñ8$¨°˜¨ ù]mQZ¹Ë’hBïIßRý Éh$&¡ŸØ"Ô£E(~?,"™°¢Ó¡€qE#y‡ËòêÝfg%$@¦Gʹ¼/¥blï0[d 9¾c’S=VÔKEÄ÷ŠÑ%'¾Ï4«kQ¡Ÿ1'.° B ÍóLd8©K'k8!2²A9©%š(h üž<ÖŒwûi p¹<½+û3Œ3A .ݸdsºg®^-Kwy|ð–0áÂñóÅÀ‘ w+Î^ž ^{’K\3Ø/y»R¡³T‡1\Qn¿¡AÜ~7@Õ–Bù¥+öƒEF‡PÍx k]}ͬ5n·õAá>îç ª“Y¸Ý[Íϸ´³êtÌïp{Òâ]œÄ¨ÀFø™ *P«¡Br*¹ØNc¶!*6§~­IÞ(íª¨Ë¥X™ß¡ )2›îd+ Ê,¦žÝùÔ§å9µRŸ,ÊN|Ñ(`œBÑHÞáRâ¼z·ÛY 5ÛQ1ˆ³…/¥bœ_ì±µO:¾c’S=VÔKEÄ÷б}ŸiV×¢B?cn5Ø¡„æy&²7¸naZà )‘*þª‰‚Ê2á÷ä±f¼Û7ØÀ岆ë]ÙŸ`œ JpåÖ K6§ pàêÕ²ôR@¨Û6¡`„ '«¼$«g®³¢³Ïm놋S–Ž˜=·ÏÚ ˜`u2Úº€¬1ź ËÂ`–ê0†+ð–Ë—xZRÝq)·5¤/™Þ PÊ/éÅBð=.¬uõ5§ñìZS7J’å~ucpMñ Âí8Ø»í&€Ë ªÖ½:ù )2-„Ž1®)®R”( ìª2³ jéÃ.B‡`{ÿ|ˆíÖï!2 …KÙ$cvÔ m² Ñ(®\È(–I¾Ðe•'­÷'@®™4Ê£g< *®Œ`OÃÚ«ª—ɘ*¢ÁÚPw-ólª¦¢À™þLX}uL|&© Rƒ\ᦊÄ!óQ¨D1FT#ã*êB‘îû[ ®¨ž–]9í&ÈidMÞ¸@†¨º!ëÈɳ÷N\“u¨yâžû(Ê”Ó{g7”º÷Nl û{'²ÑjêWT-ÚðÍ-ßšþ£c7ö\#›ÀÎ8ô;€Ÿàª_Óê—go?³Ê?sòx[sûÚ>R¿,ãš*[¡N€Ã"çߨ§Ï¥¾}è\> "tx¶¡þBAGƒ£.u/ì¼Ç_ϾN/³Wʺ•ý²u±œ“$ŒˆsnÚøòwÙçx†ãgË g&òèC‚ «º $ÚŸÐ;FÒ÷p¸TØh”rn‚ ¡ºó—Gf©(ê㛹¯:i¨Þ!ÿÈR³Ïµ ’–]©‰XAúõ¦µõ¹Úöœ§Ø• ˜Íc¸„±€±3%¾‚}•ãíY± Ã ñ4á×’%¸Žgý‰®c5 ×⳪Ý%J4Ó^ø…q ]~„œeï ‚s0\Â"ƒÖK . 0ѽBwà¨àŠõ»dL@¯Ú¿›¢‘Ö]cNò¤2Še’[Ý.Ðí]Ó ;O5§»nÃLåÑ3‡W?R‚}/ ²Ñª\SE´„Ç*T<›êušÊÄcçQœ}¼i¢™‡êDrñpôqM•­PC½JοQOŸK#|ûй|@Eèðìlûñ„Gãdz¯ÓËì¥RóOjA4]¹þbÔÜp›*Pêuƒ5BAð ÈÁKDÊ…Š¨_#š¬ƒ§¼G¼GÅæ®}dÅÒ—C"+:õëC+tpkÄ}}(ÃÁà7TDz,ÞítHÙ"„ú6:¤Uõ.ØÉpÁT¼«f-ÀÊñPQFȪ· í·oQáô _¿ðµµðŠØ´Ç¯%Kú•¯_ùð¬|§¨ð~íÆ‡‹­ßøú¯ßøú¯ßø¶"õBŽƒ7¾*œ~ãC¿ñM‰IFÄ97m|ycÛh´Ís<ã±}7Ç<ÂM‰Cæ¡«æžL©:Ù¤ªJ%ÚŸÐ;FÒ÷;¹û¸¶Ÿ› H¨î¼È #U5E}|KЀïí¯r5pˆh*ŠàCƒ1.ð+Á؇&cd  eì’KY—ñ«˜'¹ÄuÑ"\ÐËŽh›û?r ä Ò1{Q}˜sâ}å¿’1ñ˜~ü0xƒë"-áÝ¥ Å2ašvþ>u4œ< ¼ dÏăP8*‘GÆT]W橎½ežMõ{j{_Þ_àk”ßPï&,LB?±E¨mñ-¨^ùûM„ξ£ä‚'‚§5âõŸÛ=嶆ôe Ô»* Bù.ùÁ"£C ÕðíÖºúš›ûïæ?WT'ó³DšÛt€Š§ê£`}ÁØž-û„QñèÌ#àµ×]t^m¹NM؆¨Øœú]4¾ôÿ׀칦»ó= aÃ…\^¡ )²ÌÑÉV¥½YL=ÉêãÞ/‰{¨&£O{}Úƒ§½d©7×?ýÄ·:ùNÛPâåÀüŸ±ÞA\òZ¥x&‘°A^ºQ,“ ]VyÒzäšI£ôÐq}Vxºq°²Om!‰Gx„|wÚU~uŠDY`;,ÿÛöÓú7¨W€cJþa¿j{Û¶ð/Ðàí±"Å ûd¯‰Ñmi»K ƒ¡H´£V Y^ì¿#ÕÄvÝÍòœtW²(êx¼G÷Üñn1ŸçIiSÆAæl×udŒ¹}>m׃ÙkõWž˜õ-Á1§ m8(”ÞÇsUŸ}50¾×Pr×n,emÛ ß­n#Ûi1²=…܉[ÉÀØ}`ý=éy^«³Ï‰‰SÞ9哊ú}¤7 ä?æ67û‹ÝĦgªJj]µ„µÿ‰ñ¬­ÿÿÚ›ÙaOà9’Î=í=K©M°[•ÂŶ=iKUÖ﫤œÕ)bjÛ‚ËE™\ŒäFC+BÔÉc§Å“ÆM@ÆÊcǼ%.Š·Pm"8ˆç†eý,s’eX¢¹…ë(žõ~ðÌMž‘3Ngß¾½…Óÿ2¯Üòü‘u¨Ë­Ü¡UÚ<¯•‹™å`¢ õ¢JÕÙPmOcö­Œ›Ýç©SÈ,†#:9'3Ãn'§gªJj]µD¶ïœÏÚúƒRÕª&§H _ÙÕ<º˜ⶣɨÅñmµõp·(œú*ëý¼_æ!Ïêû–†ð ãÔGùlüvb¸Wùä¾­¯ƒôhý6¦UK8>q ÎêK$ËsE²Ü©#²='À‹î›Ñ­³I•8vàÓ¿8Mó¢VXX·m)õÝG•Ö=½(3êé=Ž=1Â-<ÿš3_½Vcô“×é¾!Áè¢Ì†7ýK»ØLq33z«Ëk@T(ßo¦{j’—›/¼·3«ƒ5¯†«é.€U¥{é¨ ×탷€£¿;ƒ1AýÝ®àá|„)EWè?”ñG8’hêùöþ›½ûf°q7·Òl`´àꃅS8¥Ù©0cÆÜއ õ®É†ÄÔ‹pS#Ÿà€±˜¢³˜*?Ä„04<$!òæV"õbE\‚ Å‚„"B°dR ?Àfq 5&õ_À|@B!QŒc!¥D°2"‚=i_+0—‚Hâ ˆA,äž &L°­­O½±÷»×…ê-–tFŒï„×à~U•Ë™®ê÷Ÿi×ñ]‘¸q^C] šÖ‚sD)üÁÎÌâÖ…¯*)® Öd¶ÔÄÃ"OÕ0M I¿Ê³_ÕªQËzZVš_çKU\«j 1Õpç¢Lî õékÒO(¬H‘g ™;#àñȋы—èöÃ¥2>Ÿ{úa‹Ë¿†NÄ’úSkrǘF„“¦Üøw S,¡e˜ˆ%5.—„E–_,Š©@›gfhD9Cp=PÍò„¥"I¹0.… c@$Š„v‡$Ððgˆ,§ Ä€_I‡"¤¢†‰°ÕGqL(!(¤@Y‰©0Ô A¿Q{㉿/M} endstream endobj 29 0 obj <>stream H‰´W˪dÇü‚þ‡³1ŒÀ}Tù¨GÚ+I^jeã‡VF\°æJ Fó÷ŽÈª¾>ÇÓƒ‘ÕÊ[§*+32"j·â-6]Ã}k{to²©ìCblŸ.}¯¥mR÷*¢ÛØ[ïÝ6|Ð=6‘½w©›ïÖ¼×í»‹è.ºÙ®f+tïVꆋ*þmóïe÷f£õíé‚P>¾ÊÞ,Z宣Œ¶]}W•6xÚ||m»Öèçüëò»~ýͯÿôÓÓÇŸ~ùùÇ_?o@è6©½ôh_m_ÿåã¯?ýüïí÷ß~óôôÛóŸùø#×~µý+ÿˆ.eü¯ìâÛ.¸c/Uxlõ6Æö|ߥÛàÁ!µ8Sk ™½†ÌFí®Û5öÚáÓ’ª†ÛdHW•Zµ#Ôö®5/æ#?T±4\èÚ÷h¡ž1t#¶ï/ y |h{ Ë÷R*+ƒ<Ľ¢Cm/î‘4íah>VeŽ=¤èYõ>öà¤O÷­¼oõúàiXPY”³î/@Ï’¨*,Q)‰³§K"ÍzÆÄZ×\¥’…ĹÄ'#&–3-ƳPˆ–f·R:®ÔÐ Ã"ÜÄ%!ü¾½O‘D(z7üºâî™ýó…•DºU¤4!ÃLúŠ9‹¬È>oUC‰¯s„È÷—$Ðvä=d˜>æP»CqO:€Û8®³]ëŽþˆ“Ìe$4IJŠó¨üõÛ‡¯¶üýòÛû™D1Êú4qC;ÔÄ>Ò þЫ†e¥‹Vß~Ààa(ó•1 šÕ¯èãÈí@|3Æ¥ô ey±Vï£fs±/KXKèÈ%*ÁIº"­œgBB´WÅ9ÛUÂY4ׯ^w`œ˜`Ó[éì傿×ÐVF&•c똤ã»'f)MEk`\eq( >ÔéÁ ‹V3{¾œä¼ãI!P¤Ù2PšWÑl¦t¬HOð]¥ï–-†sìXwctRãw¨®[fç»­¯ó£ ªªšÕÃO4"Ù™ §x S†q1ï@ áœÈ7aò’MT‚»„\ƒÒ·ŠÒ<5,S“£Ò†Y@¸ÆI ü¨òèòBºƒ˜D&׎Km³µcMrRM_‘ˆê ¦*.kÙÜâcL’°ê$„¢“r? j…@U,>AÄ5G`Áï 8IÓ ËƒA¬‚¸B »÷–1HDZí"9e‡&µc+¬Ú6°8ÚÄC“¢äSö–t‘Ê\Fºg+VçV^@l<.‹ÉhxVFËïêâY3ûÄ[aó”fŒs€ë ñÈ?H]elM;Ù¬ö)%’÷D5r"”Ü”×Iø< ÃÀ%îS‚¨ë¢XÞ¬L´ îÍó àÊKȪE)"&F½Kž;emëzH}¤:af”ÕàõhEh/à<6V@’ ¥±jR“/¡ç’kFÊã+™‘ÈKâôaºJ²Î§¼²‚ÙœÎ25çXæek*§ÛK›©-Pç ×l 6ïöa¶D±/yfã1½c²c OÅa•qO2$Äf$K»%¥ƒC ‡›Ê^` K+œŸb#MÈvy½È½Í…ÈX«ãsZmøôÿ’Ld¥µ¢ë¼# Ú˜u—Úg}t”k•<ÃÆVæ,MÂ@¨: %h–U4”sˆA²°6g£Y^Ì\`Ë3MêO”‘ s…|Áùè˜O&¿§¬ç˱ÉïŒ"ï“ÏÜ_ÞUmBiòÉ)Õ ñŒ4ï©õ ‹­4|å<Ö‚oÓº†”cD©a” ƒ\1ð0hwÃó‹ÆitÈ4<:¼¾—|w~„]ÂebŒï.òm”&#“³'}.ÒNZ}Ñ:|Ço¬iU>6ðŒ@ú*”šæ)!ºeíG_µO"ÉV«¬ÒÃËdåG¬ÊÛ,|ºä,¼’Eø‘Ö±ð«ùFJx`þ².j èH•­S”‰¼õ42)Äવ¤¢¿¨µ.*y‘tª>KwýtË=,g€PŸ!é”ü&Ë`4l¬ |ÁO&¬¿ãG*$®À§æÜŽÜ¥ÃÁñJÞyG²ðÐ|²Òjf—Ô¦!f‡yÀB1Î\V:5EÒIO/²Ãrçëæ¦L|{öe´–|9Mtm¯ÇfÉ-@K]”ñ–^)”ÕùÚHi9Æ(¡OÇûB}u9¬=‚A«š/…Fe»,~ÐÊùá”4žC&fcIÖ9?7²&£§et15÷Fûü(©ì¦ ì§Œ·ê‘hž/¼)1 „ê« QªÒS½J§[Så1—üjhI“€2ïgŒpÏ^9Î[÷à;èĘŸŽÂtÏÆyä*^uÚbÖд{Ì=ÕS™¼ó|9ã¦;ö:a8]¥¤‹2{RÒT©â§du ´åiñÑzD1cÎ÷!Króçÿ ç,VB³&†ËI˜½„cæƒfð‹øõžýÇ©VcùõÑ|ºs˜k?1N›«’ß­z·×Ê÷¾kGÃù|9³¥GëzbpÙ;¡³ºõîJÈ÷­{gFõèfŽ÷Ä?ªƒy¬ÿ[YLe ;˜™YÑh€ñì©ÊÑáˆÎ_`Û§tЏÛ|…1#9ª¦ºå=>çc%é‹åzO˜& èͧt«fô¦ Lj˜––Á€¯'Õû<U¼Ð¦-FÒ¥‚œž9”n™a›?!|þÝŸ8ìIì¯kø d§ï¥aü¨$@çZ–WÓÎr¢b2ðÍáìÏ_‚½át¾3}Jn(PÄõ@Íç(>9uì š†"4èèL Z 2ÑùlW&y§àRy±IÙ—»©  Á= „²IÝ)OÔ(e¬>7Ykp ¶½ ¤\¼Ý?*®1þÈIð™ù.êlsV_²C@¬rHz8ÇXè*mQ^—g×hÿS•õæÿ_Ë·ò;ÔóQ]»Ró؇—|ÿ‰L5}é#ð0ñ¶UW’46·fJzÔXÍËQDíŒf|v‹ÿ=º×Õ®È}ˆ ÑÕ/>ñèçóqMäç·«VEÞEVËÞÄpn›'â½®¦ [{¥$²i’ÔyË2»ÖçV¤L²Á­mWz×ðX}ãrX1«¥½iÜk9oiÞ×÷Q»{­ÖT1O¯=Šÿ|aÅ /І9ì+¢ƒì€ ”B ¶>©€PO¡¿âW)B¤á«Ò-å',rkpG›šÑ¢¤èBã<¿ã3aÔµÈfå{ÕXÇבš•ó˜):†Ïlo œ17Ô …Ä£Âæ›.ôp¯ï¾]R{f¨†ÑöBF'.8úš0éˆ+%u•2š/œ+ÆbÒ½òD«ä¯‹H$ÿ¥½Üz£<’0ü æ?|7‘à³}>\2‘Á¢µEȇÁë`#cBüï÷©êþ<žd³ø2öôtWWW½õÖ[Q%)ÕäŒÕ¹H4Ks Iƒ’Åhal°~_¶CµÌ=lQ¶ƒ!Á]H©Ñ­Éêº)Uù.i•ÐU“ëÒ«fõt†ç: ¿˜¢M™·¨&/s´6æÚ4Ô¢T¼é"®6ˆgZ/÷Bõû º‹ç]Ðï)G—÷Û²H¤ /?éÑ BÐx˜¼P6|U½æ×Kƒ.u)£e‚Œy9vÚ…Áïf"/sib O@[ZBK-ï^z2òº·¹Ô0évÞ¬>åµíSqÓÅêÊšúíY»¾n÷y¥¦ô!7>Ö±Mô¤ï¸Œ¯EjÁ5DýÑD§Ê ™€œï±Ø0õÇ#9‰:÷:d¢ÀQR'Ä!ÐÉrÏŒ´D…:µnbÒ„„>vrÜAæÃŽ™ÇòoËýí½£‰Ù¾ç»g/¬y÷|uöæîêäúR?‡w‹åùŪ¯úÏø9úL“6öJùÄè¿£;>üÈ¿±ô=5¼~ùÕ grൊHc¤`®îÿN”, •_R±bÊ ©ôo†*&õÓn80Œ;6¾;ÐÓ£=ù4^µ¶8ºq:[œÌLw~ñŸ™ž¼]­Ž¯–gÃùÍñÙÅru;اRH¶jõ2~©ƒ7ʽ={üq>küïuá`üp)ê9¤P h Çæ+RÏ ²†—êÄÑÙ,=nʾÿt²™°1]þÍðº¿Þ?í¦ÑJçqO"…i³F2‘+h’”=z%0Ä@ÂÃázIF2—襇>]D* a˜š¥-[‡³“ý7Ã?^'|óÃÍÅÙÏ—Ç«e«¾y½<¾ÜüêÕû÷—·™¦H{2±Ðâ•^e®A0ÖâjwÑùÜ},´šCÑ“L*N4pK³9Üco:×-Š6Ͼ 5är¿Í¦ßŸ­mãˆ8“×EFΔ*x™5Û;wmNçpó©˜D &z&Ë$5ˆÇ–Y¤!¦XC D>ttDÛf<Ú½>gÛØtngã>scÔñJ///o.Ææb}Ö¶hÓºkÛÖ„`10OÚoB–`ë墚¸œ±ÈuEÏ)x"½ö¤^Í Q›Ö¦ó›KaAD…hu ‚ru‰ Z_eF9ÔED” vŒ5÷¨)¶ÄÀÒ‡{ Nˆª!œE„ªWjÑÛkj·Ëè¹ÝbÒ=.ðMpZÓ¥-cÓ¹]n–)G$3½j—g Âåh¯{è"2ÕEÓÐÜPù*ªU¤l›Ìí±ë~˜ ˆÑ®­Ð”ÑÃÊÊ^†*žmòŸ¯NС”Ît¡L™‚>kÛÜ_`¿ñB‰ÌJÓ Iâ.WkäjõF=,&7£>EšSÑ« ´lÛšÌii蚤ôlÃk¹znÍ»Øî`^Q» ÐS*b×FK“ù t´º´mA.½^ Иq#’JOÒT»l›šŽ! ’°ÖIב«=-XséþU7ÂEéŽ\$gšÜÓmCS"£8ãmoæV$¹Ü2`Êåat0&Û€šÕ9j²Š—Ç¥MSÓaƒò 6)ÍÖ,p†ÁR–0XÎZ\‚–ì‘" <”Žƒ¬âÀë¦mC“y,ð„ž¤£Ð¦yÇ;ß¼‹ÀZ¼ƒÓrCA5Ðq)E{ÿ–™ a,rÒ»½¤W:W£æ¢Þí]¶¥…®(­I1`‘Vê¡ÈDÓp±ek2¯é,ó¬sЇY •Yé­q”ª"´Ì-û²§Ã´nâá;A *P¶kpßûä ¹]ŸJ–š×ĸßi^zÔÆ¸/çà¬y‹ë¹ö¤lœÌyåa!u º8Ž˜)ŒžVcjó”>Rl<|¸QÁÒTú®É czó±M‹°´í‹¥÷EÓØßS·åØ«Y&5£AÞ57]à¹ß[F„˜¢gP¨¡Þ(IƸûZ‰RyDˆVÆ‹Óy–­Ín,¹¬[dlÉq¬¹qÐdä‘lŒ;@¤au€85v,Nç<±ÒÑU8ÕÒïq¾I§¤*DqÄ0ñ@Ê6愇2qÇØtn Š[€Nz¿\o‚o^†;©Ç(Ä}¿¯ƒ£Æ19±M¡;'tÞŽÑçÒSÕˆvé“A­ÝSæ·ÞØÁáMÁáõI»&'sßê$ÿŽîŠ~ããçýoˆ VüC$É>—Ó}7j!M R"’vÚ½ZœàÀ“·«ÕñÕòl8¿9>»Xòžv§F÷Æÿç3f—yñ¦­¶‹'g‚×.(ÆÕvíýÊ:ÈÙÚ^<Ä^=Yo_œþ-ë‹/[Ï)"úœO›ÖßâÅb" ¢œ ÅKQÄÖr,Í+•¦>Vàg…~¸,y œðdrÂ=sÚ'½ÓU²dŒx4÷¶½5îu8âªÐ7¸âÃÀËËàq‘™~U‰?‡ç9eÉòÜJ݇d˜$°ÙFdbã“È£r¦ d’Iº,Ô@¯’´DbGšÉ ‚¬¸œÕ=–kÒ;ªüæRJ†€€ô\™ˆ…€ŠW÷„vxp7dõÎ:æ.I›uâ´þ2D^&`•#HÁ2BÖ›„/±fax¦„Œ²ÖsŸõsµ&õÐņț„€ÑêB)<´"&¸ŸÏD©j–€wâO±l¸5‰š5U%*ÖžZj«ŠoÄ?·üÓVÄÿ ‡JæM¨£HEñ@àŒ” ™¹n@啨Î(rWç1q³œÁ;K©QÍÕIò /©´7¢JL}Þ}¼¯áêZ}ÓHØÏEÔy‘P’Å’X€ ,H±¹Üâ@f ؤ-¢†Ê¥ª‡´)z#àPø6xJ¼Á’Ü™8nØø/íekÙmáÌnb`Œ}H6Éf(½\¼cÀ‰,%ÖþýU5ïX°àÌ„Ñíwø×]]UÍb.3Gï. <ºë·FS~޲$UC¬½ Ÿ%žÑqØŸ´ ?HÛfÐ@RoCÕ  r¦ “Û–µ†Äo&±PGR!ÕY¼Âï=Aê¼Txöؤs@9Ï©mÉ®ótD&Ú¾µ)'7¡ñM*„œ8BÑgú›þ þk9`°Ç7p+ô(A¡ávÖÆäôèÑk lƒ£·Óß‹À P½»y¸…~²èÀzšSi[§5AGèìÛh?9DÏ…b®æeÃLsÄÙ…øØMJÒ__}6.j*„i¯G- †ÀßQÀ0ÿê|2Âø>¥%žÍÆ®õ®Wî¡€x´êS¥Õ£ö©ìy^MßÜÀšÎLÞ™y‡Ö<½¾qõïɺ®½ j€ê¼ Gê©ÛÈìu9ºÁÅ~.luouƒ{ܲÆDd‚Ù¤.š¹fUÝöe%Þè{š–¨SÛ®~ž,&ã)ÛOÚ†•Bk;Uqꛥ±¾ÙúF»Hi­~ú='Õ¨ä4ÅÙtgè­´çep×@úý¬SÒ8f†qŽiœp×÷9+ýë xg-ØY¡ÜÅAw`ã ¯¾ÄHÍ©«ToA\VqÉs‘)Ó®›÷trÑ_v|¯¤kj\<\ÖKŸ˜õ†›ø9E™ð:õ` VädAÅOìºLÂvÄ– …ú#Bæ“·ó×<Äñ3Žé‚Í›T i%¥>Q%¢Ô óA(äÍMKíq`D¶ª« Dà‡^ij-A$zR¬¦I SÁíbs;‰; à*qœwõѰ˜¸žÒvÔôy"¬íS2  Ö*j–É j~J>¥Ê"7 °O–‘2pÍÇäHÊžôÆjÓ%tLLø»ŒG¬÷Ý6éÆ˜¯¤äC¨hºœÏÔ¥â.Œ’€œ ’)Ï Õ£® ë6ã0¹}ŸíX ‘:‘îiÅdUO€Ý»]WvYÌ;LC¯/Çm?®éÛ½ï²xù”W4ò¾4¨ÔZjªf•W¤ÊVQ„CX±’Q²oG9îë&÷+²Ç0­à¯,ÄŠåUʯ»î({2БëߟÈxƒ™çÜØ#Ù^¸ÑÚha÷àelë´Šu-ÁúåçäÐÒ?£,ì¡}pß´‹òº-“¬‹YÍKî¤4^žeÔÉïºA½€;]Ktʺ.Ó•C¤ž)B“‚<¼¨¶Ë•Rð ’ù0Ò6FŠÕ ¥-"ž¦ 5m ÃT’Õ"X&^B4ž˜QàÑŠËBÉbP³ßÍ<Œ±ÿeØüÌ“Z´yÆ_fîbÎ{}þþûï¾~ýõýåŸ'3ËyâúÛ§õé~ÔY#dO…„©ùŠ pМÒE"¿‰”\ š½É$`þáÌè®ÄAxëLb®•fVñˆuaÂÄÂCâ—ÇÓ ˆ×²ŸÑ/D vпü‘ž¶yK4ñ¥{ßð:û-ˆ\£‡íUSo ,j܉§ñ oOµŸ¬Ãdò{ÙS¦Æ‹&X¨ÑôY§f"¹d\N]QtÝy¶øÈ¢vÕ  N–RØ¡ !F÷²r:µ§öŽ£Sé@±C“»fÕÄ Üw„¿èfßUÏ—#‰~Uµe–§ÂÀ×2 zå[“£æ´‘< 2=%«Þ˜5]Õ5:vg¤yNT A.›Ù.Ë!gIJýÿ4¶×çï~þåç¾Épü|þ…ÿþþiRI¹Âƒõ• b™Í^ Ãß^{jµ'ƒáÛu'Œ]þø$#³:ä-Å1PóC’Œ†Y5q¾ÓÂ;/@'C“‘ÌŽs[òÖY›"IJ&‡iž’Ý·5SVáó¦L†HTãÕVñƒT„[k@Vê(tö’¤hî’5ÃóèÔ©ü s¢²÷Ð0+Iç⼟Re$¬âU8F¥¤¡¼VäK'¦D^ ™:’ž.áþÖ¡°ñïƒö ` £¬iôÑÃ-)¦n80’N[©j ‘Ød{#–4–?ÁqS¨ÓÊÓ+ Ëmr,Ƽ‹PÌýnç­måg(îìw“g"'[¯y/Ǩ¯MN÷¬4 ™)1– -àp^©)e—)ód(ÅM’Ž+”Ðæ{zzùºÔü˜¾¾hÁU ÙV(Ýö<ææV K p¦!T#ê‡5­“$’{ii1²ߥWY§2äû¦àCÿá¥C¿çãs£”¦È!’JžüÀà|!‚Á%!™8Ùå€MîÌ}Ñ3a…½jÆÕïƒ=}íQÆP{Ú‚â²kÒɰQUI 0•Á ˆgA’s ¿¦36 ¶Ù•‚”sÁð²R ǹå@¢Ê>Û-¶#ÐÛð¬Iþ­?Hüq¯<Pü ßä#î¤}=}qô| ¶ëÜ“$¼´‹±QÒ-Ï w뚣@§Á”Ìï¼ÖŠÀP[ŠÒÅàZäEZ55%¯©Ò{êj½æxçÛçí!e9âmò@$—Á Ób•7ÂÔ¤6âBN£Vóé1QœM-…yØLã{àfF¹ ÖpqLfº+›„>Ø~Nå¤S(ozÜ‹’:…ðbžö,°]/Ñ8 v¹:_[F/«‰ºö#Ït3¹Ó¨Ç 4ÌaÖÌ(·È_´H\'Ìɬ/ö£‰|ƒåâèÔ”„_æ|¬…°Ü1ñÔÁ[¦‘¶ÆÄÎ|ÜI)Ó½œã‡l®ŒHŠÔHŠo‡‡a'ãoc<ÊØ*©¯ä?Q8S¡É]/ÍÙÇ¿—G2³ê÷Æé>Õz)±½wæë?½øÿqýÍQ³lÿ~$‡jWÝ^úÒÄò¢¦P)3ÑpÃG¤Ð5sî]“¨üõ&_.«ÌdYP¶˜iÖdXâ¹²Lqg!Ñí¦t,]}òtÇ^Q­›K.ÊI¼ó«-)ІžÖÜÛî²ÙŽe-7—“•iÝW<’í¹D{×ĵ©Ñ^.+›e¾‚¾‡o"$àOvw•Ž+(¢3 CÀt t޽ϳjÿ=p¬¦óUï:¾ë]‡©3¿÷N7…Øïg³w‹3%Ô¦ñ¸Oئ;gS¥e”ÿK`«ÿØ LügØÚjÐè‚j#Ѷá;=å‚C–üBµ†ÍT× oeþ%ñ@¿ñÃWÑké¨V¬Jò-™iŒxÚý©±Í€÷ ·B]4+ûTñEjz¸ ‰@Ü@Õàˆ†÷=‹Lðè3_Âá%C%”Ö˜L Aà`ƒæcë£íbÒ¼¥Dq¦ü‹Ö!¦X4‘•~ÌSšÎ{z!R!¯³©TMšÞo<‡õçq+ÓøChž‘Oç:ŠA1")6²«ró=ΜÛ4»d·{pêj&c \6›ûÞz Êï }S€vŽÙ LºÙ¥øSâ~«tŠZ«DuýÍÊ…lž}()ƹí”$¨Ò¹úazÀ&Œ+Rhê ¨T:輂Œ"}ÕaÛÓ\WòP ö»í2‡ŽXzòŸpðŶ¬,¯k¬†vs4û3‡RSþ‡õl´§%ç#[c?éi‰7¡5_a¯ Ì›‹®] Oñæj“–Ï…ê#ç>ù8¶Muºº‹cÆ¢NU'ä‹NšØÇå¤"°1.%vôãtˆ,ÖáÈK‰eˆ3èâHü_zVîó$ƒ-žFÏÀš<ض/?êÚSÎÅmª£M9å66µ[Ãã7¹¢ˆ‚´Í¤Î˜!«HÐÓÅ\d×\qN°™cãc‹ôÉÂÕmXÞ¿]¥-)"ó;‘e³“/¼ìmÉøkÞ„t†Øu0£luw£”¿‡‹°ØN2ÉƼ}\Þ™ƒÎÎàæªw6Ú9Þ>掼ܨŸOG¡–ØŠ‘ñ ‹ú&Ûk)x €¡-‰ BDOU†QÓƒ˜*’‘Õ¥ŒûØ® \ñ½õ~Â1šN75Œè v´I —›…ò`™C¶ÛÐóÝÚ 3›Nµ†!蜗ïr¾[â”^¡(¾÷£h \MÒàM¿ LW9TÄ–Z»ß;cîó1}TîzÈi–ƒ»w_>Ò3ˆú8!°¤NŸÖ—È‹õÚ×ýL õ$S6êœRÛþâ1°ÞË`qZ‚ãŸ@iÿìóÜ«&÷Ýó¼Û°/M«·÷ž€¥n&Ïßû•ôxí=S¢vÇ.ÖQ²Œtáe ˜ºNµ òd„”Ê0ö3i®™Œ8/e;yQø²âÞ¡ }æmS˜ !s ­K%åFI• l¤0“êé^* õ”µ ØÃI³Ÿ’m{Ïø¶h×ù&„P§Òuå4!Ì:lj"Ûˆs‚C­÷(}Xv‹ãf€àwgàÚw¾ÀÚôw-Sr –Cº›òS;í×,VcS Pѳ“YFÉmø¯ áæ·C÷Ê­pí»dá>L%šJíü¹uŒ•CHËzïÖÎ$DÁBÍ:ã_Úd‚¶‘I嘋Ys«zè†1®•t»làÀI m¯ÉzURaàœ¥A^ÏÏ•“@‰ïSV»s£¾´Š¼LT1·®yÍ‚wö÷žóÔ­óôjÌzå(X×î+´Ó…ãy^€z+jÛ|•ù>Ýyç7`é­Càn«#ˆ°ŠÍ$ÜûÉ' @û#P,YeÄ =Í h–X’~w§(?"ÕŸY”ÙåÞébDk(.émiÿQ›[ç1mX©¦I¤EG¯ÑÎÁb"4/òé¡Ë2•Ñ]OÜÞ‰¶ä`×c7x¾ZæSË:ý‚‡Ÿj÷r<#GÛrØX[ò²â^ž«ñeC™ÐZ‡>u{Ö«ÏwŠ=ðêî´r–Oñéûœ–,^.&˜Óõ×X!sÜd ùÅcéT¾C~; ÕîãÝîÇû¨#{ho”`{ØoŒrćWžO™vÜCw?ú·Íuöì+jÈA³p)íò2P®çóÁ¥q°y˜l‡u»‘ r¬%½ÙÛ-Â<‡ð¡[g™×­}¾<“¶æ_ 0Ê‘÷{ܰ…ÕRkN­k9RÈÇëæß8÷¨>¹øš¦4:aŒã|i<Í:¾çØå[7&ðåNŸ3…òì2ÆãŽYÚPÑÓ°¥±éýXLV€”ro=ØÖìßëÀ@VNû¬Š·î´æ’GêzŒx¶]ýñzÍn¤~‘±®í©'v©]úe;Àbõ؈1ÞƒR;L¦;Ý«+¼j9BpiY  –ˆKåÚ1Ã1zAV£ Ž`OF®mN«>é{ñÊmÔ‘µÆ.žè•ÜW$hõg\ްôyw®T}1=|‚cÓ`u÷'6ÜûÉEt¹A;ù¯Wûl9¸ÊÞh­”dƒÞõ—²ß|*zŠsÛ(5’ÉV¶k”÷%ÁÄý2Ä:%~r®çucFáTŒ 7 ®¹å1‹b˜¬¸E õu.möºÌµ1&eŸÍKK>³×¯qš~qtR^ÿ•)x`R sÈŸÃàx^mQv¨ë~5T¥k2¾áð?`Zy#£hÆš‡áo>¹I!µÎC_dä%ÏP¤aæC*û€»ÏßÚkAkðê!¤"Àt°ræ-ZÒRÍ] (Å7Õ“© ÅLêiCß„'‹a{*çv·ÂîC Ì”(‚|»ßzÖv®³‚mÔ¿ ?Ð{2!/Á·`ŒlÇüùJ’¤ õ]õä¡x°hW,]¥´ƒ^ð3v`¾Z;x~7 [UCBƒÉƒ½šǤ’Íæ{^èf®f"üêï_}ýó§ßÿðݧ~úøíÏÿ~ý†¡/ÞxJP´Û—¯¯þüéç>~ÿúâ›o¾þî»_~üÓOŸ¾õÛ/_¿æËßòçÃõº^ûLJùúâË×ßþÊ[•¶r”nÆù‘1Øo6=8g^B²SÀ (22„/ðs ôãÅ: !•‡L"´›î'h?»)kœYÕ|c\dË¥¥kE"‰«ºo훲uÈ”,Ñ™–ÜÂ6iŦ¥°Y]ÔMÙÛv‹è¾û L„ºž z¡•cb<è‘9eOH‰7i¶ÎnøißV”Ù°‹.h¼šÙ!JCÖ€3i=ùFHkA2|Ø" ÿý$+îL\6ßÙ‹^Õ­º”6YUˆ±ç]K;çK²ÙOLÈ,Ìèz,y¬‰Ù1Z«·3Ê»^ßï›QŠå ¥ÒïzÓêïþ¼*ü™£ÚÃïÏÍ41W4ÆzgVŒ`¼Ö>•¤‹-ýþ|³^œ¦+p³9CÌ"œDÐô%Šzë™ô‡ÿ èË닯?þô‘rµ þÚàüùþÃD”ôYL9ÜüG†€ÕzaÉð½MŒ¿ )¾•vX‹¿;¦˜ö|uE—á†ýzcöÐJÂŽ[yS¹+TZËa ˜G3¤%ßiÕoYŒ6ëšE™=)‡Ç¼³CfC÷ O±ÅP¡ú ¿Š±CQüFœrCÔ'xœ^ìmeKô‹;RߪA¤+¹FC.ýÉêz6j]úÌRMƒ2ñ˜E uãË®ëhÇÝ.úf¸¯#‡õ&+׫D>êñTo¨ÓÙ±©»æÁ€õ+!äo¥¿>Qá•ÇhI¿éCÛM¾®ŠQ šÓlY:­€û¨jA/ ÊÇ€Öž¦¤][†žÉ5Bäúž¹­/ß.E4öÔƒM¿#ˆ†¢2h~1#0n‹ æ#TVÖÐ ±ÕíóÔ”¾ ͼ® ôˆÑF(çÜ.bI?ü4—†'àøŒU.I× ¸çÜoñìGkõ"g4…×Ù_=Üå)o[¡ƒ'å9íý®t¡S½ô¤É†+íƒÆ´·IÙs¸‹…>Õ ÆîȾÌð· ÀÊÄ«Ùܨ|W¬:€jæ#µÑE÷uvQA·Ë*5ò´šJ3üÈ„gáã\´±yýÁIb[‹@QªYòœÚ£æ´ÁæGMîWk\ÁÈF –Ó^„;I¹>Í\¿óÿBŒÖ¾«¤ú~BLK±Š bÜ¢‘¬g#cÒ "ã&5Ï=Ü×Ó{½tŸ³¶W ’U“_ rMoódjôÕEnŒOé)(òÔﯬõ'6qå Xêd´¶øs^÷4Ë@l¯^ªÕ7²‘ÑD‚ù«ãsÄ`1±³óug«Sú”-Å™Ï}lÎvoIì=i.dæŸ ­6z>fº“º'›G3i£ä—O ÊÜã» ú8ëS®Ôjégn¿òJct@«;5-[L§ì{¶–²÷*êËøi*šc°àÓz?êŠg٥͊SÛíÊ4c²àg¿MÌžtÍ¡‰óÊÅ‘n=h5:£{ì|ï½ òo:˜5ǰ¹¯‚´+Îuw*ÏÙþ«M.í#ÜžyúÛ¾Hóˆ½ò9f=ë– 7:J-êZ–šÙ¨Ñ+ÞB‘Ð+ÃŽþp¨Iw„BÑËàåz|X) 8ü}žÙ^!˜ðB~¢Õà…M…™ò|¸jž4¼ã¹z‘‚fÞøy ´í ÑúUïVá—÷3J}·Ò• »{¢/ëºÅµµ²^·é÷q-#"3’Eº&3ÙÉÔ»¨„Ÿ[Gâ¨>o¥ùcF¼1ÙëÝBðtË^lU›É·ðFPÇ=®:¢ª¬6*—·ÅLSµ}dœÌŒÉ¾= áŒò½/.v±¿ÓùõìÝñݲQQO ÆË=€G¶È‹È|'á³g¦/•‚K49ÝŽ’`2Ÿ¢ƒ¸ƒ9LÍ‹KÏ%ª¶³teª$ÚØ|H˜ÜÅ95ét$³ákC4§ âÛÈ:âÛÖñlÈ #š`yV@S9ƒ&A’u4¶Þ‡·<›šËܸõ«œ&éÒ;e¥”åv% È'Ív >¨s‘½Ë+³ƒzí·ÎIôåF0è´ªÓ[W)™f(¼h«Z2:qÌâ–ìjàAê_^W¨b™À¤ŽçoÈÐSÛÅõØWMË& ÓK˜{t¾œ#àÓ^K«°Ûq_À»ÆVPƒ²nI¨°¦‰XCN0‹õÚŽ13yª–€Ûg4¶Ëù“Ž-¾„‘²ªÕ!¦Ž/»‹G”‡ÄnqOÆË,E_ÅdO†¡ˆ›‚7O#&ûK£¨ÅP5kQ"Ù/+ªnl]*¾ö*kQÙ*ÏjwÇçHAPùçØ¾Û"4CnCÖž0ÿc úñ÷þ¿xÑçëùúËß~Ì¯ßÆŠþ毟¸¸ã»Öª4Î/ ’ òk¦§[vš\m•ú½üöÐ$ÑnööÏ<&À±†XOˆƒOm™u•Ag»Lé^¡w}„ù¯•nç¦!-ZWdüœBáôn=Žv=. ŸrFö³¯5Áq]súinMôµ>ßÐÁ@†[}Òa޹sºñR;¢ú™j â¶©'Æ£^ÌÉ“QA­ç!ýݰó§µß]5Õ”øÆ*‰p=ŸÓ2Ô°rÌxQT·±úUa×¼süûDúîëÐJ­™1eE¥µ“yó|WgÕ³ s›Þ»ÏM“]R²Ú¤cêN¿äÚ—¶¢¾ 75-¼%Z±«ç¨Ÿ…Ò_k´þñÿÒ™åë·¿ÿõ_¿~­ÕÓšÿ¦WÿÄÿø¡êªÐ(€¿üHûi'LJé1 ú¡†¶¹vÜDµ­·þ% CâÈ»I[&“ÿcePSÁˆñê«»Îèº6c Šè †£K îÊTÜi™‰)Ð8ªwT¢»–#*™l«ÙÇÿï¬:z£‡ÏE!–‰íFßA×©Žžgù{qŒÍüPªâVÉœ*Ù‘Äf~±]VïyO𷫨Ž ävתѲ›´áuÄW²á.ŠèÎU–÷¼¸«•¬¶Î$ÍçªÊ©œz:Ü?£K•ι.‡LßÌÕW¹HÙâ$Æ×rã°èž!ýôc) éRRŽÂÑË'KŸ"õɽá9ÍÄGР~úqÊW^FýhÇkùÉX`È+V'û ,ŸúI.OÒ§ÔWs™!>œï;}\–}x.É*éašÙšwA Fa!Ÿ$^­úÜÕNž‹Ó’¨j×ÜdLH˜.;—ô6QñeNÖ4„¹Mbë]žOÖhâ«zI3«PߌMÏè/ãêö¸ÔÞìÄæSlùAsSšÈ©¡$.yç%1ÞZ­ÿãB8²lêtÈEò`O‹òuh%X õYŠ}ã¥ÙþÝèý^ˆ½{Äñm‚h±ˆK2À©%(ñ ˜ˆoñ9~>ý:k¹ew(^•†TMU¤Kd;Ì"¨Räm‹Ð²MOid>‘ûešF"¥ø¬ëäYs·Kxáïx‡ÇÀwO‰¿¨@Œœ8_[RºCªaÇvMOš ËÖÎ"–2Ïù'—%”âÉz“Y6y[)2rë²\_'ÙnÖófÊõ7„ΩO˜î$’P¼é9#/Àj‹©¡ |úx7—UÑ–wt \Ó9T••ÇøãžUÆ=×Hù+.1’ól0—g«ò!¢jîg¹]ÏÒðNõmM®KÓSÍ©!•Ä—³¼Rsn¾Çt6Ø-j{¾nš^r·°Ç8›}Ÿî™4K²‚Ž…ÎÈ!ˬÇœ£˜,'qYRZMö¢ª`G‹žý^ئ}îff8B5^à:D¬CMß³ì˵ˆ¦É-phúÎf\M|Õ3ï0¢A=1àõ±µr×òžÄkÓ¾>§JÙ>:ÓÞ#êpæ5¢FJñF¼«x­þ‡Å=ZΦ>QOLïx)€î˹îƒràNxÎÉE#”„¤‘ÓãÃMF§—“Ñþ¼ÁÀ½!ü™¦¥Q ­ABkMâºÎ{¨¥Õû ŒÕ0¯÷Ué2ÂW”<ÈÝbM=mï]o^çxßÙ‰%4Ï®7Äãç}tž˜*‚lâòõÏcGò­±ISê[’ú›Ë¬»$޾oÆ·ž2 ¾|Ø\+58U&ÒÃ]V궯1p Ýz2ªùÕ)ø™”ü¡Û€¡5Áþü®0ЫÜnÕJÆ:#%O mÄ5±±Jb½º  äG P hòypÕ.×ÔV9îæ°oëÈ´H1üö2²ZÇh]ŽfêÖþûe³¢×qEÑ'èw¸“€ iTÿ·*IÊÄ`ã`ì™QÚm[Xê†vk·ÏZ§¾&¶ !`’‘¿ê[÷ÖÏ9{¯(dob<+z3"¦=ÎÍèiÖ§:´ ®Ðv¥4ìi“Ç#HªaÙ³PUPQj /GHOœ’Bc³<½ÑB²&T»E¬EùŸ´ê–º\"”:¶¿‡ 94«×±ÓìM­Å§¦×8L"Ö9ŸUÁU¨UÚê¶>…|¬=FÌã8Æ=ÆBšµ„4¥€fÕ„ãÙv€VRg»hV¸Škˆ¶3&`O[ÛÓ©1+:RŒFLµ//7Û•AÑZl8@ÌVø¢Z»m±†WsÔx¾ïÆŽ9³8óU¢¼X!CmÛ§¦.šÏ¸ãÔbo3ÀŒÊh-o…î#´žâíç“»]@Äþ‰;ïeç…,{ÆOÚ-j·o=†_RY[~ƒƒeœ´bZß}$vçHÙÐ]åžt!‹À£øÇšåI‚]s•~0òF õé¬{å ÃC¶Àî^Â’ÖÜîIZr§ µ3›ËÁ“:_2apðó ®*4oªRâÜEÁU>JKú®jÙSt0m+¿Ö‹ÏâaÔºlV„ÊX&œŒŸ‹<z¨Ú jè8ÚSj]!)ô3x™ÍŒ€:Ò@©«Ú¢“’z%1›Ö,J®+H”ÍÖDûréý¤¢¨Ç–¸~û;UשÛÞôV¦¢M ,`]Iá]l$ô犀#Á´’ü†¬6¹72€×ïLCÄgéw꺸Î,ÃFkFƒ˜’æ†Ñ;™rhtÝÅL¦öÆúÖo¾-Gç}QðuK(¿{”>Of‘€]ôàö®gÖ=¡FZÚ —¢}Xhô…ߟqNJ¡¥Îù)û‘ÂkDÇ0³ÐžT Ï&²r”ƒƒ<ºìòîjÎ8ÌsEðžV„Z8Õ{wi`õTÌÅ|ëÎŽû5~ñ´ª¼ˆ•GÌBÞŠ#õìRI¶WmuнÄHñЙ‘lo˜nž=ÆiP[§iOåG?ôÝŽP;3Þdâ|uõíÕW¿ûúù‹‡Ç?¾¹y|s÷úáoÇzv-$gŽå£ãù_ÞÜ}w<{ùòÅÍÍûwŸß?¾öÙŽßïɯ÷¤Ÿüo>ž~ûúm<¡fõŸ|üáÄò³§3'ô+ן=\¼Ó_yºýìé.~øôÇdz^|òòöõûÇ7ß¾Ënï¸ýñë/ß|óøýg÷ß¾y{ûâîæûû‡÷Ž×ñü“»Ç>éóÛw·ïþzûpûÍg¯îßß=îééxþòþþí¿4ÿõã÷¯ÞÞÿøþáv¿ãcþ»JG:¾úæjÏ>:¾ú’‘(û˜ 7P‰w1J9'¨§Å¥ñ€Š|¬(|ª/E "OØèN¸ñ ›XB±Âš6PËÛ©è\û¹G¼TKx[vŠnr{A¥›§]¢HÑ5CÖnB?èêø’Ž©™#dÓ¦–0TO3-χRéIýl{b1ZØ¡†èÓˆ<³ùôš}߈#r. xì™þyŠ«€Ù¡|e;\Y­¶H!Ájúwç[{æP#Í:Âìšj©ëÎ'™ñ𙋫J#ó²ZNãl ?.š ­ƒfÞæí®øw:®3tW‹ú§ÿ7ék“æãÙ‹»û»ã<{té{ÚöÏü÷ÝÂF)HûË }wuÝdkƒ>¨T@(µI Ÿ5p€Ê¢Ù*‘¹¾R…IºÌQ¡k óRH"å`I_^]á¡]ÃrÎcj~>£ÿW…Dø­ëü–iøKÑŽ°ç\F¼¡CøGà ˆ¹Ädž%D À¿HÀ”4 ×Êú?šS# b}“ä¥d€t1â`/BÙÈ;AºF[MB¢Çv“éjO£Šb“/öfÔ nÏBÆðKðc ý XÀeÕyj›ç”¤IÏ×µªNRŒוO&Þ³ 7æ»Ö·˜QÏl¼b³ì9ÈS/M“ï*%uû)“¡8±9ÒV½P³l)”x•£ƒŽìƒR×hÝ,:5ïô ÆaÛ2@±ÙwËHÛÍ•c—HË«²HéÈ>)Mñ‚‚Ñ]¦Q`Ï»ˆ3»isÏ+{¿'wüdA¢bÙ³Ø ¸{ËÆ†ØË9މ&ªº¯Ófk±7NÚ³wlÐ(qNÙ.ßÏÕÓU*§ÙèçMaŽ«ƒðJ\ð)×fF²,ØHܯB0¢*°Ý®¹J$@K'/gèa:<åu’•Á«Û-OLK@`~Žâå©–KxÚ’÷©æs Ƽì`P­ÔeC"L;Ú¼öÅ¿8Ú²ìS©Àb#VN»GÄgÓT¬|m7Ѹ |î4ÞS[j‰ Ç©³Ôè2$2ïdr­-gî—öYÓ<Š#nJF“„‡:cФ Ï ‡¬ÈR‹ÝˆÂŠCô™Ñ-}be[M” +"~ÑëäVfóyÊTœ8XêÆÄ„äõtÑ'"…bjI=Î:] Ç°6×z nƒú&z45†ÕŽ] ÜD:#è¬Äœy_“G2а.U[X´ùŽ/5ü„#ÂÚuÈÞ@£±8¡Ž˜•f¦¼6³#b™bÊ)Ez†1©†r`_'—uã`-A³GdÓYâ#¨ÒÎè«k{…7¿4ÁO»L2ë¿Mã?„2~Âjô”6iÿ¬ðsÄË$šOô)¡tO’q¥[Vììv‚\¶K勘XÚP¶5\ë ‹ÒvJ•…zîÕG: ±¼Ý2Ëöñ2²â£ÇôKj8A ˜¥Áw0åhiµÕc•¨! 9vlHع4]jRó̸úˆ”€Ú•R¶ßLC•n9•ß§ÿ‡êë;>¤Xu\Œãß0±w1” P‡JXM…@ Xþ Sð7.>¡P¡ÍŒá0ÔÖë²öÃUDÈh 1®S`u_içìÁp5ïG’Õú)¹îð„`¹kÒlÒF™¼ZÚ$xJ ´j5‘oùC<b…œÇE–/’>“––kÐ…4üR+iO2Q!~¬†¹ì™Ù¿0×DoÕQb$:4ïúo(UAáú±-¿QZð¿é6X…²¸P0ÜW÷¾t-ÏÃç9Ž`$@¢Â`±L›'V\1Ÿ$¤°í¬×³ZÌ_þÔM)º.uí—›ÉHË]Ù“ Eܸsë´—ŒÍ‡/*$“%Ï;€Ç& {B)3 (™äÏÌÜcãQŸ¾aÁ[©>Ž(VÇÊ+bzrhd¡X §J6ÈK(ÐŒhgîuOréˆW=TŸå5ï ÁN¾<ϧËñ¤Æ4žÂ,—“ ¹L–képý0&>Î@U4ö90·Õ ¹­»3Ü*YÄCRr+720tRÄD _éÐÀ±8䲌•Û%3Eøc´è¡àÕ¨:äð%ÎD‰Oé!"żä9Nd‰?üNÞ¿•>幺¬wœ6+®ÒãÓÇüæ°º¿SžÃßiDñéÑŒ|i“ø´>ýea¼š—å÷ßi/s,Ém,Š® öˆ>Ä Øµ¹êý»}ï« é´'Y™üAÀÞð”èE"µ”16€gôÕIYí]KÕhqž+Ÿ„[\cù,Z¬­3óÅóêô+Ï{»‚ùSúÿᩊ9_oSòÜw|³T¤˜ÏZ(ž/hÉÇ\¶”J}äôZ2ŽÉ5Îhó¦*]H*IO•´7<#»“ÚÖM%pýœqk‘îÙBÕHµžjoâ0´Æói3D=P Ö[¹ ×Xê¿òÑ>dÊÀ—£ŽÚžW.ÕR²Ø‚× µÛû\‰£.8o é"@ztXñœŠ¹øD%›Šª²²»ŒØÌ“"¦_§˜ßüH»ØExTw°è0)¾|žd¶j‚íóe©¼)¹ëÌ;Èt'´NK Ÿóó¤á]„pººrõ»Ó97PÆZŸ¿‰ÑŸÿ„›ü?‹="šæ„I¿>‹S„J±´ÛWzHE]JTJr”ÂÔí¹ö‡¦jýz#ÈZvî¶«jodˆÖ|ZÖÐö墹YŸ ^t6ádË‘mÁÃLÇqÌ®]ZwƘâ1Zs § …h)d5Eá·w³ŠA“éÑV¯¬ KžûiÑ—ØUÂënuÜAº á(%àœWÈ Â€§óÔóÏX²¿Ø”õW›ÒÛUSήÑr}{½*81ÕÈ—œã(ß·ö0ò˜µ–½–Áj üù%7𥠾ÍdK¤æíöòœ‘.Ùº Ì>徕±¡GP·93oýíœùÎq{4‰õ£ôóK»ç'¥È¾g¢@5ëtãÞE~÷¸yÞŽ·+bަ'"v_ßBSu ¦Jö0:]ŠrFXØ ñDÒÞ¹žæ«ûc0…Ë=ü%[Œ8ûwhNvøÊjU’‚ei"ø^.ìÎø1Ö—¸¡ï£Êªï_¸Sëç¹é¾GØÐP6Ï ŒtèµKÙ=«ÕMìEs¯J–¡‚¶·HbÀàûVž‹³Eì ôÊ#‡½”ÍMC4à­²Ÿ]1ÕÙ¤e^3µaÂ=‘búöÚd¤XÓî ÅjÒ.5Í!UK«Ç3‹:°\ÅŒ«Ï‘\ßÖ/âcͼPŸ>Þ'lŠŽ¢¾Ðnyneº1gº¤@¨‹ _{?÷eoL Ý5Ê{XHþ7#MÍ;‹¡Ÿ­ÄûnI÷‚Ézæ0ÀWÛ´0Y]{ôÝöõœ4ª™ÀÑ\aæ,{þ¨K·Y˜*SQóÔK[üªH³)=¢\¾§Ý~þ›žYGB\°²dîtÚ%¾õk8ŽŒÔÌW)û¹!„T´\§ ,j¯ ¯U:>¹Þɶ.!ïó§¡¥|0´ñJÑé§Üe+«ßŸUñÈwkdMØg³Ÿ2Þ¼û\h˘‹Êþ^9Râz)Nâ(m®¾óÜɘ†¬‘!Y³^¥`ÌnnS{ê=\d¼é×t¸Ñ.)ôҼ碲“T“ÖuO%0ݹqÄŸ`Ú´¥<›¿:?´ËNÿo) FK:oK㊨Œ@û&‡MÞÊ«öå³n·²Ó»Q‰¬Ñ¶Š óµö7ä”2$]ôDñ•+XüðTþ0i1ºCH+Ó8 »hµW”t¡À¯Èñª¬zÖÃ#؆ì:ï82Wó=žÓN•*M –p*Òì.ö©“qŒÊéçÒ¾@£ú, ›2ø.Ò±¯âFÌòÔ±W€¡öy¼“¤[s•ŽBGªþó‡ú°RAê6:y¨)Îm»C6Ó‹Ü3 ÀW°žÞšÞµÙw§2R׉ò,¬ˆ«¥}(‡Í¡ÛÓµªFóHû’¬¸¤ óüBþ-ò–tYgÛý¦ÿUó!A’¼ ?E™û¥_Ê»l1Uä|ÂPÏnJ£RI¨ij§m9^^cöžÖš•UÂlaXÍE“~)É׋ýŸ5q¤0nuݿNjVÉÁ—ƒ_) c‡úê/Å®îWJë­\PÄUsÎoaQç¹Â‚ù¨P ß«>¤'åOÄjˆ~…>{#TìÏ«‘–=Rt›ß:íÝÇÕxŸ•È.o„¹‰.ï&ò¥Ú¾…0ºJƒN¬÷KåÕT¡f]ÐQ("6üÞ«¿RÓ¿é¶SÒw¥÷xzâjzcmÕ¡â^žuZ_™Èyw&H.ëUT˜“ˆZ›@¾W7‘—l¦è”³gêž0ã—|ã zýBÈb(8¡<Ë(@ÄnP×eàÊ9²fÄ8ö}ÙÝÖ¡sA—Û¸qyó®òErgÐC{¸/^£yf¨pŽK¨^þWûþ‹b-—½ÌLYï¿ʾe¬Äg¨ÎÀ¡ ¿.Xd¨up¾=)Jªj–F$âÀÅ@ Àyë[¢÷‹ï"Þ†"{·€9´=>Ë‘—ŸìŽºÆe™k„E ¶;—Š Ž9ŠJ˜šW½ª²µ‰!p±{8CœsY«zUÜÓZÉ)úTŽðÖ>—Õ‘:†M˜™ÌkÍàû°ä>žJ%È ˆ3ȶ¬39c§ù’ÎÏ[¸yõ°Þíʤõ*=\éLÀ_ºÿå>åå!QãŸm‚%h­ÌÖ"¼Ô½ÐýâúCö• ÆzXçD¼ßF¶]· ¾øé~yÒuYÍ[º©ã×€9¯†åƈöç\ÿ]¢O°Å9C…ìÌ[LÉÎý§|o„BÞïºÕÔMôM¯r^ZÉlÛ­åø¾M³öî9ߢ¡àg™¹Mµu¬Ú)\íÈEABg¥QLüë!ùg)f©ýVå—çyuïô‘Ë­›\n?‹Ï‘ÙDt6ÇûçØ]+Œ9dM{õ ÷jÀàGA·ßv@XŸxp$c³X#ˆD;‘è(cžQÓ'µ¨6¤/Ü$wMW¿k†ªÆ=øYg,…øåèaS-N2G½‡+eÙwèë‡ÌÕŠÄ lÌÖ^DêØõ~%YÕ|íZQÔä¥Iu%”s¤Çj üÈpãvâüÏÎlëLx#õ¼P­v°æW-y’F,¿¦›d“t*SJ~û2‡‡`qWÑXj &°Œè.¦bðÖr[Ìb(¶Ú1ŸŠ´ñÄpûywDç=ø`! |„!ûû¹ÍÏwDI>BçfWnôœ'Ü@jŸÝÓ}·ýinÙV²“"D­ryü^1i¿“„”ÐÐÙ>9yÝYJF;ïŒc#Ǫ97?Ã7­·óŽ»Ëà5õ„V5ŸÙ =MPÂHk°Ì0×p¨-àQS-ëlYæz7nkf7Ä d#)³k0x=àÚÙ[›!Îî-âø“ð[Þš®xNËî…3ÎÝÐÔ4:GCaC¦:¢ ÃÊŒhÝ]c8K¤2î:eaf x9wß&_2‰Èñê#Ýh/Ç*‘œ  Ýå;ûݲ¹ŠÉ}³}Ãñ É.SË­Gôèiœ›â Ï0r—0tቄª}#U»&ûa’´hŠDÍ ,!‘¶òâSHEÛ E+º]6H;H–èv3±sÍìE‹3!ÅàwÜJù/!ýÏ‹FÑLjm`1m9Db@2µÌKŽ¥Æð¦"rÖÎæŠÑ=%CöV¶%„¾+ÑZ«Æq\äš3"»›cØuSîz…5”eûØã‘|][ây&íµjãí$ïB©6×uÝYm£Ç¼^[ÓCͬ'Ÿ ‡ È·,W?Bœ¬jeÄ9T<ä ø¶F*…Á-w½¡’ÛnéÊ://Ë“š­ŒŽZ·ºP7z'Ok%SÃ`££FŒZ¤¯|)Wpk‘â†ÌSŸõ¡Žš’ãÈNàû w3J¥æZ ”`Œ‘ ë×L­"´†·TMî=s‹€¨Þ±¾‡º/ÍÁ õRÕ¯}¥Ø€>Èø!Âj”(A»0JGNkvŒµ>´|Ý+î´°ÚÓ ,ûûêUi²wZ1‹ÓB'*%uKÍEþtŠ˜…“šà¢B‰K1PÍ tðÜwØxÛ_ñô¢Òój¬¢ @Ãj¤ÔÉâwì(ÛVÕ rÔ–VBíÑøŽoF‹|_ïæ÷<ôd“=GüýôOñ¦B^Š÷Ze¦õ¡Ø¶¢šÇxÎÄ6ÿårªÀ(-ÕŽ,ꙓ¹C"iê¤}”ÊX•GG+z m´dŸŽÂÂ5ÚD£OÛªü‹ÅŠÃI c»}¹'pV×¥ µ| ËtÔrHJšŸ±È+.‚j¨›æ†wÂD š!aEjäX°üe/Ú]*`Âwî^1„8¬±f4œl^ùÐU^Wp2^!ˆ…¶qòÆ1 ®Q¨ö•Iõ+Hœ“›‚rË¢ò\SúÊ“úhñL¼Ø}½_7Í^g>“àš0™¾q\±gØŠ‘G)RÓû‘-Ÿ©)bOdÔ¾ëÒAI~ÆùF]Öl+ë2Cª¢vÀýƒêvÿouË0ÁâŽöŠÍK¶L8X]À€fh2E¤MÖ4͹hÑ–A›´% ×!/Úvšºz64¿CrÐ÷ËŸöØëú7gÒŽZtæ 0­U'pbN|£~Ìå¶uµ½¯ø~a¼(ØŒÉFq÷SËS|”€''€×;,äUÅ¡“*˜¤^&Ò&ùn‚->¸p„ãÙžÈø„Ü p²ßBgNa°;Á±Ñ‹réÚú‰@¸ÀRL[†h–â;/83V…ßE¿×jšÔ`%sɘ™®ôŠƒ€³Ëc›w S䳚Û#í‹õ <ñº¥"å7>«ß8-~x+ØJEhÉ׊ói†wЇnÑ(ª¬u6¶ T-­ØI†Ûê÷;™„"ú娠o>¤¢¶ä­†svud:µ…­’¤Ï„|:ëÇF7µµ;ºè3†¥^­„–¿B,x¨:lCE²R§FGüºjX¡*À¢Ÿ:çáÞR¾ªêÇ‘m$ Zs„ð©ÐjhÑAáÃãw*ª³O ç±*÷Rs•«W@ËÏÒg!±èAó1p^§PƒÿSÌUuºÜ`¦ÄP(æTP>’GŸœÅÅÄñ¤JâSŸrõÒ¬§ß²1j1„Ÿ”§Ü…ïž„þÐëü>J•”´Y¦ÆÚÞŸO8À$XÍS‚Ð\AøÞ£Z3¬¨ÒtqU™çÕþ,VØbnj–ÏH?g¤z=t¸_]óD€Wµ(à¹Ê½§€[†æ‰« z@}••Üò ÷\ÔÃú9VðŠ|ÝŽŒ€/ D©ö{ÖoióÊSšý®‚…óU±+Ãla>ê¥ñê-”c¦ª"@*2ÀÔ·øŠd››ê®q@·Å;èõ•¼ˆNIïMï—ÏÞûîwIl~õunúÍ?Ëãƒ/ž¿~+¸5íò¯ßþ~_}wñœþ`u{gu˜Î?XÝßYÝ'jûVwVZåVÏwVO‡å÷«?|¼ÿãGŸ~üüõ›×?|÷æ™|ùãó/ûò‡o_ÿù«—ßýðâù£Ÿ¿ùþå«_2›ÜîÓŸ_ÿçM_<ÿôüÓߟ_=ûùëO^¾ùùun¿|üòå‹ÿjÿׯ¿ÿäÅË_Þ¼zþí½×ã«oß›÷ÿòøêK"Ѧ%û)ìÁOw°WG¢%›9áG¹6[‚‡€R/Ñ—¾‰mÛ™îlˆ¨àÀRþhßúÊ™‹ Vq¨±Kr ‘€Ë­S{‚:«T:œÏ!èB3jqŒã‘¿Ü…¹h-Ì¥s¨éÓNÀ²Ó ju}éÓBuÑŒ¤-ã7q•ü½ý£e"ÜCB&Éóz@úŸì—ËŽ^ÅFŸ€wø‡LÚÔý¢ŒÀ#¤(AL2Œœ¦ ˆ¶[2öûg­]ǘ˜(Q${LŸýŸ:Uµ/ßÅÞÑ õ>‚ÔëL‡wæ‚q4¨,œ;¬)b‹$Ô >i‹ÛâÂFŒu­@–…Û=|ªpãRnC–¡J»8j¨È+ùcÀÿðßx¾}þå«§W·¹RLø[Fþ¯ü÷ÏÏhñ±¨¡¾QZ/?Ãp (˜òÅ´#˜™3 ]U?,­B:ÙåS–ëãh°Ì8Ì(Š7Æxª{Œú±*È* í$& <6¦Í_2g@ÃåuŒÀ€í¦"*$±C˜ytÃ^Hô‰c«åé„ ¥xîkHçMò,V¼ŸØšÉç;¸6”¬j›g¦/Š H\WOVåÖsmÁ#lFçkÚ(ÎЬ ÖCûØ|N5Ú:D<45‚·±KAHñ¯àŸˆÌ+²Î»ì30Õ‡Óùüch¸ÿLùžU·ÉV+c›d|rDÓ™!:‰”¶…2&k’@SŽôtêmá Sù›ùc°ób$´sÛ9Õ¶Q ÜKßVÙkåCÀˆE£;ù‰V³¯÷­F?Ë¿vkÏåãܘ˜?ÀDÜÖ€eomË0‹Th¥öFt¼(FeÆ£@Ömü?3sB:|£ŒˆÐ–áVbyÞÓ‚kyé>”J]Ó†ÖŽ:Ðè\Uä5z {ØÓ °L¶ˆFxÕ¶bHÃ’õ“M²L–p®úÈ©âЮãJY~Ò°Ú7åq§.(°c^ÍájYù,`hn£ù‘—E# öÚ£¿W ÃÊ‘vJ1Dàír|³‡µ…Šó*†0­0ž³œD %it¿ø$Ú4Ôñ{Ì+.ðˆŒþøÙ»T™wyÎ9cõÞSuíà>®éžiÏ“ç¼syì‚Qç¹ö/Ó°ŽÛÂ#µ\Îíðž4_8+èó•âÐq/9ã}<%i(&Ð3ÔÙOâÒ<¤;=l”á'‹| ,–y '89Bt •èS®•(HRw/ÇÀš-e®Wí‡ôe±[Š9ºÅŽÕ¦h–—ÝÒ£0lÙà…èõH\¸ÍFël¯lB;.’~êRVvu8vÈL¾aEkt"Uµ^ψ”g‰é+ìîé÷tÁ™*Ô‡çR–x’îôQ±;”«ÇÙú0¶HèPÿ­ÇDÄwÉy,›[T`Šç ”˜ èÒ‚ëí­.+‚¬dŽÈbSt¦ t$ÐZ5àB Ðh9ԊүĢ¥C-U˜a ìŒÿS!•}=·PÕŠ¨y…„iòÉHœÀìÐjQÖ* ôTå„‚šSÜðo¨‹òÐàüA£Å:§è#ŽÆåMÅs92§Ð³s×\ŠT•®¹¤QÀCáXOúšº“(ªäF*ïBSÔy޲ð .’ ½–eÓ¤<çf6PJñ˜õ¾Ïšýìk˜œ£Š9ДD“@S4RÁWvî!% 5smˆ4=FˆÆTÁø®‹î6€ÜÎö¡ÞFF»% HØšÊÙ)oµ(•‹r,¡,…ö„Vf,"uk‡6Êr“arÃ4¡®#ÐG¨)êÞ¯EeÕ¸S3“ÁË;¥l‘¦×½¹!f…?û­©Ã‘Ú¡’IZ°Ÿô—MIÂtY"6 B»û]k¨&]u\Õ¢¶*;z¡F/,Û¶«älxe›ÊÀÜ™[pž$:ÛìÒ“Ukg1sômo^±ŸÌÙì—„"„P?K¥Æ¦¢ó!€Þ<‹(Å@ýÛ?]IZæÑÓ¾³w;£Èxe%RÓin”"*QgŠïçæÌÖΘ3#†p'„ÂxŒPð”!yÊ@ž;Þ ²/áj\;ï"`EHAe ÊõNwÜÅ5Åoç*þØKÜ-¨“ôPŠ ÓNÆÄJÀŒÈxÅ=ÞK¤gä~9xxY^w’ulHÚü4㓚ݦÿú4è]?@ï¼êÁ—Z·}IHÁ¹×dÑ—L¯5Ѝ:ÇC«QvMmHV|à!U0M-jn6‚d¿5²Ua#]4ïÔ•è³DZ›˜Ô¦@4NSe›‘Dã%º¿eH°è3v6N%š3Ôè‡<‡ ãœq•R2¦À )ÜÈÁ£ÉáaO,ȃׄ×À¡0y%>S(çÎÓUwæ:­ÎšwÝKh‰Û„B£˜Î/U @ °ì˜š˜ûØi;£ïœOðg.GuùŒ@H’êÜ tÃöÀÉ”h¾|dÔ•„–# -‚Íúˆ™ke;HªòKéé.Y“ÆGWmQ#qc©) õEòÍa:«ð‘T†¯Ñ+D¨µÏ› ƒ®<É›y_X«˜›ptÛ­rŸ²¢ƒ–˜ÞouŠS4ÐBþ(º9tÿÍNíçÆ´…NxÍXAh”óJWµÇÖˆ@‘%«Þ!ÑP†‡ãan«â›LÀxõ3¿,ú·)ù(Дŝ_œE¿ú3ß¾øöáÅc¼!ëí_=ÿéú÷óŸ¾üú«‡oßüøýÛGöxúéáç¿ÿíÇïÞüðÍë§ï||øòÕýO¯>ûÔÛ_¿zó¿}ûðòáå?^?|÷Í›çOo_½9ËÓ틯žžÿ¯õ/Þüðüñéç·¯þºšÖ@×ú]}SÐGˆŽ…Ó¶XSí€3IMÈ l?ãtgOÒ8¨¶Ó`~YÛå&? ´þÞê÷žEÚ‡ Õ£uï€Q4ºàèÐc„jè÷D 7Ã/ép Q¨¢‘w¨Kö+ðxÀ9±âÚ茞°¾‹}¼S´ãÀὉ€ò­å°áÂî$à䢢*Ùž†ŸÖ¡x|¦š#–²ú¤ )š@ˆsBWÞí^ýò)Eø'VÒ‰4„ØíN£Ø[?þºÝ‰fu¼ó7a#‰Õpáx?ޅÓ– L2<¨‹Gî"Æ>ÊÙó¡€Bb-ç`•uÚ¾'49_W¤SÜǪÜI m¯b,ã€Þ(O©Ûü6!^u¼ì6ìGÖúYWâ˜+ hdnãwïdpyôì–PNLOsÎ*7RP¥)“Ù`4Jð$ê$[ÖZâ%… ϵD`:'2öšÑ8žZŽâ­Ñ^îÖ‘Å0 ­À=L³G©_ìÔ¥lÿñâ‚o;v6ƒóô#ôG ΄ýC ò8ƒ,Ãcugœn¦¸C@&·Z³°Ù0q¯4¿”Õó Ê|\Û›g/;Ý´3¿F1Õ䣊¼Îœ6õ ˆLÒûÁY£$ƔĚQ~ׇ¹ž]ÒÝßÈ³ÑŽãøƒÁO©ËlÙ¿_ïùú¡Ùß´ÑœUÉÐõ\ðÖ|ƒô`qî3+†zs1f£m…™jòžx~¯f—!v¾1v«aЇ n]-I/Åâ*lsñ•œÏVäûô ηÎþ3½7ÆQ'ËbŸe eÊ„ÈÂĺFTަWåSš¸dÓ›BâѨšF$-Y¬I?ÇHî¶½N¬ TïG…ïËØlµÕõ@!’VÕƒ.ä”uÙz†·‚„H:9¹ÕW'w!kÁ¸ÎŠxªlˆ ¡ù¶1UÁbozóÕ8NHï(“´ Ù[-ÓVw¸îé5977 q⻯zqDŸ^'_¿ãÁ ¢PBÓ™÷?B¯©us£a0%KUÜaPg4¶æ8Uõ:œ3 DÕü¹'¦P©ÆÞV¹¡ktj]Nꦵ’Òjn `{m'^ï«o¬)¶+²Ë\H!Ðm–¼:]Ê4Ã]ƒd-ƒ‹î¦‚ºó2]#‹ÂÖ€I]ç:ÇRP3Í(ì@\vÍžKj0¢ã#VE@¢ þiœPk9Ο4øB‹j'áœ×œxy’9¶ËZ|~–†<ºü5Ô+Wª›‘µ°1žþ`¢â endstream endobj 30 0 obj <>stream H‰äWÍn^Ç }‚ïî&€ T×Cr†6+[ÝÚÀA‘ì U–c!²ÈÒ¢oßs8×€ìU Ø°Ž†w8äá!yÖc›¶iê.±ÉÙÆvy"f"ØÜꔋk!&M ™#z!n‡Ýô㔄ôu*|îëçÙç4ßÎOoN?}÷êÙóû‡¿\_>\ßÝ^Üÿsû3 'g¶K—‘öt{öóÃýõíoÛ“/ž_^>¾{y÷pÁ³O·?áä÷ø{j[Û~}}òíÉÓí×_€”Ó&³žšÛ;€Öl78Pv"›‰ï=ˆå®–¶™âÙ‰3}o®ŒÉw¯þúU¼”íÉóÛ»Û-¦—›ðûoøûÛIB›Éˆ&n…ïN*m3ñ„Ñv› ®÷Ùüj&±"ºf1U¼)f×ÂÒ}âÓ›ÚYÛM馷½«ÁMcV v. ^gàbOx亷0-3Û5Ú(,˜ZßÇèÈ¡þcQH4xé/ /3@î^X6x 6pÂo÷Ý@féc.@<ÉjóÝ[¹ä»"Ï8pE­>äé‚´ÒÜ]véJËÉjÒ³i!­ãuŸ²úˆ´˜e×±:…¼´Á¯ãQë>0:fTT¨\aš„I@\›÷ °êÜ~<1 ®D#ªàJ•¼Y/VÔ‡„ÛŒ /2Œƒ^Äð*c@˜êE§°"ÏŒ&…X ã$ÝG딀}.EºƒÐlìU}6Ii”K!|n2©P3PSA Òw™ic‘dE¬á!øv2_^ŸÃyd°5,3(s3ž ß\HÙ".t›eN¡JT‹^âqÒ¢°`)ÊD2”Í=æúžélœÒÐ6†Q-ëc …(0e¹5&5I…Ëå)3Ö‘ªüËz_ «²>¦ÌÞtgôp£Z¹Sᕯ¡£0¦vaìͱzˆa( ïN2ï–yxÁ al\dåËŠŠ ÷üø!zÄ9måËuf¥¢ÒC­0W ™‡Ý¬AƒiµXÞ'Ç$¾¤¯ÌnÃC³ùŒ#‡H\áC¯Ê¢ÒEš¯¤ˆ›Hjq,Q#ÁñpL5 Ê"ÙJ…d–jnh±HŒãÐåÕ+™íˆ'[5ƒuÕ¢ íªj%W‰ú‹Ë*ä`¥¡T­1n˜0_Êò­¶EõAŠõÅùÆÛê%­daC90ÅÀzÔ§@ ŽCDVR€˜ËB>’¯2YÂøþb}ô_Ùž½¼º¸© ë„üü|üûä÷ç?¼¸ºx|¸~óxƒKî~¿zÿê—ë×oº¿{s}sõüöòíÝýûu‘mÏ~¸}øïF/¯Þ]½ûÇÕýÕëŸÎïo–yÛž½¸»»ùŸì/Þžßܽ¼¿úOH*éd$+ÖÖÍüƒÓYœŽøä&ÌT_|«æ ­….®1ºêÐ;Ù Mžâ˜ )m,5JZ ©ó[¨ßî½^ô—Ì?úîü¬ïN*1çNÌzíAR)8ÊA9&#£ÌèL) [kõP.o¥ж?0|BÊrƒ$bZGæ0È7Š´U“sFV¥FÂ(]Ç\‹ LAcHD A­lp‚Fcm¢ÐŽÆ©‹ã-¦èÀ†ñKjN$s0c]ÉC_ª­YC6ìBø:æ(-·ñ}`ƒºcó1„Ò6 °EØðÙ/°(¶¶ ˜õ±–ÇÄR€SÔ½Ú:±Óe^غkàl«‚ iœƒk©€Ý¬ˆã»±= %DLc½ƒ§v­W81Q$’¯—&2.˜ñ¬<€BjH§÷‹ãT*»ˆp>œÇ—¤k!µ˜A;Ô²Óc¦g¤ÂV0W‚r6?&!b™i—8’%V!çØ™‰iq4I`x(“ìG¨ŒT“ÊzIM¨Oé1ç€-É¡ŒÓw 2*&šÛ7 r®£-bvì^sñvÛ}‚£$¹ë± ×£±v±óÚpç@v†-É&Ïôe|¦Ü*AæÉÞÆŸ…£ dsh`Äã‘50øÍR«A@P1K¦aò$À òçÎa…{yRd?‹s*—Â/êõw¨¸ Õ|úÚ3¸7а¥Y F© ç ÖBõ–ëø&D~¦dÁ1¬ôv ¼ú;rƒ±¾ ÷Zz³ƒ²°ëFmC˜iÉX@!µGå’0ü¶æ h]£ $®géÞ•wû!SŽ™¥ (Á ‘¼h˜Š}Ý„ésÔ\6;nàÀ59j×äo‚wúÉ€žŸœò Å!¬1°5﵉«kH‹5‚Îä&î ,½ÁH7¦8Ñ™Aô¾ÕZT½X¡^VF¨ý*øà¼xr÷Zî!cœ¯k#ƒ{CR&œUÎ’ J•Q?ûÀ9.T–D1V”YHm(tnÔ«;ªÐ5×Å9  —|Q7Y{Yvxé-jè º€~òo›X+v@C>˜621¦Ujãàƒq¨¡Ü€¬-6Ô]¬òÁ%„AƒÄ’U q,šQÄè%E ¨ˆ*ZFk'];“ìˆ$t)TMúÜ@zlhsQ1+Â(Œ‰¢¼1vx–Ì Ì˜GuQÅ–Q©äÀïŠôr´ÁJ‘2êµ àqY¤ïÌ!ÌXŒ·ŒÂÐ ªŽÙ x#~yúBR?©uaô>´Ð/ôà*å‡ú¬»(xTÊz÷§ÁΧÑéI”D:¸®5²ƒäc×ú"™í3‘LJ‡tºôM»;Š9\Ë)˜„LoLaÂ;LµrQ:9DqU„ì!ÍÐ4¤Yòh©˜š³h£ìRlÄŒ‹ý‹÷rÉ‘+×è ¼‡Ü@7ô¥¤±—RS{ÿÓ>T¶í4` ßCÖ¨Š‘Ò•ÄO0èžJÁ jnìVR .GQÕPmñ ÍÖ=U¹½¬ЛcÍ P°D-ºv%.¤å,&´¿ô7;~ÛWI›JGô!NÚÒuÜJ¿©ö¨´ÚÍúÍ" QÉÔ42¶‡ø¾…뎀b\ywì}7уüÜê5‡L‡ÐDÛ¹‚\Xĸ›ø0‚ª6¦K9ïí5y-Ü tº‰6Q5KõÉá»”í5Mµ@1/ýäΡò$¬šJ´®µÕo:½åIøuh­+¹qÓŒGÊö1ì‡*mÀà¦Ðòèèö&ñ<=ýàÆø×v+ò†ÑcS˜mKÀ´dgœjAáÙ5üSÕèÍ~,µ-Æ(ŽM¤ëlTØf@| ÇJW‡×HAW$ïÚÍÐËÈÖ“S@‘Jn(é :ܽQ2ܪ‘˜UÑ-{èg“GóU»&‰UdGÎ6d~( úA2SÃd#™KkÁ_¾’lçyûVe ÀìL1˜4•ûÍŸhAErHÙ>£ÔÊ­ÈÇ©¶P%‰œ@m1…Á=G PmÂêÝ—Rÿú'úS×8ý£¿£>]t×ѫٯ*Oä;*àt—û Í"MÝ]y5·T·˜Ýf¿ÿt½ìW_Øo J)Êû£{‚8· èCZ?°=ÊnÃöƇbðu”Nc¦þk=ÆLñ+»’Lس·–ö8¹ãðM#zù€ÔZõ›¬)¸Rk"ì#e# àÙÙ̗Ͷú¥ìsÔèô…ƒ ‹;fÊVJÉVBù„ü¹y–{Þ Ä<ômßðxÃnÔ<¶˜Nfó>zôÜ ŠÆ+é*Žœ²«Ô£î\-(„hÀ•§GÙnþf• ô©4ì¶ý `æ12󛑨£Çkèþ˜Íÿ_3÷É=o;{¹<0›]äj~X„*‡„ÓD¦”ò;:yû}Ü icZ#•ÃÎVBШ,¾PÓ<ÃùgÛã6Jw¤€óu…ˆ%×­jÛªM6Ly‡£¹Œ˜£¤ ýM¶@cR{Ôzå(åÐÀ™£§'•§¦>ÍoŠÀdO¤†wÌ!gþ‚ÌȹcÐx~µOne•®µsA ©Ót¹öužÇªÕræ•FäÐךÇšõɇ;7V¿’9Ú¬—Z7w¬9½£J {jŠ™3À‘šÒº5ëZ-Ïš”‰PK6)+Àª@ Ü!}´rg[C$ß7#Hq#æÑ.Õ LCÏ[=îÏS‰"ÊO4-ÊŸ* ÀiÇM‰n:4“Ž™¯Ûõ¬Ñ˜e¥Mçëjä€uRÆš¸‰F´xç«çß9 pTù¬‘¬®ŽÈ ‰®dKPËUe,Oƺ¾”øŒ|Dduݪo²ch¶qAJõ³ ôÕ×÷6'l·ü¯_@¤!d1<â°üÅŽ-ÒUR,ïxNÛxX›“dKßÈôy{Ê ¶ÉKK¢{U~»bÏåãXïã Úz”žÂ™t«ì5Äl&†«°÷ðTÈ#-ýAN#áí„j·€–ÆO7YÍ|µã4Ãé .!“GØŒTë&}Ù]Ôbàød÷8éø}¯xczþ|”d²3 š“°‰àsLÃïé§zÊpÛ‘ÓÛü®DOÓš¨áM…ÈÉßmìK|ÜÏöL‡ ˜© Pºƒ+ÈÝ«ÅÁv-–¨U€3 –5ŒAüÍ€u´\B„·í¡ Ýj0mß=ã ¯éègøR· R& ˆŽæ ψv?ì²O¨_¨»f\ öfÚgÝ=KI­GÎq¿+ª–gÆlÌøöÝš÷µ‡¡ÓÏLÏ ¶äñðåJ¦éÖ06Æõf;¨cC;½‰È o:u<~‰ÛÄ…¿†r¶þ²)õ[°ßX??¡Š¡¾_p¥»bÄ3ÞL$J¤]Ò¡Ó+†J¸R 0Ó òz("Ë%€€Cè[å(©ê¡¹pVCu>–cÖá-â Ä­¦×XUÌâ @í:‡/¸V¹îí7úÉàC=È¡_ós&\øKÚúq¨ù1E4¿ìx@UÕ¯®¹à Ù®»ˆL€Nú*`tÑBÓD¬µiAj$;€gCÉuZz!7Õ.tœýÒ\þ#K»ß±’ 7Z…2ÐqÖG~GJÚ:2²ßC@?ä„ã’‘ÐQAùDSjJk$O¥õì8 •äEJ@L˜ŸggÚYêÖ¹gìî%íøvx¼4ûªMrØ€¶cÀ ðq£rƒ¹bÔûGÐÞ™Ê:ªngCÓœáTŽH) å¤óV ή7=ãÖ¤æ‘ïÎûÉ.àk·ø¼­ú+)ÊYV¹vCE­ ÒúdJÅ/KíÃî]/ŠëÛ5Áêc¨ó)¢°V²Ã­Îq é†uW¦¥ÏÒÖçôtz"®–ð¨1Q¿-Î üºF7o:òŠPãÝ€¾KÊ`TÆ:ϲI)ûB5[ã[ osžìÝã¦^ýVÇõ§õjzˆNªïíÑx“êr€U-KOªs£nt[ÉMMa;"öOcþd˜ñq©Œ¸Íe¸.Ÿ1Ý O%=Oß+mÜÃÆ]“ëk‚¬ÓD5o¼¯B5³Ú0““aB<¾/©ç¦v ±†tdÅ_Þ7· L’¸yÕFC¤ã¤³7ö³ MÑcÛ¹¤[Ïyï})œ‹n×úQ=§,±fÚç {âìÓR‘ÚWÜɲP[ìZJ¢Ô¬>l·\UF*<¤Ü‡èŸ>|K‹ XëÕ—\´r@i+®-Áv;s´ Ûã4¿oçç 24*™,J¤ñ<™¹ÕƳJäÅŽY¨Bxm©5|ˆ¤·Ùޛ˫æ)é†rúÛwÇü`ÐúB®Ïç™Ê¡µ„×=†à樯fb¸´1Ï‹ä¯:·ú"uHB\’m“d@«ECUÇúæu}Z«nUs£v]U|R ]Ž€2µÁŠŸ{«Wìn$ݯ~Ûf½3à¸ò-hÕÑyŽ©mÐô`;«–ùóOÀÞ‚M¦TÅG¢•¹3›ßdp37¦Øyã£÷´ñ ‡Ýûy~ë±U¥q„9Ô‚¹&Hz+·ú© é¯R†v¿a}*K½^óéÛWTO¯Ö>aË[Ö~¶¶‘puž¿J‘¿ Ö|·Úozï~n­#\*µfl-Èýp|?á¿Ûw®ÚJïÇ躌šVÓ7k%*Ý$æÈ\‘ìÕ•§ex<^naJÇÂ<ëAOT˜„ê\ÿž¤Ų̀>ûÔ±s§¼ø,»*m_ÑúÜØžçh¬ËPø#3þþ¹²W¸i,õ‡íºaë[øúR,öÓP21cûd˜i²zQ¿ëÔeK˜ÊéW°â^|Q*ÚýưÑT1LêÀþ"nŽ*ãb’µÁãÛ«Fi±Ou£›Ì~ªÉ©ûÙw<‚Š]úÝ(T§`«ò@zO ®Á®Â’æzßZ]5QÊ JÙ“çÔsMNmy£P:f-ÏR@¸MÂN +¬±c§|«æÖ…½fÓï ÊîØ¶ãuSý2Ö¬‘vº¾x; !úc[tNì«t›»Æà…Õb_-+ˆr½}¾8_SšÎ‚(%“¨,„¡ÖáÞK­Ü§Žï•R§½ðéáØ×1P Û5‰ôKÔ Ø!uìbz½/ª³"öÈjס;ví>åd5†-ýàæ¼õÖ# ïÎc—­dvæƒÏ£¿/þüIdøÿˆèÌxŒR—Œ9Ïvëé_E]ø·ÔŒðñ)=L;OM®«mœ®à슶¦$RªÓ½»ræáÄÍËeTäU-—(Ü5‰1Àɧ*Qbõ"ë>u„ˆ»TuA“Þ÷¾ÚŸ}a.>†WE†$±×ø{˜h;ÑÌÚM–Ûfþæ)õÑ=³;6íç ÜÑ]0:ãÛˆ+†[DjW½vÍRjm¿?ÜiR¸¢ é$óIÝEÌÆÍÇo$PŸÏD­—”š(ŽÖ¯¬ö\Õ(ñ¿¹í'…/ßšeå¥K _Y ¤¤èœ­Ùr­Ïxܺ%lyÛ s«øÎ—„ôF[p­kèŸu]¡áILHÇx0y¼ëöt¦þhËH ÈhPtÔc>@õç·„þؽØ3üà-5Ö¯×Xô^þ£~îæùh£Çf"œ,p[Ip‡/«qp¶"ÈÒÕhùØ{VOÐv€û+_|еFÿ§%ú¶Ew`E¾P³2 ·ÓC$UXÒvKC1œnÜvb“´ñŠM)‡¹òF7*,8U,/Ð1< bŒÑcÄHz54üïªf·Pó6ÉL„ i~;oÛŽhȶ½xolZÓᯙÅM4¨•#!ß9sÄM,Ç>¼iP8AŸÂ`"p4«xìZÙÄ8—+Ü×ãƒüÖ½/òù€Z›Ÿ¤š­™×("YzTW9èGrHf«ù×9G²ÊV\¥]bP`·8¶7ŠÀo+$×n䙾œH±â5—0±?ÆÛ7ÿüdÜò­¼/=Åa;TãÒûCÒã…Ô$>šÊ÷t‚OÖ‹´ˆfÜÎ<º«‘ëç ÛoMI"k󢡸+Œ£"Ž È<+›$ÌEõ 7ˆêgoɽrZ@¤Eù†Ýê£ÄT¡ ÜÂRœ"Ò…à é6&J³‘¬Ïž«f’¦ ²N±ÙÂîº& ßw:è[¶Të k2- ‹™™·tØÀ\‹üÞµÒr¤F™“Â#ÒU¤¼O¬‘°³ö[XüÆéCÂ8ÉJ2Kó5¿ø¥Õ·?ÈúFÎO†ô—w¨0„ ± Æ9a©½§­¢–›¡^îô€¶¼ñ]eî‚j”šKL¥žÈƒ^ƒF­ê W@³ÖïS*ö„¸! ÒüÞÌ]!YPš¥ÅžE@ú§?@íuÚeð˜s­XQgnګŦ›n"­Á—3‡¸Éñ!¡)E*¤oÄš—Ù’/åÜÿ“_æ:zG~¾Ã„N~±÷î‚#‰‘‚‡M@BCÀåýýS—MÂ2 B‚a\ný·ow×r–ã%A’!_è04Þ9pšJK)Ô2Ó˜Õ ËŠv¸Žk%J¨Iú(0z ¦Ø—®v™$9굨Ù°ž­€ü¬jD]ɼ-m¡S[†úÊ„¯ÖªGæAU':p>V­ fê5jÙ ò]£3ï¾hßSËû45O3¡€×Wð”íÀnõÌ—ˆWõQ¸PN?Åœ=þ± ¯k4¨¥æ¨DÄd—Ò`5ïâg• è,~tbŸ=‰CÅ´5ºˆçÉ]ô\:Áó1W`·¯ÈÖkDÜfAWl97 Ñs Þä¹í­® 2 ÄTE9 Ï»ËÅöo4_Aæzusî9¼…š~ºGv£]C“³òQóùdãmL/¹V$Ž{õ@ÊèQ§þôY*Û ²¹‘yÈ$òÑóOqƼã>§æ02Î\azõûj|òW·ßPºžçÈK€++\Š=ýPIŽ+#A¡Ä6ý¬¡2ù¨ Ø8l¨3±8¥j‡Š§çêÄŠùâzé~Ð|aëÚz.Þ£)>ý4Òá ?÷\ÑÆºû¼£~ÇAÓVkäuç9ž3w[ËvÀ³:§ •è¾¶²ðˆK×±ÌöÇpÓ¼½ÿMA¬låœÏ ^ħ'ZQÔ=è0ИY63=Ð3ƒV™%ášÂ\Ý&omGÕÎ2:(!¸ocÈÖ²#Šº–ý Šÿ¿«Í¯"¥&Râ=‘ØJºìµäç– LO—§,ã¥gª OEóÃR ôje_áúÚ %Ú”w]^Œ1…EÙ¡KBó:ˆgA“o Ö*V.@ ¸CÞT|-áhÚ´j¤I©ØgZì|KL^³#„ƦvŒiƒÎÏÅpƒå@°²ˆfix;È:‰¶è*å4èF¢Q›ß±˜¤uC_¡ ãáç4j¹„r€é«&Žé”hÕVd8¶.Ô,ÿ¹DŽïWÙÎbmºø^•å-´rX²<„DÔ`–4½pN mQ”cƒ”õW‘2oB-8cêEšYï&¨_ò£š$_eIÑõËW úêÉeˆ™÷ß~‹CË{Ù7Ë“‘ Rye‰楦–­’w{ª—tç-×S (â¶Ò:ˆ¢Ÿ+&X-8SˆÑz>ÇpÊzØŽ)äŠÂX¦m%ŸQ›ËÏ[¾Œg‰E-!AU¦¹+ªá¹ÍæWöhÍ:ø›=¬5Ø3éQmJªè–m„/Y«7:òÍ‘ N yo¢¨¢ú‡#™5IiŸm:ñ»®4ž‹¬&·…£<Gö°\$N$´ÿ¼t ½ho®/¥³,)«r\Õ„YzªDÏí¬jÕSTlÕì¼ÑÔ\ H0ü!A¦zÓ¿mS&«}²ç‘¶šQ}PªUÈ0[#§í°šAéœ×‹DÌœG³T%ÐhÚ znt­2ê¼f«H1/¥€ ž¥Ay˜ê%Ô yŽïC8uYФFÁg» ¿Yç A•æ…_ÐwàÉLÍ©¬Ó¦Lô5êÙÇЧ¦çGž©ìFáÈŒmèé07Sð¶·Ê–†TSxñLJ¥Ÿ‡×¨Ð+·2¸Tx/qâNd›³=B\t„\G)Yž;ÒDÏeK³‡²7ô…Ãît¬"}y9*©5Ñ¢`X’õsàÿJ)Ó‘€_M—ã¿„.¿2*ˆF[Zt¿• uh^Éu1‡€&À8™É]5sK🹇‰†¦JÌbJ“6ŠJ[hFN„;w”œÏÙÚÌuS !f•x 6ú¨9Ù)[í —ÑÒzë+ÐÿTIU@ã3té1Kw7&Ú<÷Ö<;•t íMþ ì^„4ÇÒA”ù·vàÖ%Ô§-¾pÃ¥ÒáÖ)¦¹M\ƒWµÏ¹Ñ,% ÚaÿÆ^¸Õm±l™tƒ{G™v5ÐK'F5=t5_‘*.&XdZèF[ÙV³"­M2C!O|!+h”›€5BèCÕiRë);î|*H©»¿è;¥N½ÅÁ¬[z ÷œ1v±‹¬ \¾A+?‚c—‚|Ö†¬Ñµ¦‘t °–®Í]a^k踦[ ZY-‹ëÔhxXmc'xäD·– )¨åÄØ3ÀÉñ |C-~¶¶¹A° >È5(«p~IÇÐ61uü!>klÑÀ ~#d0›¨G2ÕŽ6Dù ¸4záL}–V£ù…P1ÝkVñÙ¸h ;P˜|Á}¡ÄÒ µ#ßC›ÛƒE‹L6%°‡0Áµh 4¦ö."U½#¦VÀålbE?ÒŸb ¿w_Èç’ÛÍËi¹>vÞZØ(G¹…rù+‹{×+‹½;ÓRØ™é³3Ӱ꼊A¯»:güS¹ªt¢KºÎ¸vÚj7p"˜tèZ‹hIM[ûØës}Ó˸ZpnoÞ¦¡;M1º¶¼QÄî7Ë(šTJVÓ»”~©¡•šM];ë”Oš§+ué5Šš+3lv{ÑÄh¼úSõÅPq7 Ô<‹¨‘ÐPÍ^»§u4 G ý™âòŒ—9²]É DW =|G&;jl¹Üƒ ¹­ý»:'ëuKA£e}>ðÖ$™¼©Ÿ×ôû}2QIçnŠÕîߙ©ÃB¨nëŒ(I¯B7——È>Éø±F>(ZgÈP6ï1yÐZªÎµ· õa$¾D“f@ºdÔ™—’"yiUö­Ê !Ì!žlš¦3ÔŒ|e W9>1¸íwc»o¬¹…‰kŸ¯Ò€Fö™-ç•2·ßüW¹'±6ªæ~y]ÊÂêGö:è'ð-'÷·²@ÌO(Ósè}åªz2œí7ÝêCõ•RdÛ³JálŸ#Îo$Á™UÔ)ÔÐJ ·–¾?£ü¿Clý8Ä¤Ü Œj G†ýBSi"XE2öñ@*þ ˜G©‚æ±cø’r˜â>X"Æ:ÖÜi#ÔfX`{Ý62½–ïÛýõŽ`ÙJv …¯×{íófZð‡‹XªýuofYªÚŒŒª2†Ž yŽ týÁ|‚>½Ò'gžºkó´’[@Œ˜6ˆWýtÂjgþJ*§>—@WŸÅü8ê7Ö[ÏJ lÐÝã‡hA„j4G}öxFÊ…`踖È<¹&1FÄÀ`íÁ;Σ壜KAVв횦`ø¦uR•ãz®Ìú]°ƒ@«1:+˜Q;ßx(ñA%i}/$2A׻ΖŒÈȼŸûÙ&²Ñ¸YA]è ÄÆè^w§™¿hõM*rMí .Y„x-1g[ ‘ƒŠíÕúÊ])kMˆ¡„röÇc Õ]Ì.Bª†·™øZ3x(ñfdBö‰kMVÆ]/àä5sÌíÏýíÛä7·#¿€“\Zñ뻇Ü*TK y°AֲܶIW9¥öH%ÏDt[JK Å7EœÂäågê!Aî5‰èa öänGçÇB€ž¸ûFÀhÜf¢Ø‰¦KçzöAy}0ú¯è¼ôuÚö»M7µaŽø*1ÊPiî=Ì2Y¹É…h 1&L8úu^··›ÏPw6hb•ÒÓ8CÈT†`PIÀ´ˆ÷%ÐVMí`ØÖ1•ÞýøÉÄh:N:Í¥åq¾ ò#1í³j¨ˆq'íÁÓ.àYòÝù@b;„àbn~â¼ï¿ nîXTá|wÁb˜[6Yy£íqȶAœ‚ô*Ù^UÂSOÚ&Oé®­²Âd,‰’µ^WæÛ””ü?” ]85{¸Ã‰â”‘“3}û5]ÂTst$Q{4r#ÅœÚòÛüÄVÌë×"ßéÛ[þ|éü†;iMuowÆ0ù"À'¥„¶¼fd®vè¾ò~P1Q Šˆ~uEqGãu€¡Û#By2슱ßÒê÷B‘”áRô†‹á‰x/ʃz¹ÒÖ»lk}=%\ÎÍ rgR¿fjŠB¤ÛÖÊã=ÂtÜ—1qžD^õ5=n¤Þ'£çUga;^e),ö––}j{ßµ»òÔ²î“ÊúŸ‘'ÔÁ¸xO¸;ܧžè'ƒýærìðÌ_ïPDCÒ$Åä»'e’Ìç>à椼hN tv{¥Ñó½ü–LÉT0úÖ¶WeÄbjzèe€+ú ¸ÁÓwॹ¾*ý2ݱ:»‘é]ïÑæß4±C'Ñå³ÞCË'¢P¯6ž0{0+:£û4.Ÿ˜^ò÷4ó•·”RgEª–[ž¸º=jþ·Ì?Vá9>Ãe!ÆFÙYµ?/ u…F$úlý±nœr×'öÖÝÖ'²ã!ìÏ_IÃ?:?—ÐOI0ÂóŽ•n’5ïÃÎ'ÌØº_“Dº9³ü,ôæ¬qÎk¹!wºåi55~ÁE^MÈç÷†:¾îR÷Ýüÿ‰»ÊH`R"Úä~ô§f+E@Óµ@·Ålë`çÚÒ i?‰ÀïÆø\Z¨MwË,¨ZÉÍm§v‘¿µ9¾i|YžUV»*Lj:3¦ªœ48ê8ÜK+;øFOÔçI‰•¡°³½í-]a^i¨§ö”{éEÓ‚¶mceÎK%9‘Ù˜#þ^œ`@:#øOÏw¤Å 1™»c2†·Gór9õÁ[šÖÞ.цâ] óùæúD~_¦šÛ=¶2j‚‚šÔÃ.žƒDÈ7fƒßiì¬É´¦ú;+ØÓ¹K&ÊȲ’¿ ªãÝ˲³d;6߸$6ߥ¿ÀQ¾»’0 ®KªäoÈáýûß’ÙßUQ+IÛUQ+%æ8Ÿ<Öþò¸û'÷‹ûåÉûô$¿|r4ǯ`:H ¶ÎË#E`Ž¢n%^ʾF g>h´ÀàM9Á£Ø;«øFÐU¡/ѵ/ÜZõ¹j›å$Ê„¥ˆ›&J‡M)ŽÃ†ÓiJjôЧÉXЩèxô+Cþ¢phf°O³ wÛUV5@É’:¯y=ºÊ¡þuÝ÷æ÷™¯wäëÏ7ìnƃ‘m&ÒýoAØ.ü@ Ò¦ÝÖ8û°Ë\Ùlík;øS(òTW¡À¡˜±T­çÑ¿{)Ÿ#þ‡‚~A‹ù¬å³ý˜ Å]ÔÆFRBŽp˜BbHsø›”C"­fÿýŸ8Cn4e‘h ëƒK}@Ì ‹L•?5œ÷Ö·J]ÃøX ]õ-àù`öÉ JóŽ¿l•óKÂ[ãùoBÂÍiV½Ú„eñ^”`:­˜°[Ž[žÒSÃ%Ý"å¹dª˜ÞåAàw/4yP¥\]SÍK´Û(äl¦åµÝ–iÛ)Ä9 ÁÀ®þŒìuÉþð1OOƒ£e ml§CCÕ]õ÷ž'=õ¥É—¡8¾ Ä0‰õØÉ\šßµA™·&Ø3ÐU<†œN`kþ˜ï ¼È4T–Ûü¯l3‘6gƧkðcæ ÕЗ0 UÍ¿û<·­BÃPwø»oÎÑÑù ­“SŠsÂ=º²D‹ÁÛ’—þ>)ç½çdIÿàVnë“„?ßÚ»hT,¨»Ü§Äœ:;Mé[,/ÝèP"”ûSgHUû\Ÿ5R½Á |¸¾7þ©Cn|BÐãqš´ ÒóÍ`úXúF«ÉŠû‘dQ†ûToÔšo.Ùw'€dºЉ?ûT{ކU÷åè!ÃÁû Q— ¯šEAè¿ò†¥àr;(úÝ@V ìcf¸K¿Iˆº)¼äý65Ìr3bàS£¼„FÞ협ëž]~‹Ó51ë¾]ÎæLžHyFì„{6tõ=jÍ?:gRG+żk)ï8ò%¼Ÿz—Žfe·€Ä׬øøN - ζYÑ_íAÍ™8ÊËôŽ8–/á]x–åÆÿa½\V.?ª(þýg"tÀc꺫JG‰ŽÁ™„C@;Ðt|{kí:_Àà,4MvWÕ¿j_Ö¥ª=jêUu¶§©SãOá— ×vcºß§h·°PÃ8ìa5b½k¢0wvk «¬œô¤ÖjP zFCxÄMÚÄõ”#»TvÇ›šdéÓôÕR?ézÛ¯Pè½ !ƒþåÐBw*T›¿Åš’À± )ÑÁe‚EB’h‚C…Z`„àu{)@Uûãgðóà0OjƤR¯´Pm×’äM!A—² gàR-˜\š’…RJ;Õ§¢C•{tMâGSë’rcf3-ÐZOÑî¶sùlØq׉ÃerCÝ}þÃ>ÿðãÇï>ýçñ[BØûW¯ÿòùÓ¿¼ÿöÛo>|øòï?ÿøù;­ýêñkVþŽ¿ïÎÍÌÿyùÍ‚“Î@ì2l¤‰˜èÈJC=k㥦…ÔCJè)5;dŸžëe]ð´Ó©Ô†«^ Û§,ØË/’PD˜O•ºûIî-âµ·Ô£ëäªL~ì’#ý”kÑÝžõ(ñMgP¿¢v}6Ù“º‰´?i$ê”mßWñø»fèXüDÙ‡Ï &ËPñŒöÓ2B’z5Ï_Ý#Lp(wEéS wÚ^MÚJÃŒUržÕI2„b#íàÍÁ¤Ô凚ðž¤9Ö<ÁvBÕ!^#òlrV AAÂÑ¡=UjñWÁ³ª%uAúºÆ”œ™öÿ<;@c#FúWíãwsâxФ$!ÐJ."ðxhаà_îËc5¤CdDäÈè£J”‘txÓ¹uî;Œã6yóoÏU ò~v¹KŸ=űÀhDi¹ïÒÁÐ=ñ¢yÏÑ“‰ù,n' y5NÍ]ôî*#%èPhœyD2mú|AN–’D!2™]FÎÄ•-… ’}læU a"Å\g—ïì44"¼±Î­U’ÙšÃำz™eç6`Ãhº%¥Bó¤©òA{Av|X$”f·{uŽ|lQ w¦$ÍüOîEE»ÔüÞ&a2‚Rz~eâ¢ì¹Ôê\ 7gÑe@ô5Ô´–‘³ø1[•w3îù8[I"¸ÌléC¢e"æ'CvFh›Ë]¤è 6 ÅWC7†’˜hÂEan#¯t\”!H‡r·Ü4eše ÏòîÂ%{1 .ÏGŽÚ²¨óIa–W í“_ëc˜÷!÷u[`h¦TúÊ}àýÌ Xãg ȸA¬l× ÅÍd$'1{»™cºÃFbï–®wt¥©þö>‰îmí!ÌÈUu¸Þ1O{ 8ÒZÎNÆh[“éÃáXEz_·/ }CZõ¼Ýr«™Jâ#uP‚!š=·m¬Û A Á967I$†&»¯+[|sìd ë4é£ÓNîÒËÃ'|].Bº[²?##vzDl î¾(ÅòkÓ¶èÇ ¼~^¹y2C+ëæ‰©ïÎS=oy²o$™1ç]¬¤ÖËbΔȪÊ[5If‹š/î×F©¶…£Í›ð@b)‚¯}HJw†«êü6"‘1^‘ˆí5«¼æPèB+kìg¿óà M‘óêUû u¯7L+Ó'=wŽ>Ên¶ÄºÃ2vŽF_w'Äí•NkxäÖˆeË+"Íam%^epfX§µçYR‰qîs¼4eøXåÕ©2±Æ›4£‡3iƒ8nMá­5Tâv*c[ !JëÞ‡ C<ës—©!RZnèFðµ`öðr±øÕ 6¿å´qòq7Ï(3÷I-‘C9Q7 Ý·K²-K´­E˜j/ç…»h‘aO’º˜í×Ê4YÑœ :ÕŒwx bÇÞkŠ;²‚dÐfŽ&c#P—‡Ó\š}ÚÖµ,Fl? ÈÊÒõ•ÇÔWåø­Ù4¯¹» ¼ ê’/‚Ö%éŠùÓˆ kÛ6S9™4^‡([œÜßæ”–ˆÊ°‡ûJYÕl«Éè”)`ƒ)Döäî;"Ôh¡KiS‰Ý‘/€åÁbh k}ÓPã.jÅ ®)=QÎH!1‘NÚs°ÖƒF½•›ÉŒÅø6%ùÜf…Ƥpi™9.ÿ1eQ¥4(¢’|_ÅNGpËì»hÅÂïÔs·ÒUÌ îë˜;wË,?+òC’«È÷-QÉ4“w.Üß‘’ÞÂZ‚žVçRØ Ñcç%qû%•oHyJô £.åZcIk#‘–å7µA0t‡âõRMäP•÷n£ê+w š£—ªÚi®ÞÜv@hØÚ’_ù!;:¦WúÉ:‚p\ ¬õ—ꨒʳ%½×z”[` ‘Ÿ}Ôj;õf [6>r«)IhÌ %GUy* G#=Å£‡摲ï'…+ê§1®ì¸a¶›ùÅ£y;†^ÈýÞU2»1Ó âIe²k7ÁØÙ5]b !)ž;¥—%®µÜŒCå-…ß&ʪùdãDm½ÞH³mš¦ëIi@"“!Q5Ú›²]; ~wÊrRiš¢í0Œ Àl Ma§)WÊÜË 2$P óEȼ¾0ôo ¢0|ï“õøã/Ò®õñþ›?~|¬Uݯ_hà?ñ÷ûwÏ9„9Û*yEÛ>)XÛB-y”á¾:²ÔK´´Nêâã9^qUS……½KkyÒ?Oê ß sÿ¬F9Ù™Ž*ðNâBמõŠâ™V³õt µÑÞUÒ¾[†¿&6o"0Fà !ÄâqÕÇ2p nƒµfå¨E““$Rk÷p»9æÜ m\€˜Å-ƒVd^B_ëCO£ÜÖxúèÅþŠÂUXÚ¡<±Üq¨+J³Q¤ ›(}Êøõd {.î& S…¶h@ñ[Ͳl&G!jˆ*©y^È=ÔÑ!á‘Rl¾Òœö bÝÂãbÿ$›‰uIAžDz®ê²­°ÞèÖUŠ@(9ǬoûôRP…kÞUŒ)'A,ÇsP„}0ø¿µ·{ÎΛ—îR[¾¦KËjèÓMHG-…²“É•¸d_OK [Œo–5’¨Ž¾ìî*ɬ{\h©šVPR‹„ʪIUûèq,¾*ó N}ÿtsæÌ¦$ÐÛqd¤8AAŒ+¾D‹{ñp=¤º+ˆ´¡ƒð\ÃŽÁu3Ÿ¿’‰ñšª4-™]G¦Z}qÚkž´3CQPWw߆J7ÇÚ¤#tÛù˜SÎ#VÚNç­É Y%nŹºžØ BðL®fŠ7™áÀþ/íåŽki áÌnHò»í˜”‰DÄþc¾ª¶ÏbHÑ÷÷±Ý®®–0—15‡eGãÿfÌ,4›¶hšÃQ²²ëÇgq—–µ8Ù:¨µªÂðÅ«ð7…¯e•ÍÚ­G“Ø®ð΂ZOVa¿Œ\©#׉rÁ»jxª¼Œ}~©Ç½žyIû\æR¸T¶|rVè¢*݆ÄÖyø*’ê·¬è—( öå °|S:Õ¾½ªgÕY㞉¾Š7ë~¯B0:*õ1.xú~§tѪ,ÁYY³·þP`hóæ'}½±y 'ý¯\Ï4´•©Kƒ¯Œ±UüœTª|°pØæEQb ­xùz¬@°_êãñ=‹Æ}LîÉTøºTL•ǮؾhÄPÓuùÇsX•µ–¤§ßñ{w•zköï‘ÁFÃêÇÕÔ·a2GÏø*n°¨sH¦'‡ÿ¢þÝ.Ëð¨f™ïdÈ#¢ñº[H*]ñl‰¯J¹¬†Œ±ŠÕ– Z‘4Y´ËWqf©µå z¡ðj)ãݧr–;0AV¢Y~¼*Šì串x{Ù—Ë0r•¯yv@Ýdš Ž–Þyè]•·Ûç%ªh×v…½éÔ¹Tú "œÒ¡9uƶ®åK –º[Ø[ yh†&j÷3õ•oÊLg¾ZZxð ‘Qª22Ÿ`îá„7ÞÅö‰w›ÍÞ‡gÆØÌCº¶yѰp¾‰×òEs­ú˜2¾©¥¹©ò¦¼_È%Ý× õcíÄÄœ:åvêÓ!gs,C&Æ:N.­Ž‹Ò-ÑYÊ7s8>nñ7ßêD¬·óë9Ÿuk6ƒËpä8P:²ùx…㨨œñ¦¢Á œgŒ¼Ì4…7¨î‰ºzxOPÞg¾€L[@Æ”ÎrÃãds*øå !q"¬.›Ã˜hÛd›©HèƒWôcûÈ6½ÐÐÑÙ1.§‰-$ ËZL¥¥›>ûR±I¦ãX™P¿˜×i“«š¿1ÃʕLJ® î`ìdc]R£¡;Kûz÷C¨"uÑü61¶*ʳ[V´ÞepЦ꾘ĕ80¿knÇ‘b¨RÚ=%Ã>õ¤ÌØòÐsߪ‡ä9Öñ;·Ž!±?ƒÚ ¾¸¿­ÝøÒ’TåÁí q™>äË«O9UseûÕ[Ú ÿÒ^pèÉ''³ º»¶ó„Ì9t¦Ý®NXñª8iy” FTc§™¯ËrŸyɦkÈ„ÝÛ§ÿuk¿) G¦¬]†Ç‘aêM Î+^¥Ô¦7â%«3—¨¼Ò*pë¾SÂW=kå)—¾g8©Mw MÛ]üÛF‹Šõší;U]5hød‰û±× a;ƒ yÓT‘ëù]ëp³š(üE×ðÿº å Ë›-.õÍ q¤6Ô–x—lY(„â…Es5¬sÖÌÆrP3 í•–—ÊAü|}!ú®;cíl Öô¯lÁ&ÐM½T°©îlo9È£›ófŸÀ,éL5XùŠI7Þz>+ËŽÆÝþʨw+š`QŠ¡RÏ£ì# [§/« b³ºÆcD’ElÞ AwœÈ¬þ†8ñÂ%ëg6´˜E¤)4çÚwžHS©Õ+‚ :™"uvä8­-Ö¡ùÝ䫊g>ÐoÝ Q»8-v@Õ}·»]jA ”Ä#ÑÑi‹Ø"eR©ÒYd$·]å¢[¡ïY'Ù"ž†šéÛ©ŠdRJÅ‘<õ=ž —åò ƒ¹tê²gFÀïðà8%ÞøV¾ùxšÇ§)„^ö\2itÍOs÷âs3ˆ³«+ü1ôpжÅv°ü,—vãæ'´ tg6*»¤:€„ •ä”ññ É<’Ò–´»¶wd«/©‘-,û:ÁK$ ­]²,ûl—ÌÎ)ÃØb½÷F‘ó«=Îõcv£*Í–2-×ÎRm¸¯W–‹Ü)Êói9†f[Öæ¼n „Ÿ9wPÓ4¯e^ÏÛKøavñ$êÕfóëu «×IÑ%7Ý_­™*2VV,²–¬6ß~Sùj‹öÎsº1‚º$ÁWqØ£ed“þü&“Z·Ž†«ˆH_ín˜HmÍ1`¹f»è³ðÛ1û}ÄY™`ÑgÒ¥êŠQ–zÙÃ:\ˆÓD}(*¼1žGnk)ª4]A_OD¿9•͇²äVqІ4le!¾vi˜“¡d7žÔD™ð+S±K_ÈB“8Ž^ˆ«sœzƒÁ¸³_qò°VôS'ñ! *q†EÖ†l†ÇxfÝŸž—«î™D¤D: דÕe¨B¿(ô”E<[~Õ§¸¦Àz¸ ݤ±‹]KÐBb_M7òd­9¬å&D“‘%äÉõ…DtQså†]zNš) 'wåä)Pƒ‰¤!ëfL,­í¬Í"ªPµ–XhtcUP¸Þ“7™hXÙÆ¨1Æ®R _¥PïLYj+›k©¿~øåáÿ~óöËË÷Ÿ^>~~þðå¯ë[–o˜~#{õÕõæç—/Ÿÿ¸ß½{ûôôç§Ÿ>¿|Ðo_]ßðËïø÷®t½ÿía\¯®÷¿²rsئÏjòÈOZTÍ¢Xj‡Ý5Å©ùô "ÝžJèÔüB¹¬0Ä'mË3Vó-†E±BïEŸ'ô!p‚¦)“ýl,ªÚDWsðÂnÈS«çµü¤D¥²¨m9;M4dNª‘¹ÖâˆL-ÃÄí@Oÿ›b/ÊÑܺ„ÞöÏ.øÁ7é1¬2H4èoòtNÕï8B$ºÚñgŠnɈ–é]:<ƒ¥þľup«Ò]eÜz‡ABö å *þ4î;…@@½’ÜÜQº)kž²±Øc/ FÔíX Z\h{bÕëS`¡!îœXƒ¹ân¹…r–4<£žP#õ&x^Ù*·8¯Lš ƒñŽiö¸×‚D{˜´ÆDM)__Ù’&^5|æÐûšw"ò3f03¤üŽHkãKsäëñíóçgRXÝÒ.ÿâߥEh]=èî§y±(Óѧ1²ÈÄ\ ¿›RmPÉÿ[{äƒÿÂwý2IºôÂb‡ñÒIšHqÑ$Û,m¤Ž±iC29(¹ü˜=ÔVŒvTÝl?RiEÉLÒE°£ß¨rŒÞE늚YR/8ä¤UÃ8¡\݆Ô$B7‘‰) 8ZfË Z*æ,å^ ‹Ê‹ü(“ÕäM6 š¡÷ò>2­X¿ƒÑÏ»Pü.y(ż«Xå¦öf´âD ¤ð©ƒ]*)Ü2°Š#Tñ:akIb•Bâ¿á;æA)ŽjùËúö庎Eç}W&Ìk!öIó‹í ¶ú„Â_ĽØܦ£åÍn½¼Þ;î+3Ý‹¼ÁœÜŽ:ÜúHÞ1‡‡ª”h‘¸ôhë6`1},ž,6iÓ™ä¾àèaöò­<¢7[—†u˜$÷ I‹0wír'š ÛÙŠýˆ;N9iO'Å#¬VŠ Œ D«šQ¸Ü|˜…ó-RP¨dÔpXàuÞa’ë±+uE°Ôcàÿqº¾V»‡ÜÕ+¶bÂÓ×$EM¡%ä«F-¬8u„Þ¨b…h ŽhS³"‰·)±ÔÙèaOÜM/å»ç³“Òjªä>e…Pï*k¹ön-§Œ(%z†ÂU¯8H\¤‚BhékÔqŸÛűct +ãÔ­ŒÂ8¦_Ircø²ßî+hè˜ßn©ê)w‚@ûæYb óé\>(0tÊÍÔÉd›N@ÃSï–£íq¼ çP–(íS(‚Ú±åƒAÁï[‘in´ã>ÁL7¿Ži’–÷ä‡:Žrgü½³‹ÊÎû þb5Ô/¸%—ðµ±µ“wëB\­ªçÁb¹ÔöÇvr!™¾æFÓ¡ÓVt *YJ&é¹:åHõÔ ŒZjâÜ—]£ÃªÙP5E &‚ðƒÖ4ë¸öˆÌ µØRH:ÊÅaº–fÕhÈ>¼cI¤18í±f¥€ ÿÑ¢"E4“°ÌK³ŽêúE, „S*V¸äÜ $+}˜‚ÜùprY«5åúZ¯+Ç…3|9PºÜ·f±¬Q$¡:œ Ç–*ÐEЮ⥴֎­Ün¥øb·âwc×(€$žŠ¥<ÎÖd'w†SÀ©L‰=â„…O/í˜=õóŒtÏÎ,‘82¡¬Úž&òŽhºvtws>qJ’iWâ>å™u•¨X—²•øÐWÙrG°¸Å…®õЖ¢Ø¤ŸÓꎊÆLˆ:œÞ!!i{J%«%vjdÒÕ¸o…½£1—Í~é´ÞJ3Rk÷Â6¢K ²$†‹3û|µáTç*îazsK0®RÆYr·¢}æ£\*‚R>ªÓY>‰÷ÎG!dNYÕÐÃq¹â"ÊÊc¤ãDiuf%b”=ù”œ’á¶ï¯¤Œ+ÂØú2á§X3¦Egú'»Ï^îö5A6­qÛ2bjØKÙïCÑ;0s©gqõÈ$í%gÎJü¼'R£Á »Ô<˜ÃEÖ¨ÖΜǼû!'§SóÝâŠX]¨—w=Öµ›u!½>ª^aÙ€³Fcê³,í4fø`µ—RcÓÓ™j,õs]ÍMÿ9wÚô8´Ù}W·™ÉD%ôZ4:@wåÜP ç£*ô­KHt7Ne }÷ÁÕ¸>,áIQ¿¥¨œ®Ðíîù§¡ëšø¦ú|”…>uÏRb¾´¤yšô #í™TŬ0Ë V TÐåÁŸµãrþ»éž4˜zXÄÊÓšþEG)´üÿàúχß~aÖ}óöËË÷Ÿ^>~~þðå¯ë[–%U„d×W×›Ÿ_¾||þãz|÷îíÓÓŸŸ~úüòA¿}u}Ã/¿ãßCºÒõþ·‡q=¾ºÞÿÊŠ. .r4òˆ6|Ò¢ ¨Jƒ$Š•z9Ë»=‹¬eÍ]Oì±™pñé=$gÔÀ&šz‹ç—!ü :ÄiÇ.f›B±ëS uÔ9òE»‹ŽLs2“†õw¤ˆ57®d –sI£h»( [D4h•+kŸµÒ›ÕÛôã´ÆðúBÑ— ghÌòü‚ÔU¨úý Ž6{\²ÂN±VHx³&V¼±²³¨“XÒ$#¶Jþ‹UŸPæ,Öòà"(kg~’ëeðƒ¿‡@.ÎD`‹;w(%1¢.’jd›n$¹ERª—¨BÏÖ!L œ(Íœ²J)±ˆ¥Ín,e`ï'PÕl]=—µ5ŠÏÀî½å&BB2|©îˆÓK½æëñíóççë¿ì—ËnÇ„Ÿ€ïðoH@Mß»£ål ±¡ °wCQa^Š\äíóUÚòÂA–²ð«9=Ó—sª¾£º`Ÿ©àïø÷é 4 pV 5݉„*g}ˆÀ§ŽÑh6¡ÆOIäƒR™TÒ“c¹êZWaÓâ S´øì  +ò&Ò\§¾_ .(¡. ôÅì þŠ*“+²sÝʘ[Xåžh…Ô}¼ü!QtY"F.¼ÄËqôâŠx] $s€£e¿t‡1,¤.< µëYÅ! ¥ª´”¡—à÷”ÎÐê×HÖaŠ{@¾Ê©‡ïn“[µ8ýáØj±'¤e¦[§hÎ9£k’¶F àÙêve±\t´¥O›ýPX%:HzMÎS2Ý%>Ùzx—ÌšÜëâXs‰ˆO ˆö§–M²Ô"Xâ.*’ð7Ô[)¢µ ‡7ù%ŠêA3E6aéB…tU/Í “Òðö°|¡ B‰sÅ‹ae›û%R Tap[ëBPÖ?Úˆ©üFœxß`Ù5Õ Ã*+U…l»òFRëpC¯1Z ZQi-(186»‹€³UPGkmîµlÉ`5øt´G€rÁ,ñ;äà!íô¨’TØþ1‚‰¹¬špsÜpÃK¿`íûÜ鼘L¶|}RÁôi&fÈöÐì=Àh(J&ª’«n1smiË YÛÂq‡ßÖÂã|/˜WÑ%°^.­…±!KÅ›/ᘠ¹ÖÎê÷’„“rÂrÀsšÚe€ò| 9ïa·«ŽÔ]Í¡l¢… lÙ7hÑ:’†!®Áÿ]¸¬ýpÙìHÁ+žs\Ü÷ œ©™1‰¬ØssuÕ`v啬]éS˜):µ\”ö/G$Z]Ø¥â¦vˆ”J¹È»íG¥–›ãÐ"ÅÈš]÷}¯9g²sSecæž¾ý’—¯#ÒÑý&­ËbhÓÛø¼ÓCÕ>Ìçû½f„,É_0U6\ñUHq„öíBMõGÚrx“ç²¼”L‘_Ó‘Ô2;TÚª#ÆÌÁŒõÐOÖ¨ÙŠQµnct¬ë%o,ËcÜ@É›mO›cwb –¹rŒ’=TÉK¨=r¼1àQcN«•u_ÅhÎû“˜H‹'ùŽ´ÁïMú¡¯äzŒ¹I¯bÝ›Œ}5V>]uÒîq}-Ä5o¶n e-_ÅPk¼«7©!5SJ_Çù¨¦qË©ÅÖ’&ªÔ7µ« 5¥*.<Œç¾²ªMä¸eS_ ‰QSˆ)Ú#šNH»´SÙ«j3s‹…¸Ó Õê¶Ú”¿Ü‘DIö”¶pU!ar›öìżÅPku7Š*µàñ£Ä¥›é èf$yÌ”– ®e@êòçä¥É3œÛ+Df©ÒE×]{±»#eT[±n5G*+žš´ë’íCÈáô<Ÿ-§‘tU –5l¯3ˆPCl¼†M—G-a\¾Qý–DÈžrÞÍ.©ì ÌÒ#=Xö·ÁχqÒPÕ6id¶åFh2mSÊ¢$­õ"DZÅz웊Œƒ‹ÃÒPê°îʪñ¶‘v~œuç{“íq„Å%C±¯î;b®ëmF–NÿãfÇN "É¥Åô8‘ Õȧ“D— ÜTìãM»×ˆ¡j ¥ v„²Gë–ùÄp§Í¹_Lë÷ˆ©7û&Ï%#Ó8îJøe(òPŽ&…Òƒ}°9Ì€ý qÙ›yò™TXXî#îEšh1Ò}WÝ(<Œá«åØ'…bÊ@tögQ&ˆß÷ÆÈÖȶ;HSך¢ ð7ªŠ­sØM…^–œÈàL˜jɼ ¾GÊ™Ëi¦‡™˜Âé›$–Î’¼YBi )R‰ý„8–QýX)!µ…”h2y¹%[Ÿ„8¾l—âd8¤Õ܇È~—Ö#Y$"½æ`LîNÁ‘;j‘Eá£SòLž>‰®“£¡8fôeݷΧt-zYX\g*˜M¨ú¢,Ï>O„«;]¦p‘&ô ‹‰I½‡€7’G½_—>é¬ExuU$®gXx¶µ²¥Šë°Â”Ø”89‘:FXEm§¹—³ôa% GOÑÿœˆ=ʓݹu“J9¹$ur$.<ÄÆ6Œ©„]~‚#kù£Pê°Ö T6Xº—&B•q[âb¸©¥ Ï¶éä’uÔܺïGÐC³Q}R^LœEKçÈMú8éK{b«]Ëw¯š£ )I=‚ú‘Õ裦rg«j†’8ÃGÅd\NÏ´dféK+diÃ]ŠÞ­¤¥}<ûÇÙ~zsñøô—›«§›‡ûËÇþÌЫs‰.¯.¯OoþþôxsÿéôêÝ»‹««ç»÷O—zöõé1ùñ2&ýêg:½y}yë'”mÚ¯ÞþvbþêéÄ9ÿÎÃ嫇³âwž®_=ÝÄ¿}úíéÕÏß¾»¾|~ºùø|Ën~¾þòÓ7ž>ÿøðñæöúâþêóÃã—Øñ:½ùöþé?Oz}w}÷ÏëÇëß?}óð|ÿÓ·Ó›w·ÿÕü˧ÏßÜ>|y~¼Žw¼åßÙvÚN?~8ë§W¯O?þ Co»z`m›´êNƒM"iàD&Zô= ¼\âsfŠ?Isˆ2WL:WH92Œct£Ai8UÄa&:žÆp yB Y–“Úi) â­ Ü>ªN£¦þÄbËìcÿœ¬dH…ª8aJŽå•*q AWñ3%àœ4ÔFÝçfŠI”™7»|…µ0µÎ$¦ë–[))ûd=0 ‚`T2„¯øÌ´j©áÖ c1]4¹ELîŠi¦xÞ9KpA§!agž‚R«ÙpÎy,›³aÇÙðºeán€TôØ ß;bˆ#…¢KˆOÿíÿ]û¿ÚµéôêâþáþDºmŸéãïø÷éLÀ&#Pcˆ&îΪl‰2Ø4콑‘`Ò®Ekª”¶H\ÚtÎÅ6“¯ò¡ŽüRñzÜà¹zßùdTD¥—kO“4!0† Ò'3¤½ŠØô—iÏä!Ç»O5Õ€øF ð÷iW§¹Ù@aÅ‘ÌkT™è(]© 1•¿¨’HEü!Tcí ³AsÞ0Ùà5Õ.aMcg¢mªñÕ™©G÷­¤ô*EÜHœ¾¼½’ è¼¾f6a¤¦t2%M3°°)œ+8Π}€{ÀƸ#KÚÔBÊU¹Ò_¦‡ÁÝâ@Ò¶`*qç˜ÂH4ÕÑ…!à¶j*²–^~Kªö¾R:¸v¢geÝÄ5 …Åq²eiS‚p‡ ´ï$¢©0WQ(ŠfS*̸i¿œ T +Zn˜"DM«jt•r «Àp˜7EÐÍ¡“¹gR\E_bpAž§¿Æ ”Ø|9P¶ŽH!oø9CÚV ­¼B£WÎ5ÞÇ7ío貟ƒ›\ Q-†\Éþ õô !ezÐäÏõ2÷*ÙgªT>f=æå¦X¡xV”r¼´¨%ʾÎ}µãßÜ—ËA E# ‡ŽÕÿ“Y°%ÿ5çØ=B–H±µçuW•˾>7ö­ÜÛzñª¶óTÝgŸ7—boˆ™Ør·€uÔY™¸Cí|ËXé'cófÞ¸™7LË÷úêŽå>v˯qÍ=RdŸ(²6£°v#KfÅ’Hõh;ߤœ»MeÙ›Oúªh½Iˆ kVugÍ2§Ã3¬˜úcÙűé–>Jå\ÎcªúöN³[ ³¸ê U£Ñ?|ƒ¢A½ö(¹—Åm™ÄZ'ÔÌV µE5—ä ÅU.qc†!¬9ý‹ '­›0Á÷lç¶2/S‰êêz£ávèDG{®TÏÉe惗ö#°kê"²tÑáY(f× © $Q3Õ|—ð*^½¯ÀW3,§b ô½žENW:&V)±=mÃd7,~—WUb !oÜßZ´H'¸˜^CYÙ5g!bóô\®:wÑ_))Ø!Þƒýbu¯|ä~ô†o©ÌÂ@%tÃ蘇moù¼@L2d& ]G#KʽºŠ¿‘Ú¯+Î#O%®\•¾tñê¹ÐçM²ž3e¯ìŠsÇ*JC@HàâœûjlŽõyòà€ö[>stream H‰´—ÍŽm7…Ÿ ßaOn$ÎŽí*WÙ0JÂBd†¢‹ˆ"‘)ºðö|«¼{c´úœ:.»\?k-Û•ûn¶âz­¸[›~åºsíŽaÞ{˰zúõñM&3Ÿeò™µ¦-9í»{;N½Û’ÁsÆãÔÅ˜Òæª56ºÉ°ÝaNbXín½g9Å=ÜR¦Ñ¼Wxá­ÖÄ2$‹³_«ß-¯oÞdò6M&ßkÖšÜ{ɰG½ØŽ_Öà"û8‘€á~-»{hɾ׊¡ï{êäÝîÕ ƒß‘fòÙã ¢‹»·µYãwކ!ï1;'ï¸w„ɰ»G9mÎÞ!Ì%ŸÞú=³/Yr·) g¶æ²ÄÊ)¯ÞHqØ,›Òˆ…ÜØ¨U³¥É’·eÖÞ6ÈIùñ«eÈÖçZµÙÕB1­Š ·;Sw'q}óú rªÂÝ&YÔ*×È´jÚ©Çí‘K9²iߢ‘ZåznST}+έ:OsùF¾z¿’x§¿Ñi/gçîV«(ÎZy‘;Eª5S5 £°ÑßýTÉèwO•V›WZæ"‰Yaòit,£8aæ=󚺔u­š·r=í½6êT¡å$²5ìd“^¬r±Wèbúúr²••F6)0†¶NCbRƒo ÙÐaP{s—Îå)Ú}ȇ;VÞVeØ®‘Z0.MÎ0°[Ÿ^†÷ªy;`²L›÷Î>´ËJ‹‘¦m ·¯Šnè¤bCóP1_mÇ÷R}HåÝÛʉfˆ¹Ø˜Ë®“ˆ{m64ê?¹Ê‹d/ÖÁôº‘FÌËø0è GßÛel¡Œ×ô“”Á}4!ß¼±g³ˆk°ç‹84O"ŽÁYtV :¿wÙ¿y£²ï”Å ÐNÄY+¶3Qƒ„w¢šjö²ÎE›c”§fïždUÑ„¾mBd9 @]ä±o¯à'ªï>I0ÿÛ ¿¦@BÊ8±ÈRmÔ~`ü •ÿ«¾?—P‚vÖ/Ýi¾ÛLùn—¯ÞVm”  0)‹ú…t¤þÓ•iófZɤ{}‚ƃw¦³¶v¶>;PòŠmQ5m詘þñö—·_ýí˯~þü»>~þá§Oßýü¯ë7˜>PWPYÿâúòÏŸþáÓ÷ׇ¯¿þêãÇ_~üÓOŸ¿ÓÚ/®_³ò·ü½µ«]ßþý-®_\ßþ GÍ¡ØyÿÛ°ƒcªMr°(É¥z´%¡ö óZ~d=½£°‡ß#ªíNÍ‘3º1ÔÒê\¯ Ìhv¼hø.™ó&ÍjY¦Ú)«€á¹Î5§ÛIy¹ f‰ª&|ÆÜâBè3©íA¸Nä`GLë#ƒ5>NÅF?Ðdn…²v9~8E=ŸÏ‘['qY‘RK‘Q‡”‹x÷CÀtcpl–×þ'ëׇ¯>ýô ¬ÎªØ/”ðü}ÿÌ!Þœ3—”ΈÏD)ÜÔ ¤¦¬ƒ)5˜šxã€ÌÆP8‚bÉ4“k¨}…;Ê"@¯9O2ué‹B-¨gÐý˜( -OÅûTÉÀ2 r³a¾†À4TTš ¨º"c q özºˆnš¶¦B“¬q™Ÿ>2Z®H›1Ñ ÇUÑW×Op~” "ÚNÿèW[ ¯oë¥ÁTcáû *`»EªŽk d òL…=7 yAcîã§ 1âù+ØÅG =æ|GrÁ?½´* ¯¡V]…¾”´‰œÇ®Ú1E PT1Va7t!.&-SÊÆ…ˆ¨„x/úÁÅ5¢Ž/?MÒYefµŠ¾®Ž€w þJM-å†2v%£{€ýÁçëÐ:;ÁËÅ/ÁÿsÙÚ’„È’ÅŸŒ›Ÿrt Ý*+ . ¤`${òì>„õaì8;yHÌ­6ØÏyp1›B×9÷ã—‚œà~CH{#õŠå[‹÷ó¶k¯Ôm4øÐ{ß%<%Žd‰ÎE]Í~Ôšf Ý}©Šš½ÐæŒôê,¡bŒh¹+-H¨Vx&<d_Ùž*€pþ.AN X–·uÙøÐ•ž$ÊÑ{Yº^¯,²ÊB—[<ÅÃäŒ6‹¤k rYJÓ½x:ØA²b±Š²^~bjµˆÎx·ÌÚ‡ÙÝë (H·žä«ÏQ¶™qÜ€o/9Ž\Œ³Q• ËŒ.Ö­Å<«Vó“$M©ø”Oi/?º–¯‰lcœU4Ⱦþù¦ëua™B8@¥äc¡<~òdyÂd¼«œé‡è+-ºÊxœô’f?e‘œ®Û8ÒûeËJ ´óôšùÉfw5yHøÍÓ•qù )®¨^ÙÕôÓa¾%¤¥ëZ<]WP®®ìI€“jãíö´tœ{ž¹Ñ ¬qîGÒkb¥š¯ÕHCk–ÕT2,ÖUÔhñ>úzÔà=‹¦“fð=ˆ±uI“Íʉ@Dã:øT¡l«Q‘xuQ‹“W½#(a«”X¨Ã” ZÏÔÆR†v w]ûÁ%a‚$ŸDÐ ä —é6Ä]]¥DþcXÙzàpZ¦ë…yœNËÛrªCLòqÐZtt ¿Âç:Áƒ§(OeïE“Ž2¾ÔçáH=4L)Ú°žZG–qÒ(bÃß«}øïb™J”‹bî­Èëí·ýhuðéä÷äÎ΋I†\ƒÀ]ÉÔSÐë14jy¨m9ÞÔ˺†UÞbA)Œ¦T–¡ð;õÜ:&pH²DÌV²dÓ÷ð[xÎ#\¬zƒ‡L¤†s<Ín%ê{Ûó<}ŠøÔ{*Ò›­Ó’„PËæs#a ¹#žYipŠyÔâñ¦'© µž»'ÜO¢:}ðQN{í£½¦† À>ËÐ$J] ië„ %Ø–D~™Ä(èÕñ8é$«ÇZ)—ÿÔx¿ÿÿ½çsM‘“žŒx®¢}1mÈ€?)†Šô(Õ|wÁ¶ZläÑÚH#Ûyrë9‡úËØ£‹ƒ¿$íªoôN¥ýŽ›¸¨î.Ò—JÍ¡ùÊ,]ŽÞØõ0|ôZ t½/U1HA“KŠ)ýœ—[B;qªAW<Ž`«W±Þ8‰ªRP‹÷D9á‡=á5û¿¨ûõ_꾄Ì.ýB¸L9^z)µ&ÖM8‹³E Èù쌳]ÌãÒ2~ðAï0©”ª‹b»>„æmŸy‹¨ÑLq·Ö‹±’Ý‹¤x'qbÈPçKΉÐå§)^²½qêE»‰/Ê ›À©ŽW`¨T¨æùˆ"i)Ô98n{K¬þ›õ²×¹í¶èÜw8¥›%ê§Lo$U€ô’*N•÷Ïš¡Ž›´..p¿­½%ŠœYäàkµx˜4AŽ@3Ú`…IKs– ù—ý‡T4uyq’A1åbÛ”äÈÎ{“î‰Q¶ŠbiN<††Ã.›7Ç.‡üŒáoƒÞœ]ùÈ ¯iâf€"dfÚÈ6ÓÀd1zyxÓ‘°Ý'À<´z¡£Y”ßchg½‘ˆ0,‘íÔÖzÃiU'|mxò{¢UÒ¤j»¦ÉBOÏ5•‘èê#j¦!HvW®ï¥XPÓPÚöV\*”hesÂkk‘·˜ønï,*Áñdޤ‚Û³.ïÒ²='x±åR^¯_ýªïÒ¾ë=áæöd𨗒ˆËªì ‰}kðYv}ÏØªÒÜòë*é+³Ê‘®8³(‡¬«"o#¸Ëˆ:P±×ýA¯$ÚÃÖ}µ_¨ ˜Þ8 ÇçNÄÕñð7=%iQY™L€¾>uPå3M™TÎÖ¬ò.±Y4HäîucùÎ5Ó ¡¥eÔŸ…ÊZúÔí“·Ûu².Õ½­ªîˆ ‰FýÔ%ßQ+ÙZÕTý¦PMObQŸ^¶»áBupWÕÑnvõ-Š ìŽ¬‚^³þ$µ‚Sä·ì¢*ëÖùSˆÿ|Òä¨vÿ¯£HPq-Nñ¿‰¦ZÕKV#å…kÙÇ;Á3JŸŽz FQyñ-œ­+æ)|7ÂÿkLˆ¡Ì³–ê*í}_q¬¥ûFÔ´¾é\­cX”&Eûü=¸ª?öVMù}gÞ;ñ¾‘¤³Ö*š/Ú£’# ›Q»fò|1&¯þb µšŽœu–ö\i`Äì•Ë—B'Ö®|q·÷ÛçsÅ­lßu^!´sgže…§¾«AÅÔjŒÇ¯nKßUÖßÕêáóʤdVe2V¸ ŠßçU~ô‰Qƒ‘žWZ·ê@@÷[Þ­ûªu²»oÕ7Fú­ùlßß÷µõö­oп»…nïïË™­$‹;ÚÖl*1 ø½¶}Púv¯ªm4.Ý·ýá³6Bá?]cÆ·À¢©éÐ ÷ŠeOìèy«'t×";8ùWð§»ÄýRÇn~Ø›Úá êWùÞXõA©£ïv¯z—"Õ¸RGŸD–8O4d€µ.§Ãªzkî]ëÿÐ_ôj-Ö\¨Eì÷X®CC˜56åÿHúسTízš\Y‰V-5KÙÃèÚÇÕŒ#¡\ãÛz´sí±÷Pÿë›Ìn‘ŽG[«ÄÐv—\ݺ(;õyÛˆ>¾Z±Ê¥nÕß~ÂÎ6³g±eì6û~•ÜÉŒä]gŒ§…ãqÆŒ|¡ÚVliK«U–T¾\\U¯ºÝê𯲂ÏÛ‰Ýó{ÔóÔoË{Gª"°­iì¾3€ò§xé<§Ç:Ûžã«›´Ð¬ªˆöt¨ÐÖùt3¼ÎÓE1—ب§Ò$ƒÁÕÈf•þ+kdgŒìú¨×ªxÚÕõ€à¸ýt*¦æÂ·j«¥?®Úq[&`¾­*GÝ6U#+#GÖ¦j™«˜ö]%ºZñ‚Ý/Ùí(o6YeR5i’£ûû­ÉÂÃ¥#vA-DõÖ-+šÀ·Ï°µ•`ÁñÑÇ”¨ÑÇîòƒ÷õ¯þœT‰]ÙÜwÇýQ·›ííg«qöóëU­× KaŽ^ÿ—?¤úç§?ÿöŸß>`€ËᩱûŠë¿TÛ_ù÷¯ƒæÄ¨>jÉP…àu¡"5>üö}HšðHý\È>?£xL†^EæF3‡}Þ ¸¹£ßoë÷¹­× $‚'B-ëwºõe•0첚ð{‰X¡™]%bBjv˜@O°ô3þ8þ»§H~ûq¡ƒ¶ÿu¦ ôèwÿ ­÷.Ù•~ ù‰0š¤^Ç`Æïó³ü‡Ÿ#$ 4nðý¾ÉF®:Û‹£4I{$¯Q‚Œ„-¤R+„ÆŒPD<ÿ‰[³jJiÐç7§”fÞÿT¿#²ý§Ì‚•¨i,}“3Oû•™À§†(ŽqÏ܈ÞIC~Ø\ÌÚÃì†ä]¹Ûˆ…ßæÛ;Ýt;^îh ¬Ð‹¤G\8¿átø¥{¶¦B ´CLd]j!ÇgMpƒ´7ì—ô²)ɤ·Ä³¤A¤`'É¢a‡õ7d8äâÈ•·1/n©ý#ˆ¤äN$‰–¾GDCžW§"ެ­€‚Ëjw‰Ø6IuwÕÉÛ¿Sþ¡}筙΃¶5iò^€œ÷¤¢Ñ‡—˜O8¼ó»¹‰Á}`À©# ~<-M™7y¸Ê½#­,ŒXë§žZGºàðA‘R»E±ŠÄn>X-w}®‹ðÈ;꟫ùI¸V£ÙÕ&Ïe•ÑÒ1²íc—öˆÈA×òDanìždØàj‰áŒ|5Õ—N2íCÄ·D»Êú¼• .b릨­"pa\ΓNŠ›ºÉ[BÓö ¸gtýwÎá%!2Bήß9÷}×Ä`æËk€™rzËæ N%Ú™«M‹®ü<]!S›Ârd‚#£i"%ÎÞ(Hk,š¾&Í{•ëTÿ…Ò?4„ž/t)µ¯ÊÝÜu7ç-$%Âeéb Ãӆܧ‡ÚxëÜ(]e÷¿T HÿÈ †E"kªšúyS‘èªAÝã­,išnËÓ¿OÝpäö÷&€ŠgBÃÝ÷«×mìѱâÛ©A~òS!j"Cyî‘z¯Ófz}Nšç‡ Gª!%µÍï²-,:ŒÁF‘±£”ðª©&Ê@öÑLªê¯*„ÕºªÐò-o›$k@ µ&¥Ëá—J—V5$zxšJÜ.Ÿ‰å®šcU‹ÜÉ@§®Ò¤5l¼QÕî+ 2JæµÚðÛ¼ÈY«f4êGóK¨ô¥,EQÿrynט5iÄð®ôÞá©õ±*°»-ˆ³ö,7cÏUƒ-ò)äÔÇ£Þ©$SG·äZÖf&¤ó–Œ…¹"YçÓ S¢vg»–£A¥ƒ™Ã7Kù.mÙKrýÆ59rj@Q€Ä÷w$æ…tÌ~"i>98[wÚ§4ö²œÐ0“Z&Élu1”ÂõS‘–*M¸›DïêªWSjíôè7IIÕZè–·–(•ötI¬¤¹RÚÜ=ÂI»0( cu ª*:竚c†ï%B6ÁVF²àsëÞm$NŽŸUsUnê2òko»š&°ôuì>tÄæá­+ŒgPksiÿýûå²£Õuá'èwø‡dÐò¾_Ä3²d%–'ö,"Mû"5Ýj?†&"Šbf øgŸ³÷ÚUµªôÞ}ØÉyšÂ†µÙÂÐ5k¬æ¦>ŸH}í¸nµuÛë­!*_wch“YéhÜl϶b> Ç5Ññc£2¤•”|Ô®„ž•º,Línþ2 qB<Û—„äƒâ®YN+PϺP‡•Gª˜ØX“¢ÐNa±‚pkK>çÉ©uÚÒ¡‘;,œç¼Ìʲxj™ŒñLaضÙ+ã«‘"Û¨¯Ûè‚§ÞÃ×Ó¨«¾kxÙÉFÝD Й4y7^vÏeïf;…‘÷Š¥þaùkñÎChx>Û_›sÖbOMàèm ¯»¶ßÇïš<|à˜¸TŠü³n\¡ïªˆ1r[PEþ{q=ú=“¬ï¶¿rÆHº. %2†'„,¼Éï•ü‡C¯Ð`b{‹ÿGN´'iá³ÔóúâÝÿ°Xüð&}òÏ|úîçë77~")(}òûåóuåó‡7—ò•§ëgO;´}åéöÙÓ ~|íéþÙÓ ÷µ§ÇgOMêçO¿<½øíÕß_¿yzüðîé†NÞÿvýñï¿|xûøþ§‡ûwn®_Ý]½¿øÝdw?Ü=þ÷E?_ß^ßþãúáúíO¯ïŸîcy:}÷ýýýÍÿ´þÍãû×7÷Ÿ®ã/ùs‘NéôëÛ‹qzñ—Ó¯¿¨ëÀ=CÇ|¸z:Åûn³;Ò4ä¡iŒê²¶B£~_ix(}ѳ`Ÿi?3œ—d5êÒñRÁü²³—(u>|¬ÁçW§Ö,égna¾K²‚í=c ý‹¢Hj55ý”Öw öŽcFƳ\µWI¨˜îÒÿ]Óô‰Âú½PEUæ²ÛàeôÕ]Žš÷ ¹RsÁÞeµRØ©é>6ÉäÐðÚ’v%? $Ëîä§)‹’ç°gë¼ ·6Z$}E¿ù¬¦.=«;œµ·m›y´ä¯ýO¢Iô|zñêîþ÷’Ìô'¨ÿ7þüóBh¬“1…II˜Þ^ȵ/·J«*?‰|ø—Hr]Y~:M(9[P¹_YŸb+É€-Œ` kÏ ‡LÐľà=¼¦ËÉ`²døJð¸œ&38•e§6d6&[Þ7\$¾ˆ×⬖&a 2 eÌÚŽÌá®ÂÜ;òf² ž;²ÆeC8ˆ*åº3ÍÔ(¥@’‰lKÞÙ^³4Œ•»ØÖ¤CS±²fS’±]H¹GS%XÍ6ÏQ7uü<¥1z¤S Fv¡®#õÉaQ¨kœ³éš4ž9¨¾š¼&Ò%ëêDK†ó†ë<'L"—wcƒïT¨€©B[±ßMþP¡IÁ¯œ ‰@qÌêìŠ7•‘ñmºGú°Jqř薸D ýŠÞd>^ýê„Ëq(L-ùVß;®EâF¡cu}—]±¥©D {þf]n-¥s`¿@é)Ü/÷, 8Þ"ªMaÈÓ(pÖðå™5<œzM4(ŽÜKd7 |—Œ’};vNçŒÈa»p·`OV^6[¤hj¢ˆC?p–ºŠæH ©—ÿW GëgÜÊŠErü̓EŽšUšzäaÇK†ìÝ kªÒ‚9›V<3·rú‚ÔˆüÏ–Á‡®4ý® 6o]dós{kV+ljç28¥еºƒ@½&³ì’Îeæ¥ôCʘ;.»ÔµŽ\É@™j~>:î¢‹Þ kª€q̶>¡÷ë-¢ö\þ˜IùLXósa%çÌioÒ:÷‹®â~ê’ ‚ÖYðV°i; Iì#ÇÌ¢¬€Õ/Ëx—­ÚÙï©Cà%Š ¶ ]‡qjg¹]ùÖ@tð®$ÖAßåTràÜD1{¬Kȱ‚ŠÿZ³ù;ˆ0rÈ¢&ÀT¸M'O⠦畠¢°Õ›— 0}T•IRa,lak E.t5a(’Ô~,j3<Ú&‹úµVÆ!òìÆY™)ØÈæœÊRhd̼T Lñ»ÆŒÃxj ¾uT38w -ô÷TÈ9ڲР-BÎ,ӯף=Z7r<£ŒªB–ˆÙÛfí’n"o|©Ç¢ÔãK ©æ3Ê{e ¶*µZüÌØ-‰CîôXÃð‹d8cÍLí(Ѳ› j`ËUòÌö±·4hx™Gy·£¹¦æ3”£koZjËwÐqó&u7îiC®É2¥»fBœF笥¸€½¨¾ë²òq×;q6á!•îgªðb–"«^ !‹0éâÞä „*M«¼½¹–! ;Çe'ÙrÐ;jØ‚i– !œñ%V€MÙg8ô§i²ªYRõe±¤Äøn‚/7)ªÑº¢F¿¿™æ>Ñ™ M–[ø§!µ ÒX?äa´fïׂ®Aá{»q©–ä7÷ä× :5û™9TÐæØo:<%&_ó2ÃP¿P£+ÅiœÕ’³Ž%³/ãü€ôõ™F}Ë1¡Æw»g î8 €¡>”½Üñ¾ ºú ãëN®>t.ýÈF`n)ð)÷ \–Qšº~§DaÆÙˆœ£‘•G#ð%ÖKÆÎÅêTölF#œ¸T%VoKØŠÙnô)\ŠqÙ¯•¸2Ó_'üÓ¥<Ÿ.Eö£qg™“Žáù[ÂdÆejJ–rá’‡,[×du˜±›™˜E¦Àg)Ó”¦dÀB)Z!hT»æ°lw1zf} cCäWÍ-éaD‹/®„”F±uT;®µG‰iÚùn’Ë"“,ßB¥íéuº0ž[ðÂiA&€ûËgËJÀ1»*Åܦ0B­³¶›âsÒ=)#µ6“"h™rXTð Z\ja{ÞÒa¥Ci¹uXo?…6µ—ƒwÉf‘À-½›ÿ©kǺCg±@#’6¾à¡OxJi«~ﲂÄ8\-Gá6±Eî÷Ê2{K¿ùöŒJ•WEäêÂ5 íôª*¯¨Êôõòêj¨ÂüSe´üûºµf{¦ŠÑÏSC•ÖÔÛ-OÖÎëœ]\Ëž?Úxât¸à‡P`Rd+î›\hômö—I/7,4ÄFè¬û$Å,EMù¸X¬[aë8Î"ÜÝJ²º¾ßZâη<¢Q0ù•ÃýP¹sRpÊ»¸²»q!Ýßd Öi«l³EiE_@o‘ÝbS¢ÆxÛà±ë77däâ)– QÙɨ§Ô`²Å.E<Ùf×ÌßiX¨Õ}—¨Ù‚þæo ´‹>J‰‚^êþ7},Lg÷±ŠMʹ§µ–J¯€ö=sLÄŠ;¨VºQ¬ •;+Ý$_É‹Ãb“®»5 Xg´:ªŽÓ>晲­™0ãMú| äT3€á³æ[Õ˜b”>'‡¯%IÂvÕ)=WÆÜÐh²ÙŠ++ïæ>pP|’ᤂ‰ÚkžèIâJm°ÛwjgE@!¯hŒŽ“RVõüHš,[ ‚zB²¬wÕè“ûäNR‘u… 2JeFM²hù@»¯*…2²ñ”‹§õî!{(ôgüžXµÄ"Yºn«„xꞥ£9ÌÝZJªôprµBY´GÚÓV(+8Ž¥JžóxQ–¯¡·ÚâU|mf6Gr’ÁT\Yã_äWMoGü+>r±<ßÓ£œ€RˆKŽÈ1‹lñ𓞟ÿªª{ÁÂJ¢Hö)‡G±³3;]]]Eº@/5jð"Zd-›”\÷’S,ãh¥bA q#•%Qªñ 'M›z*Ï¡ípîé6*ÉOâ-ÝDÖ/%¸Ýéš ¬¦‚ ”©Íæï c‡C›ãGD™n»öm;` Nƒ»o ("X¡8䋃ë@CÈr%1×ੲMNR<“EÉ'Ÿ•*å}Å2ü^doõ=8&}6i» ¯L=D?.¤¨1Tð_¤| Ï–xf‚Î@ì³~zGŒÅ§k_ôäg¾¸ú´]ô Âzò÷ßâÏ7ßÞ~x·]?žï¾>°ÇñÛöðù»/çÛ§ã×»Ãööþæöxzð}êÅÕ‡ûó¿/ú´}ß¾ÿ¹¶/Ïï÷g_ž.®Þ‡ÿ´þú|ûþp|xÅÕïŒ[pÏdFÎ8ûП² Uböt-m ßErg9ŽÄd•=,9‚~“Sêì/£Æÿ·:þ<íYü€R¤>X´)ÃøÙï•¶X6¹Ï„RfÍÔZv ÒÔ¬°¸˜Ðˆ »‚­6M`Ï> `ͦ „´çJ/ïrIKn{xI.ö—ôHC¡~¨W¾¼©lS3Iþ­§XŠ×ôÉ¥™fRbNëHÓJ­Å‘98Ähi–#1¥„x0#8wjyлC`뎔F7„ÉP–ö• ?k®`\i˜ —ðG#û(Â5¬.(7f$-Å_:$ø’CAº+('A ¾1 N)…¢ÕY|³•bÊ[Ñg ‚UT24ú#㎣i)2K• D8ÅsM[Bà}KC—2é`ìg~@,Ä} ºÜƒ½Ï\jZ+.²b\ÈòƒÌ(íJ 'N0A x¿Ö[ ®\ÁÀ1S\œÙ%GM véJ’uM :”~&V |H9O§†§CfÅvkm£TQ ,è>ïáø†X8[‹Yž@Ißöæ äU1ß­;Ì£Wœ<îÑ -¾ÊM€†2~.s¬¬vÊ[ ~Êc»¯Ö镵۰ÙÕCF}ÔBhó3Èø:¤º3ž"¨VÍ{¹UEV¾l-_ v¬‹çÿ"£ñïì;7£~ë®$/2õ)â ¿'ë $ãœqõÓ²Ó¢N „6ÿUœx&ˆ0<Ø·7¥ºQé‹2é¿ æi š´Æø„ÿÃ"cF±Sh³Ó *.ÀŒd¡ÉJ,XMÌ¢4¸rEV\Hª$‹2¨‰³ÕyVÊ+‚¬x.§¤¥0„#ûSm‰BÔ^‰Æˆ@½ÏOʶ$ùÖøÚÆOÞ—66ÔðóN:ì*ye¬l$ÓÔÛ×Ò§á+»˜L$×ÿ»chó+QÇVªSe} É ¡MT—Ç& Êy F™®¾š]‡£@4?ImÔþZ™mü![îä‰á¿áÕjl*BYJÀ ”8+ø²ÞÙÑ€êLÊ=~^œ­6¦L@0ÞûgÍéÈTßø7ÀèXJýñù!¹µ€ e’êéKáÍQÙŠ¶€Âê« ZÃÿž«NÁ¨Ûº_ÛîøY†™¦—Ÿ“§_TT‹1,y@$s>@ü–ê —ï+îÇ ‚´ä/Ô”P.38˜†Ó7^œ¾àj¯Î8W/1º±É q¢Šø«8{-¢zS¹ç ž`e@Í^ÔÔ©˜5±+t2FƒîQhA35ÌXÔ©¹8àH½FO¢±8Ä#·äàhâ´Åh—4Že@¥±!ùSº·_ •s͘S³Ïem-VHò·±£Gd_ûÒJ×#,ÇS#VƤ$Î A1—ŸéÔﯩ㼜ʩݞè8Å­º¸e|…úUí.+†y]Aù²†SùÕ„|´Ï ÒtÛZ'›±ê‹"(³ÛF—»¸ñ•˲Á±D¤UZ®1Hÿî{ºó%é+ñ’ÜM`1J‹ì`þ¶¢œ@(9Rƾ'’Nà«ü¿½0¨ðÛá‰t¶$ßïW^IfÎ\?¦‡ÒÁ€g,b n¼4šýÎ<Ñ~ĉœØ¨”ËX¬ð>:.A®X#O„’ÎŒ™»ÌnB7ڨ䎠st×¶óå3èœàï4~³ø6ÌcX—µîô!ûR4[gÅÁßÙ,á—¨ OÛ©Vl$'>z&õÃÞbŒ•Ñ5=;¡åLKåìªyN¤hðQgG çj1]¨È}ŶCî„FZu~Öѯk]±O~ÎÁAÞ• ûYQØÌ3F(e@i¤øŒTM0S›$ÏŒ‘»èÜÔzsjáZ–¨•FñFÀ°nj*íûr9•ËŒÝ0[LAÄ0Ê%¬9üùôV˜‹™aPsL c“§Ì˜ôqÔ?zäIöHTh¥ yBñä,Ù˃s8ÏŠ ÿøVº-î‚.ñâ¥þƒuâq¼àcðG6ˆšDxv†KyÆlR& \7²Ñ¼RgNu4;ÞaôáÝ|åþ¡f®ø‚ŒÆór¥°bZ‰…†pÆy_8 ïaá[àªü)÷«…û&CC¨Ód´})4‰w >*ál1!]ôlq §!¬Íõ箺^‚ÓÝ1ÇU“ ³­Ž8ðÊ$$´lfÇ(nDð>©%÷Eÿó¤pUè6mŒÁ´”&lT/«{åøºÞ–/J÷}ÁÄꦄÃóAur¼nÆwÀ‚ƾ~+À>ü;p ‰êÅK@ã^­&®ªËZeÄ•êìq/¸‚âW_WÜx2T é‰#uXG–,Vºx²ÚÒzA 7äÄJ)êÆwÇ\;ëèjÈ04¯Åçšk×”j ]Õè‹Hï²SªWy;l~ (ˆ+d 'fOÑ7PIö¨Ù{¬Ì€–w报è/›b…GNÆé±2ãŸq¶ìs\ mžB)›h7x[Ã;¿—¶|)&Œ‘Ѓa„&' ”ñAH,l.AŒÁ!ph„QpbS@É_ö«½ˆÀcñéÚ=ù™/®>m×=2nç'ð[üùæÛÛï¶ëÇóÝ×Ç69~Û>ÿq÷å|ûñtüzwØÞÞßÜO¾Q½¸úpþ÷EŸ¶ïÛ÷?·ÓöåãùýññþìËÓÅÕ»ãñðŸÖ_Ÿoߎ§í‡Y–6Ëp15¥0ðTs„ˆ%íÆP`á¡ÜáÖV!Ó•#|‚SvïM©¤2ÁAkjrd‘Ææ±ÇêI6Z\AèEÆÙÿ®¦?G·ý:º-f3,$f7.éS~î· ;÷—Õ(fœtÄB3’¤+ }Ý(+ÅvµqÇŒJÎl\N«ÊuðÉ­gyfNœìa<*špÔ‹G€íÆP §í1,N*Í…7 Ï´»H”1}:RBRâ@xk™BªûtØJˆÚàÑȺ¬€Cp-J)À¦ƒg86Í\BÆð•ù4˜`ðÆë`³ûðmt¨Ÿ4Í<'¡ùïå’dבÃÐô¼Rä?™ãžz5Uíj0¯ÚýᎶãi¤zÐÍ ’@÷M$­Ë¦PúÎ.Kw«„DEõÑã‚Æ2¤Ð4O"í¶ç Šh‘KÇεèkæíduš!MÊš§žVNE.WvôTÍf¹Ÿé9Û¦CK¨ø1‚,R½ñÆ\èH{ëA3ZBw*ÒXï·•Çñ•-1(gáhBLj]о%aÚúº¤ML„:$×U7dþžyžèÝMý]±3\/VH´µ/eËœYF2\#™z í¸`¤þ÷¹åØ£Þ×5Ö”ìï‰YfNœÁ¨hL~Ï`¼B›þôùk3!ÀVÍu).Øç˜ÞõO7ØõYnMÆn9þ©m´ùЬóÖ>ëÜ?¢WºÏ*(§øyJú\v•(S7‹¹¤Ü‹ŽÇÄÄ辡ŞòÚbQ0Oõa ø… PüÕ:#ÉÝ¿g…Šlá†ìácÆÙÜ©µTi]ìÑ+£wO=©! ¢±­rílô›âRÒöJÍšJŒ|zŒ¦óêPC27&¹Ö—ƒÔ'²´£“U˜ÒOŒÕt\]’¼Eó®k£ÑiDZu€8aÔ\*Àš²Y3ð¿Å”w¤ŠˆÅ ‚D7Xi µ+T‹ôÛ£>`–’Ù‡UŒºyáºjø­e wJÍ&l£sØ»J†õªžŠPõ—”îD±X8*‘» ª”B矒zP›o«Va7öŒÄzü–ÓF"£Rƒ ¹·ª”yöé¨5Lc-û—:­ð•û‘ï-ƒV#d®ˆç¼…¶R_Ѻsc‡4V³\û±ôV6ìÙiéšè!¥xðuƒúL œ[¿’·WâßkI„Ùè~xÒЪDƒŒâ"ø gy! *†53e#{¸é.$€\‚ê§£ÚA‘–Sº=“ø›Æ©ÀÚNÎEr ¨!Jϲƒ«Jð1äÌ:µb¹°ßè¾V³„~iΨE·òÕ}†þ¨~ÊUÑKµÕ€4{ÍÆSGYÔœ_hT£î'Ó-H½ Úò•ë:@»Ü,XôPÝø”Ï91j;ížÍïÞäd‰ÌÎÏŸ›ÄïÕ=™´zÝþ›ÝSÇÏYh6c-i17ÏéŸT’Íçjxç[Þ!ùªhÛjÊ8ÎÿÑ<ÿ¯+þ§yÖ׿9†œB´th•Ìü24«z 5ˆï˜¢¶?‘ëéþ=N~5=‡ CE5’?D린h2 ÄöïÑR¹ Q?Ú@= <ÀPª,ÞîÉm¦#a%ÕРç¨×蔈ZþÝž%¾ S Fù®ª~;òfW¾ê8÷=ºB"t#B€Ïh/ îñ›iþo‡MÖDíªû‹Áób%Pwñój=õ®Q‰8’ê÷›¶ó›M³ö=ŸS$ç?D~1ËÈ ¢_SúN¡ÀY«åV\@°f5žøÚæ8¯&ÐrðøÝ¢¾E%´ŸŒlY¥UÄ¿f¡+ˆ:ø²8<´bä|»X÷ ±æ•˜CÊhOô$«Æ†ÏX´ûcÜj«>iÆuwJ·/3Ò–¨W0Øêä¢ÅA°µ¤“Xj°Ùö0OEQÀõ^ÞE“ q}zú¼ŽüX‘öÀB†5%;£¡±ý~Óï7ój$oð,ºˆ”º3J—Ì;m‘ì3¯·ÆÊhNƯ®óDs„ÏÞÑS÷vêK@´+„m4N*¿Ï™•vTnp¼‚w®e£2šc=MFúKO'°Zó7M#4‘™m{ÚŸ½ræ/‡Æ?•ÜW¥pvôëêðö'µ¤™kؾªÑ¯¡*™¬>Q-’u#k›÷!Td6 ÀA ‡?‰Š`0ný>á¦rB=n£‰BG„f;€åÁ®)'%êM˜,êä8 õ‚>°d‡6é“‘ãÅ_ü ‚¸P*U4°Ö(¹íÚõ<‹JÏEêü¢¸®£^ï7Ipøz«ïÒù``6ª©ŠHXxc7H€Òò¾µd\Ä|G®ô½n`‚i‹à1ò›ÑUÏ2ÐÊ™$ƽ¨ØEPçN^€miU´=wÉÆÔ»¿ ÀB•XyÒñ85²óÂ¥=ŸœdC‰<ù¿èñÎÄY´yaî²!< NŒ•…ƒÞ}£]/¯œ©Î÷¸ÔŸj¦ÚöH±¬‘žî+±¶¤½ÁÜ{AÔ…d‡Õ`¥*rÝ<ÅVlµb̹HdN¯“kj²¼·¹þ¬ëìÞoUz÷ÍW]6 ûC;³×g]otÏ.#QîyÒ%Dô0¢r.á* Ûë ·ìŠ±2ò+Ï\;Ú¨[¶Û^.1Q çõýbb“¯3råb®Þֽ¢qÙjCÏhL¼8žÈqø-'êy“‘úa6_ާà½è:¨ÓñMí¥Þ«îuc”ó¬CÄ“¬1ïq!:¡™ì@©«;é=æ³ìLýmrÔ}¿:L¹|Œ yi'ò›u#õBªwN(_)4_9l®+öÌá$l‡Â ÝGêˆ'ÅYo¥ì_SpCÒ|ŠãµL<å°µ9I°kH)U+.be¢W¦LÖÅ+ ¿Î SêÆÈlþ}P^ü^i‰fѤj¹ÈÓa¢ûq€'2}„a#£@«äG>á»±‘Xj•I˹w™£éÇWT»Qï ú…ö`öð~íÐt‘ÜÊ Mn›ËZÁÔ îÍ[[¶4z¯Ÿ¯Øî@@øcsæG’ebOôš“·z]¨ìv/9îlà ã^¿f@cÖ±¬=IæÖJd1¤ _%éú=z¨ßw‹*AgC⦸¶Zâ'à4=íc…ò0#=¥ 3Õ íÁ´[G2EžBÀØ=}N™j };L”Ç…„ Š4 °*ö±eùƒ÷r7tÇh›C'0óñ €9¬½ È•òw·ª¶æŽ®Ûí©ÈŸ$ž-ÁŽ(yÜ éHXyÚê˜ σ¤ø±h8DÅèz•kœê Stë*MEÏÞŽ’6¤ ƒtÓ$þÒx[–Zp‡6uÏgvDnä_:§+ý„BÆÛ­ç’i'G<~x镜òç…¿°…H?Â}vpëÊšõä–žV±ßTmQ1`)ŒMÁÉd©Ú’qª j_Þl Hêõ&/O2Y#‚)c‘Ì !ÈäT)ïXÛ¹†#ÈbHÜ} ÉQQ`û‘Í ¡h%q´°Ü¶Ðj“yí[Çz’x>…ä¬ç¾ÈKÍÀ)ŸÉÆÎK±óñ7ô¹n°mèÁOзÍS£ÈN QæL©>¸íH²!häa¿û$i(²þXiμ9Ȇj ðÌ»O²“Ló<’Þ³:o¦ï›øÇuñ|¢ëóà;^™yg?ù ”’¯K¡ÓV†ô‘Z4»a±dÜ5l¾+A#Ö‹¢íL0Èh2ÄBˆÄÆ-—C,4Ù” {‰Ì˜38içE¶{›¹j”Oë,à$]M`³ßmªŸ`ÞÒï+{=WŒ¼•Z‡Ÿö9rßR5$ša¹úZç£Õ®È/#¯+¯ÈòJÒXEà ‘f—äC$qî>Ýùx2¯ckéûž¸8v´¹< ‡M˜òp`­{£Am™7ÜÒ(´@ìì2/†ˆA‚`\;ÙÆh@Öüš·‡œ'á•.`Ç]–7«}˜½–\ì{¥;9iôs3ÁrétþGmc5S5™–DI%2F’6žû0¬ŠQx&ÃëŒαŒ¤!yH6ƒž¢´ ©÷ÁÓ»lW1 "A¢,6Z1ÖÎRCDkí4&|#ÉY—ÈrôJÏ¢ñ6¹nþ ^ÜbøŠîzé¸4ÃÜ,*¨„µˆ[Ó­OôrïšC~Táï‰s‡€@MbqD}Vœ;ÚžÁ¸¬ SŽcjÕj½È¢'IÖʈÛÈNä"ßS`IWÂL‘=³˜y•>²0}œÓ.JˆuN½ÐÿP-?½ë4gÛ}D‡ÞÛ¶aàòu''dc%«5ìlüíJ+‘|íð 2gÆ’ÍßÞš—d6²ð£'P_aáßÇ®IœÕœlYN/'¡ôQ¡ã—nÛC“ÞdLf¹) ÁÌn$]L¿1KØÃ`õÜE–Oc§ø, tÔäÿX$k%‰52òµ$fIú]ìǸyiNñ,ŸyeŒ¡•S´ä´tIì™XÐÎ\×\¥€A’41+¼)¥æ,L__–hÊ™T€³1Nq /ÇuŠÜ)Òd@6!)€æÞ¥1ÖÂSe°þçww&b0fë@všÐÞÃSõúfPuÿKk¡y*Ðê:ÀT‚?þSp<üo" ‘÷øA*Û÷VŒ0xÒwœ?owè4å $ pʺðð²RªK6Ø$9º„GZIž'ò>×µR6SÂQË çç]v AŸ¥kÈy]úë䡿J!/ú¸[ÿáÕ—†v¢¬†Â›;½eS¢%¥ ÀöqÏeÛ#‘æ !MD³µ¸[çÚ ûådç‘)Ï8~Q”câûTtùUœµÊÐõ>ÿ /MžÖ©nu'Hº¯‹ÝÊ)]“-ãežt§æšô‰y† &¹7eK$µg@Q8ºÌb^ÉB8X™‰ FØGЃ'5‘±.µT® ƒa ¶¬i'ß5EÜÕG±GÁ§¡ØÆ¾Y ɵ,Ž\Ëy2‘‚_¨KÅ ¶»u!°>îhµ¹ŸúÂd䱊0¢¡ÚLÔû¹7éÛó{}Sµ=sk³ü‹S9Ø­^_“\>vä²m–F‚&Y…ÜË”+‹EB& aó:ÁTäšmŸÎze0ë0%‘®3ƒY¶h'®"%[¯}þrqD”‹ã]rÊ]S) ˜¶û*8÷¥‹é)±Z¬Ó¸d{+²Éh\1ëT¾Éè?1tŒû½$Î9²ÎMýJЏI!-d§¶BúödgZ")iíµ 8Ò˜¡S 6V=ãHÌ® jTæwóܧhê@²5ò!˜-1d³T¶%Û÷î+71(ÆìË<Ù2V„üb_ÉNóûlÝ¿[gå×-×ôd>^¯>c$“aËdÙEm²™^lŸrUÌfÅxÊG|ô»»õrtôºÎŠs .!ÆÔ½›Û¨K®­*RîŸùÆ3ç “½l!K)œ|”}ôêzÍ¢ª“}Ýw½fÕ ç3x–tž¼ÅBv÷ÎK›ï²ÙVa#*z ¦Ï(†$ͳ…X¨×Ìs#È0!<ŠyEîádù3‰^Yeò´¸è((_—)*]CG`eeˆëßã»ÜvÚ»Ú&ºõ9)¨TMl›3.e#aJÀÉÖÈÀ RK%ÊìäÖj~`Ò5b(Vÿ&Œç]-q¡#¨½ p¢i8¼Ú ¿·$r÷_[Sü F,q5åañ¹µ3óÂÆ†O’}h˜ŠÒêR¹$«ä.Y: pOFR¢žÈtRî¬3mw X‚kçó³* Ízúç)4X¸ˆ|Çs+SÐÊ‚Ÿõ„æù†“±¥×ƒ8úw_£ì6{»õk·æ+?]`é®hVH¢aò}ž–Œîëzpݧ"ÓgùÞÂê¾l†Š•d[¶/ÝÈ|¶‘ùÃÉ#À¡Ì°–SåyžAaw¶êiWSg‰qhEðÅä‡N©N›X¿ö>4<÷Ý3õ²:éÄ&­´íM!á]$IÌ(õ•oiv‚‘ƒw0“f.FÄ:[Ô@r bÔ´Dœ -d/ÙaHÑ•CúUšHU]@?ôß)âO–OÓÆiéÒ¶)Ò¡†HÍlœÑz>àêýî–ÏMm-dd°çÙ^ý2 íä#1¯P¢lêv¯y|™µ§$~}=ݙ͊^TÝéSµ.%¥O>zå[Ú›q³çÒ:s`…ÝdÈÅ-“ûÁ•5@0«‘Ðtêp@jUAÿyêìZ[¦PY†7KÏ h"ã[i"‚_NNë—¥D¼ÀÃi/h28€ÆÚ=¡Ø‘¦—HÃDà.Sç2×m1Yý‚Äù®ë¾Þ¼ÎAÏä†$¦¹³Míéï×¶|Öl­ŽiUDŒU)(V…-S–+æ©ð²5”ʯÇ4TfXJ õt—àð?À‚̾2ý<©OYñúÚàØÕsVI…QÊ€Áð”P‡gW§Y¥XŒÎø»Å3Iü¾“î:S!…ÌXŒÂ¤Òþ2IeDÎôDFÉûn¹¤k”DúÁ3OdæÕ û~™­~äÂV*‰C"k”v=]Ý1/;çN ûNA„rÀá¿GùV^B¡Z–{&°NÇ){Xú $„ôq iô º`§DÐ÷¸ª[¦5M>a|ujV¥Þ²-‘Ù÷åù\ `C:M¢ðЩ´c€±{ðn¾ée&Æ×”¦W¥aû”À*—¢õG3Ì =æœU—Ç c8Ý=‘ÙÖÈ|¶õh×,1ÒZ"«Í¬ ¯ï}Q?OºKäç#ZV«‹¼ªçI.)¾QQ1îoJú™B|Kõ>CsÌ…ÀT§;Ø)Ù[„M/!ÖìÙÙFJ 6»Í$Æ"t:{m—ú;¨ ¾Éò‡3ûËa-é@Öy1>ÐÉ>¢3SpÁ{Þr0{úâj V<Œ„< ÝØøÇ«ÅÅ0ÚPÏaÚe4ÚTKSqËF­£Å$l8*Ô£AEÈ"!+;Þ‡%qòÄ^ZSà¯s€RÓà÷[èr›õ¢á>+ ÍA<€Ö–ÛÔËz*cg¼ª¦s(Ú©xïÎ*g²HHçj ´ ¾  ¯£x/J»—Jö‰!ÈHèø¦ßOo h`¦ÁaecÜdiªë רŸ‘€õ,³4©e @u&úÈšjðYÝ=eOÊ›™nÍ‚ŒiW©Ù¦`eª4)ƒ<̳HzRK4„øy†ÝNñ|ƒPÓ°3x`–\<3öÁ&>ÁÞ@>¡Híg&÷ƒ.IޤNñ:vÎŒà¢ÑÄ1'ºª¥¹sŽíœZ*F %‡q°`]B pÉtHûÜØuhk™ q¨ncQÑ ç$"E (h¯ÃǫВÕ`#DÇŸHü?¨o Avø†¤°›&ÞG‰£7ðýA™Êa4&Z sífbqèä1=‚VÀ_@&j›±¸{ákó€ží7ü´ .çÿX¬8°à77Ù¡L¸àlt“Q7èT ª¬×Æ€m ¯30ÝÞöø=j$¬ ÊHü“)ó^:E~nÐ ÖdYŠ4# *.mA†T†Ÿ8D‡±…øb °kž‘ß›¼¯qÇ)òÄ3~a:_œßC`7òÏx"j˜ä‰…r‡k:y!X÷n¢}³)f^g$¶QXÙØ¼Ik.õüžÖE"]Ò˜&ò!ä1Êͱ¡Ây2éxhÍÏ󞘃Éîó‰ZFµÛ©Y ãdÐwR5ÂÕ¸®7 o„¯“Š”” B¬MGfŠ1 xÝL;<™Ã黸Ê@ïÙ) ÉRˆŽR5j-ÏB_j»1ü¯]„E…]w«„⌛*30=X@êIv$ãã,=ëiÇu «Ë¦¢Šº ‹œ±dUU²š9(p¾¥W˰ÂÌ@ŒûÌbl¨Æ”Ífóè}dDÈåˆ+'·Ø1[¸Dbíc)•&[t{JäÁveUôàÊCÒèC£CT¤}Ó sÈ(¤LC[".4É <’aÝìQ² ö20KC×ç JNÂç&±¡ÞÃsâa¶à<$>l"KRDáNÐÇlÜẊ]ŠCP¢¨4 Ñ[Êa#ºÑn-&¤ì3ô} b*OR·f2#I¥ÛqÊô¥ZÈf÷ñumF!<ÄHׯÓÎæÑ© =s!κùzRüÅôáÕW?ö›?ß¾ºÓ\b`ÏçÀ·õïßÿî‡ïo_}zxûÛ§;Œ¶ûßo?þó—·¿>¼ùéÃýooïn¿{ÿúÍý‡9ÞæÍ‹Þ?üw£Ÿoßݾû×í‡Û_zxyÿéýCš·›ßßßßýOö¯Þ¼¼»ÿøéÃí_ s†‹Ó ÝQNa3ÉyÅÚ¢iÓÀ¦[a‡¢ˆ$6@Û€hLD˱qÎ!9%†my g³é§gã8-ƒu_–ÿABüߥè4ÿ,‚‚ƒw‘¦ˆ@; B»ÀíH…£Pýö"2¤Æ;äÔ…Ì\0:È«ÀIlPÊ °"f/r*ÓŽÁjPhhÐ _ b oÔ›–¼ nNQ"¶\TÎÍ4ÊÉžRôŠ[A41^™:PÊÒîkºHæ˜ð/Ô¬ÄÌ0´Õ™‰›Æ¬-ªpô1³~˜­ðŽßÒ9©—{O$Š/<½} ä-RK·óå\`ñ&¡(˜cú8 ‘ð=i0®¦+BÒÎúììg–Ä!ÑIRø˜P€\¬t¿Ôä¶}“é;ƒn7+ñ×. €‰®ó\³Ì>å—ª‡äè*¥b;Ô<€!Ý8R´–ÐgŸ‰G§ÔNbÄL$¯ôQNðJHæ`Ýurå ñü[ë?ÕÚ_k|’Xà q;\ij¬j7ÓÎê–ø }„qc.; ™á8—=Ž‘¬À¡$À0B/o/þÔUƯ¦EÎ#<"ï½BlÜîì™ëSµ³|'ŠûNüâ nº»Äž…0–)ãÙ@°;obuì XCŽO—ZîuùôZ%/Û`É9‹åÓâ)ȱ«=¶‹q‰A{hM$öu„ äí=çU>óÞ$LÚy<ÝzpøÐ°r /pöM>\Àýã uzî¤9|-½†L߬ù‘:«(˜¾¡¯Ææ©©*ÝÖU}&úÃ%úJ"éEdA—#®Üºý£ ¬Ô»|‘¨þ‹ÁÊ~Ðëªx©gm‚çÐ6[M@‰W© úGnj„8¶¸Õk< ä±²‹{‘–Ÿ ` 5gÏbïÙÏ1ËGš˜%cT¸Í0\_±bÕHÜŒÁ-˜ýÅ‘öu,UÀPNYI#uúTË­`ɰ"2¹¾{‚Øi ¥ÐñçžÖÎH;éÙXé;ß4nÉs¤xz¾+”B\dªÌˆÜj%~=ƒ,›ìè<7¢+\ îËs«è(â²g>%Ñ¿X’q÷S’;Ë~ '¶-î±òQÜš‘zTÓÑ‚Õ~vÎIŠFeãBþü¥•­š¸ ß?ÂÊ1A%KŽÚ¯½ÏÀr­(Ta`¼ÖìÎFbåbÞk‡kA£7Q SHåvÕ½“2rÄÉ#XVSýe Wý‡1œÏâr€Ë ýÛRo;ä->#¥”˜9”æzDᣛƒ0fÏüÎDüÑÖyÖ£ÞåÖóAXQ&ï(þQùL…Ù €lç³Êõ›&&€îŒC}m)ïäó;îê_¦¨ÈŠöÂPRMßt®ˆ'›¤Š€»ÐÕpòÖCÎm›â~ŸÐè Ò~v™@€2*ªk#Û÷COÒ„–]öŸ¬g"¦¥>Ë¢ö8ôi¼‡¢ú›–ð «g’…¢=ZB熡³×„JÛ‚H ;BóÖhvÈoqH›zDS}zJ¹ô[ža9<Ó\b–€Yéû¿Öàú´ýj§.nüã pé´ë Ún¸ƒ7— ÅnX æ*ÍZÇ ÂdÊ㿲ÿ zŹèîf,I€±ã;:›úœ× ÈÿQÂÈêA9}ê£Þ¹ ûí(¯Ú~€{ÅÝ‰îæ ÀŽdw ‡îxð’Ñà³ÓÅæf×/…¦"[0VJWr¯Î‰ä‚Ô´)Zu @W.k®Ø&#ÔZB6Ž¡9T2åîÉ* Ÿt†à D›ÚÑåwx½&%Í8Ö9áõð¡o˜««Ëyf=FŽÈ¹´…áß.¾ø TAu_pÆÖ@ÄLÍt;‹LÇ´ÌÐ¹Ž‹ÄÞè+se玄¥<ÖâöÞìÔ¥eüä†üœÌV7Ǹ¯Ïw–Ô1ëp›êoöŽ)1,èQomŠßMi;ÁF`×!±˜ã7žßmíoT;\{ÁG‘ƒõ· Š oíú3æÖ)—¨¥ŒBW!õþÅRߥִً%Ÿ™u+xƒÖ.=j*+°yó&9_]6ŒW `°eý}ÝÏœ¡zÇy9š\åË;¬À[|ü±g²=¶°28Üît[qƒkû ¶€˜B†³ø|slÞ­Ð_ ý¹xï{„;ßS[Köß…%.’‹m“…ÿ°±%æ…îÃpÕô&måÎláîΡϽ¡¶ÕTrÇqê…ñN±,Èä°ÖÂ'¡Š{ѵ@¡8DÏðÍPKå¿ ìK#ù\èJQü¦g Ý„@ýÇYÉ›¬]öUL¨ö"¬ø]®™ÔubmÞN~õTOÀ%.jü‰ð¾ý3kóT.ßÛ ‚ m›±¨3—ìçdyCÕYL{bGVå/ǽ Àƒ¶! ˆ£ ÅctÐä˜Å·ûîãR6)õ£bí%ýäyƒÈŠÐB¾¹}§èÒ!+Bu¸Ü¦Ý52·ê, ]‚rÛÂkà(‰EŠª©.©Ä}@ùê´86>˜˜<5B¼úFmo'«:«¯9)/<ÖYKán\—§X¬’¢‘­ûà™:FHŽx¼¥ ¸ûxŽØ‘;JŽúvhŸü\¥‡¦ÕZ­ÇÓØà¨ÓºâsŒœ³ªVýȫϞ"õ±£ûsc“DjߥrcZâSÈh«‚~´jè=âtÑJŠáÖ¢(òÔ#«ËØÞŽ{Hö‘f'ÎÁí‘]rIy¹G×óËlFŽ,ÊØq;gL·¥ƒõéJb=Ë«œ·O¼«fÖÍ&¬;=ZYФ§™SB­ê‰ ßðrô¡‰ Õ> ™—ýŠ^¸+šÍ­=–ØÎi ¢RÙRö 0vW £‡lWhyÆè£…g†ö¨nT®ÂÀèþ^3aV¦'G½éZÑPwrUE‡Ð2@õ·Z/Á㤔6b³Ü”œB£ë ãn„y”)?MÜ¿h½IŽœujÒ†"xí¨ÇU“*ÖÇnÙ‡kîNL‡ïùÌó¼Î }ü†÷ yù=%2áB\Qq®f¡Ì\د O5ÐEàä|½.訖Šî‘©á¸8ä­(4”¥8Ž<Ös‡h} YbûØÙêzRKPu¡Ã|3zb:;wX‹m‡®Vò!îð`´F¾Úkvs9)Ø*Ø«®@øn•?‘¥Q[šIí{ƒØ“õWž¹Nþ2$ x† B¸tùÛ¡6Rõy×=ÖÖsÎUš/élÅSpY´+²¢®Ûq©¨ÓžšŸ7dñ,Yh'#š#¦ç¡në‘´Æ.Ïdl8T,Ür ¹ò8‘Zk¼}e]9wÔ&ß¿D,Ü1Twͧ&å5©´–£¾±ºÃÈD¨üIx¹íÖY]Qø òû¦T²Î‡öŠ„hAŠ’VBª*d¹udŒ oßoŒùïp".ñÜÿ:ÍÃ8¨zqrUšDÆp^Ú‘;i´ê¬àRF¬ëG>Õ_éü•ž¢ÀZç@¶P°ó²&ãD5M`¤.U§ ©ÕŽǺÝR;fôÇ w¦±5ûÞ%Ž£ž]5§žmDÏ©êSºWJ-:ŒnuO×\Ÿ»§#‡Èa5”!#ÐÕjQ-êYt¡ÙØLÏHa.Ýã3|%D‡îú!)Ýy¦ºÙ ®Ðá©ÛKEßáîÚ 17Ø ž¨²ç˜q;/FÑ §ªÒZ1‹Ú£*ģ؜‰ž™"¨ªBL=r¢kÅã„ 4ŠBsªrÆš^ß§Àn¡v¾È6MYìPµÐ=ʮ˺ØÛWêd-ZuqÒP2Ø7%fHoBŸÙÙq¡­Ígž¤W2 lÆ!!Óª~}(SÚž|P[r]‹‚Vj[I?Ö P—MºBe«= ¥h–Š‹DÎÇB1%ì0¤½ÛT9ã…ø0z^7+^ô{zî1ºˆ‰ ;Lg Ì37U¡I³¨@–ÅÅ1ËšÓù‘»í0ÄkY8\`aÛ„Áö€ò©K8Hßeú¼Pþ®F–žÏã¨-7+úx"ä#•¢,U†Ôe`ÕLjo;º7”m±Õ†ôG(c•bÌ”Ý|üÚ1މ.”‹`oÔº¿j©Ö8MÕ‘*°åÃ|ó£ÆZªçÂÅ%ø8MåÕøëk ·Ô3Ö•%éFYÊÒa§¼®Ú*fnwÇI5«ã¾d„ja®iT 978gÛ6¥CþÑz¤\@®'‰w 0fU3ŠZ'~¥–CÅdv_FhMº-Iµ#pZ\¡‘ÌølGF‘Oó:ÅÕ®@WoŸø•˜f.( ÀyDz­ÛAÈ´¹Í@g²$˜@X:OÌhóF{¶ó2 ±ùŽd1Ž„V="ƒYíÁšÇ*˜£DHÌáS¬@“¢v 3¯ŠÈË”ý— nQF%)¯uNR1”#GÚ9%»wCà@QœÓ‹Àse”¦#Tk2­,[¨HªÓ%Ž S‰ùǶª=¶WOÅÄzÑÒ­2˜åàï"µU6²•a#Ü‹‹ Wí圫]ÙBMMZ¼“Ä Ê„Æ¯‡µRës¿îñ¨£ÄxL±S¹×ð|nIà¢A[èÝ+jäi µâpO# ¿jfûpõt¼§¹öy83[Vˆ"M$Ó„Dts)¨ÎûÊ:ÎÃJ$CùúùäîþÓëËûë7·woO&ôÑc ­QÿúñéÉËû»ëÛïN=}úÉåå¯_¼¹¿Ð·ŸþÄ—á¿GûÈÑv˧'_ÜÞsò¹>¿¸¿¿º»ýìçïßÜÝÿýí÷W±MøÉ‹«ï®¸¿óYÿÿ0O Ró=BA$-å‚Ëò\Æ<©pO^\]Ü|uÁÍfѯöÝ/o®/¯^^^ÜðªÏï®_ýíêmìͲ§oÞÜøëþüúç«›çWwÿ¾º¼ùöõ·on>»½øöæê¿ïûúݳüÉç?^¿ºúá=ùùŸ¦o>»}úïöÍSz{D>âB¯¯>¦ù>`‚aÿø#UûôѦSö ùõ-ü•ü‡ÐO§vúêôÏ¥Ó+>ÿú޶lž)2!cüB]–ŒÒQã¬HEÓÊ/òùƒuÏÞ³—F'ÅX Ì资»°)IA“”0§Ã‘‚ö¶}¬‘T’½mO‡E•—Ù–lžaoY ©”$„xxœd€wã1¾Jw–!%P©UÓ¯7¢m“ZFÓµG>¬ë$R{X´-)Pmˆüœç\êpé+K@)Æ„Ëäôw$˜£îÉ÷(ö rW–3ÖôúFÏ­Ít ¯¤ÀK£6©änYÈý%4|‰ç9U~J†\‚AmÅ Å ÉnYPKd'bg ¾‰ÅK“åmÌvÌ?’Cq¶–™Z›5òrdWùZáV“<•¾õ# Ô…Ù ^]bä¦bk'à®7PQ¯4ÜXM ¼i]Î.áâ³µøé×ÏÓ£3¯©5>C(óYð­½ÌA¨/!„Í T:'geÍll³i–âÕƒÙ¹-89ÚÍrzpO—ÐSè#Sðk…ºäì ¨>e¤êÖkiÂÁ;ø»$½§ûvÒt M|ßd›„œ%>¼/Êáðà Ž\pF±0™pøa.a=,ކ‘õ¬–w¼Ÿ€Æñ·¥ö³GêȤYi¿¦?‘züÿ7'øÍi…–výºÇ5ÁUF=‘. ²HM¥E‘)"ÄVii.÷Ôå£þêlZ/M´ð¤BEbE1aÌ1áÔ°h©+ï½Y‹3þMÃ=—(=S—Y¬¬ÐA ÀÎË’@Êü›õ Ø^Íe¥N^ÍrË.‹7É]>Òxx`ÈE‘£ó¢ÆF¤’h“éͲmìoAñ›õ$¼¼›œç6n ý"_¥I å‹d4dP²ßÓÕ8FXËZ¬Ò³×h8—ÁZýÁb|rb9'™.žhVZ|0 ­¸+t¶BäœåºÒj~2C0™+ÙŠ¬•¦YCd”ckNg³6¤GJ€YK§Ðg}ãåæf¬Ë¤ÆÀÓDÔhuØÙ_«ÖØ3rS0UÍ}ä&öHÈP]~:tÒÀÉ’ÀÑ覡!³9ž&¹µ ™ŒÍñÜ~ºÙ.uO8H/¬’E$“®Ëšmè ë_NCþªÊjåxˆ0ÄU áAARŒ×Ü‘Js2±ÀØ)’(Pä‚Bw³l¶\¢5*l_¤éÕG0ªD;%±àe°ts ɼ¯tÑè•ùImfßëø)]¢ m ìH{?§Þ`ª”“.=ÿܸÃtuº-ú}„ÑqÒC”rŽà-e|zÂ[ÉuV:2Ùž˜èâØ‹îg×Ò8UßÖ]œˆ.éªÆË.æ¦6|ÀÕ)ÏÍ„ˆcýÖóñ†OIµ†åã\çS‡é ÀVÉr_+õ멸“M›Ã8Ng[Y¤þñ˜-o¾ØŸ/Ï“Ì΄ëW³·¼zaâ1šGÏí)U˾àJüyˆ.âïÂy‰¤_Œ’œËûˆ¢ wNANSüïë/ùŒe“jB ÿaùÒe´ éu{%‘v´]h@ègÒ8½cHœhûãñª/§Ã*ؽìùPãEOá/eP]O@Ø ¸e¿±Á{ÔÝUË~¯ž„èêÇá¿V/5¥ê_€a9ˆ. endstream endobj 32 0 obj <>stream H‰œWínÇ }‚ûó'€t7Ã!‡3Óþrœ Hk£…¢’ÀP$5U£C’áøí{guue#UQÎÝ¥†~r͒䵕ÒÒⲪYKcmcô´Ô±ö¢%XOÏwKíkS…Š®â&¡bEF_[x×5—®I:~sMÇ»ÅûZs©”ÕF…NϫО4üVÜÓq¯›¦bk©¼¨éÚG­IË:J¡áºzÁÅc- »KõU²ÕTêšMG8g« þVú*g— eí0¢«ka@Úø‹Új¹•Pp´BäkíÞÕºjm!°ê7å6$)âèc¦¡®£CÉòZšÐ›¶šÎÀZ.ñ^s< Ò-t|FQ­HrD ^(h¹Î‹jM†œŽ<½k«ÜmH•™ßªð ±–>d†dR”‹iÙ¼ë—Vä0³®4V¦wtAñ>ÖÑr£kka·•L[³#DF6læ¥ô¬ 'gHÍð§Z-†Þ½%T~YÞÕ¡hµŠÐ¯Šˆr$¥&&˜0D ØT‘À4jÛ}dG´ Ú @£Yè"ƒÕâšÜ‚#¦'  Ž¡íØB`PÍóé§õhëî€ZÍT2„>¨­Ïw-Îþìè…ÄÃFw='S†›`Û¢Mã1Ó)Ÿ #ìÑgEà”Ó¥¬p± —†!ˆL``4{¯0 بcl¼9°×…0œzeõŒôX)¤“þ»u8À:y”Ü@Ngê5³zL²³i;“?˜ô6&!k|•†ã éÁ/DdïBPM´yrz7üRÄ!a(ÀŽFe—:¨š”]M&¶Áeˆræ„5v¤!ÂÖ€+¨ˆ78[<Œ ÁƒÔ¥sZPBBC>‰mï­æõ2pš¬f'ëcæeÚÂx)ŽÆÆû0N-ÜQ¢8—é,h£.( &2`aŒpE8Π”Rg a³ÀïªÊü5:3›5‡Dˆk^NœS‘¤ ç*KçÔ˦áFSèXïš4%Ì jyȤFëx785$Â@ûÚ‘6¸œ Ì$y–äm ì·¨¢Ì ‚Vì>¸šDI޾æbƒ¸×®†œÁtp˜9†4b0”€e)÷œ ¤2Ãja1uï9ö+Ü FonTF˜U8Ê®ìX wÛû„Jk„W(î G8S†þ2Ajd6ÂÔ•Xн1)’.¥@Ñ‹ ÁÄ$ûºÆ»s*„NPÊùÅô„ ¶‹kF—¡SƒSØ:l’BÉœ)$ Ú§‘ù˜Ët.{`…+'Ö"Ûrå¤8›‚ØŠ0 œ^sc-RÏ „ã-¦&¦s×ôFƒu®©Ì“rÿ*ä“¡s6Ƹ–îiàLß8jû(Ò­“„b—ºàxäˆqê¶:bò¡<ÀO àùH¹”tîÏwÿÄþŠÙ|‰1N'bwo;ùËé‡ij_^]?ôòòèçóÓoޜބ9Ò“§éûì>cJÞ|}yòúÃÅÏWçñno¾„ß—›äÉ««‹£ËôÝõÙEzytýëMúñÉX‡Ÿ>Ýåô ÿ¾¿{·“ôì-ž¿Â?‰ ÿ€—?ãáß½GÉÒËôÃO9PçÀ”Ó~ñHpß¿½˜oñ¿»÷g.a寸vþ÷ä‡Ãtÿô”×߀„ÈÉ<6d>žošùqà‘ÿ»fW Ã$ÄÍðÞCkqààñqÃ% “W6Ãwz­ÅƒÇÇ k6ݾÓ{h-<>nØÂ°ÊÞðÞCk*7\ðÜOï‹w`MÆÃÇÇ ûDÅÞ®Ü×îÀX{ðô¸ÕF«÷u»/ÛÞP=|xÜ`§AÙ»¹/×ÞŒ´O[´Xö •½÷–Êxð´ÙÌì뻎þu'Ø@1z<žo@ÿùvàà¦WÿµY_ïXö÷ÿï7»Ïßý„ q>ZæÔëü¤is¸BÈEw ¹~O¿BÄUŠ\7U.1Ç›ªa¢…Ðï4Ë&h¬Â¯nOw¢M±ÖîŸS|oL[¾Iø‘³÷âN3·ÍwÝ)Š÷ÊÕãðÝzß+…«Á<` R ô.8Óf¾wq®­–@Kˆ|Фßkþ‡ó*I²íÔ[ñ  D·‡¿ OŸ÷?µºjTRu#ãê3hŸ°°Û@0³Ù߬—™°5D×KÚȃ ¾IájîéœB.LV}¾»{f¥b"ʳr¸Z9êêã`ì º? •¤T-#‰ìË£ÜÝUÉ^¼:× h«@WÈõ—¦@wª8º«["5Ÿm„\$…Ti·ƒØA+ûû™eÒî_ä«L2+TñÅÉ>k ï½ìøoYrü²"þ@ì+BMÐê?n+Í Þa ¤Ú³7Nº<Å .Á*6ØÕÑ÷G ébt}'1šäOÀ d š³î2m¯ —Hé*{„ )µõM¡ÍYøSå¸9QЉâ–ßÖh‡C–‡TÕ¢åƒk£UŽ[Jö‚­C€²ò™ÞïJ¬[ms¶[N6Ñì¶þ·>£|uU¨ý@ÊÌ %H«Æ›œáí´ñ&Gf´`nL©Þ¨ìGkÎ4I‚Ç£Šm¤ñõ-ÒB>â¶ÂèÝÅÝo+4NËPqƒK¡¨_ÿµ´yjÔeÑu-!TaµRº¿ë‘™2Ý{©mýqU·Þ(’¦[ŸAkLOƒm†_hIîq4@IüW\Ö|Ú>2šw§¹¼£Ç½¤ÌƒƒpìÆßé`HöLãÏgâò täÜ– ¢*Yù«øÎf©efâ¶Æ˜oýÇw0èh…¹“ʃ´õ§Zð÷õsîÿC+üúßiΘäþþ{Ghj±Kƒÿ PzÅÁdžU”Ü&:ÀiAIQ!ÚgÖØ(RÑⳕîP§92/(›·í†)Üú{˜k‹w¹ÅLrb2SVšÒ–ÅRMÆ0Ð!ã~Íý ê>#ðX[# ³‹†A%Ç"÷À‡ŽAÝmà1ÁõÆq€0}h·Âw›’0¢–¹áñ*…è÷P…Fj¬­Pò‘€¤Œ'`ݾ«(²8È•èåø*jÓ-¹²q­Ho9.[§î`[Yˆ», îSoBqí¡T¹­çèRªþÞ¿öŒ'E¤¹2c…f@»­º}?àè`ìˆÐÚ9(2U(ý¦ÖÏ'-Ñkwò¦É @ð݆ԓygö© ¡ÿó2Þ°A ¬FÝôÙA*­ùè§G‰˜jÅøµd*X]Ë$)­T‚@*‡»ÅÑ:÷|¾£úÜEÙòMâý˜FcÂЊÚ5G!{ÌŸ;"}®7vìûlm|²¡Zeôȧ8æ*÷,§$>WG¡¢KODÙéme|ŠS­õ©a0øUëâñ·#T:ïþ4“Ry»:,üϪ=‡³Mò¡áñtµ€ÊõÞü»Ã-q ·÷‰ø6ÉÍ$h¼³KÀ2Ú§™ O>é ⺛ID‹.ºAÊ—jëÜ?Œ©¢Ž>´ª 'gçÜœ,`›õ9Ü ïík8ù$›ûþ¨öòÖÚ„õ§û_õò?ˆ4—iih¨PKúS„ÓõS>ø½Hûõ¿iªÇ$£HaÒ„FsMСº–C*vlm….«øÑCLc(=*4~ —zJ°¬…å—Û÷>Úžª‚q¥Š½tD 4]õ1îïPotéÐÐ2»žhõÇÙDŠVÒe1ÇúqùuAõꙜÄeˆ¥¾ù†\M+ý“jŸjÙÏv ›ö€ýùbcòJ¦F•v’Iyç­ÏzŸ›äS£ÀèGÙZÏÈP©àwùhÈÝùB'pu *ãFÅH÷©åbº(NS>•¸Á¹qµÐ?OH ïÛ.ã'Øt|~nl…–œ´ˆÂ¼S4zÜ—;,õ¾ÃYLå]A9`ÆOˆå­ú#­Rÿ$Ì¥Æ'©\Ë•ç¶ãg™TòR´CF.”D~ˆÍðWŸŸ§U —}™'~œpà«pV¡¹>!¹¡[§'˜“h9¬·(¤D‘B}}{y€ô«¯í)(l·ŸÚB‹€:o¾roõyÖ÷X«§³Gp ,ØkÏUN7tÅä€;\vœoÞ‰HÛ.Þψ7¹ï§š.ßïj*}Ž.‰xÁ3Çb ú®FÞ‡¾Å\°kð¨þä–”zý”~Oß¿~àwô-1•¿x YÈŽðo€ªÒk5AD}sˆ±,AÅWJ* !Rͯà•l\6ëêŠ,Ôj{¿+° J›7×c¦ÆRþ2s ‚Ì4­@}cm;¨Û< {ž¬Ž4øÉ³8B{Y8v€TAc¹µgŸ:Ð>!: ÅÔŸ˜îAM¶Ý²¨RvR†kV‹ïz+µ’b´Ïʼìý|7"¸®S Ya† œÜäÉ"n1ôEh¹qd»†³YØKº¨€âêô'¤½¨0‚Ùö¯ûQÖ¹;(*¸°cl„ÜËB8FÖ¹~Av´‹ññêù®I€ã‰E1GA·V*ŽJBvÀkP ]ý6ë‚–0Òà< к·Â{áM å’ÚÂHUÛ4—Ò xÀu˜Bº<†§õ‚°Oîïgº‰vèʵ‡Ct‰¥æ†ƒÈ§É3£!§¦ÏÚ¼¿²E}(hJÞ ™òr[õ£xLï*fÒÉ}†N6y ( ¬ç;_Öô¶ûÛˆ°µ™5Ò¬†LƲÆÖ~ efˆ¤UsóCt;m¼–­k íø®@Õ3ÝLl*¤ƒÝ6"¼%¥èlq[a´îªË/4®–inp)°nOåZžR)5ŠÒ÷ @h™µêó¨ý¸mºû]H×Ç×. =#vkEù®uÙwY´ÚÊÊPgÿ— ïz—•þèÄtØi/hqÈZu!¦ÞØŸé`Pǫ̈Ÿï2Õ¡Pî5Ac³d鯲GÞD×0nkX¾„úëád—.%jmô¯ƒ>€u` WB}T¶€1°›L}¼Ÿê«Ìï_"­t¿™cë-ÄÁ¸ÝFïU/ÈŽ’l½¬‚¤1žÃ DÈE’p–¸.×gGžjœë@.^ˆzƒÀȧ¿^51ê+^œ-(bjLpgvƒ‚4½hñ Pœô- \·mÔJ¾{Û?@Y!ù€õ†aÜãeTŸ1.`Uw·¥ù¬¬c¼Hfú‹‰,‡vŒ†‰d ¯¸½"Ágeôw[è˜1T6N:Ñ„òÊÙ³[Vk‹ºÆYfÙŸBŒÊµPÅw¦ ZqÛnëêUèQçTÜ…ºv u…ŸT(7ƒŠ)‹Ìd¿ü5WB·½{}’¯í‚V&ZnYÆš¦*e ZYnNŸ=–žæúG ±A¥&èF·1⻺ÂBç>ƒ\ˆé 5.+†ùù®—(âs['Š£­å«1ǸÞÓ….·Òq5N.ˆ®;(kÒÏðÍ ¾¼ÁT™Ð§+’A ßRÓäÁ=Z%æy‹ñl•‚]ó@WE%x*χè§>%õGE߆²Ž³+D_ÝÄRäÓR®H$óÕ*ñ„@ÔÇÓÛJýân…âäîó‹÷/ ÒNJ“>£I_Œ»•(ýÇy•¬ØuÑ/ð?¼e²i$•ÆìM dBÆviCÿ~jVI¼0MÃã\ ¥ÏI©…ö÷|B©„êV±ñ>‚PÊÕŒëžkÌ©¶£½#s3€<ÜïY Mj)îó=w"äã)‚:Åè0Ívuä°á<ÝŘ¹õ•s¼VÒ1›½tâlF°Ì|lÆ[ª/÷ø£ÛpÞ¹>˜Ät“³^¤c”2®÷ß4æá8é‘ñ/=>ãHø˜àðÀ{é'ºä‹.?q’Þå‡üýôÛ‡¿þþôúí¿?¾}ú÷ŸßÆ“ýø.½´ÇÛ^ðJ<,=Þ÷ŽWüú&43óx…Øš±@­!\”NãèƒeBæ^„E† PsØšu]5!3XÏäѹoä…ÒÐ@5¥¦Y®Í0)ø Ë9àdbSvnB«zžç0T{­gú†BElÐ+1‚¬¼`ÈšX„°šÜ¹‹µBswI×±Ú†\–ÙëYbÈb7ÁvØŸ@ öh˜ Ô5 ñYàèuK6†–8‹ìÜ}Ó‘Ø] 4¶FgeA†Ç*u±56t(MwzãÇA¥ë|< ì]²ôêäVõí3S?86ÏVÚuÅI­ó1‡à\z¯ŽCÔO)éi:4ß¿Án2‹5#!Ê×êúÔÍ׬e^¡ÑŠ‹ñÐê†t«È±+ö\Ï”:›š yL’påækNMãk(+S“›!T@nÞ| ÁZu2,„˜11$< {LnÒ­™K÷\75‡÷iE^Ñ_C°äqYWjÒ+”°!ĽßÞª[[éõò ‚-ÝþkXei=ƒ©ŸÕ²j~aC¨ö¡ñÍn´P`Îalm—ž1¶yRÐ’NÓB¶¥[a^©LÖe8R¡5ÚQø¬VòUUíeB ¥¦ðÔÝ›wµø ký*pKÖó”±!$]°;e PtÀ»z}Žu(´c­z52Ç\GUѻּb¨s,V‚í)üƒÉéÑŽ¨Ïà„иåÞ<ê1È©{Z ØtZèLq§ïÁ!PÔAF‡é€²q‡PÍ6¡§{x–‘ñ‰Pªã²øª1àšÐ^=qB#˜Ö¼6£Tj  ¼k6¡w°+ä~ „² è¥Î¬©ÂÓûO.£” éó¹\B<¿ª¦e¶R¡¬³Ä¦¼¬UÊ•XíA–€YÇÐ,ˆ¿/€I_K]\.Mä^å¤n\‚¡ú+YïÚú+ç&Ÿ3áÖ9³NpmžmÖë ¯¡hÊN³M¬zmŽÉ™µCQ€n°«Óý0s&] —Ïɶܨ€1ÕÁQs¹Š^X}Õ¼±ŽœÕ°¥iË™iš ¯{G-d(gÍI"Ó´Ö8ùM5Ðu+—(£(^m¨'IœÝ®hÕ8¸‹2‡ñÍ%NìªpÒŸ³_¾EYŸµ?ƒe®ã@t2¬Põ #ú¨z[?«tºócçº!wJ=¡Z3®.Fhêûw(Ð`é;dÕÖŽÀ¦R yA]9’Q«xöT ;óDA”këDºw],”â0¯°|½žQ´ïï×–žÇå“ ßmÐkVyEbÚi`}²w€Rʸ"ëOØñϹÜ#ƒœ2ò•<½W*8Ö)ô©>©¬WŽb¹C~Õ6;’½bYÖ×*G>EÈ}Aoäv˜98ܹãl³x!4¯>QŒ€Ät ¯)e /ë Cqƒ±—ÓM'_~¤ýÆ%ðsæ¹ÇI® ŸHʾè‚ðd~¦ÇýûÏï?ãÉ¿~|—^ÚãíG/x¥éœï¿{Ç+~}‹B'}Dz’!Ž ‘m¸×2Â-‘ :TruhºŠ«[Ñ•rT ÌèêL`iAÐdG1¨ÈúuëDF#଺n™Ë%-ˆ¦ÖdRÖnÝë¬WLU…µjB$—6¥ÈÊöÛÊršÜ 4²õê[ äj°Ó©Î°+»²bn%Z)––nFfAÄÔô¥9@ê$&a"µÉö€ªZ’ j¯æ^CJMÓ1‰³`1-œ­êe*ƒ›Þ¬({çÜB¨,µCX AÄ}-}§l#­ÈÛE{HB÷¼!Oü>¯uHõ%]),u gwf2dha–‰CXdžHî"Ë4XÝ»<ÏåNµ¬”ÒÒuì,~A¡bµ:E!)5R«¶®îMü•=zZªVº3Oy|*=” ˆÁ)™uk4‚ˆnfMJ mCV2“æß±®;m˜Êíyåë­¨_ûPßÍ©é+Ø[š4azæ+H=©>ô°.Ué“íÒaÝa¹½µk‰÷\Ô¸2µëõõê yÍô|¬CšÎoÜsØÉS_„¼aUSí4°°žõOá 8“7§`¢w¿*skÖ\o‰(å2n¦g—Õ§7¹”B*òbšÄº¦ßˆkƒ&Q8Ìäg¸4ÊT7nËYþ,ù¸œ¤¦º!'ø#¬Sž5K‚kól–ß~ÅÚQ¢)"rƒÉ˜Á˜àÇÔƒ8Ú ‘y?ÌœI—Âås²-÷#6`‰#8j.rUûrbœ6_‚8dRb¼•œ“Û38lt*Fã³Î5ãËÔ_t„m^Mt–RÚ‚\)ÞÍ¡Ëü.;?ÂÅ®úf5~ûY3U%Ƚ¬O-±Ð[]Ë|~å8ž»$i[ÉÇ@‰b²¥Ð[“—ubº‘é™.âd'óSØ®K©e\%ËËJ,µ³@Wf~ÄÖ˜ºmôK€2*j±)ëÄr”hYÜ%@ê2éY:EªŽ¼3%Îîâ?ŽÃPi+ ’|)­-ër ^Ñ’Ý’4°ê”õµ^—«$Œ—ÓbÒŠj[é%©èÆÏpˆÉ9Tï-C'c­Ê½èDÎŽêDœŠÛã“L‰½3Õ>ŽT•שvì½rsTíØs2èîèòeð’mÙ\†WÈdXŠô_‹ðÏ¢x~гãäVû¡t«€\öð~-ê^.íÜ6ZS#Jãf•ªŽ­+}*••8´¨4!±Ÿù7°™E2g²‘„¤P7°Ju âª8z)!.™Â.SOœÒ·tCHç.Eìh' ëT8ð0Fª†Ë9z†ËQ§“âe' 1„Hña]éi)> Ãr1ën„ÆÜÄd3@̽ ñ‘Ë2íØd]¡VP÷|iI yCö Ž #Bܤu2³à‚×Ri%6št3€‰*¬BìºÎ,Z¢ß9aIâ“P¸ÛB% ÷ˆ]tKèÿÌ%>MMcòæ¯óV†H $èZÝ@¼U ºYW9Œó´Ô¹¡æõV1óu ¶Å†Â6äÄ6«é¼‰è²^i)ÕÍ}éœ}±b*>4¬N1j‰ß•£ëõÍÅsˆJT‰*Þï¡”‚“z2ç‚JÅ_ˆ\rŽá‹YÓ¢¦â'ÄÝ…E¿I)À2Röf“*|C¦±bÍÖþuH»rÝ i¿E܉¯µ<á¥ñTŒ‚—ú’RŸ¦T†ÙPóVt{•Ð¥¾Õã<ÛÛVnpRàáfj9³  ÛÞ.”†Í]EÝ>[…´EY[Bnmx™ÔÝÚñ%ž»eR·Ð:Û,@EÚg6)EÙc{4€Îµe3°¬zîå,x¬‘ ÛkÈ|­ª )¬ô(=ÇÍü]Ì|i•N˜2ÃyKX„ÑuáŠí°a”ÚBe$©, DÎŒašZDí3 ckÌaŽ6s©ƒÑC¶êã\ì&0%#q‰qËæHǬé‘n-‘@šWT¸ÆÏ§ØZ^ž P—âÀ†È*„ ŠÐæÚð"gŒ(ñI”ŠŠ×»‘=I'˜ÙŒ2ÿD3pŒì“Ð'.Žr FÏÔ]@jtQ‡¾(ƒ f}d-™Bây¡Ö,–poð–«YÝ2¡T%M%ž&úZEm mÏq}\slhÕä.Að€-ÇWfއó^ë.Î ¾/'‚Ÿ[q.ôæÙÐf>€©¯™!b“‘ÐBê jòµÌz]| j `]Ä9‡ LˆÙD› ž +$§ÒÆ ¨<ÔGˆjVš0˜‚ë§` u»7»Ú¶×qX­ÈI“›3—åé’ ×MPëQN™cÈ¢oŽE¯õ(û°Vm˜áOŽkõ$x¥ºSBùâ èZØ”ަ—:ß™ˆÑ1›<„Ll ©„HöHd²zÄ‚ì¹yØt¯Þià ŒÐ`M !õ1´JÆrË•Œ'¨´•linÜøÜÿüñOXÝñ¬Ž®‡ ëØ_ írt4,Ù~Â:<Ê/ÎüAÿžüýÅÕw×o.¯ïïþñ.øæå™;ÏÇÛÿé–7ئÝñç½è üõ-Ï£’¹a/4»[îÿCÛ+ª#ÊE ‹¨ÝБ‰õóÈH‡š £ƒ VgD»¯Ø{ÜÐìrœb¡«Ž›(¨vÝÜò8U»<Å‘) Úq=ï¥væPT;…Bît^è¡óÄvdƒ‰„jH`EE’&¶î‡¸_ƒ0ï^‡Ó6ª 5„"++½±—Òdõƒ€ÆarÚtkRlw‹ÞïqªÜ`ã ž³˜¸aL ; ™÷@Ùçš{4dl`Ka‚ôÈÐý€JlâÖ4$6´¹LÚ ìÆ_~̳2ê­u `ÜÕ&C)l…ÚçÎHX¢Ž¦$𣚊C[-=ˆ% ¤Ò`ಙu×(Æ £ñ%À‚™H™Îó)›5hW¿)dÍWÐ ñ˜6£óT ãK'׬F`ˆ·È„÷ø±àaèÒV˜-øRvZ¯©¨äùÇ.0!n»+'`±,/ˆj¾ Ò.`üHGêü=»ÆùÌ”"¯YÈ:UÁV©âi]/R¡dÕ7#Pæˆ /ò†)¼“h9 ÛîMeˆ£I[”¸ã.Ën¹ä&Í‚Èp¦ÊD¦ñ›J›ä28’ÔëÐÙ>l„Š¢nl`2{Í„/Cuß…š#÷BA2Ž:ØSˆM‹‘‹Œ†ZÕŸy”Gë2©A…Õ­vç¢jüæÝ(oÕ±t¬ô<ú"ÚëxÜÈÉïS´ÖFôD_ë-úËæs“ùÅqKuX¬åÄØ€ú&’FxæZ\ážìa:Ú«+MeìOËÏx¼=Òñã@PzȾ[ù†˜|yöòl€yŠßú—Þ‡Âç¿ñ/ú+,ó9êŸñ§¯úwsárŸ¹n¹m¹l»k½êä¦ÿæ>ðЛÁ Þ /PS$)NßHµœ×/^4¾.‡—®?þ$¹ÎËé'åÇøžËÍW”3gQYöûãäXþ;/óÕ”J•c@'²§Ú¨†d,ßù<¦1`™¯¤–r>5 M…c`sËrúÉ–Žï¹\¿dÑøgnûÓqr[úSl4MýR‚øþcßÇê?üxñòK¸å–[cªuœ›Žƒ?Š@[5^·gk¸×–¬üYÉ¥áÄe6Ð+ ?V欴ҷ Þ ð¡eZh˜±ødÛêlî•+KÔ©¸ÌFl § ôJ•ú¶÷NèŸm˜Þ/?’`~@Êš‚¤?9õÓš®Ì¢Š (+ÂX1Ž•¶ÀÏ#œKpùt®ò–ÊgNç¶Ô›þ؉H§k½·Æø¦?µx‰Šáúåc¶O«3ÒB w·Ïíó¹vY0¢¾„Ú:Ã1Ah\ÔÍÑžçéz½.HËiqÆû÷õÿ‡¿hëÿyäCÁ‰Õ»oC\|Ì41ÛÎ\ÿK—ÓúË›ëË«——7×wß}þpýúWïøÄãùoïïoÖçÝ]|{sõù¿®__½¡U¿ÿgýxòôøæogŸÀR÷ê³»×/ßÝ~{ƒ¿3þ|õ§û»¯®ïáŽgÏþ7ûeºÛ6à'ð;ðg´6oŠ›_vz »Û¦ˆÛlÅ"P,µq£Èl'Û·ß¡äƒrd'–]^ ·¢8r}šé©?Ñúpçf‚bæc2…Ï®¾ÇƒI먮bÒ˦ãkò>LÃoqFβ(ÎŽ7Ï‘bò4L’á·,¼»f’ŸÀ´áänÒ&g÷!Ü?=&/A…/¯6ÊWˆæ*Þ$áäIy‘ËŸ¦iT–ÍUT,0ë<–- aêñ Hʳ‚{]R}z&7ä%é²á¤s–¼IFY˜þ$¾ëŽŠù…T®Â‰“«8[xd–Z:_Ń‘Ëó{ïÈE i9IUÊ=gÚêÑÈ¥Ù±áŽIà›ýü  ‚tß]ö2x=“8_ûçð ^öËÓ>—..Os7L³û¸)cÖdâg„ºq”¿|D‹kÓikm¾|÷ò­¹»41r±-û)ÛŠ“\sƒ½kïû®v)o«HáY›ÿýÜM>v›²|ײµp2û ûš'¸¶tò>߀*dÁ¹V1—'e‡|NÓð6Žˆèù5 :dV*̲sîÀÙ•¿Ú¬¦7×ÒëÊù 1XA$]ÕhÝ1gߤi&Üã¦B°Žò`Ó#ÌÏìü?Ì—ÖYyÀ½À´)–3eæ·E`üD¼ö›€¶˜8ö'?’xÜêü‘ŽÒ|õÞQ7¥Ç¤ó‚¥S§;p&Ïg;§£Û;÷¾Àg tòžÃ”ÅÓã" g"/ pí\ ÇCH]§ð±†þ$Ül¡¡އy6º‰Ÿ¿žçÉY6[ýŠLMÎ]°#È^˜,Äf ®Ÿ‡èÖ2`_~Ààw¸ù¿Þ“¿'ÿPÁÌW¿Ãl%'¤EŽ<ÅÇObQæöú¯Âñu7ú~\<Íëî^¿Ýê–J.âlÁ†\m°Ö ;°Q+ËK˜S|gÌ4ðT*f×PO—N¢¸°H=¤^ãÔÃ6²6õ”0ÔõÔX%Ι*(mÇ9+«X `[ F°!Ø~Ø$‚­.ظQâ0¸fyPæÚÎmªVUsMQá µb ¹†\kœk ¹VkÞmNÍa€M©•ÆTì 6nY]Á&|ˆJ-‚ ÁÖ8Ø4‚­ØXÛÀgá ¸&­Ö%®í\¯)Íu%Ö T©õäkˆµ¦°fku±¦”Q‡Q¯Qª­9ÎU s¢ŠQ[qNK¿ ¤6°k¨§¥ß¥z«z½¦  ôê6©T›@ô3~ÏJ½Æ ¨*DmWÜQêT¥‡ÕÒ„¢~ «„B¯qèY„^í–Û 8èqªy©´c;—vʬkZûX3Ba ‹`klE°Õo‹@@Ír`£¬T¾1#ËÕ\PUzmÅ9ɬ.Ñ­º…¥BúÃÒ*¤R¯)ê1¤^Írî xg•ݽ?•Bùµ¡TbJ„B«hq„ÖÿZ‚î-¿´bRT5žÈ+äUS¼È«š¼jS©Œ9j± °>Ä4ß¹ò²JóêîѺTåyr6[S`“¶º`3:³Càšd’•Š3¾¶ý{vG©”/-ƒRÁ¦°ÁD®ýR®)äZ]®)£Œ8 °Ñ@”À˜]Á¦…ôÁf^âš\»r ¹Ö×4r­.פԂ׬ázgY&=•‚‰µ*]ˆ®Ðež‡®ÿþ%(K endstream endobj 7 0 obj [6 0 R] endobj 33 0 obj <> endobj xref 0 34 0000000000 65535 f 0000000016 00000 n 0000000144 00000 n 0000045151 00000 n 0000000000 00000 f 0000047989 00000 n 0000047803 00000 n 0000235363 00000 n 0000045202 00000 n 0000045576 00000 n 0000051485 00000 n 0000051372 00000 n 0000046577 00000 n 0000047242 00000 n 0000047290 00000 n 0000047873 00000 n 0000047904 00000 n 0000048388 00000 n 0000048744 00000 n 0000051559 00000 n 0000051971 00000 n 0000052990 00000 n 0000057112 00000 n 0000070811 00000 n 0000084596 00000 n 0000092568 00000 n 0000111865 00000 n 0000133097 00000 n 0000140645 00000 n 0000144695 00000 n 0000170906 00000 n 0000197297 00000 n 0000222687 00000 n 0000235386 00000 n trailer <<00EF4935F8244CEEA506B9266CD8846B>]>> startxref 235573 %%EOF qtl/vignettes/why_we_need_a_new_program.pdf0000644000176200001440000016407512770016226020772 0ustar liggesusers%PDF-1.3 %©ží® 1 0 obj << /Creator (CANVAS X \251 ACD Systems of America, Inc.) /Producer (Deneba PDF Filter 1.3.10.011 \050Win\051) /Author (Laura) /CreationDate (D:20120404114849) >> endobj 2 0 obj << /Pages 3 0 R /Dests 5 0 R /Type /Catalog >> endobj 6 0 obj << /Type /Page /Resources 7 0 R /Parent 3 0 R /Contents 8 0 R /MediaBox [0 0 612 792] >> endobj 7 0 obj << /ProcSet [/PDF /Text] /Font <> >> endobj 8 0 obj << /Length 9 0 R /Filter [/FlateDecode] >> stream xœí]Û®d·q} è·8N‡—âí)ˆsñK‚Dòü€,ßÌØ±&pl}ÖªâÞ侜9ÝR·aAÒÌj^6‹UÅ*²Xüý—_ø‹Ã?/ü_iáòí‡/¿p—ÿýò‹Àÿx¹Æ˜R»üþ|-!»rñ×Bö ¾^cn9¯àû ¥]½‹5^ªŸ‚Sõèÿ*šӟ¢~q©¢„“ki)öëÛU€fCkr¢G-ÛÑRKdÙèµl24×À¢1iQé ¯E%jÑhhò±°¬-ÛQI.±lJZ6%E–MMËv4Ô dÊe.ëKn,[lh¾£ì e‹ Í@窎¬êÈJS47v†¢MGV¬l®â”~M‡¶ …‘b.Î…3¾Béïtp¥tØUœ÷:ºb¤ÌÉE÷:¼öÈÒAÇWŒÄ9F©Z:ê8°K–Žm.ís6Ncì°‹¢¥“ ÒàÔZÕAú”¦Ò©E±Qf¥Qo6Êl£ìpa—,]l”†æìmÅihb‡,[ËTVZÐ)ôM‡˜[‡C«ÆžùBL†0èGÿŒ’õSc³"®]Z¸FIYxOAïÉ9.,U|¨W0x– :«®銲|ðÞ¥^þ'ïºO‚í.ïPçï¾þ#Jùpy÷+y÷'ãZ/ïþ•ŒàÏ NŽ›¼`À¾ÆŒŸñå?ú‡¿½¼û¯/¿øçwÖÁ÷jÛ|i“ÑxºÖ*˜4mü'£ñIôM­ò&‹±…¼•¢¡–ü+$l埨§¨oQ—RÝ* ¡%#êPDk×+C-Õ&l(E}ÛÊ?AðYÝÊ?Ñ”\ÞÈ?AéjeÈ?ÑXCØÊ?ÑÐÕÊE»Z™äŸ°w]ÿù'ì$ÉNþû&.ìäŸp-e'þDKñ{ñWØÕ¼ÂyQ-Cü 'ö¸ÂB9ߊ?áÈ.·âO8d¬A[ñWxQ-«øuÍV†!þŠÆ´•~€®-jeH?áÊî¶Ò¯°Ë§Âï=¾Ê§·Ò/LZI¶•s~C–¼гºVƒÅß§xM szŠü³õ¥äÿÕÆË%æ©q’)lZ‡U!êêß]jzëo ÓÎÆ]Goªb¸:ácÀ˜[² EÖ|k eßÏàÆˆ ¼OM||k†Þg †Äýò"` ‚åc!â›#g¬R*üVK·z*FÕ`CÅâÞ‹Á][Ã÷ç„ÀBQuº€¥^Á)¹.…k&m°Ò¡tÎí‡-«š¸x#›f44ë% µ¡´ˆåZ4®ò,²1{ɦÜò÷t5ì`­6tÉ—NÞóïŽÎU)*yKg ¾¹˜¤£ò©…-éTÍdY)ü,†5`S|EwÅJé «+ÖK«×Vd‘ß§P:¥LJo{š(ÍæýåëÅP ¯j±\°®ÆŠêø ûËC=z¢XüÂÛ£8'£8ó+Fq +Åb„¥Õ•Ñ*Ù¾üd&À‚Â’+ŽŠ¡·Î9 u1—^Á]aÈw¿~{ª`©À -ëU0ÿ]ÍB2CòXIB© ¬çÑõ 4ÇU° y£á77ÍÖ=}%¬Ò9¦}ý|'¤,)h9,Õ¹äXÊZ¸ÆµdGñ˜%”-Ù Wã"·®}÷Ñ+lu`¼—ì þZÏ$ŸO 6Ì ÌÇaº¨ç.¿þäâˆÊ£+´îóvÑ(Ý(…—v…Qû¢ñµ.XÖ\«¶¬¿´~½»BÙ ø[ƒ×¿ÿn«Î­«Î‡§i%úùy‹ÿi0L¿<5ðÛóÂßœw÷?' Þá§[þÝyË¿=ùâßœ÷6Ú öqG™ñM°¦ü½·n²@ê%aAÝðù¿Zá§î¾¹}°ÿ²me"b8)úʤwÞB××`0,ÏûÇÛÌ¿É|‹ÏiÿÄ /á…>S(®»˜ÿqò!·õæ+dø­›±4]c+øž%ÐIcãï~lÿþè*a&ÂËZ76;mKøH°mñIjÓ7´DŽ€_ôšø NJ~÷$‚y%±¸Â¶¥Öœœ¯Z!”b¾×£”ܺií‘[Ø,Ý›tR 1˜·°z• àZx&\w`’ÌE¼ÏJ¸½'8pp›©ÔØ•«ô^ß0Hzm_EP[$z£=ÌÓú4YWJÒw„jÁ/X¶± ˜Í<`,FÕá›Ö¹JXØàì* xWáöåÿûMLÕ,èùžÕëÎIÀê¢kÿ¶«Ç­^ îq}AÇQ¸¡–¤´‘œH¶JÃäªù‘¸© ÛïÒ’º‹*xD«‡czñ&ºsi IXµCs};¶³*³ýg—üŰ,}K¹Ò7?bùò­õ×jMܽðôM pD K@t¢ŸKƒkNÌÇØ¬U(Ö[g-™¹YÍ'ð²c¢/Ì}žèè‘( r …Zk°Êp6W … <]”,Wî7m1º\ÂåŒ ¨þ«/ö¾ZFn€r’–‹x æ›k¢@3¹ºy+úèžUU'4`T®Àbz :‰Äò!{ó­&˜JG‚»Õ&¼Ã+¡{é üŸà´^¼kwôŽ®’ã_ žØ,ƒìósïkNJZI;ŠNm]½Í™TìIsKAîº\ËexHM{˜*Lð®ÂCIÎ8ï%€ú Ýä§‘–¼øCW›íé®H*ä ‹>TW¦)_í–cÒï碭÷‚µÆ3ÀU‡…Ö{4PS«ëö‘Ž©Ñ^*Vº¸:Î* c =|®!XÑz4f¢Æ·åA‹a²ˆ‘‘˜AZªÑ¶jW #i>ùU-æš›M(íÌL \\aŸû ]F0t…b€Ú^ôtœª%q|ä.ãÜ•wž§|MMÐ-yÎþƒÖ ê;9­5±T9Ò/Ð(‰{òaXf[s“aX¥MñîJ?˜Ú ¾©-0OªoO¤v`”Zh‡¾äæ“£Ù ¤‡ˆC¼áNªÙB‚Ô´Ý@Öi¨s3ËcFͨë(•ä)…uvNét›Œ«D‰q Ë5˜‚+«©öP‚ +InÇ%î ê¼ÞÜà®Â —ðèIŒ÷–ÞÉ)aã–ÜDᡆ#ýhK5×÷`&˜KÍÅ0æÚ>–mùîŠ?”ÜI wÓK»'ÒÞ,ÏGv}è]`úüz à 0Ï‹\§Wwå…¿Àâh9ÙÕ æ™»ð”²Wȼ*™ró¥0Á;L¼®žæQ¡ZT­ÊóÇFŒ®Bæ›À¹W7¦’;0;ËšÏUcÁ}<²íÜHï nnR˜BWZ’i–`±¸w»H0Á\F¡/ò4[IÃê·¼«ð”°y$3X6Ý5wç4„ÜR;tõó³Í/ ö§U(z?¢äÎý0c$Z`6­Û M•4¤ŒÇY ¾„©›†xãÓòZ!d5CÔ ¹Óïf,“+~éïPX RƒB4ÕëZ~žš'ñ[ª*5ñ¤ã~%{rJàne,d'š} ñ@E.‡5Ùå„ÒC‰)®å¡þ¼nÆmÊtWþ±ôæYoòbF¹¸Ãóèù÷} o’4:Ôž'¾ÎŒîlÁÉàP¼ÓNCÙiúÂ1 v!eÀž{±®Ž˜Ü¦Ž…h¨úÒïC®0ogÕ|Ñow¹y[2Œâî|Á¾º3ãæžìlèU/Ž;¾I^¡8ƒÇÎC0/v“,sÿ.kšàÃ+æÊ%Éy[•¤‡iåPUÕûƒ¬ó…шzõçÃëè%µC4a©çz+xVëÁ˃4a¬}?"]VÎçœpSæ…À}§ç#˜aØ3žÌhpÕùI7ó¹vóÔ¡6[¤„1¬6Kð[¿H2V=d$ïÇc$y¤è³HªŒeMØ©,©—0ÝàÒ]Ye†Ú76¨Øª”dpÐ/–†…7»®'l¶yÄèÆ*¼·§CÐkR,aF1 t6-º-ñF™Ã6H‰i½½:.gJ£EC;F÷ÚBíß…w°Ž¢–æ:8ïJð¬;XGÑNKcHg¥ÅŸ–#œ•f¤ÜIéTNKcù‹Ý–^%”?‡ ;éÔÆý”f‚¹ ¯—Qh6µ¤fÅTa‚wnYÇ|«»µ…'&%6àéÆŸ±¾´ÒwŠ]«ÇÍ¥7Ö±[û¢täÆÀæ}_­š÷GwX÷;Cõý‚þ5U'¸Ó°p/¿­ |š$ˡŽ™³dž¢`XØ~(™ÙïàÎÌg¥}ÑÒ²+¼––]éÐNKÇxZZüii0óYi0óYéTNKƒ-} ;¸)=3³ï{YIæXL0÷K’s213£­&¸•M6U%G£'Æâ2ÕܺÉ<¦ÚÁŸ Û :‹<ä?Tx´¸¸ê%Ùñórÿ}Ã{Äl›û^ùÔ×áÆ¡0;ÜûKÞ˜¾ow8†c= )þbfŒ”Çò›œ;-­;˜+,¼ÃÒº].ËQ+ˆsfkO0*HaÜÖÃÍ>:®1(ÿ%ê­ò’îÜ1¼}«2¨m]Áaöoz÷$>VP§9g3H|ï”áÄp¬AJ¯Ñ Ü€çͶ²Ã¶-ÃV–¹ÒS(ç·å'x[þ)¶Û<ŒÐƒ¥y4Þ7°§ǶëjïÚ/á¸_e OŸ×pÜ nqŽ«V&–pnßÀd޵˜\‰ñƒë¡¥a9Ę#TÈ.›žO1n[ú™ø Ô‚Žáëü6 È%O¬ç5 74®\ð“/<3d@nEQÞÔ‡»vaÀ€EÙêp=wO¦Ÿ¤Çºä«©(oÉó•MZ@î9æ€\,u,™Ñ–“É Ö{„ÙšF†ûj´?.kHÅÀtldbØŒH;µ8cKçZ}…yÁd”íMb¡ÈûÞWLI³|çTrÎÚâÙÈ;e>e×ùG»þ^…û±äÞÂk·r¾ðDÜ»q„̓CÄÀF†‚ rpfÂÔŽU(WcØ•LÑ÷Íå(í…Ç?Üú—<àÝP­ª¨+Â-…TÔŽÝøYJ[%ýff’áŠÊ¯29ÏÜ©c€LžÂî3oÛp/ §.ãX‹!µ4€òHÏ!ºÈ¸¸<…Üš˜5Ö¹ Þ®ä1a^îO0‹7ïqeÆùñ†ÐÊÈš;סé ’WžZŸÆŒ±6žÈFQ6E/rM­ D ÐwnmÉ?;:]!Òbýºư4w2ØN‹Ïd sÅÊ^IndáVCáéCªFñÂB^›K—Ôué 4rKcdñ,¾|&¿WV=w¨6¬ptÜÄXEذ3öô¡£è4 µÉ“±wÚ|&Ë,íô²È3ÍYàÙ°¨=ºwoÕÂoÛâ-ÃR8Èû#îÊ2‘Cöè–[®¢weÓñ®ìå‘i‚(aæf.ôk-<ˆ.ovéxý ê™Yk¼f%íw^x€›ŠËzÕ>8ïãºÅœy¥¨ß͇£ain"Ï}e"S.%‰†#š…Èo_õ .fÿÜ„…: ­møˆð#ù rðÌŸ,—?wö¾/Â…¹œiFzžÞ¦~|ÍxôP} šÖ,¼æHÕ›^SÌF^Éðýª‘¢š¸ˆþ‰æ˜a.&Tt²œ¼\¹¼ ÖKÿ+”š`+9³øHdÎS¬¶%ªÑÈÔ*¼ÄÚæ:[Œšå•¹g+~-Ýìcè¯ã)]ÆÉÍ2Èj‹É>>6&ë=!ÇbÞhH?³çz½¨ëêBØÒ˜×P&·0ÌaR +1Ÿ`F(݇üZ§êÎR²ŸÁ¼¢×"Oí4;Lî²3MËš*]]›µšx1ŸZ0–P°)«×5wÕKP¢X[Ûð¨VM̉â5‚Âx Ť ¿?ðÄŠ›˜GŠÌ©i÷Îx¿oMMSÖ»rA˜èk—š&4nð·53³ý†í™iÖS½5Q¹]Ð3ÓȸL¡°e¦yP(Ú”¹$4vað5/ͳ’¤D†ÔTræš—æ•xã‰Ü=/MÜ‘»ç¥‘#ý,ÍLm;úõ43išŒ:„m… ÞUx(É™54N¹bk¹¡8sH{¦BÝuu[Öä7æéCdžŠ2¯Lsæ¾)[”¼oN€¸I¸µ9­ª: Óµ…k½”‘0ùgKå[Ž.ýL=H®ß ‹æ½vðƒ›á Ë…ž¿ß_˜¢é¤+kp¶›‘–³ØÇÚá;âvßH²iÈšƒîúƒa± Ñ¿êù7 /q;úË’­ƒ>‡ë‚ç,»Çy®N´¾OÑÈÓþ©`OŸ¡*Ç4sÆÙ7>ü¡éfg†œ•ü¬—-šh Y\ÖŽÕ+\@oòú´üóáÎ_^ã›2#{w`%Ì,þõ5Ùßsí+šïDr¿·ÈŸÈû©°ïS›°ïUÍ0å¢_'"‰°Æñ>l&hÍ­S‘þ‚Sq”>s”¸›'d®û–~cQØÏ‰&½9ÎÉ€;'1ÂÂÅOÍÉ´^|µjôWè²×Eu«µ¾º3ÍË_Oe]Ûw_ÿûÛ/¼õp ¬Ï˜ö|Iþî¡dRqgÓóûÓÞ7la¶ ¶Ðë]×t™Ö‰1žiÍfÌ÷3„îBî»RÚŠÆF¯B8`½ö0!¤¤¯B˜¨žpcÝæÐ¬2´B_ÿ0nLˆ[š?tñ—BÞÀ¢æ×ø,!dHzª¦Þ˜|m¡?·É&„³ÄM¢é\¼U_q§¾›É´^ç²)Æä-Ýß6ó¢Áïgœq̽x nxxBƬ‘¶âúåŲ~"!ã#|®Ä¤À%-n>û\ÿ|®™êo<¹1f:Ú²½ºÐÙ?G¦üªö"a`ú‡Àè9Â9„°Þ’»Æ[•™·]±Ôm,LÊVÊú–¥Þcæ£z™7Å-Ïv®°è«§kò¶··lù¢VÞl¤ÑÝ>ÝHÅBõ|ϼõ¤à%ã‡ä™ÛTépë¦í}ñ6tæåÏ—ÌÔ|wr3='4FGðm‚-ÍyÎâêšx¦ quGBŠ|/­q6øAÞUð®ÂciÎü;LÍð’ÍølÁ³hžæ’ó‡¾Žï³ ‰^@tfÀJ>ö»Lúl(cjWxw7x:šÌ³¸©Ê]bõ¡ª]U[³d2Ò6ïÓ²e¬äÁokMð®Ö#g‰u+,Œ®Â£>E»ŸÂ›\µ{ze<) ŽÞ÷zHü[–ƒ'%;4þHüÉxmEK #ï§cn`ÂÅ­!ÌPã%F[eJHõ˜©ã¬ «jú“—¥ô”ÁUKwfX“_2åŽ~Œ}–³)ÓT™fL;˜/Zº-K´È¤‹,½0Úò@ïSê+¨bõžKq+ªebjýÝ$’¯P@³f£ªk޽çYR·$™Ú[®ë°ðÒ±_iS˜øJºY’%{r‚©˜$¤‘™áÁ+"CsPšù–¨mÄÇç©r(ºbCª›Bý}jÙð]2Ïëff«Kí)=š¦É5 žïNŽì?E“5G¥{tÍè>Á #36,Ös T> ̉⠽¤è0'*ŽÄ‡$9³tAÕA…*Éyõi$磜®ðé^í :øm¯lÚŠ¬™bz‚½zÙºà °2ÓQë„ñ¥Œü gÍhÜÚ4])KØU˜à]…çƒó<@c‡Œì` >l ß̪ßôušçoqû«ðpÐûž3•2¾EáŽ(É+üA–v“–(óЈ[……Bä™ÕŸÅ]Éf: ”/q%^½KãÜsÄÌBLõX\¾>+ÞSË ¬Ä^¸~ä×R»­”JS#ÆDj†E†¸¾ <‘‰·™HuC¼¨i½Œ©†Ìn‹tWü‘\;®•…¾vQü™$ï!u*L·½ïéE/óF6¾P¦-ý`—Ì™…ˆÜïŒÚ‹ØWn5B)«úZ³mÌ ˜Yi`)¬±tTXB½pçÁ%K©2Áö¼xzT>à‰ ;Î>(ÅJj{h"½Y„èŽ9&AUî†GâÏÞx[õù”ü&ÐN¾˨çºE¹ÌÇe•y,øâÞ±¬¯ge™-éX–ÛXDz“²`±“²r66öCÙÕ…œ˜‚ËÜ\É`eå:Þ©Üñ»òÝ(kñê,3!¨ˆå˜OÞykQ󹨬µíê°û”ÔŠç›ô´VA^ÓmNS”^¶ü(þz…{®`O rÑÚWˆvvåõ…%a¦™@#Mƒ ÓúÙð³¦1«ª/xJ`þÆ€y1$å5?­8ߺ©‚iÁVÚ ¦‚ašë'(hZªÖ¬ê‹ì³»;aÙ­]a}JoÀS]TîȾ©.àž1»¢ *=%õüj_oà÷=Œÿ¤tJ§¥ }R:—ÓÒðžÎJÃ[=+ÍWòNJ3¸ü¤t;¥2À±ô¢:fþà~¼£¸e/GôæWQ™ÊtWü¡\ÿQ3u©?mÇn™×ï0pÄ—ª+ðTa‚wJrÞÍ *sóþi& s¥¶eµŸºzÈU‰âúB÷’}Óðåm럸*±Ä>äö"ó€du¾[™¿ãË„²tõàÉ<ëŠb~A*ë¹/¯ZÅñj& î9AíØýš“¨Wå¦÷0‚¾jÁÂ| Úö©WT˜ä¬Ýê¯1TAæc?j O|ë0zæcþs?Óæã/™÷Œ²œ¼Æõ öº½#F˜ÂôÐÞâO¯è®$&;&éÉ_W ¯»Åp¤›ð&Î’ pE±â»”ëôŸnóÛâÝ ™ä8%Ý#ל&å.Íyƒç »~n“á0k žtlC¥4o=Ÿ±~ÉÛH©?Î]ºeRÂ>g9Ëдº=/bBSóa‘uKšqDY·Äù§’í!vEyÏQQÝIUˆaÄw:&è[Í:ŠÓÚô]Ë y‚VzP<_Èú&wÀê\™•¤ÀÏL!WCÔ™™-W}'þ<Ÿ„©|g\ÃäbøÀj)u„’yñ‘UaÏi€+Áw¡:*w¤0:ýj(8?'DX.a‚ˆv¥Š‡,SÞ®HtÑØsn}àIsÖhÂk~Gi!Éš¯ÇÌØ¿ËréP¶9©|}â€4ÛNàEyÞ2ɺح®­¥g #§U#\-Þ?䥵ò{˜øÕÛYÍääC©Jé¬i¢nZf}mmY]jå™çÆó>lÏø“OöíƒW;kçC¬Êbºa|FŒå&p++a'>¥™/š%ŠýIIªy0…_ƒ}‰K°M–¬QB…3·“ K<ˆ"V2sÄznÏF9xM,»~k !uKâ ˆQß§‰Êu‘—ÈÁÃKv¦'nôå…O9«¢qqå#´QSu1ñ* Î7—t?®új_j÷Йp™—u€¨—3‚,i%Â<¸!î³?çÖÇ2“^×H ßó=3'KT†â“°Á1±VŒ·ñϰž‡Ì¦/š´1¶ž\ú3çV_'úiø-0™»µÊ÷LâhKöô¹1c"‰[+ñ˜B¾U§¬Ë' ˜³+ çy@úIÜMЀQ ³£IB E>#G'íî¢hNýæ-óªAÓf”–Þãnû¤åŠIaj…Ï·}¦í)òJŸˆ2&b‚c}àLx¦´]¦¢Ü6¯_+Ùõ©×JãN?ýa¡Ý^3-Yš ù,´û6Þ{üÓ{®7ÌÍæ9å…ãêภæ‹»Ë$ÆqáSÂÿW{"Ö‰éêS˜Ž[_ý>A)á¦û«»Ú|Ûeóá¥q³[®Ì û ÷‹ÿ·ºRo,8> stream xœì½|TÅ×?|fnß’lz#ÙM‡$@P"lhRBO@$T `ATE@D@šúP–1%6EADÅ‚ÀOED²ûÿÎÝ Äˆúüžçù¿Ÿ÷}?¹ñ{ÏÜ™9SΜ9sfîe%FDvšNöìÓ8'dðM«‰ØhÄ– ¿mèøÐÅÅ%Ý4üÎI®Kmžù”è‘£Æß|›þÝŽúDó;)ß|ë=£î?û ѾD‘-F:âxÑ ešFDèÔÈ$”Ÿ‚ç”Ñ·Mº»ÝöÝQDm=DÍFÜ:nøÐmB‹ëáyômCïÑN¾ù;#ÒuûÐÛFÞörÄ«DõVàyËøq'5c{lHßKûáø;FŽÿ©ëבD“ÉBÞ·[úØ-M›6iÔ¬ENó\W3}UÂïí´½ë¢!Áù¿è1º¨Œžþ*?^Ð}];ö¼xñr•ƒôä5pää‰»ÖÆÛƒÚ;èâÅ‹Sd–T㲋ÜÏQ>=J*qrPcê¾|þ)x–¤ù.„te¹ÒÄù©tˆFñP]áVMæâ’OP†¯’înb Qvßîí]„?ßeåo/ÖTkÃÊÜÄ|>‘œ¦ì’!5˜—/>¦k\h›h5¿VÚ®0 7iÔ5S“ĸQêß–û5t ŽÔ ´ó5Òz}!·þæSñ?”TwÕ]uWÝUwÕ]uWÝUwÕ]uWÝUwÕ]uWÝUwÕ]uWÝUwÕ]uWÝUwýí²ÐÔÀ»6Fvª~ïÆIÆ“?,QÈ•x¹FX5Ã1Y¼Ç‹Å“?ÌI§Ì@X¢¤+ñr°*½tÐé†Ì‚;Æ ½5«Ý¸[GP/@ÝNtŠ( ;h ¥[)‹ÚÑ8Ðh‘õü-q쥅T’ìX…浯©Me>îâÅüy)Yê)“&KS¥Ri®ô”ôžtA¶Ë=•0%^yKù^9¯Jj„§:ÕVêMªO»-~lü-ñ¯Ç¿ïK˜–ðdª„Ÿ~wF8ãÝœÅÎAÎÁÎû[o8?puþà<ïôº‚]I®4W¶+×ÕÊ•ïjãêàºÉ5Î5͵Øõ¢k»ëÇD%1,1*1)1-±Qbľ‰7%ÎH|öó{Nì8½ÿ«¬óO/ý|ýçKŽ/9þôñ9DÇ× ÞÏ£ŽO8>OÙÇÝÇ›O9ÖéXÇcùÇZk~¬é±ìc Ž%‹;~Œý÷ÑÓG¿;úõÑ/×Ñ=Gw}åèK½yôÙ£›v<ÚîhÁÑ”£IG&œ\&òß)îÊ+˜Ž+´'µåÚ2_ÕSjû§öC¶ï’†‹¹ËÐ{é¤T‚üÊ\Ü—(»Û´B¯ø¹õ ¹ÞB«¯5N„Õ3 Y´¸wýG£×ÂÒ÷I–é5⦘÷+1–§ÿ’{®€e~à©ôŸj«Á9Ì2âJ¸ä/òô°ŒÆýË#þš±Û¬s­Ê,Ñ34ƒ–n¢%ô =Bói­¤çè_ä Rˆõ!zŒ~¤Ÿh=A³£cô­¢ ô3£óô4m¢½´‡ž§a4œÀ¼¾M#é-ÚGïÑ;ô.í§oi¢t^ ›éß´>¤÷éM§è4ͦ±0зÐm0Í·Ó˜è 4F{"M¦It'ÝEßÑÝ4…î¡{é~º^¢§hÖ›éô}Ogh;[ž`œILf ]¢Ël)[Æ–³'©Š¼LeÓÉÇV°•l[ÍÖ°§˜Á,ÌÊlìiö ] _ٿسl-[ÇÖ³çØ¶‘mbϳØfæa[X+§ßè0+esØVö"ÛÆ^bÌ΂Øv¶ƒ3 a¡t‚¾`a,œíd»X‹dsÙËì¶›U²WÙk,ŠEÓfò°Ë^go°8Vųö&ÛC¿ÓEú’¾bNæb‰,‰½Åö²}ìmö{—ígï±d–ÂRY;À²Cì}öûv°tVŸ5`t’¾f‡ÕRuŽ:W§ÎWU¨ ÕEêcêbõqu‰ú„ºTIQ—©Ëi­ú¤ºB]©®RW«kÔ§Ô§ÕgԩϪkÕuòXùu½úœºAݨnRŸW_P7«u‹Z¦–«[å[åÛÔÕmêKj…º]Ý¡îTw©/«¯¨»ÕJõUõ5õuõ õMuú–ºWݧ¾­¾£¾«îWßS¨åËr•ì•} )LኤȊ¢¨Š¦èŠ¡X«zH}_ý@=¬~¤~¬Q?Q?UªÇÔÏÔãêçê õ õKõ+õ¤úµúú­úæû÷êiõŒzVý7ûˆ}ÌŽ°Oاì¨5Tsh!Z¨¦…kZ¤¥Ek1ZœVO‹×4§æÒµ$k˜5Üa ¶~n=aýÂú¥õ+ëIë×Öo¬ßZ¿³ýb»`ûÕö›íwÛEÛ%Ûe[•ÍkóÙÉÎì\KÖR´T-MK×êk ´ -SIµFZ£´éÚÚƒÚCÚ íaím¦6K›­•js´¹ÚÓžÕÖjë´õÚsÚm£¶I{^{AÛ¬y´-Z™V®mÕ^´F[c¬±Ö8k=k¼5Áê´º¬‰Ö$k²5ÅšjM³¦[ëË‹äÇôvò½½ÞAï¨wÒ¯—'éõ.zW½›~ƒÞ]ï¡÷Ô õ^zo½ÞWï§÷×èEz±>P¤ß¨ÖoÒ‡è%òãÖÖ k¦5ËÚÐÚÈÚØšm=eýÞzÚzÆzÖÚÄšcmªÏÓçëê ô…ú"ý1}±þ¸¾DB_ª/Ó—ëOê+ôÕvÉ.ÛJ`?°ÙOì;Ç~fçÙö+ûýÎ.²Lv‰]fUÌ˲àkgœs‰Ë\á*׸Πna ¹•Û¸ñ`îà!<”‡ñpÖˆGðHÖ˜eó(Ícx,ãõx?ÀäñüaýmþŸ©¿£¿«ï×ßÓèõCúûúú‡úaý#ýcýˆþ‰þ©~T?¦¦×?×Oè_è_ê_é'õ¯õoôoõïôïõÓúý¬þoýýGý'ýœ½þ³~^ÿE¿ ÿªÿ¦ÿ®_ä³ølÅ¡„è—ôËJ¨¦Wé^%\‰P"•(ÝgÁ ®D+1†dȆb¨†fè†aX «aƒ§Ôƒš 8 »dÅ¥$*IJ²b„aF¸aDQF´cÄqF=#ÞH0œ†ËH4’Œd»j¤iFºQßh`d™F–’¢¤ FFc#ÛhbäM\£™ÑÜÈ3Z-VJš’n´6òëŒ6F[ÃmíŒöF££ÑÉzÎú³q½ÑÙ®Ùu»a·Ø­v›ÑÅèjt3n0º=ŒžF¡ÑËèmô1úýŒþÆ£Èn·Ùƒí£Øh 2n47CŒc¨1ÌnŒ0F£Œ›ÑÆëyc¬q‹q«q›q»1ÎoL0î0&“ŒÉÆ|ŸÏå øB¾ˆ?ÆóÇùë/ü ¾”/ãËù“|_ÉWñÕÆ]Ö Ö_­¿Yçg¬k­ÏZ×Y×[Ÿ³n°n´nRšZ/ò󤤇¤‡¥™Òližô¨ô˜ô¸´LZ‰]Á³ÒsÒFéyi³´EzQÚ.½,½*½)í“öó¥CÒaéé3é éké”tVúAú‰ÿÄÏñŸùyþ ¿Àå¿)-”–J+ëóÖ¬›­—¬—­UV¯Õg#þ;¿È/ñ˼Š{¹O"‰I\’$™Ÿ‘¥¾’¥´Vò•6ŠÜí”J'¥³ÒUé¡ôVú+%§r“2L¥ŒUnWîPî”Ò•)ÊTeºò <¤G”YJ©2W™¯,P)‹á--U–++¤Le•²Fù—²^Ù¤x”­Ê6e‡²SÙ­¼Ž½Î;ÊåÔPù@ùX9ª|®|%5Q¾UN+?(?+¿*—vB<ú`5D S£¤ÓjŒ}‘ þ}’𢦩õÕ 5Km¤fKÍÔ5Wm=SøþíÔ’®vT;©×«Õ.jWµ›zƒÚ]í¡öT Õ^joµÚWí§öW¨Ej±:)ƒ¬[¬åÕò‘,’U²ùå£Þ¨–¨#ÔÑêë‹6nSm[-Ôi‹µ%Ø’li¶ú¶ [–-Û–kkaË·¹mlm7Ø m}mE¶m%¶¶Ñ¶±¶[­ÇíÑöö;Î>g'ØìKÃg! ³p‹d‘-ŠEµhÝbX,«Åf±[‚,Á‡%Äj ³„³¯ØIù‚ü«ü›ü»|Q¾d}ÏzÀzÐzÈú¾õë‡ÖÃÖ¬[X?áßñSü{~Úú&m¡2^ª¾ÉréEÚF¯³¯©œ¶ÒÖ=ô ½J3¥؉öÆŽª—õcz“Ícó­oIý¤þÒ©Hê#õµx->+Ñ/ì[+³r–g•¬2¯”§Ò.+]«fuXClïÙØÚñ9ÖOi¥×èYZÄÚÒ£¬€ÝɲEì1vU°û¬†=Þž`wÚ]öD{’=ÙžbOµ§ÙÓíõí ì]ì]íÝì7Ø3ì™ö,{C{#{c{¶½‰½—½·½½¯½Ÿ=ÇÞÔÞßÞÝÞÃÞÓ^¨NR'«wñ=ÖíÖÖÖ]Ö—­¯Xw[+­¯ò·ø^¾¿Íßáïòýü=~€䇸ûü~œÎOð/ø—ü+~’Í¿áßBׯƒn÷Qú*ý$§ä’¥$høpe„2ZßS)TzAç‡(%ÊP̃nÊ JwhîÊ›Êhï»Ê~å=Ì„‰Ê$e2æÄ8e¼2AJ—êK ¤ Ì{•û”û1/fcvÌÄ옃Ù2MÊ”²0GJ ¥FRc)[j"åHM¥\èüyååôÿŒrVù7´Þ½uBëÔ±Ðü[Ô[¥ÓÒ÷Àhyô¼=æÍ å åKÌ…˜é˜™J'5[m‚’ŠÙÑs¢µš¯^§4PHͤæÒÏÒyìrÔ«6c©¤?}-ŒDIVTM7,V›=(ØW/>ÁéJLJNIMK¯ß #3«a£ÆÙMršæ6kž×¢e«Öù×µië.h×¾CÇN×wîÒµÛ Ý{ô,ìÕ»Oß~ýtãà›†” ¥aÃGŒuóè1co¹õ¶ÛÇŸpÇÄI“ï¼ëî{¦Ü{ßýS§MàÁ‡f<üÈÌY³KçÌ7ÿÑ =¶øñ%O,]¶œV¬\µzÍSO?ó¯g×®[ÿ܆Ҧç_ØìÙRV¾õÅm/Ulß±s×˯ì®|•^ãÍ=oíÝ÷ö;ïîïÀA:ôþþècúäÓ£Ç>;þyÝMÝMÝMÝÍ_Ÿ’N<êÎhêÎhêÎhêÎhêÎhêÎhêÎhêÎhêÎhêÎhêÎhêÎhþ¯žÑÜ1T­þ¦e¨Bz‡ÆË)è¤ÅS±ò dßÒH»h/ÅS=yõCþÉxžúoé«BþþÀÓ@S ; Ð(Ï>`Ê"Ê1éW4VÛOס.–CÅJziO¨-i˜ˆG]sQF2ÂË¿RÝ@ ^Šôb‘פ‚¿?uEzÂ)ý}>miˆ#„«‰ú‰6ƒ¦¡þ‰òDßY„3Pv¤ÏíÚ7ÐÞh3ü•à1û*ú8[„!Ÿ©ˆ_ôæƒ ÁŸ >'žç!lE» P„mtòäóëÈÚõ·ô›Ì~£Wú„ö›mº6ú‰öÕÚ$úu جѶژ÷L¤RSsüDŸí@k¾ŸÚA.^Ñ/åk߯:Ñôk' È#¨ ¶CÐζÊVZŠç ßÄDbò 'Çl¥)êz ñÄ›(•Ÿ¡X5•ò ¿"”?‰2_7õa„hƒï ¨SþšbQV 0uï«–“ ž;c\‹÷²øåÈu02X Ü!Ú‡ú ™cÜeý½Ï!ï ÔÓMu:M ïþq¥ÉàŸ€²˜Yü@úXÈô`7ðªhC5L= À,kI|ƒïgÐ0 Ø,ú”-EÔoA~‹©¯Ð¡›B?„n(o™ºÚG´Ýßs.Ì Ì™ÛÀ?ˆê«›èÆê#¯Ï0¡³b¾T—-tKèL55uúSï÷Š~ ªA+•ÔK´Á¬ºUMżC¹÷*E˜mZ.6û¾Tè[5rº&棘ZX£¯Y9’þSס‹Õ´ZWèZŽ2û« ¡§§©‡ü)õÞ¥Ê= ‹Ð¿íˆCäða™ÔS¯¤Ëžà]V‹.г±¨ëQy#dq˜Všr=Ì“äÃLQ6úN)Äö)ùT3ü'Z¬ÒŸ&¨@Í´ÿ4þ¿þ‘²‘F!ü½rØçC‰9¡fÙ€«š"¾ ˜dè™l©~ «Ðú‘C%:Œ“ÝÔJqSž\ImårCN©ˆï§^oÚÝ(ÿ-všæa¼Ñ"(Y:ÛˆºøGXQ>h÷zô«­KÕ´Z_kS¡3Âî‚* 1˜w;€À§|| }ì \/ÖaŸÍõ6˜ç×WßÙ+ú¹V€Î¯ÖÏZzšQK?µÚzY›ŠµEØwsmÁ¾eÒ'M}¼å¾‹¢ZkŠR$ôOä²’\y,1eQiÊèqS‡! Q¦ú¡éorùWÓýº…–ëé°O¿P¬[bÖµ…ènSî²¹^ÿ„ùq:Öf)á¾ßMýßäóI1‡Nc~ 0¤EPŒršžÄ\šeÊÇOçˆù#¦¡#è__ÓŸ8 –îP7Ò\µzwkÁaŒÛiôåjðBy£ïòvD$êF|/Ó?ë”ÛwPÌ­’¢57êï ÐÓÿC½Ò×hïc4 ¶¤@?MϨ.ÊÆò(œÆ ‰æó4`*0×3Îá§,eÜ/âùHÚ‹Vp"sA~sïI*Ö‘Eÿá{z7»èÝY¬Ý/žå,ª/¥nÒoæú3S±Pž™/ëøwT(ƒ¿’FÈe4Bò! <}ŸRA•áð³nB9ðæà1¨Pƒpcß&‘Ϭã7_¤€|å˜|5`¶µ¢ÍO×hóãèÕÐÑ^„k¶W´õJ;m¼VûÌ~ŠrÁgæ9JÓ1 ÕO½½ø<Ú¬áŸÂ¯¤©l‰OübS§Zè\óYžÊf…€Œ}Û*І ß‡b/ü[nF£ìWAËž@€¿ÛŠôg—ãÕi5!ê¹V|MÈßøvÔ|Vr¨¥Ï‚MÏúcš™åÊwÃgûvHw’E@ ¢šN ø—ˆï¾ZÏJ}zB‡¼½Iú§6ýpe×£»f«Ç4ò¿€c5¨KP̯†b}þŸ´ï¿Œï4àfSþk¨‘©CßÁ'×|¯³]t;á»{® øŸ)Ö”ç* ©'ÄÏ2ãkt¥¹yíx„óªŸkë?=£Ü15Q­ÕÐrÈ- G~ ö3Ö·€*t,ëÏÏWêý+ô¥\È©“ÜmùòÏϪƒ ðñx^Šôo(]àÊs_j ò @¶Éõþ%% H½‘ÖÛÌßF †\‹„\¥JÁkò›ãS­çµÇ¼$¿{t>s_Š­MkÎÙÚó¶v\µ-¹VžZs#û¯Êüÿ0wÞÞöü_­zκ 8>Ýð7<ðUŸÁ>ëšGT5‹èÒ«D—‡Àa ¾ü<âú!œú¸1 X.@x<Ò>ökä8º;àWÆà¹£Ÿ·jm ¼T?¿à»oçRs?ÿ¥™À“¿@Ë.½ºôä÷€¯>ÀåAsñ\@.ÂsëþåVÀ)í¼ 7ærcð¯îþÈ5ö¡ÿ»ô/öÿUê? Á¦Ï‰öÖÞCü—iõxþ­½×¨ÿ¢Õ{‰?Ñ€àó½-Pcïó·{œjŠñü=€óÀòl_|JÍô£áËš>·ðÔô·›þ$ œ)šTøÎ¾³ð_AW˜û¼hÏDºAìóÍvU¯#5l+Ï¢‘@d°{ÔyÞG{~„í Æúú |˯nòÃ÷Ö®`ØÜÝl—ïÐýxŽÇZfT¯iÕ¶õO6öÏkÚÿÕçÿtüo¬©=S Õñ£¨Þ8€$ÚkñŠZ»ÿÛkù_¬Ñ5×éÿésõ:_ £ åhn´Ûýg¿´¶ðOÏÿäçþ§ÏµýŽÏ[þ&Ý|®í—T?ׯŸÒÿ¬{~&ó­µæÝ ÌÓvò8ß'Õóµº µçñ•ùxV§Q c5eë©>ìH`n`ß•Œ0Ö@ß±¾é—)Gžrðü"°Íos|ÅþµÏ7—m…/ý«09Þ‡ñ¬ÉûͼEÿ“>×Ö[៛þ!df¶}Æâ<5Z¡Àà¶+c=$êÞ+aåû\é¤ï”õË_ù‚E±Ï»Cì÷ðŒç`Øâ8u %ˆs sÿ]‰ýëW°‹oј«g|¾*µÜÌs£y¶ü)õ€…=ñ8ù+ß&óN4¶wT¿G1ÏÖ–ޥĉ³!íñîÇ÷|à|®¿uðgê§P‚ùÂ?y‡‹³)þ%Σ´¡8Ÿë•ÚÀ\c‚jœ#·Šåæ”´ ¼§$]DÙO›¼sÌw2—È#?OýÅ»0ËZl¼E‹uôÇèO+µz´R¾ƒ³´¢¥º8C®G ÅzU½®BöÞkœý‰³Ì”gšfŸkûfûšÃ®¶ô=]³Þj>½=dÓÛÿn(pÎþ·¾ ÊÉço®}ÞéÛ8÷œXão¾²æ×>§_Eäf}þ3Y¬ÙŠ åØÌ¶›2®Ý–êº —ª¿ò…ª}“À•xÏö`à\.ˆëkútÆ«§83SfR´\J½ùßWòÀg2Ïß3u¶T´Sö¿·‹n‘ÚP¾sô 7Ï$?4ßá=ÀTèéZóÙió,¬·ºçŽ>ê Y}s˜[WàûFÞˆºÌ÷~¾7xRîeêgL@7ãäߨ›¼ÞÔ™ÐÀ;Á`y! d7:Ú<€‰âÝ›ù~Ϥ¦¬NCî¥ÔÓì£8›Û½…|¤Uæùà ê¼z[ê«Í†¾n†î<ˆz;‘S] œ§hµüÃRô»#x¤Yü'Ê`ó}_ra4D@"Ê‘á™Ãöx÷+Þ Þ«M£?âÝÖÏ"Ÿ™×ÿ.W C€o`‰÷„Õá0ØŒ{;€ŸX[Èçû¸ÄÏŠ“C”ÏÑ®ûÛ$9 «µžaH@¼x(€¬þˆöµ^A×âM­@|lm ^Ðvµøv×hÇ_åû«vüU|Zm >í¡Unrm >ùoÚ×­6ßí?hÇ_É9¥6Ÿò7íèQˆïQ»°O›ÝØ£¾(ÖO¬Õwƒn½tðÂØ÷úFž÷ò¾ qùœtÄ^ë±ï °èu¢._„Ÿ§ºß-Ÿ½Þ_—àõîô×m"P§wm ­/¾RãY´u{¿ô×gÖvxwøýßräÙŽçÖz×ùÛí¨ü}4ùÖ]…ÓÏ;^%úÖç*DÛ½ØûûžòûLÞŠ€,Ÿö×[…}¢/hHŸuÕ.Ð^ìo†=´ˆµZçD‚ [kÚÜ1^c­º+ðÎú aïT´FΧx>ʰ¿AØps? »oî'?6ß«0‘‚uäC<2Ö@ƒ`7gP}Q‡ù^f¢øžÅ÷´ð9¤©—€ékTškuX,×Q±Ú m:O±(?N{æª7‰ïKÌ5ϪÆóÍð;Ä;2îÔWÑ\íÒ%ê„õª}u|õÞV}ØçS²ÈZMõ T¬½ƒø”¬ÄR²¨Ok&þ¯޼꺯¼»ß$ö¹æ¸ Ý™çÇåLà³Íh/hh\õw¦LöaO.Q–ùÎéK¤3²«Q˜W—©¾fÀ¿ØF³ NË´!æÞ½µ¼šrk|/ÐP¼Rß§,å!Š¨Þ»«ŸB®·a TœTŸ(+i¹¼e­$—ù^+pp…V—!Þ·¦'Å·µýšj?êŠ8#¸RG ?‚е³FÿMZÃßðŸ)l¡âݘxgúµhu›Ä{<ñ. åÜdú_mè&m ÖÖç©“úµWÚÃOïJíõXriÏRŒðÏ´QÐMᯉ35Tž$Ìq_{ŒÓ>лO`~÷̹MÛÑÛoÎMÄU-ÄîÆøÓEšoš?\õƒ¿|3í>þ*a«Ä;8.Îh¨òŸÛ˜sö7®!ç%¦OÿgZýî~qÀoý{ú_ÌìãÏb-ü[¼‡zà-è žGÀsõ\4éÏÕr¯–cµ\зoÍñªnsuýrÿ§ãˆ2çþþz\|? üoõûïÚ®¼å;|&˜KÇû’cþo÷PÆÛ<ßl÷7è#  ðÃü–fƒï\?C®_G… àµÀ7Kß Ý’ ¨'ÔS[~ ðìÿþÆW¥~ã;¢uõ}&æøöG@øR×’6Òw:ø™¶ô=ðŒ5÷HÂ÷ïŸÅÙøÆvhÀö%û±~Í3Ïd\b­×=Ðm‚ýy•FýÑçóõ Ø`ñ¬ø¦(T-§¾’—`¿¼P¶Á&}äûFuÍ`_ ý¾ŸïMàõÀ7’"þ¹šQ‚­Pjñ­ øÛ½Ãï·þø«íºò$*æC؆+g¯‚ŠoÚ„n|A‘“)¾¹òå‰wÒuâ{-“·3ИaW”»ªÆû§mµ¿ÙøúýVí÷Sõ¾èŸ¾Íø§o5þôü¾S©ýíÆ?}ËñOÏzóïËä¯|¯ ZØQ-^„}‡7%„ Ë>¤} ]JD¾‡ø˜³Ç°>\"gàL4ñá°_áòo¦þÍô—ÿ<Õù þÉ_ ø—Õ>浟ÿÉ/Dž}5Q;ýÊ;œÏÅ·þðÞ¢Hÿ¿y ì»ßF«MÍýŠiw0–q5ÎßsgιæxͦØ”¸?í $'ƶzO9í |[RM‡øa®ÓBŽßš¶’Ñ`³ظ€Þ©¦_#öwbï°Áÿ."°÷«ÞËEt«>ú¶ëà,ñ`½ß%Þ·ð/ó’}´Âü–q'/;ЮÃ@% ~ùâÈQµ'°te?´°"{ŸTãÿ ©ú Ä'ÕÔ‰zÔOœ‹ ˆW ÞÕ€°ã™[úN/°cQÞ pràîÖ¹¥Måš=Ç]nÒ²ÈÌœíØul*kÕÔŒo¸8gú.i# ¡¦ˆÞXÖODo,wwÈ1iÓÖ~Ú¸‰IËt²žã,ˆ[c€Sp ÔxX ìT4h#}øIZ/=]ÖɉžEAÁáÒ³ÄÐÊgéà$´þYôåYú!#£UÏ”6Qý3&W܆*ŸAáÏÐt`3pP :Ï ògÀù ÊZ gg3À¥§¥§ÊNG®Ø4€KË) Ÿ¥/-w˜²YV–ã.pHS!ÀÉ#u§J€£Ø…`[HÙ»•5lbа[¹%(ÇüsÐè9hÈT¹wf>»‘NyX¤(þ¡²à“ïÞ²ì\ ÜS)ÜML)ÝNÉ䔦‚&€& »ÙNwy°#g:êk‹ìm¥j€ä¬Ã9 ¤XŠ3³M. ò×3¹¬~FzÜ^Š6³KvÊÕ%­,ÇéÚ «%„?«Ü°ŠöÍ*sDä¼,=,iŽ\Ó‘+Êü2lWc@ô¤o¹aÏYP`“ú¢›}!'ÚÈ åÛÍ‚n/CA!RG¨o$ÒnÁôíwRÐuÒSÔ teyZ=gåNé1“k‘(Õ·ñ«V›r{PNe!µAªGš˜oV¾ <­E¤Iõ±6ÔGå.iBÓL¥/E¨£VŠ‘*ÅH•¢Q¥Ð>’f#e6ò4†ÿ:~ë`5ÂB­"Ê Ðíf ¥~Îv)FІ`;!J†ØØr#H´,º,4ÌÌ]n Êiû²4z>eº¥IåQÑ9ãvJfW²Ê£ãÃø2¨ëËR”hÀ)†äe©!/%”E8=N< EvãoóƒBHü~X ·ø7¥&}'@÷è{~ê«äý“‚¿/艂zük6„F«â|'²Áð)¯­àŸðíÔôžG€nm º£,q¯³‚W”ƒ íO–Ù#Egùëe™gj „Fæ¤ò×ø«TE| šú*¯¤$ÐÝ Ñ •|í}‘7£Ö [ô ¾K¨8‰o£ åeA¢ ž2MÍeª /”‘ÿ©°±s.p,²>_–‹Øõåi)Îà(ñgù¤²xgh…?ÅŠØydZCG¥PþtYž(dAÙ.—s;_À¸£óÜ©î†îµRvjvÃìµ’+ÕÕЕçZë*pðù0 «9æ/Ÿƒ{¹8´p øì29ÏSP…>‰~qšŽû3T‚ûx3D¸;®¤þh†Úò‡ái>ŒÐ>˜L€{¿€Oîîî7c&“»`Mƃc<8ƃc¼É1ãÁ1ãMŽñfí“ÁQŽp”€£Ää(G 8JÀQbrˆö–€£Ää(G!8 ÁQhr‚£…à(49 ÁQŽB“à 78Üàp›np¸Áá‡ÛäpƒÃ ·É‘ Žlpdƒ#ÛäÈG68²Á‘mrdƒ#Ù&‡ .p¸Àá29\àp×Éᇠ.“Ã8àp˜p8Àá‡Ãäp˜ã3'Àq'ÀqÂä8Žà8Ž&Ç pœÇ ~×é`Á›`9–ƒ`9h²ËA°ËA“å X‚å` ë“Lap¨ÍT`0¼•à­o%x+MÞJS½&‚×8<àð˜pxÀá‡Çäð€ÃɱkÀ±kLŽ5àXŽ5àXcr¬1w2 8þs¥ü‡†?ÀŠt¬µ|:k`ÒitƤSéˆIï§-&½Öšô^zФS(ϤwQšIQžI'‘Sgeμà‚H˜€žÀ`°Ø ì43tøðñfî$9Xë©­Ö6k»5e³vBãÁjOuµºYÝ­*›Õ*wÄq»iGÅÿ€ýQó> ÷,"¸·5Cmy.êÍ…m†¿\žë9ëú!ƒÈ`»3Øæ öh+0øõL6-‹ò8Ίܶ´6Î#@^ZzX¦ùÛÎD9ËÒš;+Ø.?iàÎ=lÖy@ÐHœf\ò¹“EîÒDÀ%ª ÈH8Æ¡!º{;·³µåoÚÉõ¤×ßβôlвôž /•¥sl¥ ¯ˆ½ˆ‘Ûº¹ÌyÉÏûɦ2çNõeÎ\Áeé@•¥ïwØY?rÊ‚µo€öA¿í]æìl½Êœ @2ËÒÓDî T”ŠÔ¬ˆN‚¦¸Rü5%—9[ƒ$•9[ŠÜ:¥‹g*54›§‚JåhÐÛY‘ÌÜVçYçcÎ3`? ÁB=>qUÈ R+X·Å¹«á*d.p–XD~¬[Ô#è‹Îµ©³O¢,–ºÍ¹ÌÙÈ9¿a…Žèyh÷l³Š2烮 ¾ÑæœîÌvNjxÒ9ÑÙÕ9ÔÙÛ98ñeλD3©˜ñÛœ…(° z‘Zæ¼>µÂlb'ç=N·3ÝÙÒµKÈ—ZøËÍk¸KH;O³ö,È7#µBèx¿¼ âÎÐ~Ôhƒ´vZk-YKÒ´x-\ÕznÓ-º®«º¬sôð ß w¦øõËpñ;rŒTYÜe3ìàânž$a©b:§®ä “ºñn}Ú±nžÊáÔm˜Ës¡Or³ôèQ’Û1Oh7êÖ·§Ef· Í×Û“—ÙÍ£*ÚÂØübÄzø¬ F}‹*˜OD=ç mDzx^Üvb,æáyÅÅygÛè¶¡mBZvêp[IàžyõŠ®Œ÷,é֧ȳ!¾Ø“#¾øânžú¸n,Ú΃¹½c‡í‹ÒÌ|i»™Of"ß–#®Ž¶¸\fžT¢#fž#©T#4¼¶¤¥™¹’]¬HäbEÉ.³a Ì‚œNdiè4³0øufANfVæi|5Kj K³+Yš™uIìj§?Oxýê<áõ‘'óxl—ÉÊ›LžúzÇ‘ÉK’;ŽJÌåÚ2u²Hpy¤´’aÃG :t¤gròÈž©É\[š¼~ä×Er“ä[èõŽ}‹¶¼îÙ¡¬‰»IÇ䡊ËÛæü¡®ÙWê*Ê¿Faù¢°"QWÛ‚k$ˆä¶¢®QW¨«­»­YWÇ1Bï ‹¶èÔ®¸ý~ZέèpI\bq»HÇø6B¡··NŒž·C&¶ž¬™Å[r;I ˆ$Ì3‘„èà@RôÔÖ‰q;Øú@’Ñ!Éí¨Z´$2uó4ëÕÍ“Øg`‘P{èµÇl¢¸Ìähê8¦þÃó$ø«™“&^óšt­kòäÉÅmræD¢nžŒ>Ý<Í{¡%š†ªJ:#®Quœ$™q[ £c…¯‰™h›$ª¡L– º-Øui|ºFãb«0©<6>gÜËXÁ§ØÇñ»Ê›Ûg~WyRªØ¿L*oÜÌO±]´,615”çUÐT?u‡4D`Aꂆ òÖ¤®i¸&OEì¶µˆt®KiYãµMÊœX-'CØh–¨ï©²zñfÅkD 3³8s"3åõga³j¡_ìÄ@©Íâ'Uˆ?~b Œ„¿öÉÕl“Lfâd“É_ˆÿéÊíê…§ñ£•TÏÄ:ª'§aE¾“ÕðŽñi‚òïaÉãý\e´‰>fõ™‹ÊÙEŠ¢ßX kB] ¿ÂuÛLUô8¶÷}i Åž-’úQ&#O&ÍeOúîô¢ëh=í{‰=èÛ€ôGiý†ÇJ™G=¿¤SÒ×Tì[N:Í$+öt½Y$ ¥ð÷ Úð-¦WØ}¾ßPk8=ˆòò©€ |¯ú.SÍ•(GŒi!ídªo¸o <¤$*噾|ŸSÓ3´ mÊd•rgJ¤[èaZÊb¤==Nÿ"/³ñÁR{e7jêBýévº‹Ji½ÍBY¡rDùÑw¯ï[haÕG›ÆÐ)ÖŒuçÏÊ6_ß§4ˆ¶Ó^ôWüUʃäuÊ o[ßJßkØ}¿Ä,l{UÉQæW=à{Ê÷ÙО&HÔ3Œ¢WiýDçø4ß4êL}Pó›,ž¹X$þáSùTéj„ÞFk'Ójò`DvÐNz²9J'èkÎâXW6Œ-dç¸à¤'¥­Ò‡2“Ÿƒ¼“)2šDÏÒ6óI0åg³B6–cO°•ì÷ð3üWY—’/ÉUJš÷„÷’¯‡ïì¹céšBÓ ÛgÌßázÓ9ú™.0kÁF³§˜‡`g¸Á“xO>ž/Áîùy©‡´PzUn&·“o‘÷ËŸ*(s´¡š÷òZïcÞ罇|/ùAw‚P~u‚D€Vp mÏä¼ÊGò|&ŸÇ·âoßÇ?âGøY´ä‘R6ƒò}Os™¬ û‘Ðz@aþ»¹¿¹XK:F§¼«d»|ìS-Áˆn¢ÏÙst‘)¾3°n¬ÑPX™¹Ð÷‡IX½Á˜gÓ0c`AnUÐVñ;ñZžÚFžB?ÒïtJÙjKú­wŒ¼JþÊ—çkˆ†YFë1ïFÓõ˜1_CK^Ƴxº3Ý[’ƒY]HiÝ«·Ðçñ­ð=ä»Ç7ŽÞïE–Å.²5˜àȧ½ø{”>as0¯ÿû~þÕåA•ô=‹f©,óá¬r§²@Ù lU^Qö«M íô$4úKh³=N‡è{ú•é›Ê¢\´·Ú^D·òbéejÏbi<æl}ØñvžLD)Bz+0Ÿ_ÆÜøvâFz…Ž0΢Уá¨_G9Ý ç!Ƚ#ø+GÌXí :~±Øg‘%-ÕªD›ŽÑ7¶ÏlWìBÖeýJhjhN…l‹ùï›Z²vÞ…¼S˜ƒÚ±$ö/ð•`†Q<µT¾bœ²¼=|-øée¬1>įÁêG×± hE0úQE¬'5óöF>`’ìaï›­XÆGúfJwyo¥wè9Œ‰[¾Së Mvôu·ms]~ëV-[ä5ËmšÓ$»q£†Y™ ê§§¥¦$'%ºœ ñõâbc¢£"#ÂÃBCÁAv›Õb蚪Èö´Y“;•¸{æ1C1jªãA¡'WT éÕaOf¦'#C¨ˆÖcŠ6¶1Ÿ›5̺³‚7Oïp@|TÙ-nÕâOL<§ÂMÃðà™Þ«Èÿì¢aqeänŒM/)•Õ)ýDÊôê”+ì%ÉÐä­æo@Dxô´+ÿ;"Ã:Žnåa‘“<ÒŸÞ­Or7ìd\KK²íÖ÷OþôWÒ!OXû")ŽBÛ²I6 NL QµfÍSòšJiÞo—ºñì“rò‚޾”}ˆQH#’;ˆÿ+#ÙéswK›ËÞÒ°ÅØ2m}l·Ø¾´©gíL•#åT¹¾½³}}ý%û»Á¸N6Õ®)«]#›Ín¯`/¸c%9\’d‰Ûd»dç²…4·½Ò~;Y}Ò¡`[·‘,ƒ*XÑVåQ ³T0îuh«µÝš¤Å·åÓ8ç1A;Ø ¬³Ù¯“wGïD×ÚBɪç³Ð–¡-[’If*2åûooQyû¾EnkCÛu¶î¶ý¶Ïl .ŠÍ„&6cMCšF$‡°ƧV­ç÷Ù¶Íû£w3K¿ =sù¦_½Ÿðö‹× ÉŒ…dQö‰ß^¥‡Üª#(,Wq8Bs[E·Šq+ý"FÅnÔT#2ŒÜ1ÎÜ`äâ40¡E½à þX™c¹­‚Or'…±z–zÌI˜,ä0‘®H›œèp0GŒëÙöþ‘3u÷ЖÏ:ò¢£UçO:ª¾œ‰nŠÌÌdÉiÍr›C÷šå¦%CS›§4Í‘#¡–ª„‰Æð±Þ¢SwË‚8¯×Êâ¾9ÇÆl*άb1lJží¾5{MZ÷ž<å~WùŪõƒ×>Úu 7”Åx¿58Œ”ÝÊÌ{ +ØNšïˆÛÈk™«ÖÇMʨß,Wuㆧ#îÂÄt¤áÖ€2ä ¥¾¥±­å)mmci,)RFë7[¾“‚»ªPƒIÃ5ƒ1iáD›,»5\QTÝâŽocUXcãs-©\’TYüš;HÕ¸"ËŒt[TT,Uð¡n«“™?š2I¬‚§¸ §Á²é7vð’‘ÃpaæÄXolUÌ…ÁΞ]Õ£ãÈß`v@¾m󻟅î4ίÊÌÌú3óþ7f6ŠDsäçÏ|ã ¿&m5r {.e êæ±öéæIè5°h;I>o™.[vø¼Ôå-ªÜB\ÅlÂ`ÿoý$&Jøc‰a’¤ìö¾2½jÛ=Þ=¼5k™ñöÖÝ[®ì¸\Ê]U'„¥]ɃäÃ`³èˆ»í]ltÐÝßÈdÙHŒ0ÔúY‰©‘¡Îˆž<;bsˆONJ Ó]ᩌx\úxuºÊÕnõÓ7Û˜Mü°’aÍ…þÍu'f7r7*lTÒh|£é4ZÓHw5ÊnÄ…'¹È–ÆÃ*øœò†MúTªüîŽÁ.d„˜¶\ ¤eãÁį-Q„ozY|ËTR+Èô-a-Ñábd“RÌÈ+² ?.eqA.˜}a‰9 \hkd$îPZ%‘…4ÍÉk.ô9=-*xHK^»¾°qæÀqCY0ø©;»z¿öÚYýמϸa@·®Y‡6°Ð5™íú¸ïy[Ùã²!7oÊLß5mÄËì:—÷xŸWŒ×wèg(UÛ½w¶Á=Úݘ!,]±ï65Aù€"¨> vßÿHüÌÄå´<|EäŠ(õnÇýQw¹±<4Ë1+|vœ®Æ©±qáñá‰1©·DM!}±bm´v·vOì= ÷¸JµÙ!³cq-Ó–[—„<§m‹ÜùQdH^\QÈmŒe Ý£©»n¤[IN‰LJOO‰ÔHRyZ½†ÁRz¿áÅ´žI .F+8$—W°>î`éCÃHKsƤón›3Xh`$CÅHº²3Ü%ã3¦g¬ÉP]?fð gú ¶9mÙ6I wyƒ©¯ûÃW=Ž'«0xÔöüÙLG•÷lÛ³¥(s˜„Y™€eœ¥aÒÕd;JÄ=\SS›lM„«^^Zz^¤Òä¶é·µw½´`³÷]X'6µY}-O¼øâ_lr·8¸Ï¢= OÖîmËæ³Ñìfö¨w‚wÙ+ nw·å^ï¥ËU^Ÿ/¢uâs9bdºø¾“Ém(™rØ÷h-V¯§ÄGÆvë\¯KêQÇç!Fó˜N1ÒFÅÜœöHÚ¢˜Çbׯn{+voœMUí‘jLdºÚ ¢8æ.þ_«¾¨îQm»s?qðø”œ&!Yöwf£ÜwR}ÜbâsÇ¥\Ná)â…ÉÉ ν.žQ¼#Þÿ{¼ŸÅš’±~ƒÞ/Ñ]/¤m¢;Î[tln"¬ú‹²f³[²Äè ͤH6)rd »ï·&4IÓõíÅNÛjwÚ˜sÓ™k‹í™ËrK°úÏÏfŒ5m8$Š}ÅzF ‰%EÅ4SÅ;0 'œÜÃ1øB¦ÿé¤XÏbÂa‘‡íÊëØN)¾Ê—ââsû¦ŒHáƒ3‹…uÂÈKA°qpÏ0ô4xKoÞ¼if¥•hj|žÀZ“çW&&lD¸Ð±±‘¾Ì÷ìªè&Å¥z¿·:4©ó¿ÿëåþO.zó†ÂqÝú²›šŸ’WÔᆎMVþe£å‹‹g¿ä­˜ûð õòbôNÊf œ×­^ª«^¯Ž­½ï‡æD§ç·îŸ“–—2"Ÿ mX {Lõhåv õýænbm™w}í¯ö·ôì]\ïWMm&·¶·k×QîfïÖ1n±¶Ì°Ø‚à\Q¬ø±9E cfµ“%*QŸÀ ¸”,~ŒÕÆÆÓtÔßÖ/ï Xªò¿éá˜pAxƒùm1[Úæ›³„ n¯b”:Ê2*rTô˜zÊàb,ÉM±êBt¡˜1XzDXx”ðý"›Éb,{Íë­Ú>h‹;4·Ë=ƒšqóÈG”U?.ö~ëý^ǧƒŠWðŒg{Ž_½qÛS+ÅOwöCßÛb&ÄÐî^EÁšő£ƒÇ„މ¼?úž˜'ø¶=Ž=Ñ;>Š>¥žÒO…ŠøM kÖ"¢kh×ÈNÑŶ16­Uh^d^´t—rWðLå‘àÙ1ëC×EnÝi™—+è‹¡á¹AMí"&&!×°BöL& db%7²’ù¨éèé/I®(‰X–Hí"`OìÄ‚bã´Äð˜Ø¢‚«>5ü™L˜‚+3ø$4¶ê|f&¨ðf&@õ˜’fÚ–pÓ£VT¿£MPE¹‰÷tÐðžcîŸvK᨞y~ÿ)ïiyöµ¯ù™œ>}nxyÅ q_y¥1™i,u°"]:dNõØ3Ûɽédm¹ÌXn_âX¯¬³ì4vÚ+bu=œuæ×«,=ÖÛ·©Ûbß²ìµ}d9bûMûÕn¯\/Âá É ŽØq BŠ0¥“ÐÖ¤AQ |žÛZTă¢C™øµÂ˜¸\Ö4”DžxW®I“øifC?®gRw0ÌËñ‹&4{Hh¨ø…DÙ-´5ŪQ"kájã„! ãV'È Á‰ºÛœ«ÇĬC¦ñ`!äóbë"~¡1<Ú]?¼m´;!7˜¤ha»„;RܶÊ\¼CÑä0d ˜.A˪³Âì˜.ŒÉ@HÀ¢.Ò£ñ”–6æcAb[ó§‹O ‹2ج>È )‰JƒDõAnËüùÄbÓѺ¾–|áOÀìabÈ]éiÍĘ“”hî¬Â„Nhj¿È¢›ŸÚì=ýðþÁYªV¹¥‡¶˜.ÝÝÿÆü|Æz7^þÔ‹ ?c:Ëô¾å}ùþ9Ù­S¦µo/þ'JÔº°º`ÇLzÂÝù;ö­þkدò[ü;…‡Æ(1/vôëYý_ª.ÕŸ°U‡ùQå˜qØö­ò­úݱN‡¿«¾®ï±)“õÙê ] VÅbã.ká-µØ’¸ñq<.(‘þ ú~ó0`=Œ1ŽQ¡£"ÇDËL68,7ƃ"Âa÷~ÕúõkV¬ÿSrä½U†þ†P<­tç…æó\{nx~½®¼ƒ½Cx×zúx'‹×#¢r‹•bË{ÿ°â(l­ã×ZÖÖû͸`ÿ5ÜBAq¢{²5Âo4µ`‡¨Ç$„þŸ&®56Š* ß33;Ûyµ»ÓÝ™ÝiévfÝî¶v¥³ÔÅÊ^–!mxh²)D¬V|P Š„D¤ˆ†&Ħ{ê=–9Ç‘J÷aä-šžòÔ›}#¾½>¾Gj|¸q.ÈãJÜ„ZS¹¢: rÈ™ž¡~?™çD9M¤€”“öH‚dí×Oëܰ¾_?«£ z€¤€gþ+wÎ ÄDƒÅ9h%·#0`¤\•èÆk$Â4xq1»°´^N#¦ÍÍìJXƉ—ÞUö´¹fØ‹Ü # áLõ'ðÝ»{õŽòýkï¹{SšÚ½:ÿû+ß©þ†>æpWÐÇ ÷9½ ÅxC‡4ãÇõã¡©ŽÉŒä•Bœþ‰6×xɾÿS»éˆÚVíAmR™ÒßtæTÿÊ8M¬N=äìJëã¡CÎó ©/µF,)뵦’½Êñ;‰ŽTŸš·óN>žOøEÙ”ìˆÖ¡:Ž÷'Úõ”º/ôløéν™Ãკ“áÉÌ9ç\\;æË‘™·3Ó]¢iÔŽ»m¹1~0Àèm°“I.I#KܤÅè5ƒrq° r]ÐÓ]mv7W/‹—p¥¢×ã+^Ò”˜‹f÷ͲÿƒIÅãF,äOfëzÙy²XÈ‹"r–Ù%{ ”Í]0jÞLN°l‡K7k*—¶†JieЫÔì/Þªà‡1äÛßÊXËqj_Ϥ3Hþê½3[»:Ó–`öÕ™X¢nG-Ϧ-8Ø­Á2§ä×^q.:—ÑvTM,æÇyÄ ÒËcÆì.ÂbJõl'鲞.±'PãRaRìà îûAØpÇÞl6ðMº‘0,,sÁ 8µÑkRœ×¤8©Ió}®É¸¯I“Øà¼MfÌ£™‚¹Õ¢NÂm²`ЪYÜ¢ócŒPzϵ,3o0ÚY7ëÁ¨ÿX®sÇ1|*(µ/©¤èŦ46‡_>Ô jH-°áj#ôóûJ,^Á[Ƭ؜4<:™w‘qâ¦C¾É‚¯a¤R»¥QÑXúã<Ö— …×UßÝþÜ•ëW.§«‡‡žÈµ·¦à³òÐ_¿¿=ÙM[Ó­=íáPpÊûNùôèKw®X3âmáÖ‘õûvO‘Bˆ°MHZhØ—¶z\?kDÖ4°†Ÿ­}7ƒ½À£ÝZîž@䕆YUÂætÞ’,Ù!ÝÊ%EÅ5] "¾L|JˆD•$É(.Y®Œi±† ƒ¦zs)’é @$‰LŠÅ~Î,Í…ª+DY’8DKÆÉh¤5í*ZLËiT4Ó´rQyy–ËQEà ÒÅ>ærjh“š'ÐŽ[‡‡¨zñL$eB"Ù8_Á U‰z5ÏöÊ„¬Ö¤ÿ‚·¤YV%«_‘ÌŠ&Í6ÀGÕ-ÐñÅrSl |v£wëÇókŒîn®íï+ä_âCÊ` endstream endobj 14 0 obj 19996 endobj 18 0 obj << /Length 19 0 R /Filter [/FlateDecode] /Length1 65788 >> stream xœì½|TE×?~fnß»›lzÏî&٠Б,„Þ[‚”P¥ Ø…(½)‚¢ Òl"K5AE”b ˆ`C±¹¿3swCˆ…çyÞ÷÷ù—ÏÞÍ÷žéåÌ™3gæÞÝ”‚]:wÏ̲gõ›@†chÉà1Ç…?Ñ»7@R€”þƒïžè\•øñy€ÒOäÃÆÝ1æ½ûŠ—̬þ;ï}ß°Þ'­xK¸í·áC99¾ÇXÖ÷ˆFÃ1 <;:ËOCÚð1ïÐðZ/€¼- ‡Œ;xàeó—¡ø˜÷Ž ßb+Åôm0ÐyçÀ1C»d{1^7vÂÄÏÄuVŒ þ£qw ç>ÖqÀ¤XýõŸ_ù¼kþ˜ÛòžhzçoG€õUŠ[z¸ðååBsQTV¬þ²F:£û_Ù¿ã ×ï°ƒŠe‚†é1Gá£ì®4¯è­ìðdž?î·/©Êe+f!xÿ ráYP€‚2{&¾¢¿úaY€.UZ*ec &Þ‡a4\•¨.‹”]âiH7vý­x ðêѱ•¼à4®IVt%ÙJs²É Ä0 ,Ý#í`œkà—QÃ_\Ø6ÖjúWq•W¿GBDÿCª4pƒj «¤W‹Ëì4üÇZò¡ ¡5´¶èküá] +tƒîèꉜC©ÖæÛ¡ï?–¼‚Wð ^Á+x¯à¼‚Wð ^Á+x¯à¼‚Wð ^Á+x¯à¼þ¿tY`²ÿY+ž»QPÐgº…*áb·ÌÝ‘=Ç‹…¿›BdøÝB•p±Š[f;ö.ì’Ñâ®GwzǤÑï‚®Ð:" ¡ Òî‚0FC7 wÀ$t Ä0^¯‰D³5örV2@Øní˱‰MØ#Eh“‰A´˜®R…ÎÂXa’0Y˜#ÌV ‡„+¢Mì,EHIÒ>é;é²,ÈQr‚ì›ÊýeC“42iTÒ[I’Œä)ÉÏ$/Oþ1ùwG”#ÉQàèèèí(vÜîèçxȱűÇñ¡ã¸ã¢ã²£ÂêLqzœõœ œM¹ÎæÎ|gçXççέÎíÎK.ÉáŠq¥¸<®º®N®®þ®i®']kRhŠœšž•ŸâH©•’‘Ò&e`ÊÐTšjOu¹ÁMÝV·ÝéŽu'ºÓÜµÝ Ü¹îÑîR÷4÷,÷<÷"÷*÷+îMîr÷N÷÷{îÃîOÝ_yr=^OKO‰g°g˜g”glí1µï©ó’ë¥yWéÕFWs¯6¿ÚâjþÕW¿½j\t=ïúOׯU¤V\3®±'Ÿà„•¨‹ö¡¯ iBa¢p¿0 9÷¨ðœpDøU »HñÒãÒé’ ²ŽœK–]²W.Qº$rntÒž¤ŠdH.EέLþÉŽX‡ÓÑÆÑÅϹŽRÇ6Ç^Ç1Ç玟Wœà GÎ¥;³œ9•œ‰œ[à\é,ós.ÚÏ¹Ž®î®Û‘s *9†œ‹KIös®$eçœóo8×¥’s Ü+Ýk+9w9÷ r®i%ç†zF"çJjGÎż4ë*¹štµ rÎ{µÕÕ«^½v­ÿõæœsΊRÆ9ãKœ&H·!j1ù¬Á§Ït¥¨víȵw¥UH?¸1hpQ¼Øàüô½ü•ˆ®¨óç÷ž··ž×Ï[Îkç•óòyé¼pžž‡ïØHÁééü>íôï_¬9}Ï÷#ÑýÚ÷9߯ø¾èôœÓœyê¾Óåç~Yûô£çŸ>µæÔâ“‹O®>9àä‹,縉“ãO@_½“Þ“Ù'ÓNž(8‘{"çD£Ù'ê¨u"åD‰ÈäøÇÏÿæø¹ãgX®ã{ï:þúñ×ÐõöñŽo8^p¼åñÇÓŽ§wO>»„¥9ÉžŸƒô:NÇeÊ3ÊRe‰ÙWù[¹¹í3ÛûÖï$³¹K°÷ÂOÈ¥Lß1Mš‡÷ÅÒNLmG4Å2^7s«iˆFju¤ú¢vÕX"Wf±&ðÞî–Š¯‰¥Þ'ZJ«„ÝÏï•!–Õ›{ƒåQ¿oέj«’seH¥»äoÒt² Çû]–fMþÐmú<½ìO‰x¦Át¡?,†¯`< sáYxž;ÌA¶N…Ep ~„ùðÌ"NÀEXkágø .ÃjxÞ½°Á`XCàªÚ}°Á»ð„¯a¼‡á¼Š*øx>‚àCßÂy˜ #QE‚1¨šï„•0ÆÃ8TÑPYO„»áøî…ûá>x‚á5XSpÍ)…‡á;ø¶“Åä)B‰@D"ÁU¸Fž&KÈRò \‡ "…¨`eäY²œ¬ +É*¢ щ•¬&ÏÁø•,¯‰×Å Ñ@"•I”$I–I•4É"éòûòò‡òQù˜ü±ü‰ü©ü™|\>!.Ÿ”Oɧå/ä3ò—òYùœü•üµü Î÷ïäóò÷òùrŒ|L>!Ÿ’ÏÈq=\±+aJ¸¡D*QJ´£Ä*qJ‚’¨$)ÉŠCq*.%EÐ#õ(=T?¥ŸÖ¿ÐÏè_êgõsúWú×ú7Ö_¬W¬¿Z³þnýÃzÕzÍzÝZa5l`#6ª¤*iŠ[ñ(5”šJ-%]ÉÜz´£”*+(S•iÊte†2S™¥ÌVæ(s•yÊ|åQå1eò¸²PY¤<¡< Çà”²>QžRžV– {5Ù³Êre…²RY¥¬VžSž‡Oá38'ácø\yAyQyIY£¼¬¬UÖ)¯(ë•W• ŠOÙ¨lR6+[”­z¬§Çë z¢ž¤'ëÝ©»ô=UOÓݺG¯¡×Š‹Ô–âýj+5_-P ÕÖâDµÚVm§¶W;¨ÕNjgµ‹ÚUí¦vW{¨=Õ^joµH-Vû¨·«}Õ~ju€Z">©×ÒÓõ ½¶^G¯«gêõôoõïôóú÷ú½¾ž¥g«óÕGÕÇÔêãêBu‘ú„ú¤ºX}J}Z]¢.UŸQ—©+l‚M´IL.’KäGr‚üD~&—Éò+ùüNþ ä*¹F®“ Rm- „R*P‘JT¦ U©F-¤Õ©•Úh ¥vFÃi$ui&™¤¡±4ŽÆÓšH“h2u Í6mRŸdÑT’MÓ¨›zh Z“Ö¢é4Co 7Ôë'ôÏõô‹ú%ýGu­Mëк4“Ö£õiͦ hCÚˆ6VßQ÷ÓûéôAúL§ÐRú0}„N¥ÓètõAgªïªï©ÕCêaõˆú¾úú¡ú‘zT=¦~¬~¢~ª~¦WO¨Ÿ«'ÕSêiõ õŒú¥zV=§~¥~­~£~§žW¿W/¨?¨ÕKêêO¶–êÏêeõõŠú«ú›ú»úEgKv)L½ª^“Â¥õºZ!EJQR´£hD£R¬§ š¨Iš¬)šªišEÓ5+ÚX R"ڨɒC³i!Z¨f—œ’KJ‘Rµ0-\‹Ð"µ(-Z‹Ñbµ8-^Kе$-YshNÍ¥¥h©6Ysk­†VS«¥¥kZm)Mrku´ºZ¦VO«¯eiÙZ­¡ÖHk¬5Ñr´¦’Gª¡5ÓrµÛ´æZžæÕZh-µVZ¾V ê?é?k­µ66ŦÚ4›Å¦Û¬Z[­Ö^ë uÔ:iµ.ZW­›Ö]ë¡õÔzi½µ"›Íb µÙµb­v»ÖWë§õ×h%Ú@m6X¢ Õ†iwhõúem¤6J­ÑîÔÆjã´ñÚ]Úm¢6I»›Î§ÒÇèú8]HÑ'è“t±þ }Š>M—Ð¥ôºŒ>K—ÓÚ=úýWý7ýwú½þ¢þ‚þ’¾FY_«¯Ó_‘²õ?èô¢ð°0U˜.Ìf ó…Ç„E“ÂáYܼ ¼,¬Ö „ÂVa»ð/á áma¿p^ÞŽ Ÿ Ÿ _ç„o… ÂEáGú#ý‰þL/Ó_èú+ýMj"åHMõõú«úýª~M¿®Wè†èïôz•^£×i5ˆ@Aé÷‚$Õ”jKͤ\©¹äÅÜ-¥|©Pj#µ“:Iݤ^RÁ!õ—Iä‘ÒÒ]ÒÝB é~i²T*=‚Ò i–4Gš'=*-JO µô´´TZ&dHË¥•ÒóÒéÉ'm‘¶IåÒi—ôîuÞ•Kï u¤¥¥ãÒ)éK¡¾ôµt^º(ý,ý*]• Ü )hчÊar„#œ—ãä$Ü9ѾO‘Ód\SN—kËuåzBC9Kn 7Á=Ss´ý[Êù‚*È…rk¹ÜVn'·—;ÈåNrg¹‹ÜUî&w—{È=å^ro¹H.–û`ÌíúF}s€?‚EЫɹ¯\"‘‡Ë#ô­Vj•­kˆ5Üm·&[S¬kMkºµ¶µžµµ‰5×êµæ[ÛX;X»X{X‹¬}­%Ö!ÖáÖ‘ÖÑúI[¬-Ž|NN’Sä4ù‚œÑ Xˆ…Z‹h‘,²E±¨Íb±è«Åf ±„Zì–0K¸%ÂI¾$gÅ+â¯âoâïââUý~X?¢¿¯ ¨¤ÕéëŸèŸÒoè·ô;z^6Â&:G~›4€­° Þ"ç`3l=ú^xÞ€™B'܉vÃUWýcx›Ì'êû„žB/¡·P$tzX*,†ð ùZ':%uAénq2ìÔqÑÕÝ®‡YY[Xß§sõÏ` \€7áXHòà1Ò‚ÜM' É"r”‘uÍ–dK¶9lN›Ë–bKµ¥ÙÜ6­†­¦­–­­­­½­ƒ-Ý–a«m«c«kË´Õ³Õ·uµu³u·õ°õ´eÙ²m½lmlm]ä‰ò$ùºWß®—ë;ôú¿ô×õ]úný º¾C÷Óô]ú=HÑÃô}Ÿ~@?¤'é)zš~AÏÐ/éYzŽ~E¿FY¿ e»»ÔCê)8§àRPÂKC¤¡(õ¥.RW”ùR‰4çA{©ƒÔ%wô¶´¥÷=é tgÂi¢4 çÄXiœ4^¨!Ôj é87”Ây1gÇLœsq¶L2„Ú8Gêu…L¡žP_Ȳ…(ó—¥_¤+(ÿßK¤Pêí(÷á¬N”údy$Jþ(y´p^øñ=Jy ”óV8oNK_Hgp.ÔÂQgD†T(דëã qã쨃s¢™œ+ß&Õ’j …FÂÏÂeÜåÈ7^nÆ¥þôÆ0F ¢$+ªfÑ­¶P{XxDdTtLl\|BbR²ÃéJIMs{jÔ¬•žQ»NÝÌzõ³²4lÔ¸INÓf¹·5Ïó¶hÙ*¿ °u›¶íÚwèØ©s—®Ýº÷èÙ«wQqŸÛûöë? d ?y*xF<£ žÑÏhþþ”Äâ<£ žÑÏh‚g4Á3šàMðŒ&xF<£ žÑÏh‚g4ÿWÏh’¯ÁäTÂG?†þâˆB´U’à©‘™Ð‡®…„$ðНÀ]˜v-ú[ -gy1}OÄ)D.¢"ÞÖ1Ñù1ív–ËÇÊátôQ0Vêe\ÇúKû`b9ºW‹_Â9Æ ÿyÌ· ·¡Y̳X^ Ocø2ŒŒaË‘¡ºûb¾z~·¦Ì‡8F2†×Âræúû[Cx‰Œ/°/ÅXf;Ä ¬£ ÒBD{L´%b&Ù‡»–}ÆjŒG S±þ™,‘ï§m°œéŸ‡ùÒÐ?ÝñØi(Â…¨I_ ;‘fbÿ{›ýFìƒá¬Ï•}ÂöûÛôg˜ml_Xç¿©4Ç8‡T«Ò¶ê˜Z m…l(E: ‘€èJ±ä×é *ãÓIÄmâ褲c¾è.m¥ÌèÈ1Á¸..ƒ•Âeh‚q÷Ë‹±¸Ó¤õW “~ud7LAùÊÇòF,Ç2¿áò0z`ýu‘f‹ç¸ Í@Ìú.øÄxƒþ‡q\»a]ר¯/`þîˆÖ8.¥ˆÑ¬=X&ã9wÒ«"ÓžÅ4}0<†ûÎd’åaù±,·_Wß °ÓÌG¾žF*"¢XàræÆíÅrâ2" Qq±1 ÑÑQSd¿±yÛ‹·'É&—” iòÛÆeÖìÃr>žæœYå/‹Õã’_Q~¸X™l¾0™Å¶l ”Íæ“™åò=ŠËý¬ŸL¦*)Î=ñ<´fmàse+@Ù¼Ã6³ù°˜ö„YH—¢Oe2ËÚ Œ/LÖ8OpNøin•¾Öãs©ê—õ©àE%Ïc™%ò Ô)+¡8Úà ñä µ ®Tð?˜ÖGÏC7u7dãXvFÿ’jôiå()íÆ~®C~…g‘§ãÅ£4E%¥PJ % ÒŨӰ.z ¦2°ò‘Ž«"G7É\uY Ѐ¼V§LçûeÊTÆùwȳ~\Aü‚rÔe2Ž­ L?óõu4b†)¯Æ•ò¹^@:7 ŸÕätT5ù´V—Ëꔯ-¨ßóÛ1;Ц™Žc:’é9¦gé«Ó*ùçе(ÇL„>þyâG;lãÿÜG=ŒãÝÛ0äBã%y‹±F7ÖÈYèþ!/a¿ï­\S‹Œ ÿzZ+°–šá ÖQ)ÆøõÙó\ßüOðu´oŸ&o€)ÒUwÔ¼½+ýsù‰í%– Ï—Â<ìGœ0ç#†#ú2žð±ˆeë[…'‘Ïl-šS…ãh/°¼ÙÆ×‹<èmßÏÃpMe”…I½aµ|²Äž¨kwÃ6V¬¬=lìÕI`S£PO…úâ˘& ,˜n%ç^ârÁòŽ`¼Pƒ‚2Û Ó°òVñ<^÷óãyÎ žm&ÃŒX¦ݸ=qVH=¡7ΡUJ)¬’{✋‚5XÆ ˜¯'k æ‹çëõ“p;ίY¨›f¡Î.ÿ}Œ«Â:ìϽ¨×B)òhÄJ¥ÈÃQ¼ïù¢©cg²ù#¬“ùIÔÃÌžxæˆP ‚ù6_B=‰õÎŰi8ëáÜù~½ X÷l gyó˜-Ãl6_/DÈ¥ÜÞf§`ý·°Jh³PŽ[¨O"¦Cif4&#ê›àþÉ~Ì3ÁÃì&%.Á±pš ` ¸¡0غ]|Fˆ½ K¨s7 êˆïã\ýžBa€xžË`ó‹PSðaÿ· mÉÂCN?@ÿÓÐGÌÅü³àNqL6¢ì}qŽ5æ“E9IÃü?a¹~/¡Ð çÖ tÿn¼ÂÒñ:¶½Ä6P‡ç«ÞÖªµ™¶Ç^µÃ1Åö2÷MíŶV¶3ÐÆ¿hï'+ó±4â3‹|:p›´¢+ë+égÐJè÷‘5F9òµ°ÚTõ‹ ɃˆºbCx ñ0ºk#}±Áô£íÖŽ#¦cÙo ÝÌö ´%4bÖ#žF¼ˆ« VÏ_…W…”`”ßäߊk ‚\6ʪ§G>7Âú‰·å (‹íä)©Ü ‘B OÆ|ÕüRΧ­&€ñë­ÚôOÀ«^>z«ö10H£ÿ œ¨BŒú׆ÿºmÿ-p|§ úqþþQ¦ A9fœ@Ú‹»0 eþ:èð30N¾ˆ‡W?”`<¯^Ý_}\oå§›a@Uä RBs1Ó#ªûÕýМA~ãÞþ³_|éèéÂRÖ&”ÁöË¡MöƳ<8ç•þè#,-ÏoƒÖ lî2Ð-¸_CTÆ7„†*|mÄø*,5ãã—êãƒí󊇠-RҤݑ¶ Ъs¶ú¼­Ð%•¦Úܨ÷weþÿ 8w ö!öþß®‹Ê*ÂŽO ’‡väQ´On‡©×Q—\ËD¼ˆz¨Ò1 WïŠZºÃ0ì¤Ï\ýÝwaøQ`¥ß®ŒÃ°mþ¼ª¿¼îfþ«ïüq±ÁÌu-b$ºDàz~õs¤o }Ó‡ù¦!}ÓŒ¿>ýw#v¢ÿ<úG#ŠÐ½iÒÚˆD8æ_ÌÀì‘?íCÿ×é_ï?þ]Š6Ë`l§ƒy!}°úâߦñ¼­¾×Œÿ­h•3ƒjÔäî™Î Ý竺÷ù§=N€âxVT…ØÓ¸Ž6¥•ÙÑÌ–eö3·ý”ï߸‹õD(³™ýÊlgf¿"]ÅÏ $ÞžžlŸÏÛå_7ªêVr–#ìˆ?…i~§5ŒC¨{BQ¾Á½Ñó èAô2aƵ+׺]¨wAzýIH ¬iÝú'{‹5íÛÿŸ®‘ÿÅššåÇ€jø»ðšøÑ–¡úZüŸâVk÷½–ÿÍ]uþŸúë|ZsÈbP¼F9Cu»ôOvÀ-ü·²sÿSu»ã?öW³KþêøS|uÙ Ø3ñ_‰jóî?Û[ˆ[oØþ6TŸÇ•óÍïGTêšþ5t5ê ´ÿ$®QÆB ›¬^ƒ,u=d¡+×ÍŠ H‡°8¤+È|v¾m\Gÿ#è·‹yÚ"?†ÜJž«Ë-³Ï¹}ˆ<ãzpk?d"š!ÂccÍöX÷§t'{í±ñ‹xQͼ%mãëÑŠþPÔÅ‘rêm/¼ÄÎã‘ZZP¿w½qÆg\—ïçiÚñ³å‰ÐõüâQvöeìágzªXùs”©¸†:çtèbgCŠ“—eþó¹ù'\{ãz¨±µëíÅŸ Ù9îOð„ C¾ÿ 92p–ÌΧØz%×;?ǨzŽü%ÔûB>"O4ŸSõdç/Â9þ¬f&;w:ÁNÿó-Ÿe-,×öÁruªSøó¦ÅÂ2˜ŠaË”Ga™œÁŸ¯ô ¬«lMü‹³?v–_y¦éïsu›€·¯/t`ç1Uë äS q-ý‰ŸC™ç˜·°mpŸƒb>¯0®üõy§ñžÿÜs¸¿»rͯ~Nߺ “qß8“}é1è/Î@øy\½-º/×ÿÎ Ø&èîÍÏúÌç=ì *¢Ês¸BÎçoùxµec&Ùp‡²ñ7¶‹æó¹–⽘žBœxaž=òçsìlÑ›~Šé—ã½ç Ê ¸ˆ?Ûæ¦5^äùF›ÏÍäîˆÃ?F¼bÎG6¿X8Ÿ›v}©?|$âAÄ3žÅSL÷õ‹fù<îA3ýuœ‡{G«œÕœ2Á÷!Ϊvªÿ]ª¢7žÝ3ù)¼%ý7ÏÐØfïTýÅ3þêtÒá?Úy§pŽ.ļN„°£«SÑ|?e²I¹mÈè ~ú“5fëU§Õß_ù»÷YþÁŽ5çY€ÞüÞK€ö÷SOå{9· Uß“¹A ÃïùwÏîügnñúï˜gr7¨ü§ýSUÊÇ¿Ëì÷vü9?{7çPù×#(7£{Ÿà¯ ãJ Œ¾~;ÿo!?†ùª£:ŒŸ°Í›0žñ㼫ö=U„øxu?süõûuùò³X/B­cBÙo‚Ûÿÿä(8ƒÕpNe¶þ#ÐÊ`P.ú17Ã`ð=ÀÇ_°o_a¿‡W¶9P¿¿Üÿé8þOÇå«ßÿÔöªð¿£ ìÝ=ù/ÛãÃñ³ þ.ÍZˆðCF¾î@¬CðcΕxö®’0åi(_±2ÏŸä`>îMü~ÿû7²Œ–kÎöî (þ+þ(CMùSj˜|âï혶×9ì‡ÍÿŽí0¿îKÓºÀ*ÿ{²¦[pÝeó¼žø »Ùæ3º›ûic5®“¦“&B!}×xNºuÂ%ãi Ú¬kšûýXiÚ~Æÿ{2x-¼\¸·Mf`i°¾ ˆüö6³cï2Qñµ~£]Ý+ü†ý¸ qüýR/ß_wGàž~Ä ç1íö¼I-Øš!4BÛŠ½ss¯ÿ}Yvöp© ò¥‹°¦Êüfï×°÷jü6N{q `é÷òüý}M~¾4 õøqpðw0Ž¿Óƒe°w˜]$àŽBêŒrÑÓv5ÞžFÚÆßwb{{Á: êÃp?|í( ‹îX¤¡ˆbÄ2ÄÝPŸ‡_E9ùÓ#ýï!•po/aØï~Ì3Áâù~{ A›x–g¦;Êó˜ay“×5Dh‰åa:Š;%- !Êï–1~:æÛeîßÙ¹KÏãi´i¤ Ph…rb¶Q.µ0ÊÉ·+öaÿḚ!âXòï˜uÜ2–£ÿ­þ^@à9¹ŸJëa„tÔ‘®£}påà4äJWà)jÊ]p{…ýÐbE3ÛÛ cïów‰‡gßÈE¥½ ­q ½¿ tùó¤'_ø»ô„YoëL‹Œ¿?mÎ5nç*ù0çq!¢ÿ½ïaæó1´Aqî‰æ{ª5Å É´ãØª¹e°ùÐuCåÙ+£ì6&[~[³¯ÐؾÖhÌžUÐ.ì}-ž÷vs_j°óê'ìÌrY•çO‹þŸ~¾E«=‡ú»çE·z7ãVïjüÉÿ>S©þîÆ­Þ帥¿Ú3—[=/CYe6r!®+»äµÆQô¿†xõëó "?5íµÙ‚Žs{"îAÛBšÿL”“&£þJçñ3ýfyº©¥y6o\óÏŸ§²³9f— ±ü{ñþï5°òÛùÏoù÷&*Ïi@O¦k™Nåk{·÷i¨o†0ÝB÷C6½fê r”˜.âç’-±-9ånšî×)-A£ÙØ—E&„Pc?×I!¦ÎË+cú ×_S_% ñ¦þ¢™:ˆžÄ4\F|ÇžÕ°ý4ßS³÷!^ækÓ¦žäºC¢›ÅÜ?…²9Ⱦs+{Éo[®«Fwè­ìBžuþ<NïvƒkI_“÷A-önoå¾ ›¿ý߯´ÁxfƒÜ°óçí|œpŒÌgû¤ú¾€=ÏacØÓ›çfU¡Lðušññk´Ë,¸îvàu ŽãÏ{&—ýídû“8”Ó¹•{¿À^.°×h&.‡ç…;ЪÇÞIâëýÎ*ûÛçø;$ûáþ.3R ;ˆéÚ˜ë_CÞF°_¾xñâ˜yNuýSöÝ!Æ—ÊýÐ öþ@Åvéòk/hjˆ“ËM{E(…»Ø¹8û^ÿîTkq^1=>ºl‡BÍÍžXÇ‘B-8 B­MIŽíB !iS3‡·LHݕڢ®£2ù݉÷±ˆ ˆ]û¿œ„d ·ã} ¢±± q!ã¬Iæ±NÄXÄ Äi#$ ‰›œ{‹BæÃ¥*Tˆ‹!  ƒµÆ@gÄÄcˆ™§c!cS»—xŒWˆÙ´0Û³i.'›GŽÎâÞ¦·o?îÝܻؤ»š4¿­™¬©™¬~3¸nK“Ö¨mÒpwV)£[ÖîÑB4v2>ï„îPBÀ+Ñ ð!(Nl3Ä+„oNód­Ø…*„}­•Àp»²É–ÕÂB zÂÑû^0cè…Í!aY+Z´£g`bB gðóý¦ÐÓŒçxÏC¬@ìBF\DÈô4~Náç$j‘Pú9d"ò+» ýïvz‚½$Çï̇ ôÞíô8vë8ÞCégèúŒ~†MûpS㜬íÜ‘‘éw8Ü~GL‚ßUF?Øô{-”(Ž4JÔ!šC¶²É]ßQ&ÄnÊá(£_nvf8V¶¨‡Ї`?ÉôÖü8]%ˆq]ÇÐu J +>JÞí'=€xq ê!¼ˆ.•Ù„Õ”ÑÛ<--¢é!ºbãé;œ¾G÷rú.}›ÓýH“‘ {7%; …Žñ€yìHíH31^¢olN w-ÂÐbÄaÆ{&"Ñ1ñB¦»hʦ!Žp,d@ËÌA7Á·œ¾«UðŽtx=­Pìæizºð¶Â¹ÂC½žÅKÐËnžG¢‹Ý<Óæ¡‹Ý<÷?Œ.vóŒ¾]ìæ2]ìæé3]ìæéÜ]x+£Ë_K«áhÜyq¶¥÷ —îA.݃\ºDzûÀï"kÛ3›ÒÓ‘cK½µÒ¥å¤t')íFJW“Ò¡¤t2)}˜”æ’Òþ¤4ƒ”&’ÒdRê%¥;HdE)ñn¹É›ã%¥HézR:”zH©›”¦‘R'iì-£®Mm³9)àds 6éÞÖµO(u!G](ó.Ô »ð~apŸ9SÌÄqÉŒ¦lNÏ3ýu›fmц¾…ßÂax N!D ·PŒÞÂBÞÂBñž‡€Ø¸ˆ02¦NÁ†?Æï¡xÏDä! ¦ ."dÞœ‹ cýMÜÀ–éotgæ£oá'?.êò&Ùíö6Âc‰$4™tN6’icˆfÿŽ8‚EÕiQ§‹Â9Å¢B08Ô;¹™+÷ˆþ(;‡¥¶„Œ‰“&L‚Ø‚ùæß¼0hâ$Æpóž1áï.Œ+ðyæO˜ÐÞ—Þ½½/¯kŸ¢Š‚¡%¬K¾¦0]/(3v›u1°) „Ê„,,—…iš?áŸÇ’Ÿ¶b³ ”îØL¼Éd"L(|Éí{PT=ú`_ûö)*G[Š-бƒH™(ÃßìŒ 0ýÀúÀÄI~—ŸýỔY&XRy1feTrlbFFÃR9îÊ!^z mzÛïìÜñF+Fß°xFqÿPæÀXOFÀzØo’KÀ~µk;lfåÃ2xž€™¸¬õÁÙÐ ?†?AâŒ- «pa[1mo˜ åMboa L>Ä\ÓÁ)кÀX˜O:“ /œ§BcèwÂ8Rj çqÿ³]xǸ:ÄÃ`ü4~>1N@Ìñ$,Sd¡¶¼XK)¦|î‚¥B?‘w` \p¶A„Žpì¦XúPøšÄ’…VXÊs†Ï؃©¡ ‡¥PN’ÖÔ%õ5:!ë¸K]›`~Êà_ð±J—ŒçKµ¡-ög "»…ŠëWä±C2äR-ÈÁ˜±ð:ìƒ#$•¼AÇJV)KòJ÷A$Ô‡žØÚ—0çWäW:™ý‚’°W,4ZBòåqÆmx¾ ñ$“t&½h-:–.îk¬Ÿ!0ùý4–~ÅhµÒÃÂsâ:ñªœTqÚÁñÀ3ð,¼AlØS'™@!ÇÈ—´@Ÿ¡g„'Ä—Å”Øëþ0æÃ:ø•„“&¤+¹ '’™äq²„$GÈ7´íAGÑ‹Âpa¼ð/±%~º‹Ä©Ò i®üMEQÅžŠ÷+~5²ŒÐåáalý“°{¶çø9gˆDt‚ö‹n=Éø™Læ“Õü÷å¶`-GÈò-.I¿«WZ*ÓöKUøI¥w¡…ù]Fóß?ùžþ.Ä)B†ÐPÈŠ…±Øª™Âül¾ãÅâ|Î’K+¤5Ò:éMé’lUÁ5þ½kÏ]O¿~²*fU,®ØT±Åø¢p qõÀ W.¶~ ~Fâx/F‰Û+ò.ž¤“æ¤rfIÆ“{‘“ÓÈRòoû«d'récrÛl£‰¼ÍuiCÚ’vÆO:”ŽGcl!ÝBÑ?EÐ…P!JHZ ý„¡ÂDá>a±àÞ>ÎW„kø1D‹èSD˜!¶ˆ“Äåâ×â×R_é]éœl‘ÇÈ3ä2ùG´jš+]”®J?å1e›ò‘ZÂ~¶ÂkUÆœ „­ð(Íãp såy :R”Tº†Ì¢‘-4MºWnF›‘NpIô ¯÷Òô m&t$íIwÉ~í‚]r¤¸I®ø\wbßaÉ÷ÊV2™^”­°‰˜çÅo õÄ á]øL8Eq-$†\ / ]P þ%6—ŠÀ%,ƒW…ñä!ØJ ,WÕy(ÇÈZÔ =HùM0Ð î„RÔXø¦Â(ú \Ày< ž"CÄ;àQÈ&Â×ð"ΊZÒrºEöÓâA¶_fg×$R$L#ý„¥òEú)L‚âN ¯`ëÓW…Žâ%©Ž3à!˜ã‡á>©Hü€Üénñ4j·…,Ñ…t j•¾¨Ó¶áì.G=ÐBèˆ!±(9P.z¢†XŠŸ§QOˆ(A#pŽ÷F-v¶È=hÜ!…Ô:â»Ý ñ",1î€;…PõÁLãA,q œƒÇ` ™^ñŒÃ­ä§8·;H…ô°ThÔ¡sè§´;]|óø"·Ý$¾ÃÏ«èi.í€9âÇÐòŒyÆQ”a—À 4XÏb/ÀÚ»!»¢Ýh ã°¿§ «ñ’á nŒ†Î°^P$¨dàûÈØß`(ífL†VŒ@><†\ð"·&¡þ™ímÕ³G o^óÛr›5ÍiÒ¸aƒì¬úõ2ëÖ©‘^«f ;-5Ååt$'%&ÄÇÅÆDGEF„‡ÙCClVÝ¢©Š,‰%P» µ°Äéó”øDOj›6u˜?u  ¬PâsbPáÍi|ΞÌysJ/¦V-¥×Lé­LIìÎ\È­SÛYêôÌOu–‘>]‹Ð=??µØé»Àݹ{wÛÐíragAìð|§”8 |…wŸSP’ÅmÔ-­R[ µÔ© -::utùbRÇm$1Í wИ‚¦)¨6l”/>5¿À—šÏZà܇øºt-*ÈOp¹ŠëÔö‘VƒSù€YJ< ´âÕøäV>…WãÁzskïž3¯ÌƒJ2¬CR‡ ì[ä³:Â2°Þ|_Ìýgcox±p4¼fVMæÄŽp2ïœ93¾•]‹ªÆºØ½¸ËÀ¼Ô]X2§«ž‡LlÏŒh^\ä#Ó±J'ë ë•Ù?ÓÔt—Œtú´Ô–©ÃçŒ,Á¡‰Ÿãƒn÷¹6ÅÇ{·§!¾À9§GQªË——Z<0?qc$Ìévßæ8¯3îæ˜:µ7ÚÃLÆn õ;¬¶ªŽ¡•qÜÅ“3Wûn•œ%¬E©mQ |ÎÁNlIQ*ö© » ms7ÁdxÌå‚#2§µ*™coÊÂY~Ÿä¶§:çü(©¾¿9d ?DvÛædrR)jpû22|ééLD”V8¦ØÆæÜß°Ní»Ëhjê8;îŸû  òv`qÓLd¿ËÅxn™¡ÇWÚµÈô;aPÂ&ðf¢MKXÌî@LTOSˆ©Ì^’Š’¼…Ó5ʧz*ÿBíÑÛúHô?D5ãÛwOm¦±³`N‰Ÿ·í{Üä3ã›TÆù]¾ˆVEBõ»h‚ÀcM 9=EVŸèÆ?™ õ2EE©ä!ÄYè³—´1ïÅ—ëßÌTf\b¹8¹‘ÍßL_ÓŒ›ýÍnòßÔ<ëŒK%ZösæXnŠCQ3+lë'(ñ¸Ñw9[ù 'ÎL7þáN¢ Cq‚Ï‹,kÅ ü™A~ïM üîb¼˜tÖ©]ˆŠnΜÂTgᜒ9ËŒÒA©N{êœíôMúæœq%Á)3Êç&ø çáÖªd8iŠ“‚BË©dV×^2«{Ÿ¢ívç¬E›(¡­JZoLø¢íN/¥,”2“y =ÁNn¢*OŸ°Ý PÊcEÀýƒËð05F`p5Ãì0Ša¢æåaìb:¦U¢ªÒçdqõü‹^úÿ†Ý |c¾òß@ŒÌ,ÜÀž°õ1âýéŸv@ø6Q%ÿ=bqí?”à@î»Ú¤”›H[à)¹µÐŠËx Ægn2Qï=€†!î5Ñ䌉fµnû-ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚"ˆ ‚ø(á?d ±…ª¸Â\an¼ášSØ}Í+ÁUpŠ»ÙOâ”óÿ­rSº½±4,4wŒ…)°Ä•¿R\õtl†ýJ¿~ ïBýzÙ ³£Ê<Èòž W¥Ý`ϼù«ÕÚ²'ð»%D×ÑÍïÕfC7¿ ^[XƒQâú]¢Š¯ˆDY¢‚&+%,PfìöZ\© êa¿>WfœÞb·ÓžèøÎŠ®D«ï!6½ä •{‚Ýjew› ïñVÉk m ±²BXYqJ^‰Jqz9É%Ó!6£“ýl¿ñØ)ÿïm '·ãõ\ÈË‹É!a9õë‘~Ð/ƒ˜‘®Ô0YV6jÔ8›^ÝÒâÃOÉœ(>ÐüAÇ«­ ÀVæˆ r!™ÆnÅøf ã€Zfü¶…u_)Ãæà!Œ ry3sl”ÙWå¼Z˜Ý!÷´aÄ–°0îøÁ«ÙíèJŽ”’±o KœÌb“C0&ÙÊz›\Fwx­ÔãtØÃ(u:ÂÂs2?:Èî!óë@»ïɪ_/a#­¬ÐNy…^-4Œê9íÕÃ#hÏäHÆÊÞ„E› =Ññ½—sþ¯jËÈ0ëcµñʼšIÍäÒ.y‡²OÝŸ¨´µ[{„Œ² ¹?üþˆÙá;ÃÏÅŸK¸oÝ¥¿Aì‰ö${²]~ݸ„\< *R G8>ÙbWeù@b|dbb¼š/ªÆ' ¶d{}~sç0VFb·²kòfB­ÆI.ˆeÆOœûèøÍkg\·Lˆù…׋¢AvЇÁ vÒÄk ÛšGбt i9Mylã\.ø—/  äÚ/36B^îõܼ ×û g²‚·™!u3B²ïAJ4Á‹°ô#ýîòÿ‘;ÊåiŒÔ¨QÞÔY©Ñ¨QvVtT$Jþ‰ÊµÆ4ÆýÜÒ‹k–<ðÈ2²=â·÷?¼Òæ¥7W÷M^¿¾EîàÝ“÷œ6jѲ9‡?ýn}ÑÚÏÏÈþå9ô2¾£Qö2È–mB,ë±Tæ—@æ0ÅÌu=.ÖË/6›VôZ©[¨54Ùb©•œ(&×J”jÙRmÖØ8áN;›mNÅÃËÄäžÌŒƒì} <'/Ï~Á~ÿÂ^ûÞðûžŒ,6ø5%[´­À6Ã&„õ»;Aè=Ú>2rHô$Û}‘3ls"g'¼`³HN nµ…ˆ Áz Sö}Ó„ý‹4ÄÎD‰±åôyˆ£Ã½¶RÂfÚÂCâp6Ä‘¬Çá8Ç:©3–Mg©Hª’*•I• & õ<\÷Ù¶þlû9D­¢M t‹&‰"  *+ŠݪlUpe=å«S±FbŧhÄ\Z²$©É² —Ñq^ Të·^J(-':¢{íNªݺˆ‡ÅS¢°@$b!^½‹u·rÊ*,°+óÛC•à ¢”*TYzìc¬ËýÆÇ!ð/§X|œýˆÍË¿w6×~ÿfJu32Pí̬Ë)S?9a993í{ö„ìÙ3S2)J\{ŸÞ½½/¹kŸ¢-b¨ *å¨XÁøé¨br×ø~ÿôëh©$›¤ .!Â%xjÈŠ@³ß§EŸ¯»þ̪OÉK S³¥ò? ÉΊ|Ú‡,Þ~Ïü¹ÌæXŒ+â·(_aédúvq¤jéºÜS S{¥K MÓäñ“¤qÚ}ª4U—kDkBlôäè$- Á´ÀÒÉÞ6]5-"<9=½V-HLJFN;pI5¶Ì¨à9bW¼6+æˆõÈVfCÈeÆW^7³!äp¦e™£¬²VÉ\räH&Urw 4w 47+-‚•æöXYiV +ÃÊ$°+Á_ÛÃ2%s£'ÙÂR';¹ãôÛ0W¶p†9üöË[¸€™Ù´h,ÜŠé—Ѭol¥…Ò/÷:Þs;qGSј×E ê&×~=—-Æa9Lé˜:‡Y3Ùa®* %„¦W–¹yRÑ6ÌjÜœšîÅÔ³æÝ Ãî˜þXïÒ7æU,"·=ܤ]ûÂG–W'cú{ZõiÚãÉyë¥òâíCû¿˜]cgéKê Ý¢‡ul;¶ÖՕеɍÂn÷ñõi˜ñµt·ô!ÊÁÅ­ƒéÈ$JÌ1å}ýÆ;€¹œe ã`bR)LKZK¥u ¶íÂÛ>Û8›ôsRXHxRXR’.× KOt:ZÛzEöŽê7\•ô@øÜð¥Â’¥‰kÈótMØÑˆ„x{¤=^D qrS;ÜÔ̱‡"’­BB²¨Ù=¡íÀã$„Ä;bøÐÅð¡‹áCãqªÕ:U+k¥—<¸/3‘óýøàh ãò®ìÃ8£1ªßxdv¹‹ÄÈbjJ25<-;KŒQ8¿B!‰ÄyÃÒJ5çC˜=9Ô˜€Ç$8†IpŠ¿cqpK@ã‚©Y˜Tj±<„ 4W©ñŽ$;ç‡ÝÂ&žÛõö[  ôoNþ ö{ûÝ$Åõ뵺ÏÛHHPTY•TQ叨øX*ëœuAŽŠŽŒŽˆä!ÆEÂCð«&ºH´%ÌÌjOÇëaÒI|LtLtxT$Eyw»²üX ”òåä÷u}&OœÐéþÇN¯ØHr¡~AǧFwZ_ñžT•ÔaPÅá=/UT¼<0k}£úß¾øÕ¯é엯נn›Ž¼×`µ÷6YJVÕÇ¢( ˆŒÿ *ËÐðÐ)×Eš Wa\ª´[òÏ«sZýS¤âOzÁÒ, …~Fv ¨†~ÏâÆTý˜ÀÍZ˜+ÊűFøüÚ9ê»ÞE*__ÑtýuöÃ0gçvœnÒÉŸ™EKjþj ÒÒÀCݸ«áÓ'еƒ9&9Dp%Ë!žî´€œ¥ä,É™u5Í)ȉ%TÀix–÷”¯á¬§èøŒK _óYÙô®Ò¤FgYgYgY’Çi!>-|›g‰ó ¾ý¦‰ØÑÞvÎ fwñYÉö%Èô›X3ÑQºòÅÔ„ÄøÄ¸DA¶zìî(ãºEOª;Ö–ä‚èÐ&ŽŒp*èK‘Ü.’¨£˜E†á-Ys¹ MÀÿ±G7{®=·rÁd‚‡æ]CwØMÓ?:F©Kqþ£¹@D Ð8Lè@ÇÎèøŽ«}ž˜I²Â„= ¨_šD’Bùȇò‘å…‡zØ\QMc‘€Ìg…̧D\âà! ûUîè;VšálýCŒŠ9®,‘©>4ía (*fLf‘Fï’Âu[*¶í:\Q¾æ’ôñq’pß·ªø˜ cȳoV¼pâTÅÊ­ï>¯WüZq˜4 ›‰¾¨âœ©“Åë¨l —¼ÉCÃFEÒööö‘·ÛoukrhHÄÄš:"<ÀÒ›ö.ÛøÖÅ£2î†1·Ê ÕΗ6Qê°ž«ñÎx‚ñ±6Î2g™³ÌöŸê—?ÛqUÕô Ãc¼ÉZ?[ÆÓ1LÞ¹ªMÆÅº\aè®Ô²´ÖÂŽ£ÿP±¿by`çò~êO«˜-•‡„Ý6fGÅõë¯dÞ”¾S£lL†WẆ†r0…6õºÂõÞ(±c˜:Æ 6k Êï ¿£²ÙÍ¥ËfnðLƒŒ;ô€{fsx|¤—6§ÔhÆüI5Øý4ÔO1þ“ÍI3ÓÛý”Å{Û¢ÃÒ.±³»Þ7qLâ]Ú½!÷…N·Ì }ÊörhYè7!_‡Úq¯â µjá Ôm‘ÃÙY‹«iÑ1ñqÉ1¬Åþõu*„˜p¥p±ˆ Q“²‘d&·'=!Ëd6ɸV™m¡pkVæl?gÚ¸´Ò4!-%–KH,—X.!±ÿ®„È~ ùóBžÚlÍ_­@þÉw6Ö¿š3½è”ŒŒëèÉÉäg&摉„{&<7m7˜Jíתo‘×¢zCsBíMÛbP1Ïž7Ä8éË K‰Ë G„xsì)‘"*Ç_HqS×ÿˆT¡.EaLå‚É7Ø®UtΞ÷î?ðaÇš=;—ßìygï:®ö_UÓwz깊zRyçwî[v,ÉÖiRÅxRÚ¼&ºr}’Ýø¾ÖÃg0Img|#&ŠÍ¡&4¦k¼µ5›–g‹O¯eKOϱ5ŠjœÐ4½mz?[¿ô‘¶é%õæØfÔZýLü˶¨š¸3€ã˜ëŸµ5·Åí¨¹'îpÍ¢>¯©æG“d6ßÃëÃÃoln²¡îÌ\ŽGlFíô9bNí¶b›Ú½ÔâŒaꈌ»­3­û­¿Û~ÏkÜ „ˆöÌ´1Y®ÈصÆÖ¢µ3CòB Yb„H+B6„\ B*·ï!V& !LU3ñaMp±SÈ~Ö"³³ÖSM!ü¬)$$Qˆ)£k½¶ØÚ\ÄžŒLLT ²éPPÃ’•(èµÚrãºG­|‚ÆòÉieí—¹æ•CøDåöŒ\¿I¥ºeâ?žoïðfï7>ã ·ŽS-ƒkãŒsçØÂv6#ïÂõŒ³æÙkeÞñ¦­8n>¿ÛäÃx·,§¦x6`‘ìÓ°A ó°©9e‡M1ÑQQ‘Ñ1©AVBP—³} &r‡l¹agë mŽúì’]0kÊ}I¾Ø;Ìžµ¶‹]‹IÙ™3hÏØ¾YcF _íIšÚ³pÝôNwŠ ±Å§¹-wÖ¹­x|ìø¹í½ÛÕ½÷ÒÕé·5!Ÿ×L´×ì˜Ù¦äöηÝÃfÓ œMÔûvÜÏì÷>@$khšÔP*¤<‡ÏAŽ”ÄìÄ–‰ã rÓˆÜèÜøÑâû©ýlE¡ý¢ûÇTGÛ†‡Þ}günǧÖÏb>‹;ñ}Ì÷q_&vŽ8§”šYOÊ õJB»Häϒ~ÿ°[íQ!¢L!!QVˆ%*1D œÑÇŽ Ù‰‚×Í…;íˆNìºW/ÑKuÑÜAé|Æè|ï¤3÷¯=—¸ˆòEˆÉ¦Îd°±f!Þîlìõ‰äÿÔq-ðQTçþœ™Ù™×Îcg³»Én6»IÌ"d$MÍ€ (ò4˜­ÔŠ–•D@¬€Ð¢ñAíõÙZ@©ÖÖ[^áÙzÉíE~­Ê…^¥½¥Eì5X«¥r½)·Š›Üs¾ÙÅk!9ûÍììÎÌùþç{ü¿ob0ôLÀÅhD&,Ö`žÊd 5²:Ö- d¦ãx3ÞŽÏb.‰ÛðtÌbê4èºÁtMUP„c€›z ‡é-Rláazy8 Á=ÐØ®œ4¦Ü¼¬ºÝÈöõd/E+…#ùÊbŽ\ݨ«ªÚh4F76¸@GÕéZÖŠ\d8ñå/övï¸y[—3øñ+?_Ääç<ºâå._ñ²ï@ñoLäµ;?üͳø‰ƒs:òú±ÃPoš1ô>{†XÝþŸý(Bb–4°‡0ƒ"ŒŒº;§0–Øï|à k2vÐ ´±ˆ3²Mp2„?0&LP \Õé„ °°Ž¼uâHýP¡þRv{’¨àdâÊà•‘ÙÁÙ‘ùÁù‘ï1ßcŸQ·ê[cŠ_µ¥Nf!Ûé[®,Uת/(»Å=ÒnE +÷)ï2l }“v»vÆj˜ÚΚ‘ˆ^Ô|rYÑfô:KrKM“ÑÅkLK÷©Q@V´LÀv9‡ZÙ€gUÿê¬,eä\c„1v¹ñs°C„àTG3ë"€ÃdA @pu"p ôB`ïB™£N m# ’—èÇðNtîÆÃÜ‘qT<èBéä¢+t—þ4$¥ûƶ“w»(‹Õí%lFó½ÐO~(’º”ÚK…8¡ö‹ì&åÆK„Šk¦ØÖýôÄàÿvÿùþCr›}ϼû¼u}çÃøÞÈÞ£¸K/cfݶ-ñE‹ÿíÍßüâ[Äæ\E°tÊå(ñAg•ÄpjVÍ«T_“Õ”¸ž¹NšeÍNÜÆÜâ[ ~ÍšŸèK¾å;Š|hŸÛN&s1j¦Ä¨u"I^FnašÔ)ÌDõ*ëêÄõÒ\õ6õ4ÿ§ð§x  ãuØY01:ì%Fçï{Áè4R}~¼´˜54ï€KAP Èêú1ë†cÌ7ÖÄ.QäºÖÉ0©I0ÀS;eðçX+ƒ~ƒLõh¨ š²QU½Ng>,¤e& Áýš€3#è m¨©Ž §„!£ø˜.°B%¬ð{B¥»®3H1ÀŒ]™ŸQfihEÒ‹ Æv¶ê b®µß54­ô÷¢©é*KÓDñl.2ˆÙÁÖESÃŽ]pèžãË;ßúöü'Fì*¦^^¾â‡?º{å–û~°áüó›0ûàÌqLàÓ«ó×þõð‰7Q4…x¤JbiB?p"I”1sØ‚¯ Α°‹|·‹ dˆ%¥©êwfQ©"AÇZów¾O­s1n”ÙbJŒ3§ÆÆ%fšö¬ÄWÍ%±¯&Vò+Cç˜sQ…±¦F"3ÂóÃKÃl8¡mÔ7댮sñ„$ Ìé*ñ,{ŸªÒÉ‚~¿]Åj,I¶vekòôu/ ƒ’8¦¾¡ƒ~Q¸Ñ5¦%.p g'SŸ÷tí®zפÊôž½»¶"ƒö‰Þ/õ0…dýdÁÀ¹®²DóL‘D.ý`H*ÚÕ UÓã´idÓí™7›·„*(©áªnدö×ýü[8Žø³÷¥÷~mCñ3S;÷U/ṑç{q’øP× ¾=ø‰žÚvàëøñû®üú Ôç ÖúÞD|™Si‰X³GØ#mÇ^jOù¾ú’ê©uêv»Ïæl:­N,™¯ð«¬¢%$brVcy$m²°5„9 :\‰h†ÉŒ(nˆÉ!–y Óuß·kÔØ<´BäÉüF„m‡®^ÛQÉêEdnu¶¥ézFÃJ™ÛÇ¥ÌÍ*en€›'Â{„ÐÜn/DåÏGíŸã¨ ÊærçÊÍäH²«îLîLfû­Põn6\öÌÒ ^x?‰{u’è"ƒ×â8‡sõëÖáYÝFuScS~ -b;MÍt¨1TmìÜ´)ûöŠk;âcfM8z”}fC×¢üU×›ÏJWÍ¿yÃg·’ùî¡Í—Øe ?¾…Éd„"y(CÈœåšØ‰ì•ƒ]¡ˆø ŰXFZÂ'X²¤xÖRñV”iêé4+YÑiqŸˆÃ`*Ãàu0ZtBEš{@‡C&Æèq"ÍÂÁ`ŠWZ#¥ :lŸÛÌù´0ÕÝeùÑùíá³afixsx{x(Ì… 4nÆ-À€•;:¹ª³ô/v§Ð1p@Í”rôOèÙ ýôbçñ7n‡P,ã´Ð¤Ñr—Û•+±íD* ër^ÑM%&µ—øÑ²^‰cÕOt‹(͹åhOL£Ô‘üÚ¨6À¾ò!£§wMߊŸNé]¾hÆwZI÷ñc…­ß/ÞÄlé¹{öë‹?#õ~²˜È[´# ¿èØ ”‚Y©¬,,•ŠÅŸyi¢+ø<ƒØêÊ2DÄ0ò0 0’½ ¨è°‹^»èTP‰›…‘‡Q€Î Ñ·'ø<ÎÜõÇÑtú§‹ÅÍâv±O<%ž$&Å¥âZqSi×;â(%Ey ÊõFö:ßuÒÊbvo´X‘" N0ˆ¡²<ÄX^viÑÐ&¡J&™d #\hà ‡,±$ÝB©´wBÎRù’¼d²ù‘F‚.¤HÚ@Q­¨SÄZÑ#–ÐôƒÈ€K@q9f@s)òBï’%`”ìXK|8ätÔ01RTjO†ØbTŒ¦ à — $ …s¹BáR|xuDškÒê„8Û7[¼Ùw³ÈáB;”ƒúD:I.,Ë>'l}àÕßãðÝ>tjðÌþ=÷íÜuoÏN&ˆk^1øÇâ‘¿…+±úÆëoüúÕ×_#Û3¸«"¨0Q%~ÂY¦è—ë_Ö§è\[j{ŠI¦.Sª+B ã+–¦6¦ü-‘–ø5‘kâíþ•ŽHG¼Ó¿HY¨/‰,Š÷¥Þ´NFOÆÞ¬ì·ú+ßI ¥ÂÕ\NÏ…š¸ý*î}ž~Zþ°bP—I<)ʇl¶›"IgÑΓ°.9Ò|i­Ä¥)€ˆDû«d )ZÚv›A$šRI*Ql7A-62%zÁ%\’!‹Ð󜽩—Ñ›ú%ôæ¹ÏÓ›P:!èÍä¤1Q| ¿yÞÌ ôÿf¨M£¹œØ zþ ²Ê<Ôl™Æ{¶¶<öõûu.?u÷¼G†/¬Xù“—ݱcp¡ï•gÎÜ0ôÔóƒçº¶¥xžÝzäÐëÇ_í·4¢º—˜„ÃDïzÛ™:"ˆuWsyîJn6w+·ŒãEÃ/úE5hˆ*býX…!I¬ÛèÇþt*ˆƒLÚ€4`6 ˜Gãç÷LîߣÌäò°¨.ñÓnŠá–ÝýnŠaN:ôE)F¿^è¦](tÊh7"DšHÿUO`õ!:Ý´-Ç=71ˆ½¼÷¹+¶Ýø•+ÆÿÒW¬J®fK×ä–k'µÍï.¾E®¹mè}v™™‘,ñnêì;6ŒuJk=¡Æ²žñ„jOH{B•'¤è­Þ¹BÚJ·ˆ×ˆ2sÓ Ò«Ä‡Åõ™‚?ö V#±hdä”a¿‰øâ̆ѰíðwˆR‡Ü¡t¨þN±Sê”;•Nµ·¦·V«­ÉÔf.™'µË·ÔÜR·¬zYfmæ»Ò÷•ÇêžöøÈ­ÒKÊóµ[ëvÕ¼Z®ó"Í´'T{BÆJ÷Ë{·À{7Å{·ÉÓPúmǬlžç¯Í*KÕ„8yxEŒòÍi{P„v›=ݾÉÞfµyÍNÚ·Û§l.i?b3ö+!‚G`Ÿ‹®c3:>†„u =A»¬pX)=`ä1ÞQ±¸‚©H„έÑAöòž—¡¼ç)Œ¸Äp9ñŒí£ùúñ&`7¢îHWµ¦H´Sô“vŠ~ʆJ™ ü}—èþs#†>Þ©c¦ž|ÑîDó±z\OÏI?_ïÊëÝ~Rž ÀÖÓêý–ú\AUm}~~C_ÓÖ°¶i [EÝðžr'ŸÀZ’ôÚR€ÂTF+¤Áµk)z°FC–z Z€ž_öSƒ–g-} a53ÈUâà ]SËÛ:‰±Îéžæ•s¹.ÊŠ•¼g(gž£\tA'²‹ðr¡å)âÆ3Níå•Õ>kX¡›zPgù´šŠ#±Nˆcßåd¨´ÈfU :ŽÒÕªâ¿LŠãºZQâs\%õ ù¸N0@¨\Ÿ[·n*3£4—,\ÜqIƒ{mMíp¦)?zŒk8/°÷´A:G 6Ù¶S{àîU+›²ß=üôôqcë½ú•yÆv厅«:ÃáñõŸœ»ððꣿÃ_N,ê^0áËÕÑlÃÕë¦Mº«.™›|÷mÑY³ÆT'*‚R¦qܪŽy›®™ÚÖÌÐÇL½ïiÁÉýH)¥‰²—/ú=AðÞ$ óêš¼HQ2›km’Õ+ª„YÖÅœ&ŸÉÊšžFi¬^âÆ$×)xHðO'Ζ k…‡Hð³YØ.ô Ç¥JSVxDÊQnD_J=TŸöhXE]-‘øRtå¦Eñè·–g¢âØÎ”8 þV`Ñ‹­Ô©ú¯ÊÚ0²—I§ž1Æ ¤E5Èè±k[o^Ç ç}dròÞÃaä~è­#=9Õ²„ÀŽÐ¹ û ®¡³{ŸO‘iOÀÉ™ò{$w$‡F´µA½$¿?+J–(JˆeX“ ‘H,á÷3 æIdöP°’ö;Ž#®qŽïv|k}ŒHŽ˜bœ–?øг31»X(bÑ3ý—žo¾Ðýc4ÓçzVÃc 䥥~„‹ÿP¡ýBî]…ƒ$ÏlÄø§ƒ‹ÿ¥?›Œæþ²ð\Mqým·_·‚¹ße 4‚´ÿ&HÓ¼©ÒÜ2…HÉp—`„íŽB–yŽy†WÉíjàr´4È#óüh&ÖÒv3Oñ3Ãnž§=Á=á:ðŒÖçëãû„×5QsÂÍ16(†Ô˜Þ„[äuøaÙ?¼žkÚåO⧤§ä½Ì>å—òk7ôìqñ×êïõÓ’i–t*+È4´¨J–2íærTÒxĨH’ž¦¢´eµ9çuqçVžg¿(bž}K ަ“„kšªË‰Œ*³Š.ñ£IúatXdô,-„D–Q«XÍ*¬¥(¬$Š,Ëðħ) ’¦›Ø¼Z]£¤%í«¼¸Æ‘ˆf÷:ü ~-<Ïr¥H±k˜ôt2ÙW«•ž…e]ë§õ3ï.hšŽT×…’² «õCˆ^¾¦õøõôCîH^„€ÞÚêo%XÀ$›ê D+še:ßrE³’Ž4³ä—nï¬jÖáÐP3NW5‹NÂëðʵCþMæ§Ï׬4F(jÆ©š­Å^?øôŸž–ÝõÛÁGñC'O´ þ™©ÃƒŸL9¾ñü Rüw|Mû`"©jp&ûW‚¤³ˆxô¨KÑ»Õo`-`Ô¸I8àŒp“S aTÜ#ÜtFFEñÈGŒJ9+$Kce6ak&/óAÇÔR²£¤J ´Gäb'cÑ#1[§/Qƒ+ïÒ´àmgI¢¹Îš«m“XGuˆæSu#ó:E4ÃjÔ¬•k•Zu´2Zm hl07°ž’~$ÿ\ÿ™qÀú@ú“õ7µ¨b %*=膃r"Îi´õ«Ù.ßøÍæB °c4MÑ Ó$&ƶ‚Á¬)YdCS4CÉÊ (¥ mk“yú(¡'˜‰ƒ &±iÛ­‘¹p¬}ÌuŽÜf:&s“yÐdÌ}xü §ÑĸDß‚ÙrRÊHeºÂÎP†F!GìA%˜¶ÞxjqdòŠô *‚VúUTè·é“¿gbQý H(J]¡]?}œÊG°(a·€zhÊöÀì)Û£3çÝð3=¼ä¡÷ñرí%üîGÖÐÛ{Æ4Ké1Ͳœw‡šR3b;åš1v%œ–™¼\°Öí¯"ÿ/š<ú4huúëKÃZ'GŒŸ<¸ä'sédîÝÞÁÅã2#WÍÍÞö’^—‰/Ò*¸ºâÓË×­ZÁ,:ÿËmãÛg£ÿöJþã endstream endobj 19 0 obj 24851 endobj 3 0 obj << /Type /Pages /Kids [6 0 R] /Count 1 /Resources 4 0 R >> endobj 4 0 obj << /Font <> >> endobj 5 0 obj << /CVPage2 [6 0 R /XYZ null 793 null] /CVPage2:0 [6 0 R /XYZ null 792 null] /CVPage2:1 [6 0 R /XYZ null 264 null] >> endobj 10 0 obj << /Type /Font /Subtype /TrueType /BaseFont /QWMWFL+Arial,Bold /Name /Rx05 /FirstChar 32 /LastChar 255 /Widths 11 0 R /Encoding /WinAnsiEncoding /FontDescriptor 12 0 R >> endobj 11 0 obj [278 333 474 556 556 889 722 238 333 333 389 584 278 333 278 278 556 556 556 556 556 556 556 556 556 556 333 333 584 584 584 611 975 722 722 722 722 667 611 778 722 278 556 722 611 833 722 778 667 778 722 667 611 722 667 944 667 667 611 333 278 333 584 556 333 556 611 556 611 556 333 611 611 278 278 556 278 889 611 611 611 611 389 556 333 611 556 778 556 556 500 389 280 389 584 750 556 750 278 556 500 1000 556 556 333 1000 667 333 1000 750 611 750 750 278 278 500 500 350 556 1000 333 1000 556 333 944 750 500 667 278 333 556 556 556 556 280 556 333 737 370 556 584 333 737 552 400 549 333 333 333 576 556 333 333 333 365 556 834 834 834 611 722 722 722 722 722 722 1000 722 667 667 667 667 278 278 278 278 722 722 778 778 778 778 778 584 778 722 722 722 722 667 667 611 556 556 556 556 556 556 889 556 556 556 556 556 278 278 278 278 611 611 611 611 611 611 611 549 611 611 611 611 611 556 611 556] endobj 12 0 obj << /Type /FontDescriptor /FontName /QWMWFL+Arial,Bold /FontBBox [-628 -376 2000 1018] /Flags 32 /Ascent 905 /Descent -212 /Leading 117 /CapHeight 716 /XHeight 519 /AvgWidth 565 /MaxWidth 1000 /MissingWidth 750 /ItalicAngle 0 /StemV 130 /StemH 130 /FontFile2 13 0 R >> endobj 15 0 obj << /Type /Font /Subtype /TrueType /BaseFont /QWMWFP+Arial /Name /Rx07 /FirstChar 32 /LastChar 255 /Widths 16 0 R /Encoding /WinAnsiEncoding /FontDescriptor 17 0 R >> endobj 16 0 obj [278 278 355 556 556 889 667 191 333 333 389 584 278 333 278 278 556 556 556 556 556 556 556 556 556 556 278 278 584 584 584 556 1015 667 667 722 722 667 611 778 722 278 500 667 556 833 722 778 667 778 722 667 611 722 667 944 667 667 611 278 278 278 469 556 333 556 556 500 556 556 278 556 556 222 222 500 222 833 556 556 556 556 333 500 278 556 500 722 500 500 500 334 260 334 584 750 556 750 222 556 333 1000 556 556 333 1000 667 333 1000 750 611 750 750 222 222 333 333 350 556 1000 333 1000 500 333 944 750 500 667 278 333 556 556 556 556 260 556 333 737 370 556 584 333 737 552 400 549 333 333 333 576 537 333 333 333 365 556 834 834 834 611 667 667 667 667 667 667 1000 722 667 667 667 667 278 278 278 278 722 722 778 778 778 778 778 584 778 722 722 722 722 667 667 611 556 556 556 556 556 556 889 500 556 556 556 556 278 278 278 278 556 556 556 556 556 556 556 549 611 556 556 556 556 500 556 500] endobj 17 0 obj << /Type /FontDescriptor /FontName /QWMWFP+Arial /FontBBox [-665 -325 2000 1006] /Flags 32 /Ascent 905 /Descent -212 /Leading 117 /CapHeight 716 /XHeight 519 /AvgWidth 545 /MaxWidth 1015 /MissingWidth 750 /ItalicAngle 0 /StemV 95 /StemH 95 /FontFile2 18 0 R >> endobj xref 0 20 0000000000 65535 f 0000000018 00000 n 0000000203 00000 n 0000055709 00000 n 0000055791 00000 n 0000055853 00000 n 0000000272 00000 n 0000000385 00000 n 0000000470 00000 n 0000010586 00000 n 0000055993 00000 n 0000056193 00000 n 0000057140 00000 n 0000010610 00000 n 0000030707 00000 n 0000057444 00000 n 0000057639 00000 n 0000058587 00000 n 0000030732 00000 n 0000055684 00000 n trailer << /ID [<4f8f12bf82e1d4602df2cad672b5d276> <4f8f12bf82e1d4602df2cad672b5d276>] /Size 20 /Root 2 0 R /Info 1 0 R >> startxref 58884 %%EOF qtl/vignettes/vignette.bib0000644000176200001440000000543012770016226015372 0ustar liggesusers \begin{thebibliography} @article{Kiefer, author = "J. Kiefer", title = "Sequential minimax search for a maximum", year = "1953", journal = "Proceedings of the American Mathmatical Society", volume = "4", pages = "502--506"} @article{Lander, author = "E. S. Lander and D. Botstein", title = "Mapping {M}endelian factors underlying quantitative traits using {RFLP} linkage maps", year = "1989", journal = "Genetics", volume = "121", pages = "185--199"} @article{Broman, author = "K. W. Broman and H. Wu and S. Sen and G. A. Churchill", title = "R/qtl: {QTL} mapping in experimental crosses", year = "2003", journal = "Bioinformatics", volume = "19", pages = "889--890"} @book{bromanbook, author = "K. W. Broman and S. Sen", title = "A guide to QTL mapping with R/qtl", year = "2009", publisher = "Springer" } @article{jiang, author = "C. Jiang and Z. B. Zeng", title = "Mapping quantitative trait loci with dominant and missing markers in various crosses from two inbred lines", year = "1997", journal = "Gentica", volume = "101", pages = "47--58"} @book{Bulmer, author = "M. G. Bulmer", title = "The Mathmatical Theory of Quantitative Genetics", year = "1985", publisher = "Oxford University Press" } @article{Tanks, author = "S. D. Tanksley and J. C. Nelson", title = "Advanced backcross {QTL} analysis: a method for the simultaneous discovery and transfer of valuable {QTLs} from unadapted germplasm into elite breeding lines", year = "1996", journal= "Theoretical and Applied Genetics", volume= "92", pages="191--203"} @article{Sib, author = "C. Xie and D. D. G. Gessler and S. Xu", title = "Sib mating designs for quantitative trait loci", year = "1998", journal="Genetica", volume="104", pages="9--19"} @article{Darvasi, author = "A. Darvasi and M. Soller", title = "Advanced intercrossing lines, an experimental population for fine genetic mapping", year = "1995", journal="Genetics", volume="141", pages="1199--1207"} @article{fly, author = "E. G. King and S. J. Macdonald and A. D. Long", title = "Properties and power of the {D}rosophilia {S}ynthetic {P}opulation {R}esource for the routine dissection of complex traits", year = "2012", journal="Genetics", volume ="191", pages="935--949"} @article{Collard, author = "B. C. Y. Collard and M. Z. Z. Jahufer and J. B. Brouwer and E. C. K. Pang", title = "An introduction to markers, quantitative trait loci ({QTL}) mapping and marker-assisted selection for crop improvement: the basic concepts", year = "2005", journal="Euphytica", volume="142", pages="169--196"} \end{thebibliography} qtl/vignettes/genotypeprobabilities.pdf0000644000176200001440000010435012770016226020166 0ustar liggesusers%PDF-1.3 %©ží® 1 0 obj << /Creator (CANVAS X \251 ACD Systems of America, Inc.) /Producer (Deneba PDF Filter 1.3.10.011 \050Win\051) /Author (Laura) /CreationDate (D:20120627123100) >> endobj 2 0 obj << /Pages 3 0 R /Dests 5 0 R /Type /Catalog >> endobj 6 0 obj << /Type /Page /Resources 7 0 R /Parent 3 0 R /Contents 8 0 R /MediaBox [0 0 792 324] >> endobj 7 0 obj << /ProcSet [/PDF /Text] /Font <> >> endobj 8 0 obj << /Length 9 0 R /Filter [/FlateDecode] >> stream xœí]Kä8r¾7Ðÿ!oÞ] ¹|?{ðö ðŒðy&=Zì"kÖÓe=þõŽE2‚¢²ª²Ô™]3‰>tÕWRÖ† |â°VšEz“1F‰ˆé:¹ŸÒ i:…;õ˜^wr7Ñ|þt=UÌ+½H¯¦­Á'áµ †ËÞ„‰é&Z¹¯> ídìµVøÔà NìÅoÃUÈt­ÜW§…ŠÉt,j𩇣uÎvâ·á*dº‰VAù^k…¹Vã„Ò!öâ·`"dº‰Vî«òPÿM²Ö s­*«¤rø-˜™n¢•ùš`ˆNÚ:®´¢\§”Ø[xß ÃTÆt}•Ì˨D‚§SYQ¦2jáL‹Þ@‰„éÚ ™‡Ðhh¤ç +zêPÒ c´J˜®­ðqÜx<äÖÒÀÙž7¦Ç¸K¶4Ó t>Ž›Ã®Ý†Ÿ¤ôµ”žqî:ÌAã9ÝD+úê°Qƾ—&0ïa¨Š~ž[lÀTë@öâëõµ‚¯ˆ­•–k¥0o•‚vK[µ ñ#ÙÙ×hE_½Éißk%0°qQÇm˜jÈ^|½¾ÖG>ã%Z)LÄ#,“Uq&âG²³¯7Ð ¾þØÕò<£}è‹\0ºÍûSt>mÁý¬¸“ è¿ÿîý»p>ÏÈ¥°Æiü߃xøôç¾”Z•\½œU4³î/\Nð #•„)5íº`„¡qŠÚ认+¼3’bêüª°S¬–RobQ{¥G8ÀE…2Ñ™Õ^°#·•ºÐ<£Ó8abÔÝ$¨ƒ5Ð95˜b%‹Ë9òÓ‹ cl³ãrïe˜èo¾º'ú”h¨%_ß¶œx.mËÿ[Í\OœV+{PZï`—û^¹TÑ>𥠂N™)–`½ÊƒIFžçSÏ>’hJ•SJ 0-…’0—ÙGÂ%EðÆʾšÞÎÖm\)Ô³c¢ra ëäŒç¤ÄH:ùåNtO.&£ <Â~¦LSÖ€íÞ§Â_í’Læ˜1Ò†=½dóÈ¥­U”Žp•bk2”B5¦Ð7ûÆòð—;³îÌzšY·¯Œn€½…‘Ö ÒÿªF‹Á-÷1¥ó«’Špr„‘QŠÃ9,Tdø¨ö‚qžÒ¡“zFGÔ74þN›‰>[¾îùÿ…äÿöU8ƒ̵aüRð¿s8½n>gX¤}?ÂÌ]K­:šÑ!†8VaÂ!sdV4ƒŸ´7)±6¿@ã‚uÃ!ÞTбèé”ä-ÑlÚÎôç¨3w|i¸}ÑÐ@csŽ=:rºM·Ô™uÿö@ÈEQYtж A_ ¼vŽS/*\½wœy! ã]?ÀU´‘i%¤‰œtúyþФE¸ÞŒÕôÖB…ã¢^9;wtJŮіpVð!x™µ,µtËÓ¬ÖÖ²¦ºuÀ‚¢ëŸP9ùØwä­û.XÉÞFG>móàlºÓãWAÛר˜ûp'œØ‡+<ÿu3®2Yï:nÓž·ÌáOS{v`‘‚?jÄG¡âÏJ3ÖuÜìISó¬{ØöVFÂi3ÑŸeÆuÏÿ–ÿÛWç|ôótoSB“—«'hµÿä4ÛjKÉFÚÄ–gŸï䈑Ý€dW ñŒÜ—¤q°ï`»pwpåD…9–ç(3»¶£Y ú[ç¬ÞØfúyuæN€·M€\gæuûÎ9M„’á!M)èyQlCq-€w!WÇà0ŒÑš-¸Ê8 %ŸV+÷ñ mMÈ[¼'ú3 çj?’8@›ˆÓXòéé•û3Õ¯n.qÀ tÑ謌©¡§M-àDÂ-¦+ëcþI¬$¤‹è sÒ ‚Ö\öJDL×WI½T&^n¥²Á'ÜLõÜB‰ˆéú*™—.&ƒAá*+ÌU…[–x7@"`º¶Bæ!ü`Â:¨æ néèI²…ÓõU2/ ˆP§Â\¥ñ0-Y‘d%"¦ë«d^ÂxÌZe…¹JhP̪ªm¡DÄt}•ÌK TЧÂ\¥TB›•𠔈˜®¯’za¦³fOE™Âh ©ë%ArþtUmÔ7\ê¾æLE™6ÞqCœ?]UÛã°±xÈ£ J;Ö,p4¥•g`Öà\Wåã¸éëºi/Œô‚p×9Êé&ZÁW/­Àšk¥0ï%Äf`g`"~$;ûz­è+Ž›Òè^+©x§ñö~:S­Ù‹¯×× ¾©¡sp󿢕ÂD|€ªm-ôÛ0?’}½ÖG>Ÿ¥Z LŬ‚Ug`ªu {ñõúZó²|VÇ5­¥šYat•¤„ôðÇ-¸Ÿív’OÏY–Ï+©”¹Fã…¨ƒq \+%ü‰¡˜ò`¢Ï÷a%a(õœÁͧ#æ]Š[Ø¢ë˜ÏnhŽí(JTyÁŽÜTPꌙ‘£%å¹"0übÁ6s,«£XñàÈO_ÜB«\=¹ÿžß·žßúHâfÅc{¾s^ÀdOåYcŒ¤ˆ~~KÁ|Û¶åÁKi ¨×é¡0I¦Òx µoqö¥ Z-(¡Ò‚ù\,¬!'ã `:ÒdGºŠqÒá­^½Ìø©Wƒ1@µì©¨¢""à’&èú™²K™Ð¤" õ@S˜brÎ9Û’xäRš”@k\¼òþN§;†tº} Ü\n¿ëKP6nhóhA#éhíF×6’Òåq®)®™É†Ñ·=º^´Äþžó7óÛW“íeõ—Q‹i-e2E§¥K‚ñ&ËÀ© Î 1'T\Ó àØvÆ„LΦ|8¹dÊ®‡:6¾r]¶˜þžö7žöÛ×”í%ô£Žì4„I“Ér‰7kn O¬ xKd©zŸ G„«h#Ñ2#¶Ú“-Ø™Xt«#["ʵ?ðÃjøJ–Þ©^æÉàB­’‰Ö¥²¹õ³!7é¼—@ZòZé‚•Äm´×—­ž¿3ã—ÏŒÛW¦Í…ó÷>úM÷Ñ-–¿çüMçüöÕd{׉ËÂç÷öËšcE^Þ?ç{~>®ÿ@<„̯ï)¥†ž(Jß™¿œ>€è¹ùô(£ãªðÍÿ)éù~~;¼¡Tn“0F;…ÐîŠdlTL!~%@)Ü;@o(Ý$ŒÑÞCÜF ‚É_ˆÎÍ*jqƒŒéKˆ ÅOv ¶óOC©YÄ=üX? Q?!Aïï¿ù_‰?±>~‚cÌcÿ~’€üøû5”1‡ƒ¨Íáã¼÷ˆß|úíáïÀ&á5 ô7ßÿöðh-¶-ÐqÊï[ò!±òûn}Ø_2dŠ-èë¿]CÿUÎMz-.ž±íb›”ªÀS†­ÕâO:Ž $÷ßëç\í£ûób.TîêÕL i‰N¹–&Z”È.£ÿø1sé2ávœ0‡Ã‡€›ªãŽ<’Ò ¨äRŠÏbÓ¼eêR6‘8ùyçÔ(VjNÁìweÁüBNÂlÓʤ´¢ûn(’ñÀMŽývˆ6~)Bâ1cÇïE1bTe™v»Ëȱc ? M=G7r2aœ!A‘CMb@9ÔßQq¦áÌDü.€ Žœ D -$ᦦÜ4ÂZÆM…wÎÞ,óÂ( Ã÷¬ì«¬, ã»Xyú*D¡¿­¡Ê’&k‰Þ*ЮOü¾F¸ }ÿš±×sÇ ¢?cÅwkèÛsG)RFk˜zèÔ ui¥¼õýPïcK9ÙœqЈ*÷ÉÐCç—›Tt~÷~ʯýˆo*3Ûù§¡ÔÓÙ}™×4ã›PÒòs£QÈÃ,D:Ü-ßÐS‡¦¸aÆh•0][!óµÉ•Š2…øÎ/(‘0F‰„éÚ ©‡øé!ILaCO Å¡õÁÛB‰„éÚ ™‡ß³Ó‡´¡LaøÁž,¤I£TÂtm…ÌC‡sÆrÙWÑe P}E-”H˜®­yh€¾v¥°¢L!.V“+zl DÂtm…ÌCü¤Ðš4e \«"¶… ÓµRSiUÙ*HÕ%à¹ïåŽArútE]Ô/'m¯«‚TWÄ/×ôœƒäô銺¨_'`½® R]ó‹rz±cœ>]Q×ã°]ÀiÁ › ñ€Ãµa7ãFdº¾ÊÇa+÷ÀP(JiÝàQÚ [ÄéÚ ñcªF ë•î4R˜W:ÍïÓ6LÄdg7o } 7\Õi%0¼k3nÃTë@öâëõµâníI7^µR˜ˆGXÆüê¡ ˜ˆÉξÞ@ëc¾ÖCý6PÓJ`*`•ìüèi¦Z²_¯¯5o«¤Å;O:ùô fäªÊqs(ãÜÍ[;¹§çì©$š•€9~¶¯Bå­ö^«ƒ1ycJ(Zæ­¦¿ˆ¯5ÆïKôE¦a6U¸zUaÄÚŒmy¡æ(óé ŽsP¨È lȧ7í;2[ø¨žAò ©F%¸ |=¯¦¨ª•«  Ê $PáÆ‘[â=‚ÖÉzrSå=Áo>ÁuËmjÇö–JüŽ(¤çèA„@¸µ41xºD„šÁ-1ZÎ+9{ÊA(Ì€r”·ÔÛ 1’ —`ñ¦žr㔣±¦žuN‰¹Æ°Zš¼IOÂL…/b®¨\z'Ôa Þ!–\üÄî­„åb$í§K7AÞ ð‹!À‹ÌæžÅKǯ_—¾Üñë¢}‹÷¼¿ù¼ß¸¤lo\¼˜[”D$_RÈfhË.ƒ›[¦„c¾’ƒÑ0Û0¦ëšÙÇþ:zF)÷¸uÙÖÅ{âß|âEÅ ‹Š•!\EœFrOÏÚ¹Hú/OzáÚÕ)–ÜÂß°Ÿh²îâZÓ0áWC[’-WÍQ@û‘©ظ–”ðf5¬%=ßù¢$PÕ«EªCb³1€»„}KóºÌûëô Ï%%éV#é)š[hÒéV¨¥¤œ{ìzçŒ(¬Ûé’΋·.Þ©ñ+ Æ»Í‹{7Òf£é¯éÕ­Ñ@Ö7×ݘWQ x#±nÌë¶¼ÕFú¢Í‹÷¼¿ù¼ßúžÌæîEvW‰Ý÷[F©‡Ü‚QJ ¸Åž5´ìâ’š°v«Â„0C,âZçÆ­rzÄ%ؼVI×õÑë*ЧijòƒqKÑ¡–-5÷÷ÈS!:\åQèÈÎ-ißïë“uñÞÅ{âß|âËÎEº·mÎíÖ.¶Rßã.¶Á šº`!ì´‰ø¸.¯ÿãzAü?d(KM³ÐˆkÍ?Ømj9o®¸{•=º“ô.&¹§L2dqýSQÒôï‹f·l#Zù§µˆ€#ql—XãUý¥9¶KÆ´Ý!ch÷¾Í;qÎú¦©³‡o? ¾m_dãÈ3\Û…IÆÙ]Ú…&}£^I‚]âm­þ]Û%k6~‰YÛåÒ…ŽevÍ oi£,Åk_».é}­Ú…Þ|«¾„«×Gù%ú¶KÞ‚þ"óvÉõ»ÚÔêÃ2Cù u@ؾÚ×Év©Ê–i%›î%­›{ÛÎÏKXyÆ•ÔK-¸„;ç,ö¥ì’ab4ý/´Àîly1žùªŠg[ _Ì¿Ëu&«Ò¼Ô‚°¯ñÅ4ˆûà_Ì‚´‡Fj¡ô™Xì|«ã»; y.ãJøØ?G¦l»”h¯Ø‘ÙZa4 ßžÖM°¦‰`Ô¨7û‡Ø:ROîù[?¼½ü•|âã‚·ü*üp®ƒÃkæ—¯Z#œáð a+tw´³xWjóFxÀò«k ŒÆ˜ç‘½œ^µWìÈl­ð)ò;š`MÁ¨Q nöo`}¤žþß=¾¯ŒïãÙMV^ãs”Lù$  ã+©ÁÁd8|BØÂeÃa1³fCO›WDQ8â‡îçC«H Î|(Ñ^±#³µÂhøm»£ Ö4ŒÕàfÿ[GêÉ-N÷ð¾2¼ç÷óØù³åº|WµuÎYŒ¯ ~áð a-tw4bÉmb —ÇáûÎùô'\`³šEl$󇦽aGjkƒÑ(§©DBň&‚Q£ÜìbëH=½›æßWÆ÷ñüÖ/*01Τ—0ÌÍÙ¼ž£§üJ§îØ9ó[×"—åíÅGQx`!¶óMo…ŽÔÆŠžæ›ý¦;¶AU ˆ5 ­f AlžÞ‡qèKúxvƉ¡1­¡7 AÏ@;|E0‡qɦƒÑ¦;®$!¶1˜n6·*†KÐìD$\ªv>”h¯Ø‘ÙZa4ÊØ*µJ XÕÔ0f«ýCl©'WðßÃûÊð>ž_®®¼ÉƤÀ©Ç™8ψð‰Ã¸Š7za»£ñ5«*mb_ÐfâܨS~8¿upÐȧWí;2[+|ʰêŽ&XÓD0jTƒ›ýX©§‹ßãûÊø>ûc#‘ܿӸ؜?tÅ1f–¸ ¼Ûpu Þ–[Þ)Žï,§_Wøz-_÷û ;Ž>!# _¬ß½¼=‰$ÉÁ¿¬É›õ,GÆDΛvæü§îˆž(.¹ƒ®X¹Qi4´Æ›*I8é*¥f3EI8iÜv1ÛƒÙ~|œJÃ9Ï‹´FºÿœGoõ×{Xmq_Tø€Mº‡Òž¥ÞK(r^Äë FXŸ`ÒºD;égqÄ,>Çè]‚Œ]ŸÓ*7‚¡µvÏ!äfŸÁiR"ßvéþTáž}½Ü¶Làúk4´us™ˆð“yn™x>oã žýÇ—6ë- µŠ|÷ãÉúõ‚`vŸF£_EãÜ2ÎÛòÝ0c#nåªð‰ÂFÁ ï£ÍMp‘1F™ˆ¼ãéÿeûE endstream endobj 9 0 obj 5686 endobj 13 0 obj << /Length 14 0 R /Filter [/FlateDecode] /Length1 68554 >> stream xœì½|TE×?~fæÖ½»É¦÷ÝM…jB DX ôÞ *`À‚Qzņ€ˆ€*Kh¡(øˆ ( "X@@ÅŠ*¢RrgfwCˆ(Ïó¼ïïó/ŸÝå{Ïô™{æœ3gæÞ,@ÀÅÀ [מu2홊ÈpL-2fиЧûöHèt×û&¸VÄ| ø¥×°qwyïÁü%³jbüž»G?8lÂï_…¼%´Û7|è ÂSã{ýŒmýˆh8B³"“°ýŒ§ 3á ®õh¾ Aáè±CÅ`ïó—b|ø˜AŒ Ýl+Æòí0ÑuÏ 1C»e™{â1¶c[­˜ÿ@ìGãî:.õxçÝ£Œ7²Õ«ïªß°v½†™ÙY®16à÷*Ç,y˜Œ?08ç7-NãÁʯªÕàôÀº;¯l¸~·4lt,5gò«Ú¬¼ ´²Ã• W&ÙA´TécËç)xýràyP‚êÞ™´ÎxdŒ36›,À&/‘³°8/eÀ0ªÉÔP$Ê?Ò¨aîZ‰à§WçV.pƒË¼&-ïN²Ôf¤Ô Ä4Ml=MÞÉ9ö >f5X·øàØø¨é­ò*>! a Q 1 qïËuùh ¤Bš¥C¿´‘õÿ±€\h m¶ƒö"ÞI\»B7è= 'ô‚Þȹ¾ç+ßÿ6í>Oàø>Oàø>Oàø>Oàø>Oàø>Oàø>ÿßùX`ŠïY+øŸ»QP1æ ³JéR¥°" ˆÄŸãEC˜/L!2|aV)]ªVx¸_¿6ù­Ûe´¸wÄ Ñ=†Þ=qô {¡~Û@>´†vØH ¸FÀ  =`(Ü 14ÓD¿^Ä{GcßÁ[Ù’}±1¤a 1©‹æÓõ,™uecÙD6…•°yl;Ì.K6©«&'ÈûåäK S"”8Å©4QîRLuLÂÈ„Q o%L0SÏ9–9~vüéŒp&8[;;;û:ów:8vnvîuužp^p^r–»‚]I®4W]W}WWŽ«™+×u—k¬kªëi××v×ÅD91,1*1)1-±vb—Ä^‰w%NO|&qUMR’‚“B“"’b“œIéIIí’% M¦ÉöäÄTH¥©ÖT{jxjtj|jJjÍÔú©9©£S‹S§§ÎN—úTêŠÔu©¥©;Rw¥îM}/õHꧩߤ夹ÓZ¦¤ I–6*mlÍ15ï¯õjâ«ó®Ò« ¯æ\mvµÅÕÜ«¯~Õ¼6øzóë¿\¿Vž\~ͼƟ|‚ –S ‰´}¥°nl›Ä¦#çc/²÷ÙïRÔMŽ•Ÿß—/* È9‡’¨¸•µ[ çF'ìM(w€£9·Üñ‹œÑN—³³›sÅέÎ}ÎãÎÏ¿8/»ÀŠœ«áÊteWpn$rnk¹«ÌǹHç:'öL¼9· ‚s!ȹ˜$‡sI…‚s®¿á\· Î-H]žº¦‚s‘sŸ çšTpnhÚHä\AÍñȹ¨Wg_%W®6Fι¯¶ºÚæêѫ׮Ýu½™àœ«¼˜sÎü ÕäâCùD:—ÏòB}ÞÇP Ó®½í]yÒo(ãO .H:œ›Š±ÕßHŠ8v.ä\ð9Û9ë9ãœåœ~N=§œ“ϱsôüÀg ÎÌ×égþübÕ™û‰ám?füøÂygJÎ< pzäéÏì8w諚g;·èôªÓ O-<µòÔ\€S¯ðº§£N?5cuO¹OeJ9Ùædë“9'³O6<™u²îÉô“I'ãN†Ÿ$'~:qîÄw'¾>ñ%¯ub߉Ý'Þ8± CoŸxùĆ­O´<ÑâDʉ¤‰'gó2§øósß@u\ª>§.Q{ïUù^ifûÌöõØ®»ïžý‚\*ÀòíÓåyx](ïÂÒvDlã om-ÑPk¬Ô^ÑÏ¢ÏÐ-Ñ^àµÃm _cK¼N°WJ›$®)–•[{‡å1_¬äv½Uª9ØRX.ø›2],Ãñz¯e¦·'_êVcžQö— ^„é0ƒÝ ᘠÁ\xVÃK`‡dë4x .ÂÏ0ž…Ù„ÀI¸Ë` ü ¿À%X ëàØëa0 PÑÔî‡pÞ…÷à| Ãà8ïÃkh‚‚'à#øŽÂpøÎÁ‰&zŒAÓ|,‡±0Æ¡‰.Bc=îƒûá;x&Áƒð< “a¬€©¸æÃ#ðüÛÉBò,¡„‰Èp®‘Ed1YBžƒëPN¢ L²”‚¤©NÒI 8 _“cJ‰2W™§ÌWSW(O(O*O)O+Ï( •g•ErвXY¯(Ï)K•ç•eÊ Êre…²RyQyIyYyEyU)RV)«•5ÊZe²^yMÙ x”J©²IÙ,–Æ([”­Ê6¥LÙ®ìPv*»”ו7”ÝÊåMå_Ê[Ê^åmeŸ²_yG9 TÞUÞS)‡•#ÊûÒ5éºT.™2ÈD¦2“%Y–Y•5Y—-²¡| |¨UŽ)Ç••O”O•Ï”ÊIåså”rZ9£|¡|©|¥œU¾V¾Q¾U¾C}ÿA9§ü¨œW~"ÇÉÇäò)ùŒœ0BU»¢†ªaj¸¡FªQj´£Æ©ñj‚êPªKMT“Œ0#܈0‚ÓÆã ãKã+ã¬ñµññ­ñõ7ëeëïÖ?¬Z¯X¯Z¯Y¯[Ë­¦ lÄFÕd5EMUÓÔjju5]­¡fÈ©F¤¥«¨ªÓÔéê u¦:K­ÎQKÔ¹ê«.R£{-Ùóê2õu¹ºB]©¾¨¾ŸÂgpNÁÇð¹ú²úŠúªºJ]­®QתëÔõêkêÕ£nTKÕMêfu‹mıFœo$Ãi¸ŒD#ÉH6RŒT#ͨfT—ž”žÒZJ“´VZ®ÖZk£µ•&hí´öZ­£ÖIë¬uѺjÝ´îZ­§ÖKë­õÑújyZ¾ÖO»Së¯ ÐîÒjÒ3FºQÃÈ0jµŒÚF£®ñ½ñƒqÎøÑ8oÔ32,m¾ö˜ö¸¶@{B{R{J{Z{F[¨=«-ÒkK´ç´¥Ú 6f“l28Èr‘üLN’_ȯä¹L~'?É’A®’kä:)'5Ñ×J(¥ŒJT¦ U©Fuj!µ¨A­ÔFƒh0µÓJÃh8©M#h$©CêÒ(Mch,£ñ4:¨}¶yè{$‘z$“&“,šBSi­F«ÓtZƒfõÆ ã¤ñ¹ñ“qÁ¸hü¬í§5i-Z›Ö¡ui=šI³h}Ú€6¤´w´t}ˆN¦Ó)t*-¦ÐGé4:ÎÐÒ™t–ö®öžvH;¬ÑÞ×>Ð>ÔŽjiÇ´ãÚÇÚ'Ú§ÚgÚ í¤ö¹vJ;­Ñ¾Ð¾Ô¾ÒÎj_kßhßjßi?hç´µóÚOÚí¢ö³ö‹­¥ö«vIûM»¬ý®ý¡ý©]¡³éÙ.‡hWµkr¨¦]×Êåp9BŽ”£4SèTŽ–ct¦Kº¬+ºªkº®[tC·¢'Ç£êºMÒƒu»ì’å$9YÑCõ0=\Ð#õ(=ZÑcõ8=^OкSwé‰z’žlSôT=M¯¦W×Óõz†^SN‘SõZzm½Ž^W¯§gêYz}½ÞPo¤7Ö³õ&rš\MoªçèwèÍôæº[o¡·Ô[é¹zk½ñ‹ñ«ÞVogSmšM·Yl†Íª·×;èõNzg½‹ÞUï¦w×{è=õ^zo½ÞWϳÙlA¶`›]Ï×ûéwêýõú]ú@½@¤Ö‡è…úP}˜~·>\a\ÒGê£ôÑúý}¬>N¯ß«éô‰ú}t>}Œ>NÐ'è“ô)ú4}†.4~£ÏÒEt1]BŸ£Kéót}A¿ß¸lünüaüI4^1^6^5V«5ÆZcœe\¡?Ñ ì6Í`³Ø6Ÿ=ΞbϰÅìyܼÌV³µl=ÛÀ6²-l;{½ÉÞfØ!z‘}ÀޱOÙçì ö5ûžgØÏôgú ý•^¢¿ÑËôwú‡ÜXΖ›ë׌ ÆUãšqÝ(7L+Ð?éz•^£×i950Â(cL¢?2Y®.×”›Ê9r3Ùµ[ʹr¹ÜAî"÷ûÈý˜S¾K,“GÊ÷È÷Ê÷±jò$yŠ\,?ŠÒLy¶\"Ï““ÈOÊO£·´H^"/eò2y¹ü’¼J^'{äÍòVy‡¼SÞ-¿…{wå#ò¬–|TþX>!Ÿ–¿bõäoåsòùWùwùªlâNHE>X Q”(vN‰Qp_äBÿ>IIQÒ”êJ ¥¦R[©Ë(™J}¥1¡ïßRÉešÒZi£´UÚ)í•JG¥“ÒYé¢tUº)Ý•JO¥—Ò[é£ôUò”|¥æÜil46ùùÃ,Ì`V/”þJR¨ WF[¬ÔªX-Ö k¨5ÒkuX“¬iÖêÖÖšÖºÖúÖÆÖ«Ûškmgídífíeͳö·X ­Ã­#­£S¶h[ ùœœ"§ÉòùR7-`!jaÉ"[‹jÑ,ºÅb1,V‹Íd ¶Ø-!–PK˜%œ|EÎJ—¥ß¥?¤?¥+ÒUã°qÄxßøÀøÐ8j|d3ŽŸŸÒïè÷ôzÎx6B)-QÞ&õa l…·È×° 6Ã^c< oÂ,Öw¢=pGÕÝøÞ&óÉcÆ~Ö›õa}YëÉzYÊ-¦ðùÖ % fHt4v¸èªa7B¬‡­G¬ï[? sÏ`1œ‡ÁËð$i“ä>òy’¶Î¶.¶®¶nÊe¢r?Ýgl7v;]ÆëÆÆncñ&ÝOß¡èAú.}¢‡éú>ý€~HÒSô4=C¿ _Ò¯èYú5ý†~‹²~ÊvO¹—Ü›9™‹%²$”ð!r¡<¥¾«ÜMîŽ2?P.¡t”;ÉQr÷ÊoËûPzß“ɇQŠä òDÔ‰±ò8y<«Æª³tVuã!y²ü0êÅÔŽY¨sQ[¦² Vuä V‹ÕfuX]Ve²,Veþ’ü›|åÿGù¼üJ½å>”÷‰RïPF¢äRF³sìÄ(å-PÎ[¡Þœ‘¿¿D]HG¨†‘!·Qê*õPCRQ;j¡N4Ur”;ät95` Ù¯ìîr”/7ãR yc3™$+ª¦[ «-(ØŸàpº“’SRÓªUO¯‘Q³Ví:uëefÕoаQãì&MsîhÖÜÝ¢e«ÜÖmÚ¶kß¡c§Î]ºvëÞ£g¯Þ}úæå÷»³ÿ€» ‚ÁC ‡»{øˆ‘£F¹gì¸ñ÷M˜xßý<8é¡ÉO™ZüȣӦϘ9köœ’¹óæ?öø‚'ž|êég>»hñXúü²–¯XùâK/¿òêªÕkÖ²uë_ÛàÙXºió–­ÛÊ¶ïØ¹ëõ7vïyÞÚûö¾ýï8øî{‡y>øðèGÇŽ Ÿ~vâäç§NÎhg43šÀÍߟ’øN<g43šÀMàŒ&pF8£ œÑÎhg43šÀMàŒæÿêÍ ÁŠÿ5˜ì xèÇp—TˆöjÜ/÷<2 úÑ50™ƒ%€[Z÷bÙ5ot¯‹å{#N#r}±¾´ÎˆAˆž<Že·óºØÆ8ÞŽ EÐOsÂX¹yû[(ï‡aˆe^)}«”lƒñ—°Þn܆6âe°ÎBe ,Âô¥˜?Ó–!ÍÃø ÷Çzu}a]1œ"LOÇvæúî·{JEæx/ùØfÄLì£Ò6ˆŽX& iKÄ,²w-ûÍ•˜¦aÿ³x:"×GÛa;30¿9ÖKÁø4 Çâ8¤ÁˆDDuº²i8ìBZ￯÷¾ûa8¿çŠ{ÂñûÆôWxÇØ±2°Ï×É4Ûü©^ilU1­ Ú³,(F: ‡èNÁ©ä×bùk`çÓ)ÄR!tÑø1_6ô”7ÃGt(2¯KKa9»1o’²ïwš´â2Ô¡?B-%¦¢|åbû –a›ß y(„^Øm¤YÒ×B†f"æa_ü|â¼Áø#8¯=°¯kü×°~OD[œ—bÄh>ì¿ç9ŸwÒ§<ËžÅ2ý90=JïË$¯Ãëc[©>9\yƒÂJ,3ùz©„ˆàcðCÈ™˜·Û‰A(ˆDmÄ׈•ˆQˆ&ˆŽˆêÿ…ŒýÈÛ>b<͹l ù@Ù÷#qlBf½÷°ĻWgVøÚâý$*ë`”‰¼M®/\fq,ýmsâ2ã§B¾G ¹ÿ‰ß'—© Šº'ƒ¶| BQ¶ü”뎙ëÃBÚf#]‚r<Ë,ŸŸr¾pYÒq•äè&™«*K~ê—ת”Û|ŸL9‘*¨‡}8ëÃeÄo(GQ&cøÚÀí³XÐF#fzåÕ¼R!Ÿàe¤sýòYENGU‘OkU¹¬JÅÚ‚öݯ§8Ž9þûçö‘Û8n#¹ãvÆ_¾*­T¿„®A9ævøôóéu’pŒ_útí0Îw_ÓTÚ˜¯*›ÍU,Ô\¥dbø„l¾Š÷ý@Åššg–ûÖÓtÿZêMÿŽÊY0ÆgÏ^öæxZ¬£}ÄøteL•¯â¼£ ã]îÓAä'Ž{”T€<_óð>bØ,ÔGLGôç<sÍ×¾&²gÏ|-šÓØ ôxÝ,ëEsè‹c? ÒpMå”§É}a¥r2¥Þhk÷@!Ÿ+~|<|`Ó"ÐNƒzÒj,,·\ðÀ ¯ ¹àuGp^¨C@E™í‚ex{+D7„úøñ’à…¨¾—aÎ lS‰€Ÿ8/Ƚ¡/êÐ µV(½Qç"`¶ñ2ÖëÍÇ‚õbÅzý ܉ú5mÓl´9 俟y•­Åûyí:‚#ÖB´\Œ<%î=WòÚØY\ØHã2¢<ƒv˜ûÏ@‰”­•Q0ÓæËh'±ß¹˜6õ·.êî¬ïôÙmÀ¾ç`:¯Ûœû2ÜGàú¢º!L)~ˆ1p?ûgßà Öf£·ÐžA>Ì€Z(ÒÜit êy!âS|˜ç…H³{)Idvx˜§Ó,ø{À …É×ÐíÒ#0BꙬênÔ’>@]ýžcÁ0P:ÏIe0Ç¥0¨Î¨[31ü§¹Ž—}l6ûrHí –¨W b¬~T3íˆwÕçÇËÃ7ÇZ1Nÿo1>qŸ¼]¬ÇËHÏAòé$"ÕKË»Óù°±œ~­Xgx¬2w _ÛTA»Êq©™Œ¨-5€mˆG0\éˆ Þ8ún àb¶ý&ÒM|_ÀA[BCN1mbâ]^eð~n•^rœ¹ã¦ø\kä’¹ƒ£jyäsC쯡t‡¹ƒe±‡2ÂÕû œUÃtÖ«—ãPŸ¶@ ó÷Û韀Ÿº•øè®|þù@ùoàd%êâÔ·6ü×cûoó;1@ð÷'ˆðÊ‘ãæI¤}Èq°³‰(ƒŒ×Âx˜ŸŸþyÂô§Dz•ùCYÎóªéUãUçõvqº V†_*äáIhÆ!5Çòˆªqí4ãPÞÆ¼·ÿ—^½ úA ¶„ e°Ú_ãJW¨ÆASp¬±¼ê¢"~m‚—õmЖƒë.ÝŒû5DE~hÍQ‰¯ 9_Ùo¾~üóRu~p|né0´Gš†4iO¤ü´²ÎVÕÛªi~[r«2Ut£îßµùÿ' îDìGìû¿Ý”U„¡œD?¤9ú‘ÇÐ?¹¦\G[r­â´C½~Œi¸z—§#lÁ´»‘>põ7 ß‹éǼ0©Ë}~e ¦mõÕÕ|íõôÖ¿úÀ•Kˆ ÞúW× Fbøg®çW?Gú&ÒEXþ¬7鿼ù×bü>Ä.ŒŸÃøhD† @Z†Åú 9¸?ò—}èÿ:½õþãß¥è³ Áq:ù™ÒÉU÷ÿ6õÏçmhÕ½†þoG+T¡^>àžéKôû<•÷>ÿ´ÇñSœÏòÊz›×ѧ´r?šû²Üþ£Šý›ðc±_€p?å¾3÷_¹ïÌýW¤+Ä™,ÆÓ›ïóŸ|ëFeÛJ.Á2„磣°ÌŸ´šymO0Ê÷o¸7z‰ãAˆ>^˜Gpí Æµn7ÚÝßÂxÒßükšß¶þÅÆÞfMûߎÿ§k䱦fú0° þ.ÝÆ>´ç¨ºÿ§¸ÝÚý_¯å³FW^§ÿ§qÿ:ï‡Þ 29T·¹ƒ£ª_ú?à6ñÛù¹ÿi¼ªßñÇ«ø%þxUü%¿ªìùý™Xˆ­@½ûOÁ÷Ò–¾¿ Uõ¸Bß|qäQëÊ@;PÝ·†®D{þ¿™€À5Ê|Ó¦h× S[™ß‚Àu³ü<ÒBž‡ô2ŸŸo›×1þ(ÆíÒ!Q6χÂÛÉsU¹åþ¹ð‘gÂ.àã‡:ˆ¦ˆPÄFÄÿ\ó=$öý)Ý%Þ^{Nêgþ&FTñoKÀxÄzŒc<mq¸‚vÛ ¯òóx¤¤´ïÝoœñ™×•I¢Lq¶<Ú¡¿G:ÆÏ¾Ì½âL¯‚U«xŽ2 ×P§ÿœãülHuñó³Ìw>W ü‚ë`_\u¾v`¿}Ä3¡Q?ÇýžfäúÎÃýgÉü|НWJm°‹sŒÊçÈ_A=©?ä"šKÞçT½ùù ûZ<«™ÅÏÝYØå{¾å±¬eú~X¦BmªxÞ´-…i˜¶T} –*âùJoÿºÊ×Ä[œýñ³ÌØŠ3Mß=Wõ ÄøúC'~S¹_=­ ®¥¿ˆs(ï9æm|\ãK…Þçæå[ŸwšïùÎ=‡ûÖøû*Öüªçôý¡;›‚û>ÿ™ì+HÃ]ÒL„ÇUÇâï ùrýï|!¿o‚á¾â¬Ïû¼‡ŸA…Uz×Fðù{1_íùœÉ6Ôá`>ÿævÉû|®¥ô–§#]@xÏÅó9~6ŒèK?ÅòËPGïA]A”žÏð¦û€eÍWD½ÑÞçfJODs×0¬·†?;òfÜ€yVê %â\Í\IÃÍíHï¥ïŠgŒÁ¾g1Ò<è%Î4o<Œ–ª‹sëêR/Î?âAŒ§ˆ{÷QÁ+7Ö Æ}¿G~6W›ÿLh¬©ïŒÔWVÝmT7Ê«mäMÂÆ¢ÿ²m]<Î]œ×`˜Æ¾‡Ô†°(ä mÌÃäRôÔ9è˜þ)Ò'0Οý~ wùŸ«yϧáªÀAô¾g¹C9è’è{N˜ï 'xØ– [üm¬W*Ë™_"®Ò§±ï–PH˰å8ì‡ÙQÿªë ö¡º¯Ÿ¶R_Ô±›Ñª*°.§uªÓ9M­ _zlU`:§-«Ó[ÞbWîïÆñwéiUéiÿ ãø»v“«Ó“ÿa|«Ó;þãø;>§T¦§üÃ8ºT¦w©:´O¸-߇{ÓuH?ñ­÷ß#í„¥¯|/†qaóÅ?ñ•{û_s1÷ÊfKÐæ™|< éÜW›Ýo üRßïáûû1ŸBÔ@ôñöÅë–ïôö-àë³|“·þõõHß©D|ãíOôÍmï¤Éˆ%¾û›íë×ã{ùS7Ê—Ç{ïQÔóÜ€É=°¾iÏ(ßâ…ùÒ×ü\t¿o\<ìðñƒßó6ÞÖ »W¤%h3 p­W×x©ôt6÷ÈMkÕ8a¿‚UÂÞñÿ± 2ú!ÏCKî7p.åçÊ…¸6ú'}Äó¼QÒ¥·!FþJ÷@.ÛŠ~q[´·Ø‡x.ƒms»Í}6:#ijJñLˆ?;yfY6 ÿÅŽeÂ¥oq¼‹a7îÙfËy@°¾¢ÖÆø\×WÀòC0I»•‹8Öc0 ×+§2²åG¡o«Œ]¶¢_à£Ú"¢ÖÄô5à’¾x}úuïC7äY#ßÏîUÇôW¼ç+Bþ×2Ęq¼è‡I¸·÷¿7 @žŠñtÏœVƒ„{t/àÚݪ«:ú^u`¶ Ë•Ëx ú©â¹ü0ïëòçOêÝPOžiþ½»rùÜ ,~ÊŸÇùÏÐw[! þb¨x®å;¨ þ6øó¶b˜Çß•¨ê×øý¨ ŸÂwFPqæà¿¤|ý¬¸­äoxÏö ü9ž8©J}cÏñö ,ùüYu7tPÒW`˜2zÊ‘/aÐS} BÕ¶Íý3U~ݾFË¢/Ú“ÿÿf+Ÿ¾ßàºÔÖ§ã0ýcÄ:¯>rýâéB71íú_úHÄdÄo>Ï3§zÃ×/xÛy“½å¯£šü­tVsÚ ±qUöS}ïRÍü ½ñìžËO›ÛÒó ë0§êÏø«Ò§÷ÇÑÏ;:ú$Öu!¿]•JÞ÷S¦x©ð 9}ÙG_䲯}½ª´êû+÷>Ë?ø±^=óÓ›ß{ñÓ»|4­â½œÛÐÊïÉÜ ¦é‹ý»gw¾3·X?½ÅûÞ3¹TùËþ©2sÌçÇrÿ½ƒxÎÏßÍùT¼Ãõ(ÊÀÍèÃÁß'¸\I8ÔÑ7Ãççÿ-”DZBsV…ù+Žù/Ìç|8çÃJÆÿN!=Q毷~¿.WyûEhµ¼Px!üÿòTÔ`-TP…¯…ÿô28Ô >ÌõÃ49ü|÷óÑϼ·oð¾‡WŒÙß¿¯Ýÿé<þOçåë¾ÿiì•á{GÏOù»{Ê-Çó#ð«â]š5惂|݉X‹8èÃS¨+±ü]%6åi¨x_±¢Î_ä`>îM9|qßû7Š‚žíÕþî+þ¨C½ò§VóòI¼·ãõ½¾Æû°ùÞ±æ³})z7Xá{OÖÉm ®»\ÏëJo°›}>³§w?m®ÄuRÆò!òhCß5_”'¡M¸h¾#OE_}M÷á€˽¾Ÿ¹Á÷¤"Þ^«+÷¶^û+B¼ìó·¹{¯åßzÓoŒËo{ÙxW!F¼_êûënÒÜÓ€vóÑ_àÏ›Ø hÁ× Ö}+þÎ;÷eùÙÃ)¤^Ø/ÝØªJúÍ߯áïÕ Ä;9|žöáÀËïõýûûêâ|iÚñàïþ`žx§Ûàï:q¿ˆáŽBîŠrÑËv7?`‹¶óáÄ=8Þ>0‚N‡Zlî‡ßG'ÓÇ#Æb8i0"±qÔéWQN®`y“0þR÷ö2¦ýéÃ*¯‡òPK¾ŽþÁI”ƒ3#_†çäæP]é†ëØ:þC‹åM|o7Œ¿O,Þ%>föŸ}û¡äA„þ6´Å9þþ†ŸÒµÞŸ7 ½Åz$Þ¥'Ü{[ëõÈÄûÓ^]~®š ÓPÛ ÚùÞûæ}>†>(êžä}Oµºô2$xý8¾‡*Gn™\z¢m¨8{å”¿ÓÆeËç bUsýïkÍFüYíÆß×uïôîKM~^ý4‚ŸY.­ôüi!ÇÿÓÏ·h•çP÷¼èvïfÜî]¿ÄÿÃg*Ußݸݻ·Wyær»çe(«ÜGnƒëÊney ãÛO }}‰CÓç£^m3P·'à´=¤øÎDù9©í—Cš'ÎôgzÛƒ0´M-½góæ5ßß9ˆóT~6ÇýR-þ"Ö÷w ¼ý¾ó[ñwç´õ¡7·µÜ¦Š5ƒ¿Ûû4´7…ܶÐE¯ym9&܉sÉ–8Æ–‚Š0­á³)-A§Yx/OyÁ‚ÍÂ&yml¯ŒÛ3\½ö*ÅzíýÈkƒè),ãÇ%ÄüY ßO‹=5bµX›®xí¤°…üÃâïQ¼û§`®ƒüï`nç/ù|˵UèN?½_諳ÖWç¯å}Ïnp- kò~HçïöV컲ĻÑ߈ýJ;Ìç>È ?ßÞ.æ çÈûlŸTÝðç9|ný{zï¹YùG•è@/Ä:Íùø-úe\w;‰>ÐÆ‰ç=Eæ%ß8ùþ$åtnÅÞÏ¿—óï5šJËà%v7úBuù;Ib½ßUiû‡x‡ä¼,ÞeFŠi‡°\;ïº!Ö·ü—/>@ü„8î=§ºþ)ÿÛ!ΗŠýÐ üýòíòIä×>еN£ìðú+¬îåçâüï 8ÄßNù±õŠÛñ"è¶z±ê›Ò¢ïïbépAYziF‚s;«ÆJ›:Ýe,yShDfp‹Z¸Ž¨#®.¼ŽEl@ìfüÿåȘnÇëTD1bb7â}„‚Zã¹.ÄXÄ ˆ3<‡%°øR—ÓÞ¢‹Áº1¸T³(¸€0 }˜(ì5 º""G¼€PD9ž21±qQä¸YTé“Y8ö¨Ò¹‚l9:SDy£ýˆè¦¾ù^Ú¹»—æ¶÷kâ-V¯¾7¹vK/­VÓKCS3‹9µØ2÷´ˆd‘x“‘8ðqx%t/NXŽ…AQ±½)nº)%-ó…ÝhBøŸµ(§¹‡‘R[Hf 5éEGì'zÞ›CÏo É|¡Eú%l@ìF0ú%~¿ _ÀTz†ó¯Í/ v#Ž . z¿§ñ{ ­H0ýê š#"^@ìF\@¨ôs¼ÚéIþ’œ¸òps¥'ñj§'ð¶Nà5˜~†¡Ïèg8´£¥²3·‹@F_À™ê DÅù¡‘™eôÃÒ?ÓQ¢Òp¦Q¢v²$hY,©4µž³ŒE—æŒp–ѯ6¹2œË[ÔE èAðŸdú{þ\ˆnˆÄ8„‚¡ã:ňˆå¥ ¯v„‹D¼‡8unD7„Fß/ÅnÊè‘Ò´–Αô0ÝQÈñCôAߣû}—¾-褤é¾R‡Z˜XÇŽÔŽ´æËôÍM)¡N³EzŒ8Íx­ƒhŽèŠˆx¡ÐÝ4©´ÐŠì„ƒè™9i)|/è+°R÷H§;­  ‹_ÒšÜ!¼¼àz!ºÓ.Æ(¿¤=ö$†ø%mú< ñKÚ¤G0Ä/i£ïÿ¤ŽÄ¿¤õˆ!~IëÚ Cx)£Ë¶¥Ts6ê:ЏZÓû‘K÷#—îG.ݽŸáO‰í¹Ò5cKÜé5œÅ;Hñ.R܃¯$ÅCIñRü)Î!Åw‘â ROФØMŠw’ÆÈŠbâÞ|S4ÛMŠ’âõ¤¸ˆ§‘âTRœBŠ]¤‘»Œ&–¶Ï¤µ ›Zp¥CzG3´>Á49šˆ2Ÿˆ6a7^ Lsc!W’·pŒƒÓ¤M5š{ãµ›dŽmÑŽ¾…ßÂix N#$œ ·PŒÞÂFÞ‚ñÚ1±qa",„\\ƒñZÑ11q¡ˆá\@Pëâ1°:¾Awå1ú~“ð›HÝ öx{†½{<ž;HW‡é  2½ñÐ-¤ŒØ¶þnûãwè-tþ§üèh;é}¼ôÏgYTš¶ÓÙ"‚<‹ÞJɆ4’Š´1‰xˆ×8­ñ¸p’ÌÒø>X-¸4­¦s âµ¶:ÿŒ?ëü>¾Œbð»øÎ]e)uÔµ[ÅÏq¨S¦aÊ®´2‚d‡KÝߨ¹þ (úf,)uNád«óáø¶ÎQñ"c¨7ã®"Œ¹ƒ=Òú9Ûa{¹ñƒî"ls«³yü]Îo©¼ÎVg]B†7X›/:Mvˆ{7*#ÃÝ5Õ…jžÚUm¨fª5ÕDÕ©&¨qj¸ªÙµ ͪY4MS4I£háeæwÿ-·pEügÖÜ• ‰°úÿ£hnôˆF¡xÂXGÚ±gKÒѳgtìò\î™\F,Ýûyää–ÄÚ:öjéiœÑ±L5{xetô¨ÝîÌÛHÈcù˜ê¡³ËôÊ+#&Ošç m•· ™1?ŽÓê3æççCtä}Í£›‡6 Én“{‹Kïšqã}S8Á³°cÏ<Ïš„|O&˜ ù=OõtõÏÛN~![çn'?s’Ÿ·5#¿´îÁÓY³ÜüüŽe¤(.ò3–C‰ùY”ÓpaæåÀ¥9¼å–xË¥b},— –ÓuHåRu]”“/·±(¥uîÆ”Q&ÊE¢LQ”«r™ƒ©X&5U”‰,†ƒ¢ÌÁÈb^ÆÓL‰Ç"ŽxQ„ÄB¼(ObE‘>7ŠÔñ™SQdŽè‰‘eâ½elgüelg°LÆ¿ûÚ2#ƒljš?¤ë¡É­ ’[ExæÞ7<ÚS<ØåÚ8$Ÿg¸<,­`ðáœêÉOšë’œëÚØ´ÿ-²ûóì¦É¹¡ë^yû»‡æ–6u7m<(7SÛnõÝÔ×œŠ¾êw»EcÝxcõy_mÝ"»ÏnËûjÄûjÄûjën+ú!ãÝò6jÐ2¿U/ÝD ÊkA\b~ËHû¸fBx›&FO‰ÛÞÊ*02ò=Öä–‚gÕjQ«ÏBâYA˜ìËŠžÒ41÷ˆ¾,;&‡$·„Œ ‹&Btë¹ÞEøÁ¤ 9ý׌¢¿û`^k{PnÑ€Žž=;zšwï—·QU1µ€ß’§‰?Í0Z—™{¼‰µ1± Od¬¢ OËáiºî+ø×ùŸè£­¸Ó›ˆÛA&@Q>ó8:ö¢h zõÃ{íß/oúR|y(ÊÇ,"¤È߆oØà¿g?&Lô…|¼˜à£ÞšX¥ÈÏ’ŠgVFÇ&dd4¨/ïÀýÀˆ•_EŸ>ïwL~îø§å#Ìïx>§¸(ó`¬'#`=솑‹Àµk;lîåÂR˜ OÃ,\ÖúaÊè_ÓŸ&1æf¨+pa[‡°l_˜; ’D›ßÃT˜ÁŽb­`ƒ$hÝ`,Ì'̉ÐNKÓ t‚{`)6óÌÇÌ'Í—pÿ³½c^ba~™?ÉŸ˜'¡ÖxÃiò¤¾ÜØK1–|î…%l€DÌ»Í+8‚D¸Ç Ag8DöÐ l}(|K¢ÉdÖ [yÑô˜{±T< €á°v¤-M”û›ÍC‰}<€­.†RØŠß2x>#Vù¢ù’yb &´ÇûÙ ‡ÉV~ý‘òæü ¹”Ù˜3Þ€ýð>I&oÒ±²UΔÝò$ó#‡zÐGû*Öü†üN§ð_Pbû¤6fKB¾<Á¹ oÃ$–Ô!]IšNÇÒeì^аÇzø-„ÈïEØú)£­ÔJ°¥µÒU%¡üŒ„3’ÏÁóð&±áºHy”'_ÑVt }Ž~Éž–VKªƒð®ï‚10ÖÂï$”4&ÝÉd8™Lf‘'Èbrˆ¼O¾£-h/:Š^`ÃÙxöºÔ¿=¥"iš‚ýDW+ôFÍLŸ“hÌ‘çq#ËZñ(Þ$_ô¦‚q¾p>~¸tÖªÙ ]II›dW›’‚’Aefñàd—=¹d;ýýWɸÖ~Á)3wÌ󴙇[«‚ᤠ*…–“ÉìîÝdvÏ~yÛí®Ù½òJ)¡­ ZæoLÁ¼¼í.·H¥<•'òˆ‹G #Á›,¥š(·Ý P,r%‘ âCʈ4ÍŸF`Hõ¦ÙýiÓ$oš[¤ñ·1­zåU–¡’ùµFÔõ-z5þ0 q€uÂ5¹ú6‡A<²\°õ>`ŸŽå¢æUÁµ›Û Ë%ìºÇldk¯Û#q@ò;ÿ3T‹HoQâE­§Aü\˜u?¼ÌÆ h4 ûI€¦XþŽÁè:`¼å¹ÕZ_¹íö@@@@@@@@@@@@@ÿ/%⇠dþ_¡ª‰!‰!©x! Á5ÛsÍ-ÃUpI{øOâìÿ·Ê!,™êަ9`¡9a,L… -ÇüåÒŠEÑöËœ‡æçëÕÍj±ãСCâçtÌoi¶|ëöÜÌoÍ®—fªÇ5°ù‰²—A6oeÑÂÈ—ù$6U2ßFL´›O^t<®VŒôd ®Á‹%=Â/9Òãåt[²ÍC ÔeçÚæRÓD›X<­7¾‡êð/„f7onÇ 'ÿü>û¾ÐlûÞŒL>ùÕe[¤­µm¦MjÒ7ä¾8Ö#r´}dxaäDÛƒá3m%ásâ^¶YdBgXmA’J°_Âç”ÿUõNÂmÈFàÍDHÑ;èKC‡»u¥ŒÃ´…ú§8Ô?Å¡¶8´h k¬‹º¢¹Š¸ŠUQÕ_T­(ª¥ ³F ÍžFñN/mãµÒÔŠ.#KcŽ’¤1®ç{ÜF…^P³Œ<铎ŒóB>|öøRÆ€ ³|ý,׋óv!,^YAË‚ÒÆ…ŒÏçæ%¬Q$7ÅB(ÔFA¿|pQù’“Òúlv>3jꆕgu 5ŠÊfŽ1/|sâ¯=ppÔ°ÂG”wüM“L‹^<ËóèäáËèytút×–ýw—\ZÛñúc{Êû†{ ±h±ìò´Û6²m;XÍ+îuœ?6EŽ0ኸê^s.®²0犸ê^Ó.®ª& ž¸ªbáÒ4o:g°&®²¸*⪋«wYͳ·.±®¶°ÊX'ÛÓ Eõ«ÂTÙb0×›í “Â“˜ ¨Õ&©l'Ý úrËÝ$,-R¶M–-îg}‹á°x½ øI¸–2ÒÈmSÝIÉõÕâÄê‚`Ê•Á°…×j§.Ê(¯Ìë`àìV^‡n *#óÄ|ÿÈ×`¾n\âjcÿÆ.– û¥œË9!Ù|’³³gÕÎÐãt‹O³¡šÖö#·‘•Í’je3)!!‡7‘€eÜáV·‘m-î–mu§e[“â‘Öʶ#ŸÜâ·ù ½Ö$+$+"9„…ºðútúüSûöm.o@¾Ì¶^ëðrù 4eÏ\Åí÷åWÀA®¹ÃÂÄt†Š«!Œ†pR ºaDÜQ<&¼ÃPqeÑ~‡F(‘·… g1T\h1ß¼˜ì›­Ðv Èmg/‰²8""âCùfK’#ÞD@ÆÅ^8—" ,_\¸ÅáZ…*u}/ZndÒCÅ",®cL(IXöjØ[ÖãÖqšT#–éuåºÆ\PZ{˜%"4,ì`PpxPXxP° Í;ŒÄ´<ˆ»#ˆoPÛ‚%r”›"\^Ü!|x!ícíSíÛ%ûmŒJ´0*Ñ¢íÑ4ÚoT¢¸Bw‘LžAÍk\´åVÆÅy³q¹É¼ @iã«àÀZà³³´Ú2Šˆ%H¬>d<îþò£~•í ™°ÄˆD††"ÂUô Óz¿±xô£›×Ïë;¯úêÇè§×·uþÄ¢M˜éë¤Ø^2wïÊ%¥]›Gҟוß׿üòûŸ(=Ã-Jg”¯\‡ eÛÑý¾(xRæ ¸üÜÒüj~1J®£DïþD\ƒ„0‰ÒÂrpOÅâÝ’Xo¬iÎ`â$ #qÕn±ÙЋ‰““á6‹ƒ@ª×Û»#ÊÎe*J¬hQb{åÛKúèým¿l 8oß;€ËV­Q1$WuGäÆäºú…örb…j¡62´Ð5A›?C›\û(2Duñ‰­æµ ¿\Îx(Qd¨<£š+Ù•È3Bø(»Ù(Ž3Žå¾c_Òüc&|Á-©~¥ú%+µB²R‹ìB²ììhàð/n㾯}AM´lÝa¡Õa˜ÂÄ:ÊH¶;©yÔÀ¨±QS£¤(±ý‹\ŒŠäu£"ùH£ÊhʦŒŠ†w«,z罋šXÌM>9ãEù‚VÙJឃ¨iÕÄöBQùJÊ=ä$±7âë ¯$†ìê¦èšíGõiÑ{0m±ëîÍ×ïúågŸŸóÝúϯ7êúX—{_ZùФ5RÏ ‘u;×möÓÉ!å¿Xr~ éH&“Õo®ú׵ϬÉ/[¶hÃäè \Û"åWÁãÜA{mDÂT“t\<¸¡©K‰¤[mEŒQÎÈ®Âçc46X+ÒÏAW¦”5G2–LÅ PLO»Ø/ ŸÓùÒù.öË|·À÷åÜÌÉö:~¨pa #`ŠšÜ04´Ñ ¶e^ùùŽ ƒ·³G#]Y?ï™òÐò«e'Ö“Èþ¥ü¢'jM jM$C]Öf;Äû·ê±Â «Ñ>Ýñ¥&‰xq­å÷óÒ+lwÚâbgŸ$4)¾"+âé~Å«%Úå¡:"#M\½Õ¹à$ K_ñt¿eÕ…G]Gd¤Eß0ó›­ç¨ÍVÜ·ÐÞµk‡&:¹º#Ôæà…88¸´UœdsÁu3Ø¿Ñà‘Íx&_É™¿«Ði–aåÅ#D‹B§#nœÜ|øÀw(ç³³+Î ¶‰(þ(ÞœgÁþ…ß×?OÃÀ5wOäÝòšbÕ‰wzãþüa_¤Žo~p³Ò¨A$IlÙ>íë÷ue½.y&“¥ Úxã^ëDÛ¤¨¹PBæI3µGŒéÖ™¶ùQï…ì MBóQïŠåÄåªÃI-W·)1é.+8¢ÁŠÃX^›Tâ´ßŒ8üfÄÁ͈0¢Ž¢Ý:Ñwл!ÃW(Ã_(£ÂÖd»]hk‚ Ûƒipy“- L´00ÑÂÀDyaeônwDŠÈL™)"3¥(¿wE¸#hÄ‚zûýk›XÐÄÆ¥Šõ­Â{Í ˜È=*Ÿ­ëÚ€{ÇÃøü[:EÞIKkPß·»ò;Ï€)aá•lNeDFŽýÍî=?Œ3k~ùåO?-¿üÄà™£†Ï˜3ìîÙMÚ/èùȪõN}•Å¥/¹ü³Óˇ=›^sïì]&²çñ7I¯áÓ§ 2kú5³ó‚®¯?ºf•ÿ<Žk¶×ÃåÛ!U%™³#"Ú{+ ¸&{5]0.±B•#íÂçñŠºYM\“½Ë¤pÉ+”;Òî?ìÛ|#ƒwi÷- ßU:tØf8Ñ9I A×ä²ïhïJ+ÝÕ¹€G‡ ‡+!Ñ!53ŒêŽà gP× ÝI›=DéM¸”Ä÷à|òöf È«D¦˜?~®v¾Ò~þvÅAD¥AÜðøÜ5„Ë"”úoz½¹¯*]Õ©Ü‘»~“ØN‘îä;#û&c£#ÇÄÞ<)öaǼعŽ%‘«cwÅþùë²+ìŽÈe‘ë#Y“ôB…VãÞb2êVt¢KqUwt È]ÃxÞ%9ÚÍ»loæƒpúuÌéW§ÿ”ǹƒdƒáË68›y¶áÏ6øjr³›¸ &÷ÜQèqHz”ªyþ = q‡Ð7é®Ô>òiP…“è_©aÀx2à–?ÿíõ ›Ñõ«ñU) ú„†ˆãÂ4"”$Bhϸõ‘“õ|¸[CÒp瘭׈ºïñóMúyåºÏè»/Ox tõä‡WžöI÷tšúÉ8ktŸQDûä4±/)ÿªü—òoË7½¶›ÕnëÞ¥óp©F-¹—¬šHŠ8‹oë®&+DRuHe$•Q5U’”T\®_ G(¥»eˆÕIŒÖ·Ÿ8¾³u:Ÿ0þ|ú¿9çíç î¾B„¥HlÀ·F‰R“kÙ;ì®UןãZi^óqß«BMà[‘?ü‡D×6û¶AøÏN¼‰[èû[Eòîr}…®xuOSøUâ+“ˆS¡›„Ç[­´‡¢"Ï;m‹E´#®zh_„U&AÁv± ýe³/ð‡ÐPÊÛÍ‹—Xˆdq­c¯k¿[®Øg³öò>eý¢ÝÐä|Ò‡v³7<ö_­¿Ú~ Ò%«d“‚˜aÑeI²Ú‚4EU­Ö«Jø‹SV—j Ç,ÊO‹àiÌ%Yñ–îeÍ¡0¥ŒŽsë Y¿wSBéb Y4Ü¡V UYnÒé´ÄHD*#Ämt³îQO[Ù+±ò¸=X=¢Ò©j±JÕ§‚-V‚þ‹ÆY±Ÿ?ÑÍsbÏ7?‹Sÿø“ Üë̪-¨ÐzœùYö½{ƒöî%{) BGѳ£Çѽ_Þf)˜iêó"nµþàºOîåû£¿ÿ$“,’ÌYX"K«¦¨Œf}@ó>_{ý¹Ÿ’Ÿ·IŠÏ’w\iCv•çÒ~dáöûçÏåþÜBô=¿Gù áû 2c;H8Séü¹…$µIî“<,¹HŸ®+#b'Êãô"cš<ÍPªEê,ºZ Gd‚î÷è*vØb['¶ÑzX¨£FôtˆOp §Ghh/ËEh¿ùáöÜmã¾}tšbåŽþoܩܺ*¡Ü²* ŸGEã£R„ä(á\ª”^©þÖ*ï;.»Ãxk©iÖxÞšÕÂÛ°r ¬Æ[°ÆÖÄñTÚrXxi‡Kß»|g÷—…qß¹ý•ÍBÀ¼Å{’o§÷2šö®8™s¯9]þOeßEyî?ß\wvgwgö63{O²—°$BB0£‚Üï²/  $ …Bk¨ X© j½‚Bñ~@@|¤í±Ö?üb+^àT Øå顜*fs¾ï¸©ç<ç9!™¼»ÙÝ™ýÞëï÷¾ß·'š›ùõ-‹p˜k’q-N’ŒÒ@È6“k#,~­RVB¤¹è TVcò°© (jêIÜ#òÏèÔsï,ǺM7výrcáa4bͰqãoøñS…Т¹©ëg7~oëÆÂËÜáY‡æÍÝU›>ÒuÇ+­C˜iJ`þı‹\Ý.HÃÜ0m%ð²ó{ÿÈ-çÞÃvðåþÛèöLÂ{½`ÜL¤8Uã¼ZB-‹tQk#›©Ç¸™_81ÝÎ_;OPg#ÿQ\žˆ‰0¾RÉ„ã±ÑΙ¾ý3õ;¹‘Už<1º ?‡vÒÏ)']^ÊGeŸdI«qoedçQ• ²›BlCC&eE9åG¥â8c*¨NÕ© :5·!Þø–ÈUÚôèm-€°:@XX(âAÿ‰t pñÕ‰Tž­(OàEõ$jkXUH‘ôAû}’@Øî7F~uîbáwïF׿ñ1ªþzí?ÿYË¢ó÷íøMùòê/Ñ]ÿvÍxåÌ;·oy¦ðåC¯>ÿɲª8ˆ³ë°‰Ô3Æž‹Úl›$ß lÂq:î é ƒi3¨‚Á;ÿW£$¥ ÔTøŽmÚ‡[+Q´Î‰–yæ'ž5ñ ɸć Ɔç/ƒŸç˜O¾9Gïé™Â~¹ÐørÏ|ò^a 9„-$‰&Á/ä§[Óh®Í‹ŠÐf´íA—CÍh2b‰ïÄoñ©±p¦‡ ã„<Äô˜"o‘Ø6<4@.iPâCztt}i™ fÕiÖWpßYl™=ý­Õ ÛÍ~ˆÍ‘Mu”U(µÊÐÚœeª¢<ÍøÔÚsà³Ý¯Üº»Ã(üõµ# èÜŒ‡–¿ô‹»—¿Äîùۦɛ~³´ðeáƒ'ÑÏ^ŸñÀ»ïœx æ§ô^`.â¨DÿqˆRqåP<¬ G7esMáXìÕå\÷¸‘Û j = ÅzÂA ³äò 6²`,˜Ì™RÄGp¬wß *JùX¾†ü^o´(¡XøzïõêtïtµÕÛª>N?Î<æÜ)ï J6§no§Û˜vîni‰³Ë¹KÚ/°ï—¤€tŸô͸Êov/vßãf܈ÄÎÔ`Š\T+¾¬ÍÔvê u # ·ÛA}{a|é–Aº‰A‚­¸.ÄåòL«]¶¢êư¥„#CˆÂXËpe¯› bAÈvg(pDX„æ0Œ F06ìsóƒéù!ÞùÇšZp‘§ vò4²“`Îk£…!¡Ü±¾BÎ4o\¾³ø_@/~Ø,ü×ÎË$÷wZe»ÒP-çÏâobIØ”,¶c;èâå` °íÌ0Å4½ùòŸOþ³óóû_þ8¶[¿gö†v®m­Sÿå8Š ûKˆ^³ûéЂ…¿zïƒ7~ŒcÎxs¢Ø–ü8æ¡ Ú'¨ š¼<3÷pÕ‡>/|‰|ŸD.ôÍûÞu·mì9EO•†Í¼õóh¦º£Åp””PeáÓÂWr|÷á;ÑÖû®¿s‰*^œ‚º0VÑ#ê‘[¯Ö놾D\zÂù¼ÓtV:÷èGuV'Ëjc¹ˆÍÉHî°ùé¬ÏË2hñÇ¿°De*Q¦ˆR±H*Åê})QÞˆj¶’0V-¹9„Bp‚Pß Bp‚)Çr‚KN‚ª ß[0µB9Uȯ!r†JŠ®­€—¯€R ¤"‰NPˆ”ˆtŒj¦&ãøI^Å´J2„l1ld'L1G|cåˆË†’„i’@)=‘<ˆVì+#æ™t¹Ô>Mvùl È—v@ÈížI£æp<™Hæ±µ”nuI>oÊ')!äqúCˆ"¬é+³ÿOÁ†Ì•² ƒJ…’3k=—êWÖ?]³«}ù#±ýæ©öU´\³äŸºoº}šF6µuÒÍ·Þtx÷ž4ýä›·îìy„Þ»bÅ”ÇêùÐô$æ<ö¤zÅðr 寧“ÊŸ1ô^b®xy–’åØäVÊèçò íŒÖ«±q›Ïå x¶±€ÓîtI.Ëh]–Ç[Ih±8Í ŠpTÙá#jrãP,Bq”Ã#Š[ }DWøöW¦q8ìEôxÅ€2ÛaÔÍõ:þvLÒHØªÊ ÍíÑ.iôm»¶G;ª±C×ú`7°¡XOâÝ•nE)v¾úšú°ÆZ-Ùõ‚%,†-F·£†_Å%²ÍÌ ““Tèÿ÷}™Ô-®1ƒ‘ïŸUˆáâƒì+k¾¨4 ¢¡xE´Ûì‚áå”»BÈm÷ †0ë6J0Œ"UQb럹û“Ö§§ÈöîÌ‚1KŸeSìµdbÍ{–Ò÷ݵèÚ-¿í9BX†‘¸âOcÍ;)½~À¯ Í àÚdê˘G$þàìº4šc›ÉϲÝÁ·Ùl9¹ÑÓ¨ÓFÉã=㣴®Eœ&ç=ùÀ4m·H¼]^äY¸]û>ò‹<çœÃ|ûž}Ž´™Çͳ/”ìj˜¨|–Åø,Èæ# n/ј/^!¦#ôm<€a(¢R‹^¡8æiމ &\C‰D27X@” q\Ä;Ã:ä4ŽVä‹À² ÌÅ%™œXs‚’\¤…®- ˜ ƒu@¹_Œ-)˜ã¤ |:˜h €Bq+ÌPC‚7‘•Z†ù+Ù|¾¿}XûÊp¥ÙAÆÓÅéÜtñVîV‘EùYÐ|ñÂ('Uì,®¹óþ7?BU~àtá⡽ëïÛ»oÝú½´¥\^ø÷žwÿücEÎß¾óÛÿÿæ;¿Á»¾ÐÆ–a«ðPQô3c™$”GÈãe¶9¾'NÇ⤊H¿&r]dI|sÜÖ¨6†Æ©ãB³ls¤µ%Ôn[ µÉ‹Ô¡£ñ÷|ŸhŸß‹žõž‰÷ÆlVÎúëØFùvœ<[>çøs¤ ;†„râa—ƒré–Aè–AèÄ bdõÄ ;’톽ÕÞegã`q£¸§à¼á Æa׊·Í¾6l6 :²[ô“ØvtЖ!o-]ë1w?¸ÌázÈØIŠúïy%‹N’Kè$¹tåé$ ªqÀ:)6º^Cýø¤>:){ùìw™$³ÐPJ$y­|ðû`((­0%_¿³qËN´ß}zÕìMƒ”]ËW¼øì²¥¯Ú¸×~2uêÆÞŸï(\}`BcÏUfç»ÇÞ9ùÎo~G¢Á˜Bsë]¦Âh…±ÐAgéŒ6œO¯”øf³>^ßÝårÞ\¨9:Ò;24Ý;=t›÷¶Pk´+ú>Òsžÿ\ú“& Ë¥¬¿®“ÆÒ7H³é6úCé#í³ÀçúùÐ7´±N_0ì\¼ãyÊ¥ºj)KߥœÍß4xMR–O¸‘ì6Ü­î.7ňž»=$f»]‡‰Už(Æ€¿AAA”ãm¸Ío><nYqÏgé.ÐÄëÂqá´Ð+°}X¿„ÉI@¼ Ö/‡®.M”‰.+Ëõ«ò€ê{²%Ên2UÝô]ÕRH)R:€#ëjT:&Y•ydÆk…/¿÷£7;žé){iÅÒ]»—ß½£ÐFÛ†OBƒ°½p﮿¾žyùÝwõë÷?ø5©”×aå¾…õªPŸ«½HfQ›c¯g§³óÙe,/*6Ñ&:½Šè¤r€#Rv±r³ ÙÊã^ä¥Ëûm‘5—Ë„ †ü©¯!üÝPJR)Á²_ýÞAA/Œ掚ä}¬?63sçY9¹“ôôÉz5X[{(ùíõ®#«×‰òV•dÂoçÁuÏ\ÓÖÉì±¾àèf‹ÔØe£Ú„d@ŒÁQ2a‚48:Í•,ÊÍÞÕ\ìbÛ3b÷¹ÖÝÞÁ{ ;î0¤¸²„[¯Î? jïu™ü‚z]hŸ;LZŽŸ‹Â •¾™îÝvÆpnÚ¯œ“ÉADOÀ©yÒŽ´”v•†:ë\*ŽJO¥wL`–g–w–¿ÍÓæmó¯ä—;W*?ðýÀ¿Îùe£g£÷~ßÏíÏ9ŽÈ¯*‡}²ÿÑ÷7gü•¯7õ?“"àu„C¬{¤{­›që}—oÖCž†·‘ñqnÛ@öÌ®wÉMM¶cã÷¸¦ß£M}Ó«8¶^ ½ù0k·¯÷Óõ öòúŽSûý J¹öhÏ"¦Nuä³gû}QYoÚœâÀÿP­7 ­÷Ö"ò©å÷ø†W5Q•ç(,zã“ly,ûYwaᵉÁ«gæ w> endobj 4 0 obj << /Font <> >> endobj 5 0 obj << /CVPage1 [6 0 R /XYZ null 325 null] /CVPage1:0 [6 0 R /XYZ null 324 null] /CVPage1:1 [6 0 R /XYZ null 108 null] >> endobj 10 0 obj << /Type /Font /Subtype /TrueType /BaseFont /ZZFYEH+Arial /Name /Rx05 /FirstChar 32 /LastChar 255 /Widths 11 0 R /Encoding /WinAnsiEncoding /FontDescriptor 12 0 R >> endobj 11 0 obj [278 278 355 556 556 889 667 191 333 333 389 584 278 333 278 278 556 556 556 556 556 556 556 556 556 556 278 278 584 584 584 556 1015 667 667 722 722 667 611 778 722 278 500 667 556 833 722 778 667 778 722 667 611 722 667 944 667 667 611 278 278 278 469 556 333 556 556 500 556 556 278 556 556 222 222 500 222 833 556 556 556 556 333 500 278 556 500 722 500 500 500 334 260 334 584 750 556 750 222 556 333 1000 556 556 333 1000 667 333 1000 750 611 750 750 222 222 333 333 350 556 1000 333 1000 500 333 944 750 500 667 278 333 556 556 556 556 260 556 333 737 370 556 584 333 737 552 400 549 333 333 333 576 537 333 333 333 365 556 834 834 834 611 667 667 667 667 667 667 1000 722 667 667 667 667 278 278 278 278 722 722 778 778 778 778 778 584 778 722 722 722 722 667 667 611 556 556 556 556 556 556 889 500 556 556 556 556 278 278 278 278 556 556 556 556 556 556 556 549 611 556 556 556 556 500 556 500] endobj 12 0 obj << /Type /FontDescriptor /FontName /ZZFYEH+Arial /FontBBox [-665 -325 2000 1006] /Flags 32 /Ascent 905 /Descent -212 /Leading 117 /CapHeight 716 /XHeight 519 /AvgWidth 545 /MaxWidth 1015 /MissingWidth 750 /ItalicAngle 0 /StemV 95 /StemH 95 /FontFile2 13 0 R >> endobj xref 0 15 0000000000 65535 f 0000000018 00000 n 0000000203 00000 n 0000032868 00000 n 0000032950 00000 n 0000032999 00000 n 0000000272 00000 n 0000000385 00000 n 0000000457 00000 n 0000006226 00000 n 0000033139 00000 n 0000033334 00000 n 0000034282 00000 n 0000006249 00000 n 0000032843 00000 n trailer << /ID [<7da40ceee5f65e90361978c861c87d21> <7da40ceee5f65e90361978c861c87d21>] /Size 15 /Root 2 0 R /Info 1 0 R >> startxref 34579 %%EOF qtl/vignettes/bcsft.Rnw0000644000176200001440000010143213762244053014662 0ustar liggesusers\documentclass[12pt,fullpage]{article} %\VignetteIndexEntry{Users Guide for New BCsFt Tools for R/qtl} \usepackage{Sweave} \usepackage{fullpage} \usepackage{fancyhdr} \usepackage{amsmath} \usepackage{graphicx} \usepackage{cite} \bibliographystyle{plos} \raggedbottom \lhead{\bf R/qtl bcsft vignette} \chead{} \rhead{} \lfoot{} \cfoot{} \rfoot{} \setlength{\marginparwidth}{0pt} \setlength{\oddsidemargin}{0pt} \setlength{\evensidemargin}{0pt} \setlength{\topmargin}{0pt} \setlength{\textwidth}{16cm} \setlength{\textheight}{21cm} \setlength{\parindent}{0cm} \addtolength{\parskip}{\baselineskip} \begin{document} \title{Users Guide for New $BC_sF_t$ Tools for R/qtl} \author{Laura M. Shannon \and Brian S. Yandell \and Karl Broman} \date{29 January 2013} \maketitle \section*{Introduction} Historically QTL mapping studies have employed a variety of crossing schemes including: backcrosses \cite{Tanks}, sib-mating \cite{Sib}, selfing \cite{Collard}, RI lines \cite{fly}, and generations of random mating within mapping populations \cite{Darvasi}. Different cross designs offer different advantages. Backcrossing allows for the isolation of limited regions of the donor parent genome in an otherwise recurrent parent background. Selfing and sib-mating in an intercross provide the opportunity to examine all genotype combinations and observe dominance. RI lines allow for multiple phenotype measures on a single line. Random mating increases recombination frequency. In order to use a combination of these cross types and access their various benefits, a more flexible analysis approach is needed. \begin{figure} \includegraphics{why_we_need_a_new_program.pdf} \caption{An illustration of QTL geneotype inference in populations created through different crossing structures. All images are of a chromosome section including 2 markers (A and B) and a putative QTL (Q). Chromosomal segments are pink when they share a genotype with the lower case parent and black when they share a genotype with the capital parent. Regions where the genotype cannot be observed are dashed. Regions where the genotype is unknown are gray.} \label{Crossovers} \end{figure} This guide develops methods to analyze advanced backcrosses and lines created by repeated selfing by extending features of R/qtl \cite{Broman}. Interval mapping requires estimating the probable genotype of a putative QTL based on the neighboring markers \cite{Lander}. The probability that a loci between two genotyped markers is of a given genotype depends on the recombination history of the population, which depends on the type of cross. In Figure \ref{Crossovers} we have two markers, A and B, each with two possible allele genotypes, capital or lower case. Let us assume that markers A and B are spaced such that double crossovers in a single generation are unlikely. Let Q be the position of the putative QTL between A and B. When the observed genotypes at A and B are both homozygous capital in an $F_2$ or $BC_1$ the genotype at Q is most likely homozygous capital (Figure \ref{Crossovers} part B). However, in an $F_3$, Q might be heterozygous or homozygous for either parent (Figure \ref{Crossovers} part C). Similarly, in a $BC_2$, Q might be homozygous capital or heterozygous, when the observered genotype is AB/AB. Each generation brings an additional opportunity for crossing over within the interval, increasing the likelihood that Q will not share a genotype with A and B. This has real consequences when determining genotype probabilities (Figure \ref{Probs}). \begin{figure} \includegraphics{genotypeprobabilities.pdf} \caption{ The probability that a pair of loci is of a given genotype based on the transition probabilities from the known genotype of marker one (As) to the unknown genotype of the putative QTL (Bs).} \label{Probs} \end{figure} Genetic map creation is also based on recombination history. Assuming an $F_2$ or $BC_1$ and sufficiently close markers to make double crossovers in a single generation improbable, individuals which are homozygous for the recurrent parent allele at two adjacent markers exhibit no recombination events between those two markers (figure \ref{Crossovers} part B). However, in an $F_3$ the state of being homozygous for the recurrent parent allele at neighboring markers can be accomplished with 0, 1, or 4 recombination events (figure \ref{Crossovers} part C). If an $F_3$ is treated as an $F_2$, an individual with 2 adjacent markers homozygous for the same parent will be counted as having undergone 0 recombination events. However, the actual expected number of recombination events for the described individual is: \[r^4+\frac{r(1-r)}{8}\approx r/8~,\] where $r$ is the recombination frequency. Therefore, treating an $F_3$ as an $F_2$ would artificially shorten the map length (Figure \ref{recomb}). The number of recombination events between two markers depends on the recombination frequency and cross history, and the number of recombination events in agregate determines the map length. \begin{figure} \includegraphics{recombinationcount.pdf} \caption{Estimated recombination counts between pairs of markers with observed genotypes.} \label{recomb} \end{figure} In this guide we present our method for analyzing mapping populations with advanced cross histories while avoiding the pitfalls described above. Specifically, we address populations resulting from repeated backcrossing ($BC_s$), repeated selfing ($F_t$), and backcrossing followed by selfing ($BC_sF_t$). The first section is a tutorial on how to use the new tools. The second section lays out the way we derived the equations for probabilities and recombination counts, which allow for the analysis of advanced cross histories. The third section contains a technical description of the modifications to the code of the previous release of R/qtl \cite{Broman}. \section*{Tutorial} These changes to R/qtl are mostly internal. The one thing that does change for the user is reading in the data. Data can be read in using {\em read.cross()} as for all other crosses. We will use the listeria sample data from R/qtl below. <<>>= library(qtl) listeria.bc2s3<-read.cross(format="csv", file=system.file(file.path("sampledata", "listeria.csv"), package = "qtl"), BC.gen=2, F.gen=3) @ Here's another way to convert a cross. Suppose the R/qtl hyper data was really a $BC_3$ (or $BC_3F_0$). You can convert it as follows: <<>>= data(hyper) hyper3 <- convert2bcsft(hyper, BC.gen = 3) @ We will briefly highlight the difference in results between crosses analyzed using the traditional program and those analyzed using our new tools. However, we do not discuss the entire process of QTL mapping. Please refer to the tutorials available through rqtl.org or A Guide to QTL Mapping with R/qtl by Karl Broman \cite{bromanbook} for guidence on complete analysis. First we compare the maps for the listeria data set (figure \ref{lismap}). % est.map(listeria.bc2s3) takes time <<>>= listeria.f2<-read.cross(format="csv", file=system.file(file.path("sampledata", "listeria.csv"), package = "qtl")) map.bc2s3 <- est.map(listeria.bc2s3) map.f2<-est.map(listeria.f2) @ Now, we will compare the maps for the hyper data (figure \ref{hypmap}). <<>>= map.bc1 <- est.map(hyper) map.bc3<-est.map(hyper3) @ \begin{figure} <>= plot(map.f2, map.bc2s3, label=FALSE, main="") @ \caption{A comaprison of genetic maps of the listeria data set analyzed as though it were a $F_2$ (left) and as though it were a $BC_2F_3$ (right).} \label{lismap} \end{figure} \begin{figure} <>= plot(map.bc1, map.bc3, label=FALSE, main="") @ \caption{ A comparison of genetic maps of the hyper data set analyzed as though it were a $BC_1$ (left) and as though it were a $BC_3$(right).} \label{hypmap} \end{figure} % calc.genoprob takes time. In both cases the map length is smaller when the cross is analyzed as a $BC_sF_t$ because the same number of recombination events are attributed to multiple generations. In order to demonstrate that the cross history makes a real difference in outcome of a QTL analysis, we asign the same map to both cross objects regardless of cross history for direct comparisson. Comparing identical data sets with identical maps using the {\em scanone} command illustraits that position-wise LOD score also depends on cross history (figures \ref{lisscan} and \ref{hypscan}) . <<>>= listeria.bc2s3<-replace.map(listeria.bc2s3, map.f2) listeria.f2<-replace.map(listeria.f2, map.f2) listeria.f2<-calc.genoprob(listeria.f2, step=1 ) one.f2<-scanone(listeria.f2, method="em",pheno.col=1) listeria.bc2s3<-calc.genoprob(listeria.bc2s3, step=1 ) one.bc2s3<-scanone(listeria.bc2s3, method="em",pheno.col=1) @ \begin{figure} <>= plot(one.f2, one.bc2s3, col=c("red", "purple")) @ \caption{LOD plots for simple interval mapping with the listeria data set. The red curves are from analysis as though the population were a $F_2$. The purple curves are from analysis as though the population were a $BC_2F_3$. Both were analyzed using the same map distances to facilitate comparison} \label{lisscan} \end{figure} <<>>= hyper3<-replace.map(hyper3, map.bc1) hyper<-replace.map(hyper, map.bc1) hyper<-calc.genoprob(hyper, step=1 ) one.hyp<-scanone(hyper, method="em",pheno.col=1) hyper3<-calc.genoprob(hyper3, step=1 ) one.hyp3<-scanone(hyper3, method="em",pheno.col=1) @ \begin{figure} <>= plot(one.hyp, one.hyp3, col=c("red", "purple")) @ \caption{LOD plots for simple interval mapping with the hyper data set. The red curves are from analysis as though the population were a $BC_1$. The purple curves are from analysis as though the population were a $BC_3$. Both were analyzed using the same map distances to facilitate comparison} \label{hypscan} \end{figure} \section*{Calculations} Allowing for the analysis of $BC_SF_T$ crosses in R/qtl required two new sets of calculations: genotype probabilities for different cross histories and recombination counts for these cross histories. The genotype probabilities were derived based on Jiang and Zeng's \cite{jiang} calculations and the recombination counts are estimated using a golden section search. \subsection*{Genotype Probabilities} Jiang and Zeng \cite{jiang} provide a guide for calculating genotype frequencies resulting from several types of crosses of inbred lines. Although they examine many cases ($F_2$, selfed $F_t$, random mating $F_t$, backcross from selfed $F_t$, and $BC_s$) they do not address all possible cross structures. Most notably, they do not discuss $BC_sF_t$ crosses. In this section we derive the equations for calculating genotype probabilities for a $BC_sF_t$ cross. The equations we arrived at are heavily based on those of Jiang and Zeng. However they have been modified both to address $BC_sF_t$ cross histories and to function within the context of the existing R/qtl program. We include all the implemented equations, both new and modified, below. QTL mapping requires estimating the putative QTL genotype based on the observed genotypes of flanking markers. In all cases there are 2 parental inbred lines. Line 1 will be indicated by capital letters, while line 2 will be indicated by lower case letters. A particular descendant of these lines has a known genotype at locus A (indicated with $A$ or $a$), however the genotype at locus B (indicated with $B$ or $b$), the putative QTL, has not been observed. The genotype at locus B is dependent on the genotype at locus A, the recombination rate between locus A and locus B ($r$), and the cross history. \subsubsection*{Backcross $BC_S$} The simplest case is a $BC_1$ with line 1 as the reccurrent parent. Let $q$ be a vector of the frequency of all possible genotypes of loci A and B \[q = \left[\begin{array}{cccc}freq(\frac{AB}{AB}) & freq(\frac{Ab}{AB}) & freq(\frac{aB}{AB}) & freq(\frac{ab}{AB})\end{array}\right] = \left[\begin{array}{cccc}\frac{w}{2} & \frac{r}{2} & \frac{r}{2} & \frac{w}{2}\end{array}\right] \] where $w=1-r$. After a subsequent generation of backcrossing the genotype frequencies will change based on the probability that a pair of loci with a particular genotype will produce offspring of each genotype when backcrossed to the recurrent parent. We will call this the transition probability. In order to calculate $q$ for a $BC_2$ we will need transition probabilities for all possible genotype combinations. Let $M$ be the matrix of transition probabilities. \[M=\left[\begin{array}{llll} P \left( \frac{AB}{AB}| \frac{AB}{AB}\right) & P \left(\frac{AB}{AB}|\frac{AB}{Ab}\right) & P \left( \frac{AB}{AB} |\frac{AB}{aB}\right) & P \left( \frac{AB}{AB}|\frac{AB}{ab}\right)\\[5pt] P \left(\frac{AB}{Ab} |\frac{AB}{AB} \right) & P \left((\frac{AB}{Ab} | \frac{AB}{Ab}\right) & P \left( \frac{AB}{Ab} |\frac{AB}{aB}\right) & P \left( \frac{AB}{Ab} |\frac{AB}{ab}\right)\\[5pt] P \left( \frac{AB}{aB}|\frac{AB}{AB} \right) & P \left( \frac{AB}{aB}|\frac{AB}{Ab}\right) & P \left( \frac{AB}{aB}| \frac{AB}{aB}\right) & P \left( \frac{AB}{aB}|\frac{AB}{ab}\right)\\[5pt] P \left( \frac{AB}{ab}| \frac{AB}{AB}\right) & P \left( \frac{AB}{ab}| \frac{AB}{Ab}\right) & P \left( \frac{AB}{ab}| \frac{AB}{aB}\right) & P \left( \frac{AB}{ab}| \frac{AB}{ab}\right)\end{array} \right] = \left[\begin{array}{cccc} \frac{w}{2} & \frac{r}{2} & \frac{r}{2} & \frac {w}{2}\\[5pt] 0 & \frac{1}{2} & 0 & \frac{1}{2}\\[5pt] 0 & 0 & \frac{1}{2} & \frac{1}{2}\\[5pt] 0 & 0 & 0 & 1 \end{array}\right] \] The frequency vector from the $BC_1$ can then be multiplied by the transition matrix to arrive at a frequency vector for a $BC_2$: \[q_{BC_2} = qM~. \] With each subsequent generation of backcrossing it is necessary to multiply by the transtion matrix again. The equation for determining genotype frequencies based on any number of backcross generations ($s$) is: \[q_{BC_s}=qM^{s-1}~.\] This can be further simplified \cite{Bulmer}. $P(s,0)$ is a set of probabilities for all genotype combinations at two loci in a $BC_s$ population. It is equivalent to $q_{BC_s}$, but organized differently to make it easier to read. \[P(s,0) =\begin{array}{ccc} & BB & Bb\\[5pt] AA & A_{11} & A_{12}\\[5pt] Aa & A_{12} & A_{22} \end{array} \] When $s=1$ \[A_{11}=A_{12}=\frac{w}{2}\] \[A_{12} = \frac{r}{2} \] For any value of $s$ \[A_{11}= \frac{2^s-2+w^s}{2^s} \] \[A_{12} = \frac{1-w^s}{2^s} \] \[A_{22}= \frac{w^s}{2^s} \] Note the symmetry on the diagonal of recombinant alleles (Ab/AB and aB/AB) but not on the diagonal with only non-recombinant alleles (AB/AB and ab/AB). This asymmetry is due to the fact that $ab$ alleles are only introduced in the $F_1$ and therefore all such alleles remaining in the population have never recombined where as $AB$ alleles are introduced every generation. Genotype frequencies can be calculated for all types of crosses using a vector of initial frequencies and a transition matrix. \subsubsection*{Repeated Selfing $F_t$} Next, we will discuss the calculations for genotype frequencies from an $F_t$ population resulting from repeated selfing. This crossing structure is also sometimes refered to as an $S_t$, but we are using $F_t$ to be consistant with the notation used by R/qtl. The major difference between the calculations for an $F_t$ and a $BC_s$ is that while in a backcross one allele is always AB, so there are only 4 genotype possibilities, in an $F_t$ there are 10 genotype possibilities. \[q_{F_1}=\left[\begin{array}{cccccccccc}\frac{AB}{AB} & \frac{AB}{Ab} & \frac{Ab}{Ab} & \frac{AB}{aB} & \frac{AB}{ab} & \frac{Ab}{aB} & \frac{Ab}{ab} & \frac{aB}{aB} & \frac{aB}{ab} & \frac{ab}{ab}\end{array}\right] =\left[\begin{array}{cccccccccc}0&0&0&0&1&0&0&0&0&0\end{array}\right] \] The transition matrix for an $F_t$ is the same as Jiang and Zeng \cite{jiang}: \[N=\left[\begin{array}{cccccccccc} 1 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\[5pt] \frac{1}{4} & \frac{1}{2} & \frac{1}{4} & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\[5pt] 0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\[5pt] \frac{1}{4} & 0 & 0 & \frac{1}{2} & 0 & 0 & 0 & \frac{1}{4} & 0 & 0 \\[5pt] \frac{w^2}{4} & \frac{rw}{2} & \frac{r^2}{4} & \frac{rw}{2}& \frac{w^2}{2} & \frac{r^2}{2} & \frac{rw}{2} & \frac{r^2}{4} & \frac{rw}{2} & \frac{w^2}{4}\\[5pt] \frac{r^2}{4} & \frac{rw}{2} & \frac{w^2}{4} & \frac{rw}{2}& \frac{r^2}{2} & \frac{w^2}{2} & \frac{rw}{2} & \frac{w^2}{4} & \frac{rw}{2} & \frac{r^2}{4}\\[5pt] 0 & 0 & \frac{1}{4} & 0 & 0 & 0 & \frac{1}{2} & 0 & 0 & \frac{1}{4} \\[5pt] 0 & 0 & 0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 \\[5pt] 0 & 0 & 0 & 0 & 0 & 0 & 0 & \frac{1}{4} & \frac{1}{2} & \frac{1}{4} \\[5pt] 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 1\end{array} \right] \] Again, these can be multiplied to arrive at the probability of all genotypes in the $F_t$. \[q_{F_t}=q_{F_1}N^{t-1}\] This can be simplified. $P(0,t)$ contains the probabilities for all genotype combinations for two loci in an $F_t$ population (once again it is equivalent to $q_{F_t}$ reorganizes). \[P(0,t) = \begin{array}{ccccc} & BB & Bb & bB & bb\\[5pt] AA & B_{11} & B_{12} & B_{12} & B_{14}\\[5pt] Aa & B_{12} & B_{22} & B_{23} & B_{12}\\[5pt] aA & B_{12} & B_{23} & B_{22} & B_{12}\\[5pt] aa & B_{14} & B_{12} & B_{12} & B_{11} \end{array} \] The probabilities $B_{ij}$ of ending up in a particular genotype after $t$ generations can be modeled in terms of generations spent in the double heterozygous stage (at least 1, as $F_1$ is a double heterozygote), the probability of moving from that genotype to either one of the intermediate stages or to a double homozygote, the time spent at an intermediate stage (could be 0), and the probability of moving from an intermediate stage to a double homozygote. There are four transient states (double heterozygotes), 8 intermediate states (single heterozygotes) and 4 absorbing states (double heterozygotes). The only genotypes which can produce all other genotypes are the transient double heterozygotes ($B_{22}$ and $B_{23}$). Therefore with each generation there is an exponential decay in the probability of remaining in the double heterozygous state. In order to remain in the double heterozygous state there either has to be no recombination ($w^2$) or a double recombination event ($r^2$) in every generation. In order to model this we reparameterize $w^2$ and $r^2$ as $\beta$ and $\gamma$, specifically $\beta+\gamma=w^2$ while $\beta-\gamma = r^2$. $\beta$ is also the probability of remaining in a double heterozygous state given that the line started in one of the two double heterozygous states in a single generation. \[B_{22}= \frac{\beta^{t-1}+\gamma^{t-1}}{2} \] \[B_{23}= \frac{\beta^{t-1}-\gamma^{t-1}}{2} \] \[ \beta=\frac{w^2+r^2}{2} \] \[\gamma= \frac{w^2 - r^2}{2}\] The 8 intermediate states, with one locus homozygous and one heterozygous. During one of the previous generations, one locus was fixed while the other remained heterozygous. There are two exponential decays, with the transition point unknown. After some simplification, this can be expressed as$B_{12}$: \[B_{12}=\frac{rw\left(\frac{1}{2^{t-1}}-\beta^{t-1}\right)}{1-2\beta} \] Finally, the four absorbing states, heterozygous at both loci, can be reached from a number of paths, involving simultaneous or separate fixation of both loci. The calculations are more involved, but simplify ty $B_{11}$ or $B_{14}$: \[B_{11}= f(w,r)= \frac{1}{8} \left[ w^2 \left(g \left(\beta, t \right) + g \left( \gamma, t \right) \right) + r^2 \left(g \left( \beta, t \right) - g \left( \gamma, t \right) \right) \right] + \frac{rw}{5} \left[g \left( \beta ,t \right) + g \left(2\beta , t-1 \right) \right] \] \[B_{14}=f(r,w) \] With: \[g\left( \beta, t \right) = (1-\beta^{t-1}) / (1-\beta)~.\] Unlike P(s,0), P(0,t) is symmetric on both diagonals because both parental alleles are equally present in the $F_1$ and never introgressed again. One major difference between working with a backcross and an $F_t$ is that while in a backcross phase is always known, in an $F_t$ phase cannot be observed. When dealing with phase unknown data the two heterozygote cases can be collapsed as follows: \[ \begin{array}{cccc} & BB & Bb & bb\\[5pt] AA & B_{11} & 2B_{12} & B_{14}\\[5pt] Aa & 2B_{12} & 2\left(B_{22}+ B_{23}\right) & 2B_{12}\\[5pt] aa & B_{14} & 2B_{12} & B_{11} \end{array} \] Since we cannot distinguish between the two heterozygote classes we add them and report the frequency of both. The final difference between backcross and $F_t$ calculations is that for $F_t$ populations it is possible to have partially informative markers. Partially informative markers can only be interpreted as not belonging to a particular homozygous class. For instance if a marker were measured using the presence or absence of a band on a gel, heterozygotes would be indistinguishable from the homozygous present class. We will refer to partially informative markers as either "not AA" or "not aa". In order to calculate the probability of partially informative markers we add the probabilities of the genotypes we cannot distinguish between, much like the phase unknown case above. For example, $not\; AA/BB$ could be $Aa/BB$, $aA/BB$, or $aa/BB$ so we sum all of those probabilties to get $2B_{12}+B_{14}$. All other genotypes with partially informative markers can be calculated similarly. \subsubsection*{Backcrossing followed by selfing $BC_sF_t$} The described equations for the $BC_s$ and the $F_t$ form the basis for the $BC_sF_t$. The two types of crosses can be thought of sequentially. The $BC_s$ that forms the first steps of the $BC_SF_t$ is exactly the same as the $BC_S$ on it's own. The difference between calculating an $F_t$ which follows several genetations of backcrossing and one which follows an $F_1$ is the vector of starting genotype frequencies. In this case the starting genotype frequencies can be supplied by $q_{BC_S}=qM^{s-1}$. The six genotypes not represented all have starting frequency 0. \[q_{BC_SF_0} =\left[\begin{array}{cccccccccc} \frac{2^s-2+w^s}{2^s} & \frac{1-w^s}{2^s} & 0 & \frac{1-w^s}{2^s} & \frac{w^s}{2^s} & 0 & 0 & 0 & 0 & 0\end{array}\right] \] The $q$ resulting from this modification of $q_{BC_S}$ can be multiplied by the $F_t$ transition matrix. Much like in the previous cases this can be simplified. $P(s,t)$ contains the probabilities of all possible genotype combinations at two loci for a $BC_sF_t$. Below, we explicitly identify the parts of the equations from the backcross (A) and selfing (B) probablities. \[P(s,t) = \begin{array}{ccccc} & BB & Bb & bB & bb\\[5pt] AA & C_{11} & C_{12} & C_{12} & C_{14}\\[5pt] Aa & C_{12} & C_{22} & C_{23} & C_{24}\\[5pt] aA & C_{12} & C_{23} & C_{22} & C_{24}\\[5pt] aa & C_{14} & C_{24} & C_{24} & C_{44} \end{array} \] Where: \[C_{22}= A_{22}(s)B_{22}(t) \] \[C_{23}= A_{22}(s)B_{23}(t) \] \[C_{12}= A_{22}(s)B_{12}(t) + A_{12}(s)\left(\frac{1}{2}\right)^t \] \[C_{24}=A_{22}(s)B_{12}(t) \] \[C_{11}= A_{22}(s)B_{11}(t)+A_{12}(s)\left(1-\left(\frac{1}{2}\right)^t\right)+A_{11}(s) \] \[C_{14}= A_{22}(s)B_{11}(t)+A_{12}(s)\left(1-\left(\frac{1}{2}\right)^t\right) \] \[C_{44}=A_{22}(s)B_{11}(t) \] Because these probabilities depend on the backcross probabilities there is only symmetry on one diagonal when $s>0$. Partially informative markers and phase unknown data can be treated the same way as an $F_t$. \subsection*{Recombination Counts} In the previous implementation of R/qtl recombination counts were calculated, however for advanced crossing schemes there is no direct analytic solution. Instead we implemented a hill climbing algorithm using a golden section search \cite{Kiefer} which determines the most probable recombination frequency, rather than calculating an actual value. The search space starts between 0 and 0.5 (all possible recombination frequencies). The golden section search relies on comparing three points (figure \ref{search}). To start with the points are $r=0$, $r=0.5$, and $r=r_1$, where the value of $r_1$ is determined so that the ratio of a to a+b is equal to the ratio of a to b. Then a new point ($r=r_2$) is added in the larger interval so that the ratio of d to a is equal to the ratio of c to d. The set of 3 $r$ values containing the highest maximum likelihood (as compared to the null model of unlinked markers $r=0.5$) are kept, and the remaining value is dropped (in this case $r=0.5$). The search algorithm starts again with 0, $r_1$, and $r_2$ as the three points. This process repeats until tolerance for the minimum improvement in likelihood is reached, then the $r$ value with the highest likelihood is reported as the maximum likelihodd estimate used in the map. This provides an accurate estimate of recombination frequency. \begin{figure} \includegraphics{goldensectionsearch.pdf} \caption{An illustration of the golden section search} \label{search} \end{figure} \subsection*{A Note on Intercrosses and Random Matings} These equations are accurate for $BC_sF_t$ when $F_t$ refers to any number of selfed generations. We have not implemented code to address advanced intercross lines resulting from sib mating or random mating within an advanced cross. Below we sketch ideas to develop these algorithms. In an $F_2$, selfing and sib-mating are interchangeable in terms of calculations because the entire population has an identical $F_1$ genotype. However after the $F_2$, calculations get more complicated for sib-mated populations. Each $F_2$ is sib-mated to create an $F_3$. Sib-mating brings the added complication that we need to think about families instead of individuals. There are 10 possible $F_2$ genotypes leading to 55 possible combinations of cross parents and their next generation families. A transition matrix ($L$) analagous to the one for selfing ($N$) would have to be 55 x 55 and account for the probability that a family that resulted from a cross between a particular set of parents in the $F_{t-2}$ would yield a cross between another set of parents in the $F_{t-1}$. This would be multiplied by a vector of 55 starting probabilities for the $F_1$ ($q_{F_1}^*$), these being probabilities of genotypes for specific crosses rather than for individuals. Of course, for the $F_1$, there is only one type of cross $AB/ab X AB/ab$ which can be the parents of the $F_2$, and the probability of the other 54 types of crosses is 0. Multiplying these successively will result in the probabilities of the crosses that produce the $F_t$, since our actual question is the probability of the genotypes of the $F_t$ where one individual is selected from each family, we will need a second matrix, K. This matrix will give the probability for each of the 10 possible genotypes results based on the 55 possible crosses. The final result will be the probability of the 10 genotypes ($q_{F_t}$). The equation for the genotype probabilities after t generations of intercrossing, then is: \[q_{F_t}=(q_{F_1}L^{t-2})K~.\] Note that the selfed $F_t$ is a special case with only the 10 selfings of the 55 possible crosses being non-zero. In general, this formal equation can be simplified substantially by using symmetry arguments, and implemented in a similar manner to the selfing case. Transient and absorbing states can be handled in an analogous but somewhat more complicated manner to the selfed case. However, the devil is in the details! We consider the case of random mating after $s$ generations of backcross and $t$ generations of selfing. We begin with the $q_{BC_s F_t}$ 10-vector of phase-known genotype frequencies, and multiply by a 10$\times$4 matrix ($J$) to convert these frequencies into the four possible two-locus alleles ($u$). These allele frequencies are cross multiplied ($u_Tu$) to create a 4$\times$4 matrix of random mating frequencis of genotypes, which are then reduced to the 10-vector format of phase-known genotype frequencies ($q_{BC_s F_t R}$). Eight of the rows of the matrix $J$ are simple (0, 0.5 or 1 values), while the middle two involve the possible recombinants and non-recombinants: \[J= \begin{array}{ccccc} & AB & Ab & aB & ab \\[5pt] \frac{AB}{AB} & 1 & 0 & 0 & 0\\[5pt] \frac{AB}{Ab} & \frac{1}{2} & \frac{1}{2} & 0 & 0\\[5pt] \frac{Ab}{Ab} & 0 & 1 & 0 & 0 \\[5pt] \frac{AB}{aB} & \frac{1}{2} & 0 & \frac{1}{2} & 0 \\[5pt] \frac{AB}{ab} & \frac{w}{2} & \frac{r}{2} & \frac{r}{2} & \frac{w}{2} \\[5pt] \frac{aB}{Ab} & \frac{r}{2} & \frac{w}{2} & \frac{w}{2} & \frac{r}{2}\\[5pt] \frac{ab}{Ab} & 0 & \frac{1}{2} & 0 & \frac{1}{2} \\[5pt] \frac{aB}{aB} & 0 & 0 & 1 & 0 \\[5pt] \frac{ab}{aB} & 0 & 0 & \frac{1}{2} & \frac{1}{2} \\[5pt] \frac{ab}{ab} & 0 & 0 & 0 & 1 \end{array} \] Extension to sib-mating instead of selfing follows directly. Extension to selfing or sib-mating after random mating follows as for the $F_t$ approach outlined earlier. Again, the devil is in the details. \section*{Code modifications in R/qtl} Our goal was to make R/qtl fully functional for a wider variety of cross types. Ideally these changes will be minimally visible to the user after inputing the cross type. In order to create an identical user experience we had to modify all R routines so that they would recognize the \texttt{bcsft} cross type. Cross objects in R/qtl all have the attribute "class" consisting of 2 parts: one which identifies it as a cross object and one which specifies the cross type (\texttt{bc}, \texttt{f2}, \texttt{riself}, \texttt{risib}, etc.). We added an additional option, \texttt{bcsft}. A major difference between the previous cross types and \texttt{bcsft}, all other cross types are specific. In that there are no options for types of backcrosses, it's just a backcross. With the $BC_sF_t$ we intentionally created a more flexible cross type, where the generation number can be set by the user. This means that we don't have to go back and add a cross type every time we want to analyze a population with a different history. The way we have created this flexibity is by adding the attribute \texttt{cross.scheme} to cross objects. The \texttt{cross.scheme} consists of two numbers, the first is the generations of backcrossing (s), the second is the generations of selfing (t). The addition of a cross type and an attribute allow all R routines to recognize all types of $BC_sF_t$ crosses. The previous sections detailed the way genotype probabilities and recombination counts are calculated for $BC_sF_t$ crosses. These calculations are contained within the specific \texttt{init}, \texttt{emit}, and \texttt{step} functions for \texttt{bcsft} within the C code. All three of these functions are used in the Hidden Markov Model (HMM). The \texttt{init} function determines the probability of true genotypes. The \texttt{emit} function determines the probability of observed genotypes given the true genotypes, while the \texttt{step} function determines the probability of a genotype at a particular locus given the genotype at a linked locus as described in the previous section. We created $BC_sF_t$ versions of all of these functions which follow the same format and work the same way as the existing versions, except for when they are called by \texttt{ est.map}. We did not find a closed form solution for calculating the number of recombination events between pairs of markers in a $BC_sF_t$ and so we implemented a golden section search as part of \texttt{est.map} instead. There is a second difference between the way the HMM is implemented for $BC_sF_t$ and all other types of crosses, leading to an improvement in efficiency with no effect on the estimates. Previously the probabilities for each pair of markers for each individual were calculated independently given the recombination rate between those markers in the entire data set. For the $BC_sF_t$ the entire set of probabilities is calculated once for a set of markers given the recombination rate and then applied to all individuals. In a population with 100 lines, this is the difference between 10 calculations (1 for each possible genotype combination) and 100 calculations. This method could be readily expanded to analyze populations with mixed cross histories (where some lines have undergone more generations of selfing or backcrossing than others). Recombination rates could be calculated across all individuals and then probabilities would be calculated separately for each cross history and applied to pairs of markers in an individual according to cross history. However, record keeping about cross histories for each individual line would need to be implemented in the package. Genotype probabilities differ for the autosomes and sex chromosomes. While this is not an issue for selfed populations it could be an issue in an advanced backcross or advanced intercross populations. We have arranged for proper handling of the X chromosome. Basically in an $F_t$ the X chromosome is treated as though it were the product of a $BC_t$. The only real change here is that we created the capacity to keep track of $t$. All changes to the program have been unit tested and that code is included in the package. %\section*{References} % The bibtex filename \bibliography{vignette} \end{document} qtl/vignettes/plos.bst0000644000176200001440000006372512770016226014571 0ustar liggesusers%% %% This is file `PLoS.bst', %% generated with the docstrip utility. %% %% The original source files were: %% %% merlin.mbs (with options: `annote,seq-no,nm-rvx,ed-rev,jnrlst,nmlm,x5,m5,dt-beg,yr-par,xmth,yrp-x,jxper,jttl-rm,vnum-x,pp-last,num-xser,jnm-x,btit-rm,bt-rm,pg-bk,add-pub,pre-pub,doi,in-col,pp,xedn,jabr,xand,eprint,url,url-blk,nfss,') %% ---------------------------------------- %% *** This works for PLoS (as of October. 2008) *** %% **** Updated Oct. 2008 by JZR %% %% Copyright 1994-2004 Patrick W Daly % =============================================================== % IMPORTANT NOTICE: % This bibliographic style (bst) file has been generated from one or % more master bibliographic style (mbs) files, listed above. % % This generated file can be redistributed and/or modified under the terms % of the LaTeX Project Public License Distributed from CTAN % archives in directory macros/latex/base/lppl.txt; either % version 1 of the License, or any later version. % =============================================================== % Name and version information of the main mbs file: % \ProvidesFile{merlin.mbs}[2004/02/09 4.13 (PWD, AO, DPC)] % For use with BibTeX version 0.99a or later %------------------------------------------------------------------- % This bibliography style file is intended for texts in ENGLISH % This is a numerical citation style, and as such is standard LaTeX. % It requires no extra package to interface to the main text. % The form of the \bibitem entries is % \bibitem{key}... % Usage of \cite is as follows: % \cite{key} ==>> [#] % \cite[chap. 2]{key} ==>> [#, chap. 2] % where # is a number determined by the ordering in the reference list. % The order in the reference list is that by which the works were originally % cited in the text, or that in the database. %--------------------------------------------------------------------- ENTRY { address annote archive author booktitle chapter doi edition editor eid eprint howpublished institution journal key month note number organization pages publisher school series title type url volume year } {} { label } INTEGERS { output.state before.all mid.sentence after.sentence after.block } FUNCTION {init.state.consts} { #0 'before.all := #1 'mid.sentence := #2 'after.sentence := #3 'after.block := } STRINGS { s t} FUNCTION {output.nonnull} { 's := output.state mid.sentence = { ", " * write$ } { output.state after.block = { add.period$ write$ newline$ "\newblock " write$ } { output.state before.all = 'write$ { add.period$ " " * write$ } if$ } if$ mid.sentence 'output.state := } if$ s } FUNCTION {output} { duplicate$ empty$ 'pop$ 'output.nonnull if$ } FUNCTION {output.check} { 't := duplicate$ empty$ { pop$ "empty " t * " in " * cite$ * warning$ } 'output.nonnull if$ } FUNCTION {fin.entry} { add.period$ write$ newline$ annote missing$ { "\bibAnnoteFile{" cite$ * "}" * write$ newline$ } { "\bibAnnote{" cite$ * "}{" * annote * "}" * write$ newline$ } if$ } FUNCTION {new.block} { output.state before.all = 'skip$ { after.block 'output.state := } if$ } FUNCTION {new.sentence} { output.state after.block = 'skip$ { output.state before.all = 'skip$ { after.sentence 'output.state := } if$ } if$ } FUNCTION {add.blank} { " " * before.all 'output.state := } FUNCTION {date.block} { add.blank } FUNCTION {not} { { #0 } { #1 } if$ } FUNCTION {and} { 'skip$ { pop$ #0 } if$ } FUNCTION {or} { { pop$ #1 } 'skip$ if$ } STRINGS {z} FUNCTION {remove.dots} { 'z := "" { z empty$ not } { z #1 #1 substring$ z #2 global.max$ substring$ 'z := duplicate$ "." = 'pop$ { * } if$ } while$ } FUNCTION {new.block.checka} { empty$ 'skip$ 'new.block if$ } FUNCTION {new.block.checkb} { empty$ swap$ empty$ and 'skip$ 'new.block if$ } FUNCTION {new.sentence.checka} { empty$ 'skip$ 'new.sentence if$ } FUNCTION {new.sentence.checkb} { empty$ swap$ empty$ and 'skip$ 'new.sentence if$ } FUNCTION {field.or.null} { duplicate$ empty$ { pop$ "" } 'skip$ if$ } FUNCTION {emphasize} { duplicate$ empty$ { pop$ "" } { "\emph{" swap$ * "}" * } if$ } FUNCTION {tie.or.space.prefix} { duplicate$ text.length$ #3 < { "~" } { " " } if$ swap$ } FUNCTION {capitalize} { "u" change.case$ "t" change.case$ } FUNCTION {space.word} { " " swap$ * " " * } % Here are the language-specific definitions for explicit words. % Each function has a name bbl.xxx where xxx is the English word. % The language selected here is ENGLISH FUNCTION {bbl.and} { "and"} FUNCTION {bbl.etal} { "et~al." } FUNCTION {bbl.editors} { "editors" } FUNCTION {bbl.editor} { "editor" } FUNCTION {bbl.edby} { "edited by" } FUNCTION {bbl.edition} { "edition" } FUNCTION {bbl.volume} { "volume" } FUNCTION {bbl.of} { "of" } FUNCTION {bbl.number} { "number" } FUNCTION {bbl.nr} { "no." } FUNCTION {bbl.in} { "in" } FUNCTION {bbl.pages} { "pp." } FUNCTION {bbl.page} { "p." } FUNCTION {bbl.chapter} { "chapter" } FUNCTION {bbl.techrep} { "Technical Report" } FUNCTION {bbl.mthesis} { "Master's thesis" } FUNCTION {bbl.phdthesis} { "Ph.D. thesis" } MACRO {jan} {"January"} MACRO {feb} {"February"} MACRO {mar} {"March"} MACRO {apr} {"April"} MACRO {may} {"May"} MACRO {jun} {"June"} MACRO {jul} {"July"} MACRO {aug} {"August"} MACRO {sep} {"September"} MACRO {oct} {"October"} MACRO {nov} {"November"} MACRO {dec} {"December"} MACRO {acmcs} {"ACM Comput. Surv."} MACRO {acta} {"Acta Inf."} MACRO {cacm} {"Commun. ACM"} MACRO {ibmjrd} {"IBM J. Res. Dev."} MACRO {ibmsj} {"IBM Syst.~J."} MACRO {ieeese} {"IEEE Trans. Software Eng."} MACRO {ieeetc} {"IEEE Trans. Comput."} MACRO {ieeetcad} {"IEEE Trans. Comput. Aid. Des."} MACRO {ipl} {"Inf. Process. Lett."} MACRO {jacm} {"J.~ACM"} MACRO {jcss} {"J.~Comput. Syst. Sci."} MACRO {scp} {"Sci. Comput. Program."} MACRO {sicomp} {"SIAM J. Comput."} MACRO {tocs} {"ACM Trans. Comput. Syst."} MACRO {tods} {"ACM Trans. Database Syst."} MACRO {tog} {"ACM Trans. Graphic."} MACRO {toms} {"ACM Trans. Math. Software"} MACRO {toois} {"ACM Trans. Office Inf. Syst."} MACRO {toplas} {"ACM Trans. Progr. Lang. Syst."} MACRO {tcs} {"Theor. Comput. Sci."} FUNCTION {bibinfo.check} { swap$ duplicate$ missing$ { pop$ pop$ "" } { duplicate$ empty$ { swap$ pop$ } { swap$ pop$ } if$ } if$ } FUNCTION {bibinfo.warn} { swap$ duplicate$ missing$ { swap$ "missing " swap$ * " in " * cite$ * warning$ pop$ "" } { duplicate$ empty$ { swap$ "empty " swap$ * " in " * cite$ * warning$ } { swap$ pop$ } if$ } if$ } FUNCTION {format.eprint} { eprint duplicate$ empty$ 'skip$ { "\eprint" archive empty$ 'skip$ { "[" * archive * "]" * } if$ "{" * swap$ * "}" * } if$ } FUNCTION {format.url} { url empty$ { "" } { "\urlprefix\url{" url * "}" * } if$ } STRINGS { bibinfo} INTEGERS { nameptr namesleft numnames } FUNCTION {format.names} { 'bibinfo := duplicate$ empty$ 'skip$ { 's := "" 't := #1 'nameptr := s num.names$ 'numnames := numnames 'namesleft := { namesleft #0 > } { s nameptr "{vv~}{ll}{ f{}}{ jj}" format.name$ remove.dots bibinfo bibinfo.check 't := nameptr #1 > { nameptr #5 #1 + = numnames #5 > and { "others" 't := #1 'namesleft := } 'skip$ if$ namesleft #1 > { ", " * t * } { "," * s nameptr "{ll}" format.name$ duplicate$ "others" = { 't := } { pop$ } if$ t "others" = { " " * bbl.etal * } { " " * t * } if$ } if$ } 't if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ } if$ } FUNCTION {format.names.ed} { format.names } FUNCTION {format.authors} { author "author" format.names } FUNCTION {get.bbl.editor} { editor num.names$ #1 > 'bbl.editors 'bbl.editor if$ } FUNCTION {format.editors} { editor "editor" format.names duplicate$ empty$ 'skip$ { "," * " " * get.bbl.editor * } if$ } FUNCTION {format.book.pages} { pages "pages" bibinfo.check duplicate$ empty$ 'skip$ { " " * bbl.pages * } if$ } FUNCTION {format.doi} { doi "doi" bibinfo.check duplicate$ empty$ 'skip$ { new.block "\doi{" swap$ * "}" * } if$ } FUNCTION {format.note} { note empty$ { "" } { note #1 #1 substring$ duplicate$ "{" = 'skip$ { output.state mid.sentence = { "l" } { "u" } if$ change.case$ } if$ note #2 global.max$ substring$ * "note" bibinfo.check } if$ } FUNCTION {format.title} { title duplicate$ empty$ 'skip$ { "t" change.case$ } if$ "title" bibinfo.check } FUNCTION {output.bibitem} { newline$ "\bibitem{" write$ cite$ write$ "}" write$ newline$ "" before.all 'output.state := } FUNCTION {n.dashify} { 't := "" { t empty$ not } { t #1 #1 substring$ "-" = { t #1 #2 substring$ "-" = not %{ "--" * { "-" * t #2 global.max$ substring$ 't := } { { t #1 #1 substring$ "-" = } { "-" * t #2 global.max$ substring$ 't := } while$ } if$ } { t #1 #1 substring$ * t #2 global.max$ substring$ 't := } if$ } while$ } FUNCTION {word.in} { bbl.in capitalize ":" * " " * } FUNCTION {format.date} { "" duplicate$ empty$ year "year" bibinfo.check duplicate$ empty$ { swap$ 'skip$ { "there's a month but no year in " cite$ * warning$ } if$ * } { swap$ 'skip$ { swap$ " " * swap$ } if$ * } if$ duplicate$ empty$ 'skip$ { before.all 'output.state := " (" swap$ * ")" * } if$ } FUNCTION {format.btitle} { title "title" bibinfo.check duplicate$ empty$ 'skip$ { } if$ } FUNCTION {either.or.check} { empty$ 'pop$ { "can't use both " swap$ * " fields in " * cite$ * warning$ } if$ } FUNCTION {format.bvolume} { volume empty$ { "" } { bbl.volume volume tie.or.space.prefix "volume" bibinfo.check * * series "series" bibinfo.check duplicate$ empty$ 'pop$ { swap$ bbl.of space.word * swap$ emphasize * } if$ "volume and number" number either.or.check } if$ } FUNCTION {format.number.series} { volume empty$ { number empty$ { series field.or.null } { series empty$ { number "number" bibinfo.check } { output.state mid.sentence = { bbl.number } { bbl.number capitalize } if$ number tie.or.space.prefix "number" bibinfo.check * * bbl.in space.word * series "series" bibinfo.check * } if$ } if$ } { "" } if$ } FUNCTION {format.edition} { edition duplicate$ empty$ 'skip$ { output.state mid.sentence = { "l" } { "t" } if$ change.case$ "edition" bibinfo.check " " * bbl.edition * } if$ } INTEGERS { multiresult } FUNCTION {multi.page.check} { 't := #0 'multiresult := { multiresult not t empty$ not and } { t #1 #1 substring$ duplicate$ "-" = swap$ duplicate$ "," = swap$ "+" = or or { #1 'multiresult := } { t #2 global.max$ substring$ 't := } if$ } while$ multiresult } FUNCTION {format.pages} { pages duplicate$ empty$ 'skip$ { duplicate$ multi.page.check { bbl.pages swap$ n.dashify } { bbl.page swap$ } if$ tie.or.space.prefix "pages" bibinfo.check * * } if$ } FUNCTION {format.journal.pages} { pages duplicate$ empty$ 'pop$ { swap$ duplicate$ empty$ { pop$ pop$ format.pages } { ": " * swap$ n.dashify "pages" bibinfo.check * } if$ } if$ } FUNCTION {format.journal.eid} { eid "eid" bibinfo.check duplicate$ empty$ 'pop$ { swap$ duplicate$ empty$ 'skip$ { ": " * } if$ swap$ * } if$ } FUNCTION {format.vol.num.pages} { volume field.or.null duplicate$ empty$ 'skip$ { "volume" bibinfo.check } if$ } FUNCTION {format.chapter.pages} { chapter empty$ { "" } { type empty$ { bbl.chapter } { type "l" change.case$ "type" bibinfo.check } if$ chapter tie.or.space.prefix "chapter" bibinfo.check * * } if$ } FUNCTION {format.booktitle} { booktitle "booktitle" bibinfo.check } FUNCTION {format.in.ed.booktitle} { format.booktitle duplicate$ empty$ 'skip$ { editor "editor" format.names.ed duplicate$ empty$ 'pop$ { "," * " " * get.bbl.editor ", " * * swap$ * } if$ word.in swap$ * } if$ } FUNCTION {empty.misc.check} { author empty$ title empty$ howpublished empty$ month empty$ year empty$ note empty$ and and and and and { "all relevant fields are empty in " cite$ * warning$ } 'skip$ if$ } FUNCTION {format.thesis.type} { type duplicate$ empty$ 'pop$ { swap$ pop$ "t" change.case$ "type" bibinfo.check } if$ } FUNCTION {format.tr.number} { number "number" bibinfo.check type duplicate$ empty$ { pop$ bbl.techrep } 'skip$ if$ "type" bibinfo.check swap$ duplicate$ empty$ { pop$ "t" change.case$ } { tie.or.space.prefix * * } if$ } FUNCTION {format.article.crossref} { key duplicate$ empty$ { pop$ journal duplicate$ empty$ { "need key or journal for " cite$ * " to crossref " * crossref * warning$ } { "journal" bibinfo.check emphasize word.in swap$ * } if$ } { word.in swap$ * " " *} if$ " \cite{" * crossref * "}" * } FUNCTION {format.crossref.editor} { editor #1 "{vv~}{ll}" format.name$ "editor" bibinfo.check editor num.names$ duplicate$ #2 > { pop$ "editor" bibinfo.check " " * bbl.etal * } { #2 < 'skip$ { editor #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = { "editor" bibinfo.check " " * bbl.etal * } { bbl.and space.word * editor #2 "{vv~}{ll}" format.name$ "editor" bibinfo.check * } if$ } if$ } if$ } FUNCTION {format.book.crossref} { volume duplicate$ empty$ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ pop$ word.in } { bbl.volume capitalize swap$ tie.or.space.prefix "volume" bibinfo.check * * bbl.of space.word * } if$ editor empty$ editor field.or.null author field.or.null = or { key empty$ { series empty$ { "need editor, key, or series for " cite$ * " to crossref " * crossref * warning$ "" * } { series emphasize * } if$ } { key * } if$ } { format.crossref.editor * } if$ " \cite{" * crossref * "}" * } FUNCTION {format.incoll.inproc.crossref} { editor empty$ editor field.or.null author field.or.null = or { key empty$ { format.booktitle duplicate$ empty$ { "need editor, key, or booktitle for " cite$ * " to crossref " * crossref * warning$ } { word.in swap$ * } if$ } { word.in key * " " *} if$ } { word.in format.crossref.editor * " " *} if$ " \cite{" * crossref * "}" * } FUNCTION {format.org.or.pub} { 't := "" address empty$ t empty$ and 'skip$ { address "address" bibinfo.check * t empty$ 'skip$ { address empty$ 'skip$ { ": " * } if$ t * } if$ } if$ } FUNCTION {format.publisher.address} { publisher "publisher" bibinfo.warn format.org.or.pub } FUNCTION {format.organization.address} { organization "organization" bibinfo.check format.org.or.pub } FUNCTION {article} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.title "title" output.check new.block crossref missing$ { journal remove.dots "journal" bibinfo.check "journal" output.check add.blank format.vol.num.pages output } { format.article.crossref output.nonnull } if$ eid empty$ { format.journal.pages } { format.journal.eid } if$ % format.doi output % new.block % format.url output % new.block % format.note output % format.eprint output fin.entry } FUNCTION {book} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ format.date "year" output.check date.block format.btitle "title" output.check crossref missing$ { format.bvolume output new.block format.number.series output new.sentence format.publisher.address output } { new.block format.book.crossref output.nonnull } if$ format.edition output format.book.pages output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {booklet} { output.bibitem format.authors output format.date output date.block format.title "title" output.check new.block howpublished "howpublished" bibinfo.check output address "address" bibinfo.check output format.book.pages output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {inbook} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ format.date "year" output.check date.block format.btitle "title" output.check crossref missing$ { format.publisher.address output format.bvolume output format.chapter.pages "chapter and pages" output.check new.block format.number.series output new.sentence } { format.chapter.pages "chapter and pages" output.check new.block format.book.crossref output.nonnull } if$ format.edition output format.pages "pages" output.check format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {incollection} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.title "title" output.check new.block crossref missing$ { format.in.ed.booktitle "booktitle" output.check format.publisher.address output format.bvolume output format.number.series output format.chapter.pages output new.sentence format.edition output } { format.incoll.inproc.crossref output.nonnull format.chapter.pages output } if$ format.pages "pages" output.check format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {inproceedings} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.title "title" output.check new.block crossref missing$ { format.in.ed.booktitle "booktitle" output.check new.sentence publisher empty$ { format.organization.address output } { organization "organization" bibinfo.check output format.publisher.address output } if$ format.bvolume output format.number.series output } { format.incoll.inproc.crossref output.nonnull } if$ format.pages "pages" output.check format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {conference} { inproceedings } FUNCTION {manual} { output.bibitem author empty$ { organization "organization" bibinfo.check duplicate$ empty$ 'pop$ { output address "address" bibinfo.check output } if$ } { format.authors output.nonnull } if$ format.date output date.block format.btitle "title" output.check author empty$ { organization empty$ { address new.block.checka address "address" bibinfo.check output } 'skip$ if$ } { organization address new.block.checkb organization "organization" bibinfo.check output address "address" bibinfo.check output } if$ format.edition output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {mastersthesis} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.btitle "title" output.check new.block bbl.mthesis format.thesis.type output.nonnull school "school" bibinfo.warn output address "address" bibinfo.check output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {misc} { output.bibitem format.authors output format.date output title howpublished new.block.checkb format.title output howpublished new.block.checka howpublished "howpublished" bibinfo.check output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry empty.misc.check } FUNCTION {phdthesis} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.btitle "title" output.check new.block bbl.phdthesis format.thesis.type output.nonnull school "school" bibinfo.warn output address "address" bibinfo.check output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {proceedings} { output.bibitem editor empty$ { organization "organization" bibinfo.check output } { format.editors output.nonnull } if$ format.date "year" output.check date.block format.btitle "title" output.check format.bvolume output format.number.series output editor empty$ { publisher empty$ 'skip$ { new.sentence format.publisher.address output } if$ } { publisher empty$ { new.sentence format.organization.address output } { new.sentence organization "organization" bibinfo.check output format.publisher.address output } if$ } if$ format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {techreport} { output.bibitem format.authors "author" output.check format.date "year" output.check date.block format.title "title" output.check new.block format.tr.number output.nonnull institution "institution" bibinfo.warn output address "address" bibinfo.check output format.doi output new.block format.url output new.block format.note output format.eprint output fin.entry } FUNCTION {unpublished} { output.bibitem format.authors "author" output.check format.date output date.block format.title "title" output.check format.doi output new.block format.url output new.block format.note "note" output.check format.eprint output fin.entry } FUNCTION {default.type} { misc } READ STRINGS { longest.label } INTEGERS { number.label longest.label.width } FUNCTION {initialize.longest.label} { "" 'longest.label := #1 'number.label := #0 'longest.label.width := } FUNCTION {longest.label.pass} { number.label int.to.str$ 'label := number.label #1 + 'number.label := label width$ longest.label.width > { label 'longest.label := label width$ 'longest.label.width := } 'skip$ if$ } EXECUTE {initialize.longest.label} ITERATE {longest.label.pass} FUNCTION {begin.bib} { preamble$ empty$ 'skip$ { preamble$ write$ newline$ } if$ "\begin{thebibliography}{" longest.label * "}" * write$ newline$ "\providecommand{\url}[1]{\texttt{#1}}" write$ newline$ "\providecommand{\urlprefix}{URL }" write$ newline$ "\expandafter\ifx\csname urlstyle\endcsname\relax" write$ newline$ " \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else" write$ newline$ " \providecommand{\doi}{doi:\discretionary{}{}{}\begingroup \urlstyle{rm}\Url}\fi" write$ newline$ "\providecommand{\bibAnnoteFile}[1]{%" write$ newline$ " \IfFileExists{#1}{\begin{quotation}\noindent\textsc{Key:} #1\\" write$ newline$ " \textsc{Annotation:}\ \input{#1}\end{quotation}}{}}" write$ newline$ "\providecommand{\bibAnnote}[2]{%" write$ newline$ " \begin{quotation}\noindent\textsc{Key:} #1\\" write$ newline$ " \textsc{Annotation:}\ #2\end{quotation}}" write$ newline$ "\providecommand{\eprint}[2][]{\url{#2}}" write$ newline$ } EXECUTE {begin.bib} EXECUTE {init.state.consts} ITERATE {call.type$} FUNCTION {end.bib} { newline$ "\end{thebibliography}" write$ newline$ } EXECUTE {end.bib} %% End of customized bst file %% %% End of file `PLoS.bst'. qtl/vignettes/recombinationcount.pdf0000644000176200001440000010060112770016226017460 0ustar liggesusers%PDF-1.3 %©ží® 1 0 obj << /Creator (CANVAS X \251 ACD Systems of America, Inc.) /Producer (Deneba PDF Filter 1.3.10.011 \050Win\051) /Author (Laura) /CreationDate (D:20120627123513) >> endobj 2 0 obj << /Pages 3 0 R /Dests 5 0 R /Type /Catalog >> endobj 6 0 obj << /Type /Page /Resources 7 0 R /Parent 3 0 R /Contents 8 0 R /MediaBox [0 0 792 324] >> endobj 7 0 obj << /ProcSet [/PDF /Text] /Font <> >> endobj 8 0 obj << /Length 9 0 R /Filter [/FlateDecode] >> stream xœí]K¹‘¾ Ш›€Ò|?>xŒ]Æú°c>Ï”]†l FekWûë7"™$#˜ÌêîêìªîVÁ0¤ùÄŒ¿dÌ ëç÷ïäNÀÿ>àZ™Ýþîý;±ûÄÿþþ‰Cˆ&ÚÖƒQÒÆü³w~Ð&(_Ñ‘¢JÛÁ /5ÂEB¥¿~ÿN¡jµû#è7ƒÖþåO„8ã·£¢LöŸß¿³* 2ziXûжí/êæüÇùÝ. ÑYŠC>ÆXÀ‘‚TÈüp"ÓÓAËô` bTÖÒÆ¤Bëó}”k³Ê¢#©6Œ˜”!Ú¸‚Tn}¾6¾™ÁYéuйtÚMAÌ(Š À A4}°>?v¥æNƒâ»åõ(¯Ø}½¿ùþ‰@®lòñ3´±ƒ »ÿ€ü¸m†`¥Ö»qðÆø×¿¾÷ËÏ¿ÚýìœBaˆüíW»ÿ„öDh†ö3”ÿû§e“»I9x—±—Íþ‘ =ójF?-þ°„þ•Ÿj).œ°í±M™áC‚Í ŠÅŸ3t2?gÈ "î߈g;®¶Ñý:›+_¼úíŒ)vˆN±”6Ô(‘†6¡ÿñ1ñè< i© @À8åáÅØ†DBèlŒáAT B¨³©D‚Ô'çP½XÉ-e‡Ï ó(B¶¬sJÇè;œ¢ÝõcW$#ëD™´ý¡‹VrIÂà>]ûoÅ/bT¡˜jÛÅHÛ¾„O]SOq`k€…ÔyÄŠ`˜u Z•Aá¬v‰}m:<¡©a%£A”4(³kÏžÍ=Ö‡ÚîÞÏ»']Š|ÿ‡EnÙOƒ×_qür6µC’Î/ÜS0×WÂá6¢×œØZ§ne¸Rn +‘¤pîœ^¤¨öŒí¹­Í,"{FèÒãÖøÒ¸uXïáïÛÝÜé[½ØýãÖño ã¯<¨Ø9åÁ’X¤FñIcЬSo’Zf°Æ¨Õöâ¨uXíàçRnýþRúýÊC M{`šVÑHøÓÂdÚ<Ë<ÅÁÙvÍú‹º•aJ˜fáofÉ­¬ŒŠÌä¦Ú3Öpkųז®ë=|Áyʭ㿵AEaR fƘÆ8nó Òz0sKC: Ó75!DÖí`bö7Doë¦dƒÖ®*ÐÚ¯. &È–‚‚ÅÕKë¡{5cPiX‰f#8iTC?;ÕëÎL›Ÿ¥PÒëð´ªáž‡7RrÙu4FhµsX(«j–K ÷`fàÚu»T¢(gæ©AkÓ®æZøØ·CQä#˜í¦×¨°´Ó›_òæL—§G3Þ83®<,…4¹¶H‰“ki]|ÚT''¡EÆ«0É9M"Ì^Õ”ÕKc£)«;ã¦3ód.ŸÄ×Y8ËxenÏsy…_CÆ;¬vðsÌtnýþRúýÚ;2Ö7-Øqóh˜¿Såµ&®;6&‰­{òåûíù·‰ú âÑ–Ør«ÂäËB„ˆÇè§­zÚò•üƒ`¢LyT1þÁ}B¨Ê× ––9\S»Ñƒ”9åžçI+§Œ¦s‚R¤ø ­s’:Ù鉗‘v´ú­À|ÊàZU’àJ³>F:ƒÃ).Tdî_ª=c{n+aõŒ§C³ñ…Ò켂êÞ ®?άÖVŸÏ2=x—,3ƒöB©–eÖrbéW†)uú˜‹rɲJHªÔm|U]ºrå žee¯ŒegÕXßúÿÍôÿõG™õrëÍ“(^5ÉLF;€Íªñ@F3טQ,7%iÀ|о_G7c›_3¬~Ø–ÂøÍÔ Cðo%™Wv}#À›!ÀõÇ™õ ìž3ͰnÃí¤ÒŠB³TåwRDœ™×Í<å$–ÕzàôŠ“¯ è+¥£7 TÖ]€ä(”Lù…@¹a%@q9±öv°ž™A³^!Z̪CÆæIµKU:kj}P•œóê_Bt}¬»ÓµÈ©¼úW©H%ò¥0%gËãa'rÖzÛÊcŠ%÷zznyö6ß8m®?¦­–oŸ½5Y’ßšlSd­•Á-3g†i:ìcÞ¸œ9kXrš¦蜪Ré =c|k²$ÔÆ³œ{_Yæ<«ŒûÖÿo¦ÿ¯?ʬWt“¢™’ëͰâÕ ò»…éxŸ±/,;8/Kr*‘>Q/v&ñzXéÄ’‘¦ì“CP¢æÑÜTMçŸø¼]Žû*ÆÙ$¤Wµx¯èGȼʶ¤”òl°¾!¥4`{X²ÂËÉ“bbˆnAÊÚskXÛÃûsKÅotùFé’Æ°é"sàÌ\¡cå\ŠuGQ¼›M5ßâi}½Èm‰ cWËÜâm é–FAª2 O–ÑÉë UÂØ•;Þ_7=½—5 ‹Hœ-¥Æ‘”™A{ì9Gà‘ÁRÔz2"d¦BWÑÊ|•A×2æ*¾Âc —ze.d¦ÅÓWÐÊ}µ®–1ñæZám*õÊTÈ ìXñô´r_µ˜J[­æZµ¬õÊTÈ L„®¢•û*L-c&â <¶p©WæBV`Z<}­ÌWïk-s•^P¦Ó‡ZµL$ôQÏŠ§/«yhe­e®¢ :6(ItDB•ÝÁè ý!ý.%m˜ ùf&0ÒW@7]®¢õØÏ½ÍlF‘BÈš’û(Kßݬ~¸‚NðÓI[.ƒ&:)L¤;ir½òLÄ÷d'O¯ }uª\Mµ˜Šw2×+¯ÁTkGöìëåµâmøðßùBh¢•ÂD¼öç{¢W`"¾';ùz­G¶– J+J…[W®Š^©Î¥äÙÑ «LÅÓl/ûD|l+B(W­+(_h,äŽ)æÃgÙ‹Äׯ–À3Yql§¥uÈg¾±»qÉl§ÒS­æóäu Ç%³Ñ¾±«d½Ç+ ”zH5,˜›ÖºN› äi eÕn.ÅÝ'âžÀúK=/º…;vÚb-{8 á~†åñ'±Á*ùiDZ‡}åý*ëž%°87%PVÅ Z’WÐÒ1+PÛ­÷–L߸ð-q¡l]_iHZ/”>—‡ ®<ä0›s28¹UÐÊ®.FûÃ)*$P¹_éÄ6c{f)%ñ‹Áv/]çUHßzþõ÷üµÇ•ÕÂè¹^?¹Îªˆ¾uüëïøk*ë…Л³ Ô+»˜5G]ïÕIn™y(7$Óã2“峿h毦äi eÕvþŠÊÉ%t-Ø}Ýä:¯úÖñ¯¾ã¯=ª¬—=w|˜¹…å«qª°(嫸µ8—¯N?iï*·°|ÕâeÂ&†6c9¼!Ò)µ@õDÃâPiWÉw¾Ñ²Òª µtçÄ”¯t½üd¬¯Å¼Ü†¾·1¯ÂËrË*J¥)n‚cIiÓ!¦j©Ö!ÕÄ —‹J ×(6?ZvÉÙåÉ·î}%Ý{íbµˆøüÍ:šOêf]›fr ðµä”$‹ŒÒœÒÃÂ\™ºgO‡ùLâ\ÿIUglÏ ÍI©qkÎi­IJocï¬òãsn̹ú¸¶^¶LÊUJdôD8Õ>Ž}˜f—Œ}a¹ÈA®òóÍçô;€›®Ìn™â`µk|­(e­àÏÔã„¢øŽzš8±^ÕÊ øl;cœµ’Ÿ zN_“mËC¬6-e¥ŽFû¦gXëŠ(giéZÊÐÔe+PÛ³g—+ßhòÑdõªl¼$[¤»²ÅêÍØ»Ûc/ãJÿƒRàµ2°ØŸ.uþ._-4¹ýy¾<:‰Ž“d¼HZ0?(ëmÐhàyfÉ©XþÉv£Ô&FÙg1Šé¶ƒ˜¢97ùsODR²i¼ñz‹ »öŸKX/B]ۤה¹x¯õ]Sô-Ñ[¸¦a¶½1³gB[Õz6™uá—W[»±Y›AÇg2«¥°)<‚ ›ÄÜ`‚yÎmÒs&¼ÌžÛä%¶øeàœ>áÝd×…ßb'äÖvmB‡g¾žÅ®—ð»™ê/λMú–Ê/Ó»sÞäůÌ8_&Rщ†ØBºÕY:îÉ,¥Ó_d–?Óie76ËûÇ›%—­¶Ž–›˜µu´L"÷˜¥ž?Z*qË>Ѭ­£%ÜãÍÒÏ­(6±jã`yùx«Ì³ÇÊžA¬ŽU›ÄJ‹P‡j¹ùP­b%ît0öa¯¹%«ÐNÃs2ðIÓìÃÇë{L3Û˜Vö¢ðØéF¦¹­Mçñ=¦…Móá,Ëž+SªI¼c¶ìã¯ÓÿQË/Î4p“wÁZÜ`O³QiºM‡>•ÅËà:âÓ/ëùóF½D©„m¢BÌvâfo2zX-‹Ùº×™››½ÉÈBÍ~2{ñþnkö&£1äsK«eWÂFod±ÚÚKXM^ÈS¿Û‚7ZéèÝNá—'¯‚MWá¯:sxLplZO¿¾V1çsÓ-9žnJ˜ˆ„7^lÖ^°=³µÀh”ñYj•P±ª‰`Ô¨ Wû»Ø2R÷žçëüè-àO øñž“k°ˆôAF5=e¬šÂkà ¤(~H5fP¼­5¸³YÔ¨&3( µqGäYü*¬¬ÜÍÛ33 <&X4­)V4ŒØTÑb|j"tÿi±[XÏ ëñäy(§,¼wRÄôŒV2UPàÍa¬ÀoûMk7ýmC/&lWƒ óΉLíˆö‚í™­F£ð§É›Ö+šFªpµ¿‹-#uïa¤[xŸÞãés7@r˜É˜é(üÅw+Ò¯üùé§'<"Œwr±hW± †˜™.$°…Å]n:‹Ä_ÖLîˆö‚í™­F£¬ÌR«„ŠUM£FU¸ÚßÅ–‘ºÿÔË-¾OŒïñô ˜½H©CÒã{SRóaŽ£XN×´Cµ[…â`šf<µ˜É­â,^ü;AEoöÔÆ‚bB‹EbF ”•TˆZCÐlvêÄæþ£·€>6 Ç“' ®ƒt!x µ\„qª,¤Éáa¼DŽÃ˜!Œ\ÇðØŠÒÓL`¼u¼H ðZÍOåÛ3S Œ6iS„ ËŠ*ÄL"p±¾‹-ãtomþ-¸O îñt 9^ôá‘ßñùéÂ9‰#~äðˆ0Þ>Îa`Q×±0DÀ"ÚB` Ÿ`"Ò†ÁÎíÛ3[ <&X6­)V4UŒEàbÿ ÖFêþšì[|Ÿßc[ɼ¶¯Ⱦž‚AÜñÏy0E2J{üœ‡µ¢óÞïiÏ‹x²‡7W›H5G6ñ~“`Ë‹PˆŒ „jeàMþ¤øì§¾ÆÏ †åC$èïˆû±¯®ÚFKÝN¸o«ôtH-ô2L‰¥M!îþªò»ö¨`nb³›-¤|…6ãÏÑ{ižç‡sàif[Ö90æçÊY§O²÷Ç>ÜgÈs<èÁ¸ Öom”}Gˆ},Þ݃4Þ$ÞÓ@§ Œá0e;<èñ€P=:ܽçQƒÀ1Ü/ûe ÓÏjkB"ƒ18Í>sÀXãï2š‚Ž¦?uš>|Ü}¸I÷ÄPàMú*ËÁffÐÚÚ¸ûžEÜtôPiÈ‘V@ÆÂµ™óƒ6AyÖBƒKzZ²] HG…þ¯¶# endstream endobj 9 0 obj 5533 endobj 13 0 obj << /Length 14 0 R /Filter [/FlateDecode] /Length1 65820 >> stream xœì½|TE×?~fnß»›lzßÝ´¥„šÐ¡÷– HÞ¤¬QzAQTlTYBÀxAP@E°€€ 6DP $÷wfînåyž÷ý}þå³wó½gz9sæÌ™¹w7@À… @î½ë§ÛÓQš?tü‰¡OöïÐ 鮡÷Nq­‰ÿø@á'rŸGŽ5së ÿž‘ãÑjú‹ÞZF>dØéI}~²~@4…¡‘IX~ úSFŸrÿàÆ×û´*h·P%\¬â–™{À€º¶Ok=yôq½†œ:nÈd€ŸÐ ºB{,¤5L†Ñ0ÆA/#a*º†`¯×D¼Ù{+ d/ˆöUØÄfì‘"4ƒéÄ .šG7 ÉBwa‚0U˜. …5Âáªh»KaR‚t@ú^º" r„';åæò]²¡ŒO“06á­„C †c†ãÇ*ÇOŽ?œÎg;gWggžóNç çÃÎç>ç1çIç%çg…+Ø•är»¸¹š»²\-]Ù®»\\3\Oº¶»vº.'J‰a‰Q‰I‰îÄz‰Ýû$Þ•8+ñ©ÄuI4IN N MŠHŠMr&ÕJJKê4$ix2M¶''¦B*Mµ¦ÚSÃS£SãSSRë¤6JÍJ—Z˜:+u^êÂÔ¥©kR7¥§–¥îNÝ—ú^êÑÔOS¿vg¹=î6î|÷P÷÷X÷„:ãëÜW/ê•ÄW^£×š\˺ÖòZëkÙ×¶^ûîšqýîòVå?—_¯H®¸n\gO>Á«)ÐD:€¾*¤=„)ƒÂ,äÜc ÂûÂobØCŠ•—Þ—.Ë ëÈ9‡œ({ä|¥G çÆ%ìK¨p€£9·Úñ³œÑN—³ƒ³‡sƒ…ÎÎýÎÎÏ?;¯ºÀŠœ«íJweVrn rn‰kµ«ÔǹHçº&öN¼9·¤’s!ȹ˜$‡sùIÃ8ç\ù•œ[’º:uC%ç!ç>AÎ5¯äÜp÷ä\~Iȹ¨Wæ]#×®5CÎy®µ½–síØµë×ï*oÉ9çª(dœ3¾Âir ñ!€t‚?íͧÏûèª  bØõ÷¯¿+­AúáÉøc€K⥮f oý×"º".„]¹|ÁvÁzA¿`¹ ]P.Ȥ Âz¾g#ggóû¬³|±îì}?ŒA÷k?düðü¹g‹Î> pfÌ™Ζ]8üU³]X~fÝ™e§—^{zÀé—YÞ3Q§'Œ¾§=§3N§œÊ9ÕîTÖ©ÌSMNeœjpªÖ©¤Sq§ÂO‘“?ž¼pòÛ“çO~ÉrÜrÏÉ×O¾†®·O¾trËÉv'Ûœl}2ådÒÉÄ“Žs+XšÓìù9H¯ãt|VyFY©¬0û*'·´}fûÀú½ÂP6w ö^ø¹”é; fI ñ¾LÚ©íˆæXÆëfn5ÑDm¦ŽQ_ÖΡ‹çÊ,ÚÞ;ÝVñ5³ôÃûKa•°ù½2IJöos/d°<æóÝ®¶*9ï¶ «tçÿMšn–QxŸl™cÖä Ý¡/ÔKÿ’X€`Ìî‚eð5ÌÇ`<ëáE°C²u&,…Ëð,‚§a!p .Á*Ø¿ÀÏpÖÂ&xöÃf¸†Â‡PÕ€ƒpÞ…÷à0|#à8 ï먂„Çá#øŽÁ(ø.À|ƒ*z,ŒGÕ|¬† 0 &¢Š.@e=î…ûà[¸„à!x¦Ák°fàšSÀ÷ðì$ËÈÓ„ˆD‚kp,'+ÈJò ”C‘‰BT0ȳä9²Š ¿#”ÉïÊïɇå#òQù}ñºX.Vˆ†‘¨$H¢$I²¤Hª¤II—??”ÉÇåòÇò'ò§ògòIù”ü¹|Z>#Ÿ•¿¿”¿’ÏÉçå¯åoäoq¾/_/Ê?’äcò ù”|FNꡊ] QB•0%\‰P"•(%Z‰Qâ”x%Aq(NÅ¥$*Iz˜®GèÁúý¬þ…þ¥þ•~N?¯­£kýÕzÕú›õwëÖ?­×¬×­åÖ «a±Q%YIQR·RC©©ÔRj+iRª©G)…Ê#Ê£ÊLe–2[™£ÌUæ)ó•"e²PY¤<¦,V–(+O(K•'•§àœQ–Á'ÊÓÊrej°gP“=§¬RžWV+k”µÊ Ê‹ð)|'á4| Ÿ+/)/+¯(ë”õÊe£²IÙ¬¼ªlQ¼ÊV¥XÙ¦”(Ûõh=FÕãôx=AwèNÝ¥'êIz²ž¢§ên½†^S|B\ª¶TÛªÙj;5Gm/NQ;¨ÕNjgµ‹ÚUí¦vW{¨=Õ^joµÚWí§öWsÕ­.WW¨+ÕgÔgÕçm‚M´Ià —Èeò9E~&¿+ä*ùüNþ ’4r\'夂ÔA[ (¡” T¤•©BUªQ ©Kuj¥6Dƒ©†ÐPFÃI=A#I}Ò€FÑhCci§ ÔAh³-DÛ#‰4$é4™dКJÝ´­IkÑÚ4Mo¤7ÖOê§ôÏõõKúeý'õ­CëÒz´>m@ÒtšAÑÆ´ mª¾£¤Ò‡è4ú0NgÐBú}”Τ³èlõCçªïªï©‡Õ#êQõ}õõCõ˜ú‘z\=¡~¬~¢~ª~¦žTO©Ÿ«§Õ3êYõ õKõ+õœz^ýZýFýVý^½ þ ^TT/©—ÕŸÔŸmmÔ_Ô+ê¯êUõ7õwõõO:ΗìRˆzM½.…Jaj¹Z!…KR¤¥hD£R´£ š¨Iš¬)šªišEÓ5+ÚXqR<Ú¨ɩٴ -X³K.)QJ’’µ-T Óµ-R‹Ò¢µ-V‹ÓâµÍ¡95—–¨%iÉ6YKÕÜZ ­¦VK«­¥iu¤)U««ÕÓêk ´†Zº–¡5ÒkM´¦Z3-Sk.¹¥Z -K»Ck©µÒ– ‹¡üJ¾Ñ‰NIS]ÐEºWœ»u\tuE·ë!Ö#Ö£Ö÷­Ðúg°.›ð(%ÓtÍ–`sØœ6—-Ñ–dK¶¥ØRmn[ [M[-[G['[g[[m[š­Ž­®­ž­¾­­¡­§­—­·­­¯-Ý–aëgëjëfënë!O‘§Ê÷ÑýúN½LߥïÖÿ¥¿®ïÑ÷êoÐôz¢ïÒ÷èaz„¥ïÓè‡ô=MÏгô ú%ýŠž£çé×ô”õ;P¶{K}¤¾‚Sp ‰BJøPi˜4¥¾»ÔCê‰2?XÊ—†à<è,u‘º¢äî“Þ–ö£ô¾'–ŽàL(¦HSqNL&J“„BM¡–PçÆCÒ4éaœóqvÌÅÙ±gË !M¨ƒsäq¡®PO¨/4 éB†ÐeþŠô«tåÿé¢ô#J½å>”Õ‰RïÇ ä•Ç „ï? ”·F9o‹óæ¬ô…ô%Î…Z8#jàŒH“rärCœ!©8;êâœh!gÉwHµ¤ZBc¡‰ð‹pw9ò—›q©„¿¼1Œ‘‚(ÉŠªYt«-(ØŸàpº“’SRÝ5jÖªV§n½ú ¦g4jܤi³Ìæ-²îhÙÊÓºMÛìv9í;tìÔ¹K×nÝ{ôìÕ»Oß~ýsóÜ9pÐ]ƒó‡ÀÝC‡ 1rÔè1cÇ¿gÂÄI“ ¦L½÷¾ûxð¡iOŸQøÈ£3gÍž3wÞü¢ =¶xÉãO,}ò©eO/_±ž}nÕó«×¬}áÅ—^~eÝú …M›_ÝâÝZ¼­dûŽ×Jw–íÚý¯×÷ì}ÞÚ÷öþï<ôî{‡}>øðØGÇO| Ÿ~vòÔç§ÏÎhg43šÀÍߟ’øN<g43šÀMàŒ&pF8£ œÑÎhg43šÀMàŒæÿêÍ»eÿk0™•ðÒá.±"•¸Oê¹d.  `ƒqLÆ´ÐßiË‹éû"Î ²ý±¾°®ˆ!ˆÞÌiw²¼XÆDV§0@u©ŸQŽõ-“ÀÄ*t¯¿‚ur&ŒGÿ‹˜onC›²4˜g™¼–cø³?ÃV!ÍEÿtÄ| |nMY1Œ"d ¯…å,ðõ·†ð4 Œ/°/yXf'Ĭ£ÒDgL†´ b.9€»–ÆZŒG 3±þ¹,‘í£°œÙß ó¥ &ºc±2Ò`D"¢&Ý™4v#­ýïoöqF±>Wö ÛïkÓ_a¶±sU`ÿB$ÓLãýêÊ©0å+˱ Ëü–ËÃ0èƒõ×Cš!žç24±ëºäçã úÁqí…u]g¿¾€ù{#Úã¸"Ʊö`ýõÏÙ¸“~™˜ö¦È€áQØw&“,Ëe¥úäpí k1Í"äëY¤""‚µÁ.g>`Ü~,'!#õçkcÍ5Eö ·ýx{Z1Ùäò²!@b۸̚}XÅÇÓœ3k|e±zåM0Ö‡DV&›/Lf±-[ýe³9ÅdÆO¹|årÿ#ë'“©JŠsO¼íYøDÙòS6ï°Íl>,£}aÒ•(Ç3™Ì²öù)ã “5Μ>šU¥¯ øA*$ûd}¦ŸúyQIGÁ‹Xf¾|7ê”ÕÐAœ„Çánñ2d µ žÔð?˜ÖK/@/u/dàXvGÿŠjt9ƒrœŒ‘öb?7"?ÃsÈÓIâqš$'’´ÑøNrPÚH§s÷_hu½f£ UãþÓðÿô„´uæFã{é¸a`ž`sB¹@ \~ŠáňBDm5,WÇ’R¥/Øe€+ˆ ¢šKh*îÅñ‰@=sÃûJ_ÀaÌŸ’B(¤ÇaŽCè2ÔiX=3XùH'V‘£›d®º,ù©_^«S¦ó}2åD*ãü;âÃ9®"~E9êŒ2ÃÖ¦Ÿùú€:1Ç”WãÏJù</!]à—Ïjr:¶š|Z«ËeuÊ×ÔïþyŠí˜ïï?ÓLÇ1ÉôÓ3þôÕi•üEtÊ1ÓÇa€o^'ùÐ Ûø¥oî£ÆñîorŽñŠ\b¬Bur:º?AHÆ+Øïû+×Ô\£Â·žÖò¯¥f8èþuTÊ€ñ>}ö"×7?Ó|íÇÛ§É[`†t Çu oïjßD~b»ÇŠùÈó•°û#ÌÅùˆáˆŒ'|,¢ÙºÀÖDá)ä3[‹ÁLá$Ú ,o„ðõ¢ôǶäa¸¦2ʤþ°V¾éb_Ôµ{a+ÖÖ6öêT°©¨'ŽCCq=¦‰ ¦[ÍyàW¸\°¼c/”¡  ÌvÃ4¬¼5<B}üx‘ó‚çG[„É0ã–)G@/nO\€ç¥¾ÐçÐ¥ÖÈ}qÎEÀ:,ã%Ì×—µóÅòõú)¸ç×<ÔMóPç—ÿÆ5a#öç~Ôë¡y´¢¥BäáXÞ÷lÑÔ±sÙü6€›ÉˆüêafO<Eb´“ÇÂ" [$¡žÄz`Ø,œ¿ pîÎÇüNŸÞ¬{>†³¼­˜-Ãl6_„É…ÜÞf§`ýÂw°FèóPŽ[«O!fC]if4: Mpÿtšàav“’DÁ³pšb ¸¡0غS|F‹ý ]hˆs7êŠà\ýž‚a°xžKa!ó‹aPSðbÿKжdáG¡ §¢9 ³0ÿ<¸G ÂV”½À"ŽÀ±Æ|Òc(')˜ÿg,×ò úáÜšƒî?ŒM,¯£ÄèÏ v€º<_ð¶úQ­Í´3öªŽ)¶—¹oj/¶µ²þ6Þ¢}¼Ÿ¬\ÌÇÒˆÏ@òé"Õ¤=é"؈XM?ƒ¶BWx€¬3ʯ9ÕСª_lL¦!ê‰á5Ä#讃ôuÄÓ¶[c8‰˜e¿tÛ0Ð6ЄQ […XŽx×W¬ž[…W…g”Ýäߎk ‚\1ʪ§G>7Áúšˆwe (‹ä®Ü áB w`¾j~)çÓvHÀøívmú'àÕ  =Uû褑ÿNU¡.F}kÃݶÿ8¾3ƒ8„S† ˆœ0N!íGN€]˜Š2ˆ@]ô‡ùùé' _ÊëÊ 0žW¯î¯>®·óÓm0¸*ürP)O@K±¦GT÷«¡%ƒü6ƽýW¿øÊm0j +Y›PküÕ/w‡ 4ÛËòàœCTú¢Ž@°´<¿ Ú3°¹Ë@Kp¿†¨Œo íªðµ ã«°ÒŒ÷\ª¶Ï#ŽHÝH3‘öFÚÉO«ÎÙêó¶z˜_—Ü*Mµ¹ÑàïÊüÿpîB@ìÿ¿]”U„!ŸB;¤Ú‘ÇÑ>¹f”£.¹^ñ2ê¡>H?Æ0\½+j!lèÁ°‘HŸ¸ö+º'cøqã`µÏ®ŒÁ°¾¼ª¯¼Þfþkïüy±ÅÌmb ºBàz~ís¤o ]Žé¿Ç|³¾iÆ—Fÿ½ˆÝè¿€þqˆ\t/A´" Šù—10{ä/ûÐÿuzëýÇ¿KÑfŠít²3/¤Óªï!þmêÏÛÐê{ ÿøßŽV93¨FM>àžéK´û¼U÷>ÿ´ÇñSÏŠªûåhSZ™ÍlYf?sûÑGùþÛ±X/@¸Ÿ2Û™Ù¯Ìvfö+Ò5üÌ@âíéËöù¼]¾u£ªn%W`ÂŽˆóѱ˜æZÃ8‚º'åûWܽȀþ D?ÆQ\»‚q­Ûƒz÷W¤‡ÑŸ€ôWÿšæ×­ѱ·YÓþ·ýÿéù_¬©é> ®†¿ ÷£™ª¯Åÿ)n·vÿ×kù߬ÑU×éÿ©ß¿Îû¡µ„tÅc”1T·KÿbÜÆ;;÷?õW·;þc5»Ä﯎¿ÄW—=¿= ±•¨6ïþS°½…¸ý†íïoCõy\9ß|~äQ»ª@=PÓ·†®E}ö¿‘€À5Êxæ«×!]Ý éèߎÀu³â"Òa,éód;ß6ÊÑÿ(úíâaž6ׇa·“çêrËìsn"ϸ\ÂÚõ-¡ˆ­ˆñþ±f{H¬ûSº›¿½öŒ8ÀøU<‚¨fÞ–6†IˆÍèF0êâp9õ¶^açñH-H-¨ß{Þ8ã3ÊåyšNüly t@=xœ}ûø™^+Vþe&®¡Nÿ9ú#ØÙâbç%F©ï|._þ×Áþ¸jlíÀzûñgBcEvŽû3<)èí;C÷Ÿ%³ó)¶^ÉõÀÎÏ1ªž# Åh%šÏ©ú²óá<V3—» Ý`·ïù–ײVi`•: rÔüyÓ2áY˜‰aÏ*Á³r¾Ò׿®²5ñgì,3¶òLÓ×çê6oß@èÂÎcªÖëϧæàZú3?‡2Ï1ocÛà_„f>¯0®Þú¼ÓxÏwî9Ê·Æß[¹æW?§=…é¸ïóŸÉ¾ŒôÜ%ÎAøx\½-þº/åg ùmt÷çg}æóvVå9\çów|¼:²1“l8‡ƒÙø;Eóù\ñ~LO!F¼„0Ïùó9v6ŒèO?Åô«pŽÞƒseP\ÊŸáÍòÓ/ó|ãÌçfroD+l×Ì·=;òf߀qNì Eü\ÍXKÃH'Ówù3Æ`ß³Àq!ôágš7ž F‹5ù¹uM±ÇñúSxß}”óʃù‚q_ÇúÈÎæê±Ÿ)Uhá;#õ¥U^ƒŃòªCŽ´ R„ h¿ìE]c× Ç5f _‚ClC…Æ@rŒ#äR´Ôè÷þ)ÒÇÑÏžý~ wùŸ«™çÓpãÚ ß³\†á tIô='Ìó¹L7†eÂàå*ÀtÆ—ˆkôI¬» £¥XÇjl Ö#ØqþUæ¹Û‡š¾zÚ‹ýqŽÝŒ¶Õy­_ÎhjuøÂc«ÃmSÞæíø»t׎¿ wW†»ÿÚñwå&W†'ÿCû:W†wþÚñw|N© Où‡vt« ïV½¨Ÿp[±÷¦›~â[ï¿CÚ)J_Å>tãþÂáóâK÷4÷¿Æ î•6> Î3Øx.Ò¸¯6zÞ@ÅA¤ñæKÓþzŒ¥ˆÚˆ~f],oÅ.³n_ÛÌü囑¾S͉øÚ¬×ÍtoÒdÄJ_ÿæùêõšm¯Xz#}E¼ÙGžÏ{†€è…ùH{ß@ÅvÆ[H_E°sѾv1·ÃÇÖç×XY7ôü)®D‘€ku¸²Á¤âCÐ…ëÜ£7­U¹>ü Öq}ÇþcA¤Ë6´Cžƒ6Ìn`:\ÎÓ/†áÚhŸôãÏóÆŠgA߆é< ïlaÚÅíQßbü¹ –Íô6³9„ùÐÁŸUògBìÙÉý0×RÂí;¦ ¿Áö®€=¸g›'åÁü²RýKp]_÷KÁƒêxØ#_ƶ‡¸^9åÁ)= ü{[y²ùÅÂùÜİò•¾ð1ˆiˆÑf<‹3f˜îòKfùúù‚}ûû=ª²Íþú}åþOÇñ:.ÿ[ýþ§¶W…ï=?eïîÉ·l7ŽÇ/&ø»4 Ìùº ±qȇ¥ 8WbÙ»JÂp”§áü}ÅÊ<‘ƒE¸7eðù}ïßÈ2ZvJ´9Ø»?& ïVüQ†›ò§Ô0ùÄßÛ1m¯óØ›ïÛ>Ý—¢õ€5¾÷dL·àºËæyñ q³Ígô6÷ÓÆZ\'%L"Mú®ñ‚ô ê„ËÆ;Ò ´X×,ú°Ú´ýŒ-¾÷ eþ>ðX_¸·u0°4X_â%Ÿ½ÍìØÉ&*¾1Ão´Ë¯{…ß±× †¿_êáûëâhÜÓ†áÆ£½Àž7 C 5[3„&h[±wnî÷½/ËÎN#5aC¾ôÖU™ßìýö^ ‚¿“ÃÆi?®,ý~žß¿¿¯ÉÏ—Æ¢? NþîÆñwz° ö®³‹ÜQHÝQ.zbÚžÆÂr¤|øq¶·Œ¦³ ®0÷Ãá“Ð4‘‡xq/4äá×PNþÄôADÿ{H%ÜÛKö‡ M°x¾ßÞÃÐ&†å™éŽó<&dFÞäu Ú`y˜ŽâNI@‹Bˆð¹eŒŸùö˜ûwv®ÀÒó8íFé"äXF@ކ˜o”I­2òd‰ ÇÔ†hŒc}Ä·`vÔQrËX…þC´ú{þçä>*m†ÑÒPW*GûàÊÁYÈ’®Â3R+¨)÷Àulû¡Åж·ÁÞ'æï7ŽøÏ¾ýs!B{Úã{ÃOéFóç H_¾ñwé ³Þ6šÚœkÜÎU²a&ÎãDß{ß#ÌçchƒâÜÍ÷TkŠ/A‚iDZ=TrË`ó¡7ê†Ê³WFÙ;mL¶|¶ f56ÑÙ¾ÖhÊžUÐì}-ž÷Ns_j°óê'ìÌòÙ*ÏŸ–1ü?ý|‹V{õwÏ‹n÷nÆíÞÕø‹ÿ?|¦RýÝÛ½Ëq[µg.·{^†²Êlä\WöÈŒãè ñ8ê×D0 ~>jÚkóçö܃v„ß™(;'u þrˆ ù™þ³<CÝÔÆ<›7®û¾çÀÏSÙÙ³K…hþ=ˆXß÷Xù|ç·ü{•ç´ /ÓµL§ò5ƒ½Ûû4Ô7Øn¡!ƒ^7u9ÎLñsÉ6ØÆ6œr7­íÓ)m@£Ø—¥&„`ã ×IA¦ÎË+eú ×_S_%±¦þ¢™:ˆžÆ4~\A|ÏžÕ°ý4ßS³÷!ÖóµéOSOr]ÈÎ!ÑÍ¿bÙd߃¹½ä³-7V£»üôvv¡/ÏF_ž¿¦÷=»Áµ$Œ¯É {··rßÁßþšïW:`<³AnØùþóv>N8Fæ³}R}_Àžç°±õïéÍs³ŠªÐÁ&ø:Íøø Úe\w»ð:PÇñç=Æ_;Ùþ$åtAåÞÏ¿—óï5Zˆ«àEa$ÚB Ø;I|½ß]eû"‡ä ¼ÄßeFŠa‡1]sÝàkÈÛöË ~Dœ0Ï©Ê?eßb|©Ü=ÏÞ¨Ø)B~íMí1r™i¯…0™‹3°ï0ðïNù±çÓãÐc'ôjnsG;ßß-Ô‚³*Ô*NKpîj Å-œžR!y[hDzp뺸ލÏï.¼O@lAìØÿå,80ÜŽ÷ˆBÄÄÄûgƒÇºÏ#β!Aˆ/v9í­k1˜7—ª`! .! „€6LÖ݃‹Ï#džŽ…L@Ì@ìA\æ1!ªø‰ l{TñN¶—νCLïÀAÜ»­žI»ö4ivG3Ys3YÃFfp½6&­QǤ¡©é…ŒZlé{[G ‘ØÉHløD¼º‚ '¬FƒÂ‹ 8±Íº-ÅþüT!ìk­†ÓØ+b[Hzk 5è%ECìGzÑŒ¡·…¤?ߺý¶ ö ú%~¾ _À z–ñï­Ï#ö Ž".!dz?gðsµH0ýê#Z!#žGìA\B(ôs¼Ûé)ö’¿3w+¥§ðn§'±['ñL?C×gô3lڱ⦙é;¹#­¾ÏáLõ9¢â|ŽÐÈôRúañµP¢Ü8Ò(Q»„$h BRqjCg©]œ5ÚYJ¿ÚæJs®nÝ5 Á~’é#¬ù#p!z ò2ºN ë"– V#¼”2¼Û.zñâ4@x=*}¿«)¥G‹Ýmœ­#éz¢ã‡é;œ¾G÷sú.}›ÓƒHHÑýÅ'´Ö10©i}Œ—èÛRBFë´q˜ñ^Ñ Ñ1±!Ó=4©x˜3 Ù‡Ð2sÒbøŽÓ—a­ ž1N»-  ‹ÝÜÍï@Þžw=ï¦÷²èe7÷cO ‹Ýܳ¢‹ÝÜ>‚.vs»]ìæ6]ìæ0]ìæîÞ]x+¥«^K©álÚ},qµ¦÷!—îC.݇\ºDzûÀ"kÛ3ŵk#ÇVzÒjÕv–‘Âݤ°)\K ‡“Âé¤ðR˜E ï"…i¤0ž:H¡‡î"Í…ÄSr“7ÓM ‘Âͤ°€ºIa*)L!….ÒÔSJ‹;fpÒŽ“m­Ù¤CzGKÔ>Á49šˆ2Ÿˆ:aÞ" îó`"W’™8ÆÁhÒ¶Ú­L½æéZw oaÆ·pÞ‚3è-£·°·°€`¼·B FìE\BS'aÃó{0Þë#Z!#f .!dÞœK |MÜÂVß×èîÌGßÂO~i¢'ÁoO³wÇ“`éî0´)DF¢5¢†”ÛŽßl¿ÿf­µÆ¾Ê†¶“.ñÑÅÅ$8KÉòb÷.gëò4ZG(u$Ü$i3(àþƯ2Úâqà$éÅñý0[p±»Ž³Œ±\;œÄŸs~_JÑùmü.çÇ®R‘;cÈÆÎâç;Ö/U1d·»” )sñ¤;ã›97âIÁˆ•ÅÎéŒìp>ßÞ96žG 7#î*@Ÿ'ØÙË=ÀÙËËŽ¿Ûé)À2w8[ÅßåÌ2S5fyv8`ÒLgmll­x^i²ƒØ·i)å©£,Sr•îJ%]©£$*N%A‰SÂÕPÕ®©VÕ¢ªª¬Š*UA /5ÎzÒØo¹…ËüŸY3S‚€ÈÝvêÿGÑLé•B'ð† içÞmHgïÞ¡Ðùn—÷jïäRbé9À+%·!ÞÐÎйOo³´Î¥ŠÑËÛ4­³WéqgîVBËÃP/WJ On)1XÐì8ohÛÜ@HÈìEqŒÖœ½(/¢#ïmÝ*´eHfNö-nù¾{Ú+ú&w‚wYçÞ¹Þ yÞtæ0ò:{—öv ÌÝI~&—Ûeï$?1’—»ShI~n׋… -³óò:—’~<¸ÈO˜%æ'žNÅ…™¥—ê0Ó­4Ó¥b~L—¦Ó4HåéR5§ K·µ ¥]öÖ”ž&ʯI 7ÒÄ›ilgýilg1MÚ¿{ o“–F¶µÈ:°ÝðävùÉí†#ò½ îí-¼ÛåÚ:4E¸¼‚;ÿî¡£2Ü›—<<Û;49ÛµµÅÀ[DdÑ-’³·ÂÀv}r·ô Ï.náiÑ.yHvÞ¶ö=5½©®ù•u5êq‹Âz°Â±ºÚ7½EtSÝžÕÕ”ÕÕ”ÕÕÞÓž×\Æ{änU¡M^Û&ÝFu Êk~\b^›HûÄ–\x[$FO+Ckeèiy^kr¯ Á¢ê¶®ÛšEáœbQA싊žÞ"1÷ˆ¾(;‡$·´)S ¦Bt»ÑÙæ_^4e*c¸yO+ø» ãÚy=C² ¦töÖîÝÙÛªç€Ü­Š‚¡ù¬KÞæþ0]oWjì5ëa`s(• YX Ó4_¿ŽÿTmËfA!ݵxd ä ^Gç>UAŸØ×rËЖbËCAv°€¤‘¾f§¥éÖg?¦Lõ¹|¼˜â£fNÌRàgIåŘ•Vɱ)iiIe¸(ƒXé´éÝl¿c°sÇo­m|ËâÅý#@©ë`3 ›a¼I.ûÕ®PÌʆga< sqY€!ó¡~$ ’Ä%PÖà¶cÚþ0Ê ’DßÁ ˜-Ã\³ÁIÐzÀXDºSa œgBSè÷ÀDRhäO/âþg§ðŽQ:ÄÂPü6~”>1NA]Ìñ¬€3ä m;x°–BLùL†• ‘#?±‰p¶A„®p˜ì¥iXúpø†D“iB[,åÃkìÃTñ0FÁJ(#I{š( 4º‡!ë¸K]Ű?¥ð/øŒX¥ËÆ‹Æeˆ:ÐûSGÈ^¡¢ü‘ŠVì ¹T 21f¼à}’LÞ $«”.y¤ B_lí+˜ókòÎ~AIØ/æm ùò8ã6¼ _XRŸt'ýh-:®&ƒŠ56ÄÏ0ü^Ž¥ŸF1ÚA­ô¨ð‚¸Q¼&'Tœ5‚pDÜð <oöÔE È£äùж¥ƒé3ôKáIq½ø¡2{}Œ‡E°~#¡¤éIî$£È42—IŸ¥GùïŸü@ÿ¢„$!Mh,d yÂlÕ\a ~¶ _ˆ±âQÑ@>§Kˤç¥uÒFéMé²lUÅ5þ½ë/”×.?]ó*–UW”_@Ž!®¸áÊÂÖÁÏïe(q[à±"ïbImÒ’tAÎ &cÈ$r?rrYI^âm•ìF.}L.a›m4ž·¹mLÛÐîø¹‹§“Ð{‚–ÐôOAt!Xˆj í…AÂpaŠð€°Lð ï Ÿ _ W…ëø1D‹è“D·˜&¶‹SÅUâ7â7Ò@é]é¼l‘ÇËsäRù'´jZ*=”žÊ e±²CùHÍg¿ŠÛᵪ?cHÎ í„íðÍcp såy0 ºR”TºŽÌ£“š"Ý/· -H7¸,º‘×ûéóô*m!t%IoÃ~í‚]r¸¸I–ø\wcߎ`É÷ËV2^’­PLÌóâ·…bšð.|&œ!ЏNŠE.ÒW„(ÿ[J¹(< ¯ “Èð¶°\S¢w#P/ô!éäwÁ@3¸JQSá+˜ cé'pçñ%óêŽnà[ôjÿ/`â€Ð×ä^hÛþXÈrÀÖ ø¬‰°²¿"¼ö͈,ˆ~ æûˆÝñŸ!!‡¡ì¿CŠ àFÞÔœf¢ö€´«7PwßÍhü'¥;L4Á4Íì&2hÑåf´Œ € € € € € € € € € € € € €þ_JøHì_¡*‰!‰!©x# Âu—°÷ºG‚kà÷²ŸÄ)ãÿ[å0¦LõDÓ,°Ð¬Á0fÀWcüjqÍòè4ûÕAƒ.B«‹ d4Έ(;|ø0ÿ9ãš)ü½w‚`œ.Ϥ¥Æi+<óiPáya‹@…{„³Ÿ%˜Î"| ô[RJÖo·=ˆ%gÙ¯\´cÙY­²æJõÒ=lß×°”–A2Y¿¤"7FúáÏpöÓ¦}oÄi/Ø!{lÁV«µMß`«®·é+—ßzB˜_Šf~ÅÎîq,Tg.3ú¯x"m¶6}ãev¶²»bg÷­”}qÍc‰uˆR¸Ãf‹Ò0sIp0íËž› ]!`e!iµâÝÊ ~ZZÚa¼Fþ0Åm•ÿZÒ,If%}]b³qÇž]—Y‘vv«•ÝYXe‘7Ê,‘]1öøRãr1ué¯g!Š6Îzº‰ò\:OŸ|0HÒ=š¶ ëÑ)¦m\Ÿ°czÅUÆêCÃÆEŒÉ{€Þ'ß«?6<>>VEý©ÆÆ 6‡½”¾¸­{ )%ÑÛY€5y¡V‹¢ZüÕÂ&*×f–‚¨c(¼l²’]ôp4óXC¶·¢ƒé:ƒŠ´Œ¦€“,ÞÊ§Ý TÂWÓ˜.æó-«<«ÕÅòAçBB™¬àmnP½´ TÍèAÉÿlƒÈ É¾™˜‘ènŠÔ¤IãF8ëd¥F6%#ÂQ²ðOT®7¥Q©/¬¼´nÅC>Kv†ýþÁ±«^ysí@ÇæÍ­³†î¾ïüˆ±KŸ- ;úé÷›s7ì~qÞ†lö3¾#QöÒHÉ!š+ùRŸ2Ƕ*ê[‰ö°Á‹ŽÂæFš=¤V²W‹`‡ÅR+Â/:jÅKµlÉ6kt P—Í6—âæebrw}¦|×gÍlÕÊŽ þÅýöý¡™ö}ié lðkJ¶H[;Û›Ø.¤ȽqB¯Èqö1áÃ"§ÚŸc+ Ÿ÷’Í"¹.tºÕ$*ë%lLÙ·ªwökC6Ò;!F—Ñ!†ŽòhØJ ›i õq¨ˆC+uqhÁ`×uE³)â*TüIR¥2©RàæjÛMÀmwSìé•×X.÷’ºÑ¥¤YqÌ1RFšáz¾×£Wêè%uJÉ>éH»Èå篤 ªTËåçØ¼¸hçÂbÊ j”T.dRS/aM#™*æB¡4­túåƒ ˆÂîœäîWâ|jìŒ-kÎ誔Î3zaxIâ÷¯Þhìˆa.©øöÄ™½b®÷ÑikÂWÑûúè¬Y®íFül=Ç¿Û[ñë×ÌZˆEe—ÊPoÛÈk;ÁjüéÙÄøc“¹àp.ó»fªs~—¸:—ù]3U;¿+*Wxü®ð…KUÍpÆ`•ß%~—ù]ãwsYÍµŽ²®´®·´J]„.¶'E!§7XeA‘,º àzb³ÄpAP«MT„]t¨hË­öX@1 ²ˆ¥tÄk’dñ$8Yü ‡Å´*¸ãGn^XJISMñ$%7R +K‚)› º-¼P;uQ²Ì,:Îí`yèö R²÷l fëÆ6­³ì_Ûù²a¿’u5+$“ rfæÜzi"êƒàà`î¶ìÇÓlh†f¢¶ýÈ£gd Iu31!!‹‘‡Â€i<áVži-ì‘iõ¸3­IñHëfrÝ‘GnñÛ|†Vkc’’‘"„º¬|}néþý%Éà—„×;½T±UÙSåc™ž`öa¢ô28ÈuOXÎP~×¹ÒàFŠÎ\7”ˆ'Š¹Â¸uÊïB´ß á“ÈLÄ\aÜX åw=š7KÄûf-´rÛÆØKâƒ,ŽˆˆøP¶„éÁ¢èˆ·P¢q±çÆ%wpŦqجÂ)U¾µ S2µBù"ÌïcH(JXöJØ[ÖÖ“qªT;VÐH ô2\PÔ4ö0KDhXØ¡ àð °ð `ªOkˆ'hu öD_£^ É1¦Špyñ„°æ… ¶O°Ï°/¶‹öÛ(•h®T¢ DÛ£i´_©D/q…î&!˜<…3¯YqÐö[)çÍÊå&õ2¥­>œƒB¨ÏÍUë¥I(rÀ— ¾úI¸OøËúUÕ7¨dÂ#T4® eèîû¯ˆã-Ù¼°ÿšë£Ÿ–¿Ö}Öã{‰:eÑ•wÊI¡½hÁ¾µ+‹»·Š¤?mª¸w`ÅÕ<^|–i”®(_¸%@m*ìDóû2çMH©ÏáòsKõ;jøÅ(¹RŒÍý ¿qa⩹æ`–ŠÅÜ’Xo¬iÎ`â$ƒ‰@âj:<6b³¡'%9ÂmT;ËÅ·'vG”ÉT_Ñ¢øö$Ê·—8üÑaûÛ~ÙtѾo“­ºccH¶â‰ÈŽÉv íã+ S†©cB‡¹¦¨Sãg«sâO¨E†(.6°5L!³ÎàrÆ\‰ôà±wИ]´üñÔÐüŠß>,º8t&ÓÈú7Ö½yýóAòJW-ß²…í·QcP£ 9;!Þ¿ýåªM‰öÉ£/4‰ûëó{]¿íT«Rºo$ç»å$.ñ•þXî¯å溼\æªÏ#Üünfgƒ‘ĵc|¥?–ûkùµ%ÏέÔú<Â}Cu–X!ÎQ-V¸ }ëÕ MtÈRMG¨ÍÁVi¾¿²ƒïÅÓ‚Ù¼còì7Þ™ƒGG ,’­Ž‚?•P9O„”+KÁKŒàó$âÆžûæ =³ú/ffVîë_ã ‘ý ‘͆œãûû`ÿb꫟…¡ãº'‰²jYήÉ#xOoôÏ_ÖEêûà›ªMG’Z‘#;º¿¶~×@Ò‡áa2Mœ¢NÒ'[§ÚŒZEd¡8G}DŸec[õ^Èþ°Ð$œ’Åñ®XF\®úŒÔu¹Ù<©å²‚#¬ØŒÕõHNû§¦Ã?5ljrÅä(Ø£­ŒŽ„4_¢4¢´Êù›Vìqáü &l¦Á¥äqOLz4Ÿ´Ñ|ÒFóI]àˆPJGz"Rxd Lá‘)þÍ­+ÂA#–4<à_/ø"Á ®T®•ihæ ÎDf¥øæ/_+Mž“ònih˜q»7òíXü)`HXx•y\uR“1Ç}½gï÷cÇÏ]TqõÓO+®>~÷œ±£fÏ1r^óŽKz?²nó£3^âj-³ú³3«G<]«Î¾y» dïâ7HŸQ³f:wÖu£ë’î/>ºa[c&“5bsQæ'wí=5$™ˆŠ©I¨’*ŠrjJž§G)¥{$ˆÕHŒÚßìÛ¿†ú]/št1 WË,ܲà&?3„ó ±13¤Åæ×› ï0w­+†ÕÇþK¼”‡V²A4.¿û·”×K|FÓïþ–éÙ8Gݰ†eÑ´‰}‰þ4U†*³»Èæ÷Sn\æoÍ-l _#ù Ó¹]n±ðrø] âås·ÂÝ$(ØÎmÖŸK|ŽßùŠDY¹y|Zò)&ñ{}{ûHu”–oŸ',±”öË{í—íº*å‘~´‡}”îµÿbýÅöK&ZE›$èMEܦ©²¢XÑ­ÊV…°ó3—b Ç(*,,‚… .Ñ޹4‡$©YKéDªõ;%”–\÷„Z]0\zõŠgDa‰HÄRBC*û3‡ì®È¦Ȳ÷-ZÀΟ—á.ì;”¯f5‘Ù;AÄ‘ªÅN9E1'¹_òˆäm–&Ž*MÔ ô™ÒL]®© Ñ5j;"4ÿZUis#>ŽÝZX¨£víZµ >Áœv:! ¢ZÁsDûõ:®zl̈vËV¶$ õµ'•­ r(Óý²ÌÆQVY«d.9r8“*¹Oª¿´ªVÊUO+-Õmg¥Y-¬ +“À¬kllOÅÂR;\ü°Ïå;é»Ê—$îðòýYÂÌtÈæ¹Ÿ…Ÿõ Jk10ºòoPV9Û”uãþ®ævܼnÝ p%ÉÂm;²J Éd[ssgÎÎü2B«l»ƒh2IL7OmÜɨ(Ò›¶¤¦{u¯{·`ÄÈÙ‹û¾±°b)¹ã‘f:ç<ºªâ$—»í€æ}žZX±Y*ËÛ9ü®—3jì.¹5¿¡Ð+$rD׎j][­X›Íéõ?Åa|#Ý+C9¸´}(“@‰9¦¼¯ßz3— ÒmCa"LI(„Y K`¥´QxɶS(±°½ç~I MIHjË5CjÇ»œímýÂûGô‹%Mx(tAèJaEÐÊøuäEº.äxP„C¬=Ü+²Å53ù¡P»š™ö` b’BœCÔìîàNàvBbQ|è¢øÐEñ¡‹r»T‚ê™êVÖJ5Æ1t Ó¹ÈùA|p4Ðá³C8£1ŠWã²2™DÉbrR 254%#]ŒRÜlõ á¡l-KÞ¼£â­ó+>~f iûæ)R§ÅžŒ7—®ÿjàø¯ç¼ð%¥ /]{ƒÜóáyÒwëÙwë®~bmÅ¥ÇwU|W´›q•¸8ç—k=wÈ’CU+DQ@ÙœUyÖE]:¥±º¨QS©òiÄ{¦ÝV(™}H¹‚æÃTñÙ´´ðsÂ']ýâ9¨ë9håÅAL6@Á‹HäX'|~ý<õ–÷Ê6W4ß\>‚­}kp-Ba‚hH¢Í=‰¡z m?À9BïÄAbªü®ð{ Ž%Ÿ46Ó`1'!wè~Gh©ñå¶ÐØFH/oKªÑ(„ùj4²ûh°þŸÆ®<Šò\Ï?3;³³sŸ½Ììîd7—ÝMÈ‚²!,D3  AV#ˆî BÁz*7E¥žªõV@<^8zˆ¨}Ìi±­V8§ê©Ô[+µXMå±”ÖË&çÿ¿™ ɹ<Ï1ÙÉ·»³;¿ÿ÷~—÷û¾Qüþo÷WäÜ÷ñùš÷—¼ï\‚…¬r©}iålq½ÜîÖ)ëÕM¡­êCò³ê!õ”ò'UÃñ©RW#º®êª$Iº* q©B,Aˆ™‰xÊ$+ö:*=N”lªiRUÕ *ËRU%˜ò=Îàäë¬#€É)q~WŠóÕÄ‘d®Œ¯UªÌ¬ÊlÈ0™j‹”rÆ­ÿ¯Æ9Oã÷5þ_ã5ãŸùß4®•ÀAÅOZžÒð§þ|¾ŒŸ šì“}¾!ü}¤P :jQկ鯏<)uB…IéÿÀIÄ‹zu¼hà‡âØE­:‚iüˆ½/™7Ƚ™13\ÜGcšV£ã—ÝÒtÕnú®£oÜüúo¦×Í™ÖægsV\1¢jêïÑîM¶=´§odàÈŒ_­ìŠl¦mM_'uçö±"_^Ã46¯Ÿ|#ô„`þõöe#éWSµ^Ë#ç÷>€ÉšájDq8&à(ûLòÑl_€¶åùçŠQ41‹ØÕÌM,›­mbŠöæ~ZŤôÄÌŵ³™yü‚Š+ê¶…•¢ãŒ/d}!ç µ¾PêwOv…¬/ä|¡–€ðb"Õɹ aj³cÔBÍÄ줆«*çÖÌÉ.—ÈK•ë#‹­õâÍòÍê­ÚšÌêìfæ.q›|—z¶)sGö~ùAõÁhÊë¨ÊÉ\BÈ C9Š–0ØÑ£rÔbìäë“Û’t2“G¤j³(ˆHxuS»Ô!•Š1àjó8°•ðÃûS‚úsC¯û“tFd3Š,ªp‚ òËÐÊfªñkØS&G$õû(Ñ£F@h0È+ªD3Q;Z…v BÝŽ2‚\’\¯øRÁ'H‚o£ÂArÔ04Œõ…&œ÷Œ“&ß9,1º 8NXcp¼(‡]Ïçp²á›¡1o—kZ4L»T¨Wx!Ç>^ÜÑÊ¥üIr8CvÛIIØŸ7j$EZDgð0ºpsŠnt­£6—©"µy/VE#fŒ5Á¨8Ér ~,_ó«[Wî=sÁø¾e³:n¸íËìùjsàˆúü³Ý»‹cÑ»Wn¸yó7ÿ²ï¯£ÿÔVÜsÅE«'Nº¡Æ¼6ß¼gñÊ»®ãÊÝ÷nœ?£±qiÝøƒk×[}Ó§$\ÚŠµÙ ¨:ª™~Æ.ÈB}\NÔ“ëë‹ò˜hsr\ý%õ%¹T¿Dî¨oy—¼yØ#±GÏÊÑ:?¨…~=‘žŠï­{)þ“º£ñcuÿ}¿.81†»%EnŽaœ£ MĉΠRÚL[ùáõ…"[~ ;eøÜà¼üõÁŽüZi‹ôšô•üU^o.(ˆÕ2stUĺfØÊaô0»AiUîSv*ýJ`§²OùBa”2¤ÀÔ€BPA N!K¨"OJ G JŽ@BRŒ¢ØŒyˆÞëÈÖppÞDl›§–NMª ¶qصڵà½Fù "%Ò¸õlU†€ÌsŸ“ª –X‚° ©]bHÆíåCX}ÏÉê2°®ŒK‰@Ïw”Z‡ô*s#sûr" h»ØQ¼ã ¤,‚½á(ò¦#§j #‹=EzWÉh³”|µ tÑÌZÕ ` ` ` ™W¸cæZ9š‹YŒ¸ ƒ D?(Úp„=(æp£p „@h•s£Æ4¿I`étm%Ÿ×0þaР×byHªóü#1¤“ùÖÞrþ¤Ûïøl§ëfü‘ ÐTg–XØL3ü4jÝÚó4Q,ÄÌšÃñ NûHÖ‡ObZ®;¼dßË“WOiZzâÔ8iëíë+º­Ç·mÝ;SÌê—msáÑ• F/ï¸ñ‰\Ås.þ—MmÛ"ŠœÈdC+Fœ?¯Óê¼{ªsí¥ç­;ýͦóÇ¢÷ël­nzÔöù3Îÿ±¦ÍØšÒ8£Ò¨ ôšó]ÔL )0)hMw§ét³6û"{UzGšn‰µ$¦Å¦%JÁ’|¥ZŠ]X\&ߨ®ˆ­Hô¤ß•N˜'ân~ÿ¸â£t:^hP"#­ª˜¦Î \8Qñ7ökMÒ¢ ËÑTÒæxŠÚŠhù±Ñò}'ágNÀ9."MtÄvqƒÈ¦¡+‚Å6 $sgý¬î4@TôjDRy&º&¯8³‰îÅ›NÃÐ ÀEo¤ 0ì0OdlC €Žq‡6²4݃°Ãß…ºÑiĦQ+šDÒ1b7ˆØTA8è!¨±#ƒ@ôùW$؆ScdyÈ"kC@&Q<5¹ypâ°êj™®•= ‡}»VŠVGü Ž`{î.ª³ªFoÔ±{NÑQª©®e°w>W”ñô®îëtú¾üéËKéœï¯}îŸ×¬}.p¤ü·ûfÜ÷úê¾/úÞy=øÊœ»ßüõñ_À$×ÌþSL/öº ô×Ô‰³ûj¨ÅÀ pTᨹ{ G¯;QPnW‘*"‡š‰‰C±†-ò–ÍŠH‰òA²açŒïUÿâl,eÄ|! óEGÉãÌÌ!BT¨Æ@®æ"€ÃA@p‰¸EzQðwÑÌ1¥ùVžæò1>D>ÆCtâÝ 58›•,(¸9çàJ]Þtºcçáw»Îš@—_YÖ‹ Zé$þ…tCɯ…b~ }‹ŒP „|‚)¦å…Š/þõDßß»>Ýöü{é}ñÛ¯Úº÷É;—Ü‹6™?>†*Pè9DoÜ·;¹tÙÏóÎϾ‡}ÎTìsRKQìs~ä˜iÊŽÒs˜R $Ì3K+…Åb0JÂÙL¸N:—©Â†&“ñnàëÈÙ;Êe_hLO\hÏ2Ä/³¯5–'®µ×që¢gé³–FÅ*›æÌX{lUŒ‰Ùêm—Fk›´C¤”öu¿†sº³×M÷<Îó^µ¥ÜÙUAï‘ØÕå+^£GSz„¯‚â6ª‚¶Ç\}dø_Ú÷м÷6Rз§B/nZ´½|‚ž%»í–gÑ\sÏ”Æ^RBu}ô}¥Uî;r#z`ó„Ÿ"^%ŒCÐÌ’L4ÌIE¤Æâ#ãN|UüQé1ùY9˜ëäîxOœ“muéBEPf$Õ¡(„Y†£B;#(Ò†= ;¬W˜Í4%7‰`)†¾KíÙ?jlìòvº°ƒBq‡Ä‘¸#c?DE€õÖå­&ž‰î±Þ/=ÖñXïŸÁ‘Sd°Fïp&Hj¡ª¨³(DYùü üë‚ Pa¢ †Ù›ï-‘úG ÌRÉÀÝ„õNDÓ9ç‚8³Ñ#I霚Dy”¯ß¸å;KTW£^ÓÔØTh&é7¶DbˆQ2þðâÎáÄk§-HŽ}ÙÄcǘG¶w.-\|…ñxèâö…Û¿½[ÞV¼é-8Ú3žvâ4”ؙРr{È+Âë'ŒßúC®ÀB”ÎéJÀ‘ƒ#Güá²ïË~c ì7ÊN‘h¶ 98òp„+Cö…€/À•ǃC a†°CØ%t =‡Âi§„´°JØ ìô^úHèBiû`ž¥cˆÎGÀUoCàØÇg»“ÝÅv³=ìG,×ÞfiŠ­dãg,ë†kš\ùkÇ$p`!;`Cäú,@õ¡À’<€˜ ¬3D°À¶'Ï´{`ÍaPë;ïÖàÝT©k0ßúO¸©1Êàp¾õÀìgÇŽ}esßœ Ö³…¢¸ö£5ôSaÏKiƒæÀ\A÷… +m_HúBÂ*ü¶Ží I_Hø‚äW d_P|Aõ…0¹(ø6_0|A÷…°Ÿòi¾`ø‚î ²;úÀù3ÐVý­3]” Yö${Rø½ùÇÊÀÛ³•´¬¬¬d¥À05)›‹ÚX?<âjq-t<‹vdweé¬i&”ìé,ѬnS×ñýê¢_ÝÅÀMt¬KDÁ:pÝ/¿ë~gI?„JNÊ *¤”­ìŽ$JÂ’HÂ’$QÐÉ’,¹@â9~µÏšHJäRIŸV%Éê(º±¾¾\[ ¸¶š,:N!’¼Ðiª•š-›| ¤¡d˜†¡`·>K¦Ò=ïõ­ï½Î8p_€W ¨Ïd¡uû«vómç’QÈE!– ÊPKƒû äy¹mÒ≟à$”86Œôéd6R‡!Qˆ-ØÅ)R$œ‹Hzr4‰(2b¼Ñ9ÿ—/¨8˜Ð€Õkô‚›…€„,mÙ=ú©%kJßöúöî¯YpÁª¸òºiDZ¹Ú®Yxå‘}/•kéÇ—]3î'ËÑ/®[7ó‘ï—ßu-‰ù[R ½à„ ¦ŸÑi3 ŸfΆ9–”³«1äÖkè‡Úqë#«ßb+ƒ%3ìÆXLÉŠ¤ø U|‹S¼ê–2–Cg9Db‘ÅQ“HÀ¡ï"VÃ^_Ó•Ñ~þ• 1äñš³$€¢Ó8¦Ð/"ü+¶YÄË /Œ)t[§-z•µËê¶z,ÖbèÆh p Å=±,‚Ú€®{}%¯èëy; ·£X:_“ t,Ñ€—'A] ¯â4¹å£’:Ž3i–j3µ³ƒËHnW G?­KCý‹äÖ^½ˆ< Ä8]C|ˆá´œÎ)I¤† 0õÉ´?%Ã#уP±å‰5ï·ïž©…Ô/²úi6÷оI«¦¾µ¼šÞ¼bù…÷¿Q~™ð߉8­Åš—©8zå¥(ŒÊ†Ý9˜Ö8å,&RÞ0øP\šÌM Îåæoà:‚Á‚6Îk²&iS©±IÖ‚Àá2­d”b—YËË…ë´åÆòØuÖwPTàò|æòÀå¡ùÒ2fq`qh™2m–×±£Šøˆ‰ød"BJ|a¢±H& Œ7 Ðánàûz|É'¾ x#Wîx ï&² à$7“-ŒäÅk|%N/ÏÍ“ú{+rÆr’¦bY¸(’[m4g(I!©ôD) k” è€DÔóà-)˜©¢|9â˜h RXï¶èæS£$Uõn茜¨–ÎæK¥¡øðïñÀ9)ö;ÂìÀlaa`¡À¢Ò<øÿê†a¬Šò†¬eL|rÛ«¿C±ï~v÷‡}½‡_ܲùÅý›¶¼H‡Qí½kû~_~ó³ï¡’ßøõÿþê¯_Ç‹Ò×Á|„Q¡Q6Zç,é<]o§§Òë%®5ÚŸߑڕ Â…dkjbxbsÑä¢ð¢d{jCê-îmãîSéÏ–6Œ®–òÑ"Ý$]B_,]EwÐïJ¿³>Ž}ÿ$ù-­"VŽ$0ÑT¸f”b*”„Á¬òN-ì^VÓŽ«HSµ]Ý ²)œ“ÒsRÕ ¶«Bý&ž8bÁj ÞƒÀB´¥ÆˆnT·gι§—é7y÷á ¾3'ó ŒÿïçÙ62ˆkfw `#Õ€DP9ŸpyHEꦪÂRêÞQ>§ÖRg Ô3Μ¨L ŠAu"Ý#é65êhð˜Íðú‡æü´ï‹•¿¹íÕÎ'ÊUÏ­[ýÔ¾µköôuÐÁñmè<Äïê»ã©{¿žÀ<ÿæ›?ÿå[ïü’dL›°ÉÿëU§>p¦7„‘Æ¢¶ÀN`g³×³7±œ …  ‡uA¦˜ Iu  ¡nG«+Ã(LW¹mÉÝ.p£=Žöß] Ÿ@‚ õA.•£‡¡Dq`5P[ ÚŒÉG‡f®ÅýL霒ý*úãÖ”öÚåÖ£d÷ºPÉ–.Aà±?ÜôÄ­ó¯¾à¢‹Æ_I±¹ÝSÆ=];¹µ½«ü^s¦ÿKº>ð0fbi2 ï&q¢ŸÍ}÷ÎB„SÕä ÙÙXØÇ9·$‡CÅ4!¯†¸˜ÍˆªVMU#ÙpÇÝa Û1²ê烓„Iíü*~¿ƒg)ìšvñÝ|œçx°É&ònIv'¡läÆ[O ºAÌuzŽîó|ŸëÒù#ôÊBc^¸~ðÖâ½=sRëuC”v’à±—t& õÆFíµAȬIJ¹¹&BÃôf˜<‡‘/ZKLkY¸løwî?x0œ¯KíÞ©]°ø zÑvÄ/ë»g{ùŸ¦Oྣÿö-9¼ˆ;S R,ˆšº2#­äÓN܈òa” †c ÇD ?ïÕ󳋘ï"bÙE,k™$ H@ŽaBvadÌj¾ Ð3ò ò ¸sò ’NÓ…Á[Öo¢™m ¢ØZ’R$N'èU‰]‰îD‚%Å6¼ T)HYaÀ Èý•ÂqLÃXÁ7aÀ X‹‚ûÉýä Y~[|wò¦øþgòàš”A[\S€Ô!ÁjЬÊ4ǹ` ˆVJRrPOR$}¨¯ßˆ½ þdUh³ë³Q˜PÞCd¦õ–·¯Þ3CˆúŠY³îà±S–ÏhZMß_ÞϨɳfß·•.b"†¨ª¾YÌ_°FôR'­Â¬jDrkx /8ª¬GpÎ8 n`zGÉ=à µp”Ý •|âä/w7Û+«V„"*#2v\58‘ ;†Z):R¥ ŒC7äï'¬71ù!À[@["¹_µIIóg¹]¬‹ÌU÷…GvTZ­¬YÐÈ—#&[F­X+ÕÊc¤1r“ò°.Öuá)±yƼð¼h‡ÑçÖÊëõ›#7G7ÉwéÛíám‘†ž_Ö~¢‰ü9ô§Èßä²öU¤ßN^O7í$«NTïT5>°|×›¹ýÙb1é4«ª¤é†¢˜x$Ρ~¢Jª.eÅfÞ¡0iΉùÊÖlºÁ~ŦíCtëAï…9D_†cÐׯ´q]ô’Šª©IÉy vË©”FJ3$f¦Ô/Ñ>c)÷Ò­’•·`7¯L¦ê ÕYÚ™“qrÏdoÂÒzA¢,â(È ± ’»ÀyÜGîBØ¢h--Á£S»•ÙS»­YW]ùì[OQbÿ)DnOõoŒ‰ôðRs1TÝ\Ä„áÔÁhQ÷†æ¨S¥> endobj 4 0 obj << /Font <> >> endobj 5 0 obj << /CVPage1 [6 0 R /XYZ null 325 null] /CVPage1:0 [6 0 R /XYZ null 324 null] /CVPage1:1 [6 0 R /XYZ null 108 null] >> endobj 10 0 obj << /Type /Font /Subtype /TrueType /BaseFont /ZZHJMG+Arial /Name /Rx05 /FirstChar 32 /LastChar 255 /Widths 11 0 R /Encoding /WinAnsiEncoding /FontDescriptor 12 0 R >> endobj 11 0 obj [278 278 355 556 556 889 667 191 333 333 389 584 278 333 278 278 556 556 556 556 556 556 556 556 556 556 278 278 584 584 584 556 1015 667 667 722 722 667 611 778 722 278 500 667 556 833 722 778 667 778 722 667 611 722 667 944 667 667 611 278 278 278 469 556 333 556 556 500 556 556 278 556 556 222 222 500 222 833 556 556 556 556 333 500 278 556 500 722 500 500 500 334 260 334 584 750 556 750 222 556 333 1000 556 556 333 1000 667 333 1000 750 611 750 750 222 222 333 333 350 556 1000 333 1000 500 333 944 750 500 667 278 333 556 556 556 556 260 556 333 737 370 556 584 333 737 552 400 549 333 333 333 576 537 333 333 333 365 556 834 834 834 611 667 667 667 667 667 667 1000 722 667 667 667 667 278 278 278 278 722 722 778 778 778 778 778 584 778 722 722 722 722 667 667 611 556 556 556 556 556 556 889 500 556 556 556 556 278 278 278 278 556 556 556 556 556 556 556 549 611 556 556 556 556 500 556 500] endobj 12 0 obj << /Type /FontDescriptor /FontName /ZZHJMG+Arial /FontBBox [-665 -325 2000 1006] /Flags 32 /Ascent 905 /Descent -212 /Leading 117 /CapHeight 716 /XHeight 519 /AvgWidth 545 /MaxWidth 1015 /MissingWidth 750 /ItalicAngle 0 /StemV 95 /StemH 95 /FontFile2 13 0 R >> endobj xref 0 15 0000000000 65535 f 0000000018 00000 n 0000000203 00000 n 0000030973 00000 n 0000031055 00000 n 0000031104 00000 n 0000000272 00000 n 0000000385 00000 n 0000000457 00000 n 0000006073 00000 n 0000031244 00000 n 0000031439 00000 n 0000032387 00000 n 0000006096 00000 n 0000030948 00000 n trailer << /ID [<8eba76c57efcb0dc35c52fd20150449a> <8eba76c57efcb0dc35c52fd20150449a>] /Size 15 /Root 2 0 R /Info 1 0 R >> startxref 32684 %%EOF qtl/data/0000755000176200001440000000000012770016226011766 5ustar liggesusersqtl/data/map10.RData0000644000176200001440000000223214661346505013627 0ustar liggesusersBZh91AY&SY,½ÖyïÿþÿlÄ^ïþÿÿþûÇl@903\qÐE†"kHFH ЧÆÁãŒÈ¾)2ƒ€œž÷&Iîäžç&mÈ<Îg²Oƒ™Aà†â“,¿Œµ–4¶ìð€!8l}F^Ã$;i¾l­ jªÅ€ÕZºkœýÇ2=/BDb3~6²7h±¶6†˜Ú šo’ ù;—ÎC’L`¨C$‰4Êá‚Ï;¦ê4hÑÖÚý¼ÝÒ¿ PѲ ™ñ"ˆ@‚(”õ)RUޱЈ_5u(¡U8šzxl= {œ/_àØÁÎÔçeå€ý$1çžuóæ:ãçÍ€Öµ­’I$I$’$’I’I$€uÔ’I$@~óÐ_ÁõUYŽCÇ@è&@®rÍ"LÛá€Ì05ŒI€t ȆCqSÏM`a†uck¯úgiq+²‘_éõ1£ÂûèâÝðÃw>É‚ ÎËGD¢ŠwÇfx çZ™À´ø§BµëW¯nñ싺Qxù[’¼”ë¼WÌõ‚@ljÙEvà!ø‹/L«?›˜%–¦,5U hŠTéä´„°Ë³§íáѨð;H›Ìàðq`$“iÏäz~;ýœýc¿ßy[ˈpð@/ß¿ÀÞC»ç»¯ ¥ÅΨdæVWŸ|S&Ð'ˆ]ÉáB@²÷Yäqtl/data/locations.RData0000644000176200001440000000104314661346505014703 0ustar liggesusers‹uTÝn”@ž¶¶[µ´»&ÖÚk.ºÛöÂDñ'ÆÆÔTc ‰‰ ÂHf™ °mñÊðô™êkøÕ3p ‡Ñäã çû¾sγï_ú#Ä3˜e ˜aÂÖ2à2`Û€¸!d”©Ì ÆL 0oAœ”ñ6`K 7›€1``”ç`°¸hýwwæ.[««a` m5ÁϹ(°ò³N ™óŒ—iæF\^V /à*Ü(Mø¥,Òˆ£ôáJ©&Üðù"æ¹TUP ŠÿÝ[­ÕÛ¿[ò<¤ÍW”|°B¨É6ý÷,— žUSŽ?uŸó쫬ø@vÔHQË’ˆ·!óºŠr]9†ü)/“JK§`èÑNG—I*{”íÏHû/˲c¶€Á^4½é~+ÊÚ«:QÆñéïäYI¦?Ô§§´ÓÑõô”²ý#R6óH«IY»cUIÊŒýã| :ËqÏXSýo~Š h?ùî ÄAXÊv×ä(Yä蘒§\«7 7$ž!ÆV§ŽùÄ;aõòÖ1ÞǸ‹qã ã«oMtñþÌëóÏŒ÷¿_ÁúåíÿPë§÷Ù™ªå}BÝÖ¯7û«å=¹j|Oãæ~·¶Më÷ÑoÌyûxMLZo!‰{óE’ãÖO·ùG{£((7ΕMûïÌå…ÛöP/ÊÀ1&øò®ÿíz€qtl/data/fake.bc.RData0000644000176200001440000004172414661346505014213 0ustar liggesusersý7zXZi"Þ6!ÏXÌ♨C–])TW"änRÊŸ’ÙTªµ&²†‹KQR”èiʶ$²¹`Âã9\šÝØ“E7gúÆ€„gzFG`$éâCœÝ°¶ŒÍvŽ 8eÐön«o­b8¶R•Ú“–¾;QwެÙÐ ø6ðÒ.X|[Ìá<ú0@TÛÖ{ðÝOq3cö‚ßÐíÐtõ÷ è´¿Û Ò1Þò®yô¤¢%šñ]­ÐížeUÒ¡Œ}j¸ÄÜL’S¢tΨú@K‹lM нrC]`ȃ…˜?›] ÊQ~Àañª›ˆ OûiyS˜[vËHÔ%9y8€p.LE‹•¤CqY޹»~ ™0Àƒ<%ÃŒëfP•Ohg’ätÄž®BÙý–Ô›B£Ó{_Ï} wC™«=Bù„‡ où-Õž&–C”nysÓ«Ãù.@c›éFð^F|È÷S0”ƒ¾¹æk&x@²}_^ú˜ò¦¡ãNLkþï=7Gô÷W÷ƒ,ÕØÓèßd=/¯˜øSþ"!ª¾[¡ñè£Ñ=Þ†}‹*R¤xÐsNMùñM¤ELSN 48yb»–¤ˆUöúù¿òBºjE7="¶àL9“p[øýŠFOg;†¾ ûÍ8ð%×þIöW®^ Ó©Z¥tD1=æ{i{Î5LêÔ +¤Ðg=>ööÛ‘ìEУžã> mK„3ÖHõ<øCòBÙþ<~ðKî;žV.‘Ø^ç6PÁ£ÜfõY‡¯ÎjçúÑ»°µcÕJàE‘JÓQú9 »)+u¶SµETˆ ¤v]‚ìfš…Ó %ÖŽÂ…~)°ùÿ#˜@î?Ñ.’Šø¸cq`d;w;#HaÑ~+ëg›Ø8®ÇI¿Mß}}õhøk²w¹¬âäÚÎ'8G‚†jßMC%šqÿ¯ŽMÛ  Ž!@'CƒiÌåà<ñ¾-ë–5‘OGH mÅA1/µù¼9@V: …Eôù~oú¢|-sÃ)þ‚P›`„+¥¼ÀzÒP\:«&ð›t$:*@p°1€*ü%JÔî1)ðº;Éú]‘JÃWÀ‰¿3` è0©Þ[ˆµÇ;曬=¦žÇ¬¼Þ…ô Ç®gÝ8ÎÈ»¶kÖÝ¢nNj…É¥²Ÿôv7&V^v4É™Dmq#µ íä6´Ï‘®›¦þ~o7‡—”¸£hJŒªLŽãøô ÉyË0ë‚Nž¿rꈩf¤³5E M=kãà;üÒ„$³·IhÏ])‚â%‘¬){`ù:Ù¼QG¼73ÚÊbRMòçOÓèQ ÏÝ.¹ñ¤æœô6íodFDú–ÑÊœ4}(W’tgtµZƒ_ü@ðÿµ§ï³o/±áèvñÝ%4òªÝº´R¾é­¿½© õžØAHMýó„d„Ä{±!ºî+§EEÞ°œç†m(çGO» ÷HUƒ[ŠC/íh»ÏÌ ´qþÃ÷=U‚¼µm&v–häâ+Cï.í lNKýßç(©xj3ÿ Žë¸¼“kŠƒT¦2•qdšãu>Ú¬ÔFŽ¿{Ößh_mÍr·96¹ö*Hw‰Æ}'rÚ¼„Üâ4'ÈéU<´Ñ ¥â6‡òØX‰ÂåNêwÆR¾iäÔ†;±Cb”y„…<³Å™м+Tu”ŸÎ,ÃÚ¸ðfä: ¨ÐÂa^ùñÀéÞ)YM(™-e]h†7GU¶ž8Fá!C·ÝGò¾Ù`˜wêl5£( J½B”åzLæ_H $w oηNu ¶9 d2é©za†È<ÓVŽè€ä#¿]l‘:?ë^=Ic8ðêݸ…-”ïlÍçTØÝ¸~¥;c˜¢L–- c1_Thü¾1¡Sž¼ã©1aY×OÖDÄ z‹¥²|'Ãçˆ@Šdw/Ç?8åö·€S@È¢0F6ÝkÿH²ó­±^•¬ g„ ôÎ]q¢mZŠ÷ËqÀÃhà7é`Œö°ã_Þ íI­ƒ¬oñø‡ôAkzÇq´¸ƒ³(˜ÿ#~†b`Vnáîëö†¿%"Eúâãb9V¡í‚ÀìÊÝäöŒòUŽpР'èsm0T!9Ùži8¯‹ªqßg깇t›ú)À?±¬ìN^±Lø@Äpä•BýÆc“I~*–a–N˜¡§‹ÿ±ú_¶Âþlðýš‘‹9[.¼’4¶ø1DMÀžŒã¿cm¥ðÆ$H<—Ÿdÿ§Qç$Ï]ÓÐ#f$SDF[ÀC¾Áñ“ë†À¤ãÖ ,Ç0ÆkÁŽ+ám4Jö¥ãÙsÎÆõÝNfæ4ƒâXXz?ºÄ£ÕP]õžì.Þ,-+÷­$´Wéµ}xyÕÑSŸkw©IgúùcÊÍ{» ã‹3wbѤ¢ƒÂöU+ 8‰â‚/íB$¥h«IÐe·È(ýz‹×{êçT–1è€nç~ãÔn^Œ]^.ÀVʉÓ?i ˆýûåNRáÈ{ÍkU•zè’”´;ÚãÚ€ ð±•$ñ˜šfÁ² f(õ¤¹)†;|À–‰B{(丕™ÿŠäø‘ÍY»¯"€ZÃve2½¨©4˯ÁN\µÔNœé!}Öæ|CºXï"TÊ À0Yº Í[–]M`úFtŸ€àW!ÑØaÛðù~0š™H²t‚!¯¹Šî›R9V´¤Ê•öœËÿ>7ðôpRJw–¾³²C):ᦇùÆ=y(ñh¬6Ü"’²ÈƇ LS ÷QÄ T¥ý#&m«$òAª3WµÑ3Ðc?£è4'zÁø¸g‰”çÝ(Â4wk2*½ÂýÈ¥V°)_Rû{ÿ…Gw“P}ÜÁHW=Ô©—÷ƒì,B"{Š¡Ùí¥K9‡k;½A<[fo¡iàHAÒ8 ÅBPƒ8d›^Ššï³ocÚçI=·Eä=­6ƒ8¼§¦ÞÀiå©Þ¢¨¢Rô@L”W/dDؾ[ï.>¹k~Ï%†¨Ÿö­7’-™Rß'Næ"4{#ÚI7Ø!¶M'¬9tMeÑÚóÕuÉ•¤xÎìd¿:×Ý9õ“Öaô&¼-mÖÐPb:Ìy¨hS¶ ÝíÈÅÚ¶ŠÊUëgÀ\*™>* ó_u›‘󳇘Ø'K ”Ænö9dBÌa†TÇ—Õº'–bØ”±At* éÞ@t÷ù32Mèí;c"²¶baÅÿ¾‘òðÀ“ˆ’ý±‰,¯÷1ÀGâ’ÞÄi¶ &ùªÙ &Dp’0Zª~ñ:l-sã!K8ÿÚ‰–3Èà†5ÍÉf#<.Šw?ˆÉ¯Åô@!‹êú?âå$âÉËòk`ÏwÒ©¼æ†YUU_£NGróyr&©Ê¾uÌŠËÒeÞI^ÕD¨ÿÐy‹Ö“ôéY¸I[¤±AÊ(õáP)Ú’‡O¤ðdf;„4õ Ö¢åP·Yî®M>œ\®œæúÏ¡yz¾•ÒÅçXÄÒM î1Ô%«kA•r+”D¤T´DŸú;€¦ø€S½IAÿ­r±ké ÞÏ4€;bCýŸnS-$;þeœ¾ä’/´Ê~Í%aó±Àþ¶ZuZ4Xú“X¦ µôÃH+œŸ$ÔDT0¨o3X~¾¹"öŒ̘+M&GÅKQ¡e‡N‡N¸é;þ<Y~4ü¥³*;,Í}“ 1|÷óAXu¼(ÖÇ!޶0b(‚’iÜÀü«Ž‘Z¹çÑ|¶×&»ÒFàw3Ÿ옣}þ ÑE*(†èg1ÁäðèBÅø\NWÆðÐß ]ßÜ·Ì߈۩ Y›:XôŒgÌCäB ö‡%ùåe§¾|LiYÖ[DÓ‹FæéÃ&åò÷„·¤áæÿmó¯R$úoX£ïM†%óç^ˆ<­åª®L-‚I>r™ÓyO˵ ‘Í­ÿc§¥qPh€O´ßˆŠ÷9Cát³u²0ñwl©Ø•Ú_ ¬Å-Nôè¶!J'/n4rDoÉÇ8Môª]e3œâw³Z8UûÆÞ;Ä«ž)¼”áÇ¢¢6Ô5áŽ2¥«t=ÊÛ0•9eP2ƒÿ!dÝhÚ—+Zrýœ£‰W^åRÀ™]ÝV¾dÝ~áe£€%¸ÎÖšï±Òmú.r lu_“æÊkÞk„iÞ6xú¼.„Í©cÛÅÉ »ƒ_W 0í—)³^ÄC3µ–´,"_Ûßù†³på+Yê㶤j°²Pšôøâ×݇Ì´Ô9T¸Ùø“Êür8ç„_[h0h‘Š@Ö²n-{/ÿùc–2»~ï¬ë]”×vÀóïë_ë´É–ÉÆê=3zpT<¶‡Jvruä ³ëHùÝ;ϲqóq@OÈx®ë^¿ÄÇ6V;…‡‰ÐN;ü˜bD\qá?(àñ„ÇÀþ¹1uô›g‰èutõêv°â3‡“ìwÌ5ñØÖsc Häa`ö9MÉ?]8¬îÝN8+6­¨J_Ó@~”R1A?\¯§Ž‚^[¼Aö^Ê[$yy4 °’CŽ%B`jß“˜pð!aKk¿Í'¼çå:=²Š}Â÷àÍOt­…Qâ)>ûÙ²¢K\¬MkÈñšŠ­¥în·uàX#è>”`T€úN—sAdžöÜ ì0·’¨dROjiµ*ëáVÊÇçˆñÚ<*®DtŒlRÚB6å2Õo?T|œ"$t-Š¿¨Óˆ7#Háú'mq;dÌwO·2¢&#% Åö­‘ƒ»T Ñ¥7`öØý0këí6wáÜäY<<¶du¨×óþdo(Mð}2nD{¸²±(-úã²;Å+î-0 "Ûä^×ÃÅ?¯HÞ¬öÚ¯7cY·/ÄäÁk»H]☸“'üί˜QM—Š´4È SŸ8s/Çx›âMR1¨ŽrÌq/CÐzó­5P€·?*°!×6t§ŸÆçÁ‘ÓŰРÎ!^©{õX|àß{eÍ|’¹• Ï¼DÛØ„¾?ñ©ÖÉúˆõ9–o§‡Š+HÒ"K(‰jØûªB˜f€Ê£HªµrÉOõä%š%·W)\ÛVû5{Ž ËwsOGÉÚ§Œøc¾Å]O6[¥x)KivX§H³ ú,ØZ 2$Ε»%f”‹-ñC¦¾ˆ'5Šš&À¥›Ì?Qº±ÎGo7ZÁ*:3­Ê3òN1h¸9R9¦âç8ÀfR`A«Ã“ÊNiøçU³ÀÓ:£ËÏ—Ô¸¨Ì™£…É€oÜ 9G õ‹ˆ)r¡ýо‡.$¦¼xÉS]4ÝMFgjbQ[*uáDIqßm ?HrÌÞ2´Í•0òÿC[½¥a…{#ÅYÄwÇígœ ÿÏ ØaÅêý˜×åƒÚ0Œ)í¼y÷F‘B„ßuü©<ö9îðñ@ái,Õéqõ6‹(͵ ¶rÌ)ð·àTÁ$óko­ã:?ñeâ>>G{vÿ^¥žONÿÏG5ôLDª`+C¹ûCNŠ'…°ÿÈÏWr0®þ‹ {iåw«}o!¶XÞœmt3N┵ 5àý”†(/ÙÈ=ϽsJxWYIŒ£[ÜØ1›®¹ã‰&Ò„e%ó*Òeó›öP˽?2Îl, TÓ²»<®½„á¡ÛŒ‡:ï=´!q$b,Kw§5!èiþä ý%€E&;ðѲ½pÄ;xÖDÙ›ò¦êØ\Øhº¸y_•O äuD˜CP*^­HgÅœæ.\;ŒðãÒYÅÑߌ g@-´=Vu€#×€ÞÌÈR¸¸WÆë[Ûx«Û+[—Š— 6Cª¹,qìv7ÿÄ(ò¼×Üœ¬†´c\æ–.ÇpVgúTKtªÀçHÈV®M’h´~\×[”š³J‰d4Bð؆1~G^š« Ô<þ„±×Ù}âY™Ÿë&êQé]2£}¦W(Z„eOjÑè$@2ŠàiÀò#’Ûƒ:k†¾gÈ‹£îÍb6`µðÒòÞS×â»iN7ø¥Ia*Øpõ@1 ›•dÅ {ùǪ“‡”¡þæÖˆ”ä!‹úNí—$RÔMAÙ±ede±–ÑÈ/•ÉÓC ÆëwÚŒh¿:A çH¬èÅÐIý !Çî º.IÛ6ÁuÌë&IžçA·“á 3®‘ŠxúÒù¥Ÿ ‰Ÿ<‰8I€$ÖpCü Âwf³³1ÑâhcFmùl/§Nyñ?¥p‘ÇËš%üؤµ…Ã^FÍÊEÂÇï ÖU¨‚M‹zâ.ý_¡åG ß>Î7ã(Ȥ!3:• \Ëã4LM·•Šê^h GJŽ—{ˆ’·¾ ¹Kc°ÁlÙEE£ƒÔÙ¬TÚáÈ¿`F«‰)¸ :ÄÃÂÏꋱŽÐÌ¡K^ /ñ )Âpqh¶NÐ_ó—ü€D˜ ŽR¯ø ¬QùJŽû%Ñ4Œ´‹¨.úšD8½à*ÍÔ«Rö6Ç,Ý<<χX .êÿdìgiƒ÷^>@xÙßéUY…A#£^Zë$4·éÔì]˜Z4Ì›µµGéFU ¼PzüÈ “ÔšxW@ùÇÌ‚Åzb«›t­ØC +î¢eFiÉ@¹°p ZægRO§¡ê&­ݤ Åu»§=57g<§ÖJÏM#]íOüëò·'¤3Òž'}ßk®o)]DuÞ0²¡—?…ŸñÀÜŒÄ!iýáÝI{œíwZJt^Ф‰’¯¨Üœ°q§ ’I¾¸_Vc+ GätÑdùXÐó^Gn{Ṉ.|×ÌÑŽÖe÷k7ˆQ¯Z#¤©ZA| y)4¡£+Ö¯iwv(bM'Ú<$³–¢ˆˆ U¤{h¬„Md¬‚ [lý¼Þßå†c÷ÿ G?¢M°~øQ]—cнÿcj[GzÜÐ µž£$ ©u }NÈW-ÓVÞÖdð»tÍ´ãþ·ÆÏ¼1Ñåu×c¥4v‹Ö _kYàã¹AƒÎ0™x{rÐï¹¶uŠò ¶¨ Ú Pø¦ü0ß­¦¸ûe™=Ãï¼VN÷èý¸öý¿¹æÕıt¸8ÑnNá¿%Š}Ü.ƒæ¥›K¢ö ¤ïŠlc•Ûl¨à†áõf 5 ( µ(¹õ$ÏGº ¶ ‡Ôþ‡öË÷)X5ôµ5E<*ËæX¸Ãá=î%Wtº³¶>‘òÉì‰@Oˆ¦µ>Ïâ“ÙIœÇ^öqÔ"DùíÆ*ÛË•¨2Š •LþJñ)Ë¥J¼õo¢—¬Ì0à Óù ûH1c&®'ÝHÁÄvCïŸr"Ü-sqS3º2u‚‡Ö©kS°5:zÄ•´rO>C6WMãÔå+&䌅²gES§aù¯ß ÄÃagrû1¡x¸à@qêƒËÂõ…"/ŠþÓ™ì5»ÕÿèQã—°2kbÙ -"ÆN.*㢽…^¼»Ñ‰}ÙöÞÃUèH £°\ç|P5M•åì” "éßz°ß›7Æžêªã¬Ý L J¤¢:á)ªgç?j2M­›ŸþJe›Á*9üì8$WUT7OûX›ô*¤ÜÚŸý†º­WÇkÀ_—exN,ÕÓ2 X¾Aû¨$ Ët•M=Þ¹ÅØúÐëéWVcû ¤¨•w¯þ’w®}ÏÄšçFtˆä"­– ŽåÇ·‰]þO¼’a Hà5¹jréÙx~«cÇ*ûmà@´¶dNFƒJi ŒAø:B^ë»#Põœ"5 ˆÆ="ÊÉp¨¿O`ô*GÍÏ)Á]²O¢ xÍkU#œÕç6ô’Ð+sNY+AèƒrZg•àˆœ”n ¬ ï;úÂß“T6¦Ò-ˆÈÇò…’äcöšVú‰àŒ}ä‰ÿc²~¢kS°Ð 6ÀT"r“¡½ƒÞ¤m´—Œ_"À ¿Ò¢²|>û¥èfÒÉ?UÀ’ l˜’ ½@ñ‚âÀII<"rÐ*åÀêõ¥ïkô©`¹ª×KµF˜` ºøf÷—‹ÿÿö}Yî4ˆ–ö¹c¨‰±‹6TIs“auì¢Ç"ŽA~F —@&·'…™Ç7íu×ÄF½ZÇZ>?D§jò8Þà§ mð«IWÅŒwäÌY~Þûy—ä ÿfÂq˜hTNU>Æw^wÏ!bBÈtŽwä˜iñÆÖѲ;º5n)ñ( Ɖ*}#ÛÕxEf´Ó×ÚñfG*ìr ±ÍX3úo¤­ÉÇ?™¶òqí- Ê`åK»-Òüµû-Æ?s‰}µ—ðä á+N¸‹ÞÇ›9"Bq3:ü¢vs×”=ĀЯ×}1åÝ~ ª iË%s½¢G$F&ÎÏç¯n;ŽÍZ´Ëþ#µ¶±_«=¹1<*«œ•â¨grÁÔ½g(œoQÊ'ÀëVí¬HÀ †œ+$ß´`ÅIý:?_{ëÇ1ËÁIê|ÝNÏ¥KøÚJãó ¿nŽFX:B;¹¹Wý¼¬„Fgµ˜Á¸%dŸóe­×§— ¹ãf¿äúÒ¦Z2Û)ÄÌÅcÈÊXå ~íEÑfì~W­¹™âÈóNDi62øˆì/íU…ׂ°Ê#£:Wm ´yGheŸ$gƒ} {(ĶmÕŸ(%<] ¿" €™„OÌ‚“À|m*Ü^ãé–y)á½®x‘D1h’¿”\ÆA²ø°àИõÕS³Å Š|‹5žX÷=QÕÄý<ªÉüE«ïmS4Qf°ƒ›uo›Ccáï¨k>KTÊÄÛiloß~°ë•ÈiB•Ç>l{Úizµ» o™äâÔFªàŠsÔ‘ °ñ,`2»bwà3v+Š„<‡œßaòÚÿ"ã'C4Þss[3 ãy{–ðÙ‡£Ej)”§Øzkñä€Â‚û4IDÍq=¯i˜ö‡%‡A ùA wAò`Ħ2@·v‰/—ÿ“º!…aÓÃ+L²UÜÒ ‘–n’ß7Ò ª/—1=gã7ÇBÂç^îøBmÇ7f¡û‚í£ {“âÂÒÍ3JËV ã£ÜØáØ’ˆð6–h n­^úš€d²v,ÔI‚9:†ó 9m7ÄEeý¿÷‚@‰t?¶C“ÈÖýˆ;È•éQ+6ÍÔŒZ^(éÙ¦"´Âci•oDðÆ¬µeçÅŠÞÂÖôqh3kPÒ0·Ú/›c FÉTsV½eU¦™ÆYxz9ŠÒ›D]z°Äçr¼E•±bÆã@‰G/•7÷)kÈ­_ÅuON­Üd*®%kžî³uc>ÚîjµÛìâô*õ…+V”‰DïÇã½e!æ´ß|ÿ¨Ÿ’bZ¦»­®Ãk[XZT\µ ZŠÍÓFfŒë±¯1Žè.«ó*Ç" åÑ[ËñÌm®³NîFšZf¿Ü»ƒ¿T‹üêTC:ÿ¿”Ø|cÑ4®±Iú9;iûpf)Åó<iíûX8&D¹ãÐN•Z¦[N\ï6{øe3tUñåÒ¤OΈ¨[Õf¹ux,›A€îѵm’ >G†9uß*¯²~mé=‹58c¶ËÉ­×EˆTWxüü –µãöÒÅÜøŒ|õ©xÕöÙ*ÉLüÁ¡>¹sªmïcðTô!$T³ƒ"wf;†ãà…§KéòQÐYÐV›ÂþÅ %m©à»²û™J>ÛÅÃk™AySÊ‘´¾¶àœ ºr)W¤Û¨¸¹ßmõÞ;½}ôòfp";5!Mª“.üУzñf (Ï¢t‹ eD¼=r†>×o¬œ:…¾‡Zy$Cœ±šdK€Ò" Ž áQ:#”.ÇÐ̿Ԛ­DP])Ÿq c/Æ{¤÷¾DJŒRà úò zwÊSâCdÙÿ´ ¯ÚXᢔ\VÖtÒ7>dì™Äy©C¬8ñ*±’X)ÚA°JÐWØ!§²5…Õ3ö‘>üõ‰`óÚ#ͬFªeƒðžÉt4;ïø8L¬7ßÿ™ÁÁÕãµ³ 3vÿ˜ ³IHïNmµŒàV©·öÍ)q›]ÌmoÞ~6•‚mqzüÐJ"WކUzk÷‹ä¯Ï¡Ø.p#"ßù’¼"Gó5á $ÂßtÔŽC)©ÜaƒÛš5p“ЄNó¯Z çÄ/9–›Ú·€ë¦–óÍs óLзœuîݱÓgƒð²ø-«Þ­;°@[g W’âÁY—\ŸRÝ”¥ãW³ÂŽ0rHnÚä.ܺ Ñçßó1ÔžÄ]E¸ëŽÚ¸¬ªª¿ÄU€mAÙ翱CR»%µ´îñ“áuEJ•òæåxQüÞ<Ú˼*cŸþ}¹Ö¦9³[7st²W£¢?Õ¤¢-9Âe™ì²v Û0:Ï0†ì*Êäè!çi.°ì Ž<€~ÑÛi¶{×ê"a× åæë/ó‡Q™ÎùŒ)_®ÌF!š#;oE?õk¢>pŠ@ZÝo¨ŠÏ)Øö[6\›­Õ«mf…iÃF›‡`Lu¹€XœfÝÆ%] ˜ »¿ñ»¹K˜AÖì} f÷¼»r®=ú‰u”LžÕßš›\øo?&§«ç„ "–HY ûPÉ-›(HÓŽéÕ™ HÔOía2:VN ¯ÿ~Õë:ÂWõF$„)E¼ÊlÌt,.Kÿ! ‘¢y×K¯HU’|d•{H_Ýyƒœ`±RSŒÊsžhÈ„7Ú¨Îöó¶ ,ð_©&4•mãPê›]wy0s9èg²Òäìr|öï©ßdø¦8¥¾Æ„¿*5éOÙ;§"Á‡·`ÞPW{½'—q‰ÙË©¸ÂÀ'„>ô-¼s9vFÜ8'J×áÎ×ïÇ +þĘ%7~Êà+ÌhaÌ9 ûŠÞ\ž³;ƒævAFÓÔˆ÷%\5ß(ç1ܽœ?Œ£OÉ.mð­›Ô£\¡Æ¡ˆuÎëþ7LJj_6q«¨Ç3²«¾•É ó[ÑÕ¶99Úí ÙùÄX¬ã<®jáÅBÔr;:Tç„´­57Ÿ‚ÅuC€anxèÊ0ºå'Nz\¿NüÓ«»œÄnxÚ7÷ ´Ÿñ]k OÆDØœÕuˆl†„†ã¬ŸI@0‡ETž™KÓ Ð<÷·[±‚ß(–n†çm|žå¹æ†ÞÆ4 —Hò;›{<5tM]µ1'Æ„â]¢>ç‘ô_Án»XgïýÖ`pÐýñaî‚ F¥`þGùæ¹Þó”!ÔÃ<Éò_ªV >+ WÑ'‚†8¼Py˜ëzæ°TÛ½lÁ9q5†û½2¨éãî„5ÿ«A£o›ƒ|=÷䜆º‘iГ‚F_’²p¶›°Ö /)ùÒˆ+DL A'rsúi ö±NSš3u¤NxïÚl7äÏsî´?»··f"’Xr⥩à•Wp®<«Q-£ F í©ü8 ¤+‰em=zމL|´h¸,éi(Azªø©²yå›Ç‘?'<ÒW€»5vµtØ„¥é{ðÔÂ~ù>{‡ïFÅçù•šù\åÂ-ÕK:("a~`E%7¸}kUú´öªE÷ÌVµ‚c̱êÿâ$ï³T¢ Ñx'¡ôÀó `—ÓÛ¯!²|Vâßj‚”H íÇB"w)À~ôƒŒ/³]Í¡öñ2L%ÕÅ£ÞÆ\—GOØNôTɵ°“,Ùÿm”Tn†ËGÛ`‚TãÚÆ"IØtÈǯ€ü1~¨Ö¨f‡9åÓ!©µuÄÉxè!yÛˆ‡Æ1Lß\\õËÆ,OYñœ×ë»A™Œ Æâ=L_X¥L††oä>M?S)óåÎŒä,_£hËàäËõAþò‚añŸ$ƒ'²E7uçÚÓYnx+9?ýÉTj&×Ô„Š•÷ÐÒØ'Y ŽÊ,´’¸‚:æ Ž=qpÖŒB-ŠŽ«q#¯¶¾S„Ñ\©Ê T£½ÝÕ!¨b"ÈOŠ­Fàd¿SÙ4*>ÏÄ*}<Þ’:5‹0çXpÎÊt¸ vã¼\««ºóeóéÅ{›×ÆžÐÏѱâDˆ«ÉĬ`<žE}E¹$°&—.ñì8ÄÀ˶]Ø%ÚiTDç.®¦“B=¶` 6Wz‘.ç.Àš‰ãgZòscÜæAPLÈ­Ú@þÄ÷PE§Ê¹Z¥õùõZ ƒ«PÉ<}I‹ÖÌ|}}zƒ§| œÏè~ĹºB)MMçCàa%åk\ÒKÉVyCîÿ“Á\Pù€i ‹“RR[®)ƒÊ‰—ʃqÔù8Ï:×¶zhŰùòë_ ¡t"œÈo ©hÚ­žâ =xï¡TêÞ¿xêÐ$Í\fûöù³ë„ÄÎñ=g¥ù©• Tyž³NÛ^ðØò ÝòG߯"=¦]¢3\=Gu1§%÷µéeÔà Žiy¢-À%á˜È®¦Ý9®¨&.rù/mnˆ6ø¸%F9¦^mË¥ÇBÃÕ›« {„fá¶Ò¨¼q‘›½*Ç1¨1"wµšŸI/æ—4à.fÍ`Œ¤(Áך¢ڄQ¦rÑÐÇ~n”éˆ<Æ•A.D!Ðé±g©Ú9”÷B¾ž§°`±œð}ndß®ZE4Z{ì³{÷q?zánÀ•æópà¯ùÒ©ÃØHëBù¬'‹4±•3ŽW?F5õ™Å|))Ó;Ú\FBx@ŒXõ/¹Šæ ÿ8{h¾‘I)<á¿ò/2q_?¼œQbß¾.‚¡-ÖOæåŽ:—©øi l”¿¤¬áË5ÜŒ}B™¼2‘¦}Ã(k~‚çÀ®!*4£cææ6L“Dß¹ÞŽ ûKÊ!2;ªõPÜ!øóú!Õü¨{ºôÝ=_Ëàû÷‘8ºàšÛ&Úwq¯¼;!a)ͨ•ÁЪèº"Õ1wØQSO>1ô²ñÝ|‰”~é-Žc©V[œWÚþ¶’~q¶YÏÀ®üÆŽRp/È[+.^ëÅ"'µx#rOåjœ]³€Ó€šVQªwgóbÕhôA;¼¦Ì`âÆZï ‰RŒZµQÕ\:ó#:~fžPõŠ!>u°²B xþÔÚë1p«¸ ¤¦·ªp\lÛéÂ0¶ðK‚?:í ¢û|@¶q° W·Xfšÿøys¤@1šHM¦Ì´¹ò‚ vm—p’m“pØç_Ù œÜ ÷fšs´§Æ®6C&'RXçÉQÀJiјµ”r'Å3QNê–ÉPÁéØ.;ýøÕë±½BÑ­mP/j]¤·È³âê·;¤ÜÓ˜ërÌíæ81–S"\Mbûñø5÷€È9äÁ‚™­7M5N«ò©Í‹÷M‹bgÞïÚé—|cä#iPõsqG(Ÿc@Ç\¨'ËFËÐÙøìÔPÔPQËJÖ£´17%ÚCûƒt'ƒkÏçtûŸñêT°Ùé>šæÜ;aÆTGcªÏ® ÒOXË9|6†ßz»»a>»Èd—ý”Κ'šxȾ…J5[rŠ‘é ž¼`!dBº×Ð+àå¼´ð¾´Ô_<ÓfÌï¿®}×¥¦çKÛcã{ˆôY˜çq£²¡nS”“P%;joYÉRõؽÿû#iü“‚o/e¥½Y MÅÛÉÿ÷QIqŸ§­)ßJRø¥Pà |]>(-ý›‰qwFóyÈWYºëX@rräV1<ñÇwW†Þ3‘á;ùúñ°2!‹=oáíŠÞ±ŒZÈçtÉF(­2–uÄ¢*Í-6ÃÓ¢ø;Ð(@%è±€÷.!}ö.Ð}<ýyá5ZéT¯6|³S×È1}¡-h£"%ùXÕS?Ep OŠx^WÒ ÑÒl ‘R5Š–p ïwIýÍ|t·U\pZ. J0PÔÆ:J¥ æiÛrÔI{†ê #ÇAøÍ© zr¾«šS/}×ò§°ãT*j `Y<ŽÈlÄ&¸ÈêxPR¸Š­ýc<‘#ÚÅÚ$uK‘™Â»;ÞLXì‡`ÉAƒY4Z†Ü•ÑzïðÑËàµk`€ÎC>1f‘›Ì8Cfµz$ƒ]‰—ü+ê£n-]‡Â’Cï€?„t ãkŸSÐÂÄÊNǪ¿½§‡ r¨Yev@ö´’ƤÚ!l>l_ +mÚ3÷ žËN’¨ü¾² °½·x¼ÇZ‹S?ª…IY”÷æòM¦küÝ® ×ÛŠP{†6øÿ-k¥ï‡yv¨¼‚±]±³ç{¦Fß‚B%8¥ÕY›2noCÿybØ \aQÎGS·P»æF¼S˜)jOú6Xy;@vm„„$WïrüªžšÒÔ¾Çw³9_5⊖‘‰ú¡¬-Lh?A³çCôhH ¡Sù{ËÁÝo”•Ø·­fm½~äŽøÇE’€#¯ˆÙ?D|‰¯Õ½5•êK|gÿ>ÿ. ŽuàÇa•±¥Ö?¤ÖÀÁæ]Å«Pqð‡Ó^pËX—éà•–‰Aˢͻ iÀ)¾–ÔœL´]ëwMº™dƒ°oÓŒßâùyHÇ–Àï±ôÈjÛBãÓ©‡ps#-º3*0ûc"õác$‹–¯ê!kž’Ë/5B~-9Ú#ë‚D4G•g])ˆQþ:è’’†-óbU"žƒÅ¹GÀú¥¡uä˳¼<=O¡‰^B·L:+·zw4^Xì­“ßñÚ“*î^U½ò¿&‚s<¥ a„£òžFµQÀN`d½<Õ“³UÚNUc`á W¼®qïËäƒ$T܉ç6Á›@ÌÚá–ò2.j‹ia÷÷U=>—?hG=žo:¥Ñ`}2]ƶ ×ûÔÓB¬œ7JCy[æ+»àHŸôÞ>C âI"b®úIŒ…©²@>"ÿ6͉öÉ2¥3Õ!eç#ÎdC1Ëuwâl|)ÞŒy¥t V­DgN}ç*…SC ¤ÛÄ@ðúòà!sðÓ‹±AFnKW•La)ÅÅØ°«·{ …ŸFÓ˲3À+ˆ¹òË¡îQò'ÏY%Út¾i ýƒš¼à`R愹¿k ŠæÓÛwnÑðæÏÛ­ù±ý~2¾KÉÍÐc ‹¹5EÇ=¬3¿¿B÷ aü)&FŽßLàv²~²<ôœâBÃò4î“O­ 1c€” 5[_©ùP ›\RNÔüÉß8÷¿*q#6ß¾C€kðÄ 6ASËu$鳟ôx;- b]; !>pÙRJ[úñ–èºÌþÍ‘Råêýó8¯ZæçœH lQôAS߆Ó0_qB÷‚”…Kâô·B9" G «éÙÚüpwž÷^¥!×½: ÿ®nû[›úÂüã’ä¸Ü„¤qÒR‘Âä(&Q™ñ6Õm_kT÷ãʯ@Õh€œ~³Íf„²šååõhË×|;˜™+èg\«Ê€Æz|“c£IàoAŸÙ’€7‹DÄ)êJì3­uþ¡|V­Q³ZG:FëI/%ì¡pØx—DºYð<⎔^7þ#¶ d¼ÀsÉF—f‰òùön!A0ú\=FÔ¸’±€S›Å»Š7ÆànSi]²uC­Ô]3ËQÍ‚¼Ì,¬)xLc8ÞTC»á"ý=->¤lGÌ<9›;Ü$³‹i`ÓÉçyêB"ÔMo\°Äe¦}×Ë.k,³«Fg·5ÒsùO„jDlŽüàm>ü5·ÿû)HÁ0p \µï¿BÁEWûËz¾ŠVUÍZìµÙ<¥õŸj¯O¹–¸@fý‚Ï3’%¸wɇêä/uP@Ž4â"Ÿp[þÐ(q?䥟C•v)pÖÊô›jqЉÀ•ü`#TÜÿ)™–çm=ˆcÚNF¿!kJuއxÖ:ì¥0u.+Êãvi'S™¢åÞ8žø>ãÃÂÉÑ£wË«#p Y9Ìdf–§.}Ænz.VNª°&që……Ì¡ñ•¼w‹GÖGŸ;x"ùé)’fyP ‚ñ;} ª[¹@ôJ‰~úÞ7ü ёꤘwžÃ&‡†ÂGHµ//z¦ß+QS NGZ'LÞî=mfæëR{0©„,i}Þ—¤KdÌ.°à€ª$À,'õ´‹ª÷•cð/$b5Š™?þ§7ŠœIÕøße¢W%‡M!Š¥±y00 ׯ vɸ¢“›ßsÏóë…†‰QçAUg€wY’+è"å~F^w6$½î­ãa)åqе?EóbÁC´þµPÝ@T3~ųP÷~a\pÛk¯ëœ@çzÿr 妵K塱&KJ¾a–P:8<«‹“ñùÄȵpo=—¡ƒ´Ý·ÀæÏa)W{ ¶lH˜2=ñÍ: õ‡ Pß§³&ù\¬ôÑûÊXâæÏΚÿÂq-í~g£Ü•:%!2ŸÄ‡Ì>bßÓ{ @\e3À^Oµì w4Ž’ «‡ÌŠZðëÜüTÂNù&sõwB‚ vxŒJav$¢õ‘b,æad+:òhŸKq[q;o†­@òé[z(ÙŸ á[pl 5º<”Õ€*±áYåÀóPi"lµƒðƒ¬£eùB £è3”šp7—ƒ‘*‘Ìž"j967/9)1´>`®X¸xBÆê;ÁDaN¶!^ò"µ‘æÜéTÊj•Ú!ª}4í²$Ú(Ф<6»´3?ˆ3; vø‘ÂÒÈÏÏÔzu]Äg?Û!ÊÚýÐ Eð»LùT”éìÛŒ;}÷rèššYXŽŸ)ø_‰ ö\’¨äß©ŸgÆbB\‚‡ ÿ$~QÓãpN¨ñÿLªÒa‹Ü´5„ yAìÏŸÇ=§í4[šùæ6I.j€c¬Ò†m“0Ûë™è8ɦ^içSµ°m7¤b|i‡èáÙÐÂ2~+Ê«0gálÚWÕgJPeCéøÃTgÃOš²ßš HWÍåÀÕi2ÉÖ§Þi†Œœ?™äÖ»`:^7a±Ä°ñ€ÔܱMtÌ]ó˜ÚysEá.[³ýòIó!ÊgÕ"u.¤­ÚÊØ;ï4ÆeÌ/0„b*iŸ$öªòÞ’gÖËŒ1¦c>Œê쩃‘W‚Qæþü¾ É0ü n‰‚F—¢ÿVíÖP}…ÓÔØZ¯o*’S;7‹Vo›Vw­‰Y|ƒÎ–|¢äÀÁbv>OÜ?TïH¸½)¼ àä#V?îè™æ•bd'Pe<8e› f‹æØ¼(—¶ µÛüb I5ÜiÆ´¹“þwl?ôüwH+ßùÔ:ç(ŠPm¼8q~«XÀ0õ8ÏÚQtñÙ|º™xH»7çPŽnÇ®óElQ9›œŒS:öXÁ¢1 #ìj€Ú[üòÌÚÒzsQ9xg™ÖgíKH¥"+ÕÀÚ˜S÷&—ß0°@ýOqK'ç…¿öª ¦€ÃíºåLF–ÊH Ê!¡û/M×èëbêÈœ*õÎüöÒy$_Ô÷²o‹·*? o]vE¨ßÓC€MÉ¥Yþ…2¢}¿î£îäsÓߪ;©´ò󮣿¤ë«&dåXK®„ÍKüñ¤‘t³³.“«?f©&5w ×øî iWÇ­BJûÚÙW•W².‚à;’`³?Ù|¾9c…›÷ž¸2$ˆ[zϼÉêã&“ùÌQrÀHËúm£©'uØ`ÄkÂÚq>å/94ÓRñRpyÕaUÊö’ah®4¨µ~ja‘åñYî蚊aO5Ò$;2õƒ4b–÷ɯú­2‘Îdz‡%hâvôJ¾ö`)) 9\Ô‰I½£‹­ì¥Î'I´Úâ=ÎÄ¿8BÇJm çÎPUõ~jÂàÊÊ•Z¬í¸ôÜÓ‚Çq{Ú³ïë§b¾ÿs:>ëÇW ÌøºØÇñ³¼&u­L¢Q˜¸èꦕ«(­$rãçœ^þŠHŪ¥) Í£Ûœ’:d·s9*3Èw;qhb¼^¨EbLæJ—ä}eÍ­ Sì;Ý@j¬†Ÿû²ƒsÌ¿{œ?jöÅcœ L…3C]G‡×è”B›áß2ÕC–©jqžk)7” :²æ(’oœò“9'Y©›iZë캾§t¹¤CL JÆOõ=´«*xÙQê€_ìÙÈ‹B}Ô)ß{- a¸§‚ ­«Yè¥ã¹Õ– Lõð9s9Mévî3`uðÿ- 6ÎG[ZçËT_*ºú?«7šKJ)å8ô¢~;JÝAŽ®íwÖdlõ1q @¹¹!Эøàÿ!NÃd§aá zí2$åˆÕV–DÜ‚G lLCŠË|¿ºÝ¤7×<Ê€ÚÓ£›Á[çë ¬uÕ¢WÄae¯Áž'~?®îjá"_”Vô;”aæ¾ô?Óðé%?Nƒäö{_•t…ÍÙëî—ž1;Ù¨Ë>ÑHkcµøë5v€]Òd©?µÏ3L›x± Ïâ¹¢^ýrAó‚ÿÕµ!Ž8šÞ - ,•´íY;'ÐJÿÃÏ }×#$-/¢ó‚íã ¡9™Ú¬¹ïÅ¿MüÉŠˆˆKŸ5Ç:†Çñ®Éž’Â~¨@F¦*ÿÐà3·Aæ[¯¥&¼©&úÙ9' ôUàH’ñ‡Ú/ŒôN%&ÕªÓŽ½§q:-‘±,ß\Pž/kTø¼´’>üš#öâ¼3Èû(€Ñ–Úå"¿ˆ³Ç™â)¿xÔŸ|N€ÆWµA8Z_¢PÕi¢Ä¡É—I&ìl ÷™4`3=<­¨Âë| khõGÔ¸Ï!ÒarDÞsÚŠc,ÌÚ&çH$¾)’›pÉ[A86J)Õ{:ê¯uS —Ú‹Y:½ò‡ÚìM)ZøDã§f°6*—96xŽŽèRŽäíÊlÚ°>” Z:#OdŠÕµ˜€xµÙt¸`¥…GE(6^˜‡½\¨—c:Aê–á/Š˜ßV³€P^~Ù[õ¤$ ÚT•›*ÚοÃw"Ë”<‹jŸ®°¬¤ü]ö$¬$päÅm|`°™ˆ;µ†|>ÖÜ®ÝÞ ‘¤éS+  ×q'9á–†äÔN‘Ä Is¿ŒylUÎÀ¯ÄÀŒÁlmuwQ*Êd®Ö¾K¾veC::~ÚŸxAI”î;å-ñÙn®Yà 1¦¢ÒבHÝ­d™ DJj›‰–œaƒÎFælë?|Æd&úg¼K­ EÓýnŠÄn0àm© ë o†ÏZÎx‘ì“¿â­(F­êê¤XNÿ.¼A³1s†Kü¸°>N%¶¹œú>Oˆ²+ ?ñV VoÈÒ·_*^#ÿÞoåg÷ÀÄÛæ_Ä82$3Ù]gñ©{„Ÿ«¥5ìÍy ^AAYwáª[¼c»Ò–l÷ŠAŠ×G‡Ÿ%yÒ)®=ðœ»ÀBq÷rþéµhiªÍƒ>º95MË1U_ËVÿŽUÃ,¶0 tsH2ÌÍÕXtçu_ªíú‚š,4”3êÕﺈ n¢ûå'éy(½k…xñ’I‚ Ê#WnBCѸÞw”–tÈuéoJ·ÖòlX•gÖ›èWó‚_›Ýß ÿ¹“#ÏFS‹{Ð.f+ÒŽ@àz-·xÌ ^È™ùÄ «a/ª‘]/Jй?Ñüù}oßø‹27vHey~sÙÝOKÀ1Ü ÝNùü/§Z„¾|êYØlzl¶>™¾_{ùR®‡©³ .Ý­¢>0 ‹YZqtl/data/hyper.RData0000644000176200001440000001657014661346505014052 0ustar liggesusersý7zXZi"Þ6!ÏXÌã·%:])TW"änRÊŸ’ÙTªµ&²†‹KQR”èiʵš^Au|´n0 [3€ !42Ýü4ùÉ6RŠÇymÐW‚¬9J*cm¨T´}÷îŒÒ½ 1p=t†»ÀŽódÎ3Wšë‰?—. X¿-ŸáÚÛ•Éç¬Úã" èÇ#Ûœ¤VTv]¸Ú¸uчÓLÓ—2,¨šY‡`°†klüË D¤öÛe94ÆmAý/º¿±îú“GëÅó  ¼1nø2Ö<â.YØ ƒ!ˆúß~'¥÷%t.T÷~ÂsÆñ•G3øðÆŒ÷£3“wøl §Í§ü£\® °S5ÎuíFÇHæMv‰Y?€5T‹M_Õ9ëFÚ|žCQÑJÄ–æŒÌˆéyí¹ øczp¸Ú7°î{,À˜8Ý·‘;ªç‘UÉ)k‡9BñWùÛàÞ) À(篰0Ôµv¼zŸtxcº.™Ü,Pþ#ñ1¡ø^ýöнë\{4«òo\K|ÖäáéÁq$hwšPPÍJ6wÁ%׬4¼Ä¢ÍË\HƒÈtÍý Æñäp¹MVjùvæ0yJ×°âq FtÞÅ “YMÅsZI*¾0À­þ¹¯d€^ì=\q#Ãl­"X‡›©FÓR s ?ÿ©»éí]žn)^œ gIPÔµ”æÀB–òi•¡„W6Ÿ2 ]ùrŽyŸw<vðÝúœtVYWkÌÀ<69?4¥¿ãÖ{£„• Ï0£Êà.åzŠ9cÒ²Ú̺­4ko u™lÝ ¶‚""Ö0ѯoа¤¢„·’ïø;è‰B|Ž™ F€ÅÑ;¶`Æ­µ©Pnñ!cŸÓ²¾Â¯Ñ^.4€éãU¢²ëžr†&™Iylv” t}_öv !"‰èa#A;z_¥¾BáÖ…Œ°Û2ã$Ã/ë¡ÑÁ±CŽÖõ“OóIãëÍDÉ;ƒ‚ Ùœ³ÀÈç ÒÁžÆøœ (çÆèBÙµY¢Áºqá‰.LìГiIP5Ð×}fŠYÐÑ´ˆÔA}êÄ.ÃïlcÀWfÞÆ/ËÏLÎÌå„£V!û¦7ØÉë_vøeŒ4œžI/ Ù}½õ 9éמ`F–¶K=³oãïÁ’Såk$tS,_sœêuú’Êk/ç<«-ükÉï­J)Ïôä,ÖOÍ÷Ø>;×ߣØåª4]±&å–ÙõϲÔ#Q²|çÖfwúo ?oš¹ûE°imc3¿è‹üô÷~#¥ÿU-ê“Tš °eSì/ìÓ;§Îq-UÀ+,GÓ7/xm˳ø%+/ ¹XòËzÖ–wýá¶bý_ðjúG†dh«„aÞnA×È=‰s^@–y^"=–J‡á<Ñ^°¥K$<µ,1ãæd’ ñãórÃÓùZ¶Hä™rGhçM‰òóïîÒJˆ^¡¨ é¢^Äüò©å)ã“æ™õ «Ö·ëcû›nÐe¥l&+öÌ ‘õcÒj¸éœH™ùsiލM‡`-Vö %2zfËÑ«m ))}¿› ˜]nâºâoL¾=ÏÝ‚„3Q@Œâ–NèU$®bÁ9Ô™³ûv¾xæ_¦— Ò8ÀY…Â7FJ]îÌ[ö„q0£ŽíwÏ^%Ñ*û·­í&HŸBWØ–æC[Q‹-Ãi[7|„Xž h_üÄ¢Œãú²>“ºÜÝöøë›@²ÍœpŒùßd*²œ‘"Ç-Š '»-¡týß´ÿ”X£î!ð™·cYA÷±(rŽ8Žšf¸Úƒ>õñCeË, qË%žJ ÿâè\NC¶g³SaŽ&+ Ã¥Í1:¤e-“–Ùå_'£Ñ3?‡?6O¶|øñ×¼èγj7tÒG"p->—ªÿÈ[–4%˜ƒ$ôÓüD<àû¤æw‹ø£¬åû¨«Pd[Zìe“kc)4ô½ÃbÆm( ckQdbë@Ùð™b‚ |öqüLþhBÞœR¥V\z»¹õ„"1ùMô-pª"O#Ê,Û†pþ¬/>m|ÎÆ3> ħ*<)ÃìyÍîT°Æ ÙöÝuh§ÊÑpEãF!úÏ÷+íJeÄ¥»¸B}¸?nð§š[~\oRY—6…6kv±Þ½C§ t bˆCåªYp¬DØç}¤Ž*C81ë,‹PÌ´R‹|šyG7^»€'G8ò\Î}Q&€×û‰(Z ^‹šþ¶n$JHò9ž–š- %0Ã|yr•£V‘‹&CÊ’ù¨+W’ã‚ùÔ?0/n„*·ë•¦@ûÓ¾®åG±5Uƒg_Rçâ7qéu‘½­^ìcåèîùýB®zü™—{éŸ9p<âÂßá¿ÿ/Û¨d‘FñöS©ÙBÿý.[×¹Á€»p%`¨y«»†°ï/LWy!w=X»ã b}ñÑ“a8~âÈù q3MU4'¸6ø~‰ò½›'íIè8‹¶ÿÀ-ôP!‡•%8áÎ\wÖµ”¶ñæÝðÌK69J¦nü€ ‹œìµ 4ÙlœÌKGé1B~c²hÁ oª÷&]Hs~Œ•ý¥#‘Ž­´ÊãÕó/°’)åm¿`¼¨펃ßgX”]Y§áýÅ;/táϰ†zû;ùšø4a+0m¼ô(•LƒUòÅ–š|xÑ­ý4;\H´ú¶(Ž»LÀŽÝ¨<¹…Lô¹vÔvý¾:±›$c:I>µ…!Ü„A(iˆx ‡y#@”ÑG-?™¯¾ßÝe®‰É ßÞÍiÿlJ- ج<"æ f2Úã –éÓÇÙã@B¢·ç/òü÷޳ƒe⪷ÈG^oõ^¬ )n—>¾8ÛŒÌz¾#£/Ñ|„¥ÝõÙ0*~…ûµ,W±F®ôð5Rkš×WGz€Ž"›µ(îÙ¾ý×õlç3YK £¶œÉ’¹uCüÕ-,†(‰ËÅ«`]7êÊîeÀo@ÈÆª!oKEœ×úQÉ'.;Yú´éäŒ}b„QâmF©ûÑçšÃ°}ŸµHW÷_`üØì#uüg+¼ÀÓ zfŒ¢Í)“p—_B \Ù˜uü>jd1£¥oµÀùˆÌà`RZ\°ÉrñÍ(Œ[/ÔBÕã™ðÎä/i,–¿º¨/>ºÙK׌?32 ÓÐCXTVxÄüóÆU ŠC0”µ–߯ –œrÓ1¡@6ë8ë=%X˜o§—íö`—!±{¬n‘Í3ÿH™©¥‹YãsÀDFrj+>”õ‰œ‚ªŸî¡YyÙn|=Jà\D †k︪Œ˜tj‡ç`áË89ò†£4ÙD8õxzÔŸ# H²þVæ®Ç6Ì8ʃ·-™oG…I;I—hµ\YM$ ³Ú¸a(e[Ï$ׯ'øûOø€v$„€;xNžÂ:…‹;Œ×+MÎ*=íù¯†*[y,ÿÍÆu⣶/zùWNï‰Òò)ÐGj—XÅó×6øˆgÍø>Pú©ÝC×ô8ø8ö?°ãê sr•ÁŸôÀØé:U‰/¤à^½÷g½ä¦—¯cURÃf‡-à9èÂܶڡVv§'¥²R3‘ºŸnr¦¥ý4Mé+ÿX‹¹ñø! yQ‚ïâ5¨÷£Ê­m7>U'µëOyW¡ô䨕Ñ}–òõ&f@åê°:C$Õ­–‘ßVBdîS=¼_LMÓný¤©2ÈÞZÞ‡µÆ{   X}"‚¤QÄj{<ÏÊá¸Ç}Cf¤ee[TÑ] üÍ%3¤AÒ1«ª¸@Ob“ÁšsVV î`ö´-(Ïv;±ÎJ+ÅÿV$G=bÊËdwšçéý»ÊIûƒ¨-´Êô@[tÚÚj ÚoÏ3êíÅyß–Ã÷†¿ïëqq§Íòf ìqÛFÝÄ`Ôå‹ö¼±óå¡\‰dhÞ¨áuÄ÷~o.L½šñ€½$ ßP4ÉY@ÚxáB|§_ÈäíÉÛø^—~‰·Îò‰Àø/(/sæJ‹rÈ…äoñ» TÿŸ{ß­ªÐšºså>ôÆ,5j”-~9>éçgÔÈdLc÷ÚziùºÚ,ŧéP”+é&‡ö»»áväØÀ¨Úô€ºÚÃÖbT&È¿LnñYØ.’¡2 DáÖ®Ïàn`V<¬JÜ ðÀB)\¢B‡Ó)+…~îÏøÚÊFÖPlÄ!ç5?Aë.ÅŠ\œÊTwë‘þ:í|ì–qKE'YQuá9CÿÇîP”f*Éåî׿<;pæºNé«AIX;Åeô&ðRTMäÀg¤àŸÁ´ààýÁQ2"GjS,$±u ™É°B¤†Üå7ƹÍ&ë\¢ZØóOUtý6†U¦u. ]|BE¶”óy {MÅ“vq¢?”£[ÌN_d´¡^<"Û¡•ñ}:ëg@ÔòŠÝî—EÇ?XHO3ÔG{$ÔPÝ#·è»VF‹¹®uØ(–:l¦³4+>¹oÒ“}^ó¯s s va§Âúùð2H±Û9Ò ØæÃ?b….Õ'å …ù› Ȩf åJ¯uêÔ‘þaiX}ÝßJü2Ž+"Iey¹VÅ#p…rZg‘˜Ý¸R£KRˆJŸûš@¦•qÊŠgxúÜnǪ¾$%‚ÚõíÑHq‚Ê áfÔ:x'ŽJI¾¤yÖ‡çæuá:¤üà‘}‚Š‚óúlíÚbXÄA†Ñ Ȥ ·öðȨÖç|•Hq³¢>ÊHÑ%L£»Ñ¸ÈF*)uˆ›G²¦ð9j©±½—»ŽÆ²=“8‡‡{ÆQ·'ÊT2"óé’Ê4ab Ö.]òMÃsÆÄ¥îLK~'¯ôjxìݱǂ…EÃgcŽÄµÒ¿oà¥òc\è¨wÚf,MÞ½;™ÔSî™;úŸð5Ÿ‚´nñâ-†º>”ë3ÛA³箳‚Ÿž}1x¨‘% ¦×Âzu[`SírËñg×ËC'.¬ò*ÈBN\™êI·®­‡ËÛð„H&Šã,~¿uÍ÷ð=î *Hàn¬ø»¦Hè¿üxœŽî` -"rÈÓô4K†€Ì7¡»; a¹Bššm‰ã×”]Ó«TŠ4n ò»_u¼8¼ P‘4¼ ÝðRLÚW§”6<Âö{ÂŽ¨§øóq8|{+ZÙ‡ð癳ýƒdB{íE»ÉÝ/º̧ô[㽇dž ŒkÏb¬lŠ‹´³îãü1BýHJ=ÖmÒ¯¥Öc“5/¸›òZ-…»I&fº¶ÛÑYR)kºVŽC“{ÑÔéô¶Óã÷²ssÓ,ÎZåfs‡dÝãR"Y¢r3•#Æn™¾ÑWÏôÀѰá¯C¤¸Q˜ƒ -߯Hnzȉpè|MC0Š—$Îa|êI) DqïˆÁ7üѺæ9yûº€`ÕröL-^ÛSÜŸ‹‡‡ÍîëjL:Hƒ%J‰§éçI7ØoûÚÑ>Í, ÀM>MaÔÑÔÖ¡a„åäø_B )ÑB±¯‰˜ hÉ€w±á(Šw#{ÜÚH=IÿÌVP 1Ê ûÙVY–K5W=ŽÆö¶d†lX8Ág>êX~7hÈ¿ß,1Äf{:žºÐLRBtÑC8œéüÖI‹G[ý±šK!†ÑŠÑî~“ À¤m1H–€Ô}Ä4ZN„9"Ü‚vHU¬´`¹÷–jâŽÀ–QÕíà³™dÂ;’k”¢¨®“žBO‹iŽƒ+Û`;~L„¡y5 mZhþ3n®µŸ¯X_¤0CÀ;€´Ÿã3‹± ~&”»úëQˆ* P¦|ÊI˜1 b¸7|Õ O¼q÷ä±ÄÍ‹3w±ò ©°ÍÙläôÚ6Ýg¶¾±‹ðï0òYpÕ/üyÑ=­^³™÷HÛ|ø Dj@_¸ŽD ñ½â\2qß»ßh}¯M“¸ƒ)ɤƒÑëF¢ZÚ[8v9š[äûE$Y‹sÌ´Uù™Wé«¡ IÁð’l+4|†î ÕQ­|¦½ÙÂ\çh2ä· &å àësRÐj7Bå&à„dSrÓ­WïÊóhä§÷ÁEƒ$êwáÛ.«ÁPd† €Û“Øãž b Ÿ¾Uôþ€§±…IiÆC=«¡uGÓÌõŠS{¬dê~!EÇÈrá%D„å½dÔiz¬BåÚºb´÷Æ6VŸÆ:kӯג(‹ñ˜] åÿißçÞºÀø[/s#~U ?!›ô§Ukÿ Ø´MÉW÷1šróØûE¼Õ£YÃ=:h ¡ 0­èQ| ŽÅɲv:Ö ÷ê>9X{ú›–eôÍ.€4Æß<D;øÞSc®jÈ|iF¹¼2?e.MòÀÚúË7,J, AÖŠw­)ç"O”5™F¿8ÐëÌÑÏôâ´L“D¼äbÁ]Ð ¬ð2ɱN\t_XɸïÙ®±a´bö‹É–ìMKz„;9GÆSÊ>µAŒuŸÈ®A‚/Nš³crßÕL>¥5„©{ÂÓ(9"»2ÔÓ;RztE)>Ïr*êE7¬Ã<ÔXçä?êC U,.t;’.úý¡B§à¥Ùh”g¡c ¨1™á‰S‡ÕÍ…l=–cܽšÎ1çz÷U-ê œnų4Jí£ÅcBsŒkueOÙˆ-ŸuÒO„Kàê5ô)ŽÇWn¹ øŒŸçÐ áа´™Õ$Û³!1$8b2GïF. £}êc* þ—“ÏX70êÎýòzy`&—Þ'3çÕõ69Ç¡1ø§] z)(‘Ò­R¶³RmÂ)O'˜{„L‘í•òˆ²Ø>ž«f ¨ÕÈͤÈ6}£¤&&_P¯}R›©¸+E˜HÜð¾Ãô?J»ýÄê>lH÷ºµÿdx޳&ƒwß(벦E:iSÐÜyøïìÕ$<ç«è¶©'Ëþ4õ¹Ûrs»N°g=Žm2çåÎŒ°2ýhäÉ;Å®þ=vç»É©N1¶S?ðþ—DÑÁ<óE«šÇ×÷½Kc'´¸Ü¨;îòº—Ì«9å?pè’ÐÔ¦»×­Ê%aÓ*H8؉ïñLæ–ØN¦¾Ê˜ŠbŒRÁ…Ü:ùôåFUÌn§må¿s8g¨êý‹d'nÇ£k±w¥·t Â',¼‚&Úª£°íÆó›EÀ><ÓC.%ÐøË¥ýÈ`Nuø¹bתI ^–UêÛ+¦4-\Ê ÔÙåv3 ÿ‹ùåäŒeI‚ùÞY xK2BÄê‘þ.’ëÑç= 3€s‚¿°pV+„=¢:u}p–‚Ú:Vpù÷6©Œq¦R¢ÈœžI.¨Wx?°)ù=üÓ}xIDnuÓø(J´ovÝcå& ø«²¬;XÌ›bg€³€õhƒÁ('îF¿ß·„ëé=Ñ"Y %dwÝuúéÕMcË{ƪ&S$‰’)OqQ~ïT)¥ëm‹¿Ã÷B*i˜f¸yþ3IUlãmˆ¢%;6,¦°ÐÂXt%°Ö!iûÙFzZ“à!#Ó:ø{ˆù_ZEo)=7E×B; D'ð†ÿlo«­JPÊ"@œ„…–`«^4¶ÒÈåàRÇJ¡ëÛqlBú4:|/¸DºBŹ0eqgïéyáR=ß›GÌØ$\Y¡g™¿5ƒŽ)Qü&›dÆÏ÷l”‚ô.¬²4’_¶Â{lnrÉZ¸20ÃÍSY¢Rw€u”ª*.’Jº«ð£×ƒ2ʸ6Ö[ú'[]¦ËW 1 a€{*eA3®Q®K㔿vNâÙTÊ©Ç:ßÒaFvDŒ òÓëƒqÎ%#_'Nîÿ`Ms¨É…—Î9¼¦öïÀƒ4)Ï/vœÊé ü÷]¶P[ôòÐ,®ø¥êô/b}Ò\„W*rÔ¯@’4qsÒ› ¤n ږ؇Yÿ¾Ò& ‰¸TÏÁbÐÙ•D›M’sÕäí'öaŒ°ºé“س¾d°È³WìLa¥viÒŒ¢Ä÷7ÒUpŽIÂ×;!`÷q`°Šfv@•šŠH*QçœÑbÀb%TþPq–ü“qiÖn~FN7ÄÙlÈIb#9r%,5xŸÏ‰æçH7Ãp*ghQ*W$óŽôÈ®ã€N~Ž“OΈÑ?›KqÞkt8¦NX d*o?œczZ%ÅéÀcaÉÊCý'Q!ï”»‡©–ŸËõök=Ö"Õ9N›X Û,ðKvéïê]ŸŸüËÜËÓ,ù©¾Ý^ÕlËîP†ewÜÆŠÒÚÂÀ@¶Wy‰¾y ;åWÈÏÊsÕ¨«]'$ ñ¢6ego”'öÞÒORtA©îöbÉý,>« nÅ„`GÄóùàA•\çŸøma¢gñÑ4¨•aäØ<;³a‚§ç#qÓÐO”ê–vë—?DžTuXLì[Ÿ…ë ñS ‘„+y7éÔþrN¬.\à§çä»5>'™ÖxÍu”–lÿ0P@—䣟.WZ]~‹Ü¬05€&¯Þ{›hK€¯‹0 ‹YZqtl/data/badorder.RData0000644000176200001440000001235514661346505014502 0ustar liggesusersBZh91AY&SYG»f€=àÌðú÷ ®zzàêT u©èLš$ôše64hÐ4™Mé2i“b<‰©éšŒš2d2˜44ÔðM &Ñ$Ø4Èa™ "z›M L'êh0š4ô§‰=4Óè¢ SÉ@ÿÕ$0Sj QêÑ €4I”ªª4Á@&LÀ4À ¦ =UR¦Ô&Ðba=Lš`LÀL0L˜˜0É€LŒ&hô£i¦“FĘŒ›SÔÑé?Rdhm2OÔL@ÓM=Fšzi ”z&˜ž¦ji€hƒÈz†ž¦šzš2dÑ‘ 3Q¦™ ™¢<‘êd=PyM4ÉíDÆ¡êx‚HIÉ¡©ê4Ú›Sõ@Ê4dm@h¨ÔhÔÉ €Ó F€44A¦€ÚM> #á|„ñð,ÂHÔT+K+±1i„v™Ô‹j[ ‘DF¬A6GJE•I $Ê! "éÓ9%J†&jR‰MHQa¢ i(iR™d´ÙÙEÓ %iE´Û*ô’J9aE¥†Ud²eÔT•’*IL.TFHdš&!b$¦³Y&ju‰l”J9ri*¤Ð̪ÔIF›D¨Ä)S0%ªÒ$9¨r쎆–REaD‰],S©p´5i©…*ÂÚ¤”˜QM °¤Ó•…E™Ã¡-"ÒÐåÐÖe&T©b,­ EI—,åUDGÅü0ð~%ŒxÃÀ’Uì£D“–jUYUй«¨]–r2L²•%!3 ¨ifHH+$Õ35P"äm*ˆ"‹––QB"U¦h¦µEiÒ(BHÂétè˜Ir#–AËŠ)R!eÌÕ‘V%FW0HÑbiP¢Ím*’U -‘ÔZ´B¤(² Y°ÔáE¨‰‘RBM Ya̪P¤2•UjI[J­¬Š5I$ 2– ÈL¨¹**T%KTR""¢)˜ˆ‰‰¡V´i]PÑIH,ŠˆHªÐº%e©¥œ¸¦$Ë9rÎ*F©œ¹XZEÄ"CTH«¤²*Úš\Ú²RS™eDZÑ”!¦&Šbu9Ä6³PÚdF‚ M"2K$*º„UÍeiŠ”‡J…[,ÑTC©µ:„ZsZt´9™hJÖJ!fA†!%•„•Z *%-*¨ÃWMR…J„µ Ф!ZIÒéË:‰"ÔŒµ¥WH•¥tR®\EiY!!D¬ŒR Lå¨Ò0³UavŠ)"¦*¥”––T¡H¢JΙ«+5ª,Œ®'5A,ˆÌæs…6’UdlÉ%#,‘MZU¬C©ª…&&f‘mØj‹è.Ò%b¨&)…–hO¯»r"äVFF2…$2Ìã3µè'A8ªÐ’I (HHžš'f†a虡h‚Ef'-’#"QUDË%Q9E=’Œœ¹eR±Q¢X¢ªs È0ä–eÏç¡Ç.ªSKB ‚,5C¡*hÅ™œŠQTœÌ窬±T¤¬U:gf‘Ã’—*+"™‡M(ŠÖXBtEBF¤•ŠpŽU¦Š’d%T’ZVÒ %16•’…‰FXR¦#*£‘™˜Eš!´Šz7\âg)&]D•:YdtÊ‹Yd«Uг’WELÃ(ÌTëE3¤&¤fW)2fRŒÖ¡©a¤˜"%’*a*)#J¬‹¡Ê#Hªdqi±M”X…§V‘–”'PÙ’Q’…­ ©ªÓ(“¨IIÕ#i‰M*"¡C4¥˜H…²Rd’–ɦf•er0šGRŒ‘0©R¬VŠ-2 ¢«%9u$"ê©’¡Fq(‡€1AÌË-©•Ddj¦‘’T‰ʤꪩ$œÍ©„EŠv\Nšf‚eW)2 ªTGƒð}àƒÀ`ñÈðó€ÁÝÇt…aê:…™™šätÖI$ ® t8l–¶¶Óìó`iMxO)MÅL^Є  8Q^¢I$€2”‚ÿs€D“ ªÌV­i¶†r¼_'g¸a16jâ8í·4®Z‹µ[UÊ›d¤_‹$”ŠI^Løi²$ÙÃÓtì“O´–%1ŒcÆ Æ1ŒcÆ K¹¥vDñj¥BŠÕt‘hH ¤9x r¼‚üA"™y†,Êd‰Ê£ŽU4‚‚ò‹%zd!+€ûÙ 1þ™Á¶Ö®iû{Ïìèü+y5[‡$Q¢Š‹Œk!¨Ðb£6MŠ‚ ˆ¶„£%FƒDTb±´Z‹I‹%°Y ´š‹%™I±dÅ)ˆÑPhÔFÑ¢¶-Œ•F $QE¤eŒdA&¶ L-*5‰…C £E²ašÂFÑh‹d1‰"¢"*L˜ÔjƒPFLEcF6„­i‰Œ‰A°†6’64†-P˜Ö"®ªú?«ƒUâ–á6M“hщ5ˆ£RE“AŠYP”R£F"£RQ HƉŒÆÒcIV4zž1õû“ƒÑp¸žY4Z*2ˆ“hÔcI¨Ñ‰6ÄTh¢KRQF™I´2D ¢4hØÆÑ-JE´T™(A4š“Tn-fàj4Q’Æ5ŒkI`±µ)ŒÂÑhÑŠ£c´… Ð`†lmƒ@P‘0Ñ1Tj6I-3I¶ÅƒÁ´EЉ# bÉX e‹d¶$É£D(±FÆ5DT‘¶"ŠML(¦Ec*"°Q¡‘‹F ±¨Ñ²V’(‰ ´Q†Z5Œk(ÛFˆ¢Ø–5¶,ËFKI1…£m)•Dš,•¤FÄTd±X¨ˆ+&bJ£¦llY*ˆ E°š2h“F‚,Qbe*-ŠÖ4XÑlEŒhÑXÚHH¢ˆ¬šÜ³mªÕÅZë-­¯þqIÄÔHÍ‹Hf£E±I`“E‹AjM ÉŠ"ÂFÔkÆÆŠÆ+&£ÒcXرEI£bѱ€4da’+d²Q4hÔQ±·åÜ7ÃZá4b„ѶH´B¨±Xˆ6’#hÒ+IhѨŒ*(Ö  ˆÑ‚Ö61hÅÑ¢ˆÔ‘`(,b65£FÑfV(ŒEŠ’,hŒYš$Ì’4mF¢‹QQ¬bØ4€Ä‘¶“DQŠ2I …±A¶ ¡+ˆ¶($LŒ¢ÆFÔkDh°d&QI¦ŒT¢5ÊÚ· ÷pW #E±(Ñ¢ÀF¤EIÚ5+E£l&,BcEË(Æ $¤bˆ;Êsæd„$Ì+ó V4Ÿ/ä¸IQ /­Ü½‰ÊI­d A•©iåã³ü~g¶§†ÖjÖa{fâ:Í`ƒ{©ÆcO¬{]3,#qÖ7 aZØE=rýeÌXÊñÜÑ¥/ þ¦ê •lØÏàÿ"~¯Í°Œ£#²ÉŽ{·îöCDdÁÉyÜßoÌËÄž€^‡“–“ä³s·'㪕gšnŽI’•EG¯üö,Þdrä%¹ ²Ë ÉdìM`9ñ˜¢ÞŸ,‰wÖ¢Î)ýeþZ|D ÝRÀô¾È3W¶ÃøáZtÓ‚QÚoX¡Jž^»"‰Ë¹ÑRÍ4ô’¿II”ó@ÍyB¾×ÚŒîVÛpBÔt¢ÅÐý “È´£H! ÚŸEôkù°¤[b‡ ª6Ú;~æÑ6 .¢Å¤Ý¿Ÿ üb÷ñ^¦®yвË,²Ë,²È©pW)-¨'KÍbñx˜ž¯çÏHF›ÓÏLôÔYB·ÒuN ºá{c%â*¤2Q!ÝÄ;È!D8 `ˆª@†”œFù§®ðåÅ”é“W]U×=ÖaÅ Ê´µí‡ì¨AšêdìÍîÌÌéÝÕÅAeu¥"ô=ßÉ•ÇÁƒ7æÁ„YY©T¬ÌÌÕ$îÌÍ*Š„..æ²ÿÌ$’Ì%¦K4\¿Eê(šGUÏS½”îÍ*wfff°í§yÒ“Òèç±ri¦šk·ç&Vø:wffffffffÑ»O/ŒÆlT[¢Š(¢ýPHéAZT33A;àNìÌÖ”„;ÛNöU…Ö9š±ý_¼ª–˜SMúh¦ Òtë5‹6w¶ ¡h§y í©T!a;Å;ÁeœµÜÓ¦Û©¹-«Ô^šj) YL®+*Úü)±áŠ‚¢–)b´W„}oÍ<Ûç}gÉ< âÞð¾'᨞Šj$‚Èi‹335IÞU3\PP…¤îÌPñ Ê3p>Dv1¥ØÊ*‘%L£ Îp‚­¡=NÆÝ…á¿ÌëVÚ-¨T” ‹ÞÜf¿vÜi¾øûV´­´z”êsGSs÷*>)-ÓV"ãtŸ!%Îßé,^¦`÷ Þ(K9ôÍC6ÑSP9É?;^º¤íÿ Тó ,?¨Q÷ ì„TC“çR`½#@Ù—K·¨±ÆH^bF&4{–ÿëAa¤OCi!Ÿ°à®uzv¦€&ök¸•³ñ̈mwŒ·Â ÿKx!SlÉSˆÚ¿)þ~NÚ‡‰ÑbÅká²â,´v5áÝût¹f[æË7îv/E¢þº:3 €î¦þrù ó­ê³ÿ•¸lš©m&À49• î’èO6"{‘ó&{í :ªÎNNŸYä}^uWo3=¾>œðz|õM{ólŽƒª€ë²ì'hþÉ6%ãÄG]w`ýcÅóLÆÑU–ä”jJHãs_\Ä 0#g»ßíy$ZíªÐþ•®R•{Lw 1iÛ×^ Š7”Jì' Dø£Òž6ÇO})&¨¤Šv›È­r2¢ÍõYõêxU]öxìü®¯|ÊêÙvÿ0×ÛúôæêÛ+Wf«¹9î߉Lñí]…òyeåŠä=gw§·>&´dâpº^îâ®E‹­M[TñËnŠå®z§¥‘™ £¥êÊvQ{ºê¹J¹²‘@'wnîgQwpUŽÓIÅut Ü÷v^t-Cw\O<ðÌ;˜êy{›¹zî¥îâIsÏ ËÜ/.ë™çº«Ži„UF·:£²êî›AÜtð+Ý/±W=Ì’r‰/òð÷<¯AÝÜuÝÔ]tÜ¥É\÷\½ÝÊœ7W=RÝ'p‚„óqk™í\w9ÌwH§wqÒ )ÏOS5ÜuvxyYUâ.±È“œó<ÖµP/H5®ž®´Ï*¥Äfêàx†ä»"º8ã±w< ª4*Ôœ]ÃwG=¢á㻘š¹ÖîX‘Ê+rqLöyŽ9’RË;˜£ŠyŽÔ)Gu]Tëº+¹z´T\ÅO7]ċܗCÔ#ÝÚurő뒞{'sÝÜ=Ê]×nV¸yžHåè{2r¢ò4¤$‡V`–^&ãµ 7:{¹dî)FœÜÇwvi£„ KH«×sê¤7¹ÚK&Q¿a¯Ê”­ÅÄT8\Õg.ž «¨÷Znë³;o˜”FÔBÓ\г¹í|.ì B"ã9žŠâ¥¯Ñãn¹‡¾³—²™â‰®É&Á¾ -«D™³å£ã /ÀÀ_H©b—¼#ÿî-¤äH¥5ýDÎúW0cétlqy…º"?"Ã+´¹÷!xïLe.“„þ³+qG—Ѧ¿•\ÿÑ&&ªFDÖˆèð°öÄÂåñ®•Sé©<°ÔCr®ÑÕ4κ¸!¿úmTìeÎï\b-¯ª+0–oÆèp€µïÞ˜å40=—‚Vkz@ûÑߌ v¯/SÜÛ¾°—ðlÉÈJKÿw‰Ó¡òÜqÂbË?DHtë{P´5`¾âï#è])CŒÇÒTeÓ¯áŸ+eª:>¡œD÷’Œ¬‰‘‡)QC™Ys@ú »R º›N4ñ‹ï‰÷«˜q‘Û»šš{­§êS]Iš©R ØÔ;;gAìôy£9› ¨ÛB ñˆ€³ȼŸ ˆ¥IšÁÝšÏðÍ‚¬åÔœ,®®âúÓao±¥Éïþ¾ßþ÷V*`A*zð,e™ðI6HÀÄ- ˆËtÎÉA—ìC‰v! ±>_Ͼ¤É¹-Óºkm§¾šmuÇð³Ò^ ²ùYkí›·}šç-a*öØ-ìóèZI\‡ ÜýÆ×E²øÑt2‘:¾\Xì·ø»’)„‚=Û4qtl/data/bristle3.RData0000644000176200001440000000554714661346505014454 0ustar liggesusers‹íY p”Õþ÷ßݼ!†€@™Iv÷ÿÿÝM}Ü»I¯M‚X†1HRpx•Ðj©mqÇql‡é8U©¶Xµ¨­£míñv¬µ”jKí8”a:L§8@BÞ yô¿ÿýÎ݇ÙͦÃKÝIÎ=÷ž{¾sÎιwÿmª]È[“§iš®y<.MwÛCnÿsi-צ9vnnßµ¥ÕÐ4÷TGNÓ§:ëQ~²¦eï–sšž@cÿô˜¿d2‰óÉdÇ’Iµw¼ý‰¶%³+Ñžtö¤Ò3Ñ8¤²çÿ‰C²ç“‰Ã•‹C:{“顋‡tí¿Úã*g’Å)U’ÉŒeK&™8L¤n.JöhÎ糇ñúÕ¥ŒC*}Cª˜fâðÉŠÃX:’éM\»ÚâŽ}éæE&™8dâpyãl_&™8\©8Œ¥ëRÄa¬}™8|úãÌÇtâ0–ocͧ‡Tþ¤‡tü+h҉륌C²\¹âqØ£9ŸORÆòõRçÃxu~1ãN-%«õ±ìIÖ’ý}šâ̆ˇñlH³‰Ä!™\º6Œç{²:K§nÓÙ?žìÕ‡Tyw9â0=Ÿ±8Äý>ìÞ¸y«M&C¤Úþ»>ñ'd[d[ËÖÖv{ŒŸŒµû¯Ð‘•2ž ?âWc³&f\cdB5ft\ÇÈ„cô„—DÇUQ™/flEåÖ’Ï[uþ›Û£Ku :Šn‡ªiœWûËÍØM1øáª¨OUè|•õ£Ê¬ŽŽ­(HU°ÚŠŽë¢ã*µ×ë÷ùj1Œ½âDÜ] ŸŽüðEâÿñ¹±GÒxfËÿÉo>ÕÖ¶i¶É#‚/:É#\ÎGl9מ÷yµ ¿~—׈õÞáµâ™Î{“/tÝoø2{]ì—’~Õ¡n׋|¹ ág%Ýþ4_)Òçàã¼^ÐûxC[[Û½»ÏñÆ»¥¾&WÜÊ›¡·ùÌ‘#ï-ñò;¸Ô§Ðÿj€¯Î]bþÔbþÍÁKÈBï=[ZÚÛ‘v4éŠ$JQ¢f’ó2'§x ÞQD^§µP§ÙÚ²CŠyH,ö1~L‡Z4ý¢÷ˆ QÕÜw°M|xÕà«?bþ¯âÃ}] ´~l¿ýù÷•bxëÆ·äþŠSXï3ôäËùJšoΔú*‰BÞl“ú”½ ¾CrÝy}¼ž øá_ ;±NöW’¿G0Ÿ`ùEþû¥£>ÞOÒ烿¶x¾ûüäÿÄ všX÷§uâË ¸å˜$Ĺvð×w$Þ??h%ñùqχò‚uŸé‡[e}‡í-Úö$ë¹ÿýá®_Õ±~Ì÷þ×™`½žíúí½¬{ùë-öuµodCÃÑó/ ±Áã%ýÏݬÿ©ý»¹ï=Ö÷ÀÙïlÚùS6²ûäÒWŠ¿Æ:·=ñíÛþu;'¤"°ž"g‚õñw±Î;ÖùÜy·ìxžuˆ‰/³óˆWÎ+ÅB;÷ýŸ—ÛK¬SÚÅ]ªo ²ÑGB+ß~¡ƒ I»¸ó}6XhåYôÉçÂw¾IzØ€Ø~î ÷œî6|T(ܪæû¡·×1§˜k Žëô—ÚšFXcÞLÖaK ¿‘uÈø³n²äYŠ#×N?4ûõÆ3\“þ±¾ÂÀ/±ØÛÛ(šXï¾u z~¿]€}gá'Åkäåù«lñé>üãîrÇp6‚çÓ!¢ªgØOöö‰§5çª_P©¼£}AØí§þ JýÅOë°úõ?ƒâKý•ì¡uôuêc*îô|¤~Õ/:žæ'?;pµ³ù‡‡ßd=‚ÚËuÔ3ÕA߃YsOT~NåW—¬{ž+ëk¶›ÂÆ»®gƒ/Òó—¿Á=¨»ó[­ùîƒYlP”QÉߨ0úI§Wĺå÷pH%BRýôØÕh·"6ˆ~Bõ;h1¡‘õÂ?ô#6„þ7꘻BÉQ½n÷/ªÖnX¥ê¾—úœÍ¬[ЈPÏÈ?õªÿÎׯÁzßq±~ù\©opæÉ¯>ô•Ä Ï®îõŽ¡lPX³n!„}諪_,F>ÍE½ÌG>.¤syw#æ#Ïæ¶%œ·¨»Rì[€õ…ÈßÐ_ ~>ê‡pK)ÿÁ/F–—ê«zÕ~P’£st>äÉêWtï ú£}~à–QH°Gç¤~”`ýÈ—=ûãûðØ]ùytƒâ\y²£ ÏgôÌ{-ÞŠ;Qês¤Ÿîiè/£¾…{™ºŸI½ª_ŒÊ:âY²Î¹&NÍÝ'ÙòZÃ9¥#O‡…Øu/síw_™JùÇݨ3ª“.YÇÜ‹ûήá~@çå°¬Sîu@hdÕbð'îAþ_Àù;$ûµ³¼áh'Ï—uÇ=òžÂ=8ûÅòùszPOÜ%¬Ïñ“^îrÜ]ƽèOD[zëiîB½Ò¹<ŒýYð×%å¹qr;aÉQþR¿Ì†tΣoð|qM{à#…? ò.ø;*®§âÙ/yêžú(ù¯Íy˾ѭænÇ­ùܵÒä.ômuO:ú éלFõgvAòª_” ¯¦#NÓosé޼-DžÏ‚\1ä¬cñçܵ rsÀ“ü è½ù=óS霥>PD} y_Œõ™¤üuTŸ8/ggäè{Õ;õ‡"ì£:ÜÅàƒ§þC÷ ªóiÐs ä§@_ì¦ï“1?ò³Aé|§{N)õÐì/ÅúBêÃÔGAé>S9ŠKõCè!½ þà{Ê‹¬3{]/8˳‘—nÜt'=×Ó9¨üÌÇQÃßU¡|ΕõÀ=òœå^Š£Æ¢û ×âï\—÷|îu®ÛÙúS®Ó>ªxpuy>rõ¥Q}¢¿¸ëNˆëâ˜|ûEž-ʨ¹Ÿ{å÷,Õ÷&Ã^Ï ±ñ>î•߯x4“ê’àþC}%÷©Ä#Ÿð€¯9×\·šÇ¹î´µBžƒï;Ô?tyÏâSÐO¯‘÷ uOÓe¿åÌÈþÈ Ñ/§‰vöÔA^Øâ‚çáy ðlÄWGÿÌ‚½Sàßù…ŽOB|²àžsôÞ‰<×@‹©nèü¥þA÷ƒt‚R}QÝÑ=šÎaº¿AC U Ÿ½ ôfÐ[@oe },>¾´ó5àkÁׂ_Z‡ù:ðKÁ/¿ ürð+À¯¿´óõà@Wa~øÛ@oÇüí”æIÚˆõF¬7b½ëMXoÂzÖ›°ÞŒõf¬7c~5øÕ_ù;4|â^~åâåWVsõÖ–-­ôæOr͵ôj¾¹º­5F`ñQ‘¬Hœ†H¢†H‚†ÈÇ4xê7okMxÏš»sû}±ïZ«ém½(t¢ïï0 ›.z±è Ò Dƒ0 ª0Ðý>5ò«Q@ 52ÕÈR£ …Ô(¬F # 0 # 0 # 0 # 0 # 0 ÃP†Â0†¡0 …a( Ca ÃP†Â0†©0L…a* Sa˜ ÃT¦Â0†©0,…a) KaX ÃR–°†¥0,…a)Œ Â*Œ Â*Œ Â*Œ`0É[æ<ñ2º¢m§µZŠWÖ_lݶÞoïØ$˜xu$¨o¸Gý4±s»óÓ„øUlä¯%³(”9qtl/data/bristleX.RData0000644000176200001440000000475314661346505014517 0ustar liggesusersBZh91AY&SY\;ƒÞZÿÿÿÿíÿÿÿ÷ÿÿÿô?çü˜B€0 @X !ÿÿà ¹{À|>YólL_f€x»ÒÐ*JžæiJ~©´Œ&ž¦Ôbi´™ i©²Ÿ’zjI  44hÐЦC@ < 5i½F‰2m%M©ê§µ=H €Ä2 CÔÐ ™j0M C&y*J†Ô &€ 4ˆh2…J%?Rb@Èb 4ÓMi½Q„ÐÄ 2A Ð¡¦†¦¢ ˜š4ÐÓÓ  Æ“5SCÈh ˆb4##!„‚EMªzL¨yOHÉà¡àž¨ÐHö¤ö¦ ÓÔ ƒM¨ÓÅ6ÔõÐ@SÔýSÚÙ’“â†DH‚¹˜‘UQUI&~¾¸‰?´á5¸­_•×ñ3_Èô\Ÿ)ÌtýW=ÐÞßmv÷ó«œÅ½‚æÎšd¥~á9®sa-i&zÐtpñ1G²fØÍHÏÑ'I¶ž¦«wu„è=×|ÿgjèlZ€Ã@0 ’%’(Šb"&‚`d$˜$%‰š˜€&H‚©‚H!&I"` "¢%ŠR‚ Z †` „ dš€–ZT™Hja˜%"ˆh˜Y˜bX†@€†V-ÞÔÀÙÐÛ‚$he&$¢Z&bB&X˜€†(Z‘‚a(™¢& ‰ &%I$ –H`˜b  !¢ ‚{é032ÁHM4°Ë+ ¬L4A0Í$12A‘LŒC0¥2²„D…K%T@ÐŒÙÍ©B¥Ì´´!¤œªmŠ!Ç‚‚lH*ª½n§Ÿ*ðû`nLçÆ˜Å˜"2äuÃõkê@©ƒ€’r™EÞ‡6ª­êP4„̈ !ShÎMWïñïß¿2ÿ&sœç9κÉ$’I$’I$’I$’I$’I$’I$’I$’I$“8ü Fa0ÁhP˜?*ð˜¬1;PDÈ!²8ŒV^x‚ ‘ Ò‚Gà€Á‘SB)U QR.væ$2³K’«Þ1aŒbÁ,VŠ TLA"áR  H‹ E fL”„Ô˜GT$'RH’‘& P˜Hƒ˜…ŒØLƒRPH²fŠqÁ¬V)2DÈP‘†Y0„`B È¢@ÀŒV)2d I¨ ÀØÀLL (†„kaÄ9©`®ŠÃ‘A$ ƒM£)ýâGôUs£ìÜø–„‘ˆc<@`Ñ•Š»$átac’LCP­G¨’QßàPé8ÕGFNõV„)¢ç“»Î6|­­Ú6jÈ£ŸStN0#Â+gBØŽµŸHŽ Ç‡‰ÿ?fŽ Ú)´ ÌhJm  E´˜%¨…»›“íeoÅÑ™à˳¦ŠÐ"hi& .”Æ  —(}ñI¦ 0u gO& 5µkIÌœç9ÎsœË¦Ù´mdbEá¨ÊƆ0€F€Å( RºR”¥)7- ˆˆˆˆ‚”Æ1l"$üÐ6¸Œßì3î¶'v rÅØ¡‡°ë27°låºeÁ{¾µ¯göä9]¥jì%Ò l4v:4hÑ£ ˆˆˆ‰Ü ŒcÆ1Œ„B„‡ %)JR”¥.äH(HF"""$B†˜ñ‚""%–YeÒÚÅ&1–˜‘Ë××xGJè•°”Š[*Pz½Mƶÿ¥Ôg[Ç»w=Ógðù_#¬M5º°‹Æü±³¯"'FÖU6À7$9(õÖÛËMÒuI„œö°Yv]ó¸ÎL‹z3IÌöãu”–1…«¹…×]smròE«^fMxÔôųÂó¦6“rf®®Ì«ƒ3YH±)0ÊáJUuŽp~a\á¶_{1{°¦7´Y\Xg a{š/Fm5;f𹹸|?Ó__{¯¢³ÒÜ{*¶º[ -;©SôµtóÖ™Üõ½É;¤öÆ©jlgž¹-©v=´EÙö+ªq†1É+!Si„]L%f/Âs†Fœ·A÷Þ»!,/ÄàbË`lE*UoºúªµÔ“˜ÖUÙÂë èae²k§­«M]K­ R’Ú[+XE·ËY-²%ãF2· ¶!F ‰c/ è‰BÔ-j’ºi4—Bã@,–ÖÈÆÆYb[ mnV•#l-1Ée®šJèª-…P †%ÊÁˆ ºZer¡œ]‰ :‚Æâ[bŒ´”[ÄB)4”±FfRCd¢šJ)¦žíÎØÖýŽçºÌlMÉŽdÀDÓ$^‘8L‘aIÇ-Œ‘ÈÍI-³Ci½¬wë ŒÔD |À¸ù¼¿˜Ê™ zœóRЖ1e4´Jé[îDno#sJ>Œ¡H©¤6rà®ëÖ¯P–tx~„…Ž ¶j¡s¶ ÞÃ9–lB/H´+i±A@‡pZ²-m1¯ÊŒ’I×iÉiZ§J1]&Jà  "sA‰ÿ#ùÁAr0bÅ8¨±Ì™)W3ŒfÑ2ËY³ ï”øô_ç轨{‚ÈU¦ˆ’çûÑë m|z ÿµÐˆ/œoë¯øÛCùâhDÞA´j –>M°²‚ô: -eƒ­¿+”<Îb"$¼dÄÚªMõgÐ M…lz ˜ª¸æÊñ]4…i%Tý7ô¾þ£])TW"änRÊŸ’ÙTªµ&²†‹KQR”èlaÑÍ£ÀóH쪽½ûr[à5-ók–þo& urûɤÂ~ž7={4¢Žâ› F’(Ø3v¡àþ4«š˜îFeý^d>f …R5wý_ÚñPôñMwW…^ëh} ,ie-fJ<™À|Ôçx# ŠÏ˜€5j4›óqÓÎŽ\ ¢¥d3Iu0b:|øM™óÆscùf‘Fvþ F9U„…`BȇL&æ«"Lö\ü3íÀº¨³‡—ßhuu)V™j´,öNVøöúHÈž¨9$ºyÕ"1ç m-àÖw›¶æ¸öÑ ®p÷:qE (VÔ3Èt!zÂ*týÒ¹§Q4К° hRrÞM¤FÊ\a/Ö›»É¿ ÉPÊ8¯Ç»é~‡±Œˆ›¥¨žèMÕÙ#»£h£êÑhd`:î D9:T¯p7¤7ë¸ÙbúïP.‰ ¾/^‹„ Êqåòéí)áF7>ÿƒ$ýÅ“KïàrŸ#L$V~õÜ `ìë€=žH:3ï”4?Œ,Ù„á­Å½pN±×Ï¥nÛv©"š˜ÑŠ­ÖŸ$•»8z˹.ˆ¶÷È|ƒA…¦LáÇîóò‡ »áNÉɬÄnî÷¸e€Iåˆ`é‰/D¶¤ç‘Æ­zæ çOÒÁŸ³5œ~')‚ìžbôŽÖ¹¹šzpõgõöt.ñ¥]É>¸þ܋Ҝ£›¬½SFë ÚµÌO7Q÷yn8=¤=ü9‡vº‚Ý\bKÖ?‚¹¾¾%/&ºœmÉ Ÿk¾IÁÚ*Ö?¿u³ÉЖµ p¶'–ƒwÌšb•„%—§éd-Kð>@¯Ž?‚$åŠãÔBÓ7$¾Š·!I× –Lg}õs—ÚUÀžÕ¿+ŽF÷N#Á¾¨àTÕÆ1Í*‹û)Ö)+Êy/•ÀžÄ:~˜lr#†Ú÷M¿l0PºT<¯b&íÉItâ©"% À¾9¸„åÎ¥JrH·•—Fq~¼ÛÞ«Ô?ï…$§Âlú†ò¢lƒÅ“Š‚øé$´/É_J"7d²Í›Y+jA?Sè½°5i0Íšsõþ§Ã»+:rB×û;‰¥ðª!{Ý}LÜ]:# ÉÏ÷< ê“ĽØÃ4PÙf{«•9[Í¢#ß³u¿èYB%S1ÔßBšë†Ú5îÑ[ܦæk¹ÒÅó€õeáS†³`IH†úì3—S~1è¾´òSí@+¢ü$Æ_ïÚ+oÔ‹…Ñ¢—¾3Ö„èÆPþÕ‰¤vá6~AÚÒ ^MÜ®í³R š¿<À-"ÓèV¦Ûx0™1Oì£þÖ°’UÕÞàÙ± A·¬I[(|2>5à˜M¾ÄB³j`>V?ÝÍç¾R ÕjGÿ‰[ :ñ׎9D­Æ"™™fóâ陡µs0ãKM%±d¢k¦'z·2•žcÕqâRßñÌNÞ7xÕ’hs† ¤µãýçqœCÛš½UËœj%˜@P,"@Y¦‘ásÆ­:ðáÜ•3G†‡Ï§,Ì“rzå)‚fë¦Pw'õ2Mv&3“¼&BòxÙB <ÆÝ{¸¹ï*·#é#ì×½RlaÏ.Ðijð {»lÊKg@ìØ±Z IY}Û ôéû±J`GnÏd|Œ8Ñ} Ó:x×ãpÎ÷ÄKx¿ùv¿)ç}4…»o»åUµÓâÔ2ÄУ{nwŠ Nùî&•7"aý©›¢YO•Ã9%>³-¡M5£ã|†b-ô‡&¿!˜i>¹Œ‹`Ù¢^í)áj暨q µH!_än~5ÃÈò‡ ¬¢€•1góÖ,EÔÄWc[ð͵> 5c™IO.»ËyrFdöXiS&Vß½»:ðt8¯fpW`Yª,"'ÕV 1ˆâttÙÿÔd%èðGJ£€áMý¦øk÷â,ãݘæÓZ•¯‰ÒÓá_OÁ׃êºÎðÇÎPÐÞ‘xЯi¸’˜!»3W3ðôÚÌ޽ÙCÚ¢ëÓ‰LE5²t~i^,ªþ×mê»%,úå£  dðè6Ë<¥„ÀhJØ©AÄÜ©é˜]ñ™2t•Ñ|pŽþ©3× UãÐ^ĢЧ&S­ö6Å~"=xô\¡ bÎ~Žöé%±j·leÌ3ôP“µq‘GŠ4uB;æ•~"äßÅãl%,ƒ‰Ñ;õ1aGÎ*4fjA+(lHwN¼èø^êú¼ÚV¼óó!8K’0ã;×µA‡å¼ÊQ,Qà8/åS®I·§©—Y5ÔÁ­/t—;98„:ÙO…F1ÕSÁ’ÜÃ/pYZ™"e ÏîžRjÈ*¨Æ'™ÇATÞØ¨v˹ѧ„ýýÚq¿Ñ‡¹¹!a:w² ïêó22 ÏÏÚ*É»‹ûpº:ß–c¸'d§»%€ÏjÁá­¤Z$Èv”ÑY~Iè·®‘ï½MÌÌíÍMìØ¸©Æƒ“‹yôË´~þd;%ªˆ#» Áip6®Ù&‘±2ƒhƒ¡ƒX$Àô~û$ÇíÃû§ÐZ2Û‹HÈ–xçÀ[,q(oë§f3áS°ƒ},Èíæ ÑƒIý¡.ö˜Hr›ó©ˆvÿàQpá›ã…6Qþf0Áh¿*ÈvrÙ@E’ôê¤ï@ïƒ fIˆHý:1`@ùWãI½+( “ëÀºínÿõS4…¿w=2ñôgynW°B@odDaë»Ó`ưúU]—¤U3‘„ ÁœðÂü8+{Ÿ°‘~¸›È—=·°W}2ã ~ÞšO·ŒßäéýxÓƒ°ðK<Á™"ø•DÁ¢±'BÓu,µè‰i±½çÀE…ž{û®)oP¹Ý¥a€`\’ûÿ5Æÿw7݈JŽx r¦8‰ÑO:‚Þ®2±~ €•XˆìYòŽ=Qîw¡Ï´þ¢éÄýß0ÂÔ0óåÒÁ¹@+…D¿Œª«„>ûº-ÑíG²·4Î ùÿ[6b2Œ1vŽÔ~öû;2„r\‚‘æŒð{׃…ám®bƒEÏÜ¢J³ÜŸþq'N#¿Å JV'KÕÀÌ­Ç:pìLLìc™ì‡ž¼Tª8©P ö¥ƒ¢™<®ûXÿ‚Ž•Í²kƒÄ´<@N‹18EÝxrçß0•Á_\«ÔH^(è0±úigq·À„¨pdk&ñ³Ä>joU3•ᜋ†‹ÚåÎ&j$‹›&6èþ×@jãøÝùˆhÌô.Û¦˜¦®Ø% +§ó© ¶NÌØÉ0ÎÊ„¥u<µNHäòˆ8ÞŰfçÞîËXó8r>×X9àºn`Ó?ÁH, غübúô\!š: Ñ|=›Nzu´fÛ—Âa&×-^ñŠ‘á Õz`a› ìµñÏêNø‚¢Û¤¨&Ñþò~º¶míÁï9åmS?ÁâÃd!gÖvwÏ#”¡ô£é› „Èɇ›‚çØ²ÔSYÓÃÑÞõ?U¨ª<¯ZpeKiyÎ]ßËoqwž%ú¢]ö~éË.rìšÜ ¡•‡Øø»¾B @ƒ“D µOÎûQ&2©ÏQ©غí ñ_ ]µCËBêõ™¤ ¹nßk::T‡›–·usµB¯/ÇkÇ’ z"‰s³ÃÝŒ–Y$ÅŽ ö¤Í7E=uîÆ]mˆtIf¦TÆ&LÔÙÍ ˜”åÎr¶ ³P¹@·áh ëã¿Ú„6>,T§Ã{8R¦²¬«p,w;†gÀtKwçFa]±Ÿßøm`~PAì4kkdãúçÿ’iߤÜxˆñ ™€F@Žá³g³)”¬ ¸³eŒ2áÁßàŠ<~lƒ«HÕ_dfËâTð‡í;îŤ4×ýˆ¯ü/\F½qqæ’ÿ¼¯¢Çœ^BÎVbçÊr¡i§5²ˆ­²Ó’Ug¾p®ƒh*ze/¼‚†ÑzÃÆË+Þ¤’ß·Ý;¤aΈéZAP‘¸Ym€ÃM±Ó&›ÅrŽÖ`Þ[!]$Š¦ÐŒ¿Ñ—³ƒb±u©¯*' ¨€Ë.m¶tpo#ü!Õï Ra•ÐxÔÄ~ýÆ”}%I²Ê|‡n}¶@TïxˆÈk{€Üç©£©ÃYk€P Þ;!'ÿúpª£#¦`¦sß½ËÂNÒ\hèÑ÷ú ò@'#³Sç‹MÎ\JC®Z)–96]¸m‰Ž6(Џ•>™-|6ë›­"Ü‘d$Ÿ¿Žý/DB•Žøo>Åìß(;_©@1T7<åø…þ¢V Å|Ÿ±h ‰UˆÏaÈðˆìK÷ àÒû¼uáøP}Ã|Ù<Žä¥\2”£êWº;ò‘忳ŒàMLC_¥ÞeÔ¬­-BFäF£ÓQ#â:ÎgžPó‘Ó‡º´!éÛö¡héew¿NìUOgÓ‡‚$ˆ¶óÃä‚Iyîw&ªó»!ÞÖC{¾Jáuy¹6#hŒ– FH§Qé=1;t¿‹LF4¶#Ì5B ,¹¸åc´spÜÙ^fò˵üSösåe·é(ž*7²å¯z#±ƒçf˜UÁ‰*§˜ºOƒk9pTEÐÉ"ŒðYÒ{½|Æ.ä žîÝ–ÛöàÇ©Ý(¤Y+#œV«¬rñ²Ehiùp„«å4£1Å-f_"œ»þÖ`í4–ÂIÀXG±ðãá7¦AŸ8JOx2+wýòí#ÚAÂc™˜ù¡;¬­ç9¦áåµ¾—,:ÛÛ~!¡Œ¢X¿ræçb´9²û æÈÃ2¥U­¹ÐœÚ‘=­òýW;^ª‚Ø<@ŒÈ“#ï_ÙöÌ—-(œçÆÖpKãO'yàEÁ‘¹ã¸j°NëwZª¬ ¼ž{Q$} mœc1öì¼›u£ÓUŠ>r%¹ ¨?*Œ ÎS˜«½=[½¾°ª=ÃvDŠXÏÏã—%A·Ý,¥‘ÿy¥`‚Å„’î±ZSIøÉh‰ –CòD ãIÖg¬I¬=YóS‡„œß¼ê¾ÙÃ|M‹ä–;\°ñûƒˆu•Jh2ªD®WôlöÌøZœßc-öÆE]ðXþb#…%—1DÎüx\ŒA1¶"HhšÉR,™ÿwùØè“ç¸ÇhÓî&ðDaŒÚ«Ïd‹Ÿ“ZºI]&ô~tå Ò>ï§ûVÄ ‚HÜÙ+T„+Y[RËì*`™@a=’ý÷¯}$õ¨ï2‡Á"„/hvÛNâì~,Iv _îi$3NØL šØ¨ûZ›CR1»WLð‘FN&K!cu²ÍްR‹L`ÿÚß ~úâJÜ€~Gïè㓤†P»°ßê<` î$ñj)–$k¡?è§Ý“'›­[DÝ xÆò̂ȲCâ>Öö%æŒ÷±õ|ÚìΆFý—ñ$¿ãG»J‰üäž‹ˆÃéP Æ¢žÁºJíØ7E†ÇÓϽ Èø1'½’"Y“A>ÓFÊ×ÿÈKÄõQ×%øÄu?øÞ=MnýûsbN~H)¯¾¸W€ f"¼žŸÑÔZxÞÿl}Õ·:E»ÞÆ9È|ŒãeK5•áeQ²`Žžú£B©ŠÕ’Î÷€tmÔ%Ñt1c¸©¿àÂÑ ð/÷™ ô¤½-­C¢Štºzœ•®`Šèww²\ÆÉýÚ ªûÐ[OÌ3x»[Ò<‡~pº?æ‚Ý@ÆÅ\³*ÝnJÚw†?éD8¹ J$©·*PÃñ cÅâå«gj³‚éUXqi ÀÁLv±•Î'Õª9¸ü]=ó©çŒªäÛláä1›ñZ¥‹!v–…_ZWsc¸ OŸCf·qãCF¡ò—ÆEfb`¦j=ŠŠ„ “jã®­Î ç\E'B€%óò~ÅVfC©*´8Á<“D‘N£ú×i€¯§­—§wx¯&`,.Æ„¢D²ß…!Ñ ¼®®Ð¼-PÂÆ'~Uµû!•¨MÃÿåÆƒ¥ý¾ Ÿ [Êkò–<'…r}1„mÂâ°âÑ’íeÐðW£±õÖtU®Ýa³FÅ&eac†Xœ|ÿÒÍ€ßý ]ªlý_ôÍm¨kÙ±ÊEß,±Ó”ˆcE‡,Â(G̨~À*5… œ&hb’ßMV/ÀQÂûÛ¢-wwL´vkÑ,¯ÚÂɸ‚ÌWáå;ª(ìËþÚí®T¾ÔŠ î­¡è¤Ú›+ÚëD½gP|i(õÌ_è;Ö×ö4B÷~MãDž~í‰5–õ†î’´r0A »ùéJ<‚…{bM89*`èõ‰nMåZDºÏáCgˆíÿ“†ºŸõbµ8y¦: g ½ÝYÞø^­R4U_*_ÞF%ßF. k‰.8‡ïèäû¤þ 3'9 `Z üIú4Ÿ÷†sUôî‘,¿zͼfjã6äny狪ꢩå‰=é»Ñ“„àh˳<ÖV3é­ ‘z« Î|üÑlV;JÞ >JÖµÞg×åº{äðééŒëO -¯ü:~ úçJæ¼>t Š×ølëÞ÷è#ò L#ü/dzONíqËEo³O€Y«¢ÃÏj™ l&o’ß'¢D&~¿Õ!ßño“g „Õg]áãÃi't…ºÿCUŸã/ùq"žÝK­çbú~™qVH™ä6Š…æŠlC_‰ |ÒPÁ|‡ZH´P«å‡Bo'‹W`C•*–h;s\4ÌÂtÚ7ã@]x{ûv·3ÓŒySýè³kÙ §¦@rµ(Y½Uòº¯ªž¾Ó‚™–ïöë×v“)½Âø~ìkº Þø§›±f=ü5w³ç•Vò1©¢Ö}ç÷IP¦œ@îØ8¢7©k)0vEl©:a˜üÃåÐʯ³º[·]5Wµ?!oZýA®ŠœŽH=£€ï|,5špžs/,Ú-ZáÕZæ³î†`¤²âü$ëh.–ªù » Ê0C#´è1=Gp`uf¯vTÇGâÙwŽAÑ¿ÁÖd:>Dãñ FŠðJÔþ’óë!B7$¿šcŽEpµ{Æ‘˜3™Ócƒëê*?7 ¿ðIc»á}ͧ‰õÅ.%¶b#;Yp§=B£Bö14'I„(±ÎC|÷4¨?¸IôFÈ}³Âg]²ÕÍŒíh±B¹&¨ò5o¹ÔL,Ítš N༮ô£fï—8£6 iDjé^î wrNC“ÔÙÅs8î, „+; €‹Ú¶2#kýÏ7£<Óv]ë‹”t6x}¶á.¨'/Ò­aº bs¦ƒã»ìúì¯$›•-¤1'añ/…B²¸¶æ¢:º¥0X`5ïÊ~—&•Úê6d€‰hÙ‰ÄXIá<äç¥Dçïo’gpìtýö‡ôy¤­´>ºàqs¸ÿ=ׇæVx$= :ûC¢‡û™ •^zæêÉ$[ëZ÷ ôú+æ=ÜŸKÔïICfÁ¡ªSº[%­Å"˜«úiîÃ!rIï„9p?(DUº6•#¹©$ ‹û£è?w"Çm®f׆i܇]`ŒÄ!`‰Y,¾í©öµÏU){«·Ä >g½›¸0“M¤<© `ÝMÕ=LØz|ÖÖ¶o'O@Ë€6ºãg*Óä„«Pسøl?mþ9º=­N8y+9Žß¥Ö ˜Ûläº6ë· 4 Y”â ±‘ƒŠ£%hCIÂAÉ›¬&t­Î@­&|)·vº Ð1ÄYJ÷킚­ …Ä©–»lç Ç‹sò'`?ˆ÷«Xt2KhÃBk ucÆ>*"x­´ '=Ã+K¹“ÂΉgUj"n‹3dŽí"¢ŽÚÙ&™¿Mx æXíbH~Š¢‘B :U¯FLiãñ±{DÐŒú)gêC{d{Í£DîUÑ”)5ÙŸh݆Ùi[JŒ’jçñ\f©ù—ëç¦ü¢¨t"…þ§Ú¼ÏŽ—¹O#ƒ>}+u¾çâ*>,6§èæŽYOÌõ.‰…Öi7&£º ª¬åæ¬bÚj™^c™!à©çptÓÙtlk KÜq‰ U–"KÉOW1¢åþ-²¤\@• üW ȉNÜp=n¼üSNn(³ž>…øí*ãhŒ/hXãaæ^;@-12q>ôs×d²ËQöHÆÅC„‹äH„Yéž¹ ´3r2ûòGqY?:mqúJ{“^b[û”½ùÍæ¾J€ë‚`@!‹÷RÈ&µ–m&©Z ¡mydI!±¡Ùù7ÊB}å.2¶xœgRíN~N†ê¶´ÐˆÜÚÍ»Gáo6¡óZöìÛÂø Ì’Ým2.¥3äJïcr8«Þº.Pé‘ßèBH5,s+Lñ­i|µ1s”Ÿ—óGV..ÍÓ›äÄñVÍÜsŒdm„_œQ:Ì`¦ýÆùîwè±ÂS é{-‚O¡ Nµ´Žõ¾¿ïHEgOÎ6²ÙœŸ+¹#R N{?4ŽËÀoôDkå@9­ˆ)͆ú„1• qàI< ›€â‰k½ÏQI’%¯Ö¶$CéSjèûÖÖ2±çKRýçQkŸÞ±rÛ¶3pØ|ª^€'ýmä.yýuF}©àá”o^ꈨÜ0“^Ž•"ÅÍùö» Wƒ¸š¨T(üu¼Ù>½¯*‘Ó«NÚ[°Ò‡®À–NIýZxC6ÌúOüÔïTºCå^ÊŒÛòÇZJ;K$ñäásݹ¿ç·ÿŸÕ{%¨ôÿ~¦Ëì:~ÏJûÜ?®ï ³–|ãR·qÊ“l= ÷­ËÏOläÁU/.^ã&¯@t">\9\#-þç–]#í2†›íV`Áí©§AÉ[]z9æì'–"Îk±g)ÈAèQ¿,¹ÁØ%Uôj ª@ÚU–NRÖŠ0’ –hçø€¸,›FiûãMñK|@§¶ìOb¸âñX '·ÞÊ.Q¼$ä!* =Sü'”ÂýCþ®-Í'¶Ã«Ø¶iÓÔØô°ä½'ïoí´ü?8WF]`S¹¹ëcI¼ˆüàÌW–ÒbîŠkjªgG,¬Ïj” ƒ{‰ë4Â/¹Sh_6üC­b¿ü¢öœ$a齿qç9dXrÎ/ëÜs>vz1 *}ƒÑ~ˆ8 ˆÌ¥¹Øúš[¡•Yãä. =WÔø¨î3ᛤWÒçHý#¡çß YÌG1 ¨T?=œª:Å·hZMãPо@LzÙ¬°Ò£:$ï@‰^±Š•j¨é!;ÿ%2ÚŠë»l >Ú<Üó(s9:E6ú—‚BÏ£;Ö‚»ßÁcwÞt­]PVòì¿”©Ý…«ŒéSnÒ™ÓñòH£!ÔQj SÇÀì²:lR ÅãÖ¾­T|¥pH»´wP°æ4V92=[*MÊ„˜Î;_ø2%n©i~F#GññhYs½µÉs†f„ÑyË+E¦G?ÓïÜ«lÉÖ#;”ž¨}í’‚Iª´ .œ–é%*#úc-1ü©ª² Á8(ûÝß•q"Œ áÌ<‰ïØÑ¯‰9‰ \’•¯9“rk. àÉݲÓs+í,lïå4;½}Mx' ?Þ‹ÒVÄPÂb'ä½¾CCµ7/…¡“[É«5ÜYl¡ñ”…˜Ð:”aÇÞ£#hEÞ˜‡éÒ©ÜîÍíJtÁ!Ú.ܦ¾Ê›æ®¢ü±Ó'§¿àœ²j 0"lte,\AÀ±èÞPU&ÀkD&ÃvÞâŠzåp ùàI‰¡:}êS5u;C÷H6çƒÎ¡ãA§›¤3Ù8ó$OA·±‰³éö`› ¾„ê“%žt°¶Ä8YšŠ%©ú\¶á›"[ìyƒ…ßKKŽŸ-:P˜¹•0NdÙúÿ\ÝbŒÁ‘b‰J6쨲#ôõµj•à?ÔoÃK¹Àñ³‚ºÎ[zîž–^:¹!èzþÑ…¯kú“2 ( wZ–öX»s˜Š- P( ÑÓ³Ü*ÕÞº~†|ÜáÃ7‹â’D’ÓNgí”U.ÎøB¼ZDyÐ鮫#V™þ®å,’é丮ÐÑ3[¼%.˜’g:׿€, ´™ÿÑsÁX/\^-Ýéçæ¬ÑCºz¢U„ºi€dqzKîrÔDýݬ¸{“¢šíwK’xB0PŽ5¨_(´r)1˜4·jXÎ"?N¡æO òöK4PD j`<*%wÔa–m#ð­ÜFÇ^a!Ó ùé–±Ù¶ü„¬ŽK¹¡Ï/…èè´ÊÎv"Š•È0ÃŽ>—h°*RÄ<žúÄþÓA›.f™ÈÍ"þ6‚àé÷v1*´Í+ ܸ÷¹+µÙnb ÎCÍ]vé ¯ö"ìdp× \†×Ðsl—è"FV[%оJŸ)€©Ô%™XÔ¦VzÃHûÊ–²ÓДzJyìwº»ÆRhe2§Á' Œ$œé â²îX«Î+Có«ûÐ9TGÊÔ«\›ð<@ ^©9ÉRºi”©}ç„vü~&Š©á¥jkÞLbÛN¹Ã0zÐiÀw´Ûõ|8Ï2ÉCd¡ß”Ù:&cÜdÓ¨ˆÜÕÞîÞ‰ ý@Ël,ªŠµ”NÜ_ÉÄAYR= å–/*HfšüôãzÌyû:Þmã#æúùìq{y Îp·®ÅBËKe'Á9™wŠÒ‹5Þ ºŽF±óuÊöì‰94›ú0ÈžÍhrG” -Ù°öš`],Êãá9ùlf!@Eõ±ýg~®bØ}`>' b2 pR6JA˜ôá;Þ1WxþêÉì,êÚcøºŒÀÊNd”>ªÚ¹Í×J2p«·!7ѰŠÂž¦Æ':,&’vÍÌK¦HÙÕŽ«zPbÚå}0#Käì·f´ °CØP*sqœÐ¥Ô+¹£Ã€m7 wmò‰!½0øìo&Wèš=ü]“aÌÓY_£{@Z•$þ3’»X'[þiZU9u9°°ºô°+ÃGEhÊ|–Réžf Öú±Ó-¤Z£Ï¸q#@(9àr"ÔÄøc¿‚zDwÿ!ËÿØj!Q0e”4›8»eÒ+†EÄJ| "èKÂ[’Þ º¨Ð5`1A{©?ìéóû<{ÙLPm¹6Bݬ÷Øk3¡ÔlÏ](’ó:¾`õ²ÇµHå$nF+® $éªÂIWbSüC`Ý!ù[¼æAcPƒ÷ ×£R¸±0bLÓFË%w#¨Az';/ PØõÏ_*íåÞf(퀖†]³åÆ€n'åDÚ ÔQ ÞG²¦h; û-‰Äõ8ÚOSAà2^gÒÍ$‡”3Y›?.Ë÷ k~RY G!Ôo'_襎¶\ó<ñèéi©–fvùH­M>©×¯¤r/ÃìP¼«€9^ ~³Š4@ki?­‰°ÿO͵•C#•ø¢MfÄkê«Ü— ' /í4™m|a+u@F/ïgoËå/FùD»Ôô~BH"pÛLð|ןduªzT¾¥‘À¶!t{òâ‹áD^¨ÆÞ“¬úï§oÁæ—ˆ ‘P²(Ôgè© »"P)†P>ÇŽ…~;«P ZÇ¢ùóÍõc«Þ2}dñ±G׋â/’%ÏMñÐ’I ‚W–c_¿¶$þ¡qA|ú%Ÿ\~CF<1íºÐE¢ 9´0x>µ}ù‚H“ZAR¤VML{•~/Õ0[Ì”åÇ¢Q²Æía 6 {ÍïÏÂê˜Ýuü£áOwmËéf‚Ý*R`˜€çÌCæ™Ø’ÓäçIgOË ï€'`j|ÌÂÊ`ñ¤L Á†óz  NæØiÝy¯I¢ãÙ|b"BDpÜÇß<%ψÁ0 NM²kRmÞ^œ{¶ÿ³µúׯ',msÔc¼cûúUGôâH„Ò!øžIJÙOFï;™és4†a­èÃ-šreE~®5‘W²i^ «u-K¾Á¹ÍwÁYp6å‰=ËwF@öј*kp„.ÏWÞo#H«>·-Ÿ8ÔÇ7ñ—(š‰t_ŸÒ¶äì'8·Ök)š ay’&äqׄ‘/Ãß:ì&E± ¢áÐÆÊÊ·©¼"Xmw2:]"øè5êÑæpÃ9Äb_ÔBÅCç4krWlz É%‡bL *©½SvWR¬Z›!NF}FKnð? ó®›Qm@iŃ\{ZaÛß[«¡¸œ€·íWÅÊ‘qJö鑨„.¼`â`WÕµ@ráÜ‚kU@S$´ë°Œó>ôÀÌ^vGØm®í¦oùîê›5¨Ô‰‚S¦G®ÃvZ¢T[¡=«ÈâU²þiÞÿÙ="¿éŠÙØt¹*äÕ#§%/Q^§Âp&ïÝçÝ– o† GvâfÏ„û‚*/^MïQÚŠ»¾ˆÙrÉf=–#c¶¥Ùï ƒ°é²:‡c3†´ù‰«d„¥ªÍbåöZµè~ðq̃jÎC×:µT|:éÙ_…×~RÃýûû<•§’ëð‰=L*l£ë[¬j÷$ ŠÐìµ^/ïY@OÍá’°zÓ¢/èÕ¹I3B•Ø’¿J{Œ* .[Ýâr´ÚÈ;¤ÍÊÈÂáÎ5¹¥ãì@ÊtÍÞg¿Ie:;iÁkÊXpüO;¿2C”̧Ò_Þ,c>B8]Ä™±ë‘§+‘wG2Ósgu©^iG~F™èrÅÕ›ú)v)W^%¼ÅvoRNc0ðjÚBãßJMd!ìQRdp1 yߤUg©[çn1’(+Ù”½\ÿîø®2ðæ/âkÈ»2wñ^MÔ‡Dªé|øÐÁåâ®9Ÿ"¥Ê~»r±ÏWÚo­ò>©ÁTölMñ¤ô¹é¸dâÄ0*u–òÎEš¹-­­løTG%=,÷4íh‹çr›‚÷¹T³_ úÄ àDÃ\´zžQ€”Ñi ín¿¨Nî z¢cÒ w\{•I”väÆÅ3jõ(ƒØë¦õ³ŽÏû_•ã)ê-þŸéS5áHù_ ¿‚à7+A«?y``4€vuæð€q¹íÏ^ÎÚoÉ!+pc…£ ùèÓB4ð>+†¢` ¼s)Äq½ï ä§w2ù­®Àñëîcs¤þÜób‘A]¸D0Õè¥ο K¯—JÆ»SÄT?‚ÍtW §V]Ð&˘EÀ€—+0±¤Ô¦8œ*ÀfV='OGö‹ Uͪ×bï4O=m.½¦0•‰)ÖÞAx›¾mÔº‚å:~ÖPð€”Ÿ »…LùIõ‡`õ™ U.R½ F´›dµÑ ¹¾Y)é9!l’+¿ì¶(FB½C½ ݈ªô+Nå-HÎXïݽ2ŸJ‘à ‘#ÐH ½Â’µ Ï·’8fãáûÊk÷p9ßvÙŠ%zžúAϳ›†èGhx…N8)em™¢4oœѹÎ>™ó)åì¸}Þ r²o¾äuT!˜[²×®$Žà)áÊRã“ÅPèÉv%èŒ]d0çm¹àðËx,Ú¯‘ó_›þÂi=^Tcþh+­òQl @íÈ"¯‡¢…À ˆ>×öð¤W€wx)a9.ã’fOäîéFû“ÖÍMë2i EuÒ™íCÍÌwïQô PŸâ¸5yÐ[™AŸ,´ÑCÝË|'ºíóïh_ÌZßæë¢ÈžgOöÛÅîk|©5­Ò}¾ÿ¯o}ÇŸó­I†²+ÛàµaX4èÆÇ䂾Ú7jË ‡›„`¯t›tP—zrvW¨DÚ.ZøôÃrX¨›¨P#H€´¥Ü‡ ñª{¤‡3‘ŸÌñ–Æ^MÕ¢¹(‰·x ií/¼0.-ýz}hïî¾¾>Іu~ÚŽ¶T¡àœƒM¬ þ‘ü <–ü`,‰ÀŒoÐñj–ä.˜xWÍÐrTleÄÉ›Ü32gFDQNËí§<Ü+CíÞ·wJÑs‚y6ŠÆ¶I·¥})Â!p>Õ“ š*Û jìä³o”€-"¯”Üé€à½KÀÃ2þœ@ûÍŽ=ï'‘HWôU=*84ýhçuâšv~Í¥–3 ’BŒ%°Þ`t0¤[Ï–¾eðd!Á¸y”­›Ç֪‚^–ÊÍ%q }Þ`'h_Ûwæ~+kF( ^îZ<6EÏn ×g í ZF²sžI”©A˜ºÙ´§µ¨Èfƒ< ÒkC‰Çš:âQqKAl›.ÌèÀ&ÝÊ|-ÜÖ¬Àõ-Ûm›ðuŒwÝ%ȵá•Û¹íî ¿Œî¨«e) .»ÐJÐm‘ëbè‹ñp•ò?Q’…Í0¸l•¢Á#æñ™ÕŒeäKÖ¦ÛÜr—]èòeÍÄè_4 ¼}«i•9D 2½Q›áôOÚèþÝšMº¦™^’f…+4«ŒûÔ(JZ……ä²^™€´ºüÂ?’:“?IÜ5Ã& ¾¼˜cDá¶ n²‡¯] ®í¹„P$ž¬œ¨ïv+#é I®r 7˜ô#Ê—£Ç¤Tmà px\Ü a®cÝÁvl\æÉI–¿ …m΀Háô,ç‹4ô .¶d²7ýØ“Ëe=rfÜ"òQméÏ îíÃõÒ#ø&%Á-w?/–;ü!Ó+™tÃHL¦¨4mŽAÍ}#0#UçqoS&Óp7,C0ÀBdÓ 1Û]ûºŸ‰ítæ©É "¼ga¤¦Ÿ 7¬®L½¯y®bó²âÊÕF·[ýYÁâ á)J±wÙÝ·j^Ò‰©“¨ƒ¾¯"Åp€ÌÝCÌÉ*È®eÀbȉR8”T¡\Á[¼›ù®¬ƒ+NT"¤[€”Q#kÒ‰oЏBn¥1G¶a¬_O*‡¥vOüm•Ë1ÚÂÙÛIîØ}j²|7Œù¸S}ÜUÃNd^íÇeTæŠ'ˆÛ »÷ iå>aÊaR˜|¢‹Žˆàq²¿%£}/°3’ CûdljÀÜ…+£6¾òdøq˾ת…h›T@/b/“¦¦ö' $Ý-ÎúÝÝft¾ø‰/¾fYÙ³&%™'¾­Ë^å8ÿªÔˆeçdz˜ˆâ Gtêÿ¿•4üÐJ;Yþy]Ú‹ª˜€4acR+Ò#:)†—R½Ü¥{ç™s §cijöûhg%po†W§ñ°?—“¬ã¬ÁòÒKM¥{0×¶Œªû5tð¿â/@ò S†bv¸Ø%ôˆ¢dë7з ‰(ª½ø©ì |žÍE?™Qÿ‡Ã£†Ê&’qæ<]’*÷:ŽÝpüY>Tå‘× ‹üçÚÑ[µ/)±?,᪠)N[`mÆû—Ô2Ïžã|ó$Qð¯ez³š¥Ì)L ]kIP¾ÄÆa@XO †´ýø¯˜™ÎWt»Ï×ïÛϤÇê5o)Ýá¬!ëæ•8˜WÑþ…v`cÕì( î|/IPïHð‰ÐƒPö;×HÈ"èíÝÐß?œ¾‚ÏùÖ]Þo pµƒ }T~¢Ø2òh@É]›/Çùv&{”îï!.Ô‘Ê>ç ó“ìõM``w`”º~?ó¬¤vÊüOÕØd™Û• a£ŽK¼ëC²8%Vû†È.ÀØÒ¢€ÿs¬J4’Ò«!©´ íNÁTufq~‡ÿKíMµ=oHù“P/PÓµï‚ò²²R¶÷á4Ó‰ÿæÈ”K¨aíC$„Ñ7³°Æë«;‘õ®²0Ȇy„—¡ráþ›„ï¿W<*¦4Î?4‹•¬N? òo‚Єf±>‘y³‡7¢rëRüã7/~ɲæÇK`±p@ö{Äx‹RÌÍßÄM3:ûùïœ;õYÄã,€KìùpžV…ÜòC);÷œæå¯p-è—» º§› õ«rüÃýçÛÏ^zšÑ ¢È;Íc†–”OŒèÈ߃‰…vW-[Êír15oÜд:' à§uµâRkzAJ?ž HûgÅ=ÝUñˆŒfÒ\ I<ô@Þ‰’%F”ÁÑ宾BŒ[ýi°å?úi±Ž]–­¶7qÕÖÎ^ò¶% Ï|ãvwv£éŸèùµ9¢yªóÃZå #-rêÎk¶ÐH°yLçc9>ŽÏýòH=˜.†½J"í¾Ô»‘Œm¢Ä6RÎÉ=‰oãÖ©ì >±¹°ívWJÄÎùæÞŸ=QžÓ˜Ó &²|-I ¤#fƒ‹«ñ¯8É^%Až;Ë•ÿDzV°¾)[¼ µêL"¿_ºiÎÈC®É /º¸í9ó$tMß4"Ëð|ò{+ß¾X!ÄÛY|8”!HŒå÷,3–‘ óÓ±‡ïgÄÛÂëN>sÖŽ'¤À¤0fÖmkÀ9’°E>6h‚@{ÛÕ{ÅzO,îDüwºœjâKÜ»ÙóÆkùXçØ\͕ЯÅeœbák<ú:ø¥µ§¥U¤‰Ë$´Š%¡Ì ÌÝÎçœ7è¹ÝziÆ:ÉQ‡í|Î žt­ï:—ú‡‡~Qœ_÷qIøü×yHÑ5Ø?«)k—»Ã¼¤@çÝRq|“9¸ „?ä ¢ôŽ4žÉñ é ÿ܆ì«î'œ«ãOèj‚d×…ªžá%b«{¸@Ê|öª$´>k81v²3oYÖØÍkÇá³²¶VÅ{C}áÓà,Ð`rÑѸã G-Ë1Øul+5râ9ƒm^5ÌX›{kÂôAªâµ—·9ß'‰‰Lõ—“´ó´ëRùµ¬¿’7؃é{¸bRò€:¥hH~"¿?>jîÆ#žH©ÚuhëDŒ\ÑT¬,Ûƒ“r­ñ+•'7Ý’ûd²Ù³î3ö|¥Ð‘êja‘Ý4cÔþ´.³©tÜèZ£àºB0ø~—ßzºmt!Z¸£Ý­C¤€tì§À&{<€RSd uD€œ[÷ÐV]Oÿ x+mî‚:|8ê¦]Bã£ù‚`åÖ}é—¶p¥E-—ÓƒYZ…S*WÜT<à³ÁÝôm‡v:Ø%4pÊ;ëuàå62æ ïŸ‹Ä ]'SN:#¦¥Dzž32ìÑM‘ÚEhšz6û¶OdÓ×à@šåª.N!௹Ü Sðf!ñŽÑ¤ ᇘþ`åÔǶ" < vö¤˜b'+¸u ¡r¼áŸ8¬C¤<…ýcë|5j‹¯¯ñA5‡d,•2Ê(múE{ŽÚbõf, l=ª!ùÉ ì¾(H£ÿwD¶7dêK‡´ahÁc’[ýRe`ÚÁ±¼‰ƒøûƒao..åw}(þœ>–òåÔô·QçÐ䢫áñQÍQPlÜ­\H,œ%In@ ÷Ýuñ”{lïR¥~(;¥ÇŸÿíLÎíë ÄúäòëZÃUÙøÇ£$µgrÿcŽ×å8Óxî{Dá&Hqka¸ôm¤»}ÑÛ ²ÿÁW>0 ‹YZqtl/data/multitrait.RData0000644000176200001440000002506414661346505015117 0ustar liggesusersý7zXZi"Þ6!ÏXÌá½)ø])TW"änRÊŸ’ÙTªµ&²†‹KQR”èiÊ·©¢ôr³M]õ—€¨µ@œ£è¶[­Gañ;6c-åXçÉ%@IWD\ÇdîSœr%dÏí„ÃæŒQ×[ÛÁ²ÌÐ=†!‰â?ñ,ìþ &zP“5@±c˜PNFS+Wª¾Ïë³kW›õÔ¿ðü¡l‹±(õÛ=û…Ãþ~^ûÌ4í×CMë;R•7_8ܷߥKçÔ—D̻ȻpOÙ uÚ!ÂõƒÑçð]ЩçCФ¹ù­ê&Û´÷¢ ß°3ãmGiñ¶ +bpÓÒûgÓ;×.'GÃÐXãÚf‡¤!E&ȶuê:q"šÕ&Úg"…Ö‚a‰·c}Ù˜)C†>˜º§Ü8rqâUÚ>y„ ü0u¢@‚…ŸAh¬rû}¸;ƒ~I–ÌZî³è›¬ „ç2pb®Ê,m«iñ°1 »ã$Úgüõ!]8Ü’n4œ´TtÌCšÈ\¦"{ÁÁ»4¦¸.:n<»MИ »„†‹g“%j L“œþþÓ™­ÎTJ çÒ’Aî¼z©7g4ï¤îéOp¸ÝÑs¸Y\=©vÅ„Ódõr³tŸÕKHçz™f³¬æ`èéõáÛÍ\¡)ËTÜÙ@ïp¯–ÉÛO飉_Ac}hÿóº*<‚ŠX⟹«¡Åµòö7$¸Ò›_Ù¢×r}‚ŸhoS5‹§¿žsC3v˜…Â8å’æ{Þ.¦3÷Ä»±XÉtÜ?!‚­l =‡”-÷‰‚cØH™L~²Ù@¼Ë'·!û°|^ËÙqæc‘ì‹?æü cÉEFVS6Éög=›ºZ! ‡Uª¦)®ÈÉàOÓÀ“¬$`þp–u±AH!ï)ÁýJGöªÎlÓss¨÷×6¯Ðëtl‹ÞD5ÈÜjäàKˆùÐW`O mM]þB— ÂlÀ»!„?µfÌkV¾ËªT„Wàã„AÜÑ•s¬³Ë±“‰œßMŒÌ-l…½ùÓi׎IÍ%Þ‡HL#0lÚÈ%w®®t)“‡vÙ/ÄÇò0t©aR®Nô›ÖÛ4¿Â¨Œ!Ò³V;ë UbýÖR»E„¤Ñë¬K黬y¸7ð1ý1–òë¼^i À¾Š¨Ü«#¿)ÜMÝ5ŠÑÀ–ŽÕvk-©%˳Í™|çÖ5¡Q‡Ô-ƒ&t±S²·G°í#/«ßpð”ÀÉf‰tìxKüvÁõ1¿å}©kõ¤REb»©R¢ˆC6Ÿ†ìƒ~œGÖEÑCI ±›Ág—íHOAYtÏPº&¥ƒ†£pï¥PÄ+†ó•ͼq> t°È¢­ ÌÀ¤„K=—Ÿô5óØ_Q¸VZêèîHŠ’ßÉm§U“ý‰1Û‡ê¡"™ž“Γ7*eØøŠj`[Wé€vnc¼bHeEzüÿÚf£”ÃDmu„\Qñtýz‚÷˜WBcÀyÚjq"ìÕ˜²EDÑo4­}&Ùš:°ãë ƒqºU©×2ÓV"ì4¥¤o‡¾©×N `DA~ÖoÎëÅËÁr¯o¨·8 7È…1&Æ "ù Lº„W¸[—Ëžva¦S*Ol™Ù i`o‚Ö/9>ªA±~ƒÓÞË!ÍÖå€ÏPäõwžµéðÔµ`_LéÊÓü4ñȪTÕ×A†L°äHœ&}ù»®Ý×Ë7Èö…ÃØ M€¤ æ:…â¡S-ÌZbõWUˆŠ?søQ"!Ä••j¸Y©bIN2¥ç½æØJÊßù©gœ ÔRÊå"šØpU²h#œ|NK~*ᜇ &h6÷,@bù6ý‘DK‘*æì±ýl¯ÈÂ`BòTn0(WìA¯ -r¨%?Ždôª{ÙÚ–©ï·þÓd‹Ÿ^pµ‘PØß¤y×È bã°ÃÇ~oI%²M¿V€Ï¢55×ì Ýnw'eì÷Vl­’¥ÒBBŸú„¥Õ¹Zñ>2Qá¸þÛ$»œZm9ÉÆê2¦Ž§²áBÀ*é3fìÊ#—TB¥×M2Þ‹ÝÃiÍ„lªuÓw† Bèçaõ¶BW½5ýÈÆK„‡^×ó:“âãaÉ6gZ+:†ëA€¢¾WBãr&&”³hö=„ŧ±û‚ ±`CIª A’)žÒó°Ö”ÿhƒWÜ°ŠƒfI&qHZ£Y• @ïI.†W&b};³'gNõañ²þ—¤O=9P†~·O2ÁÓ·<%3ÌL7h “ dnÒZê¬+¤ºlí¶œs&éð@ðÖ‚¬ýμal³æ&øÏqþèì8ödâS°—ºŽ» šù)§%/=ŠƒèšñL¨ãÚ£kêæBòäéÇÈø&ðePLŸ#GvïÝ-8âcp¼³Ý}V>ÓÒUûÕÀ½ö†ß÷o+Ñ3ͺ„Á‡Z{¸.¤1—¡)cd-¼SAB óNò¹¤åTµ:¨Àäíf ’ÞS²ß@mŽ è0n‚µk§¬ó¦-¡&öÏñ³¦¯PbMå&5 ƒâBÇ+V®ž,Ôl\¨o–D•:#…K3³ÉÀØ(,m_¢æûCL#]¯N-EB c¯O[ßBÚsÀ$BŒñB¼û΢TáìÂȪÕ„Ö‡ #_ÚBĽ­Õ’.Ę„bñ ¹åR}¡³3 â@?‚+šeµ«m êd€ú•9UË÷b™ ƒeÇÖ¿h­ì3.ïäV<ϳåw¦ø Þ‚¿="îYå²…‘†Ëˆ8ŒÜvŠü‚ +éX»¨ˆ|RTˆ1_am¢¨þÀAä_]5.ÍøFP®UÛ"êè-žìíû¡!?§Ï <¬„e¶5P Õ6š—}gÿ'w¤­˜•Æ'-#¡ìË·"éÿ"“ðÞÒÊÉfíàyê]ÕG«6)5ÌŸ G&C”3ã]I¬Ú²Ï˜–ü²ëQ÷Œùw3M°\½Ä‘÷|Ý_~œêÏ‚½KK]O$?#aœTv§d¨°n±ZÝqr¼™þnGÁ ^ÆÚF/ÒbÔÑ•¢0—µ·¤E\êd˜§ñÆK0m" žˆ‹æ;ÓÔ“¾ñ‘3" ·íVü%XN÷0.â©?µ|‰ô¿¸½e Çãtâ”\ú°øóïy­KuN€¤¡¥¤§­K¾ý¡áþ»s¥:eU^RàjŸñ V ÂüôÚ;î•úæ} Ùí-Qh{O»Š¡nùò5fÞè†ÂÄéT¾Èq™•pÐjF ìœB‰jƒŸŸ0x2nK¯½´>iâ8Òò›Ók„ŽLﻃ”¤ÿ¨nÚxöc;î—sµIMYyÂØ)òWŽN‰½•ïô‘ɲ-´ó7½T›Àe.vä342ˆÇgºyŽ7as•ü <Î…Gæ)t<ä!oØœT@¼ÙLºykÇõÌFí‡âg¿?XX¶©Öѱ›o;œe9‡^)’½ÄcB&v@¶ßeöE µ-ƒæ€BÝu̸ þúÓÕ‚G4ÐGU ”P†ÂÝçüÆñᦄwN‰Z~»ä èsi· –.#Oñ)¢ßV¯,ìfÜê/lêª |Hd†a³aÃñö¦@ÅOÒôP ó0S3˜\ÿp91”éÇ^¸ÎÔb·“ƒFã]uºO sÐ-:Ø~3/NÀ@¤XøÂi")hv)4Qg¹èì86V˜¬Ø ×õÎ^*f>­Æ×Õ`N”Óò7· i ÜÓ{Ñ ©•jâƒÿ™#_Ð7s#è®ù숋ÆíAæ¬ñŒL(ëí·Í»1cV`ÇXqgA('3oç« ®¬t°lqP0àê<~\¿[@Cëêý1RÅÞ˜dÔ(\±`QœUãƒz±=ùÇŸ®¥×â7^ûXM-ËÊ$d.°K’É!è;k‚CÈ"LmïZ€& ÂyC΃ûã½uÝ0;’ÿƒÀÝÆªRíD|³ðZß|‘P¯B“–bÚ’åáðvï¯ÔcÞÆ•@_p5W4=Û˜²€Ü€2ËLÆ«FLÎëÍáùû-/¶[ö–¦^¢w%µdïBZÞ„éµÀ5¸NP2DÁš$ñE‡Åi¤Iµ®[ÞŸ^&õCöQ-nÌW¹ÑJ“Êjy°3ƒ .) Td𩳸øEZ%°ÄÉÊš ô%Ø–ž"+ÿaXívtÔC=ª°U®ÌëF:ÆÌpþâøÚÿÞv ù¿¸aØÜã\@†2<€B‘ŶYùKŸSÇïk<ƒ”à7´Ò|êz0ëóHÒƒ×Æ¾²Që:—t€Á:Èš=¤ >ûGÏsQJ7.;þPÜyÁvÛ¢DÝ»œS V›1<ÅóÊHï Çe’AzYk±ž£n» ZÊå¨&%9B\ø‹Øot“ZIò2ö••§wCnßîŸ{sIË]D#Šh_cqæÙï×>n;ìa8Ñ>Ð ³öx-ònÙ[4ŒâÔŸ2CŠÙ®Ñž€eï§r-vÑèàÜÔ3  n­eé:í„eX»²]>&Vü¥ —À(NŒÏ:fík²x²å÷â¾Þtû½êÄJx|›DÜÓän?€ÍãÒ‡yÇO˜3„°_4 ê<%dx)Üh”ˆ¦Oˆ¤Ã¶¢‹kSb9¡Hs‚8§37°YÝpòŠþÖq“ïP‚¸×JëWù±¯®ô ÷Ú"tJu«ðð= fü´¡MŠ®l6—`²aÂÓC 9õC*ÔÞ3s1ˆÊw¬¯ÔRûÚKx±x™ˆ©}$7ƒÒÞ€` 1K‘»õgäÆUÄ9ú*ùnúë­8Œk¾uJr]L) 'Uû—œ«†þÇ•ÍʵŒÁUÔê`Èç)T…¨ü˜ìœ]é³¾ˆ2üx÷òe0^õÑêrÜͼž *“6„S}ú©‡4“;/åé̈ÿ›UŒú‹íК\›9|–2[X NÞiÇÂôtrô(ŒlçWlVÑ÷·Ë£Ö®PcQ£€»õÇÿÎÕüë)ðéo `ú |æ85 Pþ›>°t³•ÿ~f¬ÇEøé—öÍœW„©Ô-ܬ’-ðdÙJ%òÊÄ{%¢Üà_ÄâœÖmBÞA‰ð³ãóärTÿ8,ïHªh2õ9;?«-õJN¼âŽâ“¿],|ýîJ‚ä2¨ …²©WjâƒX¿!ÀRø¤ÜW"é¿y¹ïÁ,5öà¸7Âÿã2Ý÷6#è)dÃ^›kJ¢1NjO­‰z‰¸yb7HôŠv¶­|¸vgBQ¸¯çŠ|A²w}}«1n= ª#À4¬ð€Àó÷… zØ]K\Â(òpvYçÀWÚ©ë©o*ŽUb´Øûj¶«i»¥@Ž`yHtÉ–§uV¶d:}q1˜Ø ”;ø˜±\žìppƒ·ý…‰Ú å˜p<·e…¯ç {dQlÌ”,Ÿ„Z:Õ@ŽéÝ ¡´æíÅÁÐ…2{)1Ñ*†¦ ^†ð9|W`òÜý8^íš5/‘¨·AX¼_¦9çw¤ÌM©$Ã+ºtˆ2f¤cq(ÍùH78²âU‚V›ë1|g,øµ¢tc'J§þŽ?x‰ØÚ­SšÎºw¼…í§§óŠ4¿) ø}ùn®¾Ü½œK‡{± _¶c¯º1ê»ïkæc/9nÔ0Wýcièd¿oˆèúiËeš„ŽŽ±l’ý0ú‡òšÃU³ jº:Fôy¡yñ'N>_|ùkÞ.;n¦^6΃[˜›ÿÛ“V;ÚSYìJ†æ)¸ª4ìÓÔ×ÐEçÇþš•¾4xáSdÂöó+‘ò틟 „¿xŒŒÉkK8Ô̇¾,×ÎR«¡ŠÜ]λû Ý>ºÙŒÃi%¸!âTë1ƒ Jš ðcÊàdPâ„_ù´ÁGõO¡Æù3kD:שœà*sÑöR‚Î+ ²»†:åÂZTZ! 3C2,›ÚQZIV¼Žsü„q@?ßöa—yÊ¿¡OSª1,S~ 3 ¾3•Oƒ’†Ï|LÌT:‹#éòòO,}»8(/ú§3Q½b’C_›]£‘®mˆŒòÀnçñª[ouæ~´…‹=½úš–†|FS®²œóä$Ôu†Až¼Š†idúQ¦=É÷%ó†ˆO!?NÍm=àRëÕQ-6u†7¡£fBNņä@\Í·Ž=‡´4¦’&æ”d¹j„âþò`óh¢Ä<]ˆá;SÖÁ¬å€$Ï£Þ»á&rx•[>Gaž¬ÖÑJé&Ó0-èH5à¬iÈçR-t-5á@C5à ]7ÿê>ž²¤˜áä À¢Zj¨°]‹UUÞ)l‰)“Ó _¬ôýSxÿx*-6.·gÞVÂ)ç¤y’2‰Xy$“¶Ôæûa÷·S`eÌd³2 ÛèÁw­èô¿h™hº¦%âeè2;”Z/|è@Ýv/X¹™Ð ‰sE¿e WA¹[ô ÞÁU@k»7ð³pž\0«Ò20щ Îz¡Uçµ+joþŠk¡fIܦNnI`¿—Dß{iÿÐ-l5Š”LSš¡œÂb$±ã¶êVQ( q¼ó^߫Š`×€‰h¥„ ê•ÂÑÙ¦ž·M‰Î%ò¯0ts ,‚%ݪ¹u‘œÈ¥pBœ_²CJ¾û!ð&û“òÙE>|||îU×ášXÈÎöØxÐKê,‚ô%Õý9³ò…À¡jü±|ÎX³ám†ûê)–бÞv<$‰,¨5Ô#%Ø cðW'ä \ÕþËž×ÏÄ–¦ÀœJÆÛ‘[ҜǚýÔôÏOIYŽƒ‹QåDa/ªë†a^ê~Z²àÏ6H\âowµrUy$’üIª5Ú± ®a5(è}òŠu“ÝÓ-ƒÅ !€ï¡ÇÅ£ƒRô@l¿¹N—a˜XcO‰‰'JTÖçÛ†MO»·Œ‹$ˆE©nqBl”1Û~ Œ‰cGþy3d™ü©Ó Óxq¿H²±ØóÐê:*üÿh{Ïù¨¡yµÇŒïòstÑóÜ"+åôÍË./+±jê‹D¤ “·Œ.bgcÛPÔVd%P½êl:ãÄ>LDÐ0g˜Þ-ÈΟ1 Ì/„ÿW…²=ý5‰ššýl~ž’¶8mÖŽ>ºµ™Œà cƒ çlPFÀ×XЇµ,±01ÐŽaf¸+Ñk†©éõÄå’ý­©Ÿ"®Çÿ2$ã×p+ïÚå­ŠicsöÇÍÚ ¸CKhȆÍAhk§Ü‡¯Yã~­Õ—{4">Ã^IÊåÎÅUìzÜš±ú§Ê¡ì"¨`ÖÏÁ²æ?Û=ƒnRi(ßiÒ£È~KŠu$Äц1^éóÙÉ®kôÄœe#”Ž‹U lCUíu Èc„â%\Ž‹B ÀO÷ϱ†é6zSº5ÈU¿#ªxßsùcR˜r»QÓkió.¶Íi u.4ic“ŠúÒ(÷ÕJÓËd5DÔ´%+ÙezË«pªõ¢µé¼ÒF“GÞŽ³¿›} /ýâN2sãéGâÆNï7ÖhDPHN‰8Ù1IC¤Z½,{¾žý…tU6¹Þ~›-\bYZ2˦ÆÑB¹0’“ôdõþ' áÆ<ßdBWöƒ‚(A«tÔ˜&‚Z³Í8DÑîlÙ5¾sfN#¢Ç †#|^`GH›NnQ[•ì…%öÎâ²Çs ‚IEÄ¥&Z‘7êž„ž t‘"hᱚM3,Ù†]ÝõAHO£Q[·z™×rбԇ ç j!iS{ú>'±Ñyùw£Þœñk’6FÔý+bˆõXŠ^±Äiíý©Ä¼sYb8š˜V0föˆ‹šœ'‚r1O¶ÍN'>ÖŸiÇØ*ÊTçbuÔ¥Y½oÕ¥1?[>èD"šzÉ5on0ˉKxçPÛÜÏ‘-!ª 'äNgŠ[Ìw L2¥ºc"šÙuY˜-|åzÀ>Å]k£›£q‰›Óö"_šÁê;4EVŠ#‘sn›b,Æãhsx~G,ÈJ ¸ ‰ü¸t/¿vÖ„ŸQ¸> JÒ,ëoý]1vÚ¦% y‚BÄ´‘iÃd|Å™»e a±3fc˜þJ +ë²L¤+>Ûèy½‹¢Šî–Âà2ÌB}}FØ2—¦6ØÓ(´íyòGV&4!)´FDeYÀÑ+.{ôPÓ¨U-aÊÿECÙkð]ÝI©üÓLë, æ°ŒŒ}ì+ñöZÝÉ:8Ð|rwÚÊõ$ 2Üïo[LÀ>«9Ê Hîœ#©ñ –† mcc—‡*PÂ\BFz¨n\÷®6k ­õáÿ¿ËËŶE¿1#âñTp͹E³qKLÛä–éývÈ G²FX.ÓTRË' r!vëÛÉ•~8!¼0Õ"áìØÔ×6dç×ìH uÕ¶ÂÍ_shgr3ŸTiY¨¸1?É>7Sûñäý¼|˯B9}f DhÈɾNbá™Q9+n—ɼ~®€CÒò™’ŠG¦ì•U¡ºXùÕ¶?Ú­—©Pm0Ö40?%Vža™éÞJoáŸÖñg”’Îù‡X°ßJ+eM ÿ˜¡¨½Y¦i”‡ƒ»·?æux-Hh·š$PÏÒRDÒ#Î(f ܵiM#eŽ›¦‡„öI|FChá;HãÀd2út38StüÃ;L~oè#'Wß’Cˆ‚V7  Ë?ÇÍHµáßù¹vAê*;nêyö»7‰B¬!AW÷Ä»|m®ˆ¯b¾!7¬ÙR;ŒAb/´¶°ž®p#æ¹òš ÖOOüã—¡õ’9ù½t{¦•~Gð½Òò!±°ŠGk†Zr¡½ÕœÉ ‰$÷uÏ“ö¸Û ½ö/ó¬þ¯V€…f°!ïfTb&>f2%Œæ­‰7Lú'v‘ŠÍ"0}(üä'„È¡âÇSLÐzÒ—€$BÓ]À‚Ë•`°Àåö˜gBöÉ>×’/éõ‰Q’”%½c‹uF³÷"*(S“Rrç"t '퇎Ìyê„"† ˜þùç¬Úê(‘uCºñÆ£8@ G%â"6¿žp=ÈFú°#)Ÿžìwƒž¦s[R„mqJCõ%ÜËG©ÚBHÖ¤&J7 Í[f.¼A;ˆ¾‰ÚÇÉ{³3qñ¦Èø0ËKÆÞ whß\Vo‘ì,lGl¸Õp]ÔÊ13vP‘ë«7UÛÕà‰Õá¢Áèžâ66ZY±±ñòŒ­QÙŠù˜× á›BC= q'GŸ0!,°´T–/}T£óÿD‚[lWa› ̯ \LÃ<×4Õ…VùàqÒ7Y%%FM¥]†™äÅ+ÕOÇÆ±·(. aƒqúM:†µ'üfs‚ò;2ú•âxHco¨Ô@†¥–ÑKÌ%y%ˆŸ-nnÌÝ`ì(cÈÌa—Q/Aƒº;Þ§€ä¾Å÷Àäd>=(zIüÍÊ J+SÁoz8¤Dº±-îö¬Q „»`g¦'­ÌR-æÊrpÙ/) ÅÛkŸ Ð+4à@H5aާŒü™~¥``ú.¡ZÚÒïâ"vN÷½.ÂFÈSR-qñ=©iÐh›c7ÌÇù(@¯jí¯a«dJac Úaüœ+¤`ç­àê쩲…»Ãc[·$~þΖÛùS2™3W†ê„èž7@GˆÓ˜Ôç˜à¾N–i]v#\‹ï$â— 1±ð1@!eF²t6ú©“ô#÷›{±Óˆ_Ѽ·ý Ë-¬ôÙÝYøh“øJ¢[¿ï?8"Ô_Ÿ/1eæÌkR¢‚Q׫c»¥äÆ XLSDY³{Žÿ&%E9GB÷Q¦Mê6¼²h¡•"P>5± #s¢Ä¾ÃSú$µ‰ 2Ì7k ¥©¢m ½˜u™8÷ýÎF€M5 CmÙž@tÓÃYrd©Ý‰þ¼OñMªu¿°G£JÖɾ7Ö)B+`æ%ã½eD%×Ó&\xxèê·é@y^÷ïk›è˜58„cú)^§nÛ´8i1&m7÷ùK ÿ³Ë'Ób~ÃÖ”ÇÓ¯ÑwZliÿwuô˜k@¯ãœ÷SÅÁ¯z\w¡ o«š àÑÈ¥'Ÿ´+!(×ôYyŠèÝh8 â6¸x™EÎËV¨ ÷FÔ ×¶IÉ?~PS/$pб‹ÄšS^翟'4œ)˜fžÄ¹šŒ¢LÃ@Äú˜=ÌŽ”„z™˜Ìƒù]åÐp Ês{O¡Ò× ×ß $&NMýì“ûDÇÎlôôÈk@Aùƒ°l©]µükú³§šP‡U•(Ãñ‹‚­+µnÓu3Ç«Õ9´¦‰É°kS¦ÖÛaoÇflž¡¢¡m ¾ À¸>]¤Ê¥k3Z\àšƒyÊÖî:*KÏ“ÁÈ/¨L)ЀHM I åŸwæû™¢ºÁbÄâ1¸°6®ÜÏÀ˜´d)c~×)+Òü2å¡ràÔ šøu_iY©ÐŸ¹`݉~hkEAA¼Í‹éau=/‚|;]¾ ^é$æìVd--©>‹àƒlç0¹±…c»~l‡˜¯½¤G‘6‰àò çð,‹¦9«”¤D±ºC&F1†'l6w ß™'˜„OâÒ±Ô¹6 ñÞ϶ØÙU¥>d::2˜+vHãI;ÐÜ*‚šZÔܦ[f¾ êBûÌK¹Å>ì”Tü·¢vþRÎ4›‚Zá§4Cªñl,Øã˜ pØTœ¼ÈñjþŽpûæ#¼Ó/iw ¬XÿÕ^n€Žé?nŸ›Œ×ý £:æÐ–ªé¤ÅcBÇfuVlÑ»+bY¯c’`&£0Ylþ¦‡óü=Ióƒk޳&®¼ Wù"u~| ¦ÆˆwF>)H×ýœ5LKÝSôÈáÔQ 2Ô4iu-‚<}FïRàÀ0Dñ\²eMw’šåhü»K¤½ P‰äžšuŒ„&`JzIe¼Ès<#îõ2®%%ä”6žÚ¤A#û?—¿X”Ý~÷Ÿ’0ñ#„nÓglˆŸ¬Ì⎃M჎BÙÿž£vD³| Ç"ˆhäë>}+æŸA(¶<&‹e¾bI?Öƒ á„g¸iPGì¿5K¯±]pC¿È{_Úᔥ×.de%H¨ºfÕü½v?9á À½?·[úêÞq_f˜à™dzkÌégÚ=½ƒ‘£IPÔ;ÝævÙ8qT–Wëlm¾m5ƒLsÁƒù¹Õ2zG÷®(…J¢¥GÕ“&Þøäã0Ѱ ™¿¢¦‘£G´£Ì¤¾2vá£gÉÆ…ï Ï“ÇϬ0Ç+Ø5úSDëù8)«zW1¦<èÇá’Žl ¨–oËõBº·þ…†éà(ÛÛ…ýffz4E–“Âó;ùé¨Ê¸E0[I’RÚTfþ¹Û;­YÕj|vã8Ñ|iiŽ…ƒ²1õPôªž¿ƒÂëfñ¥Ó,òSwÿ¼[&ö¯%Î45Ûac³£8šû¸]µ«^‚Ñ["¹9iò’rW@l%¹0ÓOm„ÿ¸— ÔHNkèZ˜þñ » 2„ÖË€‰Á ðÐÎTíý3r¯b¾x`~STA‘no/í26)EÁ–æ1ñ5„l³ˆ¤–¡Ðuhq¯Ó Ã"0ª2l-8’9>¶=ç—º öÞm%oÄÿA©¢|FrxøÏÎÓÉTz©Hí°a­‡à^Éô„µ‚•75özÒ~T›F¾f¸È5ÄvPìà´ŸY¹G?«T5FÞ”¨ÞT¦``ß²•Ý¿¨¹‚f\DWØì2нoð\-—6õ·ß%`°÷ÚÂÕBRÂy\ôøKÛô¼¿Àh$ äf˜š¦×-îßT÷ c ¤0úiü@é![ň ~²bå÷ÔSµf‚>ýlFovªÓ:ßÔw°÷ê®2ÇðĘáç[ÎÖY\¡$¨`ß)”>Õ.4&6ÛE:'†y)<Ppo0Nb«4 Æš »t\ý =‡Û´‚+?É¥,•*•‹9ú¥q=H'®Àx)f­É¦Mº[â¶V Þ4oò×¥<:ë-µ! 3°FK AS|Y´¸^àp)"aŒ@-á¢ü`aå;’áMTtT´ÿÿ‘b6Œt˜z+M¥e`G?$š[ñ=ÆfEtâpŸ—¿QA瞥‹í!ã:%ÂFÁüm~èï£ çr–D&Åã}´efj<¶cûû?‘Nàâ`¤©X ³ÿ|.n šv¸R„T¦»mcSϼðñGÃúC†BqÄè¡MÕtj„èÑ@¶Û:¸«i5ÔÎ -³¨ÄD3·Z7uí‡à€Ð‹Ž“(8¯åÖÌԅ⎋E•§dý"æ¾Ø®©ùšà,Pçt×¢æ!2•¥¿rùÄ•cµ  ïw'à@‰Aûƒ1nI¤W_×Bò«OHó.Ñßw[ªB"»ì`D‡blÚ}CˆËS¶J‹WPA„¡álMpæ ðp̬¾9¶Nô·äK>(+Tp)iLøÙUe'è—NlÖî… íä_?|¼3)]Ë£HÓ¡„:³ñNÈ•õ{ÚtÕx„›u&“Kb‘†TVàŸásÃêf­#›n.)ÃÊŠô‹ß‡d×dIÁ½Yø!q’zÞñJsߟ”ÿ5­ OÊãñ}Bd®kû§’Ð9á˜[ÞCÐ>˜Çï0 ‹YZqtl/data/mapthis.RData0000644000176200001440000002234014661346505014360 0ustar liggesusersBZh91AY&SYCBý}*ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿàYÿ^ Œù0ð Ò²R>©K€]€`Å##LOýU  £!‘‰ˆi“G¨hiµI“OPÚ' Ôba='¢ÐF&! Ñ¦ FCA 4a2 4Ó4iÓ=56S&ŸúR Tü‘§ä“T Ð€ŠOýUMF~©í)4 €hÈh‘ ÐÐ 2Ð2h2@4ÄÐ$õJªPMF ¦ 4Á0M¤ÀFL €ŒhbdÓ˜˜LLÀ™0Ó‰¡‘1  š&†¢0ž@˜ÐhÓ $D¦…jièŒL 2 ž„z'êƒ €@4 4ÈÓò@„d”ò1dçM«¨ªªªªªªªªªªªª|ÌZW¬Ã"XȬ÷áÀ¢Š(²±ª…ê5ª-ŠÅbÚÆ°š+!E…šL ±‘,b³6Y,³+"$Ô‰F‰šRh4ԘРVMI™ &D‹f™KM“H–Te‘#%#eÊ m!¬„h¥šf “HdÊ"Ñ”4d3I*XF‘‘ Ø˜lc1(°a´¡ @†ˆKÊŒŒ D)2ˆš„ÙF’Xe‹@dÁ¨„Í LK&͈¶i6%Œ±i ÐaQM¡ –ij l³ 6*jdBŲTF4ÑQjhjY›Fc2b)FRi±)F!dYF“&Ë*lŒXA²R‘&–dQb…*fiS2e2Z,$•f%1 F0P²E 4j# ›3KK#&#$YA% 6PQIˆÃaMI!£% ¤‘M1¦”“™IÌbÄÌɉ¨’L¦QRÊ™©ÂhTlIIĨ©fŠ€Ôb¤$Ó2„PDÓ"›2™‰–B‘²*`• ‰¢ÂSE!6bŒlˆbJS1I±Y5È1E%3QL$Ƀ$% 3a¤$ÔiÈÄÉYJ‹ ŠfD¤$J14ÁJmi¦“1™fŒf4‰#M J†&’¤c4¦2A!°šÍF4eBRY›)I†Y%šQ©e¦#)”4&E)$£2dÆ€€ae™‘™’¤©‘4)‘’bfd‘!¤Ð‚R!¤†B¦4¨ÒFM“JcSPH³)H’K,3K&l²E&fl‘0””Í2„)"#)ŠFfȰdƂԴ ˆÌ¨™XÔaLi¢e)©H™cQcˆ›6&•¥E›±‰fEE‘•2„Ì£,Ë%),SF L™*DÄ© - )“B°ÍškI%Lš,Ó ‰Òh‰Œ¬Ä Ñ$•˜YH±(ieQ1R2 I0Z"Æ•’6fHÄ ”l’fl’™š’ÄE( Ìl”I4 + hÁ@˜ÙB‰¦¤XHh$ÌÉbJRÈÉfÍ(”Ôb**IŠmI*cB$À%£ “LÆ%B2¡›#RFl#$É”4̉‰ %£XÐK$”²)›"e5,&†QQ•a ¤Èa0(ÒIb"ÉŠÃ4Ó4¤šfY$4e‰c*bj bM„!¢É´dc&a3%I3Hˆ)52”ÔÍ&„†’˜©¤¢•5Œš"$‹Hd–$Œ0ÆÉ3 56SJXŠB’È4šcÈJ$”¥£„FHI¥ 2ˆ0Ù*Y¢T‚&`ŠLÙ”ŒLfT(©‰a¡bLÌjLjY›C)%0FÉ€(ÐÒJa$l aLe$™¤Ñ¬ŒY†”FF@›FA1©$›FBDË6 A´Ä¥ ¡šY™)ˆiLŒ˜BÒɤ0SfÑ‘X˜¤lÈA©TFB! f‰¢`Ù‰„$2"š4…–ŠJ21XdÃEL‰L&Ó6i6(Ùh£&Y …ˆ&"’lF%$¥¦ h!`ɰ`6EˆD’5„‹4Ä2š$Е&4f%!±’%‹0‹HŠRL…%)€³,˜Ê“ha 4“6m™I1 B•†d‘"RJXÓ!“ Dd¦#fL(,bBP¬e$°DÊJ ÍLÚdDD‰$J )²PÌJ”™A£Q–L)4TQ¤Œ‰PRE™ 0M"’3 Œ“FŒ‘h¦É, #h 4•%DÂÆj2jREM1 FF–C(¥M„`hJ3 Øl’Fš)¥©IML)H¦HÒdFi0a4ÌfM‘³&¤ÒXI©$R$j% hPk)¢ dÊY)$ÌH Ù1J‰²dQ&dK"$€‰K$Ðj@b6R„U#M$™¦2Ê͈B0X˜˜#1X̘LÁ1 ¡¥60T²ÁM ,h’Ã&%””¦’L‚¢CJ5¢fPTHh£iD(ÐÈ‘„i Õa„a© (¤‘f J1¡1A6 ”±)“A5›L‹f–AB,––*"JɬØÔQ)Š”¢3J›¦¤ŒDK1%’QLJLLccl³(LÑi†2"-bb‘™…0™˜Ù2”ˆÒ(±13“dÔ‰™…"Lfi„‘H”˜LÄ¢$¤”КlI¤É)C1²É5,Ñ¢$Q’BYM†Å%1™šd&“*š-4Â’3LË$6MFfˆšaŒDØ ¤lÄ›3&@,™X¤)E4Ã"KL 1 ,–QŠa’%‘š(ÙJšbHƒA$Ñ–l)Œ"Ê(¥ Ú""¦Š%IÍD©,ÑK12T°‹2 J"a…0”‘ ’Œ(°ÓHQ)4³ÊJÓBe6Q²Hf‘’L¦K4i¤£L¡ É)±†0’ÌA%&’K# ±”bÒfiI2R ÁŠ)°4Ù¡²fÄ$,BÁRDE™b‘F„EŒhY2”“M–eA´j J% MiJQ¤f“* šª*H¦M ™HØ…cLÌѨÍ3QL©(ÉBI¡’HУEDš*Ò(4ÒA¢Sb!"–šFbDÐ"))K"šM¤5 Ì™™d‘)¥ISYA“J3&D%–E1e4FÌÆ‰˜L"l’RI&‘ I4$–µ±Y- L1i2lÓD #ÆÄ4ÛM·7Wac^_ ¿Àûàáa‰‘“•—“™››¡£¥§òùÙý-,í-m~öß‹{‹”Ÿ”Ÿ¯Ú[´É—‰Ô(þ߯ÿâDÜ5U~>Q)[ô×Å–Z•E¢„!I‚(ì\DDHKÁ8ˆˆˆ˜3òBEÜ’%œËÅH$…ËGšTv»‘¬’/@Ð’@Ó@ $g¬I/l&K<úàz_áŒ?™C(e 2¥EbÉT Ê傹d¡%‚Á‚H+F1•Y0´T%€ضvY)Ä(°’l$™I´’ä’LÉbI$ÜA$’II$’KÅ¢Áp˜A &- …Á‚„A † p´LZ"ÐâAh@\0ÂA ‡ D )ÈMͳT¥Å‰$“2\’I´“"I6M„“"I6’\’I™,I$›ˆ$’I0’I$ˆ$’I¸±$’fK’I6’dI&ÂI°’dI&ÒK’I3%‰$“q’I%$’I+¬ÁŠú Ù¤$!-i!,†ªl¹»e¶ªµ·àvÚÛmk@:4c!´Ø„„#÷' 7ñ¸¾Á ´ëE‰qÝÑ"Œ)âžOÒî>ïì~×Å|T“Ât6Ûm¶Ûi±—6##âxSn]ææææç5ÍK²;-ä’I\“¤’J`–ffffffffo*˜•ƒê&2&­kZÔ„ … ñŠd’I@À)á'3$SÄH¦%ˆ‘LK"˜–"E1,D„ıÄI3¤~À ¶°Z^&×ß}÷ÞD0õ°œYJR”¥A$¬Ù³›åÁz¾^؉ ‰b$&%ˆ™”‰ ™H™”‰ ™H™”‰ ™Hˆ’R2ð0`Ä-€á„ÉÙZÖµª$ÑŠ $’€•ƒJR”¤%)<„¥) JR”ÝÝÝê°L +ukZÖ· 0a„Ô±â""É6R”¥)•9èˆÂ4Ò"Öâ»ï¾ûÀ¼@ HHUì²’ˆˆ…4“¤’¢¹ÝÝÀ¤F¦‘º6Fèµ­ÉkZÜQH¤` ´¬¥,ˆˆV¤”’JŠnîîîîîîîîîîîîï{Œ¥(iJ„ ÚT¥)lD+I7R”Ê¥À-h#‚Œ²Ë,ª”Aù=)JRq I$•©QXîîîîîîîîîîîîî÷Ù‚"""ð ^ÔI$‰$’Mð@Dl8 Dtl“Éê0à n˜UZ5lW6-flËW-\Æ-(Ò±§w6K&f$1™%AA%Œš1»ºÐÍHlILѹUКdƒ"îº “«Œ£ c3&R˜—uÉ3`BîìÝ4ÝwE™ÎšI„JY ÀîäŽq b c.]š‘!£10$Yn뉳"ŒNìî”È LËíÚJbL™¤A†ŒÑ¤ÉÑŽî`šç)S™M4±©d„h1#e0FA1Ý]BÀˆ]ÕØÎî&båvÊLÔÉ79‰–bclNæ;‰ NîœâbI4¶iLˆÃ‹50h‘Î0‘TÃL¢eÎ1wuwr$ I“»¨5-›$1S0FÉÝÌ©¦ç.k…dˆM¡˜‹("%$BÅ¥.[†#ræÄ‘…™¢RNu“Rh6ÊFL¡$ 2HÊXÚ ˆ´ÇwcB»·EwqDi”»µsv]),ÃD”JbdD‹#1bÊåÃLA"Y‰ŒÒ$s´œèÂI1C4e’` EI(Ìew\‹œË12Š42f)!”lÓ%)ÝÒ bI2$Ò &&fÌÅ‘ “%4ASF,…"3a’•E±‘.ë²Cºíα·.’D¢¤D‰.Ý:º$¡š˜Рٓ»£ܸQ¤l*\¸™F¦fšL¦„ܹ Òfeîî»JKnët¦›º¸¢DiÆhÔ»®wvîæi &à C 1,‰–“$Ì‚Ä,)*-"¹p%˜ÂÊ fDË¢MŽv'u·Nëv2æ»;wMwuÒêK,Ò@H“F•ÍÒ‘ÝÚ†„fss4nÜîŠR@RÅ%eÎ"I0ÊSaÝÌÔÝÛµw+»¹‚À¥Ò¹î숒wn®îTs’’! ¨%bS&“wWL0¥ PË ”¥6h‚ŒA•Ý×5ÐL„„Ì•Ží®ÝÕvåгC@ Ý]FiåÂI6$bˆ·;H×;9nÐ&4FšRî¹,Gvé……lrî멚5ˆDîºÒa]Ô\IŒ1ˆ`hE“&RdQÎRJRç!*BD‘ÝÆDs’LÂRd˜Ù&ÌHÅš$Ý͹ÍJ!MƒJQ¦6RŽ›µ) ŒÉRF1RCI(&RÒ,‚ )£S6e…”1eLˆ³4%"iD0f’fÓI°¦i)“»“ºk‚EƒwQÚ#u.Ñ9§ºîçnŒTR™²!”Wu¸™DJ06AÎDCJ湆”£E¥FbÉDȲ‰¤“ŠL¡SEA&9Ù“1&!˜JLŠI¤ $$²I3³¬L³F4¢Á4Ë@³ ˜ˆÓ2`Ä$š0“A,ÂY,UÊ» RY¥Ýs”]±e) ;·"Q@IfaˆQ.]3MDI‚JçL›‰RG.‰ºWv+´ššlƒ`2PRBd²[ Û²’3œË»¡RLXÉ(¡4Š4Áa  ÝÔ`ÝÝ16ívé4Üà”¨°GuÔ—:Íš,°‰¦ŠJ&±)¤îºÍ$¡±h4XÔš ‘e‘)¡$€Æ»·fSb,¦˜JY;®–Áš’Èîé•ݺوÈë®ØNèºlfb2äUÀîí(°F(Ðj4™)ÝÜäíÍ˺¹Âç%&FÌfé1]Ò»ŽÝÒM\áËõ}Sóü»Ãx_ÈüOWü?Âð[ÁØ^ ÈŠiˆ›4ÄfÌ’Q%Êæ @ŒI™—]ÙE×tdZfsnBQ•Ó²Wrë„ÓI24ˆ‰F1DaNíÐ"1FÀ¤hÆ$™±×u¢»º ²!Q4›dQš!"…L.]F˜ÎîÙÀHfBî×bJRI„wW)™+ºãcŒD¤³ ;ªédBÍΑA¡E2IBîæÈƒ*”’‚.v$f¤Âl &„@©¢¹Ë‘´ÊuÌ»· I3JhfšæâY0™ šêw\É%‚›t®¥‰]Üi4¦ÉM6c ’JnvÜuÒ Å)ww.É(i’›¦“2räÐÌ‚’F\é*b$®n³˜QJ7ut±)"îÝ6h˜FŠdÆÉ»«¤†Í3%™ (‹šàçQ0I4´S,$Ɔ¢E$K4‘&Q.›¬Ä›ºç.™bÁQP$™¹Ãb2ÊÜìš Šb$De®u3 ƒœÔb–F-(ÓY¤¢HI]Ût”Ù$¦Ü®Ìl©³ ØW]sJhF”FÈIM'8cœÝ-ÝÙˆÁ–"’lf‘i¢snfÍ2)“4ØÈƒw\R`F–m“P ÑŒMFÈZcÌ6šFÌIQ%ˆ‘LŠîtnÎq͸Å;·SÝÍ1¢‘©Š)°˜&îi¢ÈŒ14i‘n‡i“ L’() HšŒÍ"Äi–4̈&¢“e£»—NDÓ,4Ù4\âH[ºè‚DYæRTš!ÆërÝ»¸Ä¤ZRîàE+¤Ù–Ý’d$ i‹1¦LËœÈÑ·…k¨”‘°‰©I4,S†™4F¬¥`Q¦„Ü»K%Š a4‘†È¤&BÜkgw,$!h]ÕÙ°Y.uwvKºìÍ)”ÅÝv;«”3)†21b¹GPÑ¡¦…% I$’™‰QJÉe›L]ÜÍ&Û) “e"Ü×c XÓFflT¤ˆYQ&)ŠL’RL][†S2, F1™C#»¬`»º‘˜Ý×e…HBIYšF¥’W:"ˆÈˆ“ޏ¥@É¢TYLÊDås&i&w:èÜ» ¤@ÆEÝus‹2Á&I.\LŒ²Z²PHL̲ŠI˜"fFÌŒˆRde59Ì2Í€Me1ÎÈ7"¸Â™HLY™‘¤¤];,,C,Ó¨SJŠH‹$‰;»Y'n¸Bl¢š”Ò’”wk´×5Å»ºRl%]ÖêrºŒŒÊ&$J0”bÒbÅ2‚¤6ææÃ®¸³Á².%&%ÝØÑ³ ‘Ë©XÌŒ¹Ä™ÍÎvÄDÉ-˜’wv4.»»®ÅIŒ£]ÎÜC)š4Äi”¡WuÐHÝJL“wWbS1™ÜaŒ M¹®šÍݸÀB )“-Ü9Ô®ë©L£ºÜ̉Q%a“ çLË P“Mº]H6Y3¸éCIY”gqÌ h…Êê†À‰PK—wpÙu¢)7wB&Dš"XÌ‹¥×w$‰\ݦ##ºä+›‘-ÝÒccId1.î]×îºR³ N\£dÒÁ:î (‰I9Ú»¤×wiMšd„Æ21ŠJbW.Å$&ç]ºMtæ1·8úíÒBSuÕsHˆÌ4JÆlc¢gKr™“Fæ»n\Á¢†TÀ"%@c¥u‘ËIÕÍbeÙ]šwr„‚Šnî´ÌÉÝÝ×f¡P]7hIS˜¦¹r¤î®4‹2K1ˆÜäbHŒÄæº2”(’i¤LM&”2a“D,î×4ŠdA ³]¸Æ$i¤”% Èî»LÂ0™$LL»­Ê”&h2 F“0S1“®çs®RräfÍ4i0@À5ˆbi fR™%É£fSYtå'6êJ,Ñ2Ä’IHšUÎK‰Ë6Nç.‰”îIÝ4îå¦i ”‚eÝÅŠi¦F-6;·w\Ì´(wq¨#RI'väÈîݦ*4™®vˆ‘MP"a6& ¤Q™¤%¹·hDÓs¤eÝÝÚêb&‡ut €ÄÂæ¸e L¥»«¢;®Ò”ƒ"f#16,’‹—Wn®fJf4Ðç&fÍî'.’Rk¸í&##MË—wÝц¤¤À±(ºšTdÍ2Šwnhî»@¢QšIeYH¦(ÈÛšêD™H@“£]ÑÕ ’ˆH2”‰%(4,¤ˆÒb ¤4ØCšå'wl“͸æë7 ˆëª8Ì—wId„4°Û§7whÜ»Žº 4ш³h”˜èçuÝwwpî¹wLÒåÑe$FJ £¦º'wsräÜ»)˜³»³»W$Ê`™¤É–3F*ç&„Ú4™`ÌšîµÍŠgS±ŠBhæí¤%‹2±)¢@å\³$¤ˆšSLãnní+AL›œ”—v줒T–QM3I&QK)™ HÍ ’ÍÈÁ]Ýf(SH9¸šKsš#ˆÙ¤ËLb¡36”ÉRiœ¹i¢l”Ø)LMn]®UÔJ,1I61¤Ò™\å1˘FM"’Y!IÝpÕ˘Ù,ÕÐ ek¤C%Ó…M2HæL²&L›‚Ù14IFaŒ\ìR((ÊDJš4i&ÄÓCHD`˜ jîéL),"LÓM(“I»ºIƒS2¹s"a¤K$db„’ ™¢snED²—;§¤“6JHŒRA)s§.¦îìŠQ$šBZEIw\Ê#IHH¦W]ÚàJÄ’ÌhÐe¹» !˜dws²bÍM–H¹Ñ…DQ¤£DÓ&E0Ñ®æi ˜¨Í…# ¹®³\æ-2¹\ÂAˆFÈAÌ´ HSc¤©a53I5Œ%fM¦¥Ks© †55˲I’(Í45 †d@¤ÑÝÐÌQdÙ°fT²R"f‘³fRB\ä—uÌJM”ÆN¹×h€¹\ˆ#Œ·v¹¦åÙ.t…3J%“%Ìu9Ã,¦•"LIWwrìbnreÍÜä»·\Ó»¦»­Ò1  ]ˆØfS"ës§ ×c’nvNœ¦¹ÚD4Ô×;Û§'fh!”.îœÅÖsr™‘D5×[¶“ sºº¸XLˆ³‡stîè]$îr4Ê•ÝnÑ Îwd±ˆ†\Îì×.Pa“&ì]§n9%Ý2ç]Ù…;”Ü:;§w7w„jåà+ nî¨aË™,Rd’†ÝÛ†’I›7]Ó“¸éÚ‘®î¨¹®#wnŠ‘³nœ’‹ N»w]ÔLƒ»„HL¥vt‘daW:Ä™Ýw;…3L¤Û)Ìi’˜wvi³+—hÝœbf7.TFî×%HÜ·iBk—#$™¹£«3J†’w\Hc$²$”‘&’ä®è‰™”ÝÜŒšHF&“3)‰²§vë6æãÍÔ£S$Ìi”“•2“»ƒ6i2œÌæY–Jb¢Äa³1šB’˜5)£MݵƑ˜L ‘FÍ.êëºèœMD]ÎwîÒDf¡æÆ+”é»Gu®ŒÈ$’“ e*$È)¦ÊSš"I” GtE\ÑwE&'uÉ4–"ÑuÜ ‘›3 )ˆÄlÑÊáBš7.ÝÛ’ç3»´Në¡;¹×u®îSEréR³w]ˆ4š(Ä1Ýti¢î»&DK6îæ£JFH\‹©;·hÍ”Ã(îé&æ®”Ýs\¹fg7f@‘0Ás­&¦3f*FÄfl™*&Š!d% &9tI+»“&P$¡°‘r¹£M š‘&˜BÜ»#1([» š$H¤¦Ásu9Ö`”£FTd$cgYÜ·%6i"D¦7rëtMƒºÝ$’f×;ÐFc2É™¤­Ý¹)#ILH™®îe(ˆ±ŠDŒÛ›¦šwWwrås+&°DNíÓbwrXœÝî覌[›±78D¢].™s’˜Ô&áÉ`.\6fÀËœ„˜ÂÙ1‚a“ ²ƒ6$lA¤Îî PQ¢™Ê™¤¢…”î»#1dåÔRC)34ÝÜØ¤±"L\º$lЃ%β•$™ˆ&¦‰·+³w\Kšîms$Ù¨±;ºnqŒÄ¤²˜Û´³i1²æê¦cnîîÝ Á—8Q– ¹r1´¡+—k4³I4Ó2šk»t\ºÊi‹D"Â-$”ƒNîÆ˜ˆHm›“Kº¸€Ésv# Š50Û•ÊDÑ,ÒŒLÊXeE$D”„̰ÄëŠÆlÂç& vNá¥L™rå,Ó%¦¤‘§; ¨„NË¥ÝÙ¡›3$²‘’D$ÆÈ¬4C4‰ Ü»»4Ó3 ºèd(Ù;¶ÜÙMÄiŠ YI;µu0‘*KºèØf\çN°hÎíÚ˜fçB’wv*L‘®ëº»rRZIl±¥B‚ $‰2‘bDfî®ÄîÜ£›É%4©L‡wfHÑ™ ”©)4¦ËÜìŒÓ4Æd¢3I ’#AIF,¹Ù4Ís»º–P,YJf”DSeNr7wl´´ŒÙ0îºlÉ(H•!:s¦®²’YI(Æë·N]3`ŒÅu×I"4©)EÆ‹w9ÄX¤Ì›$R„»«¢¦d—n»1d‚ʉ+]×M$ˆ„i“§a1¤Í$ˆˆLfˆÐ®wwfÆJaJ2”Cw]’¥EÔÊë»#»‚&B`PÅ.îNîSe$¤eeFÀ$¥˜’Ä–1$Ñ¥I«¹wtÌéwIpÂe%LØÈÌ &E‘Êw.èêB$e#œLbQ)gwT©;·e¶ºmj4mFŠ®·6*ÜÖ»®¬bs©%#¹ÂSHdcDçY)#)±b$Äœå%9ÎÎ! ç7NÅ wtÁ¢Bdjjî9uwWqÒìç8Âto(ÆÆÆÆØÛbñ2ð/ ZJÒ[-•¤µ*–ËRZ’«Ç¼¨hº.‹£fa  ¡ €‚AÈ c$¡BJ1Œ`ÁƒÁ”(P ”$¡B(P ÊIB (P¡$($¡BªŒ–K%%-ÃMš÷Ý2›4OSѵjÕU߬aô?]{³†,XoZ™^Û$ º¿çEkÝkÜ÷h­ªÁí¹[4¾Db3)šöÕ[ˆlCbÖ‹E¢ÑhµÝÖ‹E¢Ñh´Z-‹]ÜÕËE¢CbØ‹ñmUvßÁ—^RÿZÎß™+V¾ß-ì”Àf‡Ãáî­Ôw“6nøîh–HØÛa­ˆ{d1¸²ÀÁ‹»M ‚ ¼–¯"ónå&  ¤çnw ©d °TŠ(ÆéÚîç]×w$uuب)) Öåwt”ì3»¥+»¤¤„II7\¤s¹‰s—UÙ) %É:1‰Ë£fîÝ¢fgvæe›´“)œ]¬Ô“a's«‹»ºç¡Ýs¨šwWs›‰˜eŒÛ»qÝØ''uÉs—tºã»S»—GN®Îr5È"»uÝË¥Ýw2 wuËvRBRZM\Ò Cœ‘³¥Á1 r˜Ä —QKuÝÎuÐPÑΔ®tº\Ú©Ý»´çNã\s®ê:g–íÎîë w!œçW‡ ÝÛs—&ç9×wBn\¸“w]×vçXÜ®W»cÕË›¡ÄÎÆ)ÝÎJæ"»³’7w;·:à¸S®áNë‹¿‹Ä~ï‚ñÏÙýù~LJðþÆüîccÅÆ›Mƒiãq¸ÙÍþ/ŠÕ«U,ùBЯ//$' á0Ú®­wwwdâââQ¢´Œ.;Žººº®D EÅÇò„!,`÷¢˜¤É—ÿ‹¹"œ(H!¡~€qtl/data/fake.f2.RData0000644000176200001440000002330614661346505014132 0ustar liggesusersBZh91AY&SYú"´vÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ÷ÿÿÿÿÿÿÿÿàI\ÓÀP R@@h(B€w_v‰ƒž @î>k†ß\©×UV|ànû¡`Ñ mMFA OSL™Oäh M)ø›BO&§‘=3CTò›##Si¦#LŒ?&)˜DòdÓÓL©í14i¢lSÁ4žšdž fG„j3SÓR¤BoõQL'¤Õ?jP44 ž  Ð$ÊUE=S é4ƒ˜ÓLš4À!“& ˆÓ!„Ó#F €&˜i‘¦FF™ŒŒi‘‰0&FF0“Õ*©@6¢H4ô4ôƒLƒ@@Ð €D’5&Ôôõ‰â†ÔÓÐM4h2h @ÈÐCM2ÓFž£@4µÔ4 Ô@iê|¶Úµ}o Ëb“l2Æ#a¨H´Ò4ÈÊ,h´˜™4„„Œ¥ÒTZ ¡˜e”lÑ*1 Ã$K i ÊPšIŠc@ȉB šH‘3ˆ˜ƒ_¦$±H@E[´;Æ:Q]zIà­ù-­­òmko]¥­¯)©µ¯éÊ·Ú6µ~”­í¼%­UáxAxrºsr\™+’¨ †Bvˆ(gLŒY"Ri(K@Ê*Õ)0%LÅS*³ » ¨Ã­J#¥i§% ÍZÅ‚âT¡rI3jʱ+Vªœ)¬¨ŠfšH•˜UÌŒNYÓ¦K:VJh‹TÕ8\ä¥cS¡+,© ¸eeYË%„δJE9aER ©d["Њ8QI«H¹¢†©„,é(FYZ…iauYȌȠJUš‰G Hä!²¹¡‹V&´ÊÉaµ(¨%iE@ivY( p­J°RÃL„0Ð$Af‚ ª©¬( ²V¥´ È—wHŽî;q¡#‰sÆ!„B‰.’¢ÎTA#KÔ4ÐLˆÄHއm(Ê’iDŠ\D±„»±wcÒ㋦•Hd¥,æfd„G$ÈR«6²¶p¤°ÔÛ)iˆIÌÄæ+9t8ªª*Ö˜¨eC—MB£U T¸ZªÉRèr‘’°³–™I²3 fF%ƒÈ½ÊÄ46jAÓ:Ru1„YU’Q,…R5Ý‹‘Ît‹0‹®t.îE×a×ræ0¤•,¢-C‘Ã:%tTT¬‹‘ V†©hU*ÌÚ)(tÎB!±P,ZÄæ´*°ÈÔ#¬¬+TY‚ÉC"µ ˆš@²ÅJEb’J„bEs¦G4BU9Ih–)­"ÅI9t²XG,,BéÙsB2%(¤£—4¶KZd ²5ae¨a²ê[*Ë04•K 9EI—*2K‘¬K$¤å™t Í“+$ÂÎ…!. ‘VFªV¦œÄ-BRÉ2ŠI•ˆ)’ÉaT\‹¦²P ÔÅ »Te',*²ºfräe@•DË=Üó@ºA™š(ˆ­U–¥dj…ÊK…ÂP¹T«-—P.f:–&eÈÔR"„Í@ˆ«$è_:6ÒaÃü/ᘛxÙ˜­Q- éˆ*Qs… UJU(Œ1I³39E,ë¹tì†w.2 +$\­NÒM!$¬,È+•r¹!ÔÓ93hªœª UY¡¢!A¡ ¦…‰U@êά4 9˜Dj…X–´9¡ªªEÒVF)QÅ Mç,ò¤åÚT-ΣJ éîÙ×ä‰' %$,ª+¢²Á ·M'. ã»uÐΗBn.Û”C¹×I®ŠQÓB5ª‘òœÁ$”LÂ6‹, ¡3š*¢Ò,È¡YpÅg5¦…L«¢RjFITÓˆ@¢$—"Ô(¬”)0º%FY5$ê ZG) ¹¥%*t¨4šn!µÑÝJ. Ýќ氺]²LÑiȵ5(Ú…Hbl¤‚ÌÊR1+%4Î¥jWT(´DŒY%e,ЪÉ+JœÅ¦†!†‚B˜¤Pó&r¢s9E$“Y'¨U)râ©!"–Ô͈èC%ÒéÓ.wÅp׮΄°¨éEU QI™ŠTb ©¬H"‘RÖ¦š²’5¡ *Ò3Hˆ³-L’N•T˜QšÐ°«†Š©©³ èY± 2²¤’U†efU\JZRe„–¤†–U¡J¢²!“5NdÉS9‰ŠZÂ2+iH–UiZ­@ÄI9h”•–m”¥!réÓY !¤Rté˳XU&r:µšhFZb¡Ô0ÒæbE\µ.3–¢idr­$JÔ¬¨É ГN°¹V©Ie‘T²¤åʪZÉ”J†¦I¬Ä5 U«Z„A¤¤¨U'E †Ì´ärͨ²P-DZ„J4#¢Z¢ªZp¨Ó $Ä2 L•2’¸š æ«NiœÐŠöÜDK·eÜî,—g(šªD¬Ò(´"ªN¨Qd•b]V(…&³vFIšr I#*xÝv(•Ô•D‰Ã[.Ga¢©k5­$Y©¤X†t³ ’5!" árâE˳hhe¥$‘HTd*Ñ”…¥JYÒNPÓ´²R¸†%¦T™Ñ23‰ufb´j³*¢Œ+PÍUBˆªJ¢2CE”Dq2é´Ô Äï-BuJºJ20à C-(#.¢d'*,´QLU5b˜k*’¢ÃCL£2Ôª%5´% ä™`JZÔŒ‹juEBŠ…¬Í:EÄ1-$PÍ´‚£D¡M3—NŠ‹BL¦©É3‰“#!j´"³riк¢òÉÇ C ¹R†¤•)V…ÎVD¨Ô ‡CVYQÔPЪê‰Éi±"‚Í¥VHe¬”ÊR ¡B­KLÃ$ɦE¢"ª…TEåP’ÝŽÔÂTŠ»NÓ4¥¦Í4¨²°ˆé$))*Ë– ˜”dE!JfÄÊ(°ÒBLN•iZË%Y¦²‹ ŠM¥j†&Bs4“!)J²I"¨–[S˜ª’”˜–u¤aÐH«9eEÚªie% ¨j² ‚Š3*L1H¸ªÄîpH‰Üê\‹®ç!…Fa4%MÎTR´š°µQ)+ $1 +6D™¦%!d˜TRU¨VÎI)²:Z\ÐæUЮaK%iHF”bf™$Ë1PH‚¸ª¢UÔ¶f­8Šj†rÒÚ(D–´á„­PÉjÅD :Ê%¦Õ !* T3‘…bV)Ê„ÅY¥&p¹j'+6¡¤% HRYUEÒ‚²2ÉL,™… )hqDÕ—);E¡´!g)2¢¬K4ƒ2’IM‹:²‚U2*ŠYÑâ»­2.ÌÙZ©¥g6š‘I"‘'4¢"&fU²¨Y‰˜¢[Eš§K–]"3afE!#54²QeÔDŠ ¤•Yš‰&ˆUÌå ’’QҤŠ•¢©µ2S:&QÅD0”ÙÊ*S‘Ó¡ÌÀË,é©V|= /HR(¤…J,ìºX¨†D'È‚Ù-Ð"kb!$,Cqƒløqä<‹fH¡$VIBÓ-"²ºL©+B-VuœªL«%0%4 Q‚–I…¡™bŠU§Bª"© Ú!ÌQI3M g9rÐÒ”KZˆ "IEÖ2ÀÖœ ²°« ²¨+.Z%AhŠR„\”²Ð³©D«##  ªQd‹ ”FÊ„åÕQS©Íh†æBJ“R᢬°¢•,ÊT«-H”Ž ¦bt,Šy.ºpÑWdÒ¦™)34D*¢iУQBÑ)YY!°Ì£R”A"íVÊN"Jµ53 6Vt¢²iŠÃ,%dUW*ëU¤)‘¥ÒJæ|Ïq.j8©Ó’%"¥¦*PAÌŒÒéÖEDeF CH“ JÕR6A%W#2%fÒ’*ÊQ8“4»Éu¨‹q²äš(•vR¨' %*4¡:I…’˘²D¤…-VTF'C6„™$aBŽ!˜%EÃ2ŠªQQ3"ÙJ£CD56›‹¤˜R‹V’sHªÔPš\ü ¡E2<„çÃ.¦T’t42å´RdY©Šò¼i嬤"Ê0ÊŠ.†¨Eˆ(sZFDe†*³š´Jèb# 0¬µV$†ÉP­QaA¢‘ª‘jœ:†¨š\¡E22Ë¡¢‘¬”XªZL"Í—E Ž7CC®.¨\Fî6J•È.b˜´Ê24 ³¡\N–¡Ú‚Y:Z¡-\fî0`•×%ÝÐXE*t°Ìâ‰ÒÚÎZQ˜´:º¬ä²U"auœU 2N¶i MA5¨…’I¢R"di‰a&W)R ¶¥¬ê‰$h˜fH©G#V•µÑe¤b‘h$eÉadÓ¤‡æàá9%)¢­Kj²­AQ¡ÖAVt’i'pT¡©ÜëŒ.'#]8Jî¢7œH¨é„¥)É2ŽBЭHˆ”ˆ6VÄ¡EÌ„­CN­:F”(aj’– tMœ¢ä¢tæ`¨œiº;\â;r鱉3•s’ZÓ”Qh¡ÃDìй†Å6ªMfd,éˆT%¨T*B‚‚’ºt®³…•X¢Y† §2®s%‘a¥‘a’†Í$ŒÔ‚æ…ÖJjÌ.Rr–WÐ" Ò®™m"+™¦V±+(ê*’YÕ”êˆi ¡³ãxØ<`Áå ·”6Æq€ÛÈ@†‰¤œ¦RqaVÌÈC’´áqPÔª„2ˆRÊNÖšt™d%&Uˆ‚Ó5-MC Ð4–$—$9ˆÐË1E¥¢FG6•ĄªEš´„:ÎG+ª\ÔÖgJ0•aÍ’W#"ë5T•%7“ÛŶñâ x%BD)Ì@”æ¦H¥%1BDæ¦ JR&‹Ä€Ë´c+©© ´!¶6Ø@b""1¿¹‡´IU®„, 4_J"j³BA$Ì›NÅã1˜˜Ùq,¸˜Žàd—bQ i’Á,²<ƒ<Ó<ÒÍ J­ˆz©ï-K»àIá«I5ªÚwˆ“JjÜX¯RB%cZ ³LY¤™”%p’$$P–)•ä$ (’qÆ„¤,¦ß_,>SuwdÌÎìÎ0ÂXp0áˆWæ#9Âë@•¬…ê?OqÙÇ’î¦lwÉôn2Í ³¥­ìI)„B"Pâ’H*Œ@„$ €/Æ ·4rÜÀ˜ &ÊÚ¦¡¨j†¡¨j†¹M4ÓM4ÓM4€;3nìɳ<³±vmQ ví¬¥2lMaAXR)šlzP™#0,*` `H.Ë˵E;”l% …¢ÂÙAÆD˲eƒ•(9©p¡h¼Ã+/KФŒ t[»*T¸T¡$12D‹ ]¢Âü‘h°áRJ•,/KeцWe Ò eÙ}|ØXPHJù’@@$È §ŠÊ$€H5öêIþÀ!¶Û°ù?/¢êÒùºÞ•rîJ·©ÑÉ æ&x<=džð½á áEðc»©ç=ª·‡¶ŒbÚKQ±¬!±FŠ1ƒFŨ¨5E´mŠKRZ+‹TZ5Ø¢f€“hÑ´QhÚEA6ŒI±i4QI´fZŠdhÅˆÚ FбQ³,–±4ŒPZ1ÚLRlbŒ$lF£A´I´mQQ ÖM¢Á‚hÔj H²±6‹%b – cTPEdªa¨Ú1IIŒEF&D@FÄjKI²cEbÐci±‹ccDXÚ‹F+FÑa*ŠhÆÅ£HXÑh¤Õ%bÛ&6ŒllXŠ6-1¬”•Æ 1V0Z,d4Q¶Äš ŠŠŒcdÛ £QEFŒ6ÉEŠ€Æ±QZ*-’ÑŒX4llhŠˆ¨Á¢™ETX´mE*#d¬lRmIdÆ(Õ6f’( ‹AfTX¢ÅAб‹£cX¢1¨b$ ¨£BhÚ*’´˜Œm5cXØÛ‹Tlh¨¨’±ÆÑ£hÔXØÖ(£b Qb¢6BŠ XƒEÆÙ"1RQFÂ[F¤Ú1Qlb(‚±EhÄmF«g˜, ZÑ C`ÀX¶§°¬U£dÅ£QA£lmPl%£Eª £ bŠ#AdÑ©,QÆ*-m¤Á ƒ*KŒ”•$TTb²cQˆÅ“ ¶/Ð^¼K[Ë?3Å+Ák^Ø ´TlÅ’ŒQb±¤Ú5DV#jˆ¶4ZŠ‹Æ-šŠƒ¢‹&ÚC 3XÖÄX¨ÑlhÙ+I¢ÆÚJ’Š-¢£Ƥ±XÔl’hÆÑ£ŒDFÆÐE±T%mm!­cŒDV™E&-6+Eƒb¤ŒhÔQKRDTk¢Æ‚±FÆ+h6,•I±•KMb#dÑ¢±lX«Ã,·2jˆ¬FLZ+4E±ŠÑ°‹ETF-‹ch´›F¢±X´– *HÆ(Å Šˆ4EhÔb±X¨ÑlX1¶Kd6-FÚ5¢¨Tj1TcEˆ±£Ac!DQª*1 +b4jB6JB¡6¢Ñ±cllXØ,Z6‚‹b*(¤Åh‹bØ‹ lFŒlljÆÅŒUˆŒ[&بض6Ed¢bѶœj-fX¨¨Ô‘¨6̶ ŒdÑb£X­cF±ll[²TQ¨*#Im‹DZ(Å`ŠˆØÆ’Æ£cd,še¨ÚűFÑ6*PˆÁ²EɢɱX±bŒ%±±±dÅ!j(¨“bŠ1Š*-h¨HÑm‹E6Q$PU6¢ÑQ£Dch±Q¶زUlb1¤ÐlbبÄÊ5 ´F©6$Ö“Z ‘ 5 ¢dÆ´h ±X«¨´lX±­21E6Œ±¢),hЛTch¡4VÅE¢bØÚbÔm5ŠÑ¬•Ù˜Á„6 PDlh¶ ¢Ñƒ6#Š(´V5Š[m´TXØÅ’¢¢Å£DXÐk6‹bQ¬Y6 h41F‹EFŠ"ÅRhµ„Ñ%!hÚ6M¤6* ÅFÈZMQ£,cTZ6€ÒmT!´UMQ@k‚ÄY %b¢’£E¬m5&ØŠ$FˆLT[EcÒ+&Ô…c±£À[L±h‹hÅhÆ£XÚ(5“E¢Õ®ªÒèW†øYà›8 ¶8:,Þs󯫶ñ.XÅ#J-£i" ÛE‹ŒQlI (¨ÄI£lmš¢¨ÆØ¢5ˆÔl% Ø¬†Š£cÁlQ¬cbÑŠLm‹©(ÁhˆÖÉIb5D[&Š´b±Ñ¬RF#mÆ“F£@Ëhµ4”m¬X Œ•*ŒhÂccAŠM©1±¬d¤¨(ÛÑÿ‹µ[À–*Š6„´E¢™aQ±cbÖ,&‚£X¢ÆˆÔUƒÒca-ˆ¤ª#EŒEBhÖŒA¬lÆÔ‘‹ŒXÖ5¢Ñ£h±f* Š’¨Ù5IÈXÆŠ4D£`ˆÐY F¢*MFƒX±ˆÔh£i-,FFÅŠ-EhŒm&´m%%EбŒšÅ‰1F*6+E4F£l%¢,X0Q¨Ú",ZM¢Ñh±€Ø¶MEh¨Àh´Q`­ˆÔl•Ó1¢ŠV4mAFM±±£b a– hØ#i’‹ccÖ-’ŠÈPQ¶Å±TlQ’’Š TX4bÕÉ’£61¢#hÉTZ4hÑE&±Œci+ŒcX¢-£hµI±QF5TTbØÅ±ª(¨£Q ¨ÖKEEÙµ&+IhذTDh¨ÔTF1¢1ED…Œ6É‹lE‚ÆÙ(ÕLmµAQ©1R–Ñj¶÷õ¶Õ^T¼ca‘¤†Z(‹Ai ££M’±¤´(KŠÔ%[&ˆÑµf€¢ #Q¬Ò£%‚ƨ¢4kJň“äkm[^Û瞆€ñX<£½øòG}›ñç·«m¿a­ò º8pHY» Ú7GŒa%Š`¹áœÛ/Ð [»¿|^;œTAe½g%åæ`ºããii]Ú4|ï^š±–á¤MÝÁ‹ÇÞñ¤È­½@ìp|æ"`E&„OÑkX_ uqzU÷æo ÆÐNØ„-Ÿlaõ]KIäýLjU"ØH« ²Â8T¢Èpc,™Õ1¢¤¸¹Jë]!Œ€>–/&jÈå›BcÄ]ôÒÀ2™öþL-ÇÙÍIšæ;_~uGv%t<N<™¨‰7Â@Ö M·È€‹-£ßF<ÄÎÔª¨?jΩ@|àí–o±²i ÉÃÏKž®Tb" }!$«¯·VR©¶3^˜HArÕmÉùÄ[Í$^¬£º‡Ò1÷£¿`t?u6Q¢Þee–Õ^Š(¢Š(¢ˆ¡¢XPø%ŽšRT ðxBÔZÔÖ­X±jÐ3N XN¢§[—Ó,ŽÓ iQ5•æ:‰æ˜€áßàÕ“»§§Í}m¼‰1EMzõëÔí E"³¨©”̱ÖÛfÝ¥º´sEd™‰ª˜ÂaŒzE–+"ˆ’b!ÈQa"µB¨ª¬ 8È$¢D(tD0Ã%Q (1’Ê¢P† dÃBDI¡È„(H‰¢ÂµT&*¢µUJ)4ÓM4Êh1Ô” ¦š`š¯ {ÕœeJU†ìîïÌÖÑk—%®ºïäÀ ë™`E¢ê…"‘%êáü Îî°TjV µF¯®ÁVÅ]Šf¾’v^4jăcŸEy«­ Ög¹ƒ~ýûõ€Ø,WÁ¾WF ”œIÞn÷*|’øXÜžÚ-YmÞIöËdÉÎè‘)38•GC 0É"¿~AÒÊ߯ypç¦0„Ãhµ˜Ù®ºë¯ “Q:ÀNÓ§ †Qãa/ž£½ÂH”’ft;¸î”‡yƒ¼T!-åN;(2kN¼ *¶ÊššF¦{v®`˜5©”ʘ(«ŠÜ*ª”ª1w²¢£{R'hÆ*!°m¸S)ï‰ d B°aQŠjÔ*ÄŠ•öYS> @ªE2AJ¢ ¢…²¡vU;»º¯årw(vãwZ¬éð;ÇÛ8#å©Úã³»=M,ܪ݌ª&‚°¥QiÊuñ¡xþ>ñùmJ«à®Ô«ú¾/»8ñ|<'vi.àQB ðºÑkqªÕʪªèÍS¨)··y_/y]AjUò† [Wj_eþßÂÂfX¨¶NëìÏ-ç¼Ï…o  îàÂLÊÊkÌy­ä³§ÉçyÒ¯gJ¨-«È;Ëç8bí‹@ò,í6‹ÙhW, ûÂpšÖä§w0h¬ñpñ;¹¯ƒ3-ᄲß;*7[‰Z0Êð:ÄN÷ È3¬ÒäbQH ™) LfiE3)DÆTPI$“M€e”RLR“DÀ!Œe˜ÓLS$/T¼¯2Iö^ÝR”ˆ “daE FÈJ3™˜"šY“"ˆ)² ²@Ä‹&Š Ù†$ÈbaJhÊR! CDÀ@”¶™„¥"RdІDC$i¨‚/¾ðWàM%D¨€%Ó1†RL4„RE H,f¦ "˜Ñ ]Ò‚KÆ’C$q×1ö„÷ìÈ |-“åyEFp4‹‹YMÜÓ‰aøÁ×—+w„†—ØÁ7_vž« EÕ~o…,3ÃÒ³Pyr%¬ÀÚ×lÜÖŽeW¾ü„ãú¨HëguóàÓ»6UššfvR(]}ϸ˜>Ë×zIÓ”üö’l&Ùd]Uëy锯~ˆv&© ‡^†v¾fZ5+©êÃͬˆ¸œ^ŒüëªÔsu„ècñ½4†<štßû_ÔB“9FçdàÑ¢µ·ˆ{ñ<¿Å¬-“›ÉÊœç—~‘å['%~f n ?à›óûy˶\”A¡Ãé½}H+G#’ ü åØ)µ{$츄¿\H/\uâV®;*õþöÛ‰ô9å& ¦š³J ‚i&&¡5kXí3±äSYÎ g8L†HÅŽ$ã 0Èí>묌Ê#2Ú±ÙÕщÈ>;Ïãù›û}N™V¸­sHî’‘ÃÃôGhÆ©¬Ž’ãºÈZÌh»¸ ON4¢½¶¥øÈÑŽð¼2¢Fjh¤Ä¨P¡"…JÃ2d¨cÎxÂ$Z reI*@ÄÉŽˆŠ3&´LqÆ(AT@ÃPš$[DÉ$ìÉ¡ÉH¢-Ë(T°©K &X1‹Ü·ï÷„è™cq·¿lò7’ˆ@¦§ÜRI“?ÞüjThçÒnT“§Q€ƒ0»ÆAo&(´„“Zô2¯E¬B$oä‡å¬8€$…Ô,†Íqá¯Ëü¸AIkdzu SÞ¼ ŠO½Ò׫2Þ÷sP "´g;=*,ðbÐ@ BHÕ¯’Íœ>¾]_@‚÷q0ÊnߗǦ 0ïÉ ã’ºà„ îJŒ]ùBÀ![ú{аL‚l5‹mT¶EµˆqÂ…ÆŠO?ŽÎÒÑuxoê÷MîE'šxÍës\{±×”¦˜fðX8H¦Œu·›vØ@kÈ¡\„[Ýw þjiû¿&™ql³d¹)@¹Ý.§N€7XD Ü 9°`tánÕ“G¼1zH€AçÈ(Ξï´v½é×k9öç4jPnњǦÂ<½«FíÁÖzâÕXbz^ÿP…n0|¼u{î‡Û+Y°¤Kœž¤ÑMûx1=­§Ô£Á¶ÕÞ´ÉA†œÒŽz »®;®yžn›ºÔµw\4qÇ* U*\ÝssÃr´«ÝÜ3×;²/s%–«¹åz¸„Žî¡ë„ã™ç¸æ^ÑÇSÏtÔåh蓸⻷ÍG$ñÕ*Ä*:évzæzî˜ei^·4C ŠtEÝÂâIW—¹§¨n–êC›«„±t½ÜÅsVR¡¥ågsÜ÷vç®âN¢G†ÒuÖŽÜœ×qËÉg-n†:¡B˜žU¥—²ÜNºÝGtpâîŽÂœˆ¹dj(:+CG=Ý×VTæyän+¡êÚ©.ã•èÇK<ÜMÃ[„»Û„¸âèI{ºW®z·sÍw\»ˆH…¥êx»Žîîë¹.ÜR‘upê$;¥{Ž8K3$Š/'<<…N‰D{¬¼Ì¼œ+Çt'KIwJrJqÖ*n»urwŽE&án蛬#ÉÍÖR¢ynžäbç]ÃÄœ½ÝQQitúÜ#ÓÌt#M8I{‰çBJ´½Òãºz•J¸•§› 뺞^Iî¹ÃÄ÷MÙã»…ÕnŽã„î‹µÕ ÈÜtNåEà¥9駺ÐíTœ,‹ÊÇVYƒ¥;£¸dzžž{ŽAî¤èy«ždº–® á{ºŽ»n¹zîî;8z:$Ž8xnN¨å·nIé©Jh„3ÊTœR¿çë”ð98´œ$â(‘˜ëIÇÜwp/tÝÑw(«È¼÷<ó‘wR÷wQÔöXÒœ”ÁÈ#ÌU…î#‹‡”ÎfnåS¸I8IÿÅÜDÕƒƒºëµÝÜtrs*qàã¼¾ ¹©F*îÇQ/i{»¶¨¦zܼBƒwu= ¹î9¹ázÜ')÷põt—= %Çw#Dri¤ÚTF/Ï™±Pž›\ÿ'&TŸº÷ÉcÚCÜX&h£õAkètZ×Ëh‚øeïÑX”®“~äßr´²Øº6ùœò@OÁP3cøãìâ×Êû§² ÆåXÄ 0/ÛUx½h¯gÆß?H‰,»ÆØÔù‡Î™nKiXóNþ›•fõh:i¼¥•/YâùD¥Ç8 GâK‹SSUyeÞ…ÊÿŽºËà±¼þ~ÿh€A‰ßµßïJÜ©ðÍ>¡ˆFÞ€"sªjøŸü]ÉáBCèŠ@qtl/data/listeria.RData0000644000176200001440000001550014661346505014527 0ustar liggesusersBZh91AY&SYºÿ¦`‹ßÿÿÿÿÿÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿþÿýÿÿÿÿÿûÿÿÿÿà.ßw’"%JU@¤l”RI"BJD…T@¥*‘QJ“CIJARªT€©^ž¾á¤kÖZúÛuÖÚí»k¡’í£±ŸôU*•*±0Ðßp€¬á¤DIé¢z zdõ2“LSf¦SÌ“"{S&M'‰‘¡3LJzýMÁ7¨hmSÐjzŸ šžšShM<ž"m4Ѧ‰âh'¦‰èÒ10a •4COÕ ¦%=P È4hhÐ&RªR40`˜0Sõ*ªS@ÐhJªjhÓ&0&˜0M1€Ð44ÀF&C`!¦€2hh2i¦˜ƒFÉ“&¦ŒFF†™4hhÉ $L£@ˆ‡©¦ÐÚA“G¤Äa4Äzƒ&šh4144™2i¦˜˜F†LM †† 46¦Œ# M2zŒ˜ #Oty|פÄñµ<ÝŽu1^¢Žª¤H?;°tzXÆxP§‹Ç‹xPñ?Ûcr¸E_LÅ ¤ò’…Ê­ÙÚÌignMInÚ-´šhšµÎàéªgR¬È‰jLšðÁ!QÝ Lƒå­HB¸S¬ÖÕ¶§: Â)+(Ý:C“ÉX¼i–´ gnÈaNtå9­bhÍu´“ Q&!-2°™ œÎ‚V‰…&"ç С’Ã&mbr$Þ WFQÓ’™Y'YœânŽÜ-Î &šiˆQX·F²tlìÌ” Îµ·YØ­ 2%Â8¤UÙz¡èÐð¨9#¡´ ¤:M³±MC¤ÖíFZ¶Vq8‘KŠÉ~û;œ"¹H%á(Hª“Ab¨A± ÙEb¦Š¢ÒÐC—D±j4Tªâ+.!Š˜©ˤZT•;P©2áJG³¡&Ö(re*ÛÂ$"¢›*ÅBU”vØÚ6id]˜u™4Mj‘• ÚsY‚‘œº¥Z‚ aTs²Ã5 Ü•cqÌÖÓP¸«M­†f³¬ä—)"ÑI2¤ä¬Ei™!©ˆS,…5KÖÚ³- ™™#iL”éd\Sb(´ÎB¨°¡FÖMµ–í¶ÝÀØÃ¬‚$QXdEÈv¨¬XLåDÍ–ÒHH#T”Hèl*¬0‚:°ª¥U§2æÔ¥®;LvYŒØZ7‚º’¤DŠWY&rë38s¹ÖÖìÜ›G„éХʼn³CœÃTÚ²:tæ’U ÉX¬Á9(‰]f•!«$´ȺÔ‚’–¢¶ZK.b¤Ñ.¨\T). œ¤Õ­RÖ«Y‡-‘4¬Q#ç+­º¶hR-³E E¤D²(C­k@–ª4áJbr¨¹@”´æ¥¢3Zq ›H‚ɨÍ;)š6Õ¹v]¤–‰2I™bè“¶Ú+4¹R%Â鉶, ¤Z°EšÕ­pí³SNä""2JTg :ÓPÄM¥Z¡˜¬CáY‚3ŒãÛ+kt›•™ÉÑœ8­5–¶»L,3HH³­›Âû´’Ž’âåk¨"Ëbð“°¡DX‹U­X¶nÆÄAK5D“†[Q2ÄCYGQUDäT_cp„«"å„P]9ÌV"´Ô0¶'@Ö§ªC‡Q !-ˆk»L´µ%K¶’K 75knµ l¥„dY˜S;Vе ‰œ²UOqVÕ¬·0ŽÄsQ®74ÜÖÎ8+KC7--Ñ—Ø[§%š5#D‘«$»¥¸I'³“nZË6ÎÚÊÜ9)-·[bæYµ²Óˆ‹m Ñd„…%i\".ueÁFÜœ Ó¢vë;Z›q¤’e¤qÆu-nÆÉ8›VœÐ‘2BUV)%et”¥˜¤ëeØ$œY[˜Ü¤7:G;ŽÑ›NÁmÛc:êÕ9¢ZÂO¬s 2ÄÅQ ´¸UÓ‚j(c_£ÝÔ)N€‡)KØâ0³š2ͺƠ­¸Ý;Z »¶´ë7Zœ¬Ä͈³@« 3k2¤(#FP“IR¶ÐºuZqd¨’É­Z•U!ÒŽRÒ8»r™­Z›h³[VÎÚ§[»J%DRBB¹p¢T‹Cg^ zDÒ³b‘A$W1k"Í’c"ª &ÐÍ¡'[$h¢F[*DL±*Ù*ÒÛ†L²mÄâu¹ ­µe‘ÚÑ3%Í&mŠK(J@’ ¸¨ „Xr iYÙBÔX Û-ÒŒ´í¶Pœ›‘¹Èê])gm!$Ù”‘BF°Œ“È´ QN„M%#›tYÛ9§hU§[,”a[mf£¬âæ56윶iŒÒÃhãKH”IC •`´Â’ Ê@¶Zj¤BÒæK 4¢ÍR3(Q– ,¬ç:­$48±ŠíR¢"áh…$Ü‹¬šAVÔ6tÙ°T¹I3 bBkM@”#Š-?ßݲ¯jVi4Üu¤gRÆØ­Ãµ«JÚÄdZk.³díÒáÂJ‹e†¢c95A8aޤVR)*Ô²:„i”¦Z-T¢ˆæÒL4³š - ™!šXFê"[iYYeÙg"­‘©H¦Fœ¢¹"¬êœ±4I åIf˜B‘j&Í«(ʵjЬN@ã“vì£ í:Í2’Ôèvš”\švpºlÐDÉXSÂ=Í™bÌêbg ¦­¢à•Ò 39…Ôe]¨Ûge¥–ÑÙÈæ!V–ak Î)‡ EK Ím-nv™:FÚm--´LÉ4„¥µ¶‡"Y*ĬJB2¹ª,Kê³ÓTP®,’Í—#¬¤‘c9UgDDÃ’.rB4ÌéÄÂLQ©#.Rd‘BÄéXv´æ V©Rm²#Z‹$.E aÜÛ‘Ì£±nÑX776ÔšÌBΧ,- 4Œ“ •FmT®‘%ˆpÊVÄRG8 R³4*TNVr3”QYŠˆIH’†(‹0Let‚µl,@ªSe4²YDI‰©‰Ë9j%66M¹Ù¬H,5»FMZ\í`‹i\¥bI”i%ÌÍ ÐÃPÈh-n)F–eYr‘¨Úp´À²¨‚9›j‚­¡Âêp.tYˆÉX…pá¦Ñ3–Ö6CQiÎ)Ó¦Zˆ¦Î™•›VօΑ2¢†,t¶kFŽU¥E’Ä¢ÕXˆˆ™L%3LœîpvtåÂŒ’.)ÄB(Ù,Çl´U¹E ¶:,ÊÜåvÖÖÖRK[%9¤%¬-«.Ò¬ìÓµe…ªT™§E"TŒ"êlÜv²Š¶ZjÚjW¡I‘&¤b[KJ«¦ Dí"ê VI*(bafh²Í 2²ÁZ  º¶îr”‚;»mn” ˆ„tÎZ`P]d¬[H²BÓQK9J+"D:&&¦:­m#[$éa"KQi$Ĩº‰,4„¢ŽN’ÂMmYÎËM¥l\ŬD”fK¢tÍg,¡ŽDb‡I9Z¨X¦˜Dd¡Y É|`0àÄut9dNÅÊD‰ÎˆMÜ%˜ÅÅ·‹-‰¬+#޳#TH®!!•±dв„,¶b'"¨è¤©ÍiET€¢K$PeÔ!eH!F‚›e‘¬Ö´Yq›2e‰Íj°ÉÒ‚K NbG6‰¡ÐULH9BZ¦!ÚX¦Ë$"AÛv³F@œ-5»v¸Îqi²°L+2“]šìæ)+IZ”¦F(L‹$ƒ«9‘†‡Sg ‰%EÓB±aÊ…f$GZ…©ÌQkY¡d :BOíœLR†–¡ÈƒâVî,KZªe•µV†‰ÚÉ Ì–¶¦k B) P…b¡aZ¡¶AdÕœ™F(Ó™"…–³Y¬[ Ò˶Ô9mdD"×5N1DÙb™Z¡Ñ²)BÎd–Ö´Qà‰Î{dçí•›šV±'#M± îЬ+’·(ínÐàº$­’‘ÐJŠLéœN")ŠaEY¤¦"ZªI‘vX„LÐæ­%2 ÄS"åâå‰v‘µˆÔT8X¬±¢ËgY;j-H‡vг¦âÃ’Ó- ­lºÓšvÚÚ tjÚ :D;²ŠËšÓ‚«K@í¬Ü:(g"ਲ਼B`Ú5±FH”Û» [¦¹Nœ³¦M W"Ëš²KZŽSkNYe´æHm fhcYaQ"ÄVIШ#19t„"%™&èYêÌŽð8ã¥fvb‰C ”ÊÑ`ckQ™JSe46¶á¥–Y›­»µ¬ËqI`·j9‰&f†–)µ‘E³¡ „ [ C’ApE¤h²©á+8w$š²LÎI9 ÐÔ£dÈ®@fÂZ"Q“²dy†aÓ ™’u’Ë$¢k2HQ)$ƒ†ÒÑY¤BJÈÚ‘r¥¬Z E Q‘+xcÉ“–Â9E'妠kBj¢l(í"T™Q ‡JD«¨‰Ð‘L±dÑ)ŠEĹ\Ž"dw†ìc®*­$áDAai˜v·`Ì”3Åö<Œµ—¢œ©ÊM¹²’&ÜwÒßʸ«KVZâã¯uŠA ¡™U²Ùh²–XáÁ½!–ôÒhšˆFs–dCZÓFs–þ±­M&¸i>ÉÝól1k®›wO¸ŒoøH‰"5¢;ïxï]gÉã¼^õsu•¦›N„18ç88)TóP(*ÒÂRgÍ&ïNÎs‡9Ãa)’'@Œ‘pBfÉ"*bC‰þ]ñ¾#Q¬„—t†ì~C¯Çbݳ¢-ÔÀÇ1Ìs½uz­^%8mC;eóù|Kø½¤·ÛÈzñÝÙé«ÜznË!ð½W–ìÉ#©DQÔa#bY"€Ôâ ˆµŠ­l¼Ò¸WÊñØ•òŒ¡~ãyšqåEEEEEEEBI$’I$’I$’I$’I$’I$’I$’I$’I$’I$•4QEQEP’I$’§7v(¼9Æ"II@ÅÆ/“™Åazûaá €¤œ‰8@¤Í eÄ…dŽ{ƒ-œØe¹½³ tZr2æ82Ó XLH^“’AX„"B`I@Å$‚%%"DcNRL`.f°‰‹rr‚ñÅÍlÜËr²Þå0ËgÅ9Œ·:Lª·+–:‰!9ôD$$•"£IHY‰"&Õ¤E¥±jE²%°2 "$Љ *H¢H¢HŒ‹Al%²É"ØZ-DµÑÔwqWÔEDwÝѵ$["E¤’Ô-’ BÒ€H# H€¬‹"*È ²"*H 2"È22$ŠŒ„-%©U¶"KQ-‘-@«º‹«¢ã¸îŠâ㢒-‰%©lHZlÀZØÊ°¦1—evØ]”´Z‘6±ýíûfC£Ij×ÜÔÅŒZ²³»»ÃIruÅBÇEUÙ6ø¾€7Ø`ZKH¶ d*…°‚Ù ‘ $VE$Ye$µ- E±!jÈIlDqÑGtGGuQÕÝuÇwJ©¬IhÄà,¥±ª,‚) Œ’# 2 ¡"¢GwtTuGuqwTuE×-I-"ÒÒZ‚ÙÈK@WGWtwGUÅÇ]uÝc(—`Êe]—`Ø\-’ÙhK`´‹b„TwGq×WqwGq]Ñݲ(,ˆ ’*²È$‚%¤µj%²BÒEYjjG\ÝG]qÕEÜ]GKb%¨KBØ dµ"[$KF\ ìl»c.À¢ã\a²!lH–Ái b­²BØ–¢E±’Ø–ÄÄ-D–È’ØKbª°–‹I d-$Œ$*P,'Ô%„|Å:»ÆW^ ÁÝÇqÇT\ÅÇqQP]ÇQÔ\GDr­‰>&É P‹BZ–’[%¢Z’¢ØBÔ Q P‹RºŠƒª¸êê:Ž8äîê¤d$DAYFE¨[i"ÒZ‚ØI-’Žº+ îè먻©:ê;¹R$µÔ%±‚Ò°E²E¤‹d¤¶BÔ‹QTIj%¢-‚["ªÒÒE²Báp» ¶Á²ãa€Sl·q\uÝTWwGEÑW¼;ºû×]xï·nî¼ é ¢ê:8â)"âáÎêK«¨ãQÓÚ±V¬‘}I¢&¬[N¾ ûjò4êoeéa{¤ð)‰üÿãøìÄ#«¡b"8>œ Ò0Í,8"ˆ«.îú…ldÍ$Åîé‚`AOÐ*Déä` EŽd€Êåï˜"@ « Ø, 3ÔéTÒ“rpÍW¹¤ÑÎM<Ãyq’ïÙj Ì‹j¤^ãâãbÆx|=‡Ԧ€ƒ»váÊf¢5ÌGG5Ü=Ôuz8F0grÛl¨ù² ^Éqÿ;Nï7'¼aĉűjФ*Ü%²ô´Í ó4èÇò<ºJ>ãª2ƒƒ)•FW_®mcà ˜pe¦2U›Öad|õ⬰®\“¡ÿÌD2’Bh×-U×]i„NHN vœ»Ñ<ÑØg -y’i¬šUUV‰¦³£DÓS‹M ¦²“#,é¦ 3“#,Ì™–tÊ4+Ma’aRªR¨Ã˜·q7W]×]mË| œ 6nÖ7Dµ€{Ì/=Š‹IpÒ™vÊ5Åk ™ÂNÆ a†s 0R'D0B\àÁƒ¬b‡\dæó÷•³Õ¹Ã•ñyÓì7ÒÔµjî^ ²W#†ƒ¦oUJ©JS—xƾê,f~%RáÃ6BÂ¥‰99H’×IÌZa…eŠÃi0¦*åÙòtAƒßü-’’ÒbŠk–Ëm²Õ(D‰!a!9!1(ÅØlåú\º\ò¹âÓM+r²ÎFÓ,`ꎀ¥RŠ¥S‡=ÌåÂã ÜãMSM~{,Q$˜DÄÃÉ“Œ@¾ñ‹ã0ϼÆS8^%ÁrËœª‘U[¿ÓœËnN4U]uÒ¢D‰rF&&ÅáÕŒæ'Ös 0yVh¬èÉyžûW-鬿eŠ NNi—ç#N 9çAw/ÛŒ-Z«N]Ã`cÄË-v¤©ˆ÷¾á¡m²×m–ܦ' xéÍÌ+L9·£¸µÒaÍeŒ¸«,¶UaŒžá)pØ*y¥¼å7×ôM¢6=ΆǸI‹cÈcIúžêÃŽ>|aLBzãôCbà{›³•’ê¤9µGȧ䯎¡¬¿wM8ö„$•zï"e+…^‹Y8k÷&¡_®„Vk<ÓkXþø˜µU¸ÆÙŽþ¥{Çc™‘ïe£[)àe|”wíœ-a0ºÁÊ&$Šx¬ׯ‡73¹æ@Öên6.µÁ#UÄè5ý~é ÉùçÏ.ÞÎU¨A¬½ßß’¦æÔcŸ*‰ƒ'–½7ñ€×ä„0Å]œ°.Oƒ3¨{èÉ_U/¦¡,…çc$sîmçÄç3\½®Æ~¦½ƒÏõÝÖŠQT§\¬ ©EU S 0R•*‡wQ•J¢©T·ÒeEJ*¢©*¢ª¨®·Êe–‡¶Îø<ÿåwºÍèu_Ïéáÿ×êóì/÷Øù-a¥FKÙ,€Gt¦Se!-ul—4C^2âdF€Ã(6bD"2Ë‘–ó‘–Ì2Ã{‘–Íì¹÷l´Þܬ·°Ó Ós&œ68°Á¹¹ÅÅÈà­ÍíŠÑ³fÊÓsC )²°Ó‘‡ÍŒ²lÞÃ,·›4•³s{ Î-˜p`ˆ<”˜”œ¤è]ü¿§¿‹oŒûæÿ~_¯þ«Eþ—ÓÛpßûž$©Oâw× QÔÝ·ÔŽŽ&%›ÿÀÐ&jPæ<·ßBHoL $Å\„HBßssLJb`-œ`ÓÑšöׄC-á«Ö‘Fíé©Ýœ„;ñá?#Œ6Ü'†6þ’›$›T3ÕѤ€æpDŒÑè87ô# mÉ× 9f¤\Eü÷%¯€cK¸¸„h¿c¡çÁ¼½*H˜ŒÊüÐRÇ]·P‚êÒвͷ§Y‚¢Î^užÚÞ´ƒÆŽùcøsY:ÓÖ¨XðŒVÊ¥ü'“u|E §\ïÁSBÐ&%4ìw²=8ªÿ šgwQ‡  ôê'›H€YëM?Iªã/#‰vRõ]rÔŠ³ÔÄxd¡CËkvñ) Û #include #include #include "R_init.h" void R_init_qtl(DllInfo* info) { R_registerRoutines(info, NULL, NULL, NULL, NULL); R_useDynamicSymbols(info, TRUE); } qtl/src/summary_scantwo.c0000644000176200001440000002260212770016226015245 0ustar liggesusers/********************************************************************** * * summary_scantwo.c * * copyright (c) 2006, Karl W Broman * * last modified Dec, 2006 * first written Oct, 2006 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These constitute a subroutine for getting the maximum LOD scores * for each pair of chromosomes in scantwo output. * * Contains: R_summary_scantwo, summary_scantwo * **********************************************************************/ #include #include #include #include #include #include #include #include "util.h" #include "summary_scantwo.h" /********************************************************************** * * R_summary_scantwo * * Wrapper for call from R * **********************************************************************/ void R_summary_scantwo(int *n_pos, int *n_phe, double *lod, int *n_chr, int *chr, double *pos, int *xchr, double *scanoneX, int *n_chrpair, int *chr1, int *chr2, int *chrpair, double *pos1_jnt, double *pos2_jnt, double *pos1_add, double *pos2_add, double *pos1_int, double *pos2_int, double *jnt_lod_full, double *jnt_lod_add, double *add_lod_full, double *add_lod_add, double *int_lod_full, double *int_lod_add, double *lod_1qtl) { double ***Lod, **ScanoneX; double **Pos1_jnt, **Pos2_jnt; double **Pos1_add, **Pos2_add; double **Pos1_int, **Pos2_int; double **JNT_lod_full, **JNT_lod_add; double **ADD_lod_full, **ADD_lod_add; double **INT_lod_full, **INT_lod_add; double **LOD_1qtl; int i, j, k, **Chrpair; *n_chrpair = *n_chr*(*n_chr+1)/2; /* re-organize matrices */ reorg_genoprob(*n_pos, *n_pos, *n_phe, lod, &Lod); reorg_errlod(*n_chrpair, *n_phe, pos1_jnt, &Pos1_jnt); reorg_errlod(*n_chrpair, *n_phe, pos2_jnt, &Pos2_jnt); reorg_errlod(*n_chrpair, *n_phe, pos1_add, &Pos1_add); reorg_errlod(*n_chrpair, *n_phe, pos2_add, &Pos2_add); reorg_errlod(*n_chrpair, *n_phe, pos1_int, &Pos1_int); reorg_errlod(*n_chrpair, *n_phe, pos2_int, &Pos2_int); reorg_errlod(*n_chrpair, *n_phe, jnt_lod_full, &JNT_lod_full); reorg_errlod(*n_chrpair, *n_phe, jnt_lod_add, &JNT_lod_add); reorg_errlod(*n_chrpair, *n_phe, add_lod_full, &ADD_lod_full); reorg_errlod(*n_chrpair, *n_phe, add_lod_add, &ADD_lod_add); reorg_errlod(*n_chrpair, *n_phe, int_lod_full, &INT_lod_full); reorg_errlod(*n_chrpair, *n_phe, int_lod_add, &INT_lod_add); reorg_errlod(*n_chrpair, *n_phe, lod_1qtl, &LOD_1qtl); reorg_errlod(*n_pos, *n_phe, scanoneX, &ScanoneX); reorg_geno(*n_chr, *n_chr, chrpair, &Chrpair); for(i=0, k=0; i<*n_chr; i++) { for(j=i; j<*n_chr; j++, k++) { chr1[k] = i; chr2[k] = j; Chrpair[j][i] = Chrpair[i][j] = k; } } summary_scantwo(*n_pos, *n_phe, Lod, *n_chr, chr, pos, xchr, ScanoneX, *n_chrpair, Chrpair, Pos1_jnt, Pos2_jnt, Pos1_add, Pos2_add, Pos1_int, Pos2_int, JNT_lod_full, JNT_lod_add, ADD_lod_full, ADD_lod_add, INT_lod_full, INT_lod_add, LOD_1qtl); } /********************************************************************** * * summary_scantwo * * Function to pull out the major bits from scantwo output * * n_pos: Total number of positions * n_phe: Number of phenotype columns * Lod: Array of LOD scores indexed as [phe][pos2][pos1] * diagonal = scanone results; upper.tri = add've LOD; lower = full * n_chr Number of distinct chromosomes * chr Index of chromosomes; length n_pos, taking values in 1..n_chr * pos cM positions; length n_pos * xchr Index of xchr; length n_chr; 0=autosome, 1=X chromosome * ScanoneX special X scanone; matrix indexed as [phe][pos] * * n_chrpair Number of pairs of chromosomes * Chrpair Matrix giving chrpair index for a pair of chromosomes * Pos1_jnt, Pos2_jnt On output, positions of maximum joint LOD * Matrices indexed as [phe][chrpair] * Pos1_add, Pos2_add On output, positions of maximum add've LOD * Matrices indexed as [phe][chrpair] * Pos1_int, Pos2_int On output, positions of maximum int've LOD * Matrices indexed as [phe][chrpair] * JNT_lod_* On output, joint and add've LOD at pos'ns with * maximum joint LOD; matrices indexed as [phe][chrpair] * ADD_lod_* On output, joint and add've LOD at pos'ns with * maximum add've LOD; matrices indexed as [phe][chrpair] * INT_lod_* On output, joint and add've LOD at pos'ns with * maximum int've LOD; matrices indexed as [phe][chrpair] * LOD_1qtl On output, maximum 1-QTL LOD for each pair of chr * (selected from either scanone or scanoneX * **********************************************************************/ void summary_scantwo(int n_pos, int n_phe, double ***Lod, int n_chr, int *chr, double *pos, int *xchr, double **ScanoneX, int n_chrpair, int **Chrpair, double **Pos1_jnt, double **Pos2_jnt, double **Pos1_add, double **Pos2_add, double **Pos1_int, double **Pos2_int, double **JNT_lod_full, double **JNT_lod_add, double **ADD_lod_full, double **ADD_lod_add, double **INT_lod_full, double **INT_lod_add, double **LOD_1qtl) { int i, j, k, c1, c2, thepair; double *maxone, *maxoneX; allocate_double(n_chr, &maxone); allocate_double(n_chr, &maxoneX); for(i=0; i maxone[chr[j]-1]) maxone[chr[j]-1] = Lod[i][j][j]; if(ScanoneX[i][j] > maxoneX[chr[j]-1]) maxoneX[chr[j]-1] = ScanoneX[i][j]; } /* zero out the matrices for the maximum LOD scores */ for(j=0; j JNT_lod_full[i][thepair]) { JNT_lod_full[i][thepair] = Lod[i][j][k]; JNT_lod_add[i][thepair] = Lod[i][k][j]; Pos1_jnt[i][thepair] = pos[j]; Pos2_jnt[i][thepair] = pos[k]; } if(Lod[i][k][j] > ADD_lod_add[i][thepair]) { ADD_lod_add[i][thepair] = Lod[i][k][j]; ADD_lod_full[i][thepair] = Lod[i][j][k]; Pos1_add[i][thepair] = pos[j]; Pos2_add[i][thepair] = pos[k]; } if(Lod[i][j][k] - Lod[i][k][j] > INT_lod_full[i][thepair] - INT_lod_add[i][thepair]) { INT_lod_full[i][thepair] = Lod[i][j][k]; INT_lod_add[i][thepair] = Lod[i][k][j]; Pos1_int[i][thepair] = pos[j]; Pos2_int[i][thepair] = pos[k]; } } } /* pull out biggest single-QTL LOD scores */ for(j=0; j maxoneX[k]) LOD_1qtl[i][thepair] = maxoneX[j]; else LOD_1qtl[i][thepair] = maxoneX[k]; } else { if(maxone[j] > maxone[k]) LOD_1qtl[i][thepair] = maxone[j]; else LOD_1qtl[i][thepair] = maxone[k]; } } } } /* end loop over phenotype columns */ } /* end of summary_scantwo.c */ qtl/src/info.h0000644000176200001440000000367212770016226012760 0ustar liggesusers/********************************************************************** * * info.h * * copyright (c) 2001, Karl W Broman * * last modified Oct, 2001 * first written Oct, 2001 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * This function is for calculating the information contained in the * genotype data on a particular chromosome * * Contains: R_info * **********************************************************************/ /********************************************************************** * * R_info: calculates information contained in the genotype data for * a particular chromosome. * * * n_ind Number of individuals * * n_pos Number of marker positions * * n_gen Number of different genotypes * * genoprob Conditional genotype probabilities * * info1 Vector of length n_pos, to contain the output * (using the entropy version of the information) * * info2 Same as info1 (for the prop'n variance version * of the information) * * which 0 = only entropy version * 1 = only variance version * 2 = both * **********************************************************************/ void R_info(int *n_ind, int *n_pos, int *n_gen, double *genoprob, double *info1, double *info2, int *which); /* end of info.h */ qtl/src/hmm_bcsft.h0000644000176200001440000000652012770016226013762 0ustar liggesusers/********************************************************************** * * hmm_bcsft.h * * copyright (c) 2001-7, Karl W Broman 2011 modified by Brian S Yandell and Laura M Shannon * * last modified Mar, 2011 BSY, LMS * last modified Oct, 2007 * first written Feb, 2001 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: init_bcsft,step_bcsft, init_bcsftb, step_bcsftb, * calc_genoprob_bcsft, calc_genoprob_special_bcsft, sim_geno_bcsft, est_map_bcsft, * argmax_geno_bcsft, errorlod_bcsft, nrec2_bcsft, * logprec_bcsft, est_rf_bcsft, calc_pairprob_bcsft, marker_loglik_bcsft * * These are the init, emit, and step functions plus * all of the hmm wrappers for the BCSFT intercross. * * Genotype codes: 0=AA; 1=AB; 2=BB * Phenotype codes: 0=missing; 1=AA; 2=AB; 3=BB; 4=not BB; 5=not AA * **********************************************************************/ double init_bcsft(int true_gen, int *cross_scheme); double emit_bcsft(int obs_gen, int true_gen, double error_prob, int *cross_scheme); double step_bcsft(int gen1, int gen2, double rf, double junk, int *cross_scheme); double init_bcsftb(int true_gen, int *cross_scheme); double emit_bcsftb(int obs_gen, int true_gen, double error_prob, int *cross_scheme); double step_bcsftb(int gen1, int gen2, double rf, double junk, int *cross_scheme); double nrec_bcsftb(int gen1, int gen2, double rf, int *cross_scheme); void calc_genoprob_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob); void calc_genoprob_special_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob); void sim_geno_bcsft(int *n_ind, int *n_pos, int *n_draws, int *geno, double *rf, double *error_prob, int *draws); void est_map_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *loglik, int *maxit, double *tol, int *verbose); void argmax_geno_bcsft(int *n_ind, int *n_pos, int *geno, double *rf, double *error_prob, int *argmax); double errorlod_bcsft(int obs, double *prob, double error_prob); double nrec2_bcsft(int obs1, int obs2, double rf, int *cross_scheme); double logprec_bcsft(int obs1, int obs2, double rf, int *cross_scheme); void est_rf_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, int *maxit, double *tol); void calc_pairprob_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob, double *pairprob); void marker_loglik_bcsft(int *n_ind, int *geno, double *error_prob, double *loglik); /* end of hmm_bcsft.h */ qtl/src/fill_geno_nodblXO.h0000644000176200001440000000223412770016226015401 0ustar liggesusers/********************************************************************** * * fill_geno_nodblXO.h * * copyright (c) 2010, Karl W Broman * * last modified May, 2010 * first written May, 2010 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * This function fills in missing genotype data only between markers with * exactly the same genotype. * **********************************************************************/ void R_fill_geno_nodblXO(int *n_ind, int *n_mar, int *geno); void fill_geno_nodblXO(int n_ind, int n_mar, int **Geno); /* end of fill_geno_nodblXO.h */ qtl/src/scanone_hk_binary.c0000644000176200001440000002022314123705310015454 0ustar liggesusers/********************************************************************** * * scanone_hk_binary.c * * copyright (c) 2010-2014, Karl W Broman * * last modified Mar, 2014 * first written Jun, 2010 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These functions are for performing a genome scan with a * single QTL model by Haley-Knott regression * * Contains: R_scanone_hk_binary, scanone_hk_binary * **********************************************************************/ #include #include #include #include #include #include #include #include #include "util.h" #include "scanone_hk_binary.h" #define TOL 1e-12 /********************************************************************** * * R_scanone_hk_binary * * Wrapper for call from R; reorganizes genotype prob and result matrix * and calls scanone_hk. * **********************************************************************/ void R_scanone_hk_binary(int *n_ind, int *n_pos, int *n_gen, double *genoprob, double *addcov, int *n_addcov, double *intcov, int *n_intcov, double *pheno, double *result, double *tol, int *maxit, int *verbose, int *ind_noqtl) { double ***Genoprob, **Addcov=0, **Intcov=0; reorg_genoprob(*n_ind, *n_pos, *n_gen, genoprob, &Genoprob); /* reorganize addcov and intcov (if they are not empty) */ if(*n_addcov > 0) reorg_errlod(*n_ind, *n_addcov, addcov, &Addcov); if(*n_intcov > 0) reorg_errlod(*n_ind, *n_intcov, intcov, &Intcov); scanone_hk_binary(*n_ind, *n_pos, *n_gen, Genoprob, Addcov, *n_addcov, Intcov, *n_intcov, pheno, result, *tol, *maxit, *verbose, ind_noqtl); } /********************************************************************** * * scanone_hk_binary * * Performs genome scan using the Haley-Knott regression method * for a binary trait * * n_ind Number of individuals * * n_pos Number of marker positions * * n_gen Number of different genotypes * * Genoprob Array of conditional genotype probabilities * Indexed as Genoprob[gen][pos][ind] * * Addcov Matrix of additive covariates: Addcov[cov][ind] * * n_addcov Number of columns of Addcov * * Intcov Number of interactive covariates: Intcov[cov][ind] * * n_intcov Number of columns of Intcov * * pheno Phenotype data, as a vector * * result vector of length n_ind, to contain the log10 likelihood values * * tol tolerance for convergence * * maxit maximum number of iterations * * verbose if TRUE, give some output * * ind_noqtl Indicators (0/1) of which individuals should be excluded * from QTL effects. * **********************************************************************/ void scanone_hk_binary(int n_ind, int n_pos, int n_gen, double ***Genoprob, double **Addcov, int n_addcov, double **Intcov, int n_intcov, double *pheno, double *result, double tol, int maxit, int verbose, int *ind_noqtl) { int i, j, k, k2, kk, s, ncolx, thepos, flag, ny, *jpvt; double *dwork, *x, *x_bk, *coef, *resid, *qty, *qraux, *ests; double *z, *nu, *wt, *pi, tol2; double curllik, llik=0.0; ncolx = n_gen + (n_gen-1)*n_intcov+n_addcov; tol2 = TOL; ny = 1; /* allocate space and set things up*/ /* lengths: 2*ncolx: dwork n_ind*ncolx: x, x_bk ncolx: coef, qraux, ests n_ind: resid, qty, z, nu, wt, pi */ dwork = (double *)R_alloc(2*n_ind*ncolx + ncolx*5 + n_ind*6, sizeof(double)); x = dwork + 2*ncolx; x_bk = x + n_ind*ncolx; coef = x_bk + n_ind*ncolx; resid = coef + ncolx; qty = resid + n_ind; qraux = qty + n_ind; z = qraux + ncolx; nu = z + n_ind; wt = nu + n_ind; pi = wt + n_ind; ests = pi + n_ind; /* length ncolx */ jpvt = (int *)R_alloc(ncolx, sizeof(int)); for(thepos=0; thepos1) Rprintf("\t%-5d %-5d %-10.5lf\n", thepos+1, 0, curllik); /* multiply design matrix by current wts */ for(i=0; i1) { for(i=0; i2) Rprintf("\t\t%-4d %1lf %-7.5lf\n", j, pheno[j], pi[j]); /* multiply design matrix by new weights */ for(i=0; i1) Rprintf("\t%-5d %-5d %-10.5lf\n", thepos+1, s+1, llik); if(fabs(llik - curllik) < tol) { /* converged? */ flag = 1; break; } curllik = llik; } /* end of IRLS iterations */ if(!flag) warning("Didn't converge."); result[thepos] = llik; if(verbose) Rprintf("%-5d final %-10.5lf\n", thepos+1, llik); } /* end loop over positions */ } /* end of scanone_hk_binary.c */ qtl/src/findDupMarkers_notexact.c0000644000176200001440000000545612770016226016645 0ustar liggesusers/********************************************************************** * * findDupMarkers_notexact.c * * copyright (c) 2009-2010, Karl W Broman * * last modified Apr, 2010 * first written Jun, 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * This function is for identifying duplicate markers * where the observed genotypes for one marker match those of another marker, * with no observed genotypes for which the other is missing * * Contains: R_findDupMarkers_notexact, findDupMarkers_notexact * **********************************************************************/ #include #include #include #include #include #include #include #include #include "util.h" #include "findDupMarkers_notexact.h" void R_findDupMarkers_notexact(int *nind, int *nmar, int *geno, int *order, int *markerloc, int *adjacent_only, int *result) { int **Geno; reorg_geno(*nind, *nmar, geno, &Geno); findDupMarkers_notexact(*nind, *nmar, Geno, order, markerloc, *adjacent_only, result); } void findDupMarkers_notexact(int nind, int nmar, int **Geno, int *order, int *markerloc, int adjacent_only, int *result) { int i, j, oi, oj, k, flag; for(i=0; i 1)) { /* skip */ } else { flag = 0; for(k=0; k #include #include #include #include #include #include "util.h" #include "hmm_main.h" #include "hmm_bc.h" double init_bc(int true_gen, int *cross_scheme) { return(-M_LN2); /* ln(0.5) */ } double emit_bc(int obs_gen, int true_gen, double error_prob, int *cross_scheme) { switch(obs_gen) { case 0: return(0.0); case 1: case 2: if(obs_gen==true_gen) return(log(1.0-error_prob)); else return(log(error_prob)); } return(0.0); /* shouldn't get here */ } double step_bc(int gen1, int gen2, double rf, double junk, int *cross_scheme) { if(gen1==gen2) return(log(1.0-rf)); else return(log(rf)); return(log(-1.0)); /* shouldn't get here */ } double nrec_bc(int gen1, int gen2, double rf, int *cross_scheme) { if(gen1==gen2) return(0.0); else return(1.0); } void calc_genoprob_bc(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { calc_genoprob(*n_ind, *n_mar, 2, geno, rf, rf, *error_prob, genoprob, init_bc, emit_bc, step_bc); } void calc_genoprob_special_bc(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { calc_genoprob_special(*n_ind, *n_mar, 2, geno, rf, rf, *error_prob, genoprob, init_bc, emit_bc, step_bc); } void sim_geno_bc(int *n_ind, int *n_pos, int *n_draws, int *geno, double *rf, double *error_prob, int *draws) { sim_geno(*n_ind, *n_pos, 2, *n_draws, geno, rf, rf, *error_prob, draws, init_bc, emit_bc, step_bc); } void est_map_bc(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *loglik, int *maxit, double *tol, int *verbose) { est_map(*n_ind, *n_mar, 2, geno, rf, rf, *error_prob, init_bc, emit_bc, step_bc, nrec_bc, nrec_bc, loglik, *maxit, *tol, 0, *verbose); } void argmax_geno_bc(int *n_ind, int *n_pos, int *geno, double *rf, double *error_prob, int *argmax) { argmax_geno(*n_ind, *n_pos, 2, geno, rf, rf, *error_prob, argmax, init_bc, emit_bc, step_bc); } double errorlod_bc(int obs, double *prob, double error_prob) { double p=0.0; switch(obs) { case 0: return(0.0); case 1: p=prob[0]; break; case 2: p=prob[1]; break; } p = (1.0-p)/p*(1.0-error_prob)/error_prob; if(p < TOL) return(-12.0); else return(log10(p)); } void calc_errorlod_bc(int *n_ind, int *n_mar, int *geno, double *error_prob, double *genoprob, double *errlod) { calc_errorlod(*n_ind, *n_mar, 2, geno, *error_prob, genoprob, errlod, errorlod_bc); } void est_rf_bc(int *n_ind, int *n_mar, int *geno, double *rf) { int i, j1, j2, **Geno, a, b; double **Rf; /* reorganize geno and rf */ reorg_geno(*n_ind, *n_mar, geno, &Geno); reorg_errlod(*n_mar, *n_mar, rf, &Rf); for(j1=0; j1< *n_mar; j1++) { /* count meioses */ a = 0; for(i=0; i < *n_ind; i++) { if(Geno[j1][i] != 0) a++; } Rf[j1][j1] = (double) a; for(j2=j1+1; j2< *n_mar; j2++) { a=b=0; for(i=0; i< *n_ind; i++) { if(Geno[j1][i] != 0 && Geno[j2][i] != 0) { a++; if(Geno[j1][i] != Geno[j2][i]) b++; } } if(a != 0) { /* at least one informative meiosis */ /* if(b > a/2) b = a/2; */ Rf[j1][j2] = (double)b/(double)a; if(b==0) /* no recombinations */ Rf[j2][j1] = (double)a*log10(1.0-Rf[j1][j2]); else Rf[j2][j1] = (double)b*log10(Rf[j1][j2]) + (double)(a-b)*log10(1.0-Rf[j1][j2]); Rf[j2][j1] += (double)a*log10(2.0); } else { Rf[j1][j2] = NA_REAL; Rf[j2][j1] = 0.0; } } /* end loops over markers */ } } void calc_pairprob_bc(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob, double *pairprob) { calc_pairprob(*n_ind, *n_mar, 2, geno, rf, rf, *error_prob, genoprob, pairprob, init_bc, emit_bc, step_bc); } void marker_loglik_bc(int *n_ind, int *geno, double *error_prob, double *loglik) { marker_loglik(*n_ind, 2, geno, *error_prob, init_bc, emit_bc, loglik); } /* end of hmm_bc.c */ qtl/src/hmm_4way.c0000644000176200001440000004550712770016226013550 0ustar liggesusers/********************************************************************** * * hmm_4way.c * * copyright (c) 2001-2010, Karl W Broman * * last modified Jul, 2010 * first written Feb, 2001 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: init_4way, emit_4way, step_4way, nrec_4way, nrec_4way1, * nrec_4way2, calc_genoprob_4way, calc_genoprob_special_4way, sim_geno_4way, * est_map_4way, argmax_geno_4way, errorlod_4way, * calc_errorlod_4way, nrec2_4way, logprec_4way, est_rf_4way * calc_pairprob_4way, marker_loglik_4way * * These are the init, emit, and step functions plus * all of the hmm wrappers for the "4-way" cross (autosomal data) * * Genotype codes: 0=AC, 1=AD, 2=BC, 3=BD * Phenotype codes: 0=missing, 1=AC, 2=BC, 3=AD, 4=BD, * 5=(AC/AD=A), 6=(BC/BD=B),7=(AC/BC=C),8=(AD/BD=D) * 9=(AC/BD), 10=(AD/BC) * **********************************************************************/ #include #include #include #include #include #include #include "hmm_main.h" double init_4way(int true_gen, int *cross_scheme) { return(-2.0*M_LN2); } double emit_4way(int obs_gen, int true_gen, double error_prob, int *cross_scheme) { switch(obs_gen) { case 0: return(0.0); case 1: switch(true_gen) { case 1: return(log(1.0-error_prob)); case 2: case 3: case 4: return(log(error_prob/3.0)); } case 2: switch(true_gen) { case 2: return(log(1.0-error_prob)); case 1: case 3: case 4: return(log(error_prob/3.0)); } case 3: switch(true_gen) { case 3: return(log(1.0-error_prob)); case 1: case 2: case 4: return(log(error_prob/3.0)); } case 4: switch(true_gen) { case 4: return(log(1.0-error_prob)); case 1: case 2: case 3: return(log(error_prob/3.0)); } case 5: switch(true_gen) { case 1: case 3: return(log(1.0-2.0*error_prob/3.0)); case 2: case 4: return(log(2.0*error_prob/3.0)); } case 6: switch(true_gen) { case 2: case 4: return(log(1.0-2.0*error_prob/3.0)); case 1: case 3: return(log(2.0*error_prob/3.0)); } case 7: switch(true_gen) { case 1: case 2: return(log(1.0-2.0*error_prob/3.0)); case 3: case 4: return(log(2.0*error_prob/3.0)); } case 8: switch(true_gen) { case 3: case 4: return(log(1.0-2.0*error_prob/3.0)); case 1: case 2: return(log(2.0*error_prob/3.0)); } case 9: switch(true_gen) { case 1: case 4: return(log(1.0-2.0*error_prob/3.0)); case 2: case 3: return(log(2.0*error_prob/3.0)); } case 10: switch(true_gen) { case 2: case 3: return(log(1.0-2.0*error_prob/3.0)); case 1: case 4: return(log(2.0*error_prob/3.0)); } case 11: switch(true_gen) { case 1: return(log(error_prob)); case 2: case 3: case 4: return(log(1.0-error_prob/3.0)); } case 12: switch(true_gen) { case 2: return(log(error_prob)); case 1: case 3: case 4: return(log(1.0-error_prob/3.0)); } case 13: switch(true_gen) { case 3: return(log(error_prob)); case 1: case 2: case 4: return(log(1.0-error_prob/3.0)); } case 14: switch(true_gen) { case 4: return(log(error_prob)); case 1: case 2: case 3: return(log(1.0-error_prob/3.0)); } } return(0.0); /* shouldn't get here */ } double step_4way(int gen1, int gen2, double rf1, double rf2, int *cross_scheme) { switch(gen1) { case 1: switch(gen2) { case 1: return(log(1.0-rf1)+log(1.0-rf2)); case 2: return(log(rf1)+log(1.0-rf2)); case 3: return(log(1.0-rf1)+log(rf2)); case 4: return(log(rf1)+log(rf2)); } case 2: switch(gen2) { case 1: return(log(rf1)+log(1.0-rf2)); case 2: return(log(1.0-rf1)+log(1.0-rf2)); case 3: return(log(rf1)+log(rf2)); case 4: return(log(1.0-rf1)+log(rf2)); } case 3: switch(gen2) { case 1: return(log(1.0-rf1)+log(rf2)); case 2: return(log(rf1)+log(rf2)); case 3: return(log(1.0-rf1)+log(1.0-rf2)); case 4: return(log(rf1)+log(1.0-rf2)); } case 4: switch(gen2) { case 1: return(log(rf1)+log(rf2)); case 2: return(log(1.0-rf1)+log(rf2)); case 3: return(log(rf1)+log(1.0-rf2)); case 4: return(log(1.0-rf1)+log(1.0-rf2)); } } return(log(-1.0)); /* shouldn't get here */ } double nrec_4way(int gen1, int gen2, double rf, int *cross_scheme) { switch(gen1) { case 1: switch(gen2) { case 1: return(0.0); case 2: case 3: return(0.5); case 4: return(1.0); } case 2: switch(gen2) { case 1: case 4: return(0.5); case 2: return(0.0); case 3: return(1.0); } case 3: switch(gen2) { case 1: case 4: return(0.5); case 3: return(0.0); case 2: return(1.0); } case 4: switch(gen2) { case 2: case 3: return(0.5); case 4: return(0.0); case 1: return(1.0); } } return(log(-1.0)); /* shouldn't get here */ } double nrec_4way1(int gen1, int gen2, double rf, int *cross_scheme) { switch(gen1) { case 1: case 3: switch(gen2) { case 1: case 3: return(0.0); case 2: case 4: return(1.0); } case 2: case 4: switch(gen2) { case 1: case 3: return(1.0); case 2: case 4: return(0.0); } } return(log(-1.0)); /* shouldn't get here */ } double nrec_4way2(int gen1, int gen2, double rf, int *cross_scheme) { switch(gen1) { case 1: case 2: switch(gen2) { case 1: case 2: return(0.0); case 3: case 4: return(1.0); } case 3: case 4: switch(gen2) { case 1: case 2: return(1.0); case 3: case 4: return(0.0); } } return(log(-1.0)); /* shouldn't get here */ } void calc_genoprob_4way(int *n_ind, int *n_mar, int *geno, double *rf1, double *rf2, double *error_prob, double *genoprob) { calc_genoprob(*n_ind, *n_mar, 4, geno, rf1, rf2, *error_prob, genoprob, init_4way, emit_4way, step_4way); } void calc_genoprob_special_4way(int *n_ind, int *n_mar, int *geno, double *rf1, double *rf2, double *error_prob, double *genoprob) { calc_genoprob_special(*n_ind, *n_mar, 4, geno, rf1, rf2, *error_prob, genoprob, init_4way, emit_4way, step_4way); } void sim_geno_4way(int *n_ind, int *n_pos, int *n_draws, int *geno, double *rf1, double *rf2, double *error_prob, int *draws) { sim_geno(*n_ind, *n_pos, 4, *n_draws, geno, rf1, rf2, *error_prob, draws, init_4way, emit_4way, step_4way); } void est_map_4way(int *n_ind, int *n_mar, int *geno, double *rf1, double *rf2, double *error_prob, double *loglik, int *maxit, double *tol, int *sexsp, int *verbose) { if(*sexsp) est_map(*n_ind, *n_mar, 4, geno, rf1, rf2, *error_prob, init_4way, emit_4way, step_4way, nrec_4way1, nrec_4way2, loglik, *maxit, *tol, *sexsp, *verbose); else est_map(*n_ind, *n_mar, 4, geno, rf1, rf2, *error_prob, init_4way, emit_4way, step_4way, nrec_4way, nrec_4way, loglik, *maxit, *tol, *sexsp, *verbose); } void argmax_geno_4way(int *n_ind, int *n_pos, int *geno, double *rf1, double *rf2, double *error_prob, int *argmax) { argmax_geno(*n_ind, *n_pos, 4, geno, rf1, rf2, *error_prob, argmax, init_4way, emit_4way, step_4way); } double errorlod_4way(int obs, double *prob, double error_prob) { double p=0.0; switch(obs) { case 0: return(0.0); case 1: case 2: case 3: case 4: p=prob[obs-1]; break; case 5: p=(prob[0]+prob[2]); break; case 6: p=(prob[1]+prob[3]); break; case 7: p=(prob[0]+prob[1]); break; case 8: p=(prob[2]+prob[3]); break; case 9: p=(prob[0]+prob[3]); break; case 10: p=(prob[1]+prob[2]); break; case 11: p=1.0-prob[0]; break; case 12: p=1.0-prob[1]; break; case 13: p=1.0-prob[2]; break; case 14: p=1.0-prob[3]; break; } p = (1.0-p)/p; if(obs>10) p *= (1.0-error_prob/3.0)/error_prob; else if(obs>4 && obs<11) p *= (1.0-2.0*error_prob/3.0)/(2.0*error_prob/3.0); else p *= (1.0-error_prob)/error_prob; if(p < TOL) return(-12.0); else return(log10(p)); } void calc_errorlod_4way(int *n_ind, int *n_mar, int *geno, double *error_prob, double *genoprob, double *errlod) { calc_errorlod(*n_ind, *n_mar, 4, geno, *error_prob, genoprob, errlod, errorlod_4way); } double nrec2_4way(int obs1, int obs2, double rf, int *cross_scheme) { int temp; /* make obs1 <= obs2 */ if(obs1 > obs2) { temp = obs2; obs2 = obs1; obs1 = temp; } switch(obs1) { case 1: switch(obs2) { case 1: return(0.0); case 2: case 3: return(1.0); case 4: return(2.0); case 5: case 7: return(rf); case 6: case 8: return(1.0+rf); case 9: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 10: return(1.0); case 11: return(2.0*rf/(1.0-(1.0-rf)*(1.0-rf))); case 12: case 13: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); case 14: return(2.0*rf*(1.0-rf)/(1.0-rf*rf)); } case 2: switch(obs2) { case 2: return(0.0); case 3: return(2.0); case 4: return(1.0); case 5: case 8: return(1.0+rf); case 6: case 7: return(rf); case 9: return(1.0); case 10: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 12: return(2.0*rf/(1.0-(1.0-rf)*(1.0-rf))); case 11: case 14: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); case 13: return(2.0*rf*(1.0-rf)/(1.0-rf*rf)); } case 3: switch(obs2) { case 3: return(0.0); case 4: return(1.0); case 5: case 8: return(rf); case 6: case 7: return(1.0+rf); case 9: return(1.0); case 10: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 13: return(2.0*rf/(1.0-(1.0-rf)*(1.0-rf))); case 11: case 14: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); case 12: return(2.0*rf*(1.0-rf)/(1.0-rf*rf)); } case 4: switch(obs2) { case 4: return(0.0); case 5: case 7: return(1.0+rf); case 6: case 8: return(rf); case 9: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 10: return(1.0); case 14: return(2.0*rf/(1.0-(1.0-rf)*(1.0-rf))); case 12: case 13: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); case 11: return(2.0*rf*(1.0-rf)/(1.0-rf*rf)); } case 5: switch(obs2) { case 5: return(rf); case 6: return(1.0+rf); case 7: case 8: case 9: case 10: return(2.0*rf); case 11: case 13: return(rf*(3.0+rf)/(1.0+rf)); case 12: case 14: return(rf*(3.0-rf)/(2.0-rf)); } case 6: switch(obs2) { case 6: return(rf); case 7: case 8: case 9: case 10: return(2.0*rf); case 12: case 14: return(rf*(3.0+rf)/(1.0+rf)); case 11: case 13: return(rf*(3.0-rf)/(2.0-rf)); } case 7: switch(obs2) { case 7: return(rf); case 8: return(1.0+rf); case 9: case 10: return(2.0*rf); case 11: case 12: return(rf*(3.0+rf)/(1.0+rf)); case 13: case 14: return(rf*(3.0-rf)/(2.0-rf)); } case 8: switch(obs2) { case 8: return(rf); case 9: case 10: return(2.0*rf); case 13: case 14: return(rf*(3.0+rf)/(1.0+rf)); case 11: case 12: return(rf*(3.0-rf)/(2.0-rf)); } case 9: switch(obs2) { case 9: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 10: return(1.0); case 11: case 14: return(2.0*rf*(2.0-rf)/(2.0-(1.0-rf)*(1.0-rf)-rf*rf)); case 12: case 13: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); } case 10: switch(obs2) { case 10: return(2.0*rf*rf/(rf*rf+(1.0-rf)*(1.0-rf))); case 12: case 13: return(2.0*rf*(2.0-rf)/(2.0-(1.0-rf)*(1.0-rf)-rf*rf)); case 11: case 14: return(rf*(1.0+rf)/(1.0-rf*(1.0-rf))); } case 11: switch(obs2) { case 11: return(4.0*rf/(2.0+(1.0-rf)*(1.0-rf))); case 12: case 13: return(rf*(5.0-rf)/(2.0+rf*(1.0-rf))); case 14: return(2.0*rf*(2.0+rf)/(2.0+rf*rf)); } case 12: switch(obs2) { case 12: return(4.0*rf/(2.0+(1.0-rf)*(1.0-rf))); case 14: return(rf*(5.0-rf)/(2.0+rf*(1.0-rf))); case 13: return(2.0*rf*(2.0+rf)/(2.0+rf*rf)); } case 13: switch(obs2) { case 13: return(4.0*rf/(2.0+(1.0-rf)*(1.0-rf))); case 14: return(rf*(5.0-rf)/(2.0+rf*(1.0-rf))); } case 14: switch(obs2) { case 14: return(4.0*rf/(2.0+(1.0-rf)*(1.0-rf))); } } return(log(-1.0)); /* shouldn't get here */ } double logprec_4way(int obs1, int obs2, double rf, int *cross_scheme) { int temp; /* make obs1 <= obs2 */ if(obs1 > obs2) { temp = obs2; obs2 = obs1; obs1 = temp; } switch(obs1) { case 1: switch(obs2) { case 1: return(2.0*log(1.0-rf)); case 2: case 3: return(log(rf)+log(1.0-rf)); case 4: return(2.0*log(rf)); case 5: case 7: return(log(1.0-rf)); case 6: case 8: return(log(rf)); case 9: return(log(rf*rf+(1.0-rf)*(1.0-rf))); case 10: return(log(2.0)+log(rf)+log(1.0-rf)); case 11: return(log(1.0-(1.0-rf)*(1.0-rf))); case 12: case 13: return(log(1.0 - rf*(1.0-rf))); case 14: return(log(1.0-rf*rf)); } case 2: switch(obs2) { case 2: return(2.0*log(1.0-rf)); case 3: return(2.0*log(rf)); case 4: return(log(rf)+log(1.0-rf)); case 5: case 8: return(log(rf)); case 6: case 7: return(log(1.0-rf)); case 9: return(log(2.0)+log(rf)+log(1.0-rf)); case 10: return(log(rf*rf+(1.0-rf)*(1.0-rf))); case 12: return(log(1.0-(1.0-rf)*(1.0-rf))); case 11: case 14: return(log(1.0 - rf*(1.0-rf))); case 13: return(log(1.0-rf*rf)); } case 3: switch(obs2) { case 3: return(2.0*log(1.0-rf)); case 4: return(log(rf)+log(1.0-rf)); case 5: case 8: return(log(1.0-rf)); case 6: case 7: return(log(rf)); case 9: return(log(2.0)+log(rf)+log(1.0-rf)); case 10: return(log(rf*rf+(1.0-rf)*(1.0-rf))); case 13: return(log(1.0-(1.0-rf)*(1.0-rf))); case 11: case 14: return(log(1.0 - rf*(1.0-rf))); case 12: return(log(1.0-rf*rf)); } case 4: switch(obs2) { case 4: return(2.0*log(1.0-rf)); case 5: case 7: return(log(rf)); case 6: case 8: return(log(1.0-rf)); case 9: return(log(rf*rf+(1.0-rf)*(1.0-rf))); case 10: return(log(2.0)+log(rf)+log(1.0-rf)); case 14: return(log(1.0-(1.0-rf)*(1.0-rf))); case 12: case 13: return(log(1.0 - rf*(1.0-rf))); case 11: return(log(1.0-rf*rf)); } case 5: switch(obs2) { case 5: return(log(2.0)+log(1.0-rf)); case 6: return(log(2.0)+log(rf)); case 7: case 8: case 9: case 10: return(0.0); case 11: case 13: return(log(1.0+rf)); case 12: case 14: return(log(2.0-rf)); } case 6: switch(obs2) { case 6: return(log(2.0)+log(1.0-rf)); case 7: case 8: case 9: case 10: return(0.0); case 12: case 14: return(log(1.0+rf)); case 11: case 13: return(log(2.0-rf)); } case 7: switch(obs2) { case 7: return(log(2.0)+log(1.0-rf)); case 8: return(log(2.0)+log(rf)); case 9: case 10: return(0.0); case 11: case 12: return(log(1.0+rf)); case 13: case 14: return(log(2.0-rf)); } case 8: switch(obs2) { case 8: return(log(2.0)+log(1.0-rf)); case 9: case 10: return(0.0); case 13: case 14: return(log(1.0+rf)); case 11: case 12: return(log(2.0-rf)); } case 9: switch(obs2) { case 9: return(log(2.0)+log(rf*rf+(1.0-rf)*(1.0-rf))); case 10:return(log(4.0)+log(rf)+log(1.0-rf)); case 11: case 14: return(log(2.0-(1.0-rf)*(1.0-rf)-rf*rf)); case 12: case 13: return(log(2.0-2.0*rf*(1.0-rf))); } case 10: switch(obs2) { case 10: return(log(2.0)+log(rf*rf+(1.0-rf)*(1.0-rf))); case 12: case 13: return(log(2.0-(1.0-rf)*(1.0-rf)-rf*rf)); case 11: case 14: return(log(2.0-2.0*rf*(1.0-rf))); } case 11: switch(obs2) { case 11: return(log(2.0+(1.0-rf)*(1.0-rf))); case 12: case 13: return(log(2.0+rf*(1.0-rf))); case 14: return(log(2.0+rf*rf)); } case 12: switch(obs2) { case 12: return(log(2.0+(1.0-rf)*(1.0-rf))); case 13: return(log(2.0+rf*rf)); case 14: return(log(2.0+rf*(1.0-rf))); } case 13: switch(obs2) { case 13: return(log(2.0+(1.0-rf)*(1.0-rf))); case 14: return(log(2.0+rf*(1.0-rf))); } case 14: switch(obs2) { case 14: return(log(2.0+(1.0-rf)*(1.0-rf))); } } return(log(-1.0)); /* shouldn't get here */ } void est_rf_4way(int *n_ind, int *n_mar, int *geno, double *rf, int *maxit, double *tol) { est_rf(*n_ind, *n_mar, geno, rf, nrec2_4way, logprec_4way, *maxit, *tol, 2); } void calc_pairprob_4way(int *n_ind, int *n_mar, int *geno, double *rf1, double *rf2, double *error_prob, double *genoprob, double *pairprob) { calc_pairprob(*n_ind, *n_mar, 4, geno, rf1, rf2, *error_prob, genoprob, pairprob, init_4way, emit_4way, step_4way); } void marker_loglik_4way(int *n_ind, int *geno, double *error_prob, double *loglik) { marker_loglik(*n_ind, 4, geno, *error_prob, init_4way, emit_4way, loglik); } /* end of hmm_4way.c */ qtl/src/ril48_reorg.h0000644000176200001440000000550012770016226014155 0ustar liggesusers/********************************************************************** * * ril48_reorg.h * * copyright (c) 2009, Karl W Broman * * last modified Apr, 2009 * first written Apr, 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These functions are for reorganizing results of argmax.geno, calc.genoprob * and sim.geno, for 4- and 8-way RIL * * Contains: R_reorgRIgenoprob, reorgRIgenoprob, * R_reorgRIdraws, reorgRIdraws, * R_reorgRIpairprob, reorgRIpairprob * **********************************************************************/ /********************************************************************** * reorgRIgenoprob * * For 4- and 8-way RIL, reorganize the QTL genotype probabilities * using the information on the order of the founder strains in each * cross. **********************************************************************/ void reorgRIgenoprob(int n_ind, int n_mar, int n_str, double ***Prob, int **Crosses); /* wrapper for R */ void R_reorgRIgenoprob(int *n_ind, int *n_mar, int *n_str, double *prob, int *crosses); /********************************************************************** * reorgRIdraws * * For 4- and 8-way RIL, reorganize the imputed QTL genotypes * using the information on the order of the founder strains in each * cross. **********************************************************************/ void reorgRIdraws(int n_ind, int n_mar, int n_str, int n_draws, int ***Draws, int **Crosses); /* wrapper for R */ void R_reorgRIdraws(int *n_ind, int *n_mar, int *n_str, int *n_draws, int *draws, int *crosses); /********************************************************************** * reorgRIpairprob * * For 4- and 8-way RIL, reorganize the QTL the results of calc.pairprob * using the information on the order of the founder strains in each * cross. **********************************************************************/ void reorgRIpairprob(int n_ind, int n_mar, int n_str, double *****PairProb, int **Crosses); /* wrapper for R */ void R_reorgRIpairprob(int *n_ind, int *n_mar, int *n_str, double *pairprob, int *crosses); /* end of ril48_reorg.h */ qtl/src/mqmeliminate.h0000644000176200001440000000376613355127045014515 0ustar liggesusers/********************************************************************** * * mqmeliminate.h * * Copyright (c) 1996-2009 by * Ritsert C Jansen, Danny Arends, Pjotr Prins and Karl W Broman * * initial MQM C code written between 1996-2002 by Ritsert C. Jansen * improved for the R-language by Danny Arends, Pjotr Prins and Karl W. Broman * * Modified by Danny Arends and Pjotr Prins * last modified September 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif /* backward elimination in regression of trait on multiple cofactors routine subX haalt uit matrices voor volledige model de submatrices voor submodellen; matrices XtWX en Xt van volledig model worden genoemd fullxtwx en fullxt; analoog vector XtWY wordt full xtwy genoemd; */ double backward(int Nind, int Nmark, cvector cofactor, MQMMarkerMatrix marker, vector y, vector weight, int* ind, int Naug, double logLfull, double variance, double F1, double F2, cvector* newcofactor, vector r, cvector position,vector *informationcontent,vector *mapdistance,matrix *Frun,int run,char REMLorML, bool fitQTL,bool dominance,int em, double windowsize,double stepsize, double stepmin,double stepmax,MQMCrossType crosstype,int verbose); #ifdef __cplusplus } #endif /* end of MQMsupport.h */ qtl/src/mqmregression.h0000644000176200001440000000450313355127045014714 0ustar liggesusers/********************************************************************** * * mqmregression.h * * Copyright (c) 1996-2009 by * Ritsert C Jansen, Danny Arends, Pjotr Prins and Karl W Broman * * initial MQM C code written between 1996-2002 by Ritsert C. Jansen * improved for the R-language by Danny Arends, Pjotr Prins and Karl W. Broman * * Modified by Danny Arends and Pjotr Prins * last modified September 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif int designmatrixdimensions(const cvector cofactor,const unsigned int nmark,const bool dominance); /* * Used regression (perhaps change it to something faster) * regression of trait on multiple cofactors y=xb+e with weight w * (xtwx)b=(xtw)y * b=inv(xtwx)(xtw)y */ double regression(int Nind, int Nmark, cvector cofactor, MQMMarkerMatrix marker, vector y, vector* weight, ivector ind, int Naug, double *variance, vector Fy, const bool biasadj, const bool fitQTL, const bool dominance, bool verbose); /* ----------------------------------------------------------------------- subroutines from book 'Numerical Recipees in C' for calculating F-probabilities and for generating randomly permuted trait data for other tasks -----------------------------------------------------------------------*/ void ludcmp(matrix m, int dim, ivector ndx, int *d); void lusolve(matrix lu, int dim, ivector ndx, vector b); double gammln(double xx); double betai(double a, double b, double x); double betacf(double a, double b, double x); double inverseF(int df1, int df2, double alfa,int verbose); #ifdef __cplusplus } #endif /* end of mqmregression.h */ qtl/src/mqmmapqtl.h0000644000176200001440000000322113355127045014026 0ustar liggesusers/********************************************************************** * * mqmmapqtl.h * * Copyright (c) 1996-2009 by * Ritsert C Jansen, Danny Arends, Pjotr Prins and Karl W Broman * * initial MQM C code written between 1996-2002 by Ritsert C. Jansen * improved for the R-language by Danny Arends, Pjotr Prins and Karl W. Broman * * Modified by Danny Arends and Pjotr Prins * last modified September 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif double mapQTL(int Nind, int Nmark, cvector cofactor, cvector selcofactor, MQMMarkerMatrix marker, cvector position, vector mapdistance, vector y, vector r, ivector ind, int Naug, double variance, char printoutput,vector *informationcontent,matrix *Frun,int run,char REMLorML,bool fitQTL,bool dominance,int em, double windowsize,double stepsize, double stepmin,double stepmax,MQMCrossType crosstype,int verbose); #ifdef __cplusplus } #endif /* end of mqmmapqtl.h */ qtl/src/hmm_f2i.h0000644000176200001440000000770412770016226013346 0ustar liggesusers/********************************************************************** * * hmm_f2i.h * * copyright (c) 2006-7, Karl W Broman * (Some code adapted from code from Nicola Armstrong) * * last modified Mar, 2007 * first written Aug, 2006 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: est_map_f2i, R_est_map_f2i, * emit_f2i, nrec_f2i, step_f2i, * * These are functions for the HMM under the Stahl model * (with chiasmata coming from two mechanisms: one following a * chi-square model and one following a no interference model). * m = interference parameter in the chi-square model (m=0 == NI) * p = proportion of chiasmata from the NI model (p=1 == NI) * * Code for is for an intercross. * * INTERCROSS:: * Genotype codes: [0, ..., 2(m+1) - 1] x [1, ..., 2*(m+1)], * with the first (m+1) corresponding to A and the * others to B, and then for the two chromosomes crossed. * Phenotype codes: 0=missing; 1=AA; 2=AB, 3=BB, 4=not BB, 5=not AA * **********************************************************************/ /********************************************************************** * * est_map_f2i * * This function re-estimates the genetic map for a chromosome * with the Stahl model, taking m and p known, for an intercross * * n_ind Number of individuals * * n_mar Number of markers * * geno Genotype data, as a single vector storing the matrix * by columns, with each column corresponding to a marker * * d inter-marker distances in cM * (on exit, contains the new estimates) * * m Interference parameter (non-negative integer) * * p Proportion of chiasmata from the NI mechanism * * error_prob Genotyping error probability * * loglik Loglik at final estimates of recombination fractions * * maxit Maximum number of iterations to perform * * tol Tolerance for determining convergence * **********************************************************************/ void est_map_f2i(int n_ind, int n_mar, int *geno, double *d, int m, double p, double error_prob, double *loglik, int maxit, double tol, int verbose); /********************************************************************** * emit_f2i: log Pr(obs_gen | true_gen) **********************************************************************/ double emit_f2i(int obs_gen, int true_gen, double error_prob, int m, int n_bcstates); /********************************************************************** * nrec_f2i: proportion of recombinantion events **********************************************************************/ double nrec_f2i(int gen1, int gen2, int m, int n_bcstates); /* R wrapper for est_map_stahl for intercross */ void R_est_map_f2i(int *n_ind, int *n_mar, int *geno, double *d, int *m, double *p, double *error_prob, double *loglik, int *maxit, double *tol, int *verbose); /********************************************************************** * step_f2i * * Calculate transition probabilities for Stahl model in an intercross, * on the basis of the results for a BC. **********************************************************************/ double step_f2i(int g1, int g2, int pos, double ***tm, int n_bcstates); /* end of hmm_f2i.h */ qtl/src/hmm_ri8selfIRIP1.c0000644000176200001440000001546213355127045015004 0ustar liggesusers/********************************************************************** * * hmm_ri8selfIRIP.c * * Rohan Shah * * October, 2014 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: init_ri8IRIP1, emit_ri8IRIP1, step_ri8IRIP1, step_special_ri8IRIP1, * calc_genoprob_ri8IRIP1, calc_genoprob_special_ri8IRIP1, * argmax_geno_ri8IRIP1, sim_geno_ri8IRIP1, * est_map_ri8IRIP1, nrec2_ri8IRIP1, logprec_ri8IRIP1, est_rf_ri8IRIP1, * marker_loglik_ri8IRIP1, calc_pairprob_ri8IRIP1, * errorlod_ri8IRIP1, calc_errorlod_ri8IRIP1 * * These are the init, emit, and step functions plus * all of the hmm wrappers for 8-way RIL by selfing, with 1 generation of . * * Genotype codes: 1-8 * "Phenotype" codes: 0=missing; otherwise binary 1-255, with bit i * indicating SNP compatible with parent i * **********************************************************************/ #include #include #include #include #include #include #include "hmm_main.h" #include "hmm_ri8selfIRIP1.h" #include "hmm_bc.h" #include "util.h" #define M_LN56 4.0253516907351492333570491078177094338635851326626269 #define M_LN7 1.9459101490553133051053527434431797296370847295818611 double init_ri8selfIRIP1(int true_gen, int *cross_scheme) { return(-3.0*M_LN2); /* log(1/8) */ } double emit_ri8selfIRIP1(int obs_gen, int true_gen, double error_prob, int *cross_scheme) { if(obs_gen==0) return(0.0); if(obs_gen & (1 << (true_gen-1))) return(log(1.0-error_prob)); else return(log(error_prob)); } double step_ri8selfIRIP1(int gen1, int gen2, double rf, double junk, int *cross_scheme) { //See Teuscher and Broman 2007, "Haplotype Probabilities for Multiple-Strain Recombinant Inbred Lines", Equation (3), s=1 double equalProb = (1-rf)*(1-rf)*(1-rf)+(2*rf)/8; if(gen1 == gen2) return(log(equalProb)-log(1+2*rf)); else return(log(1-equalProb/(1+2*rf)) - M_LN7); } void calc_genoprob_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { calc_genoprob(*n_ind, *n_mar, 8, geno, rf, rf, *error_prob, genoprob, init_ri8selfIRIP1, emit_ri8selfIRIP1, step_ri8selfIRIP1); } void calc_genoprob_special_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { calc_genoprob_special(*n_ind, *n_mar, 8, geno, rf, rf, *error_prob, genoprob, init_ri8selfIRIP1, emit_ri8selfIRIP1, step_ri8selfIRIP1); } void argmax_geno_ri8selfIRIP1(int *n_ind, int *n_pos, int *geno, double *rf, double *error_prob, int *argmax) { argmax_geno(*n_ind, *n_pos, 8, geno, rf, rf, *error_prob, argmax, init_ri8selfIRIP1, emit_ri8selfIRIP1, step_ri8selfIRIP1); } void sim_geno_ri8IRIP1(int *n_ind, int *n_pos, int *n_draws, int *geno, double *rf, double *error_prob, int *draws) { sim_geno(*n_ind, *n_pos, 8, *n_draws, geno, rf, rf, *error_prob, draws, init_ri8selfIRIP1, emit_ri8selfIRIP1, step_ri8selfIRIP1); } /* for estimating map, must do things with recombination fractions on the RIL scale */ void est_map_ri8IRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *loglik, int *maxit, double *tol, int *verbose) { est_map(*n_ind, *n_mar, 8, geno, rf, rf, *error_prob, init_ri8selfIRIP1, emit_ri8selfIRIP1, step_ri8selfIRIP1, nrec_bc, nrec_bc, loglik, *maxit, *tol, 0, *verbose); } /* expected no. recombinants */ double nrec2_ri8selfIRIP1(int obs1, int obs2, double rf, int *cross_scheme) { int n1, n2, n12, nr, and, i, nstr=8; double rf0, rf1, num; if(obs1==0 || obs2==0) return(-999.0); /* this shouldn't happen */ n1=n2=n12=0; and = obs1 & obs2; /* count bits */ for(i=0; i j+1 with steps of stepsize=20 cM, starting from -20 cM up to 220 cM 2. all marker-cofactors in the neighborhood of the QTL are dropped by using cM='windows' as criterium */ nextinterval= 'n'; #ifndef STANDALONE R_CheckUserInterrupt(); /* check for ^C */ R_FlushConsole(); #endif while (nextinterval=='n') { // step 1: // Rprintf("DEBUG testing STEP 1"); if (position[j]==MLEFT) { if (moveQTL<=mapdistance[j]) { QTLposition[j]= position[j]; QTLposition[j+1]= MMIDDLE; QTLr[j]= recombination_frequentie((mapdistance[j]-moveQTL)); QTLr[j+1]= r[j]; QTLloci[j+1]= marker[j]; QTLloci[j]= marker[Nloci-1]; QTLmapdistance[j]= moveQTL; QTLmapdistance[j+1]= mapdistance[j]; if (firsttime=='y') weight[0]= -1.0; moveQTL+= stepsize; } else if (moveQTL<=mapdistance[j+1]) { QTLposition[j]= position[j]; QTLposition[j+1]= MMIDDLE; QTLr[j]= recombination_frequentie((moveQTL-mapdistance[j])); QTLr[j+1]= recombination_frequentie((mapdistance[j+1]-moveQTL)); //r[j]; QTLloci[j]= marker[j]; QTLloci[j+1]= marker[Nloci-1]; QTLmapdistance[j]= mapdistance[j]; QTLmapdistance[j+1]= moveQTL; moveQTL+= stepsize; } else nextinterval= 'y'; } else if (position[j]==MMIDDLE) { if (moveQTL<=mapdistance[j+1]) { QTLposition[j]= position[j]; QTLposition[j+1]= MMIDDLE; QTLr[j]= recombination_frequentie((moveQTL-mapdistance[j])); //0.0; QTLr[j+1]= recombination_frequentie((mapdistance[j+1]-moveQTL)); //r[j]; QTLloci[j]= marker[j]; QTLloci[j+1]= marker[Nloci-1]; QTLmapdistance[j]= mapdistance[j]; QTLmapdistance[j+1]= moveQTL; moveQTL+= stepsize; } else nextinterval= 'y'; } else if (position[j]==MRIGHT) { if (moveQTL<=stepmax) { QTLposition[j]= MMIDDLE; QTLposition[j+1]= MRIGHT; QTLr[j]= recombination_frequentie((moveQTL-mapdistance[j])); //0.0; QTLr[j+1]= r[j]; // note r[j]=999.0 QTLloci[j]= marker[j]; QTLloci[j+1]= marker[Nloci-1]; QTLmapdistance[j]= mapdistance[j]; QTLmapdistance[j+1]= moveQTL; moveQTL+= stepsize; } else { nextinterval= 'y'; moveQTL= stepmin; } } else if (position[j]==MUNLINKED) { QTLposition[j]= MLEFT; QTLposition[j+1]= MRIGHT; //position[j] ?? MRIGHT ? QTLr[j]= 0.0; QTLr[j+1]= r[j]; QTLloci[j+1]= marker[j]; QTLloci[j]= marker[Nloci-1]; QTLmapdistance[j]= mapdistance[j]; QTLmapdistance[j+1]= mapdistance[j]; if (firsttime=='y') weight[0]= -1.0; nextinterval= 'y'; moveQTL= stepmin; } if (nextinterval=='n') { // QTLcofactor[j]= MAA; // QTLcofactor[j+1]= MAA; for (jj=0; jj0) (*Frun)[step][run]+= QTLlikelihood; else (*Frun)[step][0]+= QTLlikelihood; /* Each individual has condition multilocus probabilities for being 0, 1 or 2 at the QTL. Calculate the maximum per individu. Calculate the mean of this maximum, averaging over all individuals This is the information content plotted. */ infocontent= 0.0; for (int i=0; i #include #include #include #include #include #include "hmm_main.h" #include "util.h" void init_stepf(double *rf, double *rf2, int n_gen, int n_mar, int *cross_scheme, double stepf(int, int, double, double, int *), double **probmat) { int j,obs1,obs2,tmp1; for(j=0; j obs2) { tmp1 = obs2; obs2 = obs1; obs1 = tmp1; } tmp1 = ((obs2 * (obs2 - 1)) / 2) - 1; return(probmat[mar][obs1 + tmp1]); } void forward_prob(int i, int n_mar, int n_gen, int curpos, int *cross_scheme, double error_prob, int **Geno, double **probmat, double **alpha, double initf(int, int *), double emitf(int, int, double, int *)) { /* forward equations */ /* Note: true genotypes coded as 1, 2, ... but in the alpha's and beta's, we use 0, 1, ... */ int j,v,v2; double errortol,salpha; /* initialize alpha */ /* curpos = -1: use error_prob always */ /* curpos >= 0: use TOL except when j == curpos, then use error_prob */ errortol = error_prob; if(curpos > 0) errortol = TOL; for(v=0; v= 0: use TOL except when j2+1 == curpos, then use error_prob */ errortol = error_prob; if(curpos >= 0) errortol = TOL; for(j2=n_mar-2; j2>=0; j2--) { if(curpos == j2+1) errortol = error_prob; for(v=0; v= 0) { j0 = curpos; jmax = j0 + 1; } /* calculate genotype probabilities */ for(j=j0; j= y[1]) { x[0] = x[1]; x[1] = x[3]; y[0] = y[1]; y[1] = y[3]; } else { x[2] = x[0]; x[0] = x[3]; y[2] = y[0]; y[0] = y[3]; } } /* handle boundary situations cleanly */ if((x[0] == 0.0 && y[0] >= y[1]) || (x[2] == 0.0 && y[2] >= y[1])) return(0.0); if((x[0] == 1.0 && y[0] >= y[1]) || (x[2] == 1.0 && y[2] >= y[1])) return(1.0); x[1] = (x[2] + x[0]) / 2.0; /* make negative if does not converge */ if(iter >= maxit) x[1] = - x[1]; return(x[1]); } /* end of hmm_util.c */ qtl/src/zeroin.c0000644000176200001440000001651713355127045013332 0ustar liggesusers/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 1999, 2001 the R Core Team * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * http://www.r-project.org/Licenses/ */ /* from NETLIB c/brent.shar with max.iter, add'l info and convergence details hacked in by Peter Dalgaard */ /* Karl Broman changed R_* to Rqtl_*, to avoid potential conflicts with R */ /************************************************************************* * C math library * function ZEROIN - obtain a function zero within the given range * * Input * double zeroin(ax,bx,f,info,Tol,Maxit) * double ax; Root will be seeked for within * double bx; a range [ax,bx] * double (*f)(double x, void *info); Name of the function whose zero * will be seeked for * void *info; Add'l info passed to f * double *Tol; Acceptable tolerance for the root * value. * May be specified as 0.0 to cause * the program to find the root as * accurate as possible * * int *Maxit; Max. iterations * * * Output * Zeroin returns an estimate for the root with accuracy * 4*EPSILON*abs(x) + tol * *Tol returns estimated precision * *Maxit returns actual # of iterations, or -1 if maxit was * reached without convergence. * * Algorithm * G.Forsythe, M.Malcolm, C.Moler, Computer methods for mathematical * computations. M., Mir, 1980, p.180 of the Russian edition * * The function makes use of the bisection procedure combined with * the linear or quadric inverse interpolation. * At every step program operates on three abscissae - a, b, and c. * b - the last and the best approximation to the root * a - the last but one approximation * c - the last but one or even earlier approximation than a that * 1) |f(b)| <= |f(c)| * 2) f(b) and f(c) have opposite signs, i.e. b and c confine * the root * At every step Zeroin selects one of the two new approximations, the * former being obtained by the bisection procedure and the latter * resulting in the interpolation (if a,b, and c are all different * the quadric interpolation is utilized, otherwise the linear one). * If the latter (i.e. obtained by the interpolation) point is * reasonable (i.e. lies within the current interval [b,c] not being * too close to the boundaries) it is accepted. The bisection result * is used in the other case. Therefore, the range of uncertainty is * ensured to be reduced at least by the factor 1.6 * ************************************************************************ * * NOTE: uniroot() --> do_zeroin2() --- in ../main/optimize.c * ~~~~~~~~~~~~~~~~~~ */ #include #include #include "zeroin.h" #define EPSILON DBL_EPSILON double Rqtl_zeroin( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double (*f)(double x, void *info), /* Function under investigation */ void *info, /* Add'l info passed on to f */ double *Tol, /* Acceptable tolerance */ int *Maxit) /* Max # of iterations */ { double fa = (*f)(ax, info); double fb = (*f)(bx, info); return Rqtl_zeroin2(ax, bx, fa, fb, f, info, Tol, Maxit); } /* Rqtl_zeroin2() is faster for "expensive" f(), in those typical cases where * f(ax) and f(bx) are available anyway : */ double Rqtl_zeroin2( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double fa, double fb, /* f(a), f(b) */ double (*f)(double x, void *info), /* Function under investigation */ void *info, /* Add'l info passed on to f */ double *Tol, /* Acceptable tolerance */ int *Maxit) /* Max # of iterations */ { double a,b,c, fc; /* Abscissae, descr. see above, f(c) */ double tol; int maxit; a = ax; b = bx; c = a; fc = fa; maxit = *Maxit + 1; tol = * Tol; /* First test if we have found a root at an endpoint */ if(fa == 0.0) { *Tol = 0.0; *Maxit = 0; return a; } if(fb == 0.0) { *Tol = 0.0; *Maxit = 0; return b; } while(maxit--) /* Main iteration loop */ { double prev_step = b-a; /* Distance from the last but one to the last approximation */ double tol_act; /* Actual tolerance */ double p; /* Interpolation step is calcu- */ double q; /* lated in the form p/q; divi- * sion operations is delayed * until the last moment */ double new_step; /* Step at this iteration */ if( fabs(fc) < fabs(fb) ) { /* Swap data for b to be the */ a = b; b = c; c = a; /* best approximation */ fa=fb; fb=fc; fc=fa; } tol_act = 2*EPSILON*fabs(b) + tol/2; new_step = (c-b)/2; if( fabs(new_step) <= tol_act || fb == (double)0 ) { *Maxit -= maxit; *Tol = fabs(c-b); return b; /* Acceptable approx. is found */ } /* Decide if the interpolation can be tried */ if( fabs(prev_step) >= tol_act /* If prev_step was large enough*/ && fabs(fa) > fabs(fb) ) { /* and was in true direction, * Interpolation may be tried */ register double t1,cb,t2; cb = c-b; if( a==c ) { /* If we have only two distinct */ /* points linear interpolation */ t1 = fb/fa; /* can only be applied */ p = cb*t1; q = 1.0 - t1; } else { /* Quadric inverse interpolation*/ q = fa/fc; t1 = fb/fc; t2 = fb/fa; p = t2 * ( cb*q*(q-t1) - (b-a)*(t1-1.0) ); q = (q-1.0) * (t1-1.0) * (t2-1.0); } if( p>(double)0 ) /* p was calculated with the */ q = -q; /* opposite sign; make p positive */ else /* and assign possible minus to */ p = -p; /* q */ if( p < (0.75*cb*q-fabs(tol_act*q)/2) /* If b+p/q falls in [b,c]*/ && p < fabs(prev_step*q/2) ) /* and isn't too large */ new_step = p/q; /* it is accepted * If p/q is too large then the * bisection procedure can * reduce [b,c] range to more * extent */ } if( fabs(new_step) < tol_act) { /* Adjust the step to be not less*/ if( new_step > (double)0 ) /* than tolerance */ new_step = tol_act; else new_step = -tol_act; } a = b; fa = fb; /* Save the previous approx. */ b += new_step; fb = (*f)(b, info); /* Do step to a new approxim. */ if( (fb > 0 && fc > 0) || (fb < 0 && fc < 0) ) { /* Adjust c for it to have a sign opposite to that of b */ c = a; fc = fa; } } /* failed! */ *Tol = fabs(c-b); *Maxit = -1; return b; } qtl/src/fitqtl_hk.h0000644000176200001440000000624412770016226014010 0ustar liggesusers/********************************************************************** * * fitqtl_hk.h * * copyright (c) 2007-2014, Karl W Broman * * last modified Mar, 2014 * first written Nov, 2007 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These functions are for fitting a fixed multiple-QTL model by * Haley-Knott regression. * * Contains: R_fitqtl_hk, fitqtl_hk, galtRssHK * **********************************************************************/ void R_fitqtl_hk(int *n_ind, int *n_qtl, int *n_gen, double *genoprob, int *n_cov, double *cov, int *model, int *n_int, double *pheno, int *get_ests, /* return variables */ double *lod, int *df, double *ests, double *ests_covar, double *design_mat, int *matrix_rank, double *residuals); /********************************************************************** * * fitqtl_hk * * Fits a fixed multiple-QTL model by Haley-Knott regression. * * n_ind Number of individuals * * n_qtl Number of QTLs in the model * * n_gen Number of different genotypes * * Genoprob QTL genotype probabilities * * Cov covariates matrix, Cov[mar][ind] * * n_cov Number of covariates * * model Model matrix * * n_int Number of interactions in the model * * pheno Phenotype data, as a vector * * get_ests 0/1: If 1, return estimated effects and their variances * * lod Return LOD score * * df Return degree of freedom * * ests Return ests (vector of length sizefull) * * ests_covar Return covariance matrix of ests (sizefull^2 matrix) * * matrix_rank On return, rank of design matrix * * residuals On return, the residuals from the fit * **********************************************************************/ void fitqtl_hk(int n_ind, int n_qtl, int *n_gen, double ***Genoprob, double **Cov, int n_cov, int *model, int n_int, double *pheno, int get_ests, double *lod, int *df, double *ests, double *ests_covar, double *design_mat, int *matrix_rank, double *residuals); /* galtRssHK - calculate RSS for full model by Haley-Knott regression */ double galtRssHK(double *pheno, int n_ind, int *n_gen, int n_qtl, double ***Genoprob, double **Cov, int n_cov, int *model, int n_int, double *dwork, int *iwork, int sizefull, int get_ests, double *ests, double **Ests_covar, double *designmat, int *matrix_rank, double *residuals); /* end of fitqtl_hk.h */ qtl/src/mqmmixture.h0000644000176200001440000000373413355127045014236 0ustar liggesusers/********************************************************************** * * mqmmixture.h * * Copyright (c) 1996-2010 by * Ritsert C Jansen, Danny Arends, Pjotr Prins and Karl W Broman * * initial MQM C code written between 1996-2002 by Ritsert C. Jansen * improved for the R-language by Danny Arends, Pjotr Prins and Karl W. Broman * * Modified by Danny Arends and Pjotr Prins * last modified May 2010 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif /* ML estimation of recombination frequencies via EM; calculation of multilocus genotype probabilities; ignorance of unlikely genotypes*/ double rmixture(MQMMarkerMatrix marker, vector weight, vector r, cvector position, ivector ind, int Nind, int Naug, int Nmark,vector *mapdistance, char reestimate,MQMCrossType crosstype,int verbose); /* ML estimation of parameters in mixture model via EM; */ double QTLmixture(MQMMarkerMatrix loci, cvector cofactor, vector r, cvector position, vector y, ivector ind, int Nind, int Naug, int Nloci, double *variance, int em, vector *weight, const bool useREML,bool fitQTL,bool dominance, MQMCrossType crosstype, bool* warned,int verbose); #ifdef __cplusplus } #endif /* end of mqmmixture.h */ qtl/src/inferFounderHap.c0000644000176200001440000001505512770016226015075 0ustar liggesusers/********************************************************************** * * inferFounderHap.c * * copyright (c) 2011, Karl W Broman * * last modified Dec, 2011 * first written Dec, 2011 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: constructFounderHap, whichUnique * * These are for reconstructing the founder haplotypes in inbred lines * by a crude method using groups of adjacent SNPs * **********************************************************************/ #include #include #include #include #include #include #include "inferFounderHap.h" #include "util.h" void R_inferFounderHap(int *n_snp, int *n_founders, int *n_ind, int *foundergen, int *indgen, int *max_offset, int *hap) { int **founderGen, **indGen, **Hap; reorg_geno(*n_founders, *n_snp, foundergen, &founderGen); reorg_geno(*n_ind, *n_snp, indgen, &indGen); reorg_geno(*n_ind, *n_snp, hap, &Hap); inferFounderHap(*n_snp, *n_founders, *n_ind, founderGen, indGen, *max_offset, Hap); } void inferFounderHap(int n_snp, int n_founders, int n_ind, int **founderGen, int **indGen, int max_offset, int **Hap) { int i, j, left, offset, n_unique; unsigned int *fhap, *indhap; int *fhapunique; allocate_uint(n_founders, &fhap); allocate_int(n_founders, &fhapunique); allocate_uint(n_ind, &indhap); for(left=0; left=0; offset++) { R_CheckUserInterrupt(); /* check for ^C */ /* founder haplotypes as integers */ for(i=0; i 0 && founderGen[left-offset][i]) fhap[i] += (1 << (offset*2+1)); } /* individual haplotypes as integers */ for(i=0; i 0 && indGen[left-offset][i] < 0)) /* missing genotype */ Hap[left][i] = -1; else { if(indGen[left+offset][i]) indhap[i] += (1 << (offset*2)); if(offset > 0 && indGen[left-offset][i]) indhap[i] += (1 << (offset*2+1)); } } } /* which founder haplotypes are unique */ whichUnique(fhap, n_founders, fhapunique, &n_unique); if(n_unique>0) { /* at least one unique founder haplotype */ for(i=0; i 1) and then count the unique ones */ void whichUnique(unsigned int *x, int n_x, int *is_unique, int *n_unique) { int i, j; for(i=0; i0)&&(!finished)) { for (int j=0; jmaxlogL){ maxlogL= logL[j]; dropj = j; } } #ifndef STANDALONE R_CheckUserInterrupt(); /* check for ^C */ R_FlushConsole(); #endif //See which cofactor we need to drop, if we dont drop any (or have none left) we're finished if ( ((*newcofactor)[dropj]==MCOF) && ( F2> 2.0*(savelogL-maxlogL)) ) { savelogL= maxlogL; (*newcofactor)[dropj]= MNOCOF; Ncof-=1; if(verbose) Rprintf("INFO: Marker %d is dropped, resulting in reduced model logL = %.3f\n",(dropj+1),ftruncate3(savelogL)); } else if ( ((*newcofactor)[dropj]==MBB) && (F1> 2.0*(savelogL-maxlogL)) ) { savelogL= maxlogL; (*newcofactor)[dropj]= MNOCOF; Ncof-=1; if(verbose) Rprintf("INFO: Marker %d is dropped, resulting in logL of reduced model = %.3f\n",(dropj+1),ftruncate3(savelogL)); } else { // if (verbose) { info("Backward selection of markers to be used as cofactors has finished.\n"); } finished=true; } } if (verbose) { Rprintf("MODEL: ----------------------:MODEL:----------------------\n"); for (int j=0; j #include #include #include #include #include #include #include #include "util.h" #include "lapackutil.h" #include "scanone_imp.h" #define TOL 1e-12 /********************************************************************** * * R_scanone_imp * * Wrapper for call from R; reorganizes genotype prob and result matrix * and calls scanone_imp. * **********************************************************************/ void R_scanone_imp(int *n_ind, int *n_pos, int *n_gen, int *n_draws, int *draws, double *addcov, int *n_addcov, double *intcov, int *n_intcov, double *pheno, int *nphe, double *weights, double *result, int *ind_noqtl) { /* reorganize draws */ int ***Draws; double **Addcov=0, **Intcov=0, **Result; reorg_draws(*n_ind, *n_pos, *n_draws, draws, &Draws); reorg_errlod(*n_pos, *nphe, result, &Result); /* reorganize addcov and intcov (if they are not empty) */ /* currently reorg_errlod function is used to reorganize the data */ if(*n_addcov != 0) reorg_errlod(*n_ind, *n_addcov, addcov, &Addcov); if(*n_intcov != 0) reorg_errlod(*n_ind, *n_intcov, intcov, &Intcov); scanone_imp(*n_ind, *n_pos, *n_gen, *n_draws, Draws, Addcov, *n_addcov, Intcov, *n_intcov, pheno, *nphe, weights, Result, ind_noqtl); } /********************************************************************** * * scanone_imp * * Performs genome scan using the pseudomarker algorithm (imputation) * method of Sen and Churchill (2001). * * n_ind Number of individuals * * n_pos Number of marker positions * * n_gen Number of different genotypes * * n_draws Number of impiutations * * Draws Array of genotype imputations, indexed as * Draws[repl][mar][ind] * * Addcov Additive covariates matrix, Addcov[mar][ind] * * n_addcov Number of additive covariates * * Intcov Interacting covariates matrix, Intcov[mar][ind] * * n_intcov Number of interacting covariates * * pheno Phenotype data, as a vector/matrix * * nphe Number of phenotypes * * weights Vector of positive weights, of length n_ind * * Result Matrix of size [n_pos x nphe]; upon return, contains * the "LPD" (log posterior distribution of QTL location). * * ind_noqtl Indicators (0/1) of which individuals should be excluded * from QTL effects. * **********************************************************************/ void scanone_imp(int n_ind, int n_pos, int n_gen, int n_draws, int ***Draws, double **Addcov, int n_addcov, double **Intcov, int n_intcov, double *pheno, int nphe, double *weights, double **Result, int *ind_noqtl) { /* create local variables */ int i, j, k, nrss, sizefull, sizenull, lwork, multivar=0; double **lrss0, **lrss1, *LOD, dtmp, *tmppheno, *dwork_null, *dwork_full; /* if number of pheno is 1 or do multivariate model, we have only one rss at each position. Otherwise, we have one rss for each phenotype */ if( (nphe==1) || (multivar==1) ) nrss = 1; else nrss = nphe; /* number of columns in design matrices for null and full model */ sizenull = 1 + n_addcov; sizefull = n_gen + n_addcov + n_intcov*(n_gen-1); /* allocate memory */ tmppheno = (double *) R_alloc(n_ind*nphe, sizeof(double)); /* for null model */ lwork = 3*sizenull + MAX(n_ind, nphe); if(multivar == 1) /* request to do multivariate normal model */ dwork_null = (double *)R_alloc(sizenull+lwork+2*n_ind*sizenull+n_ind*nphe+nphe*nphe+sizenull*nphe, sizeof(double)); else /* normal model, don't need to allocate memory for rss_det, which is nphe^2 */ dwork_null = (double *)R_alloc(sizenull+lwork+2*n_ind*sizenull+n_ind*nphe+sizenull*nphe, sizeof(double)); /* for full model */ lwork = 3*sizefull + MAX(n_ind, nphe); if(multivar == 1) /* request to do multivariate normal model */ dwork_full = (double *)R_alloc(sizefull+lwork+2*n_ind*sizefull+n_ind*nphe+nphe*nphe+sizefull*nphe, sizeof(double)); else /* normal model, don't need to allocate memory for rss_det, which is nphe^2 */ dwork_full = (double *)R_alloc(sizefull+lwork+2*n_ind*sizefull+n_ind*nphe+sizefull*nphe, sizeof(double)); /* for rss' and lod scores - we might not need all of this memory */ lrss0 = (double **)R_alloc(n_draws, sizeof(double*)); lrss1 = (double **)R_alloc(n_draws, sizeof(double*)); /*LOD = (double **)R_alloc(n_draws, sizeof(double*));*/ for(i=0; i 1) { for(k=0; k (b)) ? (a) : (b)) #endif /********************************************************************** * * addlog * * Calculate addlog(a,b) = log[exp(a) + exp(b)] * * This makes use of the function log1p(x) = log(1+x) provided * in R's math library. * **********************************************************************/ double addlog(double a, double b); /********************************************************************** * * subtrlog * * Calculate subtrlog(a,b) = log[exp(a) - exp(b)] * * This makes use of the function log1p(x) = log(1+x) provided * in R's math library. * **********************************************************************/ double subtrlog(double a, double b); /********************************************************************** * * reorg_geno * * Reorganize the genotype data so that it is a doubly indexed array * rather than a single long vector * * Afterwards, geno indexed like Geno[mar][ind] * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void reorg_geno(int n_ind, int n_pos, int *geno, int ***Geno); /********************************************************************** * * reorg_genoprob * * Reorganize the genotype probability data so that it is a triply * indexed array rather than a single long vector * * Afterwards, genoprob indexed like Genoprob[gen][mar][ind] * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void reorg_genoprob(int n_ind, int n_pos, int n_gen, double *genoprob, double ****Genoprob); /********************************************************************** * * reorg_pairprob * * Reorganize the joint genotype probabilities so that they form a * quintuply indexed array rather than a single long vector * * Afterwards, pairprob indexed like * Pairprob[gen1][gen2][pos1][pos2][ind] with pos2 > pos1 * * You *must* refer to cases with pos2 > pos1, as cases with * pos2 <= pos1 point off into the ether. * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void reorg_pairprob(int n_ind, int n_pos, int n_gen, double *pairprob, double ******Pairprob); /********************************************************************** * * allocate_alpha * * Allocate space for alpha and beta matrices * * Afterwards, indexed like alpha[gen][mar] * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_alpha(int n_pos, int n_gen, double ***alpha); /********************************************************************** * * reorg_draws * * Reorganize the simulated genotypes so that it is a triply * indexed array rather than a single long vector * * Afterwards, draws indexed like Draws[repl][mar][ind] * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void reorg_draws(int n_ind, int n_pos, int n_draws, int *draws, int ****Draws); /********************************************************************** * * allocate_double * * Allocate space for a vector of doubles * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_double(int n, double **vector); /********************************************************************** * * allocate_int * * Allocate space for a vector of ints * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_int(int n, int **vector); /********************************************************************** * * allocate_uint * * Allocate space for a vector of unsigned ints * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_uint(int n, unsigned int **vector); /********************************************************************** * * allocate_dmatrix * * Allocate space for a matrix of doubles * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_dmatrix(int n_row, int n_col, double ***matrix); /********************************************************************** * * allocate_imatrix * * Allocate space for a matrix of ints * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void allocate_imatrix(int n_row, int n_col, int ***matrix); /********************************************************************** * * sample_int * * Make a single draw from (1, ..., n) with probs (p_0, ..., p_(n-1)) * **********************************************************************/ int sample_int(int n, double *p); /********************************************************************** * * reorg_errlod * * Just like reorg_geno(), only for a matrix of doubles. * * Afterwards, errlod indexed like Errlod[mar][ind] * * Allocation done by R_alloc, so that R does the cleanup. * **********************************************************************/ void reorg_errlod(int n_ind, int n_mar, double *errlod, double ***Errlod); /********************************************************************** * * double_permute * * This function randomly permutes a vector of doubles * * Input: * * array = vector of doubles; on output, it contains a random * permutation of the input vector * * len = length of the vector * **********************************************************************/ void double_permute(double *array, int len); /********************************************************************** * * int_permute * * This function randomly permutes a vector of int * * Input: * * array = vector of int; on output, it contains a random * permutation of the input vector * * len = length of the vector * **********************************************************************/ void int_permute(int *array, int len); /********************************************************************** * * random_int * * Generates a random int integer between "low" and "high", inclusive. * * Input: * * low * * high * **********************************************************************/ int random_int(int low, int high); /********************************************************************** * wtaverage * calculate the weight average of the LOD scores *********************************************************************/ double wtaverage(double *LOD, int n_draws); /********************************************************************** * comparegeno * * Count number of matches in the genotypes for all pairs of * individuals. * * Input: * **********************************************************************/ void comparegeno(int **Geno, int n_ind, int n_mar, int **N_Match, int **N_Missing); /********************************************************************** * R_comparegeno: wrapper for R **********************************************************************/ void R_comparegeno(int *geno, int *n_ind, int *n_mar, int *n_match, int *n_missing); void R_locate_xo(int *n_ind, int *n_mar, int *type, int *geno, double *map, double *location, int *nseen, int *ileft, int *iright, double *left, double *right, int *gleft, int *gright, int *ntyped, int *full_info); /* Note: type ==0 for backcross and ==1 for intercross */ void locate_xo(int n_ind, int n_mar, int type, int **Geno, double *map, double **Location, int *nseen, int **iLeft, int **iRight, double **Left, double **Right, int **gLeft, int **gRight, int **nTyped, int full_info); /* multiply two matrices - I'm using dgemm from lapack here */ void matmult(double *result, double *a, int nrowa, int ncola, double *b, int ncolb); /* multiply two matrices - I'm using dgemm from lapack here */ /* void matmult2(double *result, double *a, int nrowa, int ncola, double *b, int ncolb); */ /********************************************************************** * * expand_col2drop * * Used in scantwo_1chr_em for the X chromosome, to figure out * what columns to drop in the presence of covariates when certain * genotype columns must be dropped * **********************************************************************/ void expand_col2drop(int n_gen, int n_addcov, int n_intcov, int *col2drop, int *allcol2drop); void dropcol_xpx(int *n_col, int *col2drop, double *xpx); void dropcol_xpy(int n_col, int *col2drop, double *xpy); void dropcol_x(int *n_col, int n_row, int *col2drop, double *x); /********************************************************************** * * reviseMWril Revise genotypes for 4- or 8-way RIL * to form encoding the founders' genotypes * * n_ril Number of RILs to simulate * n_mar Number of markers * n_str Number of founder strains * * Parents SNP data for the founder strains [dim n_mar x n_str] * * Geno On entry, the detailed genotype data; on exit, the * SNP data written bitwise. [dim n_ril x n_mar] * * Crosses The crosses [n_ril x n_str] * **********************************************************************/ void reviseMWril(int n_ril, int n_mar, int n_str, int **Parents, int **Geno, int **Crosses, int missingval); /* wrapper for calling reviseMWril from R */ void R_reviseMWril(int *n_ril, int *n_mar, int *n_str, int *parents, int *geno, int *crosses, int *missingval); /* wrapper for calcPermPval */ void R_calcPermPval(double *peaks, int *nc_peaks, int *nr_peaks, double *perms, int *n_perms, double *pval); /* calculate permutation p-values for summary.scanone() */ void calcPermPval(double **Peaks, int nc_peaks, int nr_peaks, double **Perms, int n_perms, double **Pval); #ifdef __cplusplus } #endif #endif /* end of util.h */ qtl/src/hmm_ri8selfIRIP1.h0000644000176200001440000000635213355127045015007 0ustar liggesusers/********************************************************************** * * hmm_ri8self.h * * Rohan Shah * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * Contains: init_ri8self, emit_ri8self, step_ri8self, step_special_ri8self, * calc_genoprob_ri8self, calc_genoprob_special_ri8self, * argmax_geno_ri8self, sim_geno_ri8self, * est_map_ri8self, nrec2_ri8self, logprec_ri8self, est_rf_ri8self, * marker_loglik_ri8self, calc_pairprob_ri8self, * errorlod_ri8self, calc_errorlod_ri8self * * These are the init, emit, and step functions plus * all of the hmm wrappers for 8-way RIL by selfing. * * Genotype codes: 1-8 * "Phenotype" codes: 0=missing; otherwise binary 1-255, with bit i * indicating SNP compatible with parent i * **********************************************************************/ double init_ri8selfIRIP1(int true_gen, int *cross_scheme); double emit_ri8selfIRIP1(int obs_gen, int true_gen, double error_prob, int *cross_scheme); double step_ri8selfIRIP1(int gen1, int gen2, double rf, double junk, int *cross_scheme); void calc_genoprob_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob); void calc_genoprob_special_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob); void argmax_geno_ri8selfIRIP1(int *n_ind, int *n_pos, int *geno, double *rf, double *error_prob, int *argmax); void sim_geno_ri8selfIRIP1(int *n_ind, int *n_pos, int *n_draws, int *geno, double *rf, double *error_prob, int *draws); void est_map_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *loglik, int *maxit, double *tol, int *verbose); /* expected no. recombinants */ double nrec2_ri8selfIRIP1(int obs1, int obs2, double rf, int *cross_scheme); /* log [joint probability * 8] */ double logprec_ri8selfIRIP1(int obs1, int obs2, double rf, int *cross_scheme); void est_rf_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, int *maxit, double *tol); void marker_loglik_ri8selfIRIP1(int *n_ind, int *geno, double *error_prob, double *loglik); void calc_pairprob_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob, double *pairprob); double errorlod_ri8self(int obs, double *prob, double error_prob); void calc_errorlod_ri8selfIRIP1(int *n_ind, int *n_mar, int *geno, double *error_prob, double *genoprob, double *errlod); /* end of hmm_ri8self.h */ qtl/src/scanone_mr.h0000644000176200001440000000551512770016226014147 0ustar liggesusers/********************************************************************** * * scanone_mr.h * * copyright (c) 2001-6, Karl W Broman * * last modified Feb, 2006 * first written Nov, 2001 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These functions are for performing a genome scan with a * single QTL model by marker regression (i.e., analysis of variance at * the marker loci) * * Contains: R_scanone_mr, scanone_mr * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif /********************************************************************** * * R_scanone_mr * * Wrapper for call from R; reorganizes genotype and result matrix * and calls scanone_mr. * **********************************************************************/ void R_scanone_mr(int *n_ind, int *n_pos, int *n_gen, int *geno, double *addcov, int *n_addcov, double *intcov, int *n_intcov, double *pheno, double *weights, double *result); /********************************************************************** * * scanone_mr * * Performs genome scan using marker regression. * * n_ind Number of individuals * * n_pos Number of marker positions * * n_gen Number of different genotypes * * Geno Genotype matrix * * Addcov Matrix of additive covariates: Addcov[cov][ind] * * n_addcov Number of columns of Addcov * * Intcov Number of interactive covariates: Intcov[cov][ind] * * n_intcov Number of columns of Intcov * * pheno Phenotype data, as a vector * * weights Vector of positive weights, of length n_ind * * result Vector of length n_pos, to contain the RSS * **********************************************************************/ void scanone_mr(int n_ind, int n_pos, int n_gen, int **Geno, double **Addcov, int n_addcov, double **Intcov, int n_intcov, double *pheno, double *weights, double *result); #ifdef __cplusplus } #endif /* end of scanone_mr.h */ qtl/src/mqmprob.h0000644000176200001440000000466512770016226013505 0ustar liggesusers/********************************************************************** * * mqmprob.h * * Copyright (c) 1996-2009 by * Ritsert C Jansen, Danny Arends, Pjotr Prins and Karl W Broman * * initial MQM C code written between 1996-2002 by Ritsert C. Jansen * improved for the R-language by Danny Arends, Pjotr Prins and Karl W. Broman * * Modified by Danny Arends and Pjotr Prins * last modified September 2009 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * **********************************************************************/ #ifdef __cplusplus extern "C" { #endif cvector relative_marker_position(const unsigned int nmark,const ivector chr); vector recombination_frequencies(const unsigned int nmark, const cvector position, const vector mapdistance); double recombination_frequentie(const double cmdistance); void validate_markertype(const MQMCrossType crosstype, const char markertype); //double probright(const char c, const int j, const cvector imarker, const vector rs, const cvector position,const MQMCrossType crosstype); double left_prob(const double r, const MQMMarker markerL,const MQMMarker markerR,const MQMCrossType crosstype); double right_prob_F2(const char markerL, const int j, const MQMMarkerVector imarker, const vector rs, const cvector position); double right_prob_BC(const char markerL, const int j, const MQMMarkerVector imarker, const vector rs, const cvector position); double right_prob_RIL(const char markerL, const int j, const MQMMarkerVector imarker, const vector rs, const cvector position); //double prob(const cmatrix loci, const vector rs, const int i, const int j, const char markertype, const MQMCrossType crosstype, const int ADJ); double start_prob(const MQMCrossType crosstype,MQMMarker markertype); bool is_knownMarker(const char marker,const MQMCrossType crosstype); #ifdef __cplusplus } #endif /* end of mqmprob.h */ qtl/src/forwsel.h0000644000176200001440000000460512770016226013503 0ustar liggesusers/********************************************************************** * * forwsel.h * * copyright (c) 2007, Karl W Broman * * last modified Jan, 2007 * first written Jan, 2007 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * This is a simple routine to do forward selection in regression * to a fixed number of covariates * * Contains: R_markerforwsel, markerforwsel, * R_markerforwself2, markerforwself2 * **********************************************************************/ /* R wrappers */ void R_markerforwsel(int *n, int *m, double *x, double *y, int *maxsize, int *chosen, double *rss); void R_markerforwself2(int *n, int *m, int *x, double *y, int *maxsize, int *chosen, double *rss); /********************************************************************** * markerforwsel * * n = number of individuals * m = number of covariates (not including intercept) * * X = covariate matrix, indexed as X[covariate][individual] * y = outcome * * maxsize = maximum number of covariates * * chosen = on output, index [0, 1, ..., (m-1)] of chosen covariates * rss = on output, rss for those models * **********************************************************************/ void markerforwsel(int n, int m, double **X, double *y, int maxsize, int *chosen, double *rss); /********************************************************************** * markerforwself2 * * the same as markerforwsel, but for an intercross, in which each * column must be expanded to two, and we must select on the pairs of * columns. * **********************************************************************/ void markerforwself2(int n, int m, double **X, double *y, int maxsize, int *chosen, double *rss); /* end of forwsel.h */ qtl/src/countXO.c0000644000176200001440000001021612770016226013407 0ustar liggesusers/********************************************************************** * * countXO.c * * copyright (c) 2008-9, Karl W Broman * * last modified Apr, 2009 * first written Feb, 2008 * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License, * version 3, as published by the Free Software Foundation. * * This program is distributed in the hope that it will be useful, * but without any warranty; without even the implied warranty of * merchantability or fitness for a particular purpose. See the GNU * General Public License, version 3, for more details. * * A copy of the GNU General Public License, version 3, is available * at http://www.r-project.org/Licenses/GPL-3 * * C functions for the R/qtl package * * These functions are for comparing marker orders by counts of * obligate crossovers * * Contains: R_countXO_bc, R_countXO_f2, R_countXO_4way, countXO * R_countXO_ril48 * **********************************************************************/ #include #include #include #include #include #include #include #include // #include "util.h" #include "ripple.h" #include "util.h" #include "countXO.h" /********************************************************************** * * countXO * * This function counts the number of obligate crossovers for each * individual on a chromosome * * Input: * * n_ind = no. individuals * * n_mar = no. markers * * n_gen = no. possible genotypes * * geno = genotype data [n_ind x n_mar] * * nxo = the output; the number of obligate crossovers for each * individual * * countxo = function to count the number of obligate crossovers in * an interval and to update the current inferred genotype * (specific for backcross, intercross, and four-way cross) * **********************************************************************/ void countXO(int n_ind, int n_mar, int n_gen, int *geno, int *nxo, int countxo(int *curgen, int nextgen)) { int **Geno; int j, k, curgen; /* reorganize genotype data and marker order matrix */ reorg_geno(n_ind, n_mar, geno, &Geno); for(j=0; j #include #include #include #include #include #include "hmm_main.h" #include "hmm_bcsft.h" #include "hmm_f2.h" #include "hmm_bc.h" #include "hmm_util.h" #include "util.h" /* ref: Jiang and Zeng (1997 Genetics) */ void prob_bcsft(double rf, int s, int t, double *transpr); void count_bcsft(double rf, int s, int t, double *transct); void expect_bcsft(double rf, int s, int t, double *transexp); /* assign probabilities or counts based on vector of precomputed values */ /* in transpr and transct, which are re-computed only when rf,s or t changes */ double assign_bcsft(int gen1, int gen2, double *transpr) { /* joint probability with known genotype, phase unknown */ switch(gen1) { case 1: case 3: { /* AA and aa for gen1 */ if(gen2 == gen1) { if(gen1 == 1) return(transpr[0]); /* 1,1: A1 */ return(transpr[5]); /* 3,3: A0 */ } if(gen2 + gen1 == 4) return(transpr[2]); /* 1,3: C */ break; } case 2: { /* Aa and aA for gen1 */ if(gen2 == gen1) return(transpr[3]); /* 2,2: D or E */ } } if((gen1 == 1) || (gen2 == 1)) return(transpr[1]); /* 1,2: B1 */ return(transpr[6]); /* 2,3: B0 */ } double assign_bcsftb(int gen1, int gen2, double *transpr) { /* joint probability with known genotype and unknown */ switch(gen1) { case 1: case 4: /* AA and aa for gen1 */ { if(gen2 == gen1) { if(gen1 == 1) return(transpr[0]); /* 1,1: A1 */ return(transpr[5]); /* 4,4: A0 */ } if(gen2 + gen1 == 5) return(transpr[2]); /* 1,4: C */ break; } case 2: case 3: /* Aa and aA for gen1 */ { if(gen2 == gen1) return(transpr[3]); /* 2,2: D */ if(gen2 + gen1 == 5) return(transpr[4]); /* 2,3: E */ } } if((gen1 == 1) || (gen2 == 1)) return(transpr[1]); /* 1,2|3: B1 */ return(transpr[6]); /* 2|3,4: B0 */ } double assign_bcsftc(int obs1, int obs2, double *transval) { /* joint probability of obs2 and obs1, allowing for partially informative genos */ if((obs1 == 0) || (obs2 == 0)) return(0.0); /* shouldn't get here */ int temp; /* make obs1 <= obs2 */ if(obs1 > obs2) { temp = obs2; obs2 = obs1; obs1 = temp; } switch(obs1) { case 1: case 3: { /* AA and aa for obs1 */ if(obs2 == obs1) { if(obs1 == 1) return(transval[0]); /* 1,1: A1 */ return(transval[5]); /* 3,3: A0 */ } if(obs2 + obs1 == 4) return(transval[2]); /* 1,3: C */ if(obs1 == 1) { /* B1 */ if(obs1 + obs2 == 3) return(transval[1]); /* 1,2: B1 */ if(obs1 + obs2 == 5) return(transval[0] + transval[1]); /* 1,4: A1 or B1 */ return(transval[2] + transval[1]); /* 1,5: B1 or C */ } { /* B0 */ if(obs1 + obs2 == 7) return(transval[2] + transval[6]); /* 3,4: A1 or B0 */ return(transval[5] + transval[6]); /* 3,5: A0 or B0 */ } } case 2: /* Aa and aA for obs1 */ { if(obs2 == obs1) return(transval[3]); /* 2,2: D or E */ if(obs1 + obs2 == 5) return(transval[6]); /* 2,3: B0 */ if(obs1 + obs2 == 6) return(transval[1] + transval[3]); /* 2,4: A1 or B0 */ return(transval[6] + transval[3]); /* 2,5: A0 or B0 */ } case 4: /* AA or Aa for obs1 */ { if(obs1 == obs2) return(transval[0] + 2 * transval[1] + transval[3]); /* 4,4: 1 or 2 */ break; } case 5: /* Aa or aa for obs1 */ { if(obs1 == obs2) return(transval[3] + 2 * transval[6] + transval[5]); /* 5,5: 2 or 3 */ } } return(transval[1] + transval[2] + transval[3] + transval[6]); /* 4,5: 1 or 2 x 2 or 3 */ } /* end of assign functions */ /* init, emit and step when genotype known, phase unknown geno = 1,2,3 for AA,Aa,aa */ double init_bcsft(int true_gen, int *cross_scheme) { static double init1 = 0; static double init2 = 0; static double init3 = 0; static int s = -1; static int t = -1; if(s != cross_scheme[0] || t != cross_scheme[1] || init1 == 0) { s = cross_scheme[0]; t = cross_scheme[1]; /* static variables used frequently */ if(s == 0) { /* Ft */ init2 = (1 - t) * M_LN2; /* Aa: log(2 ^ (1-t)) */ init1 = log1p(-exp(init2)) - M_LN2; /* AA: log((1 - 2^(1-t)) / 2) */ init3 = init1; /* aa: */ } if(s > 0) { if(t == 0) { /* BCs */ init2 = -s * M_LN2; /* Aa: log(2 ^ -s) */ init1 = log1p(-exp(init2)); /* AA: log(1 - 2^-s) */ } if(t > 0) { /* BCsFt */ double sm2,tm2; sm2 = -s * M_LN2; tm2 = -t * M_LN2; init2 = sm2 + tm2; /* Aa: log(2 ^ -(s+t)) */ init3 = sm2 + log1p(-exp(tm2)) - M_LN2; /* aa: log(2^-s * (1 - 2^-t) / 2) */ init1 = log1p(exp(init3) - exp(sm2)); /* AA: log((1 - 2^-s) + 2^-s * (1 - 2^-t)) */ } } } switch(true_gen) { case 1: return(init1); case 2: return(init2); case 3: return(init3); } return(0.0); /* should not get here */ } void genotab_em_bcsft(int *cross_scheme, double *ret) { /* used by genotab.em */ ret[0] = exp(init_bcsft(1, cross_scheme)); ret[1] = exp(init_bcsft(2, cross_scheme)); ret[2] = exp(init_bcsft(3, cross_scheme)); ret[3] = ret[0] + ret[1]; ret[4] = ret[1] + ret[2]; return; } double emit_bcsft(int obs_gen, int true_gen, double error_prob, int *cross_scheme) { if(cross_scheme[1] > 0) return(emit_f2(obs_gen, true_gen, error_prob,cross_scheme)); return(emit_bc(obs_gen, true_gen, error_prob,cross_scheme)); } double step_bcsft(int gen1, int gen2, double rf, double junk, int *cross_scheme) { static double transpr[10]; static double oldrf = -1.0; static int s = -1; static int t = -1; if(s != cross_scheme[0] || t != cross_scheme[1] || fabs(rf - oldrf) > TOL) { s = cross_scheme[0]; t = cross_scheme[1]; oldrf = rf; if(rf < TOL) rf = TOL; prob_bcsft(rf, s, t, transpr); /* collapse when phase is unknown */ if(t > 0) { /* only if Ft in play */ transpr[3] += transpr[4]; /* D or E */ } /* put probabilities on log scale */ int k; for(k=0; k<7; k++) { /* if(transpr[k] > 0.0) */ transpr[k] = log(transpr[k]); } } double out; /* Find joint probability pr(gen1,gen2). */ out = assign_bcsft(gen1, gen2, transpr); /* Divide by marginal prob to get pr(gen2|gen1). */ out -= transpr[6+gen1]; return(out); } /****************************************************************************/ /* init, emit and step functions with phase-known genotypes (i.e. the 4-state chain: AA, Aa, aA, aa */ double init_bcsftb(int true_gen, int *cross_scheme) { static double init1 = 0; static double init2 = 0; static double init3 = 0; static double init4 = 0; static int s = -1; static int t = -1; /* static variables used frequently */ if(s != cross_scheme[0] || t != cross_scheme[1] || init1 == 0) { s = cross_scheme[0]; t = cross_scheme[1]; if(s == 0) { /* Ft */ init2 = - t * M_LN2; /* Aa: log(2 ^ -t) */ init1 = log1p(-exp(init2 + M_LN2)) - M_LN2; /* AA: log((1 - 2^(1-t)) / 2) */ init3 = init2; /* aA: */ init4 = init1; /* aa: */ } if(s > 0) { if(t == 0) { /* BCs */ init2 = -s * M_LN2; /* Aa: log(2 ^ -s) */ init1 = log1p(-exp(init2)); /* AA: log(1 - 2^-s) */ init3 = 0; init4 = 0; } if(t > 0) { /* BCsFt */ double sm2,t1m2; sm2 = -s * M_LN2; /* -s * log(2) = log(2 ^ -s) */ t1m2 = -(1 + t) * M_LN2; /* -2t * log(2) = log(2 ^ -(t+1)) */ init2 = sm2 + t1m2; /* Aa: log(2^-(s+t+1)) */ init3 = init2; /* aA: log(2^-(s+t+1)) */ init4 = subtrlog(sm2 - M_LN2, init2); /* aa: log(2^-(s+1) - 2^-(s+t+1)) */ init1 = addlog(log1p(-exp(sm2)), init4); /* AA: log((1-2^-s) + (2^-(s+1) - 2^-(s+t+1))) */ } } } switch(true_gen) { case 1: return(init1); case 2: return(init2); case 3: return(init3); case 4: return(init4); } return(0.0); /* should not get here */ } double emit_bcsftb(int obs_gen, int true_gen, double error_prob, int *cross_scheme) { if(cross_scheme[1] > 0) return(emit_f2b(obs_gen, true_gen, error_prob,cross_scheme)); return(emit_bc(obs_gen, true_gen, error_prob,cross_scheme)); } double step_bcsftb(int gen1, int gen2, double rf, double junk, int *cross_scheme) { static double oldrf = -1.0; static double transpr[10]; static int s = -1; static int t = -1; if(s != cross_scheme[0] || t != cross_scheme[1] || fabs(rf - oldrf) > TOL) { s = cross_scheme[0]; t = cross_scheme[1]; oldrf = rf; if(rf < TOL) rf = TOL; prob_bcsft(rf, s, t, transpr); /* expand when phase is known */ if(t > 0) { /* only if Ft in play */ transpr[1] /= 2.0; /* B1 split */ transpr[6] /= 2.0; /* B0 split */ transpr[3] /= 2.0; /* D split */ transpr[4] /= 2.0; /* E split */ transpr[8] -= M_LN2; /* log(pr(gen1=2)) = log(pr(gen2=3)) */ } /* put probabilities on log scale */ int k; for(k=0; k<7; k++) { /* if(transpr[k] > 0.0) */ transpr[k] = log(transpr[k]); } } double out; /* Find joint probability pr(gen1,gen2). */ out = assign_bcsftb(gen1, gen2, transpr); /* Divide by marginal prob to get pr(gen2|gen1). */ if(gen1 > 2) gen1--; out -= transpr[6+gen1]; return(out); } double nrec_bcsftb(int gen1, int gen2, double rf, int *cross_scheme) { static double oldrf = -1.0; static double transexp[10]; static int s = -1; static int t = -1; if(s != cross_scheme[0] || t != cross_scheme[1] || fabs(rf - oldrf) > TOL) { s = cross_scheme[0]; t = cross_scheme[1]; oldrf = rf; if(rf < TOL) rf = TOL; expect_bcsft(rf, s, t, transexp); /* reduce by half if t>0 *** NOT SURE IF THIS IS RIGHT THING TO DO? */ if(t > 0) { int k; for(k=0; k<7; k++) transexp[k] /= 2; } } /* Return expected count. */ return(assign_bcsftb(gen1, gen2, transexp)); } /* compute log likelihood for golden section search */ double assign_bcsftd(int n_gen, int obs1, int obs2, double *transval) { if(n_gen == 5) return(assign_bcsftc(obs1, obs2, transval)); return(assign_bcsftb(obs1, obs2, transval)); } double comploglik_bcsft(double rf, int n_gen, double *countmat, int *cross_scheme) { static double transpr[10]; static double probmat[15]; static double oldrf = -1.0; static int s = -1; static int t = -1; int obs1,obs2,tmp1; if(s != cross_scheme[0] || t != cross_scheme[1] || fabs(rf - oldrf) > TOL) { s = cross_scheme[0]; t = cross_scheme[1]; oldrf = rf; if(rf < TOL) rf = TOL; /* compute probabilities */ prob_bcsft(rf, s, t, transpr); transpr[3] += transpr[4]; for(obs2=1; obs2<=n_gen; obs2++) { tmp1 = ((obs2 * (obs2 - 1)) / 2) - 1; for(obs1=1; obs1<=obs2; obs1++) probmat[obs1 + tmp1] = assign_bcsftd(n_gen, obs1, obs2, transpr); } } double lod,temp; /* compute log likelihood */ lod = 0.0; for(obs2=1; obs2<=n_gen; obs2++) { tmp1 = ((obs2 * (obs2 - 1)) / 2) - 1; for(obs1=1; obs1<=obs2; obs1++) { temp = countmat[obs1 + tmp1]; if(temp > 0.0) lod += temp * log(probmat[obs1 + tmp1]); } } return(lod); } /****************************************************************************/ void calc_genoprobo_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { /* cross_scheme is hidden in genoprob */ int n_gen; n_gen = 2; if(genoprob[1] > 0) n_gen = 3; calc_genoprob(*n_ind, *n_mar, n_gen, geno, rf, rf, *error_prob, genoprob, init_bcsft, emit_bcsft, step_bcsft); } void calc_genoprob_bcsft(int *n_ind, int *n_mar, int *geno, double *rf, double *error_prob, double *genoprob) { double **alpha, **beta, **probmat; int **Geno; double ***Genoprob; int i, cross_scheme[2]; /* cross scheme hidden in genoprob argument; used by hmm_bcsft */ cross_scheme[0] = (int)genoprob[0]; cross_scheme[1] = (int)genoprob[1]; genoprob[0] = 0.0; genoprob[1] = 0.0; int n_gen,j,v,sgeno; double temp; n_gen = 2; if(cross_scheme[1] > 0) n_gen = 3; /* allocate space for alpha and beta and reorganize geno and genoprob */ reorg_geno(*n_ind, *n_mar, geno, &Geno); reorg_genoprob(*n_ind, *n_mar, n_gen, genoprob, &Genoprob); allocate_alpha(*n_mar, n_gen, &alpha); allocate_alpha(*n_mar, n_gen, &beta); allocate_dmatrix(*n_mar, 6, &probmat); /* initialize stepf calculations */ init_stepf(rf, rf, n_gen, *n_mar, cross_scheme, step_bcsft, probmat); for(i=0; i<*n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ sgeno = 0; for(j=0; j<*n_mar; j++) sgeno += Geno[j][i]; if(sgeno > 0) { /* forward-backward equations */ forward_prob(i, *n_mar, n_gen, -1, cross_scheme, *error_prob, Geno, probmat, alpha, init_bcsft, emit_bcsft); backward_prob(i, *n_mar, n_gen, -1, cross_scheme, *error_prob, Geno, probmat, beta, init_bcsft, emit_bcsft); /* calculate genotype probabilities */ calc_probfb(i, *n_mar, n_gen, -1, alpha, beta, Genoprob); } else { /* chromosome with no genotypes for this individual get init probabilities */ for(v=0; v